phoros.lisp

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