phoros.lisp

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