phoros.lisp

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