phoros.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011 Bert Burgemeister
   3 ;;;
   4 ;;; This program is free software; you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation; either version 2 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License along
  15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
  16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17
  18 (in-package :phoros)
  19
  20 (setf *js-target-version* 1.8)
  21
  22 ;;; Debug helpers.  TODO: remove them.
  23 (defparameter *t* nil)
  24 (defparameter *tt* nil)
  25
  26 (cffi:define-foreign-library phoml
  27   (:unix (:or "./libphoml.so"
  28               "./phoml/lib/libphoml.so"))
  29   (t (:default "libphoml")))
  30
  31 (defparameter *standard-coordinates* 4326
  32   "EPSG code of the coordinate system that we use for communication.")
  33
  34 (defparameter *spherical-mercator* 900913
  35   "EPSG code of the coordinate system used for some distance calculations.")
  36
  37 (defvar *postgresql-credentials* nil
  38   "A list: (database user password host &key (port 5432) use-ssl).")
  39
  40 (defvar *postgresql-aux-credentials* nil
  41   "A list: (database user password host &key (port 5432) use-ssl).")
  42
  43 (defparameter *photogrammetry-mutex* (bt:make-lock "photogrammetry"))
  44
  45 (setf *read-default-float-format* 'double-float)
  46
  47 (defparameter *phoros-server* nil "Hunchentoot acceptor.")
  48
  49 (defparameter *common-root* nil
  50   "Root directory; contains directories of measuring data.")
  51
  52 (defparameter *login-intro* nil
  53   "A few friendly words to be shown below the login form.")
  54
  55 (defparameter *postgresql-warnings* nil
  56   "If t, show PostgreSQL's WARNINGs and NOTICEs.")
  57
  58 (defparameter *render-footprints-p* nil
  59   "If t, put image footprints into images on client.")
  60
  61 (defparameter *use-multi-file-openlayers* nil
  62   "If t, use OpenLayers uncompiled from openlayers/*, which makes
  63   debugging easier.  Otherwise use a single-file shrunk
  64   ol/Openlayers.js.")
  65
  66 (defparameter *number-of-images* 4
  67   "Number of photos shown to the HTTP client.")
  68
  69 (defparameter *number-of-features-per-layer* 500
  70   "What we think a browser can swallow.")
  71
  72 (defparameter *number-of-points-per-aux-linestring* 500
  73   "What we think a browser can swallow.")
  74
  75 (defparameter *user-point-creation-date-format* "IYYY-MM-DD HH24:MI:SS TZ"
  76   "SQL date format used for display and GeoJSON export of user points.")
  77
  78 (defun phoros-version (&key major minor revision)
  79   "Return version of this program, either one integer part as denoted by
  80 the key argument, or the whole dotted string."
  81   (let* ((version-string
  82           (handler-bind ((warning #'ignore-warnings))
  83             (asdf:component-version (asdf:find-system :phoros))))
  84          (version-components
  85           (mapcar #'parse-integer
  86                   (cl-utilities:split-sequence #\. version-string))))
  87     (cond (major (first version-components))
  88           (minor (second version-components))
  89           (revision (third version-components))
  90           (t version-string))))
  91
  92 (defun check-dependencies ()
  93   "Say OK if the necessary external dependencies are available."
  94   (handler-case
  95       (progn
  96         (geographic-to-utm 33 13 52)    ;check cs2cs
  97         (phoros-photogrammetry:del-all) ;check photogrammetry
  98         (initialize-leap-seconds)    ;check source of leap second info
  99         (format *error-output* "~&OK~%"))
 100     (error (e) (format *error-output* "~A~&" e))))
 101
 102 (defun muffle-postgresql-warnings ()
 103   "For current DB, silence PostgreSQL's warnings about implicitly
 104 created stuff."
 105   (unless *postgresql-warnings*
 106     (execute "SET client_min_messages TO ERROR;")))
 107
 108 (defun check-db (db-credentials)
 109   "Check postgresql connection.  Return t if successful; show error on
 110 *error-output* otherwise.  db-credentials is a list like so: (database
 111 user password host &key (port 5432) use-ssl)."
 112   (let (connection)
 113     (handler-case
 114         (setf connection (apply #'connect db-credentials))
 115       (error (e) (format *error-output* "Database connection ~S failed: ~A~&"
 116                          db-credentials e)))
 117     (when connection
 118       (disconnect connection)
 119       t)))
 120
 121 (defun ignore-warnings (c) (declare (ignore c)) (muffle-warning))
 122
 123 (defmethod hunchentoot:session-cookie-name (acceptor)
 124   (declare (ignore acceptor))
 125   "phoros-session")
 126
 127 (defun start-server (&key (http-port 8080) address (common-root "/"))
 128   "Start the presentation project server which listens on http-port
 129 at address.  Address defaults to all addresses of the local machine."
 130   (setf *phoros-server*
 131         (make-instance 'hunchentoot:acceptor
 132                        :port http-port
 133                        :address address
 134                        :access-logger #'log-http-access
 135                        :message-logger #'log-hunchentoot-message))
 136   (setf hunchentoot:*session-max-time* (* 3600 24))
 137   (setf *common-root* common-root)
 138   (check-db *postgresql-credentials*)
 139   (with-connection *postgresql-credentials*
 140     (assert-phoros-db-major-version))
 141   (hunchentoot:reset-session-secret)
 142   (hunchentoot:start *phoros-server*))
 143
 144 (defun stop-server () (hunchentoot:stop *phoros-server*))
 145
 146 (eval-when (:compile-toplevel :load-toplevel :execute)
 147   (register-sql-operators :2+-ary :&& :overlaps))
 148
 149 (setf hunchentoot:*default-handler*
 150       #'(lambda ()
 151           "Http default response."
 152           (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+)))
 153
 154 (hunchentoot:define-easy-handler phoros-handler ()
 155   "First HTTP contact: if necessary, check credentials, establish new
 156 session."
 157   (with-connection *postgresql-credentials*
 158     (let* ((presentation-project-name
 159             (second (cl-utilities:split-sequence
 160                      #\/ (hunchentoot:script-name*) :remove-empty-subseqs t)))
 161            (presentation-project-id
 162             (ignore-errors
 163               (query
 164                (:select 'presentation-project-id
 165                         :from 'sys-presentation-project
 166                         :where (:= 'presentation-project-name
 167                                    presentation-project-name))
 168                :single))))
 169       (cond
 170         ((null presentation-project-id)
 171          (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+))
 172         ((and (equal (hunchentoot:session-value 'presentation-project-name)
 173                      presentation-project-name)
 174               (hunchentoot:session-value 'authenticated-p))
 175          (hunchentoot:redirect
 176           (format nil "/phoros/lib/view-~A" (phoros-version))
 177           :add-session-id t))
 178         (t
 179          (progn
 180            (setf (hunchentoot:session-value 'presentation-project-name)
 181                  presentation-project-name)
 182            (setf (hunchentoot:session-value 'presentation-project-id)
 183                  presentation-project-id)
 184            (setf (hunchentoot:session-value 'presentation-project-bbox)
 185                  (let ((bbox
 186                         (ignore-errors
 187                           (bounding-box (get-dao 'sys-presentation-project
 188                                                  presentation-project-name)))))
 189                    (if (or (null bbox) (eq :null bbox))
 190                        nil
 191                        bbox)))
 192            (setf (hunchentoot:session-value 'aux-data-p)
 193                  (with-connection *postgresql-aux-credentials*
 194                    (view-exists-p (aux-point-view-name
 195                                    presentation-project-name))))
 196            (who:with-html-output-to-string (s nil :prologue t :indent t)
 197              (:body
 198               :style "font-family:sans-serif;"
 199               (:form
 200                :method "post" :enctype "multipart/form-data"
 201                :action "/phoros/lib/authenticate" :name "login-form"
 202                (:fieldset
 203                 (:legend (:b (:a :href "http://phoros.berlios.de"
 204                                  :style "text-decoration:none;"
 205                                  "Phoros")
 206                              (who:fmt "&nbsp;[~A]" presentation-project-name)))
 207                 (:noscript
 208                  (:b (:em "You can't do much without JavaScript there.")))
 209                 (:p "User:"
 210                     :br
 211                     (:input :type "text" :name "user-name"))
 212                 (:p "Password:"
 213                     :br
 214                     (:input :type "password" :name "user-password")
 215                     "&nbsp;&nbsp;&nbsp;"
 216                     (:span :id "cackle"))
 217                 (:input :type "submit" :value "Submit"
 218                         :onclick (ps-inline
 219                                   (setf (chain document
 220                                                (get-element-by-id "cackle")
 221                                                inner-h-t-m-l)
 222                                         "Ok, let&#039;s see&#8230;"))))
 223                (:script :type "text/javascript"
 224                         (who:str (ps (chain document
 225                                             :login-form
 226                                             :user-name
 227                                             (focus))))))
 228               (loop
 229                  for i in *login-intro*
 230                  do (who:htm (:p (who:str i))))))))))))
 231
 232 (pushnew (hunchentoot:create-regex-dispatcher "/phoros/(?!lib/)"
 233                                               'phoros-handler)
 234          hunchentoot:*dispatch-table*)
 235
 236 (defun stored-bbox ()
 237   "Return stored bounding box for user and presentation project of
 238 current session."
 239   (with-connection *postgresql-credentials*
 240     (let ((bbox (bounding-box
 241                  (get-dao 'sys-user-role
 242                           (hunchentoot:session-value
 243                            'user-id)
 244                           (hunchentoot:session-value
 245                            'presentation-project-id)))))
 246       (if (eq :null bbox)
 247           (hunchentoot:session-value 'presentation-project-bbox)
 248           bbox))))
 249
 250 (defun stored-cursor ()
 251   "Return stored cursor position for user and presentation project of
 252 current session."
 253   (with-connection *postgresql-credentials*
 254     (let ((cursor
 255            (query
 256             (:select (:st_x 'cursor) (:st_y 'cursor)
 257                      :from 'sys-user-role
 258                      :where (:and (:= 'user-id
 259                                       (hunchentoot:session-value 'user-id))
 260                                   (:= 'presentation-project-id
 261                                       (hunchentoot:session-value
 262                                        'presentation-project-id))
 263                                   (:raw "cursor IS NOT NULL")))
 264             :list)))
 265       (when cursor
 266         (format nil "~{~F~#^,~}" cursor)))))
 267
 268
 269 (hunchentoot:define-easy-handler
 270     (authenticate-handler :uri "/phoros/lib/authenticate"
 271                           :default-request-type :post)
 272     ()
 273   "Check user credentials."
 274   (with-connection *postgresql-credentials*
 275     (let* ((user-name (hunchentoot:post-parameter "user-name"))
 276            (user-password (hunchentoot:post-parameter "user-password"))
 277            (presentation-project-id (hunchentoot:session-value
 278                                      'presentation-project-id))
 279            (user-info
 280             (when presentation-project-id
 281               (query
 282                (:select
 283                 'sys-user.user-full-name
 284                 'sys-user.user-id
 285                 'sys-user-role.user-role
 286                 :from 'sys-user-role 'sys-user
 287                 :where (:and
 288                         (:= 'presentation-project-id presentation-project-id)
 289                         (:= 'sys-user-role.user-id 'sys-user.user-id)
 290                         (:= 'user-name user-name)
 291                         (:= 'user-password user-password)))
 292                :row)))
 293            (user-full-name (first user-info))
 294            (user-id (second user-info))
 295            (user-role (third user-info)))
 296       (if user-role
 297           (progn
 298             (setf (hunchentoot:session-value 'authenticated-p) t
 299                   (hunchentoot:session-value 'user-name) user-name
 300                   (hunchentoot:session-value 'user-full-name) user-full-name
 301                   (hunchentoot:session-value 'user-id) user-id
 302                   (hunchentoot:session-value 'user-role) user-role)
 303             (hunchentoot:redirect (format nil "/phoros/lib/view-~A"
 304                                           (phoros-version))
 305                                   :add-session-id t))
 306           (who:with-html-output-to-string (s nil :prologue t :indent t)
 307             (:body
 308              :style "font-family:sans-serif;"
 309              (:b "Rejected. ")
 310              (:a :href (format nil "/phoros/~A/" (hunchentoot:session-value
 311                                                   'presentation-project-name))
 312                  "Retry?")))))))
 313
 314 (hunchentoot:define-easy-handler logout-handler (bbox longitude latitude)
 315   (if (hunchentoot:session-value 'authenticated-p)
 316       (with-connection *postgresql-credentials*
 317         (let ((presentation-project-name
 318                (hunchentoot:session-value 'presentation-project-name))
 319               (sys-user-role
 320                (get-dao 'sys-user-role
 321                         (hunchentoot:session-value 'user-id)
 322                         (hunchentoot:session-value 'presentation-project-id))))
 323           (when sys-user-role
 324             (when bbox
 325               (setf (bounding-box sys-user-role) bbox))
 326             (when (and longitude latitude)
 327               (let* ;; gkludge: should be done by some library, not by DB query
 328                   ((point-form (format nil "POINT(~F ~F)" longitude latitude))
 329                    (point-wkb (query (:select
 330                                       (:st_geomfromtext point-form))
 331                                      :single)))
 332                 (setf (cursor sys-user-role) point-wkb)))
 333             (update-dao sys-user-role))
 334           (hunchentoot:remove-session hunchentoot:*session*)
 335           (who:with-html-output-to-string (s nil :prologue t :indent t)
 336             (:html
 337              (:head
 338               (:title (who:str
 339                        (concatenate
 340                         'string
 341                         "Phoros: logged out" )))
 342               (:link :rel "stylesheet"
 343                      :href (format nil "/phoros/lib/css-~A/style.css"
 344                                    (phoros-version))
 345                      :type "text/css"))
 346              (:body
 347               (:h1 :id "title" "Phoros: logged out")
 348               (:p "Log back in to project "
 349                   (:a :href (format nil "/phoros/~A" presentation-project-name)
 350                       (who:fmt "~A." presentation-project-name))))))))
 351       "Bye (again)."))
 352
 353 (pushnew (hunchentoot:create-regex-dispatcher "/logout" 'logout-handler)
 354          hunchentoot:*dispatch-table*)
 355
 356 (define-condition superseded () ()
 357   (:documentation
 358    "Tell a thread to finish as soon as possible taking any shortcuts
 359    available."))
 360
 361 (hunchentoot:define-easy-handler
 362     (local-data :uri "/phoros/lib/local-data" :default-request-type :post)
 363     ()
 364   "Receive coordinates, respond with the count nearest json objects
 365 containing picture url, calibration parameters, and car position,
 366 wrapped in an array.  Wipe away any unfinished business first."
 367   (when (hunchentoot:session-value 'authenticated-p)
 368     (dolist (old-thread (hunchentoot:session-value 'recent-threads))
 369       (ignore-errors (bt:interrupt-thread old-thread #'(lambda () (signal 'superseded)))))
 370     (setf (hunchentoot:session-value 'recent-threads) nil)
 371     (push (bt:current-thread) (hunchentoot:session-value 'recent-threads))
 372     (setf (hunchentoot:content-type*) "application/json")
 373     (with-connection *postgresql-credentials*
 374       (let* ((presentation-project-id (hunchentoot:session-value
 375                                        'presentation-project-id))
 376              (common-table-names (common-table-names
 377                                   presentation-project-id))
 378              (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
 379              (longitude (cdr (assoc :longitude data)))
 380              (latitude (cdr (assoc :latitude data)))
 381              (count (cdr (assoc :count data)))
 382              (zoom (cdr (assoc :zoom data)))
 383              (snap-distance (* 1d-4 (expt 2 (- 22 zoom)))) ; assuming geographic coordinates
 384              (point-form (format nil "POINT(~F ~F)" longitude latitude))
 385              (result
 386               (handler-case
 387                   (ignore-errors
 388                     (or
 389                      ;; footprint is ready
 390                      (query
 391                       (sql-compile
 392                        `(:limit
 393                          (:order-by
 394                           (:union
 395                            ,@(loop
 396                                 for common-table-name in common-table-names
 397                                 for aggregate-view-name
 398                                 = (aggregate-view-name common-table-name)
 399                                 collect
 400                                 `(:select
 401                                   (:as (:st_distance 'coordinates
 402                                                      (:st_geomfromtext
 403                                                       ,point-form
 404                                                       ,*standard-coordinates*))
 405                                        'distance)
 406                                   'usable
 407                                   'recorded-device-id      ;debug
 408                                   'device-stage-of-life-id ;debug
 409                                   'generic-device-id       ;debug
 410                                   'directory
 411                                   'filename 'byte-position 'point-id
 412                                   (:as (:not (:is-null 'footprint))
 413                                        'footprintp)
 414                                   ,(when *render-footprints-p*
 415                                          '(:as (:st_asewkt 'footprint)
 416                                            'footprint-wkt))
 417                                   'trigger-time
 418                                   ;;'coordinates   ;the search target
 419                                   'longitude 'latitude 'ellipsoid-height
 420                                   'cartesian-system
 421                                   'east-sd 'north-sd 'height-sd
 422                                   'roll 'pitch 'heading
 423                                   'roll-sd 'pitch-sd 'heading-sd
 424                                   'sensor-width-pix 'sensor-height-pix
 425                                   'pix-size
 426                                   'bayer-pattern 'color-raiser
 427                                   'mounting-angle
 428                                   'dx 'dy 'dz 'omega 'phi 'kappa
 429                                   'c 'xh 'yh 'a1 'a2 'a3 'b1 'b2 'c1 'c2 'r0
 430                                   'b-dx 'b-dy 'b-dz 'b-rotx 'b-roty 'b-rotz
 431                                   'b-ddx 'b-ddy 'b-ddz
 432                                   'b-drotx 'b-droty 'b-drotz
 433                                   :from
 434                                   ',aggregate-view-name
 435                                   :where
 436                                   (:and
 437                                    (:= 'presentation-project-id
 438                                        ,presentation-project-id)
 439                                    (:st_contains
 440                                     'footprint
 441                                     (:limit
 442                                      (:select
 443                                       'centroid :from
 444                                       (:as
 445                                        (:order-by
 446                                         (:union
 447                                          ,@(loop
 448                                               for common-table-name
 449                                               in common-table-names
 450                                               for aggregate-view-name
 451                                               = (aggregate-view-name
 452                                                  common-table-name)
 453                                               collect
 454                                               `(:select
 455                                                 (:as
 456                                                  (:st_distance
 457                                                   (:st_centroid 'footprint)
 458                                                   (:st_geomfromtext
 459                                                    ,point-form
 460                                                    ,*standard-coordinates*))
 461                                                  'distance)
 462                                                 (:as (:st_centroid 'footprint)
 463                                                      'centroid)
 464                                                 :from
 465                                                 ',aggregate-view-name
 466                                                 :where
 467                                                 (:and
 468                                                  (:= 'presentation-project-id
 469                                                      ,presentation-project-id)
 470                                                  (:st_dwithin
 471                                                   'footprint
 472                                                   (:st_geomfromtext
 473                                                    ,point-form
 474                                                    ,*standard-coordinates*)
 475                                                   ,snap-distance)))))
 476                                         'distance)
 477                                        'centroids))
 478                                      1))))))
 479                           'distance)
 480                          ,count))
 481                       :alists)
 482                      ;; No footprint yet
 483                      (query
 484                       (sql-compile
 485                        `(:limit
 486                          (:order-by
 487                           (:union
 488                            ,@(loop
 489                                 for common-table-name in common-table-names
 490                                 for aggregate-view-name
 491                                 = (aggregate-view-name common-table-name)
 492                                 collect
 493                                 `(:select
 494                                   (:as (:st_distance 'coordinates
 495                                                      (:st_geomfromtext
 496                                                       ,point-form
 497                                                       ,*standard-coordinates*))
 498                                        'distance)
 499                                   'usable
 500                                   'recorded-device-id     ;debug
 501                                   'device-stage-of-life-id ;debug
 502                                   'generic-device-id       ;debug
 503                                   'directory
 504                                   'filename 'byte-position 'point-id
 505                                   (:as (:not (:is-null 'footprint))
 506                                        'footprintp)
 507                                   'trigger-time
 508                                   ;;'coordinates   ;the search target
 509                                   'longitude 'latitude 'ellipsoid-height
 510                                   'cartesian-system
 511                                   'east-sd 'north-sd 'height-sd
 512                                   'roll 'pitch 'heading
 513                                   'roll-sd 'pitch-sd 'heading-sd
 514                                   'sensor-width-pix 'sensor-height-pix
 515                                   'pix-size
 516                                   'bayer-pattern 'color-raiser
 517                                   'mounting-angle
 518                                   'dx 'dy 'dz 'omega 'phi 'kappa
 519                                   'c 'xh 'yh 'a1 'a2 'a3 'b1 'b2 'c1 'c2 'r0
 520                                   'b-dx 'b-dy 'b-dz 'b-rotx 'b-roty 'b-rotz
 521                                   'b-ddx 'b-ddy 'b-ddz
 522                                   'b-drotx 'b-droty 'b-drotz
 523                                   :from
 524                                   ',aggregate-view-name
 525                                   :where
 526                                   (:and (:= 'presentation-project-id
 527                                             ,presentation-project-id)
 528                                         (:st_dwithin 'coordinates
 529                                                      (:st_geomfromtext
 530                                                       ,point-form
 531                                                       ,*standard-coordinates*)
 532                                                      ,snap-distance)))))
 533                           'distance)
 534                          ,count))
 535                       :alists)))
 536                 (superseded () nil))))
 537         (when *render-footprints-p*
 538           (setf
 539            result
 540            (loop
 541               for photo-parameter-set in result
 542               for footprint-vertices =  ;something like this:
 543                 ;; "SRID=4326;POLYGON((14.334342229 51.723293508 118.492667334,14.334386877 51.723294417 118.404764286,14.334347429 51.72327914 118.506316418,14.334383211 51.723279895 118.435823396,14.334342229 51.723293508 118.492667334))"
 544                 (ignore-errors          ;probably no :footprint-wkt
 545                   (mapcar (lambda (p)
 546                           (mapcar (lambda (x)
 547                                     (parse-number:parse-real-number x))
 548                                   (cl-utilities:split-sequence #\Space p)))
 549                         (subseq
 550                          (cl-utilities:split-sequence-if
 551                           (lambda (x)
 552                             (or (eq x #\,)
 553                                 (eq x #\()
 554                                 (eq x #\))))
 555                           (cdr (assoc :footprint-wkt photo-parameter-set)))
 556                          2 7)))
 557               collect
 558                 (if footprint-vertices
 559                     (acons :rendered-footprint
 560                            (pairlis
 561                             '(:type :coordinates)
 562                             (list
 563                              :line-string
 564                              (loop
 565                                 for footprint-vertex in footprint-vertices
 566                                 for reprojected-vertex =
 567                                 (photogrammetry
 568                                  :reprojection
 569                                  ;; KLUDGE: translate keys, e.g. a1 -> a_1
 570                                  (json:decode-json-from-string
 571                                   (json:encode-json-to-string photo-parameter-set))
 572                                  (pairlis '(:x-global :y-global :z-global)
 573                                           (proj:cs2cs
 574                                            (list
 575                                             (proj:degrees-to-radians
 576                                              (first footprint-vertex))
 577                                             (proj:degrees-to-radians
 578                                              (second footprint-vertex))
 579                                             (third footprint-vertex))
 580                                            :destination-cs
 581                                            (cdr (assoc :cartesian-system
 582                                                        photo-parameter-set)))))
 583                                 collect
 584                                 (list (cdr (assoc :m reprojected-vertex))
 585                                       (cdr (assoc :n reprojected-vertex))))))
 586                            photo-parameter-set)
 587                     photo-parameter-set))))
 588         (json:encode-json-to-string result)))))
 589
 590 (hunchentoot:define-easy-handler
 591     (store-point :uri "/phoros/lib/store-point" :default-request-type :post)
 592     ()
 593   "Receive point sent by user; store it into database."
 594   (when (hunchentoot:session-value 'authenticated-p)
 595     (let* ((presentation-project-name (hunchentoot:session-value
 596                                        'presentation-project-name))
 597            (user-id (hunchentoot:session-value 'user-id))
 598            (user-role (hunchentoot:session-value 'user-role))
 599            (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
 600            (longitude (cdr (assoc :longitude data)))
 601            (latitude (cdr (assoc :latitude data)))
 602            (ellipsoid-height (cdr (assoc :ellipsoid-height data)))
 603            (stdx-global (cdr (assoc :stdx-global data)))
 604            (stdy-global (cdr (assoc :stdy-global data)))
 605            (stdz-global (cdr (assoc :stdz-global data)))
 606            (input-size (cdr (assoc :input-size data)))
 607            (attribute (cdr (assoc :attribute data)))
 608            (description (cdr (assoc :description data)))
 609            (numeric-description (cdr (assoc :numeric-description data)))
 610            (point-form
 611             (format nil "SRID=4326; POINT(~S ~S ~S)"
 612                     longitude latitude ellipsoid-height))
 613            (aux-numeric-raw (cdr (assoc :aux-numeric data)))
 614            (aux-text-raw (cdr (assoc :aux-text data)))
 615            (aux-numeric (if aux-numeric-raw
 616                             (apply #'vector aux-numeric-raw)
 617                             :null))
 618            (aux-text (if aux-text-raw
 619                          (apply #'vector aux-text-raw)
 620                          :null))
 621            (user-point-table-name
 622             (user-point-table-name presentation-project-name)))
 623       (assert
 624        (not (string-equal user-role "read")) ;that is, "write" or "admin"
 625        () "No write permission.")
 626       (with-connection *postgresql-credentials*
 627         (assert
 628          (= 1 (execute (:insert-into user-point-table-name :set
 629                                      'user-id user-id
 630                                      'attribute attribute
 631                                      'description description
 632                                      'numeric-description numeric-description
 633                                      'creation-date 'current-timestamp
 634                                      'coordinates (:st_geomfromewkt point-form)
 635                                      'stdx-global stdx-global
 636                                      'stdy-global stdy-global
 637                                      'stdz-global stdz-global
 638                                      'input-size input-size
 639                                      'aux-numeric aux-numeric
 640                                      'aux-text aux-text)))
 641          () "No point stored.  This should not happen.")))))
 642
 643 (hunchentoot:define-easy-handler
 644     (update-point :uri "/phoros/lib/update-point" :default-request-type :post)
 645     ()
 646   "Update point sent by user in database."
 647   (when (hunchentoot:session-value 'authenticated-p)
 648     (let* ((presentation-project-name (hunchentoot:session-value
 649                                        'presentation-project-name))
 650            (user-id (hunchentoot:session-value 'user-id))
 651            (user-role (hunchentoot:session-value 'user-role))
 652            (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
 653            (user-point-id (cdr (assoc :user-point-id data)))
 654            (attribute (cdr (assoc :attribute data)))
 655            (description (cdr (assoc :description data)))
 656            (numeric-description (cdr (assoc :numeric-description data)))
 657            (user-point-table-name
 658             (user-point-table-name presentation-project-name)))
 659       (assert
 660        (not (string-equal user-role "read")) ;that is, "write" or "admin"
 661        () "No write permission.")
 662       (with-connection *postgresql-credentials*
 663         (assert
 664          (= 1 (execute
 665                (:update user-point-table-name :set
 666                         'user-id user-id
 667                         'attribute attribute
 668                         'description description
 669                         'numeric-description numeric-description
 670                         'creation-date 'current-timestamp
 671                         :where (:and (:= 'user-point-id user-point-id)
 672                                      (:or (:= (if (string-equal user-role
 673                                                                 "admin")
 674                                                   user-id
 675                                                   'user-id)
 676                                               user-id)
 677                                           (:is-null 'user-id)
 678                                           (:exists
 679                                            (:select 'user-name
 680                                                     :from 'sys-user
 681                                                     :where (:= 'user-id
 682                                                                user-id))))))))
 683          () "No point stored.  Did you try to update someone else's point ~
 684              without having admin permission?")))))
 685
 686 (hunchentoot:define-easy-handler
 687     (delete-point :uri "/phoros/lib/delete-point" :default-request-type :post)
 688     ()
 689   "Delete user point if user is allowed to do so."
 690   (when (hunchentoot:session-value 'authenticated-p)
 691     (let* ((presentation-project-name (hunchentoot:session-value
 692                                        'presentation-project-name))
 693            (user-id (hunchentoot:session-value 'user-id))
 694            (user-role (hunchentoot:session-value 'user-role))
 695            (user-point-table-name
 696             (user-point-table-name presentation-project-name))
 697            (data (json:decode-json-from-string (hunchentoot:raw-post-data))))
 698       (with-connection *postgresql-credentials*
 699         (assert
 700          (eql 1 (cond ((string-equal user-role "admin")
 701                      (execute (:delete-from user-point-table-name
 702                                             :where (:= 'user-point-id data))))
 703                     ((string-equal user-role "write")
 704                      (execute
 705                       (:delete-from
 706                        user-point-table-name
 707                        :where (:and
 708                                (:= 'user-point-id data)
 709                                (:or (:= 'user-id user-id)
 710                                     (:is-null 'user-id)
 711                                     (:exists
 712                                      (:select 'user-name
 713                                               :from 'sys-user
 714                                               :where (:= 'user-id
 715                                                          user-id))))))))))
 716             () "No point deleted.  This should not happen.")))))
 717
 718 (defun common-table-names (presentation-project-id)
 719   "Return a list of common-table-names of table sets that contain data
 720 of presentation project with presentation-project-id."
 721   (handler-case
 722       (query
 723        (:select 'common-table-name
 724                 :distinct
 725                 :from 'sys-presentation 'sys-measurement 'sys-acquisition-project
 726                 :where (:and
 727                         (:= 'sys-presentation.presentation-project-id
 728                             presentation-project-id)
 729                         (:= 'sys-presentation.measurement-id
 730                             'sys-measurement.measurement-id)
 731                         (:= 'sys-measurement.acquisition-project-id
 732                             'sys-acquisition-project.acquisition-project-id)))
 733        :column)
 734     (condition (c)
 735       (cl-log:log-message
 736        :error
 737        "While fetching common-table-names of presentation-project-id ~D: ~A"
 738        presentation-project-id c))))
 739
 740 (defun encode-geojson-to-string (features &key junk-keys)
 741   "Encode a list of property lists into a GeoJSON FeatureCollection.
 742 Each property list must contain keys for coordinates, :x, :y, :z; it
 743 may contain a numeric point :id and zero or more pieces of extra
 744 information.  The extra information is stored as GeoJSON Feature
 745 properties.  Exclude property list elements with keys that are in
 746 junk-keys."
 747   (with-output-to-string (s)
 748     (json:with-object (s)
 749       (json:encode-object-member :type :*feature-collection s)
 750       (json:as-object-member (:features s)
 751         (json:with-array (s)
 752           (mapcar
 753            #'(lambda (point-with-properties)
 754                (dolist (junk-key junk-keys)
 755                  (remf point-with-properties junk-key))
 756                (destructuring-bind (&key x y z id &allow-other-keys) ;TODO: z probably bogus
 757                    point-with-properties
 758                  (json:as-array-member (s)
 759                    (json:with-object (s)
 760                      (json:encode-object-member :type :*feature s)
 761                      (json:as-object-member (:geometry s)
 762                        (json:with-object (s)
 763                          (json:encode-object-member :type :*point s)
 764                          (json:as-object-member (:coordinates s)
 765                            (json:encode-json (list x y z) s))))
 766                      (json:encode-object-member :id id s)
 767                      (json:as-object-member (:properties s)
 768                        (dolist (key '(:x :y :z :id))
 769                          (remf point-with-properties key))
 770                        (json:encode-json-plist point-with-properties s))))))
 771            features)))
 772       (json:encode-object-member :phoros-version (phoros-version) s))))
 773
 774 (defun box3d (bbox)
 775   "Return a WKT-compliant BOX3D string from string bbox."
 776   (concatenate 'string "BOX3D("
 777                (substitute #\Space #\,
 778                            (substitute #\Space #\, bbox :count 1)
 779                            :from-end t :count 1)
 780                ")"))
 781
 782 (hunchentoot:define-easy-handler (points :uri "/phoros/lib/points.json") (bbox)
 783   "Send a bunch of GeoJSON-encoded points from inside bbox to client."
 784   (when (hunchentoot:session-value 'authenticated-p)
 785     (setf (hunchentoot:content-type*) "application/json")
 786     (handler-case
 787         (with-connection *postgresql-credentials*
 788           (let* ((presentation-project-id
 789                   (hunchentoot:session-value 'presentation-project-id))
 790                  (common-table-names
 791                   (common-table-names presentation-project-id)))
 792             (encode-geojson-to-string
 793              (query
 794               (sql-compile
 795                `(:limit
 796                  (:order-by
 797                   (:union
 798                    ,@(loop
 799                         for common-table-name in common-table-names
 800                         for aggregate-view-name
 801                         = (point-data-table-name common-table-name)
 802                         ;; would have been nice, was too slow:
 803                         ;; = (aggregate-view-name common-table-name)
 804                         collect
 805                         `(:select
 806                           (:as (:st_x 'coordinates) x)
 807                           (:as (:st_y 'coordinates) y)
 808                           (:as (:st_z 'coordinates) z)
 809                           (:as 'point-id 'id) ;becomes fid on client
 810                           'random
 811                           :distinct-on 'random
 812                           :from ',aggregate-view-name
 813                           :natural :left-join 'sys-presentation
 814                           :where
 815                           (:and
 816                            (:= 'presentation-project-id
 817                                ,presentation-project-id)
 818                            (:&&
 819                             'coordinates
 820                             (:st_setsrid  (:type ,(box3d bbox) box3d)
 821                                           ,*standard-coordinates*))))))
 822                   random)
 823                  ,*number-of-features-per-layer*))
 824               :plists)
 825              :junk-keys '(:random))))
 826       (condition (c)
 827         (cl-log:log-message
 828          :error "While fetching points from inside bbox ~S: ~A"
 829          bbox c)))))
 830
 831 (hunchentoot:define-easy-handler (aux-points :uri "/phoros/lib/aux-points.json") (bbox)
 832   "Send a bunch of GeoJSON-encoded points from inside bbox to client."
 833   (when (hunchentoot:session-value 'authenticated-p)
 834     (setf (hunchentoot:content-type*) "application/json")
 835     (handler-case
 836         (let ((limit *number-of-features-per-layer*)
 837               (aux-view-name
 838                (aux-point-view-name (hunchentoot:session-value
 839                                      'presentation-project-name))))
 840           (encode-geojson-to-string
 841            (with-connection *postgresql-aux-credentials*
 842              (query
 843               (s-sql:sql-compile
 844                `(:limit
 845                  (:order-by
 846                   (:select
 847                    (:as (:st_x 'coordinates) 'x)
 848                    (:as (:st_y 'coordinates) 'y)
 849                    (:as (:st_z 'coordinates) 'z)
 850                    :from ,aux-view-name
 851                    :where (:&&
 852                            'coordinates
 853                            (:st_setsrid  (:type ,(box3d bbox) box3d)
 854                                          ,*standard-coordinates*)))
 855                   (:random))
 856                  ,limit))
 857               :plists))))
 858       (condition (c)
 859         (cl-log:log-message
 860          :error "While fetching aux-points from inside bbox ~S: ~A"
 861          bbox c)))))
 862
 863 (hunchentoot:define-easy-handler
 864     (aux-local-data :uri "/phoros/lib/aux-local-data"
 865                     :default-request-type :post)
 866     ()
 867   "Receive coordinates, respond with the count nearest json objects
 868 containing arrays aux-numeric, aux-text, and distance to the
 869 coordinates received, wrapped in an array."
 870   (when (hunchentoot:session-value 'authenticated-p)
 871     (setf (hunchentoot:content-type*) "application/json")
 872     (let* ((aux-view-name
 873             (aux-point-view-name (hunchentoot:session-value
 874                                   'presentation-project-name)))
 875            (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
 876            (longitude (cdr (assoc :longitude data)))
 877            (latitude (cdr (assoc :latitude data)))
 878            (count (cdr (assoc :count data)))
 879            (point-form
 880             (format nil "POINT(~F ~F)" longitude latitude))
 881            (snap-distance 1e-3) ;about 100 m, TODO: make this a defparameter
 882            (bounding-box
 883             (format nil "~A,~A,~A,~A"
 884                     (- longitude snap-distance)
 885                     (- latitude snap-distance)
 886                     (+ longitude snap-distance)
 887                     (+ latitude snap-distance))))
 888       (encode-geojson-to-string
 889        (ignore-errors
 890          (with-connection *postgresql-aux-credentials*
 891            (nsubst
 892             nil :null
 893             (query
 894              (s-sql:sql-compile
 895               `(:limit
 896                 (:order-by
 897                  (:select
 898                   (:as (:st_x 'coordinates) 'x)
 899                   (:as (:st_y 'coordinates) 'y)
 900                   (:as (:st_z 'coordinates) 'z)
 901                   aux-numeric
 902                   aux-text
 903                   (:as
 904                    (:st_distance
 905                     (:st_transform
 906                      'coordinates
 907                      ,*spherical-mercator*)
 908                     (:st_transform
 909                      (:st_geomfromtext ,point-form ,*standard-coordinates*)
 910                      ,*spherical-mercator*))
 911                    distance)
 912                   :from ',aux-view-name
 913                   :where (:&& 'coordinates
 914                               (:st_setsrid (:type
 915                                             ,(box3d bounding-box) box3d)
 916                                            ,*standard-coordinates*)))
 917                  'distance)
 918                 ,count))
 919              :plists))))))))
 920
 921 (hunchentoot:define-easy-handler
 922     (aux-local-linestring :uri "/phoros/lib/aux-local-linestring.json"
 923                           :default-request-type :post)
 924     ()
 925   "Receive longitude, latitude, radius, and step-size; respond
 926 with the a JSON object comprising the elements linestring (a WKT
 927 linestring stitched together of the nearest auxiliary points from
 928 within radius around coordinates), current-point (the point on
 929 linestring closest to coordinates), and previous-point and next-point
 930 \(points on linestring step-size before and after current-point
 931 respectively)."
 932   (when (hunchentoot:session-value 'authenticated-p)
 933     (setf (hunchentoot:content-type*) "application/json")
 934     (let* ((thread-aux-points-function-name
 935             (thread-aux-points-function-name (hunchentoot:session-value
 936                                               'presentation-project-name)))
 937            (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
 938            (longitude (cdr (assoc :longitude data)))
 939            (latitude (cdr (assoc :latitude data)))
 940            (radius (cdr (assoc :radius data)))
 941            (step-size (cdr (assoc :step-size data)))
 942            (azimuth (if (numberp (cdr (assoc :azimuth data)))
 943                         (cdr (assoc :azimuth data))
 944                         0))
 945            (point-form
 946             (format nil "POINT(~F ~F)" longitude latitude))
 947            (sql-response
 948             (ignore-errors
 949               (with-connection *postgresql-aux-credentials*
 950                 (nsubst
 951                  nil :null
 952                  (query
 953                   (sql-compile
 954                    `(:select '* :from
 955                              (,thread-aux-points-function-name
 956                               (:st_geomfromtext
 957                                ,point-form ,*standard-coordinates*)
 958                               ,radius
 959                               ,*number-of-points-per-aux-linestring*
 960                               ,step-size
 961                               ,azimuth
 962                               ,(proj:degrees-to-radians 91))))
 963                   :plist))))))
 964       (with-output-to-string (s)
 965         (json:with-object (s)
 966           (json:encode-object-member
 967            :linestring (getf sql-response :threaded-points) s)
 968           (json:encode-object-member
 969            :current-point (getf sql-response :current-point) s)
 970           (json:encode-object-member
 971            :previous-point (getf sql-response :back-point) s)
 972           (json:encode-object-member
 973            :next-point (getf sql-response :forward-point) s)
 974           (json:encode-object-member
 975            :azimuth (getf sql-response :new-azimuth) s))))))
 976
 977 (defun get-user-points (user-point-table-name &key
 978                         (bounding-box "-180,-90,180,90")
 979                         (limit :null)
 980                         (order-criterion 'id))
 981   "Return limit points from user-point-table-name in GeoJSON format,
 982 and the number of points returned."
 983   (let ((user-point-plist
 984          (query
 985           (s-sql:sql-compile
 986            `(:limit
 987              (:order-by
 988               (:select
 989                (:as (:st_x 'coordinates) 'x)
 990                (:as (:st_y 'coordinates) 'y)
 991                (:as (:st_z 'coordinates) 'z)
 992                (:as 'user-point-id 'id) ;becomes fid in OpenLayers
 993                'stdx-global 'stdy-global 'stdz-global
 994                'input-size
 995                'attribute 'description 'numeric-description
 996                'user-name
 997                (:as (:to-char 'creation-date
 998                               ,*user-point-creation-date-format*)
 999                     'creation-date)
1000                'aux-numeric 'aux-text
1001                :from ,user-point-table-name :natural :left-join 'sys-user
1002                :where (:&& 'coordinates
1003                            (:st_setsrid  (:type ,(box3d bounding-box) box3d)
1004                                          ,*standard-coordinates*)))
1005               ,order-criterion)
1006              ,limit))
1007           :plists)))
1008     (values
1009      (encode-geojson-to-string (nsubst nil :null user-point-plist))
1010      (length user-point-plist))))
1011
1012 (hunchentoot:define-easy-handler
1013     (user-points :uri "/phoros/lib/user-points.json")
1014     (bbox)
1015   "Send *number-of-features-per-layer* randomly chosen GeoJSON-encoded
1016 points from inside bbox to client.  If there is no bbox parameter,
1017 send all points."
1018   (when (hunchentoot:session-value 'authenticated-p)
1019     (setf (hunchentoot:content-type*) "application/json")
1020     (handler-case
1021         (let ((bounding-box (or bbox "-180,-90,180,90"))
1022               (limit (if bbox *number-of-features-per-layer* :null))
1023               (order-criterion (if bbox '(:random) 'id))
1024               (user-point-table-name
1025                (user-point-table-name (hunchentoot:session-value
1026                                        'presentation-project-name))))
1027           (with-connection *postgresql-credentials*
1028             (nth-value 0 (get-user-points user-point-table-name
1029                                           :bounding-box bounding-box
1030                                           :limit limit
1031                                           :order-criterion order-criterion))))
1032       (condition (c)
1033         (cl-log:log-message
1034          :error "While fetching user-points~@[ from inside bbox ~S~]: ~A"
1035          bbox c)))))
1036
1037 (hunchentoot:define-easy-handler
1038     (user-point-attributes :uri "/phoros/lib/user-point-attributes.json")
1039     ()
1040   "Send JSON object comprising arrays attributes and descriptions,
1041 each containing unique values called attribute and description
1042 respectively, and count being the frequency of value in the user point
1043 table."
1044   (when (hunchentoot:session-value 'authenticated-p)
1045     (setf (hunchentoot:content-type*) "application/json")
1046     (handler-case
1047         (let ((user-point-table-name
1048                (user-point-table-name (hunchentoot:session-value
1049                                        'presentation-project-name))))
1050           (with-connection *postgresql-credentials*
1051             (with-output-to-string (s)
1052               (json:with-object (s)
1053                 (json:as-object-member (:descriptions s)
1054                   (json:with-array (s)
1055                     (mapcar #'(lambda (x) (json:as-array-member (s)
1056                                             (json:encode-json-plist x s)))
1057                             (query
1058                              (:limit
1059                               (:order-by
1060                                (:select 'description
1061                                         (:count 'description)
1062                                         :from user-point-table-name
1063                                         :group-by 'description)
1064                                'description)
1065                               100)
1066                              :plists))))
1067                 (json:as-object-member (:attributes s)
1068                   (json:with-array (s)
1069                     (mapcar #'(lambda (x) (json:as-array-member (s)
1070                                             (json:encode-json-plist x s)))
1071                             (query (format nil "~
1072                               (SELECT attribute, count(attribute) ~
1073                                  FROM ((SELECT attribute FROM ~A) ~
1074                                        UNION ALL ~
1075                                        (SELECT attribute ~
1076                                           FROM (VALUES ('solitary'), ~
1077                                                        ('polyline'), ~
1078                                                        ('polygon')) ~
1079                                           AS defaults(attribute))) ~
1080                                         AS attributes_union(attribute) ~
1081                                  GROUP BY attribute) ~
1082                               ORDER BY attribute LIMIT 100"
1083                                            ;; Counts of solitary,
1084                                            ;; polyline, polygon may be
1085                                            ;; to big by one if we
1086                                            ;; collect them like this.
1087                            (s-sql:to-sql-name user-point-table-name))
1088                                    :plists))))))))
1089       (condition (c)
1090         (cl-log:log-message
1091          :error "While fetching user-point-attributes: ~A"
1092          c)))))
1093
1094 (hunchentoot:define-easy-handler photo-handler
1095     ((bayer-pattern :init-form "65280,16711680")
1096      (color-raiser :init-form "1,1,1")
1097      (mounting-angle :init-form "0"))
1098   "Serve an image from a .pictures file."
1099   (when (hunchentoot:session-value 'authenticated-p)
1100     (handler-case
1101         (progn
1102           (push (bt:current-thread)
1103                 (hunchentoot:session-value 'recent-threads))
1104           (let* ((s (cdr (cl-utilities:split-sequence
1105                           #\/
1106                           (hunchentoot:script-name*)
1107                           :remove-empty-subseqs t)))
1108                  (directory (last (butlast s 2)))
1109                  (file-name-and-type (cl-utilities:split-sequence
1110                                       #\. (first (last s 2))))
1111                  (byte-position (parse-integer (car (last s)) :junk-allowed t))
1112                  (path-to-file
1113                   (car
1114                    (directory
1115                     (make-pathname
1116                      :directory (append (pathname-directory *common-root*)
1117                                         directory '(:wild-inferiors))
1118                      :name (first file-name-and-type)
1119                      :type (second file-name-and-type)))))
1120                  stream)
1121             (setf (hunchentoot:header-out 'cache-control)
1122                   (format nil "max-age=~D" (* 3600 24 7)))
1123             (setf (hunchentoot:content-type*) "image/png")
1124             (setf stream (hunchentoot:send-headers))
1125             (send-png
1126              stream path-to-file byte-position
1127              :bayer-pattern
1128              (apply #'vector (mapcar
1129                               #'parse-integer
1130                               (cl-utilities:split-sequence
1131                                #\, bayer-pattern)))
1132              :color-raiser
1133              (apply #'vector (mapcar
1134                               #'parse-number:parse-positive-real-number
1135                               (cl-utilities:split-sequence  #\, color-raiser)))
1136              :reversep (= 180 (parse-integer mounting-angle)))))
1137       (superseded () nil)
1138       (condition (c)
1139         (cl-log:log-message
1140          :error "While serving image ~S: ~A" (hunchentoot:request-uri*) c)))))
1141
1142 (pushnew (hunchentoot:create-prefix-dispatcher "/phoros/lib/photo"
1143                                                'photo-handler)
1144          hunchentoot:*dispatch-table*)
1145
1146 ;;; for debugging; this is the multi-file OpenLayers
1147 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1148           "/phoros/lib/openlayers/" "OpenLayers-2.10/")
1149          hunchentoot:*dispatch-table*)
1150
1151 (pushnew (hunchentoot:create-folder-dispatcher-and-handler "/phoros/lib/ol/" "ol/")
1152          hunchentoot:*dispatch-table*)
1153
1154 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1155           (format nil "/phoros/lib/css-~A/" (phoros-version)) "css/") ;TODO: merge this style.css into public_html/style.css
1156          hunchentoot:*dispatch-table*)
1157
1158 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1159           "/phoros/lib/public_html/" "public_html/")
1160          hunchentoot:*dispatch-table*)
1161
1162 (pushnew (hunchentoot:create-static-file-dispatcher-and-handler
1163           "/favicon.ico" "public_html/favicon.ico")
1164          hunchentoot:*dispatch-table*)
1165
1166 (hunchentoot:define-easy-handler
1167     (view :uri (format nil "/phoros/lib/view-~A" (phoros-version))
1168           :default-request-type :post)
1169     ()
1170   "Serve the client their main workspace."
1171   (if
1172    (hunchentoot:session-value 'authenticated-p)
1173    (who:with-html-output-to-string (s nil :prologue t :indent t)
1174      (:html
1175       (:head
1176        (:title (who:str
1177                 (concatenate
1178                  'string
1179                  "Phoros: " (hunchentoot:session-value
1180                              'presentation-project-name))))
1181        (if *use-multi-file-openlayers*
1182            (who:htm
1183             (:script :src "/phoros/lib/openlayers/lib/Firebug/firebug.js")
1184             (:script :src "/phoros/lib/openlayers/lib/OpenLayers.js"))
1185            (who:htm (:script :src "/phoros/lib/ol/OpenLayers.js")))
1186        (:link :rel "stylesheet"
1187               :href (format nil "/phoros/lib/css-~A/style.css"
1188                             (phoros-version))
1189               :type "text/css")
1190        (:script :src (format         ;variability in script name is
1191                       nil            ; supposed to fight browser cache
1192                       "/phoros/lib/phoros-~A-~A-~A.js"
1193                       (phoros-version)
1194                       (hunchentoot:session-value 'user-name)
1195                       (hunchentoot:session-value 'presentation-project-name)))
1196        (:script :src "http://maps.google.com/maps/api/js?sensor=false"))
1197       (:body
1198        :onload (ps (init))
1199        (:noscript (:b (:em "You can't do much without JavaScript here.")))
1200        (:h1 :id "title"
1201             "Phoros: " (who:str (hunchentoot:session-value 'user-full-name))
1202             (who:fmt " (~A)" (hunchentoot:session-value 'user-name))
1203             "with " (:span :id "user-role"
1204                            (who:str (hunchentoot:session-value 'user-role)))
1205             "permission on "
1206             (:span :id "presentation-project-name"
1207                    (who:str (hunchentoot:session-value
1208                              'presentation-project-name)))
1209             (:span :id "presentation-project-emptiness")
1210             (:span :id "phoros-version" :class "h1-right"
1211                    (who:fmt "v~A" (phoros-version))))
1212        (:div :class "controlled-streetmap"
1213              (:div :id "streetmap" :class "streetmap" :style "cursor:crosshair")
1214              (:div :id "streetmap-controls" :class "streetmap-controls"
1215                    (:div :id "streetmap-vertical-strut"
1216                          :class "streetmap-vertical-strut")
1217                    (:div :id "streetmap-layer-switcher"
1218                          :class "streetmap-layer-switcher")
1219                    (:div :id "streetmap-overview" :class "streetmap-overview")
1220                    (:div :id "streetmap-mouse-position"
1221                          :class "streetmap-mouse-position")
1222                    (:div :id "streetmap-zoom" :class "streetmap-zoom")))
1223        (:div :class "phoros-controls"
1224              (:div :id "real-phoros-controls"
1225                    (:h2 (:span :id "h2-controls") (:span :id "creator"))
1226                    (:div :id "point-attribute"
1227                          :class "combobox"
1228                          (:select :id "point-attribute-select"
1229                                   :name "point-attribute-select"
1230                                   :class "combobox-select"
1231                                   :onchange
1232                                   (ps-inline
1233                                    (consolidate-combobox "point-attribute"))
1234                                   :disabled t)
1235                          (:input :id "point-attribute-input"
1236                                  :name "point-attribute-input"
1237                                  :class "combobox-input"
1238                                  :onchange (ps-inline
1239                                             (unselect-combobox-selection
1240                                              "point-attribute"))
1241                                  :disabled t
1242                                  :type "text"))
1243                    ;; (:select :id "point-attribute" :disabled t
1244                    ;;          :size 1 :name "point-attribute")
1245                    (:input :id "point-numeric-description"
1246                            :class "vanilla-input"
1247                            :disabled t
1248                            :type "text" :name "point-numeric-description")
1249
1250                    (:div :id "point-description"
1251                          :class "combobox"
1252                          (:select :id "point-description-select"
1253                                   :name "point-description-select"
1254                                   :class "combobox-select"
1255                                   :onchange (ps-inline
1256                                              (consolidate-combobox
1257                                               "point-description"))
1258                                   :disabled t)
1259                          (:input :id "point-description-input"
1260                                  :name "point-description-input"
1261                                  :class "combobox-input"
1262                                  :onchange (ps-inline
1263                                             (unselect-combobox-selection
1264                                              "point-description"))
1265                                  :disabled t
1266                                  :type "text"))
1267                    (:button :id "delete-point-button" :disabled t
1268                             :type "button"
1269                             :onclick (ps-inline (delete-point))
1270                             "delete")
1271                    (:button :disabled t :id "finish-point-button"
1272                             :type "button"
1273                             (:b "finish"))
1274                    (:div :id "aux-point-distance-or-point-creation-date"
1275                          (:code :id "point-creation-date")
1276                          (:select :id "aux-point-distance" :disabled t
1277                                   :size 1 :name "aux-point-distance"
1278                                   :onchange (ps-inline
1279                                              (aux-point-distance-selected))
1280                                   :onclick (ps-inline
1281                                             (enable-aux-point-selection)))
1282                          (:div :id "include-aux-data"
1283                                (:label
1284                                 (:input :id "include-aux-data-p"
1285                                         :class "tight-input"
1286                                         :type "checkbox" :checked t
1287                                         :name "include-aux-data-p"
1288                                         :onchange (ps-inline
1289                                                    (flip-aux-data-inclusion)))
1290                                 "aux data")))
1291                    (:div :id "aux-data"
1292                          (:div :id "aux-numeric-list")
1293                          (:div :id "aux-text-list")))
1294              (:div :id "multiple-points-phoros-controls"
1295                    (:h2 "Multiple Points Selected")
1296                    (:p "You have selected multiple user points.")
1297                    (:p "Unselect all but one to edit or view its properties."))
1298              (:div :class "walk-mode-controls"
1299                    (:div :id "walk-mode"
1300                          (:label
1301                           (:input :id "walk-p"
1302                                   :class "tight-input"
1303                                   :type "checkbox" :checked nil
1304                                   :onchange (ps-inline
1305                                              (flip-walk-mode)))
1306                           "snap+walk"))
1307                    (:div :id "decrease-step-size"
1308                          :onclick (ps-inline (decrease-step-size)))
1309                    (:div :id "step-size"
1310                          :onclick (ps-inline (increase-step-size))
1311                          "4")
1312                    (:div :id "increase-step-size"
1313                          :onclick (ps-inline (increase-step-size))
1314                          :ondblclick (ps-inline (increase-step-size)
1315                                                 (increase-step-size)))
1316                    (:div :id "step-button" :disabled nil
1317                          :onclick (ps-inline (step))
1318                          :ondblclick (ps-inline (step t))
1319                          "step"))
1320              (:div :class "image-main-controls"
1321                    (:div :id "auto-zoom"
1322                          (:label
1323                           (:input :id "zoom-to-point-p"
1324                                   :class "tight-input"
1325                                   :type "checkbox" :checked t)
1326                           "auto zoom"))
1327                    (:div :id "zoom-images-to-max-extent"
1328                          :onclick (ps-inline (zoom-images-to-max-extent)))
1329                    (:div :id "no-footprints-p"
1330                          (:b "?"))
1331                    (:div :id "remove-work-layers-button" :disabled t
1332                          :onclick (ps-inline (reset-layers-and-controls))
1333                          "start over")))
1334        (:div :class "help-div"
1335              (:button :id "download-user-points-button"
1336                       :type "button"
1337                       :onclick "self.location.href = \"/phoros/lib/user-points.json\""
1338                       "download points") ;TODO: offer other formats and maybe projections
1339              (:button :id "blurb-button"
1340                       :type "button"
1341                       :onclick (ps-inline
1342                                 (chain window
1343                                        (open
1344                                         (+ "/phoros/lib/blurb?openlayers-version="
1345                                            (@ *open-layers *version_number*))
1346                                         "About Phoros")))
1347                       (:img :src "/phoros/lib/public_html/phoros-logo-plain.png"
1348                             :alt "Phoros" :style "vertical-align:middle"
1349                             :height 20))
1350              (:button :id "logout-button"
1351                       :type "button"
1352                       :onclick (ps-inline (bye))
1353                       "bye")
1354              (:h2 :id "h2-help" "Help")
1355              (:div :id "help-display"))
1356        (:div :id "images" :style "clear:both"
1357              (loop
1358                 for i from 0 below *number-of-images* do
1359                 (who:htm
1360                  (:div :class "controlled-image"
1361                        (:div :id (format nil "image-~S-controls" i)
1362                              :class "image-controls"
1363                              (:div :id (format nil "image-~S-zoom" i)
1364                                    :class "image-zoom")
1365                              (:div :id (format nil "image-~S-layer-switcher" i)
1366                                    :class "image-layer-switcher")
1367                              (:div :id (format nil "image-~S-usable" i)
1368                                    :class "image-usable"
1369                                    (:b "!"))
1370                              (:div :id (format nil "image-~S-trigger-time" i)
1371                                    :class "image-trigger-time"))
1372                        (:div :id (format nil "image-~S" i)
1373                              :class "image" :style "cursor:crosshair"))))))))
1374    (hunchentoot:redirect
1375     (concatenate 'string "/phoros/" (hunchentoot:session-value
1376                                      'presentation-project-name))
1377     :add-session-id t)))
1378
1379 (hunchentoot:define-easy-handler
1380     (epipolar-line :uri "/phoros/lib/epipolar-line")
1381     ()
1382   "Receive vector of two sets of picture parameters, respond with
1383 JSON encoded epipolar-lines."
1384   (when (hunchentoot:session-value 'authenticated-p)
1385     (setf (hunchentoot:content-type*) "application/json")
1386     (let* ((data (json:decode-json-from-string (hunchentoot:raw-post-data))))
1387       (json:encode-json-to-string
1388        (photogrammetry :epipolar-line (first data) (second data))))))
1389
1390 (hunchentoot:define-easy-handler
1391     (estimated-positions :uri "/phoros/lib/estimated-positions")
1392     ()
1393   "Receive a two-part JSON vector comprising (1) a vector containing
1394 sets of picture-parameters with clicked (\"active\") points
1395 stored in :m, :n; and (2) a vector containing sets of
1396 picture-parameters; respond with a JSON encoded two-part vector
1397 comprising (1) a point in global coordinates; and (2) a vector of
1398 image coordinates (m, n) for the global point that correspond to the
1399 images from the received second vector.  TODO: report error on bad
1400 data (ex: points too far apart)."
1401   ;; TODO: global-point-for-display should probably contain a proj string in order to make sense of the (cartesian) standard deviations.
1402   (when (hunchentoot:session-value 'authenticated-p)
1403     (setf (hunchentoot:content-type*) "application/json")
1404     (let* ((data
1405             (json:decode-json-from-string (hunchentoot:raw-post-data)))
1406            (active-point-photo-parameters
1407             (first data))
1408            (number-of-active-points
1409             (length active-point-photo-parameters))
1410            (destination-photo-parameters
1411             (second data))
1412            (cartesian-system
1413             (cdr (assoc :cartesian-system
1414                         (first active-point-photo-parameters))))
1415            (global-point-cartesian
1416             (photogrammetry
1417              :multi-position-intersection active-point-photo-parameters))
1418            (global-point-geographic-radians
1419             (proj:cs2cs (list (cdr (assoc :x-global global-point-cartesian))
1420                               (cdr (assoc :y-global global-point-cartesian))
1421                               (cdr (assoc :z-global global-point-cartesian)))
1422                         :source-cs cartesian-system))
1423            (global-point-for-display    ;points geographic cs, degrees; std deviations in cartesian cs
1424             (pairlis '(:longitude :latitude :ellipsoid-height
1425                        :stdx-global :stdy-global :stdz-global
1426                        :input-size)
1427                      (list
1428                       (proj:radians-to-degrees
1429                        (first global-point-geographic-radians))
1430                       (proj:radians-to-degrees
1431                        (second global-point-geographic-radians))
1432                       (third global-point-geographic-radians)
1433                       (cdr (assoc :stdx-global global-point-cartesian))
1434                       (cdr (assoc :stdy-global global-point-cartesian))
1435                       (cdr (assoc :stdz-global global-point-cartesian))
1436                       number-of-active-points)))
1437            (image-coordinates
1438             (loop
1439                for i in destination-photo-parameters
1440                collect
1441                  (ignore-errors
1442                    (photogrammetry :reprojection i global-point-cartesian)))))
1443       (json:encode-json-to-string
1444         (list global-point-for-display image-coordinates)))))
1445
1446 (hunchentoot:define-easy-handler
1447     (user-point-positions :uri "/phoros/lib/user-point-positions")
1448     ()
1449   "Receive a two-part JSON vector comprising
1450 - a vector of user-point-id's and
1451 - a vector containing sets of picture-parameters;
1452 respond with a JSON object comprising the elements
1453 - image-points, a vector whose elements
1454    - correspond to the elements of the picture-parameters vector
1455      received and
1456    - are GeoJSON feature collections containing one point (in picture
1457      coordinates) for each user-point-id received;
1458 - user-point-count, the number of user-points we tried to fetch
1459   image-points for."
1460   (when (hunchentoot:session-value 'authenticated-p)
1461     (setf (hunchentoot:content-type*) "application/json")
1462     (let* ((user-point-table-name
1463             (user-point-table-name (hunchentoot:session-value
1464                                     'presentation-project-name)))
1465            (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
1466            (user-point-ids (first data))
1467            (user-point-count (length user-point-ids))
1468            (destination-photo-parameters (second data))
1469            (cartesian-system
1470             (cdr (assoc :cartesian-system
1471                         (first destination-photo-parameters)))) ;TODO: in rare cases, coordinate systems of the images shown may differ
1472            (user-points
1473             (with-connection *postgresql-credentials*
1474               (query
1475                (:select
1476                 (:as (:st_x 'coordinates) 'longitude)
1477                 (:as (:st_y 'coordinates) 'latitude)
1478                 (:as (:st_z 'coordinates) 'ellipsoid-height)
1479                 (:as 'user-point-id 'id) ;becomes fid on client
1480                 'attribute
1481                 'description
1482                 'numeric-description
1483                 'user-name
1484                 (:as (:to-char 'creation-date "IYYY-MM-DD HH24:MI:SS TZ")
1485                      'creation-date)
1486                 'aux-numeric
1487                 'aux-text
1488                 :from user-point-table-name :natural :left-join 'sys-user
1489                 :where (:in 'user-point-id (:set user-point-ids)))
1490                :plists)))
1491            (global-points-cartesian
1492             (loop
1493                for global-point-geographic in user-points
1494                collect
1495                (ignore-errors ;in case no destination-photo-parameters have been sent
1496                  (pairlis '(:x-global :y-global :z-global)
1497                           (proj:cs2cs
1498                            (list
1499                             (proj:degrees-to-radians
1500                              (getf global-point-geographic :longitude))
1501                             (proj:degrees-to-radians
1502                              (getf global-point-geographic :latitude))
1503                             (getf global-point-geographic :ellipsoid-height))
1504                            :destination-cs cartesian-system)))))
1505            (image-coordinates
1506             (loop
1507                for photo-parameter-set in destination-photo-parameters
1508                collect
1509                (encode-geojson-to-string
1510                 (loop
1511                    for global-point-cartesian in global-points-cartesian
1512                    for user-point in user-points
1513                    collect
1514                    (ignore-errors
1515                      (let ((photo-coordinates
1516                             (photogrammetry :reprojection
1517                                             photo-parameter-set
1518                                             global-point-cartesian))
1519                            (photo-point
1520                             user-point))
1521                        (setf (getf photo-point :x)
1522                              (cdr (assoc :m photo-coordinates)))
1523                        (setf (getf photo-point :y)
1524                              (cdr (assoc :n photo-coordinates)))
1525                        photo-point)))
1526                 :junk-keys '(:longitude :latitude :ellipsoid-height)))))
1527       (with-output-to-string (s)
1528         (json:with-object (s)
1529           (json:encode-object-member :user-point-count user-point-count s)
1530           (json:as-object-member (:image-points s)
1531             (json:with-array (s)
1532               (loop for i in image-coordinates do
1533                    (json:as-array-member (s) (princ i s))))))))))
1534
1535 (hunchentoot:define-easy-handler
1536     (multi-position-intersection :uri "/phoros/lib/intersection")
1537     ()
1538   "Receive vector of sets of picture parameters, respond with stuff."
1539   (when (hunchentoot:session-value 'authenticated-p)
1540     (setf (hunchentoot:content-type*) "application/json")
1541     (let* ((data (json:decode-json-from-string (hunchentoot:raw-post-data))))
1542       (json:encode-json-to-string
1543        (photogrammetry :multi-position-intersection data)))))