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 (define-condition superseded () ()
 354   (:documentation
 355    "Tell a thread to finish as soon as possible taking any shortcuts
 356    available."))
 357
 358 (hunchentoot:define-easy-handler
 359     (local-data :uri "/phoros/lib/local-data" :default-request-type :post)
 360     ()
 361   "Receive coordinates, respond with the count nearest json objects
 362 containing picture url, calibration parameters, and car position,
 363 wrapped in an array.  Wipe away any unfinished business first."
 364   (when (hunchentoot:session-value 'authenticated-p)
 365     (dolist (old-thread (hunchentoot:session-value 'recent-threads))
 366       (ignore-errors (bt:interrupt-thread old-thread #'(lambda () (signal 'superseded)))))
 367     (setf (hunchentoot:session-value 'recent-threads) nil)
 368     (push (bt:current-thread) (hunchentoot:session-value 'recent-threads))
 369     (setf (hunchentoot:content-type*) "application/json")
 370     (with-connection *postgresql-credentials*
 371       (let* ((presentation-project-id (hunchentoot:session-value
 372                                        'presentation-project-id))
 373              (common-table-names (common-table-names
 374                                   presentation-project-id))
 375              (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
 376              (longitude (cdr (assoc :longitude data)))
 377              (latitude (cdr (assoc :latitude data)))
 378              (count (cdr (assoc :count data)))
 379              (zoom (cdr (assoc :zoom data)))
 380              (snap-distance (* 1d-4 (expt 2 (- 22 zoom)))) ; assuming geographic coordinates
 381              (point-form (format nil "POINT(~F ~F)" longitude latitude))
 382              (result
 383               (handler-case
 384                   (ignore-errors
 385                     (or
 386                      (query
 387                       (sql-compile
 388                        `(:limit
 389                          (:order-by
 390                           (:union
 391                            ,@(loop
 392                                 for common-table-name in common-table-names
 393                                 for aggregate-view-name
 394                                 = (aggregate-view-name common-table-name)
 395                                 collect
 396                                 `(:select
 397                                   (:as (:st_distance 'coordinates
 398                                                      (:st_geomfromtext
 399                                                       ,point-form
 400                                                       ,*standard-coordinates*))
 401                                        'distance)
 402                                   'usable
 403                                   'recorded-device-id  ;debug
 404                                   'device-stage-of-life-id ;debug
 405                                   'generic-device-id       ;debug
 406                                   'directory
 407                                   'filename 'byte-position 'point-id
 408                                   (:as (:not (:is-null 'footprint))
 409                                        'footprintp)
 410                                   'trigger-time
 411                                   ;;'coordinates   ;the search target
 412                                   'longitude 'latitude 'ellipsoid-height
 413                                   'cartesian-system
 414                                   'east-sd 'north-sd 'height-sd
 415                                   'roll 'pitch 'heading
 416                                   'roll-sd 'pitch-sd 'heading-sd
 417                                   'sensor-width-pix 'sensor-height-pix
 418                                   'pix-size
 419                                   'bayer-pattern 'color-raiser
 420                                   'mounting-angle
 421                                   'dx 'dy 'dz 'omega 'phi 'kappa
 422                                   'c 'xh 'yh 'a1 'a2 'a3 'b1 'b2 'c1 'c2 'r0
 423                                   'b-dx 'b-dy 'b-dz 'b-rotx 'b-roty 'b-rotz
 424                                   'b-ddx 'b-ddy 'b-ddz
 425                                   'b-drotx 'b-droty 'b-drotz
 426                                   :from
 427                                   ',aggregate-view-name
 428                                   :where
 429                                   (:and
 430                                    (:= 'presentation-project-id
 431                                        ,presentation-project-id)
 432                                    (:st_contains
 433                                     'footprint
 434                                     (:limit
 435                                      (:select
 436                                       'centroid :from
 437                                       (:as
 438                                        (:order-by
 439                                         (:union
 440                                          ,@(loop
 441                                               for common-table-name
 442                                               in common-table-names
 443                                               for aggregate-view-name
 444                                               = (aggregate-view-name
 445                                                  common-table-name)
 446                                               collect
 447                                               `(:select
 448                                                 (:as
 449                                                  (:st_distance
 450                                                   (:st_centroid 'footprint)
 451                                                   (:st_geomfromtext
 452                                                    ,point-form
 453                                                    ,*standard-coordinates*))
 454                                                  'distance)
 455                                                 (:as (:st_centroid 'footprint)
 456                                                      'centroid)
 457                                                 :from
 458                                                 ',aggregate-view-name
 459                                                 :where
 460                                                 (:and
 461                                                  (:= 'presentation-project-id
 462                                                      ,presentation-project-id)
 463                                                  (:st_dwithin
 464                                                   'footprint
 465                                                   (:st_geomfromtext
 466                                                    ,point-form
 467                                                    ,*standard-coordinates*)
 468                                                   ,snap-distance)))))
 469                                         'distance)
 470                                        'centroids))
 471                                      1))))))
 472                           'distance)
 473                          ,count))
 474                       :alists))
 475                     (query
 476                      (sql-compile
 477                       `(:limit
 478                         (:order-by
 479                          (:union
 480                           ,@(loop
 481                                for common-table-name in common-table-names
 482                                for aggregate-view-name
 483                                = (aggregate-view-name common-table-name)
 484                                collect
 485                                `(:select
 486                                  (:as (:st_distance 'coordinates
 487                                                     (:st_geomfromtext
 488                                                      ,point-form
 489                                                      ,*standard-coordinates*))
 490                                       'distance)
 491                                  'usable
 492                                  'recorded-device-id  ;debug
 493                                  'device-stage-of-life-id ;debug
 494                                  'generic-device-id       ;debug
 495                                  'directory
 496                                  'filename 'byte-position 'point-id
 497                                  (:as (:not (:is-null 'footprint))
 498                                       'footprintp)
 499                                  'trigger-time
 500                                  ;;'coordinates   ;the search target
 501                                  'longitude 'latitude 'ellipsoid-height
 502                                  'cartesian-system
 503                                  'east-sd 'north-sd 'height-sd
 504                                  'roll 'pitch 'heading
 505                                  'roll-sd 'pitch-sd 'heading-sd
 506                                  'sensor-width-pix 'sensor-height-pix
 507                                  'pix-size
 508                                  'bayer-pattern 'color-raiser
 509                                  'mounting-angle
 510                                  'dx 'dy 'dz 'omega 'phi 'kappa
 511                                  'c 'xh 'yh 'a1 'a2 'a3 'b1 'b2 'c1 'c2 'r0
 512                                  'b-dx 'b-dy 'b-dz 'b-rotx 'b-roty 'b-rotz
 513                                  'b-ddx 'b-ddy 'b-ddz
 514                                  'b-drotx 'b-droty 'b-drotz
 515                                  :from
 516                                  ',aggregate-view-name
 517                                  :where
 518                                  (:and (:= 'presentation-project-id
 519                                            ,presentation-project-id)
 520                                        (:st_dwithin 'coordinates
 521                                                     (:st_geomfromtext
 522                                                      ,point-form
 523                                                      ,*standard-coordinates*)
 524                                                     ,snap-distance)))))
 525                          'distance)
 526                         ,count))
 527                      :alists))
 528                 (superseded () (terpri) nil))))
 529         (json:encode-json-to-string result)))))
 530
 531 (hunchentoot:define-easy-handler
 532     (store-point :uri "/phoros/lib/store-point" :default-request-type :post)
 533     ()
 534   "Receive point sent by user; store it into database."
 535   (when (hunchentoot:session-value 'authenticated-p)
 536     (let* ((presentation-project-name (hunchentoot:session-value
 537                                        'presentation-project-name))
 538            (user-id (hunchentoot:session-value 'user-id))
 539            (user-role (hunchentoot:session-value 'user-role))
 540            (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
 541            (longitude (cdr (assoc :longitude data)))
 542            (latitude (cdr (assoc :latitude data)))
 543            (ellipsoid-height (cdr (assoc :ellipsoid-height data)))
 544            (stdx-global (cdr (assoc :stdx-global data)))
 545            (stdy-global (cdr (assoc :stdy-global data)))
 546            (stdz-global (cdr (assoc :stdz-global data)))
 547            (input-size (cdr (assoc :input-size data)))
 548            (attribute (cdr (assoc :attribute data)))
 549            (description (cdr (assoc :description data)))
 550            (numeric-description (cdr (assoc :numeric-description data)))
 551            (point-form
 552             (format nil "SRID=4326; POINT(~S ~S ~S)"
 553                     longitude latitude ellipsoid-height))
 554            (aux-numeric-raw (cdr (assoc :aux-numeric data)))
 555            (aux-text-raw (cdr (assoc :aux-text data)))
 556            (aux-numeric (if aux-numeric-raw
 557                             (apply #'vector aux-numeric-raw)
 558                             :null))
 559            (aux-text (if aux-text-raw
 560                          (apply #'vector aux-text-raw)
 561                          :null))
 562            (user-point-table-name
 563             (user-point-table-name presentation-project-name)))
 564       (assert
 565        (not (string-equal user-role "read")) ;that is, "write" or "admin"
 566        () "No write permission.")
 567       (with-connection *postgresql-credentials*
 568         (assert
 569          (= 1 (execute (:insert-into user-point-table-name :set
 570                                      'user-id user-id
 571                                      'attribute attribute
 572                                      'description description
 573                                      'numeric-description numeric-description
 574                                      'creation-date 'current-timestamp
 575                                      'coordinates (:st_geomfromewkt point-form)
 576                                      'stdx-global stdx-global
 577                                      'stdy-global stdy-global
 578                                      'stdz-global stdz-global
 579                                      'input-size input-size
 580                                      'aux-numeric aux-numeric
 581                                      'aux-text aux-text)))
 582          () "No point stored.  This should not happen.")))))
 583
 584 (hunchentoot:define-easy-handler
 585     (update-point :uri "/phoros/lib/update-point" :default-request-type :post)
 586     ()
 587   "Update point sent by user in database."
 588   (when (hunchentoot:session-value 'authenticated-p)
 589     (let* ((presentation-project-name (hunchentoot:session-value
 590                                        'presentation-project-name))
 591            (user-id (hunchentoot:session-value 'user-id))
 592            (user-role (hunchentoot:session-value 'user-role))
 593            (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
 594            (user-point-id (cdr (assoc :user-point-id data)))
 595            (attribute (cdr (assoc :attribute data)))
 596            (description (cdr (assoc :description data)))
 597            (numeric-description (cdr (assoc :numeric-description data)))
 598            (user-point-table-name
 599             (user-point-table-name presentation-project-name)))
 600       (assert
 601        (not (string-equal user-role "read")) ;that is, "write" or "admin"
 602        () "No write permission.")
 603       (with-connection *postgresql-credentials*
 604         (assert
 605          (= 1 (execute (:update user-point-table-name :set
 606                                 'attribute attribute
 607                                 'description description
 608                                 'numeric-description numeric-description
 609                                 'creation-date 'current-timestamp
 610                                 :where (:and (:= 'user-point-id user-point-id)
 611                                              (:= (if (string-equal user-role
 612                                                                    "admin")
 613                                                      user-id
 614                                                      'user-id)
 615                                                  user-id)))))
 616          () "No point stored.  Did you try to update someone else's point ~
 617              without having admin permission?")))))
 618
 619 (hunchentoot:define-easy-handler
 620     (delete-point :uri "/phoros/lib/delete-point" :default-request-type :post)
 621     ()
 622   "Delete user point if user is allowed to do so."
 623   (when (hunchentoot:session-value 'authenticated-p)
 624     (let* ((presentation-project-name (hunchentoot:session-value
 625                                        'presentation-project-name))
 626            (user-id (hunchentoot:session-value 'user-id))
 627            (user-role (hunchentoot:session-value 'user-role))
 628            (user-point-table-name
 629             (user-point-table-name presentation-project-name))
 630            (data (json:decode-json-from-string (hunchentoot:raw-post-data))))
 631       (with-connection *postgresql-credentials*
 632         (assert
 633          (eql 1 (cond ((string-equal user-role "admin")
 634                      (execute (:delete-from user-point-table-name
 635                                             :where (:= 'user-point-id data))))
 636                     ((string-equal user-role "write")
 637                      (execute (:delete-from user-point-table-name
 638                                             :where (:and
 639                                                     (:= 'user-point-id data)
 640                                                     (:= 'user-id user-id)))))))
 641             () "No point deleted.  This should not happen.")))))
 642
 643 (defun common-table-names (presentation-project-id)
 644   "Return a list of common-table-names of table sets that contain data
 645 of presentation project with presentation-project-id."
 646   (handler-case
 647       (query
 648        (:select 'common-table-name
 649                 :distinct
 650                 :from 'sys-presentation 'sys-measurement 'sys-acquisition-project
 651                 :where (:and
 652                         (:= 'sys-presentation.presentation-project-id
 653                             presentation-project-id)
 654                         (:= 'sys-presentation.measurement-id
 655                             'sys-measurement.measurement-id)
 656                         (:= 'sys-measurement.acquisition-project-id
 657                             'sys-acquisition-project.acquisition-project-id)))
 658        :column)
 659     (condition (c)
 660       (cl-log:log-message
 661        :error
 662        "While fetching common-table-names of presentation-project-id ~D: ~A"
 663        presentation-project-id c))))
 664
 665 (defun encode-geojson-to-string (features &key junk-keys)
 666   "Encode a list of property lists into a GeoJSON FeatureCollection.
 667 Each property list must contain keys for coordinates, :x, :y, :z; it
 668 may contain a numeric point :id and zero or more pieces of extra
 669 information.  The extra information is stored as GeoJSON Feature
 670 properties.  Exclude property list elements with keys that are in
 671 junk-keys."
 672   (with-output-to-string (s)
 673     (json:with-object (s)
 674       (json:encode-object-member :type :*feature-collection s)
 675       (json:as-object-member (:features s)
 676         (json:with-array (s)
 677           (mapcar
 678            #'(lambda (point-with-properties)
 679                (dolist (junk-key junk-keys)
 680                  (remf point-with-properties junk-key))
 681                (destructuring-bind (&key x y z id &allow-other-keys) ;TODO: z probably bogus
 682                    point-with-properties
 683                  (json:as-array-member (s)
 684                    (json:with-object (s)
 685                      (json:encode-object-member :type :*feature s)
 686                      (json:as-object-member (:geometry s)
 687                        (json:with-object (s)
 688                          (json:encode-object-member :type :*point s)
 689                          (json:as-object-member (:coordinates s)
 690                            (json:encode-json (list x y z) s))))
 691                      (json:encode-object-member :id id s)
 692                      (json:as-object-member (:properties s)
 693                        (dolist (key '(:x :y :z :id))
 694                          (remf point-with-properties key))
 695                        (json:encode-json-plist point-with-properties s))))))
 696            features)))
 697       (json:encode-object-member :phoros-version (phoros-version) s))))
 698
 699 (defun box3d (bbox)
 700   "Return a WKT-compliant BOX3D string from string bbox."
 701   (concatenate 'string "BOX3D("
 702                (substitute #\Space #\,
 703                            (substitute #\Space #\, bbox :count 1)
 704                            :from-end t :count 1)
 705                ")"))
 706
 707 (hunchentoot:define-easy-handler (points :uri "/phoros/lib/points.json") (bbox)
 708   "Send a bunch of GeoJSON-encoded points from inside bbox to client."
 709   (when (hunchentoot:session-value 'authenticated-p)
 710     (setf (hunchentoot:content-type*) "application/json")
 711     (handler-case
 712         (with-connection *postgresql-credentials*
 713           (let* ((presentation-project-id
 714                   (hunchentoot:session-value 'presentation-project-id))
 715                  (common-table-names
 716                   (common-table-names presentation-project-id)))
 717             (encode-geojson-to-string
 718              (query
 719               (sql-compile
 720                `(:limit
 721                  (:order-by
 722                   (:union
 723                    ,@(loop
 724                         for common-table-name in common-table-names
 725                         for aggregate-view-name
 726                         = (point-data-table-name common-table-name)
 727                         ;; would have been nice, was too slow:
 728                         ;; = (aggregate-view-name common-table-name)
 729                         collect
 730                         `(:select
 731                           (:as (:st_x 'coordinates) x)
 732                           (:as (:st_y 'coordinates) y)
 733                           (:as (:st_z 'coordinates) z)
 734                           (:as 'point-id 'id) ;becomes fid on client
 735                           'random
 736                           :distinct-on 'random
 737                           :from ',aggregate-view-name
 738                           :natural :left-join 'sys-presentation
 739                           :where
 740                           (:and
 741                            (:= 'presentation-project-id
 742                                ,presentation-project-id)
 743                            (:&&
 744                             'coordinates
 745                             (:st_setsrid  (:type ,(box3d bbox) box3d)
 746                                           ,*standard-coordinates*))))))
 747                   random)
 748                  ,*number-of-features-per-layer*))
 749               :plists)
 750              :junk-keys '(:random))))
 751       (condition (c)
 752         (cl-log:log-message
 753          :error "While fetching points from inside bbox ~S: ~A"
 754          bbox c)))))
 755
 756 (hunchentoot:define-easy-handler (aux-points :uri "/phoros/lib/aux-points.json") (bbox)
 757   "Send a bunch of GeoJSON-encoded points from inside bbox to client."
 758   (when (hunchentoot:session-value 'authenticated-p)
 759     (setf (hunchentoot:content-type*) "application/json")
 760     (handler-case
 761         (let ((limit *number-of-features-per-layer*)
 762               (aux-view-name
 763                (aux-point-view-name (hunchentoot:session-value
 764                                      'presentation-project-name))))
 765           (encode-geojson-to-string
 766            (with-connection *postgresql-aux-credentials*
 767              (query
 768               (s-sql:sql-compile
 769                `(:limit
 770                  (:order-by
 771                   (:select
 772                    (:as (:st_x 'coordinates) 'x)
 773                    (:as (:st_y 'coordinates) 'y)
 774                    (:as (:st_z 'coordinates) 'z)
 775                    :from ,aux-view-name
 776                    :where (:&&
 777                            'coordinates
 778                            (:st_setsrid  (:type ,(box3d bbox) box3d)
 779                                          ,*standard-coordinates*)))
 780                   (:random))
 781                  ,limit))
 782               :plists))))
 783       (condition (c)
 784         (cl-log:log-message
 785          :error "While fetching aux-points from inside bbox ~S: ~A"
 786          bbox c)))))
 787
 788 (hunchentoot:define-easy-handler
 789     (aux-local-data :uri "/phoros/lib/aux-local-data"
 790                     :default-request-type :post)
 791     ()
 792   "Receive coordinates, respond with the count nearest json objects
 793 containing arrays aux-numeric, aux-text, and distance to the
 794 coordinates received, wrapped in an array."
 795   (when (hunchentoot:session-value 'authenticated-p)
 796     (setf (hunchentoot:content-type*) "application/json")
 797     (let* ((aux-view-name
 798             (aux-point-view-name (hunchentoot:session-value
 799                                   'presentation-project-name)))
 800            (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
 801            (longitude (cdr (assoc :longitude data)))
 802            (latitude (cdr (assoc :latitude data)))
 803            (count (cdr (assoc :count data)))
 804            (point-form
 805             (format nil "POINT(~F ~F)" longitude latitude))
 806            (snap-distance 1e-3) ;about 100 m, TODO: make this a defparameter
 807            (bounding-box
 808             (format nil "~A,~A,~A,~A"
 809                     (- longitude snap-distance)
 810                     (- latitude snap-distance)
 811                     (+ longitude snap-distance)
 812                     (+ latitude snap-distance))))
 813       (encode-geojson-to-string
 814        (ignore-errors
 815          (with-connection *postgresql-aux-credentials*
 816            (nsubst
 817             nil :null
 818             (query
 819              (s-sql:sql-compile
 820               `(:limit
 821                 (:order-by
 822                  (:select
 823                   (:as (:st_x 'coordinates) 'x)
 824                   (:as (:st_y 'coordinates) 'y)
 825                   (:as (:st_z 'coordinates) 'z)
 826                   aux-numeric
 827                   aux-text
 828                   (:as
 829                    (:st_distance
 830                     (:st_transform
 831                      'coordinates
 832                      ,*spherical-mercator*)
 833                     (:st_transform
 834                      (:st_geomfromtext ,point-form ,*standard-coordinates*)
 835                      ,*spherical-mercator*))
 836                    distance)
 837                   :from ',aux-view-name
 838                   :where (:&& 'coordinates
 839                               (:st_setsrid (:type
 840                                             ,(box3d bounding-box) box3d)
 841                                            ,*standard-coordinates*)))
 842                  'distance)
 843                 ,count))
 844              :plists))))))))
 845
 846 (hunchentoot:define-easy-handler
 847     (aux-local-linestring :uri "/phoros/lib/aux-local-linestring.json"
 848                           :default-request-type :post)
 849     ()
 850   "Receive longitude, latitude, radius, and step-size; respond
 851 with the a JSON object comprising the elements linestring (a WKT
 852 linestring stitched together of the nearest auxiliary points from
 853 within radius around coordinates), current-point (the point on
 854 linestring closest to coordinates), and previous-point and next-point
 855 \(points on linestring step-size before and after current-point
 856 respectively)."
 857   (when (hunchentoot:session-value 'authenticated-p)
 858     (setf (hunchentoot:content-type*) "application/json")
 859     (let* ((thread-aux-points-function-name
 860             (thread-aux-points-function-name (hunchentoot:session-value
 861                                               'presentation-project-name)))
 862            (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
 863            (longitude (cdr (assoc :longitude data)))
 864            (latitude (cdr (assoc :latitude data)))
 865            (radius (cdr (assoc :radius data)))
 866            (step-size (cdr (assoc :step-size data)))
 867            (azimuth (if (numberp (cdr (assoc :azimuth data)))
 868                         (cdr (assoc :azimuth data))
 869                         0))
 870            (point-form
 871             (format nil "POINT(~F ~F)" longitude latitude))
 872            (sql-response
 873             (ignore-errors
 874               (with-connection *postgresql-aux-credentials*
 875                 (nsubst
 876                  nil :null
 877                  (query
 878                   (sql-compile
 879                    `(:select '* :from
 880                              (,thread-aux-points-function-name
 881                               (:st_geomfromtext
 882                                ,point-form ,*standard-coordinates*)
 883                               ,radius
 884                               ,*number-of-points-per-aux-linestring*
 885                               ,step-size
 886                               ,azimuth
 887                               ,(proj:degrees-to-radians 91))))
 888                   :plist))))))
 889       (with-output-to-string (s)
 890         (json:with-object (s)
 891           (json:encode-object-member
 892            :linestring (getf sql-response :threaded-points) s)
 893           (json:encode-object-member
 894            :current-point (getf sql-response :current-point) s)
 895           (json:encode-object-member
 896            :previous-point (getf sql-response :back-point) s)
 897           (json:encode-object-member
 898            :next-point (getf sql-response :forward-point) s)
 899           (json:encode-object-member
 900            :azimuth (getf sql-response :new-azimuth) s))))))
 901
 902 (defun get-user-points (user-point-table-name &key
 903                         (bounding-box "-180,-90,180,90")
 904                         (limit :null)
 905                         (order-criterion 'id))
 906   "Return limit points from user-point-table-name in GeoJSON format,
 907 and the number of points returned."
 908   (let ((user-point-plist
 909          (query
 910           (s-sql:sql-compile
 911            `(:limit
 912              (:order-by
 913               (:select
 914                (:as (:st_x 'coordinates) 'x)
 915                (:as (:st_y 'coordinates) 'y)
 916                (:as (:st_z 'coordinates) 'z)
 917                (:as 'user-point-id 'id) ;becomes fid in OpenLayers
 918                'stdx-global 'stdy-global 'stdz-global
 919                'input-size
 920                'attribute 'description 'numeric-description
 921                'user-name
 922                (:as (:to-char 'creation-date
 923                               ,*user-point-creation-date-format*)
 924                     'creation-date)
 925                'aux-numeric 'aux-text
 926                :from ,user-point-table-name :natural :left-join 'sys-user
 927                :where (:&& 'coordinates
 928                            (:st_setsrid  (:type ,(box3d bounding-box) box3d)
 929                                          ,*standard-coordinates*)))
 930               ,order-criterion)
 931              ,limit))
 932           :plists)))
 933     (values
 934      (encode-geojson-to-string (nsubst nil :null user-point-plist))
 935      (length user-point-plist))))
 936
 937 (hunchentoot:define-easy-handler
 938     (user-points :uri "/phoros/lib/user-points.json")
 939     (bbox)
 940   "Send *number-of-features-per-layer* randomly chosen GeoJSON-encoded
 941 points from inside bbox to client.  If there is no bbox parameter,
 942 send all points."
 943   (when (hunchentoot:session-value 'authenticated-p)
 944     (setf (hunchentoot:content-type*) "application/json")
 945     (handler-case
 946         (let ((bounding-box (or bbox "-180,-90,180,90"))
 947               (limit (if bbox *number-of-features-per-layer* :null))
 948               (order-criterion (if bbox '(:random) 'id))
 949               (user-point-table-name
 950                (user-point-table-name (hunchentoot:session-value
 951                                        'presentation-project-name))))
 952           (with-connection *postgresql-credentials*
 953             (nth-value 0 (get-user-points user-point-table-name
 954                                           :bounding-box bounding-box
 955                                           :limit limit
 956                                           :order-criterion order-criterion))))
 957       (condition (c)
 958         (cl-log:log-message
 959          :error "While fetching user-points~@[ from inside bbox ~S~]: ~A"
 960          bbox c)))))
 961
 962 (hunchentoot:define-easy-handler
 963     (user-point-attributes :uri "/phoros/lib/user-point-attributes.json")
 964     ()
 965   "Send JSON object comprising arrays attributes and descriptions,
 966 each containing unique values called attribute and description
 967 respectively, and count being the frequency of value in the user point
 968 table."
 969   (when (hunchentoot:session-value 'authenticated-p)
 970     (setf (hunchentoot:content-type*) "application/json")
 971     (handler-case
 972         (let ((user-point-table-name
 973                (user-point-table-name (hunchentoot:session-value
 974                                        'presentation-project-name))))
 975           (with-connection *postgresql-credentials*
 976             (with-output-to-string (s)
 977               (json:with-object (s)
 978                 (json:as-object-member (:descriptions s)
 979                   (json:with-array (s)
 980                     (mapcar #'(lambda (x) (json:as-array-member (s)
 981                                             (json:encode-json-plist x s)))
 982                             (query
 983                              (:limit
 984                               (:order-by
 985                                (:select 'description
 986                                         (:count 'description)
 987                                         :from user-point-table-name
 988                                         :group-by 'description)
 989                                'description)
 990                               100)
 991                              :plists))))
 992                 (json:as-object-member (:attributes s)
 993                   (json:with-array (s)
 994                     (mapcar #'(lambda (x) (json:as-array-member (s)
 995                                             (json:encode-json-plist x s)))
 996                             (query (format nil "~
 997                               (SELECT attribute, count(attribute) ~
 998                                  FROM ((SELECT attribute FROM ~A) ~
 999                                        UNION ALL ~
1000                                        (SELECT attribute ~
1001                                           FROM (VALUES ('solitary'), ~
1002                                                        ('polyline'), ~
1003                                                        ('polygon')) ~
1004                                           AS defaults(attribute))) ~
1005                                         AS attributes_union(attribute) ~
1006                                  GROUP BY attribute) ~
1007                               ORDER BY attribute LIMIT 100"
1008                                            ;; Counts of solitary,
1009                                            ;; polyline, polygon may be
1010                                            ;; to big by one if we
1011                                            ;; collect them like this.
1012                            (s-sql:to-sql-name user-point-table-name))
1013                                    :plists))))))))
1014       (condition (c)
1015         (cl-log:log-message
1016          :error "While fetching user-point-attributes: ~A"
1017          c)))))
1018
1019 (hunchentoot:define-easy-handler photo-handler
1020     ((bayer-pattern :init-form "65280,16711680")
1021      (color-raiser :init-form "1,1,1")
1022      (mounting-angle :init-form "0"))
1023   "Serve an image from a .pictures file."
1024   (when (hunchentoot:session-value 'authenticated-p)
1025     (handler-case
1026         (progn
1027           (push (bt:current-thread)
1028                 (hunchentoot:session-value 'recent-threads))
1029           (let* ((s (cdr (cl-utilities:split-sequence
1030                           #\/
1031                           (hunchentoot:script-name*)
1032                           :remove-empty-subseqs t)))
1033                  (directory (last (butlast s 2)))
1034                  (file-name-and-type (cl-utilities:split-sequence
1035                                       #\. (first (last s 2))))
1036                  (byte-position (parse-integer (car (last s)) :junk-allowed t))
1037                  (path-to-file
1038                   (car
1039                    (directory
1040                     (make-pathname
1041                      :directory (append (pathname-directory *common-root*)
1042                                         directory '(:wild-inferiors))
1043                      :name (first file-name-and-type)
1044                      :type (second file-name-and-type)))))
1045                  stream)
1046             (setf (hunchentoot:header-out 'cache-control)
1047                   (format nil "max-age=~D" (* 3600 24 7)))
1048             (setf (hunchentoot:content-type*) "image/png")
1049             (setf stream (hunchentoot:send-headers))
1050             (send-png
1051              stream path-to-file byte-position
1052              :bayer-pattern
1053              (apply #'vector (mapcar
1054                               #'parse-integer
1055                               (cl-utilities:split-sequence
1056                                #\, bayer-pattern)))
1057              :color-raiser
1058              (apply #'vector (mapcar
1059                               #'parse-number:parse-positive-real-number
1060                               (cl-utilities:split-sequence  #\, color-raiser)))
1061              :reversep (= 180 (parse-integer mounting-angle)))))
1062       (superseded () (terpri) nil)
1063       (condition (c)
1064         (cl-log:log-message
1065          :error "While serving image ~S: ~A" (hunchentoot:request-uri*) c)))))
1066
1067 (pushnew (hunchentoot:create-prefix-dispatcher "/phoros/lib/photo"
1068                                                'photo-handler)
1069          hunchentoot:*dispatch-table*)
1070
1071 ;;; for debugging; this is the multi-file OpenLayers
1072 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1073           "/phoros/lib/openlayers/" "OpenLayers-2.10/")
1074          hunchentoot:*dispatch-table*)
1075
1076 (pushnew (hunchentoot:create-folder-dispatcher-and-handler "/phoros/lib/ol/" "ol/")
1077          hunchentoot:*dispatch-table*)
1078
1079 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1080           (format nil "/phoros/lib/css-~A/" (phoros-version)) "css/") ;TODO: merge this style.css into public_html/style.css
1081          hunchentoot:*dispatch-table*)
1082
1083 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1084           "/phoros/lib/public_html/" "public_html/")
1085          hunchentoot:*dispatch-table*)
1086
1087 (pushnew (hunchentoot:create-static-file-dispatcher-and-handler
1088           "/favicon.ico" "public_html/favicon.ico")
1089          hunchentoot:*dispatch-table*)
1090
1091 (hunchentoot:define-easy-handler
1092     (view :uri (format nil "/phoros/lib/view-~A" (phoros-version))
1093           :default-request-type :post)
1094     ()
1095   "Serve the client their main workspace."
1096   (if
1097    (hunchentoot:session-value 'authenticated-p)
1098    (who:with-html-output-to-string (s nil :prologue t :indent t)
1099      (:html
1100       (:head
1101        (:title (who:str
1102                 (concatenate
1103                  'string
1104                  "Phoros: " (hunchentoot:session-value
1105                              'presentation-project-name))))
1106        (if *use-multi-file-openlayers*
1107            (who:htm
1108             (:script :src "/phoros/lib/openlayers/lib/Firebug/firebug.js")
1109             (:script :src "/phoros/lib/openlayers/lib/OpenLayers.js"))
1110            (who:htm (:script :src "/phoros/lib/ol/OpenLayers.js")))
1111        (:link :rel "stylesheet"
1112               :href (format nil "/phoros/lib/css-~A/style.css"
1113                             (phoros-version))
1114               :type "text/css")
1115        (:script :src (format         ;variability in script name is
1116                       nil            ; supposed to fight browser cache
1117                       "/phoros/lib/phoros-~A-~A-~A.js"
1118                       (phoros-version)
1119                       (hunchentoot:session-value 'user-name)
1120                       (hunchentoot:session-value 'presentation-project-name)))
1121        (:script :src "http://maps.google.com/maps/api/js?sensor=false"))
1122       (:body
1123        :onload (ps (init))
1124        (:noscript (:b (:em "You can't do much without JavaScript here.")))
1125        (:h1 :id "title"
1126             "Phoros: " (who:str (hunchentoot:session-value 'user-full-name))
1127             (who:fmt " (~A)" (hunchentoot:session-value 'user-name))
1128             "with " (:span :id "user-role"
1129                            (who:str (hunchentoot:session-value 'user-role)))
1130             "permission on "
1131             (:span :id "presentation-project-name"
1132                    (who:str (hunchentoot:session-value
1133                              'presentation-project-name)))
1134             (:span :id "presentation-project-emptiness")
1135             (:span :id "phoros-version" :class "h1-right"
1136                    (who:fmt "v~A" (phoros-version))))
1137        (:div :class "controlled-streetmap"
1138              (:div :id "streetmap" :class "streetmap" :style "cursor:crosshair")
1139              (:div :id "streetmap-controls" :class "streetmap-controls"
1140                    (:div :id "streetmap-vertical-strut"
1141                          :class "streetmap-vertical-strut")
1142                    (:div :id "streetmap-layer-switcher"
1143                          :class "streetmap-layer-switcher")
1144                    (:div :id "streetmap-overview" :class "streetmap-overview")
1145                    (:div :id "streetmap-mouse-position"
1146                          :class "streetmap-mouse-position")
1147                    (:div :id "streetmap-zoom" :class "streetmap-zoom")))
1148        (:div :class "phoros-controls"
1149              (:div :id "real-phoros-controls"
1150                    (:h2 (:span :id "h2-controls") (:span :id "creator"))
1151                    (:div :id "point-attribute"
1152                          :class "combobox"
1153                          (:select :id "point-attribute-select"
1154                                   :name "point-attribute-select"
1155                                   :class "combobox-select"
1156                                   :onchange
1157                                   (ps-inline
1158                                    (consolidate-combobox "point-attribute"))
1159                                   :disabled t)
1160                          (:input :id "point-attribute-input"
1161                                  :name "point-attribute-input"
1162                                  :class "combobox-input"
1163                                  :onchange (ps-inline
1164                                             (unselect-combobox-selection
1165                                              "point-attribute"))
1166                                  :disabled t
1167                                  :type "text"))
1168                    ;; (:select :id "point-attribute" :disabled t
1169                    ;;          :size 1 :name "point-attribute")
1170                    (:input :id "point-numeric-description"
1171                            :class "vanilla-input"
1172                            :disabled t
1173                            :type "text" :name "point-numeric-description")
1174
1175                    (:div :id "point-description"
1176                          :class "combobox"
1177                          (:select :id "point-description-select"
1178                                   :name "point-description-select"
1179                                   :class "combobox-select"
1180                                   :onchange (ps-inline
1181                                              (consolidate-combobox
1182                                               "point-description"))
1183                                   :disabled t)
1184                          (:input :id "point-description-input"
1185                                  :name "point-description-input"
1186                                  :class "combobox-input"
1187                                  :onchange (ps-inline
1188                                             (unselect-combobox-selection
1189                                              "point-description"))
1190                                  :disabled t
1191                                  :type "text"))
1192                    (:button :id "delete-point-button" :disabled t
1193                             :type "button"
1194                             :onclick (ps-inline (delete-point))
1195                             "delete")
1196                    (:button :disabled t :id "finish-point-button"
1197                             :type "button"
1198                             (:b "finish"))
1199                    (:div :id "aux-point-distance-or-point-creation-date"
1200                          (:code :id "point-creation-date")
1201                          (:select :id "aux-point-distance" :disabled t
1202                                   :size 1 :name "aux-point-distance"
1203                                   :onchange (ps-inline
1204                                              (aux-point-distance-selected))
1205                                   :onclick (ps-inline
1206                                             (enable-aux-point-selection)))
1207                          (:div :id "include-aux-data"
1208                                (:label
1209                                 (:input :id "include-aux-data-p"
1210                                         :class "tight-input"
1211                                         :type "checkbox" :checked t
1212                                         :name "include-aux-data-p"
1213                                         :onchange (ps-inline
1214                                                    (flip-aux-data-inclusion)))
1215                                 "aux data")))
1216                    (:div :id "aux-data"
1217                          (:div :id "aux-numeric-list")
1218                          (:div :id "aux-text-list")))
1219              (:div :id "multiple-points-phoros-controls"
1220                    (:h2 "Multiple Points Selected")
1221                    (:p "You have selected multiple user points.")
1222                    (:p "Unselect all but one to edit or view its properties."))
1223              (:div :class "walk-mode-controls"
1224                    (:div :id "walk-mode"
1225                          (:label
1226                           (:input :id "walk-p"
1227                                   :class "tight-input"
1228                                   :type "checkbox" :checked nil
1229                                   :onchange (ps-inline
1230                                              (flip-walk-mode)))
1231                           "snap+walk"))
1232                    (:div :id "decrease-step-size"
1233                          :onclick (ps-inline (decrease-step-size)))
1234                    (:div :id "step-size"
1235                          :onclick (ps-inline (increase-step-size))
1236                          "4")
1237                    (:div :id "increase-step-size"
1238                          :onclick (ps-inline (increase-step-size))
1239                          :ondblclick (ps-inline (increase-step-size)
1240                                                 (increase-step-size)))
1241                    (:div :id "step-button" :disabled nil
1242                          :onclick (ps-inline (step))
1243                          :ondblclick (ps-inline (step t))
1244                          "step"))
1245              (:div :class "image-main-controls"
1246                    (:div :id "auto-zoom"
1247                          (:label
1248                           (:input :id "zoom-to-point-p"
1249                                   :class "tight-input"
1250                                   :type "checkbox" :checked t)
1251                           "auto zoom"))
1252                    (:div :id "zoom-images-to-max-extent"
1253                          :onclick (ps-inline (zoom-images-to-max-extent)))
1254                    (:div :id "no-footprints-p"
1255                          (:b "?"))
1256                    (:div :id "remove-work-layers-button" :disabled t
1257                          :onclick (ps-inline (reset-layers-and-controls))
1258                          "start over")))
1259        (:div :class "help-div"
1260              (:button :id "download-user-points-button"
1261                       :type "button"
1262                       :onclick "self.location.href = \"/phoros/lib/user-points.json\""
1263                       "download points") ;TODO: offer other formats and maybe projections
1264              (:button :id "blurb-button"
1265                       :type "button"
1266                       :onclick (ps-inline
1267                                 (chain window
1268                                        (open
1269                                         (+ "/phoros/lib/blurb?openlayers-version="
1270                                            (@ *open-layers *version_number*))
1271                                         "About Phoros")))
1272                       (:img :src "/phoros/lib/public_html/phoros-logo-plain.png"
1273                             :alt "Phoros" :style "vertical-align:middle"
1274                             :height 20))
1275              (:button :id "logout-button"
1276                       :type "button"
1277                       :onclick (ps-inline (bye))
1278                       "bye")
1279              (:h2 :id "h2-help" "Help")
1280              (:div :id "help-display"))
1281        (:div :id "images" :style "clear:both"
1282              (loop
1283                 for i from 0 below *number-of-images* do
1284                 (who:htm
1285                  (:div :class "controlled-image"
1286                        (:div :id (format nil "image-~S-controls" i)
1287                              :class "image-controls"
1288                              (:div :id (format nil "image-~S-zoom" i)
1289                                    :class "image-zoom")
1290                              (:div :id (format nil "image-~S-layer-switcher" i)
1291                                    :class "image-layer-switcher")
1292                              (:div :id (format nil "image-~S-usable" i)
1293                                    :class "image-usable"
1294                                    (:b "!"))
1295                              (:div :id (format nil "image-~S-trigger-time" i)
1296                                    :class "image-trigger-time"))
1297                        (:div :id (format nil "image-~S" i)
1298                              :class "image" :style "cursor:crosshair"))))))))
1299    (hunchentoot:redirect
1300     (concatenate 'string "/phoros/" (hunchentoot:session-value
1301                                      'presentation-project-name))
1302     :add-session-id t)))
1303
1304 (hunchentoot:define-easy-handler
1305     (epipolar-line :uri "/phoros/lib/epipolar-line")
1306     ()
1307   "Receive vector of two sets of picture parameters, respond with
1308 JSON encoded epipolar-lines."
1309   (when (hunchentoot:session-value 'authenticated-p)
1310     (setf (hunchentoot:content-type*) "application/json")
1311     (let* ((data (json:decode-json-from-string (hunchentoot:raw-post-data))))
1312       (json:encode-json-to-string
1313        (photogrammetry :epipolar-line (first data) (second data))))))
1314
1315 (hunchentoot:define-easy-handler
1316     (estimated-positions :uri "/phoros/lib/estimated-positions")
1317     ()
1318   "Receive a two-part JSON vector comprising (1) a vector containing
1319 sets of picture-parameters with clicked (\"active\") points
1320 stored in :m, :n; and (2) a vector containing sets of
1321 picture-parameters; respond with a JSON encoded two-part vector
1322 comprising (1) a point in global coordinates; and (2) a vector of
1323 image coordinates (m, n) for the global point that correspond to the
1324 images from the received second vector.  TODO: report error on bad
1325 data (ex: points too far apart)."
1326   ;; TODO: global-point-for-display should probably contain a proj string in order to make sense of the (cartesian) standard deviations.
1327   (when (hunchentoot:session-value 'authenticated-p)
1328     (setf (hunchentoot:content-type*) "application/json")
1329     (let* ((data
1330             (json:decode-json-from-string (hunchentoot:raw-post-data)))
1331            (active-point-photo-parameters
1332             (first data))
1333            (number-of-active-points
1334             (length active-point-photo-parameters))
1335            (destination-photo-parameters
1336             (second data))
1337            (cartesian-system
1338             (cdr (assoc :cartesian-system
1339                         (first active-point-photo-parameters))))
1340            (global-point-cartesian
1341             (photogrammetry
1342              :multi-position-intersection active-point-photo-parameters))
1343            (global-point-geographic-radians
1344             (proj:cs2cs (list (cdr (assoc :x-global global-point-cartesian))
1345                               (cdr (assoc :y-global global-point-cartesian))
1346                               (cdr (assoc :z-global global-point-cartesian)))
1347                         :source-cs cartesian-system))
1348            (global-point-for-display    ;points geographic cs, degrees; std deviations in cartesian cs
1349             (pairlis '(:longitude :latitude :ellipsoid-height
1350                        :stdx-global :stdy-global :stdz-global
1351                        :input-size)
1352                      (list
1353                       (proj:radians-to-degrees
1354                        (first global-point-geographic-radians))
1355                       (proj:radians-to-degrees
1356                        (second global-point-geographic-radians))
1357                       (third global-point-geographic-radians)
1358                       (cdr (assoc :stdx-global global-point-cartesian))
1359                       (cdr (assoc :stdy-global global-point-cartesian))
1360                       (cdr (assoc :stdz-global global-point-cartesian))
1361                       number-of-active-points)))
1362            (image-coordinates
1363             (loop
1364                for i in destination-photo-parameters
1365                collect
1366                  (ignore-errors
1367                    (photogrammetry :reprojection i global-point-cartesian)))))
1368       (json:encode-json-to-string
1369         (list global-point-for-display image-coordinates)))))
1370
1371 (hunchentoot:define-easy-handler
1372     (user-point-positions :uri "/phoros/lib/user-point-positions")
1373     ()
1374   "Receive a two-part JSON vector comprising
1375 - a vector of user-point-id's and
1376 - a vector containing sets of picture-parameters;
1377 respond with a JSON object comprising the elements
1378 - image-points, a vector whose elements
1379    - correspond to the elements of the picture-parameters vector
1380      received and
1381    - are GeoJSON feature collections containing one point (in picture
1382      coordinates) for each user-point-id received;
1383 - user-point-count, the number of user-points we tried to fetch
1384   image-points for."
1385   (when (hunchentoot:session-value 'authenticated-p)
1386     (setf (hunchentoot:content-type*) "application/json")
1387     (let* ((user-point-table-name
1388             (user-point-table-name (hunchentoot:session-value
1389                                     'presentation-project-name)))
1390            (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
1391            (user-point-ids (first data))
1392            (user-point-count (length user-point-ids))
1393            (destination-photo-parameters (second data))
1394            (cartesian-system
1395             (cdr (assoc :cartesian-system
1396                         (first destination-photo-parameters)))) ;TODO: in rare cases, coordinate systems of the images shown may differ
1397            (user-points
1398             (with-connection *postgresql-credentials*
1399               (query
1400                (:select
1401                 (:as (:st_x 'coordinates) 'longitude)
1402                 (:as (:st_y 'coordinates) 'latitude)
1403                 (:as (:st_z 'coordinates) 'ellipsoid-height)
1404                 (:as 'user-point-id 'id) ;becomes fid on client
1405                 'attribute
1406                 'description
1407                 'numeric-description
1408                 'user-name
1409                 (:as (:to-char 'creation-date "IYYY-MM-DD HH24:MI:SS TZ")
1410                      'creation-date)
1411                 'aux-numeric
1412                 'aux-text
1413                 :from user-point-table-name :natural :left-join 'sys-user
1414                 :where (:in 'user-point-id (:set user-point-ids)))
1415                :plists)))
1416            (global-points-cartesian
1417             (loop
1418                for global-point-geographic in user-points
1419                collect
1420                (ignore-errors ;in case no destination-photo-parameters have been sent
1421                  (pairlis '(:x-global :y-global :z-global)
1422                           (proj:cs2cs
1423                            (list
1424                             (proj:degrees-to-radians
1425                              (getf global-point-geographic :longitude))
1426                             (proj:degrees-to-radians
1427                              (getf global-point-geographic :latitude))
1428                             (getf global-point-geographic :ellipsoid-height))
1429                            :destination-cs cartesian-system)))))
1430            (image-coordinates
1431             (loop
1432                for photo-parameter-set in destination-photo-parameters
1433                collect
1434                (encode-geojson-to-string
1435                 (loop
1436                    for global-point-cartesian in global-points-cartesian
1437                    for user-point in user-points
1438                    collect
1439                    (ignore-errors
1440                      (let ((photo-coordinates
1441                             (photogrammetry :reprojection
1442                                             photo-parameter-set
1443                                             global-point-cartesian))
1444                            (photo-point
1445                             user-point))
1446                        (setf (getf photo-point :x)
1447                              (cdr (assoc :m photo-coordinates)))
1448                        (setf (getf photo-point :y)
1449                              (cdr (assoc :n photo-coordinates)))
1450                        photo-point)))
1451                 :junk-keys '(:longitude :latitude :ellipsoid-height)))))
1452       (with-output-to-string (s)
1453         (json:with-object (s)
1454           (json:encode-object-member :user-point-count user-point-count s)
1455           (json:as-object-member (:image-points s)
1456             (json:with-array (s)
1457               (loop for i in image-coordinates do
1458                    (json:as-array-member (s) (princ i s))))))))))
1459
1460 (hunchentoot:define-easy-handler
1461     (multi-position-intersection :uri "/phoros/lib/intersection")
1462     ()
1463   "Receive vector of sets of picture parameters, respond with stuff."
1464   (when (hunchentoot:session-value 'authenticated-p)
1465     (setf (hunchentoot:content-type*) "application/json")
1466     (let* ((data (json:decode-json-from-string (hunchentoot:raw-post-data))))
1467       (json:encode-json-to-string
1468        (photogrammetry :multi-position-intersection data)))))