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 (defvar *postgresql-credentials* nil
  35   "A list: (database user password host &key (port 5432) use-ssl)")
  36
  37 (defvar *postgresql-aux-credentials* nil
  38   "A list: (database user password host &key (port 5432) use-ssl)")
  39
  40 (defparameter *photogrammetry-mutex* (bt:make-lock "photogrammetry"))
  41
  42 (setf *read-default-float-format* 'double-float)
  43
  44 (defparameter *phoros-server* nil "Hunchentoot acceptor.")
  45
  46 (defparameter *common-root* nil
  47   "Root directory; contains directories of measuring data.")
  48
  49 (defparameter *use-multi-file-openlayers* nil
  50   "If t, use OpenLayers uncompiled from openlayers/*, which makes
  51   debugging easier.  Otherwise use a single-file shrunk
  52   ol/Openlayers.js.")
  53
  54 (defparameter *number-of-images* 4
  55   "Number of photos shown to the HTTP client.")
  56
  57 (defparameter *number-of-features-per-layer* 500
  58   "What we think a browser can swallow.")
  59
  60 (defun check-db (db-credentials)
  61   "Check postgresql connection.  Return t if successful; show error on
  62 *error-output* otherwise.  db-credentials is a list like so: (database
  63 user password host &key (port 5432) use-ssl)."
  64   (let (connection)
  65     (handler-case
  66         (setf connection (apply #'connect db-credentials))
  67       (error (e) (format *error-output* "Database connection ~S failed: ~A~&"
  68                          db-credentials e)))
  69     (when connection
  70       (disconnect connection)
  71       t)))
  72
  73 (defmethod hunchentoot:session-cookie-name (acceptor)
  74   (declare (ignore acceptor))
  75   "phoros-session")
  76
  77 (defun start-server (&key (http-port 8080) address (common-root "/"))
  78   "Start the presentation project server which listens on http-port
  79 at address.  Address defaults to all addresses of the local machine."
  80   (setf *phoros-server*
  81         (make-instance 'hunchentoot:acceptor
  82                        :port http-port
  83                        :address address
  84                        :access-logger #'log-http-access
  85                        :message-logger #'log-hunchentoot-message))
  86   (setf *session-max-time* (* 3600 24))
  87   (setf *common-root* common-root)
  88   (check-db *postgresql-credentials*)
  89   (with-connection *postgresql-credentials*
  90     (assert-phoros-db-major-version))
  91   (hunchentoot:start *phoros-server*))
  92
  93 (defun stop-server () (hunchentoot:stop *phoros-server*))
  94
  95 (eval-when (:compile-toplevel :load-toplevel :execute)
  96   (register-sql-operators :2+-ary :&& :overlaps))
  97
  98 (setf *default-handler*
  99       #'(lambda ()
 100           "Http default response."
 101           (setf (return-code*) +http-not-found+)))
 102
 103 (define-easy-handler phoros-handler ()
 104   "First HTTP contact: if necessary, check credentials, establish new
 105 session."
 106   (with-connection *postgresql-credentials*
 107     (let* ((presentation-project-name
 108             (second (cl-utilities:split-sequence #\/ (script-name*) :remove-empty-subseqs t)))
 109            (presentation-project-id
 110             (ignore-errors
 111               (query
 112                (:select 'presentation-project-id
 113                         :from 'sys-presentation-project
 114                         :where (:= 'presentation-project-name presentation-project-name))
 115                :single))))
 116       (cond
 117         ((null presentation-project-id)
 118          (setf (return-code*) +http-not-found+))
 119         ((and (equal (session-value 'presentation-project-name) presentation-project-name)
 120               (session-value 'authenticated-p))
 121          (redirect "/phoros-lib/view" :add-session-id t))
 122         (t
 123          (progn
 124            (setf (session-value 'presentation-project-name)
 125                  presentation-project-name)
 126            (setf (session-value 'presentation-project-id)
 127                  presentation-project-id)
 128            (setf (session-value 'presentation-project-bbox)
 129                  (presentation-project-bbox presentation-project-id))
 130            (who:with-html-output-to-string (s nil :prologue t :indent t)
 131              (:form :method "post" :enctype "multipart/form-data"
 132                     :action "/phoros-lib/authenticate"
 133                     "User:" :br
 134                     (:input :type "text" :name "user-name") :br
 135                     "Password:" :br
 136                     (:input :type "password" :name "user-password") :br
 137                     (:input :type "submit" :value "Submit")))))))))
 138
 139 (pushnew (create-prefix-dispatcher "/phoros/" 'phoros-handler)
 140          *dispatch-table*)
 141
 142 (define-easy-handler
 143     (authenticate-handler :uri "/phoros-lib/authenticate"
 144                           :default-request-type :post)
 145     ()
 146   "Check user credentials."
 147   (with-connection *postgresql-credentials*
 148     (let* ((user-name (post-parameter "user-name"))
 149            (user-password (post-parameter "user-password"))
 150            (presentation-project-id (session-value 'presentation-project-id))
 151            (user-info
 152             (when presentation-project-id
 153               (query
 154                (:select
 155                 'sys-user.user-full-name
 156                 'sys-user.user-id
 157                 'sys-user-role.user-role
 158                 :from 'sys-user-role 'sys-user
 159                 :where (:and
 160                         (:= 'presentation-project-id presentation-project-id)
 161                         (:= 'sys-user-role.user-id 'sys-user.user-id)
 162                         (:= 'user-name user-name)
 163                         (:= 'user-password user-password)))
 164                :row)))
 165            (user-full-name (first user-info))
 166            (user-id (second user-info))
 167            (user-role (third user-info)))
 168       (if user-role
 169           (progn
 170             (setf (session-value 'authenticated-p) t
 171                   (session-value 'user-name) user-name
 172                   (session-value 'user-full-name) user-full-name
 173                   (session-value 'user-id) user-id
 174                   (session-value 'user-role) user-role)
 175             (redirect "/phoros-lib/view" :add-session-id t))
 176           "Rejected."))))
 177
 178 (define-easy-handler logout-handler ()
 179   (if (session-verify *request*)
 180       (progn (remove-session *session*)
 181              "Bye.")
 182       "Bye (again)."))
 183
 184 (pushnew (create-regex-dispatcher "/logout" 'logout-handler)
 185          *dispatch-table*)
 186
 187 (define-easy-handler
 188     (local-data :uri "/phoros-lib/local-data" :default-request-type :post)
 189     ()
 190   "Receive coordinates, respond with the count nearest json objects
 191 containing picture url, calibration parameters, and car position,
 192 wrapped in an array."
 193   (when (session-value 'authenticated-p)
 194     (setf (content-type*) "application/json")
 195     (let* ((presentation-project-id (session-value 'presentation-project-id))
 196            (common-table-names (common-table-names presentation-project-id))
 197            (data (json:decode-json-from-string (raw-post-data)))
 198            (longitude-input (cdr (assoc :longitude data)))
 199            (latitude-input (cdr (assoc :latitude data)))
 200            (count (cdr (assoc :count data)))
 201            (zoom-input (cdr (assoc :zoom data)))
 202            ;;(snap-distance (* 10d-5 (expt 2 (- 18 zoom-input)))) ; assuming geographic coordinates
 203            (snap-distance (* 10d-1 (expt 2 (- 18 zoom-input)))) ; assuming geographic coordinates
 204            (point-form
 205             (format nil "POINT(~F ~F)" longitude-input latitude-input))
 206            (result
 207             (ignore-errors
 208               (with-connection *postgresql-credentials*
 209                 (loop
 210                    for common-table-name in common-table-names
 211                    nconc
 212                      (query
 213                       (:limit
 214                        (:order-by
 215                         (:select
 216                          'date          ;TODO: debug only
 217                          'measurement-id 'recorded-device-id 'device-stage-of-life-id ;TODO: debug only
 218                          'directory
 219                          'filename 'byte-position 'point-id
 220                          'trigger-time
 221                          ;'coordinates   ;the search target
 222                          'longitude 'latitude 'ellipsoid-height
 223                          'cartesian-system
 224                          'east-sd 'north-sd 'height-sd
 225                          'roll 'pitch 'heading 'roll-sd 'pitch-sd 'heading-sd
 226                          'sensor-width-pix 'sensor-height-pix 'pix-size
 227                          'mounting-angle
 228                          'dx 'dy 'dz 'omega 'phi 'kappa
 229                          'c 'xh 'yh 'a1 'a2 'a3 'b1 'b2 'c1 'c2 'r0
 230                          'b-dx 'b-dy 'b-dz 'b-rotx 'b-roty 'b-rotz
 231                          'b-ddx 'b-ddy 'b-ddz 'b-drotx 'b-droty 'b-drotz
 232                          :from
 233                          (aggregate-view-name common-table-name)
 234                          :where
 235                          (:and (:= 'presentation-project-id presentation-project-id)
 236                                (:st_dwithin 'coordinates
 237                                             (:st_geomfromtext point-form *standard-coordinates*)
 238                                             snap-distance)))
 239                         (:st_distance 'coordinates
 240                                       (:st_geomfromtext point-form *standard-coordinates*)))
 241                        count)
 242                       :alists))))))
 243       (json:encode-json-to-string result))))
 244
 245 (define-easy-handler
 246     (store-point :uri "/phoros-lib/store-point" :default-request-type :post)
 247     ()
 248   "Receive point sent by user; store it into database."
 249   (when (session-value 'authenticated-p)
 250     (let* ((presentation-project-name (session-value 'presentation-project-name))
 251            (user-id (session-value 'user-id))
 252            (user-role (session-value 'user-role))
 253            (data (json:decode-json-from-string (raw-post-data)))
 254            (longitude-input (cdr (assoc :longitude data)))
 255            (latitude-input (cdr (assoc :latitude data)))
 256            (ellipsoid-height-input (cdr (assoc :ellipsoid-height data)))
 257            (stdx-global (cdr (assoc :stdx-global data)))
 258            (stdy-global (cdr (assoc :stdy-global data)))
 259            (stdz-global (cdr (assoc :stdz-global data)))
 260            (attribute (cdr (assoc :attribute data)))
 261            (description (cdr (assoc :description data)))
 262            (numeric-description (cdr (assoc :numeric-description data)))
 263            (point-form
 264             (format nil "SRID=4326; POINT(~S ~S ~S)"
 265                     longitude-input latitude-input ellipsoid-height-input))
 266            (aux-numeric-raw (cdr (assoc :aux-numeric data)))
 267            (aux-text-raw (cdr (assoc :aux-text data)))
 268            (aux-numeric (if aux-numeric-raw
 269                             (apply #'vector aux-numeric-raw)
 270                             :null))
 271            (aux-text (if aux-text-raw
 272                          (apply #'vector aux-text-raw)
 273                          :null))
 274            (user-point-table-name
 275             (user-point-table-name presentation-project-name)))
 276       (assert
 277        (not (string-equal user-role "read")) ;that is, "write" or "admin"
 278        () "No write permission.")
 279       (with-connection *postgresql-credentials*
 280         (assert
 281          (= 1 (execute (:insert-into user-point-table-name :set
 282                                      'user-id user-id
 283                                      'attribute attribute
 284                                      'description description
 285                                      'numeric-description numeric-description
 286                                      'creation-date 'current-timestamp
 287                                      'coordinates (:st_geomfromewkt point-form)
 288                                      'stdx-global stdx-global
 289                                      'stdy-global stdy-global
 290                                      'stdz-global stdz-global
 291                                      'aux-numeric aux-numeric
 292                                      'aux-text aux-text
 293                                      )))
 294          () "No point stored.  This should not happen.")))))
 295
 296 (define-easy-handler
 297     (update-point :uri "/phoros-lib/update-point" :default-request-type :post)
 298     ()
 299   "Update point sent by user in database."
 300   (when (session-value 'authenticated-p)
 301     (let* ((presentation-project-name (session-value 'presentation-project-name))
 302            (user-id (session-value 'user-id))
 303            (user-role (session-value 'user-role))
 304            (data (json:decode-json-from-string (raw-post-data)))
 305            (user-point-id (cdr (assoc :user-point-id data)))
 306            (attribute (cdr (assoc :attribute data)))
 307            (description (cdr (assoc :description data)))
 308            (numeric-description (cdr (assoc :numeric-description data)))
 309            (user-point-table-name
 310             (user-point-table-name presentation-project-name)))
 311       (assert
 312        (not (string-equal user-role "read")) ;that is, "write" or "admin"
 313        () "No write permission.")
 314       (with-connection *postgresql-credentials*
 315         (assert
 316          (= 1 (execute (:update user-point-table-name :set
 317                                 'attribute attribute
 318                                 'description description
 319                                 'numeric-description numeric-description
 320                                 'creation-date 'current-timestamp
 321                                 :where (:and (:= 'user-point-id user-point-id)
 322                                              (:= (if (string-equal user-role "admin")
 323                                                      user-id
 324                                                      'user-id)
 325                                                  user-id)))))
 326          () "No point stored.  Did you try to update someone else's point ~
 327              without having admin permission?")))))
 328
 329 (define-easy-handler
 330     (delete-point :uri "/phoros-lib/delete-point" :default-request-type :post)
 331     ()
 332   "Delete user point if user is allowed to do so."
 333   (when (session-value 'authenticated-p)
 334     (let* ((presentation-project-name (session-value 'presentation-project-name))
 335            (user-id (session-value 'user-id))
 336            (user-role (session-value 'user-role))
 337            (user-point-table-name
 338             (user-point-table-name presentation-project-name))
 339            (data (json:decode-json-from-string (raw-post-data))))
 340       (with-connection *postgresql-credentials*
 341         (assert
 342          (eql 1 (cond ((string-equal user-role "admin")
 343                      (execute (:delete-from user-point-table-name
 344                                             :where (:= 'user-point-id data))))
 345                     ((string-equal user-role "write")
 346                      (execute (:delete-from user-point-table-name
 347                                             :where (:and
 348                                                     (:= 'user-point-id data)
 349                                                     (:= 'user-id user-id)))))))
 350             () "No point deleted.  This should not happen.")))))
 351
 352
 353 (defun common-table-names (presentation-project-id)
 354   "Return a list of common-table-names of table sets that contain data
 355 of presentation project with presentation-project-id."
 356   (handler-case
 357       (with-connection *postgresql-credentials*
 358         (query
 359          (:select 'common-table-name
 360                   :distinct
 361                   :from 'sys-presentation 'sys-measurement 'sys-acquisition-project
 362                   :where (:and
 363                           (:= 'sys-presentation.presentation-project-id presentation-project-id)
 364                           (:= 'sys-presentation.measurement-id 'sys-measurement.measurement-id)
 365                           (:= 'sys-measurement.acquisition-project-id 'sys-acquisition-project.acquisition-project-id)))
 366                :column))
 367     (condition (c)
 368       (cl-log:log-message
 369        :error
 370        "While fetching common-table-names of presentation-project-id ~D: ~A"
 371        presentation-project-id c))))
 372
 373 (defun encode-geojson-to-string (features &rest junk-keys)
 374   "Encode a list of property lists into a GeoJSON FeatureCollection.
 375 Each property list must contain keys for coordinates, :x, :y, :z; and
 376 for a numeric point :id, followed by zero or more pieces of extra
 377 information.  The extra information is stored as GeoJSON Feature
 378 properties.  Exclude property list elements with keys that are in
 379 junk-keys."
 380   (with-output-to-string (s)
 381     (json:with-object (s)
 382       (json:encode-object-member :type :*feature-collection s)
 383       (json:as-object-member (:features s)
 384         (json:with-array (s)
 385           (mapcar
 386            #'(lambda (point-with-properties)
 387                (dolist (junk-key junk-keys)
 388                  (remf point-with-properties junk-key))
 389                (destructuring-bind (&key x y z id &allow-other-keys) ;TODO: z probably bogus
 390                    point-with-properties
 391                  (json:as-array-member (s)
 392                    (json:with-object (s)
 393                      (json:encode-object-member :type :*feature s)
 394                      (json:as-object-member (:geometry s)
 395                        (json:with-object (s)
 396                          (json:encode-object-member :type :*point s)
 397                          (json:as-object-member (:coordinates s)
 398                            (json:encode-json (list x y z) s))))
 399                      (json:encode-object-member :id id s)
 400                      (json:as-object-member (:properties s)
 401                        (dolist (key '(:x :y :z :id))
 402                          (remf point-with-properties key))
 403                        (json:encode-json-plist point-with-properties s))))))
 404            features))))))
 405
 406 (defun box3d (bbox)
 407   "Return a WKT-compliant BOX3D string from string bbox."
 408   (concatenate 'string "BOX3D("
 409                (substitute #\Space #\,
 410                            (substitute #\Space #\, bbox :count 1)
 411                            :from-end t :count 1)
 412                ")"))
 413
 414 (define-easy-handler (points :uri "/phoros-lib/points.json") (bbox)
 415   "Send a bunch of GeoJSON-encoded points from inside bbox to client."
 416   (when (session-value 'authenticated-p)
 417     (setf (content-type*) "application/json")
 418     (handler-case
 419         (let* ((presentation-project-id (session-value 'presentation-project-id))
 420                (common-table-names
 421                 (common-table-names presentation-project-id)))
 422           (encode-geojson-to-string
 423            (with-connection *postgresql-credentials*
 424              (query
 425               (sql-compile
 426                `(:limit
 427                  (:order-by
 428                   (:union
 429                    ,@(loop
 430                         for common-table-name in common-table-names
 431                         for aggregate-view-name
 432                         = (aggregate-view-name common-table-name)
 433                         collect
 434                         `(:select
 435                           (:as
 436                            (:st_x
 437                             (:st_transform 'coordinates ,*standard-coordinates*))
 438                            x)
 439                           (:as
 440                            (:st_y
 441                             (:st_transform 'coordinates ,*standard-coordinates*))
 442                            y)
 443                           (:as
 444                            (:st_z
 445                             (:st_transform 'coordinates ,*standard-coordinates*))
 446                            z)
 447                           (:as 'point-id 'id) ;becomes fid on client
 448                           (:as (:random) random)
 449                           :from ',aggregate-view-name
 450                           :natural :left-join 'sys-presentation
 451                           :where
 452                           (:and
 453                            (:= 'presentation-project-id ,presentation-project-id)
 454                            (:&&
 455                             (:st_transform 'coordinates ,*standard-coordinates*)
 456                             (:st_setsrid  (:type ,(box3d bbox) box3d)
 457                                           ,*standard-coordinates*))))))
 458                   random)
 459                  ,*number-of-features-per-layer*))
 460               :plists))
 461            :random))
 462       (condition (c)
 463         (cl-log:log-message
 464          :error "While fetching points from inside bbox ~S: ~A"
 465          bbox c)))))
 466
 467 (define-easy-handler (aux-points :uri "/phoros-lib/aux-points.json") (bbox)
 468   "Send a bunch of GeoJSON-encoded points from inside bbox to client."
 469   (when (session-value 'authenticated-p)
 470     (setf (content-type*) "application/json")
 471     (handler-case
 472         (let ((limit *number-of-features-per-layer*)
 473               (aux-view-name
 474                (aux-point-view-name (session-value
 475                                      'presentation-project-name))))
 476           (encode-geojson-to-string
 477            (with-connection *postgresql-credentials*
 478              (query
 479               (s-sql:sql-compile
 480                `(:limit
 481                  (:order-by
 482                   (:select
 483                    (:as
 484                     (:st_x (:st_transform 'coordinates ,*standard-coordinates*))
 485                     'x)
 486                    (:as
 487                     (:st_y (:st_transform 'coordinates ,*standard-coordinates*))
 488                     'y)
 489                    (:as
 490                     (:st_z (:st_transform 'coordinates ,*standard-coordinates*))
 491                     'z)
 492                    :from ,aux-view-name
 493                    :where (:&&
 494                            (:st_transform 'coordinates ,*standard-coordinates*)
 495                            (:st_setsrid  (:type ,(box3d bbox) box3d)
 496                                          ,*standard-coordinates*)))
 497                   (:random))
 498                  ,limit))
 499               :plists))))
 500       (condition (c)
 501         (cl-log:log-message
 502          :error "While fetching aux-points from inside bbox ~S: ~A"
 503          bbox c)))))
 504
 505 (define-easy-handler
 506     (aux-local-data :uri "/phoros-lib/aux-local-data" :default-request-type :post)
 507     ()
 508   "Receive coordinates, respond with the count nearest json objects
 509 containing arrays aux-numeric, aux-text, and distance to the
 510 coordinates received, wrapped in an array."
 511   (when (session-value 'authenticated-p)
 512     (setf (content-type*) "application/json")
 513     (let* ((aux-view-name (aux-point-view-name (session-value 'presentation-project-name)))
 514            (data (json:decode-json-from-string (raw-post-data)))
 515            (longitude-input (cdr (assoc :longitude data)))
 516            (latitude-input (cdr (assoc :latitude data)))
 517            (count (cdr (assoc :count data)))
 518            (point-form
 519             (format nil "POINT(~F ~F)" longitude-input latitude-input)))
 520       (encode-geojson-to-string
 521        (ignore-errors
 522          (with-connection *postgresql-credentials*
 523            (nsubst
 524             nil :null
 525             (query
 526              (s-sql:sql-compile
 527               `(:limit
 528                 (:order-by
 529                  (:select
 530                   (:as
 531                    (:st_x (:st_transform 'coordinates ,*standard-coordinates*))
 532                    'x)
 533                   (:as
 534                    (:st_y (:st_transform 'coordinates ,*standard-coordinates*))
 535                    'y)
 536                   (:as
 537                    (:st_z (:st_transform 'coordinates ,*standard-coordinates*))
 538                    'z)
 539                   aux-numeric
 540                   aux-text
 541                   (:as
 542                    (:st_distance
 543                     'coordinates
 544                     (:st_geomfromtext ,point-form ,*standard-coordinates*))
 545                    distance)
 546                   :from ',aux-view-name)
 547                  'distance)             ;TODO: convert into metres
 548                 ,count))
 549              :plists))))))))
 550
 551 (defun presentation-project-bbox (presentation-project-id)
 552   "Return bounding box of the entire presentation-project as a string
 553   \"x1,y1,x2,y2\"."
 554   (let* ((common-table-names
 555           (common-table-names presentation-project-id)))
 556     (with-connection *postgresql-credentials*
 557       (substitute
 558        #\, #\Space
 559        (string-trim
 560         "BOX()"
 561         (query
 562          (sql-compile
 563           `(:select
 564             (:st_extent (:st_transform 'coordinates ,*standard-coordinates*))
 565                     :from
 566                     (:as (:union
 567                           ,@(loop
 568                                for common-table-name in common-table-names
 569                                for aggregate-view-name
 570                                = (aggregate-view-name common-table-name)
 571                                collect
 572                                `(:select
 573                                  'coordinates
 574                                  :from ',aggregate-view-name
 575                                  :natural :left-join 'sys-presentation
 576                                  :where
 577                                  (:= 'presentation-project-id
 578                                      ,presentation-project-id))))
 579                          all-coordinates)))
 580          :single!))))))
 581
 582 (define-easy-handler (user-points :uri "/phoros-lib/user-points.json") (bbox)
 583   "Send *number-of-features-per-layer* randomly chosen GeoJSON-encoded
 584 points from inside bbox to client.  If there is no bbox parameter,
 585 send all points."
 586   (when (session-value 'authenticated-p)
 587     (setf (content-type*) "application/json")
 588     (handler-case
 589         (let ((bounding-box (or bbox "-180,-90,180,90"))
 590               (limit (if bbox *number-of-features-per-layer* :null))
 591               (order-criterion (if bbox '(:random) 'id))
 592               (user-point-table-name
 593                (user-point-table-name (session-value
 594                                        'presentation-project-name))))
 595           (encode-geojson-to-string
 596            (with-connection *postgresql-credentials*
 597              (nsubst
 598               nil :null
 599               (query
 600                (s-sql:sql-compile
 601                 `(:limit
 602                   (:order-by
 603                    (:select
 604                     (:as
 605                      (:st_x (:st_transform 'coordinates ,*standard-coordinates*))
 606                      'x)
 607                     (:as
 608                      (:st_y (:st_transform 'coordinates ,*standard-coordinates*))
 609                      'y)
 610                     (:as
 611                      (:st_z (:st_transform 'coordinates ,*standard-coordinates*))
 612                      'z)
 613                     (:as 'user-point-id 'id) ;becomes fid on client
 614                     'attribute
 615                     'description
 616                     'numeric-description
 617                     'user-name
 618                     (:as (:to-char 'creation-date "IYYY-MM-DD HH24:MI:SS TZ")
 619                          'creation-date)
 620                     'aux-numeric
 621                     'aux-text
 622                     :from ,user-point-table-name :natural :left-join 'sys-user
 623                     :where (:&&
 624                             (:st_transform 'coordinates ,*standard-coordinates*)
 625                             (:st_setsrid  (:type ,(box3d bounding-box) box3d)
 626                                           ,*standard-coordinates*)))
 627                    ,order-criterion)
 628                   ,limit))
 629                :plists)))))
 630       (condition (c)
 631         (cl-log:log-message
 632          :error "While fetching user-points~@[ from inside bbox ~S~]: ~A"
 633          bbox c)))))
 634
 635 (define-easy-handler photo-handler
 636     ((bayer-pattern :init-form "#00ff00,#ff0000")
 637      (color-raiser :init-form "1,1,1"))
 638   "Serve an image from a .pictures file."
 639   (when (session-value 'authenticated-p)
 640     (handler-case
 641         (let* ((s (cdr (cl-utilities:split-sequence #\/ (script-name*)
 642                                                     :remove-empty-subseqs t)))
 643                (directory (last (butlast s 2)))
 644                (file-name-and-type (cl-utilities:split-sequence
 645                                     #\. (first (last s 2))))
 646                (byte-position (parse-integer (car (last s)) :junk-allowed t))
 647                (path-to-file
 648                 (car
 649                  (directory
 650                   (make-pathname
 651                    :directory (append (pathname-directory *common-root*)
 652                                       directory '(:wild-inferiors))
 653                    :name (first file-name-and-type)
 654                    :type (second file-name-and-type)))))
 655                stream)
 656           (setf (content-type*) "image/png")
 657           (setf stream (send-headers))
 658           (send-png stream path-to-file byte-position
 659                     :bayer-pattern (canonicalize-bayer-pattern bayer-pattern)
 660                     :color-raiser (canonicalize-color-raiser color-raiser)))
 661       (condition (c)
 662         (cl-log:log-message
 663          :error "While serving image ~S: ~A" (request-uri*) c)))))
 664
 665 (pushnew (create-prefix-dispatcher "/phoros-lib/photo" 'photo-handler)
 666          *dispatch-table*)
 667
 668 ;;; for debugging; this is the multi-file OpenLayers
 669 (pushnew (create-folder-dispatcher-and-handler
 670           "/phoros-lib/openlayers/" "OpenLayers-2.10/")
 671          *dispatch-table*)
 672
 673 (pushnew (create-folder-dispatcher-and-handler "/phoros-lib/ol/" "ol/")
 674          *dispatch-table*)
 675
 676 (pushnew (create-folder-dispatcher-and-handler "/phoros-lib/css/" "css/") ;TODO: merge this style.css into public_html/style.css
 677          *dispatch-table*)
 678
 679 (pushnew (create-folder-dispatcher-and-handler
 680           "/phoros-lib/public_html/" "public_html/")
 681          *dispatch-table*)
 682
 683 (pushnew (create-static-file-dispatcher-and-handler
 684           "/favicon.ico" "public_html/favicon.ico")
 685          *dispatch-table*)
 686
 687 (define-easy-handler
 688     (view :uri "/phoros-lib/view" :default-request-type :post) ()
 689   "Serve the client their main workspace."
 690   (if
 691    (session-value 'authenticated-p)
 692    (who:with-html-output-to-string (s nil :indent t)
 693      (:html
 694       :xmlns "http://www.w3.org/1999/xhtml"
 695       (:head
 696        (:title (who:str
 697                 (concatenate
 698                  'string
 699                  "Phoros: " (session-value 'presentation-project-name))))
 700        (if *use-multi-file-openlayers*
 701            (who:htm
 702             (:script :src "/phoros-lib/openlayers/lib/Firebug/firebug.js")
 703             (:script :src "/phoros-lib/openlayers/lib/OpenLayers.js")
 704             ;;(:script :src "/phoros-lib/openlayers/lib/proj4js.js") ;TODO: we don't seem to use this
 705             )
 706            (who:htm (:script :src "/phoros-lib/ol/OpenLayers.js")))
 707        (:link :rel "stylesheet"
 708               :href "/phoros-lib/css/style.css" :type "text/css")
 709        (:script :src "/phoros-lib/phoros.js")
 710        (:script :src "http://maps.google.com/maps/api/js?sensor=false"))
 711       (:body
 712        :onload (ps (init))
 713        (:h1 :id "title"
 714             "Phoros: " (who:str (session-value 'user-full-name))
 715             (who:fmt " (~A)" (session-value 'user-name))
 716             "with " (:span :id "user-role"
 717                            (who:str (session-value 'user-role)))
 718             "permission on "
 719             (:span :id "presentation-project-name"
 720                    (who:str (session-value 'presentation-project-name))))
 721        (:div :class "controlled-streetmap"
 722              (:div :id "streetmap" :class "streetmap" :style "cursor:crosshair")
 723              (:div :id "streetmap-controls" :class "streetmap-controls"
 724                    (:div :id "streetmap-vertical-strut"
 725                          :class "streetmap-vertical-strut")
 726                    (:div :id "streetmap-layer-switcher"
 727                          :class "streetmap-layer-switcher")
 728                    (:div :id "streetmap-overview" :class "streetmap-overview")
 729                    (:div :id "streetmap-mouse-position"
 730                          :class "streetmap-mouse-position")
 731                    (:div :id "streetmap-zoom" :class "streetmap-zoom")))
 732        (:div :class "phoros-controls"
 733              (:div :id "phoros-controls-vertical-strut"
 734                    :class "phoros-controls-vertical-strut")
 735              (:div :id "real-phoros-controls"
 736                    (:h2 (:span :id "h2-controls") (:span :id "creator"))
 737                    (:select :id "point-attribute" :disabled t
 738                             :size 1 :name "point-attribute")
 739                    (:input :id "point-numeric-description" :class "vanilla-input "
 740                            :disabled t
 741                            :type "text" :name "point-numeric-description")
 742                    (:input :id "point-description" :class "vanilla-input"
 743                            :disabled t
 744                            :type "text" :name "point-description")
 745                    (:div (:button :id "delete-point-button" :disabled t
 746                                   :type "button" :onclick (ps-inline (delete-point))
 747                                   "delete")
 748                          (:button :disabled t :id "finish-point-button"
 749                                   :type "button"
 750                                   "finish"))
 751                    (:div :id "aux-point-distance-or-point-creation-date"
 752                          (:code :id "point-creation-date")
 753                          (:input :id "include-aux-data-p"
 754                                  :type "checkbox" :checked t :name "include-aux-data-p"
 755                                  :onchange (ps-inline (flip-aux-data-inclusion)))
 756                          (:select :id "aux-point-distance" :disabled t
 757                                   :size 1 :name "aux-point-distance"
 758                                   :onchange (ps-inline (aux-point-distance-selected))
 759                                   :onclick (ps-inline (enable-aux-point-selection))))
 760                    (:div :id "aux-data"
 761                          (:div :id "aux-numeric-list")
 762                          (:div :id "aux-text-list")))
 763              (:div :id "multiple-points-phoros-controls"
 764                    (:h2 "Multiple Points Selected")
 765                    (:p "You have selected multiple user points.")
 766                    (:p "Unselect all but one to edit its properties."))
 767              (:div :class "image-main-controls"
 768                    (:div :id "auto-zoom"
 769                          (:input :id "zoom-to-point-p" :class "tight-input"
 770                                  :type "checkbox" :checked t "auto zoom"))
 771                    (:div :id "zoom-images-to-max-extent"
 772                          :onclick (ps-inline (zoom-images-to-max-extent)))
 773                    (:div :id "remove-work-layers-button" :disabled t
 774                          :onclick (ps-inline (reset-layers-and-controls))
 775                          "start over")))
 776        (:div :class "help-div"
 777              (:button :id "download-user-points-button"
 778                       :type "button" :onclick "self.location.href = \"/phoros-lib/user-points.json\""
 779                       "download points") ;TODO: offer other formats and maybe projections
 780              (:button :id "blurb-button"
 781                       :type "button"
 782                       :onclick (ps-inline
 783                                 (chain window
 784                                        (open "/phoros-lib/blurb" "About Phoros")))
 785                       (:img :src "/phoros-lib/public_html/phoros-logo-plain.png"
 786                             :alt "Phoros" :style "vertical-align:middle"
 787                             :height 20))
 788              (:button :id "logout-button"
 789                       :type "button"
 790                       :onclick "self.location.href = \"/phoros-lib/logout\""
 791                       "bye")
 792              (:h2 :id "h2-help" "Help")
 793              (:div :id "help-display"))
 794        (:div :id "images" :style "clear:both"
 795              (loop
 796                 for i from 0 below *number-of-images* do
 797                 (who:htm
 798                  (:div :class "controlled-image"
 799                        (:div :id (format nil "image-~S-controls" i)
 800                              :class "image-controls"
 801                              (:div :id (format nil "image-~S-zoom" i)
 802                                    :class "image-zoom")
 803                              (:div :id (format nil "image-~S-layer-switcher" i)
 804                                    :class "image-layer-switcher")
 805                              (:div :id (format nil "image-~S-trigger-time" i)
 806                                    :class "image-trigger-time"))
 807                        (:div :id (format nil "image-~S" i)
 808                              :class "image" :style "cursor:crosshair"))))))))
 809    (redirect
 810     (concatenate 'string "/phoros/" (session-value 'presentation-project-name))
 811     :add-session-id t)))
 812
 813 (define-easy-handler (epipolar-line :uri "/phoros-lib/epipolar-line") ()
 814   "Receive vector of two sets of picture parameters, respond with
 815 JSON encoded epipolar-lines."
 816   (when (session-value 'authenticated-p)
 817     (setf (content-type*) "application/json")
 818     (let* ((data (json:decode-json-from-string (raw-post-data))))
 819       (json:encode-json-to-string
 820        (photogrammetry :epipolar-line (first data) (second data))))))
 821
 822 (define-easy-handler
 823     (estimated-positions :uri "/phoros-lib/estimated-positions")
 824     ()
 825   "Receive a two-part JSON vector comprising (1) a vector containing
 826 sets of picture-parameters including clicked (\"active\") points
 827 stored in :m, :n; and (2) a vector containing sets of
 828 picture-parameters; respond with a JSON encoded two-part vector
 829 comprising (1) a point in global coordinates; and (2) a vector of
 830 image coordinates (m, n) for the global point that correspond to the
 831 images from the received second vector.  TODO: report error on bad
 832 data (ex: points too far apart)."
 833   ;; TODO: global-point-for-display should probably contain a proj string in order to make sense of the (cartesian) standard deviations.
 834   (when (session-value 'authenticated-p)
 835     (setf (content-type*) "application/json")
 836     (let* ((data (json:decode-json-from-string (raw-post-data)))
 837            (active-point-photo-parameters (first data))
 838            (destination-photo-parameters (second data))
 839            (cartesian-system (cdr (assoc :cartesian-system (first active-point-photo-parameters))))
 840            (global-point-cartesian (photogrammetry :multi-position-intersection active-point-photo-parameters))
 841            (global-point-geographic-radians
 842             (proj:cs2cs (list (cdr (assoc :x-global global-point-cartesian))
 843                               (cdr (assoc :y-global global-point-cartesian))
 844                               (cdr (assoc :z-global global-point-cartesian)))
 845                         :source-cs cartesian-system))
 846            (global-point-for-display    ;points geographic cs, degrees; std deviations in cartesian cs
 847             (pairlis '(:longitude :latitude :ellipsoid-height
 848                        :stdx-global :stdy-global :stdz-global)
 849                      (list
 850                       (proj:radians-to-degrees (first global-point-geographic-radians))
 851                       (proj:radians-to-degrees (second global-point-geographic-radians))
 852                       (third global-point-geographic-radians)
 853                       (cdr (assoc :stdx-global global-point-cartesian))
 854                       (cdr (assoc :stdy-global global-point-cartesian))
 855                       (cdr (assoc :stdz-global global-point-cartesian)))))
 856            (image-coordinates
 857             (loop
 858                for i in destination-photo-parameters
 859                collect
 860                  (ignore-errors
 861                    (photogrammetry :reprojection i global-point-cartesian)))))
 862       (json:encode-json-to-string
 863         (list global-point-for-display image-coordinates)))))
 864
 865 (define-easy-handler
 866     (user-point-positions :uri "/phoros-lib/user-point-positions")
 867     ()
 868   "Receive a two-part JSON vector comprising
 869 - a vector of user-point-id's and
 870 - a vector containing sets of picture-parameters;
 871 respond with a JSON object comprising the elements
 872 - image-points, a vector whose elements
 873    - correspond to the elements of the picture-parameters vector
 874      received and
 875    - are GeoJSON feature collections containing one point (in picture
 876      coordinates) for each user-point-id received;
 877 - user-point-count, the number of user-points we tried to fetch
 878   image-points for."
 879   (when (session-value 'authenticated-p)
 880     (setf (content-type*) "application/json")
 881     (let* ((user-point-table-name
 882             (user-point-table-name (session-value 'presentation-project-name)))
 883            (data (json:decode-json-from-string (raw-post-data)))
 884            (user-point-ids (first data))
 885            (user-point-count (length user-point-ids))
 886            (destination-photo-parameters (second data))
 887            (cartesian-system
 888             (cdr (assoc :cartesian-system
 889                         (first destination-photo-parameters)))) ;TODO: in rare cases, coordinate systems of the images shown may differ
 890            (user-points
 891             (with-connection *postgresql-credentials*
 892               (query
 893                (:select
 894                 (:as
 895                  (:st_x (:st_transform 'coordinates *standard-coordinates*))
 896                  'longitude)
 897                 (:as
 898                  (:st_y (:st_transform 'coordinates *standard-coordinates*))
 899                  'latitude)
 900                 (:as
 901                  (:st_z (:st_transform 'coordinates *standard-coordinates*))
 902                  'ellipsoid-height)
 903                 (:as 'user-point-id 'id) ;becomes fid on client
 904                 'attribute
 905                 'description
 906                 'numeric-description
 907                 'user-name
 908                 (:as (:to-char 'creation-date "IYYY-MM-DD HH24:MI:SS TZ")
 909                      'creation-date)
 910                 'aux-numeric
 911                 'aux-text
 912                 :from user-point-table-name :natural :left-join 'sys-user
 913                 :where (:in 'user-point-id (:set user-point-ids)))
 914                :plists)))
 915            (global-points-cartesian
 916             (loop
 917                for global-point-geographic in user-points
 918                collect
 919                (ignore-errors ;in case no destination-photo-parameters have been sent
 920                  (pairlis '(:x-global :y-global :z-global)
 921                           (proj:cs2cs
 922                            (list
 923                             (proj:degrees-to-radians
 924                              (getf global-point-geographic :longitude))
 925                             (proj:degrees-to-radians
 926                              (getf global-point-geographic :latitude))
 927                             (getf global-point-geographic :ellipsoid-height))
 928                            :destination-cs cartesian-system)))))
 929            (image-coordinates
 930             (loop
 931                for photo-parameter-set in destination-photo-parameters
 932                collect
 933                (encode-geojson-to-string
 934                 (loop
 935                    for global-point-cartesian in global-points-cartesian
 936                    for user-point in user-points
 937                    collect
 938                    (ignore-errors
 939                      (let ((photo-coordinates
 940                             (photogrammetry :reprojection
 941                                             photo-parameter-set
 942                                             global-point-cartesian))
 943                            (photo-point
 944                             user-point))
 945                        (setf (getf photo-point :x)
 946                              (cdr (assoc :m photo-coordinates)))
 947                        (setf (getf photo-point :y)
 948                              (cdr (assoc :n photo-coordinates)))
 949                        photo-point)))
 950                 :longitude :latitude :ellipsoid-height))))
 951       (with-output-to-string (s)
 952         (json:with-object (s)
 953           (json:encode-object-member :user-point-count user-point-count s)
 954           (json:as-object-member (:image-points s)
 955             (json:with-array (s)
 956               (loop for i in image-coordinates do
 957                    (json:as-array-member (s) (princ i s))))))))))
 958
 959 (define-easy-handler
 960     (multi-position-intersection :uri "/phoros-lib/intersection")
 961     ()
 962   "Receive vector of sets of picture parameters, respond with stuff."
 963   (when (session-value 'authenticated-p)
 964     (setf (content-type*) "application/json")
 965     (let* ((data (json:decode-json-from-string (raw-post-data))))
 966       (json:encode-json-to-string
 967        (photogrammetry :multi-position-intersection data)))))