phoros.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011 Bert Burgemeister
   3 ;;;
   4 ;;; This program is free software; you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation; either version 2 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License along
  15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
  16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17
  18 (in-package :phoros)
  19
  20 (setf *js-target-version* 1.8)
  21
  22 ;;; Debug helpers.  TODO: remove them.
  23 (defparameter *t* nil)
  24 (defparameter *tt* nil)
  25
  26 (cffi:define-foreign-library phoml
  27   (:unix (:or "./libphoml.so"
  28               "./phoml/lib/libphoml.so"))
  29   (t (:default "libphoml")))
  30
  31 (defparameter *standard-coordinates* 4326
  32   "EPSG code of the coordinate system that we use for communication.")
  33
  34 (defparameter *spherical-mercator* 900913
  35   "EPSG code of the coordinate system used for some distance calculations.")
  36
  37 (defvar *postgresql-credentials* nil
  38   "A list: (database user password host &key (port 5432) use-ssl).")
  39
  40 (defvar *postgresql-aux-credentials* nil
  41   "A list: (database user password host &key (port 5432) use-ssl).")
  42
  43 (defparameter *photogrammetry-mutex* (bt:make-lock "photogrammetry"))
  44
  45 (setf *read-default-float-format* 'double-float)
  46
  47 (defparameter *phoros-server* nil "Hunchentoot acceptor.")
  48
  49 (defparameter *common-root* nil
  50   "Root directory; contains directories of measuring data.")
  51
  52 (defparameter *login-intro* nil
  53   "A few friendly words to be shown below the login form.")
  54
  55 (defparameter *postgresql-warnings* nil
  56   "If t, show PostgreSQL's WARNINGs and NOTICEs.")
  57
  58 (defparameter *use-multi-file-openlayers* nil
  59   "If t, use OpenLayers uncompiled from openlayers/*, which makes
  60   debugging easier.  Otherwise use a single-file shrunk
  61   ol/Openlayers.js.")
  62
  63 (defparameter *number-of-images* 4
  64   "Number of photos shown to the HTTP client.")
  65
  66 (defparameter *number-of-features-per-layer* 500
  67   "What we think a browser can swallow.")
  68
  69 (defparameter *number-of-points-per-aux-linestring* 500
  70   "What we think a browser can swallow.")
  71
  72 (defparameter *user-point-creation-date-format* "IYYY-MM-DD HH24:MI:SS TZ"
  73   "SQL date format used for display and GeoJSON export of user points.")
  74
  75 (defun phoros-version (&key major minor revision)
  76   "Return version of this program, either one integer part as denoted by
  77 the key argument, or the whole dotted string."
  78   (let* ((version-string
  79           (handler-bind ((warning #'ignore-warnings))
  80             (asdf:component-version (asdf:find-system :phoros))))
  81          (version-components
  82           (mapcar #'parse-integer
  83                   (cl-utilities:split-sequence #\. version-string))))
  84     (cond (major (first version-components))
  85           (minor (second version-components))
  86           (revision (third version-components))
  87           (t version-string))))
  88
  89 (defun check-dependencies ()
  90   "Say OK if the necessary external dependencies are available."
  91   (handler-case
  92       (progn
  93         (geographic-to-utm 33 13 52)    ;check cs2cs
  94         (phoros-photogrammetry:del-all) ;check photogrammetry
  95         (initialize-leap-seconds)    ;check source of leap second info
  96         (format *error-output* "~&OK~%"))
  97     (error (e) (format *error-output* "~A~&" e))))
  98
  99 (defun muffle-postgresql-warnings ()
 100   "For current DB, silence PostgreSQL's warnings about implicitly
 101 created stuff."
 102   (unless *postgresql-warnings*
 103     (execute "SET client_min_messages TO ERROR;")))
 104
 105 (defun check-db (db-credentials)
 106   "Check postgresql connection.  Return t if successful; show error on
 107 *error-output* otherwise.  db-credentials is a list like so: (database
 108 user password host &key (port 5432) use-ssl)."
 109   (let (connection)
 110     (handler-case
 111         (setf connection (apply #'connect db-credentials))
 112       (error (e) (format *error-output* "Database connection ~S failed: ~A~&"
 113                          db-credentials e)))
 114     (when connection
 115       (disconnect connection)
 116       t)))
 117
 118 (defun ignore-warnings (c) (declare (ignore c)) (muffle-warning))
 119
 120 (defmethod hunchentoot:session-cookie-name (acceptor)
 121   (declare (ignore acceptor))
 122   "phoros-session")
 123
 124 (defun start-server (&key (http-port 8080) address (common-root "/"))
 125   "Start the presentation project server which listens on http-port
 126 at address.  Address defaults to all addresses of the local machine."
 127   (setf *phoros-server*
 128         (make-instance 'hunchentoot:acceptor
 129                        :port http-port
 130                        :address address
 131                        :access-logger #'log-http-access
 132                        :message-logger #'log-hunchentoot-message))
 133   (setf hunchentoot:*session-max-time* (* 3600 24))
 134   (setf *common-root* common-root)
 135   (check-db *postgresql-credentials*)
 136   (with-connection *postgresql-credentials*
 137     (assert-phoros-db-major-version))
 138   (hunchentoot:reset-session-secret)
 139   (hunchentoot:start *phoros-server*))
 140
 141 (defun stop-server () (hunchentoot:stop *phoros-server*))
 142
 143 (eval-when (:compile-toplevel :load-toplevel :execute)
 144   (register-sql-operators :2+-ary :&& :overlaps))
 145
 146 (setf hunchentoot:*default-handler*
 147       #'(lambda ()
 148           "Http default response."
 149           (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+)))
 150
 151 (hunchentoot:define-easy-handler phoros-handler ()
 152   "First HTTP contact: if necessary, check credentials, establish new
 153 session."
 154   (with-connection *postgresql-credentials*
 155     (let* ((presentation-project-name
 156             (second (cl-utilities:split-sequence
 157                      #\/ (hunchentoot:script-name*) :remove-empty-subseqs t)))
 158            (presentation-project-id
 159             (ignore-errors
 160               (query
 161                (:select 'presentation-project-id
 162                         :from 'sys-presentation-project
 163                         :where (:= 'presentation-project-name
 164                                    presentation-project-name))
 165                :single))))
 166       (cond
 167         ((null presentation-project-id)
 168          (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+))
 169         ((and (equal (hunchentoot:session-value 'presentation-project-name)
 170                      presentation-project-name)
 171               (hunchentoot:session-value 'authenticated-p))
 172          (hunchentoot:redirect
 173           (format nil "/phoros/lib/view-~A" (phoros-version))
 174           :add-session-id t))
 175         (t
 176          (progn
 177            (setf (hunchentoot:session-value 'presentation-project-name)
 178                  presentation-project-name)
 179            (setf (hunchentoot:session-value 'presentation-project-id)
 180                  presentation-project-id)
 181            (setf (hunchentoot:session-value 'presentation-project-bbox)
 182                  (let ((bbox
 183                         (ignore-errors
 184                           (bounding-box (get-dao 'sys-presentation-project
 185                                                  presentation-project-name)))))
 186                    (if (or (null bbox) (eq :null bbox))
 187                        nil
 188                        bbox)))
 189            (setf (hunchentoot:session-value 'aux-data-p)
 190                  (with-connection *postgresql-aux-credentials*
 191                    (view-exists-p (aux-point-view-name
 192                                    presentation-project-name))))
 193            (who:with-html-output-to-string (s nil :prologue t :indent t)
 194              (:body
 195               :style "font-family:sans-serif;"
 196               (:form
 197                :method "post" :enctype "multipart/form-data"
 198                :action "/phoros/lib/authenticate" :name "login-form"
 199                (:fieldset
 200                 (:legend (:b (:a :href "http://phoros.berlios.de"
 201                                  :style "text-decoration:none;"
 202                                  "Phoros")
 203                              (who:fmt "&nbsp;[~A]" presentation-project-name)))
 204                 (:noscript
 205                  (:b (:em "You can't do much without JavaScript there.")))
 206                 (:p "User:"
 207                     :br
 208                     (:input :type "text" :name "user-name"))
 209                 (:p "Password:"
 210                     :br
 211                     (:input :type "password" :name "user-password")
 212                     "&nbsp;&nbsp;&nbsp;"
 213                     (:span :id "cackle"))
 214                 (:input :type "submit" :value "Submit"
 215                         :onclick (ps-inline
 216                                   (setf (chain document
 217                                                (get-element-by-id "cackle")
 218                                                inner-h-t-m-l)
 219                                         "Ok, let&#039;s see&#8230;"))))
 220                (:script :type "text/javascript"
 221                         (who:str (ps (chain document
 222                                             :login-form
 223                                             :user-name
 224                                             (focus))))))
 225               (loop
 226                  for i in *login-intro*
 227                  do (who:htm (:p (who:str i))))))))))))
 228
 229 (pushnew (hunchentoot:create-regex-dispatcher "/phoros/(?!lib/)"
 230                                               'phoros-handler)
 231          hunchentoot:*dispatch-table*)
 232
 233 (defun stored-bbox ()
 234   "Return stored bounding box for user and presentation project of
 235 current session."
 236   (with-connection *postgresql-credentials*
 237     (let ((bbox (bounding-box
 238                  (get-dao 'sys-user-role
 239                           (hunchentoot:session-value
 240                            'user-id)
 241                           (hunchentoot:session-value
 242                            'presentation-project-id)))))
 243       (if (eq :null bbox)
 244           (hunchentoot:session-value 'presentation-project-bbox)
 245           bbox))))
 246
 247 (defun stored-cursor ()
 248   "Return stored cursor position for user and presentation project of
 249 current session."
 250   (with-connection *postgresql-credentials*
 251     (let ((cursor
 252            (query
 253             (:select (:st_x 'cursor) (:st_y 'cursor)
 254                      :from 'sys-user-role
 255                      :where (:and (:= 'user-id
 256                                       (hunchentoot:session-value 'user-id))
 257                                   (:= 'presentation-project-id
 258                                       (hunchentoot:session-value
 259                                        'presentation-project-id))
 260                                   (:raw "cursor IS NOT NULL")))
 261             :list)))
 262       (when cursor
 263         (format nil "~{~F~#^,~}" cursor)))))
 264
 265
 266 (hunchentoot:define-easy-handler
 267     (authenticate-handler :uri "/phoros/lib/authenticate"
 268                           :default-request-type :post)
 269     ()
 270   "Check user credentials."
 271   (with-connection *postgresql-credentials*
 272     (let* ((user-name (hunchentoot:post-parameter "user-name"))
 273            (user-password (hunchentoot:post-parameter "user-password"))
 274            (presentation-project-id (hunchentoot:session-value
 275                                      'presentation-project-id))
 276            (user-info
 277             (when presentation-project-id
 278               (query
 279                (:select
 280                 'sys-user.user-full-name
 281                 'sys-user.user-id
 282                 'sys-user-role.user-role
 283                 :from 'sys-user-role 'sys-user
 284                 :where (:and
 285                         (:= 'presentation-project-id presentation-project-id)
 286                         (:= 'sys-user-role.user-id 'sys-user.user-id)
 287                         (:= 'user-name user-name)
 288                         (:= 'user-password user-password)))
 289                :row)))
 290            (user-full-name (first user-info))
 291            (user-id (second user-info))
 292            (user-role (third user-info)))
 293       (if user-role
 294           (progn
 295             (setf (hunchentoot:session-value 'authenticated-p) t
 296                   (hunchentoot:session-value 'user-name) user-name
 297                   (hunchentoot:session-value 'user-full-name) user-full-name
 298                   (hunchentoot:session-value 'user-id) user-id
 299                   (hunchentoot:session-value 'user-role) user-role)
 300             (hunchentoot:redirect (format nil "/phoros/lib/view-~A"
 301                                           (phoros-version))
 302                                   :add-session-id t))
 303           (who:with-html-output-to-string (s nil :prologue t :indent t)
 304             (:body
 305              :style "font-family:sans-serif;"
 306              (:b "Rejected. ")
 307              (:a :href (format nil "/phoros/~A/" (hunchentoot:session-value
 308                                                   'presentation-project-name))
 309                  "Retry?")))))))
 310
 311 (hunchentoot:define-easy-handler logout-handler (bbox longitude latitude)
 312   (if (hunchentoot:session-value 'authenticated-p)
 313       (with-connection *postgresql-credentials*
 314         (let ((presentation-project-name
 315                (hunchentoot:session-value 'presentation-project-name))
 316               (sys-user-role
 317                (get-dao 'sys-user-role
 318                         (hunchentoot:session-value 'user-id)
 319                         (hunchentoot:session-value 'presentation-project-id))))
 320           (when sys-user-role
 321             (when bbox
 322               (setf (bounding-box sys-user-role) bbox))
 323             (when (and longitude latitude)
 324               (let* ;; kludge: should be done by some library, not by DB query
 325                   ((point-form (format nil "POINT(~F ~F)" longitude latitude))
 326                    (point-wkb (query (:select
 327                                       (:st_geomfromtext point-form))
 328                                      :single)))
 329                 (setf (cursor sys-user-role) point-wkb)))
 330             (update-dao sys-user-role))
 331           (hunchentoot:remove-session hunchentoot:*session*)
 332           (who:with-html-output-to-string (s nil :prologue t :indent t)
 333             (:html
 334              (:head
 335               (:title (who:str
 336                        (concatenate
 337                         'string
 338                         "Phoros: logged out" )))
 339               (:link :rel "stylesheet"
 340                      :href (format nil "/phoros/lib/css-~A/style.css"
 341                                    (phoros-version))
 342                      :type "text/css"))
 343              (:body
 344               (:h1 :id "title" "Phoros: logged out")
 345               (:p "Log back in to project "
 346                   (:a :href (format nil "/phoros/~A" presentation-project-name)
 347                       (who:fmt "~A." presentation-project-name))))))))
 348       "Bye (again)."))
 349
 350 (pushnew (hunchentoot:create-regex-dispatcher "/logout" 'logout-handler)
 351          hunchentoot:*dispatch-table*)
 352
 353 (hunchentoot:define-easy-handler
 354     (local-data :uri "/phoros/lib/local-data" :default-request-type :post)
 355     ()
 356   "Receive coordinates, respond with the count nearest json objects
 357 containing picture url, calibration parameters, and car position,
 358 wrapped in an array."
 359   (when (hunchentoot:session-value 'authenticated-p)
 360     (setf (hunchentoot:content-type*) "application/json")
 361     (with-connection *postgresql-credentials*
 362       (let* ((presentation-project-id (hunchentoot:session-value
 363                                        'presentation-project-id))
 364              (common-table-names (common-table-names
 365                                   presentation-project-id))
 366              (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
 367              (longitude (cdr (assoc :longitude data)))
 368              (latitude (cdr (assoc :latitude data)))
 369              (count (cdr (assoc :count data)))
 370              (zoom (cdr (assoc :zoom data)))
 371              (snap-distance (* 10d-5 (expt 2 (- 18 zoom)))) ; assuming geographic coordinates
 372              (point-form (format nil "POINT(~F ~F)" longitude latitude))
 373              (result
 374               (ignore-errors
 375                 (query
 376                  (sql-compile
 377                   `(:limit
 378                     (:order-by
 379                      (:union
 380                       ,@(loop
 381                            for common-table-name in common-table-names
 382                            for aggregate-view-name
 383                            = (aggregate-view-name common-table-name)
 384                            collect
 385                            `(:select
 386                              (:as (:st_distance 'coordinates
 387                                                 (:st_geomfromtext
 388                                                  ,point-form
 389                                                  ,*standard-coordinates*))
 390                                   'distance)
 391                              'recorded-device-id      ;debug
 392                              'device-stage-of-life-id ;debug
 393                              'generic-device-id       ;debug
 394                              'directory
 395                              'filename 'byte-position 'point-id
 396                              'trigger-time
 397                                         ;'coordinates   ;the search target
 398                              'longitude 'latitude 'ellipsoid-height
 399                              'cartesian-system
 400                              'east-sd 'north-sd 'height-sd
 401                              'roll 'pitch 'heading
 402                              'roll-sd 'pitch-sd 'heading-sd
 403                              'sensor-width-pix 'sensor-height-pix 'pix-size
 404                              'bayer-pattern 'color-raiser
 405                              'mounting-angle
 406                              'dx 'dy 'dz 'omega 'phi 'kappa
 407                              'c 'xh 'yh 'a1 'a2 'a3 'b1 'b2 'c1 'c2 'r0
 408                              'b-dx 'b-dy 'b-dz 'b-rotx 'b-roty 'b-rotz
 409                              'b-ddx 'b-ddy 'b-ddz 'b-drotx 'b-droty 'b-drotz
 410                              :from
 411                              ',aggregate-view-name
 412                              :where
 413                              (:and (:= 'presentation-project-id
 414                                        ,presentation-project-id)
 415                                    (:st_dwithin 'coordinates
 416                                                 (:st_geomfromtext
 417                                                  ,point-form
 418                                                  ,*standard-coordinates*)
 419                                                 ,snap-distance)))))
 420                      'distance)
 421                     ,count))
 422                  :alists))))
 423         (json:encode-json-to-string result)))))
 424
 425 (hunchentoot:define-easy-handler
 426     (store-point :uri "/phoros/lib/store-point" :default-request-type :post)
 427     ()
 428   "Receive point sent by user; store it into database."
 429   (when (hunchentoot:session-value 'authenticated-p)
 430     (let* ((presentation-project-name (hunchentoot:session-value
 431                                        'presentation-project-name))
 432            (user-id (hunchentoot:session-value 'user-id))
 433            (user-role (hunchentoot:session-value 'user-role))
 434            (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
 435            (longitude (cdr (assoc :longitude data)))
 436            (latitude (cdr (assoc :latitude data)))
 437            (ellipsoid-height (cdr (assoc :ellipsoid-height data)))
 438            (stdx-global (cdr (assoc :stdx-global data)))
 439            (stdy-global (cdr (assoc :stdy-global data)))
 440            (stdz-global (cdr (assoc :stdz-global data)))
 441            (input-size (cdr (assoc :input-size data)))
 442            (attribute (cdr (assoc :attribute data)))
 443            (description (cdr (assoc :description data)))
 444            (numeric-description (cdr (assoc :numeric-description data)))
 445            (point-form
 446             (format nil "SRID=4326; POINT(~S ~S ~S)"
 447                     longitude latitude ellipsoid-height))
 448            (aux-numeric-raw (cdr (assoc :aux-numeric data)))
 449            (aux-text-raw (cdr (assoc :aux-text data)))
 450            (aux-numeric (if aux-numeric-raw
 451                             (apply #'vector aux-numeric-raw)
 452                             :null))
 453            (aux-text (if aux-text-raw
 454                          (apply #'vector aux-text-raw)
 455                          :null))
 456            (user-point-table-name
 457             (user-point-table-name presentation-project-name)))
 458       (assert
 459        (not (string-equal user-role "read")) ;that is, "write" or "admin"
 460        () "No write permission.")
 461       (with-connection *postgresql-credentials*
 462         (assert
 463          (= 1 (execute (:insert-into user-point-table-name :set
 464                                      'user-id user-id
 465                                      'attribute attribute
 466                                      'description description
 467                                      'numeric-description numeric-description
 468                                      'creation-date 'current-timestamp
 469                                      'coordinates (:st_geomfromewkt point-form)
 470                                      'stdx-global stdx-global
 471                                      'stdy-global stdy-global
 472                                      'stdz-global stdz-global
 473                                      'input-size input-size
 474                                      'aux-numeric aux-numeric
 475                                      'aux-text aux-text)))
 476          () "No point stored.  This should not happen.")))))
 477
 478 (hunchentoot:define-easy-handler
 479     (update-point :uri "/phoros/lib/update-point" :default-request-type :post)
 480     ()
 481   "Update point sent by user in database."
 482   (when (hunchentoot:session-value 'authenticated-p)
 483     (let* ((presentation-project-name (hunchentoot:session-value
 484                                        'presentation-project-name))
 485            (user-id (hunchentoot:session-value 'user-id))
 486            (user-role (hunchentoot:session-value 'user-role))
 487            (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
 488            (user-point-id (cdr (assoc :user-point-id data)))
 489            (attribute (cdr (assoc :attribute data)))
 490            (description (cdr (assoc :description data)))
 491            (numeric-description (cdr (assoc :numeric-description data)))
 492            (user-point-table-name
 493             (user-point-table-name presentation-project-name)))
 494       (assert
 495        (not (string-equal user-role "read")) ;that is, "write" or "admin"
 496        () "No write permission.")
 497       (with-connection *postgresql-credentials*
 498         (assert
 499          (= 1 (execute (:update user-point-table-name :set
 500                                 'attribute attribute
 501                                 'description description
 502                                 'numeric-description numeric-description
 503                                 'creation-date 'current-timestamp
 504                                 :where (:and (:= 'user-point-id user-point-id)
 505                                              (:= (if (string-equal user-role
 506                                                                    "admin")
 507                                                      user-id
 508                                                      'user-id)
 509                                                  user-id)))))
 510          () "No point stored.  Did you try to update someone else's point ~
 511              without having admin permission?")))))
 512
 513 (hunchentoot:define-easy-handler
 514     (delete-point :uri "/phoros/lib/delete-point" :default-request-type :post)
 515     ()
 516   "Delete user point if user is allowed to do so."
 517   (when (hunchentoot:session-value 'authenticated-p)
 518     (let* ((presentation-project-name (hunchentoot:session-value
 519                                        'presentation-project-name))
 520            (user-id (hunchentoot:session-value 'user-id))
 521            (user-role (hunchentoot:session-value 'user-role))
 522            (user-point-table-name
 523             (user-point-table-name presentation-project-name))
 524            (data (json:decode-json-from-string (hunchentoot:raw-post-data))))
 525       (with-connection *postgresql-credentials*
 526         (assert
 527          (eql 1 (cond ((string-equal user-role "admin")
 528                      (execute (:delete-from user-point-table-name
 529                                             :where (:= 'user-point-id data))))
 530                     ((string-equal user-role "write")
 531                      (execute (:delete-from user-point-table-name
 532                                             :where (:and
 533                                                     (:= 'user-point-id data)
 534                                                     (:= 'user-id user-id)))))))
 535             () "No point deleted.  This should not happen.")))))
 536
 537 (defun common-table-names (presentation-project-id)
 538   "Return a list of common-table-names of table sets that contain data
 539 of presentation project with presentation-project-id."
 540   (handler-case
 541       (query
 542        (:select 'common-table-name
 543                 :distinct
 544                 :from 'sys-presentation 'sys-measurement 'sys-acquisition-project
 545                 :where (:and
 546                         (:= 'sys-presentation.presentation-project-id
 547                             presentation-project-id)
 548                         (:= 'sys-presentation.measurement-id
 549                             'sys-measurement.measurement-id)
 550                         (:= 'sys-measurement.acquisition-project-id
 551                             'sys-acquisition-project.acquisition-project-id)))
 552        :column)
 553     (condition (c)
 554       (cl-log:log-message
 555        :error
 556        "While fetching common-table-names of presentation-project-id ~D: ~A"
 557        presentation-project-id c))))
 558
 559 (defun encode-geojson-to-string (features &key junk-keys)
 560   "Encode a list of property lists into a GeoJSON FeatureCollection.
 561 Each property list must contain keys for coordinates, :x, :y, :z; it
 562 may contain a numeric point :id and zero or more pieces of extra
 563 information.  The extra information is stored as GeoJSON Feature
 564 properties.  Exclude property list elements with keys that are in
 565 junk-keys."
 566   (with-output-to-string (s)
 567     (json:with-object (s)
 568       (json:encode-object-member :type :*feature-collection s)
 569       (json:as-object-member (:features s)
 570         (json:with-array (s)
 571           (mapcar
 572            #'(lambda (point-with-properties)
 573                (dolist (junk-key junk-keys)
 574                  (remf point-with-properties junk-key))
 575                (destructuring-bind (&key x y z id &allow-other-keys) ;TODO: z probably bogus
 576                    point-with-properties
 577                  (json:as-array-member (s)
 578                    (json:with-object (s)
 579                      (json:encode-object-member :type :*feature s)
 580                      (json:as-object-member (:geometry s)
 581                        (json:with-object (s)
 582                          (json:encode-object-member :type :*point s)
 583                          (json:as-object-member (:coordinates s)
 584                            (json:encode-json (list x y z) s))))
 585                      (json:encode-object-member :id id s)
 586                      (json:as-object-member (:properties s)
 587                        (dolist (key '(:x :y :z :id))
 588                          (remf point-with-properties key))
 589                        (json:encode-json-plist point-with-properties s))))))
 590            features)))
 591       (json:encode-object-member :phoros-version (phoros-version) s))))
 592
 593 (defun box3d (bbox)
 594   "Return a WKT-compliant BOX3D string from string bbox."
 595   (concatenate 'string "BOX3D("
 596                (substitute #\Space #\,
 597                            (substitute #\Space #\, bbox :count 1)
 598                            :from-end t :count 1)
 599                ")"))
 600
 601 (hunchentoot:define-easy-handler (points :uri "/phoros/lib/points.json") (bbox)
 602   "Send a bunch of GeoJSON-encoded points from inside bbox to client."
 603   (when (hunchentoot:session-value 'authenticated-p)
 604     (setf (hunchentoot:content-type*) "application/json")
 605     (handler-case
 606         (with-connection *postgresql-credentials*
 607           (let* ((presentation-project-id
 608                   (hunchentoot:session-value 'presentation-project-id))
 609                  (common-table-names
 610                   (common-table-names presentation-project-id)))
 611             (encode-geojson-to-string
 612              (query
 613               (sql-compile
 614                `(:limit
 615                  (:order-by
 616                   (:union
 617                    ,@(loop
 618                         for common-table-name in common-table-names
 619                         for aggregate-view-name
 620                         = (point-data-table-name common-table-name)
 621                         ;; would have been nice, was too slow:
 622                         ;; = (aggregate-view-name common-table-name)
 623                         collect
 624                         `(:select
 625                           (:as (:st_x 'coordinates) x)
 626                           (:as (:st_y 'coordinates) y)
 627                           (:as (:st_z 'coordinates) z)
 628                           (:as 'point-id 'id) ;becomes fid on client
 629                           'random
 630                           :distinct-on 'random
 631                           :from ',aggregate-view-name
 632                           :natural :left-join 'sys-presentation
 633                           :where
 634                           (:and
 635                            (:= 'presentation-project-id
 636                                ,presentation-project-id)
 637                            (:&&
 638                             'coordinates
 639                             (:st_setsrid  (:type ,(box3d bbox) box3d)
 640                                           ,*standard-coordinates*))))))
 641                   random)
 642                  ,*number-of-features-per-layer*))
 643               :plists)
 644              :junk-keys '(:random))))
 645       (condition (c)
 646         (cl-log:log-message
 647          :error "While fetching points from inside bbox ~S: ~A"
 648          bbox c)))))
 649
 650 (hunchentoot:define-easy-handler (aux-points :uri "/phoros/lib/aux-points.json") (bbox)
 651   "Send a bunch of GeoJSON-encoded points from inside bbox to client."
 652   (when (hunchentoot:session-value 'authenticated-p)
 653     (setf (hunchentoot:content-type*) "application/json")
 654     (handler-case
 655         (let ((limit *number-of-features-per-layer*)
 656               (aux-view-name
 657                (aux-point-view-name (hunchentoot:session-value
 658                                      'presentation-project-name))))
 659           (encode-geojson-to-string
 660            (with-connection *postgresql-aux-credentials*
 661              (query
 662               (s-sql:sql-compile
 663                `(:limit
 664                  (:order-by
 665                   (:select
 666                    (:as (:st_x 'coordinates) 'x)
 667                    (:as (:st_y 'coordinates) 'y)
 668                    (:as (:st_z 'coordinates) 'z)
 669                    :from ,aux-view-name
 670                    :where (:&&
 671                            'coordinates
 672                            (:st_setsrid  (:type ,(box3d bbox) box3d)
 673                                          ,*standard-coordinates*)))
 674                   (:random))
 675                  ,limit))
 676               :plists))))
 677       (condition (c)
 678         (cl-log:log-message
 679          :error "While fetching aux-points from inside bbox ~S: ~A"
 680          bbox c)))))
 681
 682 (hunchentoot:define-easy-handler
 683     (aux-local-data :uri "/phoros/lib/aux-local-data"
 684                     :default-request-type :post)
 685     ()
 686   "Receive coordinates, respond with the count nearest json objects
 687 containing arrays aux-numeric, aux-text, and distance to the
 688 coordinates received, wrapped in an array."
 689   (when (hunchentoot:session-value 'authenticated-p)
 690     (setf (hunchentoot:content-type*) "application/json")
 691     (let* ((aux-view-name
 692             (aux-point-view-name (hunchentoot:session-value
 693                                   'presentation-project-name)))
 694            (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
 695            (longitude (cdr (assoc :longitude data)))
 696            (latitude (cdr (assoc :latitude data)))
 697            (count (cdr (assoc :count data)))
 698            (point-form
 699             (format nil "POINT(~F ~F)" longitude latitude))
 700            (snap-distance 1e-3) ;about 100 m, TODO: make this a defparameter
 701            (bounding-box
 702             (format nil "~A,~A,~A,~A"
 703                     (- longitude snap-distance)
 704                     (- latitude snap-distance)
 705                     (+ longitude snap-distance)
 706                     (+ latitude snap-distance))))
 707       (encode-geojson-to-string
 708        (ignore-errors
 709          (with-connection *postgresql-aux-credentials*
 710            (nsubst
 711             nil :null
 712             (query
 713              (s-sql:sql-compile
 714               `(:limit
 715                 (:order-by
 716                  (:select
 717                   (:as (:st_x 'coordinates) 'x)
 718                   (:as (:st_y 'coordinates) 'y)
 719                   (:as (:st_z 'coordinates) 'z)
 720                   aux-numeric
 721                   aux-text
 722                   (:as
 723                    (:st_distance
 724                     (:st_transform
 725                      'coordinates
 726                      ,*spherical-mercator*)
 727                     (:st_transform
 728                      (:st_geomfromtext ,point-form ,*standard-coordinates*)
 729                      ,*spherical-mercator*))
 730                    distance)
 731                   :from ',aux-view-name
 732                   :where (:&& 'coordinates
 733                               (:st_setsrid (:type
 734                                             ,(box3d bounding-box) box3d)
 735                                            ,*standard-coordinates*)))
 736                  'distance)
 737                 ,count))
 738              :plists))))))))
 739
 740 (hunchentoot:define-easy-handler
 741     (aux-local-linestring :uri "/phoros/lib/aux-local-linestring.json"
 742                           :default-request-type :post)
 743     ()
 744   "Receive longitude, latitude, radius, and step-size; respond
 745 with the a JSON object comprising the elements linestring (a WKT
 746 linestring stitched together of the nearest auxiliary points from
 747 within radius around coordinates), current-point (the point on
 748 linestring closest to coordinates), and previous-point and next-point
 749 \(points on linestring step-size before and after current-point
 750 respectively)."
 751   (when (hunchentoot:session-value 'authenticated-p)
 752     (setf (hunchentoot:content-type*) "application/json")
 753     (let* ((thread-aux-points-function-name
 754             (thread-aux-points-function-name (hunchentoot:session-value
 755                                               'presentation-project-name)))
 756            (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
 757            (longitude (cdr (assoc :longitude data)))
 758            (latitude (cdr (assoc :latitude data)))
 759            (radius (cdr (assoc :radius data)))
 760            (step-size (cdr (assoc :step-size data)))
 761            (azimuth (if (numberp (cdr (assoc :azimuth data)))
 762                         (cdr (assoc :azimuth data))
 763                         0))
 764            (point-form
 765             (format nil "POINT(~F ~F)" longitude latitude))
 766            (sql-response
 767             (ignore-errors
 768               (with-connection *postgresql-aux-credentials*
 769                 (nsubst
 770                  nil :null
 771                  (query
 772                   (sql-compile
 773                    `(:select '* :from
 774                              (,thread-aux-points-function-name
 775                               (:st_geomfromtext
 776                                ,point-form ,*standard-coordinates*)
 777                               ,radius
 778                               ,*number-of-points-per-aux-linestring*
 779                               ,step-size
 780                               ,azimuth
 781                               ,(proj:degrees-to-radians 91))))
 782                   :plist))))))
 783       (with-output-to-string (s)
 784         (json:with-object (s)
 785           (json:encode-object-member
 786            :linestring (getf sql-response :threaded-points) s)
 787           (json:encode-object-member
 788            :current-point (getf sql-response :current-point) s)
 789           (json:encode-object-member
 790            :previous-point (getf sql-response :back-point) s)
 791           (json:encode-object-member
 792            :next-point (getf sql-response :forward-point) s)
 793           (json:encode-object-member
 794            :azimuth (getf sql-response :new-azimuth) s))))))
 795
 796 (defun get-user-points (user-point-table-name &key
 797                         (bounding-box "-180,-90,180,90")
 798                         (limit :null)
 799                         (order-criterion 'id))
 800   "Return limit points from user-point-table-name in GeoJSON format,
 801 and the number of points returned."
 802   (let ((user-point-plist
 803          (query
 804           (s-sql:sql-compile
 805            `(:limit
 806              (:order-by
 807               (:select
 808                (:as (:st_x 'coordinates) 'x)
 809                (:as (:st_y 'coordinates) 'y)
 810                (:as (:st_z 'coordinates) 'z)
 811                (:as 'user-point-id 'id) ;becomes fid in OpenLayers
 812                'stdx-global 'stdy-global 'stdz-global
 813                'input-size
 814                'attribute 'description 'numeric-description
 815                'user-name
 816                (:as (:to-char 'creation-date
 817                               ,*user-point-creation-date-format*)
 818                     'creation-date)
 819                'aux-numeric 'aux-text
 820                :from ,user-point-table-name :natural :left-join 'sys-user
 821                :where (:&& 'coordinates
 822                            (:st_setsrid  (:type ,(box3d bounding-box) box3d)
 823                                          ,*standard-coordinates*)))
 824               ,order-criterion)
 825              ,limit))
 826           :plists)))
 827     (values
 828      (encode-geojson-to-string (nsubst nil :null user-point-plist))
 829      (length user-point-plist))))
 830
 831 (hunchentoot:define-easy-handler
 832     (user-points :uri "/phoros/lib/user-points.json")
 833     (bbox)
 834   "Send *number-of-features-per-layer* randomly chosen GeoJSON-encoded
 835 points from inside bbox to client.  If there is no bbox parameter,
 836 send all points."
 837   (when (hunchentoot:session-value 'authenticated-p)
 838     (setf (hunchentoot:content-type*) "application/json")
 839     (handler-case
 840         (let ((bounding-box (or bbox "-180,-90,180,90"))
 841               (limit (if bbox *number-of-features-per-layer* :null))
 842               (order-criterion (if bbox '(:random) 'id))
 843               (user-point-table-name
 844                (user-point-table-name (hunchentoot:session-value
 845                                        'presentation-project-name))))
 846           (with-connection *postgresql-credentials*
 847             (nth-value 0 (get-user-points user-point-table-name
 848                                           :bounding-box bounding-box
 849                                           :limit limit
 850                                           :order-criterion order-criterion))))
 851       (condition (c)
 852         (cl-log:log-message
 853          :error "While fetching user-points~@[ from inside bbox ~S~]: ~A"
 854          bbox c)))))
 855
 856 (hunchentoot:define-easy-handler
 857     (user-point-attributes :uri "/phoros/lib/user-point-attributes.json")
 858     ()
 859   "Send JSON object comprising arrays attributes and descriptions,
 860 each containing unique values called attribute and description
 861 respectively, and count being the frequency of value in the user point
 862 table."
 863   (when (hunchentoot:session-value 'authenticated-p)
 864     (setf (hunchentoot:content-type*) "application/json")
 865     (handler-case
 866         (let ((user-point-table-name
 867                (user-point-table-name (hunchentoot:session-value
 868                                        'presentation-project-name))))
 869           (with-connection *postgresql-credentials*
 870             (with-output-to-string (s)
 871               (json:with-object (s)
 872                 (json:as-object-member (:descriptions s)
 873                   (json:with-array (s)
 874                     (mapcar #'(lambda (x) (json:as-array-member (s)
 875                                             (json:encode-json-plist x s)))
 876                             (query
 877                              (:limit
 878                               (:order-by
 879                                (:select 'description
 880                                         (:count 'description)
 881                                         :from user-point-table-name
 882                                         :group-by 'description)
 883                                'description)
 884                               100)
 885                              :plists))))
 886                 (json:as-object-member (:attributes s)
 887                   (json:with-array (s)
 888                     (mapcar #'(lambda (x) (json:as-array-member (s)
 889                                             (json:encode-json-plist x s)))
 890                             (query (format nil "~
 891                               (SELECT attribute, count(attribute) ~
 892                                  FROM ((SELECT attribute FROM ~A) ~
 893                                        UNION ALL ~
 894                                        (SELECT attribute ~
 895                                           FROM (VALUES ('solitary'), ~
 896                                                        ('polyline'), ~
 897                                                        ('polygon')) ~
 898                                           AS defaults(attribute))) ~
 899                                         AS attributes_union(attribute) ~
 900                                  GROUP BY attribute) ~
 901                               ORDER BY attribute LIMIT 100"
 902                                            ;; Counts of solitary,
 903                                            ;; polyline, polygon may be
 904                                            ;; to big by one if we
 905                                            ;; collect them like this.
 906                            (s-sql:to-sql-name user-point-table-name))
 907                                    :plists))))))))
 908       (condition (c)
 909         (cl-log:log-message
 910          :error "While fetching user-point-attributes: ~A"
 911          c)))))
 912
 913 (hunchentoot:define-easy-handler photo-handler
 914     ((bayer-pattern :init-form "65280,16711680")
 915      (color-raiser :init-form "1,1,1")
 916      (mounting-angle :init-form "0"))
 917   "Serve an image from a .pictures file."
 918   (when (hunchentoot:session-value 'authenticated-p)
 919     (handler-case
 920         (let* ((s (cdr (cl-utilities:split-sequence #\/
 921                                                     (hunchentoot:script-name*)
 922                                                     :remove-empty-subseqs t)))
 923                (directory (last (butlast s 2)))
 924                (file-name-and-type (cl-utilities:split-sequence
 925                                     #\. (first (last s 2))))
 926                (byte-position (parse-integer (car (last s)) :junk-allowed t))
 927                (path-to-file
 928                 (car
 929                  (directory
 930                   (make-pathname
 931                    :directory (append (pathname-directory *common-root*)
 932                                       directory '(:wild-inferiors))
 933                    :name (first file-name-and-type)
 934                    :type (second file-name-and-type)))))
 935                stream)
 936           (setf (hunchentoot:content-type*) "image/png")
 937           (setf stream (hunchentoot:send-headers))
 938           (send-png
 939            stream path-to-file byte-position
 940            :bayer-pattern
 941            (apply #'vector (mapcar
 942                             #'parse-integer
 943                             (cl-utilities:split-sequence  #\, bayer-pattern)))
 944            :color-raiser
 945            (apply #'vector (mapcar
 946                             #'parse-number:parse-positive-real-number
 947                             (cl-utilities:split-sequence  #\, color-raiser)))
 948            :reversep (= 180 (parse-integer mounting-angle))))
 949       (condition (c)
 950         (cl-log:log-message
 951          :error "While serving image ~S: ~A" (hunchentoot:request-uri*) c)))))
 952
 953 (pushnew (hunchentoot:create-prefix-dispatcher "/phoros/lib/photo"
 954                                                'photo-handler)
 955          hunchentoot:*dispatch-table*)
 956
 957 ;;; for debugging; this is the multi-file OpenLayers
 958 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
 959           "/phoros/lib/openlayers/" "OpenLayers-2.10/")
 960          hunchentoot:*dispatch-table*)
 961
 962 (pushnew (hunchentoot:create-folder-dispatcher-and-handler "/phoros/lib/ol/" "ol/")
 963          hunchentoot:*dispatch-table*)
 964
 965 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
 966           (format nil "/phoros/lib/css-~A/" (phoros-version)) "css/") ;TODO: merge this style.css into public_html/style.css
 967          hunchentoot:*dispatch-table*)
 968
 969 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
 970           "/phoros/lib/public_html/" "public_html/")
 971          hunchentoot:*dispatch-table*)
 972
 973 (pushnew (hunchentoot:create-static-file-dispatcher-and-handler
 974           "/favicon.ico" "public_html/favicon.ico")
 975          hunchentoot:*dispatch-table*)
 976
 977 (hunchentoot:define-easy-handler
 978     (view :uri (format nil "/phoros/lib/view-~A" (phoros-version))
 979           :default-request-type :post)
 980     ()
 981   "Serve the client their main workspace."
 982   (if
 983    (hunchentoot:session-value 'authenticated-p)
 984    (who:with-html-output-to-string (s nil :prologue t :indent t)
 985      (:html
 986       (:head
 987        (:title (who:str
 988                 (concatenate
 989                  'string
 990                  "Phoros: " (hunchentoot:session-value
 991                              'presentation-project-name))))
 992        (if *use-multi-file-openlayers*
 993            (who:htm
 994             (:script :src "/phoros/lib/openlayers/lib/Firebug/firebug.js")
 995             (:script :src "/phoros/lib/openlayers/lib/OpenLayers.js"))
 996            (who:htm (:script :src "/phoros/lib/ol/OpenLayers.js")))
 997        (:link :rel "stylesheet"
 998               :href (format nil "/phoros/lib/css-~A/style.css"
 999                             (phoros-version))
1000               :type "text/css")
1001        (:script :src (format         ;variability in script name is
1002                       nil            ; supposed to fight browser cache
1003                       "/phoros/lib/phoros-~A-~A-~A.js"
1004                       (phoros-version)
1005                       (hunchentoot:session-value 'user-name)
1006                       (hunchentoot:session-value 'presentation-project-name)))
1007        (:script :src "http://maps.google.com/maps/api/js?sensor=false"))
1008       (:body
1009        :onload (ps (init))
1010        (:noscript (:b (:em "You can't do much without JavaScript here.")))
1011        (:h1 :id "title"
1012             "Phoros: " (who:str (hunchentoot:session-value 'user-full-name))
1013             (who:fmt " (~A)" (hunchentoot:session-value 'user-name))
1014             "with " (:span :id "user-role"
1015                            (who:str (hunchentoot:session-value 'user-role)))
1016             "permission on "
1017             (:span :id "presentation-project-name"
1018                    (who:str (hunchentoot:session-value
1019                              'presentation-project-name)))
1020             (:span :id "presentation-project-emptiness")
1021             (:span :id "phoros-version" :class "h1-right"
1022                    (who:fmt "v~A" (phoros-version))))
1023        (:div :class "controlled-streetmap"
1024              (:div :id "streetmap" :class "streetmap" :style "cursor:crosshair")
1025              (:div :id "streetmap-controls" :class "streetmap-controls"
1026                    (:div :id "streetmap-vertical-strut"
1027                          :class "streetmap-vertical-strut")
1028                    (:div :id "streetmap-layer-switcher"
1029                          :class "streetmap-layer-switcher")
1030                    (:div :id "streetmap-overview" :class "streetmap-overview")
1031                    (:div :id "streetmap-mouse-position"
1032                          :class "streetmap-mouse-position")
1033                    (:div :id "streetmap-zoom" :class "streetmap-zoom")))
1034        (:div :class "phoros-controls"
1035              (:div :id "real-phoros-controls"
1036                    (:h2 (:span :id "h2-controls") (:span :id "creator"))
1037                    (:div :id "point-attribute"
1038                          :class "combobox"
1039                          (:select :id "point-attribute-select"
1040                                   :name "point-attribute-select"
1041                                   :class "combobox-select"
1042                                   :onchange
1043                                   (ps-inline
1044                                    (consolidate-combobox "point-attribute"))
1045                                   :disabled t)
1046                          (:input :id "point-attribute-input"
1047                                  :name "point-attribute-input"
1048                                  :class "combobox-input"
1049                                  :onchange (ps-inline
1050                                             (unselect-combobox-selection
1051                                              "point-attribute"))
1052                                  :disabled t
1053                                  :type "text"))
1054                    ;; (:select :id "point-attribute" :disabled t
1055                    ;;          :size 1 :name "point-attribute")
1056                    (:input :id "point-numeric-description"
1057                            :class "vanilla-input"
1058                            :disabled t
1059                            :type "text" :name "point-numeric-description")
1060
1061                    (:div :id "point-description"
1062                          :class "combobox"
1063                          (:select :id "point-description-select"
1064                                   :name "point-description-select"
1065                                   :class "combobox-select"
1066                                   :onchange (ps-inline
1067                                              (consolidate-combobox
1068                                               "point-description"))
1069                                   :disabled t)
1070                          (:input :id "point-description-input"
1071                                  :name "point-description-input"
1072                                  :class "combobox-input"
1073                                  :onchange (ps-inline
1074                                             (unselect-combobox-selection
1075                                              "point-description"))
1076                                  :disabled t
1077                                  :type "text"))
1078                    (:button :id "delete-point-button" :disabled t
1079                             :type "button"
1080                             :onclick (ps-inline (delete-point))
1081                             "delete")
1082                    (:button :disabled t :id "finish-point-button"
1083                             :type "button"
1084                             (:b "finish"))
1085                    (:div :id "aux-point-distance-or-point-creation-date"
1086                          (:code :id "point-creation-date")
1087                          (:select :id "aux-point-distance" :disabled t
1088                                   :size 1 :name "aux-point-distance"
1089                                   :onchange (ps-inline
1090                                              (aux-point-distance-selected))
1091                                   :onclick (ps-inline
1092                                             (enable-aux-point-selection)))
1093                          (:div :id "include-aux-data"
1094                                (:label
1095                                 (:input :id "include-aux-data-p"
1096                                         :class "tight-input"
1097                                         :type "checkbox" :checked t
1098                                         :name "include-aux-data-p"
1099                                         :onchange (ps-inline
1100                                                    (flip-aux-data-inclusion)))
1101                                 "aux data")))
1102                    (:div :id "aux-data"
1103                          (:div :id "aux-numeric-list")
1104                          (:div :id "aux-text-list")))
1105              (:div :id "multiple-points-phoros-controls"
1106                    (:h2 "Multiple Points Selected")
1107                    (:p "You have selected multiple user points.")
1108                    (:p "Unselect all but one to edit or view its properties."))
1109              (:div :class "walk-mode-controls"
1110                    (:div :id "walk-mode"
1111                          (:label
1112                           (:input :id "walk-p"
1113                                   :class "tight-input"
1114                                   :type "checkbox" :checked nil
1115                                   :onchange (ps-inline
1116                                              (flip-walk-mode)))
1117                           "snap+walk"))
1118                    (:div :id "decrease-step-size"
1119                          :onclick (ps-inline (decrease-step-size)))
1120                    (:div :id "step-size"
1121                          :onclick (ps-inline (increase-step-size))
1122                          "4")
1123                    (:div :id "increase-step-size"
1124                          :onclick (ps-inline (increase-step-size))
1125                          :ondblclick (ps-inline (increase-step-size)
1126                                                 (increase-step-size)))
1127                    (:div :id "step-button" :disabled nil
1128                          :onclick (ps-inline (step))
1129                          :ondblclick (ps-inline (step t))
1130                          "step"))
1131              (:div :class "image-main-controls"
1132                    (:div :id "auto-zoom"
1133                          (:label
1134                           (:input :id "zoom-to-point-p"
1135                                   :class "tight-input"
1136                                   :type "checkbox" :checked t)
1137                           "auto zoom"))
1138                    (:div :id "zoom-images-to-max-extent"
1139                          :onclick (ps-inline (zoom-images-to-max-extent)))
1140                    (:div :id "remove-work-layers-button" :disabled t
1141                          :onclick (ps-inline (reset-layers-and-controls))
1142                          "start over")))
1143        (:div :class "help-div"
1144              (:button :id "download-user-points-button"
1145                       :type "button"
1146                       :onclick "self.location.href = \"/phoros/lib/user-points.json\""
1147                       "download points") ;TODO: offer other formats and maybe projections
1148              (:button :id "blurb-button"
1149                       :type "button"
1150                       :onclick (ps-inline
1151                                 (chain window
1152                                        (open
1153                                         (+ "/phoros/lib/blurb?openlayers-version="
1154                                            (@ *open-layers *version_number*))
1155                                         "About Phoros")))
1156                       (:img :src "/phoros/lib/public_html/phoros-logo-plain.png"
1157                             :alt "Phoros" :style "vertical-align:middle"
1158                             :height 20))
1159              (:button :id "logout-button"
1160                       :type "button"
1161                       :onclick (ps-inline (bye))
1162                       "bye")
1163              (:h2 :id "h2-help" "Help")
1164              (:div :id "help-display"))
1165        (:div :id "images" :style "clear:both"
1166              (loop
1167                 for i from 0 below *number-of-images* do
1168                 (who:htm
1169                  (:div :class "controlled-image"
1170                        (:div :id (format nil "image-~S-controls" i)
1171                              :class "image-controls"
1172                              (:div :id (format nil "image-~S-zoom" i)
1173                                    :class "image-zoom")
1174                              (:div :id (format nil "image-~S-layer-switcher" i)
1175                                    :class "image-layer-switcher")
1176                              (:div :id (format nil "image-~S-trigger-time" i)
1177                                    :class "image-trigger-time"))
1178                        (:div :id (format nil "image-~S" i)
1179                              :class "image" :style "cursor:crosshair"))))))))
1180    (hunchentoot:redirect
1181     (concatenate 'string "/phoros/" (hunchentoot:session-value
1182                                      'presentation-project-name))
1183     :add-session-id t)))
1184
1185 (hunchentoot:define-easy-handler
1186     (epipolar-line :uri "/phoros/lib/epipolar-line")
1187     ()
1188   "Receive vector of two sets of picture parameters, respond with
1189 JSON encoded epipolar-lines."
1190   (when (hunchentoot:session-value 'authenticated-p)
1191     (setf (hunchentoot:content-type*) "application/json")
1192     (let* ((data (json:decode-json-from-string (hunchentoot:raw-post-data))))
1193       (json:encode-json-to-string
1194        (photogrammetry :epipolar-line (first data) (second data))))))
1195
1196 (hunchentoot:define-easy-handler
1197     (estimated-positions :uri "/phoros/lib/estimated-positions")
1198     ()
1199   "Receive a two-part JSON vector comprising (1) a vector containing
1200 sets of picture-parameters with clicked (\"active\") points
1201 stored in :m, :n; and (2) a vector containing sets of
1202 picture-parameters; respond with a JSON encoded two-part vector
1203 comprising (1) a point in global coordinates; and (2) a vector of
1204 image coordinates (m, n) for the global point that correspond to the
1205 images from the received second vector.  TODO: report error on bad
1206 data (ex: points too far apart)."
1207   ;; TODO: global-point-for-display should probably contain a proj string in order to make sense of the (cartesian) standard deviations.
1208   (when (hunchentoot:session-value 'authenticated-p)
1209     (setf (hunchentoot:content-type*) "application/json")
1210     (let* ((data
1211             (json:decode-json-from-string (hunchentoot:raw-post-data)))
1212            (active-point-photo-parameters
1213             (first data))
1214            (number-of-active-points
1215             (length active-point-photo-parameters))
1216            (destination-photo-parameters
1217             (second data))
1218            (cartesian-system
1219             (cdr (assoc :cartesian-system
1220                         (first active-point-photo-parameters))))
1221            (global-point-cartesian
1222             (photogrammetry
1223              :multi-position-intersection active-point-photo-parameters))
1224            (global-point-geographic-radians
1225             (proj:cs2cs (list (cdr (assoc :x-global global-point-cartesian))
1226                               (cdr (assoc :y-global global-point-cartesian))
1227                               (cdr (assoc :z-global global-point-cartesian)))
1228                         :source-cs cartesian-system))
1229            (global-point-for-display    ;points geographic cs, degrees; std deviations in cartesian cs
1230             (pairlis '(:longitude :latitude :ellipsoid-height
1231                        :stdx-global :stdy-global :stdz-global
1232                        :input-size)
1233                      (list
1234                       (proj:radians-to-degrees
1235                        (first global-point-geographic-radians))
1236                       (proj:radians-to-degrees
1237                        (second global-point-geographic-radians))
1238                       (third global-point-geographic-radians)
1239                       (cdr (assoc :stdx-global global-point-cartesian))
1240                       (cdr (assoc :stdy-global global-point-cartesian))
1241                       (cdr (assoc :stdz-global global-point-cartesian))
1242                       number-of-active-points)))
1243            (image-coordinates
1244             (loop
1245                for i in destination-photo-parameters
1246                collect
1247                  (ignore-errors
1248                    (photogrammetry :reprojection i global-point-cartesian)))))
1249       (json:encode-json-to-string
1250         (list global-point-for-display image-coordinates)))))
1251
1252 (hunchentoot:define-easy-handler
1253     (user-point-positions :uri "/phoros/lib/user-point-positions")
1254     ()
1255   "Receive a two-part JSON vector comprising
1256 - a vector of user-point-id's and
1257 - a vector containing sets of picture-parameters;
1258 respond with a JSON object comprising the elements
1259 - image-points, a vector whose elements
1260    - correspond to the elements of the picture-parameters vector
1261      received and
1262    - are GeoJSON feature collections containing one point (in picture
1263      coordinates) for each user-point-id received;
1264 - user-point-count, the number of user-points we tried to fetch
1265   image-points for."
1266   (when (hunchentoot:session-value 'authenticated-p)
1267     (setf (hunchentoot:content-type*) "application/json")
1268     (let* ((user-point-table-name
1269             (user-point-table-name (hunchentoot:session-value
1270                                     'presentation-project-name)))
1271            (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
1272            (user-point-ids (first data))
1273            (user-point-count (length user-point-ids))
1274            (destination-photo-parameters (second data))
1275            (cartesian-system
1276             (cdr (assoc :cartesian-system
1277                         (first destination-photo-parameters)))) ;TODO: in rare cases, coordinate systems of the images shown may differ
1278            (user-points
1279             (with-connection *postgresql-credentials*
1280               (query
1281                (:select
1282                 (:as (:st_x 'coordinates) 'longitude)
1283                 (:as (:st_y 'coordinates) 'latitude)
1284                 (:as (:st_z 'coordinates) 'ellipsoid-height)
1285                 (:as 'user-point-id 'id) ;becomes fid on client
1286                 'attribute
1287                 'description
1288                 'numeric-description
1289                 'user-name
1290                 (:as (:to-char 'creation-date "IYYY-MM-DD HH24:MI:SS TZ")
1291                      'creation-date)
1292                 'aux-numeric
1293                 'aux-text
1294                 :from user-point-table-name :natural :left-join 'sys-user
1295                 :where (:in 'user-point-id (:set user-point-ids)))
1296                :plists)))
1297            (global-points-cartesian
1298             (loop
1299                for global-point-geographic in user-points
1300                collect
1301                (ignore-errors ;in case no destination-photo-parameters have been sent
1302                  (pairlis '(:x-global :y-global :z-global)
1303                           (proj:cs2cs
1304                            (list
1305                             (proj:degrees-to-radians
1306                              (getf global-point-geographic :longitude))
1307                             (proj:degrees-to-radians
1308                              (getf global-point-geographic :latitude))
1309                             (getf global-point-geographic :ellipsoid-height))
1310                            :destination-cs cartesian-system)))))
1311            (image-coordinates
1312             (loop
1313                for photo-parameter-set in destination-photo-parameters
1314                collect
1315                (encode-geojson-to-string
1316                 (loop
1317                    for global-point-cartesian in global-points-cartesian
1318                    for user-point in user-points
1319                    collect
1320                    (ignore-errors
1321                      (let ((photo-coordinates
1322                             (photogrammetry :reprojection
1323                                             photo-parameter-set
1324                                             global-point-cartesian))
1325                            (photo-point
1326                             user-point))
1327                        (setf (getf photo-point :x)
1328                              (cdr (assoc :m photo-coordinates)))
1329                        (setf (getf photo-point :y)
1330                              (cdr (assoc :n photo-coordinates)))
1331                        photo-point)))
1332                 :junk-keys '(:longitude :latitude :ellipsoid-height)))))
1333       (with-output-to-string (s)
1334         (json:with-object (s)
1335           (json:encode-object-member :user-point-count user-point-count s)
1336           (json:as-object-member (:image-points s)
1337             (json:with-array (s)
1338               (loop for i in image-coordinates do
1339                    (json:as-array-member (s) (princ i s))))))))))
1340
1341 (hunchentoot:define-easy-handler
1342     (multi-position-intersection :uri "/phoros/lib/intersection")
1343     ()
1344   "Receive vector of sets of picture parameters, respond with stuff."
1345   (when (hunchentoot:session-value 'authenticated-p)
1346     (setf (hunchentoot:content-type*) "application/json")
1347     (let* ((data (json:decode-json-from-string (hunchentoot:raw-post-data))))
1348       (json:encode-json-to-string
1349        (photogrammetry :multi-position-intersection data)))))