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