phoros.lisp

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