phoros.lisp

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