1 ;;; PHOROS -- Photogrammetric Road Survey
2 ;;; Copyright (C) 2010, 2011, 2012, 2016 Bert Burgemeister
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.
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.
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.
20 (setf *js-target-version
* 1.8)
22 ;;; Debug helpers. TODO: remove them.
23 (defparameter *t
* nil
)
24 (defparameter *tt
* nil
)
26 (cffi:define-foreign-library phoml
27 (:unix
(:or
"./libphoml.so"
28 "./phoml/lib/libphoml.so"))
29 (t (:default
"libphoml")))
31 (defparameter *standard-coordinates
* 4326
32 "EPSG code of the coordinate system that we use for communication.")
34 (defparameter *spherical-mercator
* 900913
35 "EPSG code of the coordinate system used for some distance calculations.")
37 (defvar *postgresql-credentials
* nil
38 "A list: (database user password host &key (port 5432) use-ssl).")
40 (defvar *postgresql-aux-credentials
* nil
41 "A list: (database user password host &key (port 5432) use-ssl).")
43 (defparameter *photogrammetry-mutex
* (bt:make-lock
"photogrammetry"))
45 (setf *read-default-float-format
* 'double-float
)
47 (defparameter *phoros-server
* nil
"Hunchentoot acceptor.")
49 (defparameter *common-root
* nil
50 "Root directory; contains directories of measuring data.")
52 (defparameter *proxy-root
* "phoros"
53 "First directory element of the server URL. Must correspond to the
54 proxy configuration if Phoros is hidden behind a proxy.")
56 (defparameter *login-intro
* nil
57 "A few friendly words to be shown below the login form.")
59 (defparameter *number-of-images
* 4
60 "Number of photos shown to the HTTP client.")
62 (defparameter *aux-numeric-labels
* nil
63 "Labels for auxiliary numeric data rows shown to the HTTP client.")
65 (defparameter *aux-text-labels
* nil
66 "Labels for auxiliary text data rows shown to the HTTP client.")
68 (defparameter *browser-cache-max-age
* (* 3600 24 7)
69 "Value x for Cache-Control:max-age=x, for images on client.")
71 (defparameter *number-of-features-per-layer
* 500
72 "What we think a browser can swallow.")
74 (defparameter *number-of-points-per-aux-linestring
* 500
75 "What we think a browser can swallow.")
77 (defparameter *user-point-creation-date-format
* "IYYY-MM-DD HH24:MI:SS TZ"
78 "SQL date format used for display and GeoJSON export of user points.")
80 (defparameter *phoros-version
*
81 (asdf:component-version
(asdf:find-system
:phoros
))
82 "Phoros version as defined in system definition.")
84 (defparameter *aggregate-view-columns
*
86 'recorded-device-id
;debug
87 'device-stage-of-life-id
;debug
88 'generic-device-id
;debug
91 'filename
'byte-position
'point-id
93 ;;'coordinates ;the search target
94 'longitude
'latitude
'ellipsoid-height
96 'east-sd
'north-sd
'height-sd
98 'roll-sd
'pitch-sd
'heading-sd
99 'sensor-width-pix
'sensor-height-pix
101 'bayer-pattern
'color-raiser
103 'dx
'dy
'dz
'omega
'phi
'kappa
104 'c
'xh
'yh
'a1
'a2
'a3
'b1
'b2
'c1
'c2
'r0
105 'b-dx
'b-dy
'b-dz
'b-rotx
'b-roty
'b-rotz
107 'b-drotx
'b-droty
'b-drotz
)
108 "Most of the column names of aggregate-view.")
110 (defun version-number-parts (dotted-string)
111 "Return the three version number components of something like
114 (values-list (mapcar #'parse-integer
115 (cl-utilities:split-sequence
#\. dotted-string
)))))
117 (defun phoros-version (&key major minor revision
)
118 "Return version of this program, either one integer part as denoted by
119 the key argument, or the whole dotted string."
120 (multiple-value-bind (major-number minor-number revision-number
)
121 (version-number-parts *phoros-version
*)
122 (cond (major major-number
)
124 (revision revision-number
)
125 (t *phoros-version
*))))
127 (defun check-dependencies ()
128 "Say OK if the necessary external dependencies are available."
131 (geographic-to-utm 33 13 52) ;check cs2cs
132 (phoros-photogrammetry:del-all
) ;check photogrammetry
133 #+phoros-uses-imread.so
134 (assert (= 42 (imread:ping
42))) ;check imread
135 (initialize-leap-seconds) ;check source of leap second info
136 (format *error-output
* "~&OK~%"))
137 (error (e) (format *error-output
* "~A~&" e
))))
139 (defun muffle-postgresql-warnings ()
140 "For current DB, silence PostgreSQL's warnings about implicitly
142 (unless (cli:verbosity-level
:postgresql-warnings
)
143 (execute "SET client_min_messages TO ERROR;")))
145 (defun check-db (db-credentials)
146 "Check postgresql connection. Return t if successful; show error on
147 *error-output* otherwise. db-credentials is a list like so: (database
148 user password host &key (port 5432) use-ssl)."
151 (setf connection
(apply #'connect db-credentials
))
152 (error (e) (format *error-output
* "Database connection ~S failed: ~A~&"
155 (disconnect connection
)
158 (defun ignore-warnings (c) (declare (ignore c
)) (muffle-warning))
160 (defmethod hunchentoot:session-cookie-name
(acceptor)
161 (declare (ignore acceptor
))
164 (defun start-server (&key
(proxy-root "phoros") (http-port 8080) address
166 "Start the presentation project server which listens on http-port
167 at address. Address defaults to all addresses of the local machine."
168 (setf *phoros-server
*
169 (make-instance 'hunchentoot
:easy-acceptor
172 :document-root
(ensure-directories-exist
174 :error-template-directory
(ensure-directories-exist
175 "unexpected_html/errors/")))
176 (setf hunchentoot
:*session-max-time
* (* 3600 24))
177 (setf *proxy-root
* proxy-root
)
178 (setf *common-root
* common-root
)
179 (check-db *postgresql-credentials
*)
180 (with-connection *postgresql-credentials
*
181 (assert-phoros-db-major-version))
182 (hunchentoot:reset-session-secret
)
183 (hunchentoot:start
*phoros-server
*))
185 (defun stop-server () (hunchentoot:stop
*phoros-server
*))
187 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
188 (register-sql-operators :2+-ary
:&& :overlaps
))
190 (hunchentoot:define-easy-handler phoros-handler
()
191 "First HTTP contact: if necessary, check credentials, establish new
193 (with-connection *postgresql-credentials
*
194 (let* ((s (cl-utilities:split-sequence
196 (hunchentoot:script-name
*)
197 :remove-empty-subseqs t
))
198 (presentation-project-name (second s
))
199 (presentation-project-id
201 (presentation-project-id-from-name presentation-project-name
))))
203 ;; TODO: remove the following line (which seems to function as a
204 ;; wakeup call of sorts)...
205 (get-dao 'sys-user-role
0 0)
206 ;; ...and make sure the following error doesn't occur any longer
207 ;; while accessing the HTTP server:
208 ;; #<POSTMODERN:DAO-CLASS PHOROS::SYS-USER-ROLE> cannot be printed readably.
211 ((null presentation-project-id
)
212 (setf (hunchentoot:return-code
*) hunchentoot
:+http-not-found
+))
213 ((and (equal (hunchentoot:session-value
'presentation-project-name
)
214 presentation-project-name
)
215 (hunchentoot:session-value
'authenticated-p
))
216 (hunchentoot:redirect
217 (format nil
"/~A/lib/view-~A"
224 (setf (hunchentoot:session-value
'presentation-project-name
)
225 presentation-project-name
)
226 (setf (hunchentoot:session-value
'presentation-project-id
)
227 presentation-project-id
)
228 (setf (hunchentoot:session-value
'presentation-project-bbox
)
231 (bounding-box (get-dao 'sys-presentation-project
232 presentation-project-name
)))))
233 (if (or (null bbox
) (eq :null bbox
))
236 (setf (hunchentoot:session-value
'aux-data-p
)
237 (with-connection *postgresql-aux-credentials
*
238 (view-exists-p (aux-point-view-name
239 presentation-project-name
))))
240 (setf (hunchentoot:session-value
'number-of-threads
) 0)
241 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
243 :style
"font-family:sans-serif;"
245 :method
"post" :enctype
"multipart/form-data"
246 :action
(format nil
"/~A/lib/authenticate"
250 (:legend
(:b
(:a
:href
"http://phoros.boundp.org"
251 :style
"text-decoration:none;"
253 (who:fmt
" [~A]" presentation-project-name
)))
255 (:b
(:em
"You can't do much without JavaScript there.")))
258 (:input
:type
"text" :name
"user-name"))
261 (:input
:type
"password" :name
"user-password")
263 (:span
:id
"cackle"))
264 (:input
:type
"submit" :value
"Submit"
266 (setf (chain document
267 (get-element-by-id "cackle")
269 "Ok, let's see…"))))
270 (:script
:type
"text/javascript"
271 (who:str
(ps (chain document
276 for i in
*login-intro
*
277 do
(who:htm
(:p
(who:str i
))))))))))))
279 (pushnew (hunchentoot:create-regex-dispatcher
"/phoros/(?!lib/)"
281 hunchentoot
:*dispatch-table
*)
283 (defun stored-bbox ()
284 "Return stored bounding box for user and presentation project of
286 (with-connection *postgresql-credentials
*
287 (let ((bbox (bounding-box
288 (get-dao 'sys-user-role
289 (hunchentoot:session-value
291 (hunchentoot:session-value
292 'presentation-project-id
)))))
294 (hunchentoot:session-value
'presentation-project-bbox
)
297 (defun stored-cursor ()
298 "Return stored cursor position for user and presentation project of
300 (with-connection *postgresql-credentials
*
303 (:select
(:st_x
'cursor
) (:st_y
'cursor
)
305 :where
(:and
(:= 'user-id
306 (hunchentoot:session-value
'user-id
))
307 (:= 'presentation-project-id
308 (hunchentoot:session-value
309 'presentation-project-id
))
310 (:raw
"cursor IS NOT NULL")))
313 (format nil
"~{~F~#^,~}" cursor
)))))
316 (hunchentoot:define-easy-handler
317 (authenticate-handler :uri
"/phoros/lib/authenticate"
318 :default-request-type
:post
)
320 "Check user credentials."
321 (with-connection *postgresql-credentials
*
322 (let* ((user-name (hunchentoot:post-parameter
"user-name"))
323 (user-password (hunchentoot:post-parameter
"user-password"))
324 (presentation-project-id (hunchentoot:session-value
325 'presentation-project-id
))
327 (when presentation-project-id
330 'sys-user.user-full-name
332 'sys-user-role.user-role
333 :from
'sys-user-role
'sys-user
335 (:= 'presentation-project-id presentation-project-id
)
336 (:= 'sys-user-role.user-id
'sys-user.user-id
)
337 (:= 'user-name user-name
)
338 (:= 'user-password user-password
)))
340 (user-full-name (first user-info
))
341 (user-id (second user-info
))
342 (user-role (third user-info
)))
345 (setf (hunchentoot:session-value
'authenticated-p
) t
346 (hunchentoot:session-value
'user-name
) user-name
347 (hunchentoot:session-value
'user-full-name
) user-full-name
348 (hunchentoot:session-value
'user-id
) user-id
349 (hunchentoot:session-value
'user-role
) user-role
)
350 (hunchentoot:redirect
351 (format nil
"/~A/lib/view-~A"
356 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
358 :style
"font-family:sans-serif;"
360 (:a
:href
(format nil
"/~A/~A/"
362 (hunchentoot:session-value
363 'presentation-project-name
))
366 (defun assert-authentication ()
367 "Abort request handler on unauthorized access."
368 (unless (hunchentoot:session-value
'authenticated-p
)
369 (setf (hunchentoot:return-code
*) hunchentoot
:+http-precondition-failed
+)
370 (hunchentoot:abort-request-handler
)))
372 (hunchentoot:define-easy-handler logout-handler
(bbox longitude latitude
)
373 (if (hunchentoot:session-value
'authenticated-p
)
374 (with-connection *postgresql-credentials
*
375 (let ((presentation-project-name
376 (hunchentoot:session-value
'presentation-project-name
))
378 (get-dao 'sys-user-role
379 (hunchentoot:session-value
'user-id
)
380 (hunchentoot:session-value
'presentation-project-id
))))
383 (setf (bounding-box sys-user-role
) bbox
))
384 (when (and longitude latitude
)
385 (let* ;; kludge: should be done by some library, not by DB query
386 ((point-form (format nil
"POINT(~F ~F)" longitude latitude
))
387 (point-wkb (query (:select
388 (:st_geomfromtext point-form
))
390 (setf (cursor sys-user-role
) point-wkb
)))
391 (update-dao sys-user-role
))
392 (hunchentoot:remove-session hunchentoot
:*session
*)
393 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
399 "Phoros: logged out" )))
400 (:link
:rel
"stylesheet"
401 :href
(format nil
"/~A/lib/css-~A/style.css"
406 (:h1
:id
"title" "Phoros: logged out")
407 (:p
"Log back in to project "
408 (:a
:href
(format nil
"/~A/~A"
410 presentation-project-name
)
411 (who:fmt
"~A." presentation-project-name
))))))))
414 (pushnew (hunchentoot:create-regex-dispatcher
"/logout" 'logout-handler
)
415 hunchentoot
:*dispatch-table
*)
417 (hunchentoot:define-easy-handler set-cursor-handler
(bbox longitude latitude
)
418 (assert-authentication)
419 (with-connection *postgresql-credentials
*
420 (let ((presentation-project-name
421 (hunchentoot:session-value
'presentation-project-name
))
423 (get-dao 'sys-user-role
424 (hunchentoot:session-value
'user-id
)
425 (hunchentoot:session-value
'presentation-project-id
))))
428 (setf (bounding-box sys-user-role
) bbox
))
429 (when (and longitude latitude
)
430 (let* ;; kludge: should be done by some library, not by DB query
431 ((point-form (format nil
"POINT(~F ~F)" longitude latitude
))
432 (point-wkb (query (:select
433 (:st_geomfromtext point-form
))
435 (setf (cursor sys-user-role
) point-wkb
)))
436 (update-dao sys-user-role
))))
439 (pushnew (hunchentoot:create-regex-dispatcher
"/set-cursor" 'set-cursor-handler
)
440 hunchentoot
:*dispatch-table
*)
442 (define-condition superseded
() ()
444 "Tell a thread to finish as soon as possible taking any shortcuts
447 (hunchentoot:define-easy-handler
448 (selectable-restrictions :uri
"/phoros/lib/selectable-restrictions.json"
449 :default-request-type
:post
)
451 "Respond with a list of restrictions the user may choose from."
452 (assert-authentication)
453 (setf (hunchentoot:content-type
*) "application/json")
454 (with-connection *postgresql-credentials
*
455 (json:encode-json-to-string
458 (:select
'restriction-id
459 :from
'sys-selectable-restriction
460 :where
(:= 'presentation-project-id
461 (hunchentoot:session-value
462 'presentation-project-id
)))
466 (defun selected-restrictions (presentation-project-id selected-restriction-ids
)
467 "Get from current database connection a list of restriction clauses
468 belonging to presentation-project-id and ids from list
469 selected-restriction-ids."
472 `(:select
'sql-clause
473 :from
'sys-selectable-restriction
474 :where
(:and
(:= 'presentation-project-id
475 ,presentation-project-id
)
477 ,@(loop for i in selected-restriction-ids
478 collect
(list := 'restriction-id i
))))))
481 (defun sql-where-conjunction (sql-boolean-clauses)
482 "Parenthesize sql-boolean-clauses and concatenate them into a
483 string, separated by \"AND\". Return \" TRUE \" if
484 sql-boolean-clauses is nil."
485 (if sql-boolean-clauses
486 (apply #'concatenate
'string
(butlast (loop
487 for i in sql-boolean-clauses
494 (hunchentoot:define-easy-handler
495 (nearest-image-data :uri
"/phoros/lib/nearest-image-data"
496 :default-request-type
:post
)
498 "Receive coordinates, respond with the count nearest json objects
499 containing picture url, calibration parameters, and car position,
500 wrapped in an array. Wipe away any unfinished business first."
501 (assert-authentication)
502 (dolist (old-thread (hunchentoot:session-value
'recent-threads
))
504 (bt:interrupt-thread old-thread
505 #'(lambda () (signal 'superseded
)))))
506 (setf (hunchentoot:session-value
'recent-threads
) nil
)
507 (setf (hunchentoot:session-value
'number-of-threads
) 1)
508 (push (bt:current-thread
) (hunchentoot:session-value
'recent-threads
))
509 (setf (hunchentoot:content-type
*) "application/json")
510 (with-connection *postgresql-credentials
*
511 (let* ((presentation-project-id (hunchentoot:session-value
512 'presentation-project-id
))
513 (common-table-names (common-table-names
514 presentation-project-id
))
515 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
516 (longitude (cdr (assoc :longitude data
)))
517 (latitude (cdr (assoc :latitude data
)))
518 (count (cdr (assoc :count data
)))
519 (zoom (cdr (assoc :zoom data
)))
520 (snap-distance ;bogus distance in degrees,
521 (* 100e-5 ; assuming geographic
522 (expt 2 (- ; coordinates
523 14 ; (1m = 1e-5 degrees)
526 (point-form (format nil
"POINT(~F ~F)" longitude latitude
))
527 (selected-restrictions-conjunction
528 (sql-where-conjunction
529 (selected-restrictions presentation-project-id
530 (cdr (assoc :selected-restriction-ids
532 (nearest-footprint-centroid-query
533 ;; Inserting the following into
534 ;; image-data-with-footprints-query as a subquery would
535 ;; work correctly but is way too slow.
540 ,@*aggregate-view-columns
*
546 for common-table-name
547 in common-table-names
548 for aggregate-view-name
549 = (aggregate-view-name
555 (:st_centroid
'footprint
)
558 ,*standard-coordinates
*))
560 (:as
(:st_centroid
'footprint
)
562 ,@*aggregate-view-columns
*
566 ;; no-ops wrt self-references in
567 ;; selected-restrictions-conjunction
568 ,@(postmodern-as-clauses
569 (pairlis *aggregate-view-columns
*
570 *aggregate-view-columns
*))
571 :from
',aggregate-view-name
)
572 'images-of-acquisition-project
)
575 (:= 'presentation-project-id
576 ,presentation-project-id
)
581 ,*standard-coordinates
*)
583 (:raw
,selected-restrictions-conjunction
)))))
587 (nearest-footprint-image
588 (ignore-errors (logged-query "centroid of nearest footprint"
589 nearest-footprint-centroid-query
591 (nearest-footprint-centroid
592 (cdr (assoc :centroid nearest-footprint-image
)))
593 (image-data-with-footprints-query
599 for common-table-name in common-table-names
600 for aggregate-view-name
601 = (aggregate-view-name common-table-name
)
604 ,@*aggregate-view-columns
*
607 ((:is-null
'footprint
) 'coordinates
)
608 (t (:st_centroid
'footprint
)))
609 ,nearest-footprint-centroid
)
611 (:as
(:not
(:is-null
'footprint
))
613 ,(when (cli:verbosity-level
:render-footprints
)
614 '(:as
(:st_asewkt
'footprint
)
619 ,@(postmodern-as-clauses
620 nearest-footprint-image
)
621 :from
',aggregate-view-name
)
622 'images-of-acquisition-project-plus-reference-image
)
625 (:= 'presentation-project-id
626 ,presentation-project-id
)
627 (:st_contains
'footprint
628 ,nearest-footprint-centroid
)
629 (:raw
,selected-restrictions-conjunction
)))))
632 (nearest-image-without-footprints-query
638 for common-table-name in common-table-names
639 for aggregate-view-name
640 = (aggregate-view-name common-table-name
)
643 ,@*aggregate-view-columns
*
644 (:as
(:st_distance
'coordinates
647 ,*standard-coordinates
*))
649 (:as
(:not
(:is-null
'footprint
))
654 ;; no-ops wrt self-references in
655 ;; selected-restrictions-conjunction
656 ,@(postmodern-as-clauses
657 (pairlis *aggregate-view-columns
*
658 *aggregate-view-columns
*))
659 :from
',aggregate-view-name
)
660 'images-of-acquisition-project
)
662 (:and
(:= 'presentation-project-id
663 ,presentation-project-id
)
664 (:st_dwithin
'coordinates
667 ,*standard-coordinates
*)
669 (:raw
,selected-restrictions-conjunction
)))))
672 (nearest-image-without-footprint
673 (unless nearest-footprint-centroid
;otherwise save time
674 (ignore-errors (logged-query "no footprint, first image"
675 nearest-image-without-footprints-query
677 (image-data-without-footprints-query
683 for common-table-name in common-table-names
684 for aggregate-view-name
685 = (aggregate-view-name common-table-name
)
688 ,@*aggregate-view-columns
*
689 (:as
(:st_distance
'coordinates
692 ,*standard-coordinates
*))
694 (:as
(:not
(:is-null
'footprint
))
699 ,@(postmodern-as-clauses
700 nearest-image-without-footprint
)
701 :from
',aggregate-view-name
)
702 'images-of-acquisition-project
)
704 (:and
(:= 'presentation-project-id
705 ,presentation-project-id
)
706 (:st_dwithin
'coordinates
709 ,*standard-coordinates
*)
711 (:raw
,selected-restrictions-conjunction
)))))
717 (if nearest-footprint-centroid
718 (logged-query "footprints are ready"
719 image-data-with-footprints-query
721 (logged-query "no footprints yet"
722 image-data-without-footprints-query
724 (superseded () nil
))))
725 (when (cli:verbosity-level
:render-footprints
)
729 for photo-parameter-set in result
730 for footprint-vertices
= ;something like this:
731 ;; "SRID=4326;POLYGON((14.334342229 51.723293508 118.492667334,14.334386877 51.723294417 118.404764286,14.334347429 51.72327914 118.506316418,14.334383211 51.723279895 118.435823396,14.334342229 51.723293508 118.492667334))"
732 (ignore-errors ;probably no :footprint-wkt
735 (parse-number:parse-real-number x
))
736 (cl-utilities:split-sequence
#\Space p
)))
738 (cl-utilities:split-sequence-if
743 (cdr (assoc :footprint-wkt photo-parameter-set
)))
746 (if footprint-vertices
750 '(:type
:coordinates
)
754 for footprint-vertex in footprint-vertices
755 for reprojected-vertex
=
758 ;; KLUDGE: translate keys, e.g. a1 -> a_1
759 (json:decode-json-from-string
760 (json:encode-json-to-string photo-parameter-set
))
761 (pairlis '(:x-global
:y-global
:z-global
)
763 (list (proj:degrees-to-radians
764 (first footprint-vertex
))
765 (proj:degrees-to-radians
766 (second footprint-vertex
))
767 (third footprint-vertex
))
769 (cdr (assoc :cartesian-system
770 photo-parameter-set
)))))
772 (list (cdr (assoc :m reprojected-vertex
))
773 (cdr (assoc :n reprojected-vertex
))))))
775 photo-parameter-set
))))
776 (decf (hunchentoot:session-value
'number-of-threads
))
777 (json:encode-json-to-string result
))))
779 (hunchentoot:define-easy-handler
780 (nearest-image-urls :uri
"/phoros/lib/nearest-image-urls"
781 :default-request-type
:post
)
783 "Receive coordinates, respond with a json array of the necessary
784 ingredients for the URLs of the 256 nearest images."
785 (assert-authentication)
786 (when (cli:verbosity-level
:suppress-preemptive-caching
)
787 (return-from nearest-image-urls
""))
788 (push (bt:current-thread
) (hunchentoot:session-value
'recent-threads
))
789 (if (<= (hunchentoot:session-value
'number-of-threads
)
790 0) ;only stuff cache if everything else is done
792 (incf (hunchentoot:session-value
'number-of-threads
))
793 (setf (hunchentoot:content-type
*) "application/json")
794 (with-connection *postgresql-credentials
*
795 (let* ((presentation-project-id (hunchentoot:session-value
796 'presentation-project-id
))
797 (common-table-names (common-table-names
798 presentation-project-id
))
799 (data (json:decode-json-from-string
800 (hunchentoot:raw-post-data
)))
801 (longitude (cdr (assoc :longitude data
)))
802 (latitude (cdr (assoc :latitude data
)))
804 (radius (* 5d-4
)) ; assuming geographic coordinates
805 (point-form (format nil
"POINT(~F ~F)" longitude latitude
))
813 'directory
'filename
'byte-position
814 'bayer-pattern
'color-raiser
'mounting-angle
820 for common-table-name
821 in common-table-names
822 for aggregate-view-name
823 = (aggregate-view-name common-table-name
)
827 'filename
'byte-position
828 'bayer-pattern
'color-raiser
834 ,*standard-coordinates
*))
837 ',aggregate-view-name
839 (:and
(:= 'presentation-project-id
840 ,presentation-project-id
)
845 ,*standard-coordinates
*)
852 (setf (hunchentoot:return-code
*)
853 hunchentoot
:+http-gateway-time-out
+)
855 (decf (hunchentoot:session-value
'number-of-threads
))
856 (json:encode-json-to-string result
))))
857 ;; (setf (hunchentoot:return-code*) hunchentoot:+http-gateway-time-out+)
860 (hunchentoot:define-easy-handler
861 (store-point :uri
"/phoros/lib/store-point" :default-request-type
:post
)
863 "Receive point sent by user; store it into database."
864 (assert-authentication)
865 (let* ((presentation-project-name (hunchentoot:session-value
866 'presentation-project-name
))
867 (user-id (hunchentoot:session-value
'user-id
))
868 (user-role (hunchentoot:session-value
'user-role
))
869 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
870 (longitude (cdr (assoc :longitude data
)))
871 (latitude (cdr (assoc :latitude data
)))
872 (ellipsoid-height (cdr (assoc :ellipsoid-height data
)))
873 ;; (stdx-global (cdr (assoc :stdx-global data)))
874 ;; (stdy-global (cdr (assoc :stdy-global data)))
875 ;; (stdz-global (cdr (assoc :stdz-global data)))
876 (input-size (cdr (assoc :input-size data
)))
877 (kind (cdr (assoc :kind data
)))
878 (description (cdr (assoc :description data
)))
879 (numeric-description (cdr (assoc :numeric-description data
)))
881 (format nil
"SRID=4326; POINT(~S ~S ~S)"
882 longitude latitude ellipsoid-height
))
883 (aux-numeric-raw (cdr (assoc :aux-numeric data
)))
884 (aux-text-raw (cdr (assoc :aux-text data
)))
885 (aux-numeric (if aux-numeric-raw
886 (nullify-nil (apply #'vector aux-numeric-raw
))
888 (aux-text (if aux-text-raw
889 (nullify-nil (apply #'vector aux-text-raw
))
891 (user-point-table-name
892 (user-point-table-name presentation-project-name
)))
894 (not (string-equal user-role
"read")) ;that is, "write" or "admin"
895 () "No write permission.")
896 (with-connection *postgresql-credentials
*
898 (= 1 (execute (:insert-into user-point-table-name
:set
901 'description description
902 'numeric-description numeric-description
903 'creation-date
'current-timestamp
904 'coordinates
(:st_geomfromewkt point-form
)
905 ;; 'stdx-global stdx-global
906 ;; 'stdy-global stdy-global
907 ;; 'stdz-global stdz-global
908 'input-size input-size
909 'aux-numeric aux-numeric
910 'aux-text aux-text
)))
911 () "No point stored. This should not happen."))))
913 (hunchentoot:define-easy-handler
914 (update-point :uri
"/phoros/lib/update-point" :default-request-type
:post
)
916 "Update point sent by user in database."
917 (assert-authentication)
918 (let* ((presentation-project-name (hunchentoot:session-value
919 'presentation-project-name
))
920 (user-id (hunchentoot:session-value
'user-id
))
921 (user-role (hunchentoot:session-value
'user-role
))
922 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
923 (user-point-id (cdr (assoc :user-point-id data
)))
924 (kind (cdr (assoc :kind data
)))
925 (description (cdr (assoc :description data
)))
926 (numeric-description (cdr (assoc :numeric-description data
)))
927 (user-point-table-name
928 (user-point-table-name presentation-project-name
)))
930 (not (string-equal user-role
"read")) ;that is, "write" or "admin"
931 () "No write permission.")
932 (with-connection *postgresql-credentials
*
935 (:update user-point-table-name
:set
938 'description description
939 'numeric-description numeric-description
940 'creation-date
'current-timestamp
941 :where
(:and
(:= 'user-point-id user-point-id
)
942 (:or
(:= (if (string-equal user-role
953 () "No point stored. Did you try to update someone else's point ~
954 without having admin permission?"))))
956 (defun increment-numeric-string (text)
957 "Increment rightmost numeric part of text if any; otherwise append a
958 three-digit numeric part."
959 (let* ((end-of-number
960 (1+ (or (position-if #'digit-char-p text
:from-end t
)
961 (1- (length text
)))))
963 (1+ (or (position-if-not #'digit-char-p text
:from-end t
966 (width-of-number (- end-of-number start-of-number
))
967 (prefix-text (subseq text
0 start-of-number
))
968 (suffix-text (subseq text end-of-number
)))
969 (when (zerop width-of-number
)
970 (setf width-of-number
3))
971 (format nil
"~A~V,'0D~A"
974 (1+ (or (ignore-errors
977 :start start-of-number
:end end-of-number
))
981 (hunchentoot:define-easy-handler
982 (uniquify-point-attributes :uri
"/phoros/lib/uniquify-point-attributes"
983 :default-request-type
:post
)
985 "Check if received set of point-attributes are unique. If so,
986 return null; otherwise return (as a suggestion) a uniquified version
987 of point-attributes by modifying element numeric-description."
988 (assert-authentication)
989 (setf (hunchentoot:content-type
*) "application/json")
990 (let* ((presentation-project-name (hunchentoot:session-value
991 'presentation-project-name
))
992 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
993 (user-point-id (cdr (assoc :user-point-id data
)))
994 (kind (cdr (assoc :kind data
)))
995 (description (cdr (assoc :description data
)))
996 (numeric-description (cdr (assoc :numeric-description data
)))
997 (user-point-table-name
998 (user-point-table-name presentation-project-name
)))
999 (flet ((uniquep (user-point-id kind description numeric-description
)
1000 "Check if given set of user-point attributes will be
1009 :from user-point-table-name
1010 :where
(:and
(:!= 'user-point-id user-point-id
)
1012 (:= 'description description
)
1013 (:= 'numeric-description
1014 numeric-description
)))))
1021 :from user-point-table-name
1022 :where
(:and
(:= 'kind kind
)
1023 (:= 'description description
)
1024 (:= 'numeric-description
1025 numeric-description
)))))
1027 (with-connection *postgresql-credentials
*
1028 (json:encode-json-to-string
1030 user-point-id kind description numeric-description
)
1032 for s
= numeric-description
1033 then
(increment-numeric-string s
)
1034 until
(uniquep user-point-id kind description s
)
1036 (setf (cdr (assoc :numeric-description data
))
1038 (return data
))))))))
1040 (hunchentoot:define-easy-handler
1041 (delete-point :uri
"/phoros/lib/delete-point" :default-request-type
:post
)
1043 "Delete user point if user is allowed to do so."
1044 (assert-authentication)
1045 (let* ((presentation-project-name (hunchentoot:session-value
1046 'presentation-project-name
))
1047 (user-id (hunchentoot:session-value
'user-id
))
1048 (user-role (hunchentoot:session-value
'user-role
))
1049 (user-point-table-name
1050 (user-point-table-name presentation-project-name
))
1051 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
1052 (with-connection *postgresql-credentials
*
1054 (eql 1 (cond ((string-equal user-role
"admin")
1055 (execute (:delete-from user-point-table-name
1056 :where
(:= 'user-point-id data
))))
1057 ((string-equal user-role
"write")
1060 user-point-table-name
1062 (:= 'user-point-id data
)
1063 (:or
(:= 'user-id user-id
)
1070 () "No point deleted. This should not happen."))))
1072 (defun common-table-names (presentation-project-id)
1073 "Return a list of common-table-names of table sets that contain data
1074 of presentation project with presentation-project-id."
1077 (:select
'common-table-name
1079 :from
'sys-presentation
'sys-measurement
'sys-acquisition-project
1081 (:= 'sys-presentation.presentation-project-id
1082 presentation-project-id
)
1083 (:= 'sys-presentation.measurement-id
1084 'sys-measurement.measurement-id
)
1085 (:= 'sys-measurement.acquisition-project-id
1086 'sys-acquisition-project.acquisition-project-id
)))
1091 "While fetching common-table-names of presentation-project-id ~D: ~A"
1092 presentation-project-id c
))))
1094 (defun encode-geojson-to-string (features &key junk-keys
)
1095 "Encode a list of property lists into a GeoJSON FeatureCollection.
1096 Each property list must contain keys for coordinates, :x, :y, :z; it
1097 may contain a numeric point :id and zero or more pieces of extra
1098 information. The extra information is stored as GeoJSON Feature
1099 properties. Exclude property list elements with keys that are in
1101 (with-output-to-string (s)
1102 (json:with-object
(s)
1103 (json:encode-object-member
:type
:*feature-collection s
)
1104 (json:as-object-member
(:features s
)
1105 (json:with-array
(s)
1107 #'(lambda (point-with-properties)
1108 (dolist (junk-key junk-keys
)
1109 (remf point-with-properties junk-key
))
1110 (destructuring-bind (&key x y z id
&allow-other-keys
) ;TODO: z probably bogus
1111 point-with-properties
1112 (json:as-array-member
(s)
1113 (json:with-object
(s)
1114 (json:encode-object-member
:type
:*feature s
)
1115 (json:as-object-member
(:geometry s
)
1116 (json:with-object
(s)
1117 (json:encode-object-member
:type
:*point s
)
1118 (json:as-object-member
(:coordinates s
)
1119 (json:encode-json
(list x y z
) s
))))
1120 (json:encode-object-member
:id id s
)
1121 (json:as-object-member
(:properties s
)
1122 (dolist (key '(:x
:y
:z
:id
))
1123 (remf point-with-properties key
))
1124 (json:encode-json-plist point-with-properties s
))))))
1126 (json:encode-object-member
:phoros-version
(phoros-version) s
))))
1129 "Return a WKT-compliant BOX3D string from string bbox."
1130 (concatenate 'string
"BOX3D("
1131 (substitute #\Space
#\
,
1132 (substitute #\Space
#\
, bbox
:count
1)
1133 :from-end t
:count
1)
1136 (hunchentoot:define-easy-handler
(points :uri
"/phoros/lib/points.json") (bbox)
1137 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
1138 (assert-authentication)
1139 (setf (hunchentoot:content-type
*) "application/json")
1141 (with-connection *postgresql-credentials
*
1142 (let* ((presentation-project-id
1143 (hunchentoot:session-value
'presentation-project-id
))
1145 (common-table-names presentation-project-id
)))
1146 (encode-geojson-to-string
1153 for common-table-name in common-table-names
1154 for aggregate-view-name
1155 = (point-data-table-name common-table-name
)
1156 ;; would have been nice, was too slow:
1157 ;; = (aggregate-view-name common-table-name)
1160 (:as
(:st_x
'coordinates
) x
)
1161 (:as
(:st_y
'coordinates
) y
)
1162 (:as
(:st_z
'coordinates
) z
)
1163 (:as
'point-id
'id
) ;becomes fid on client
1165 :distinct-on
'random
1166 :from
',aggregate-view-name
1167 :natural
:left-join
'sys-presentation
1170 (:= 'presentation-project-id
1171 ,presentation-project-id
)
1174 (:st_setsrid
(:type
,(box3d bbox
) box3d
)
1175 ,*standard-coordinates
*))))))
1177 ,*number-of-features-per-layer
*))
1179 :junk-keys
'(:random
))))
1182 :error
"While fetching points from inside bbox ~S: ~A"
1185 (hunchentoot:define-easy-handler
1186 (aux-points :uri
"/phoros/lib/aux-points.json")
1188 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
1189 (assert-authentication)
1190 (setf (hunchentoot:content-type
*) "application/json")
1192 (let ((limit *number-of-features-per-layer
*)
1194 (aux-point-view-name (hunchentoot:session-value
1195 'presentation-project-name
))))
1196 (encode-geojson-to-string
1197 (with-connection *postgresql-aux-credentials
*
1203 (:as
(:st_x
'coordinates
) 'x
)
1204 (:as
(:st_y
'coordinates
) 'y
)
1205 (:as
(:st_z
'coordinates
) 'z
)
1206 :from
,aux-view-name
1209 (:st_setsrid
(:type
,(box3d bbox
) box3d
)
1210 ,*standard-coordinates
*)))
1216 :error
"While fetching aux-points from inside bbox ~S: ~A"
1219 (hunchentoot:define-easy-handler
1220 (aux-local-data :uri
"/phoros/lib/aux-local-data"
1221 :default-request-type
:post
)
1223 "Receive coordinates, respond with the count nearest json objects
1224 containing arrays aux-numeric, aux-text, and distance to the
1225 coordinates received, wrapped in an array."
1226 (assert-authentication)
1227 (setf (hunchentoot:content-type
*) "application/json")
1228 (let* ((aux-view-name
1229 (aux-point-view-name (hunchentoot:session-value
1230 'presentation-project-name
)))
1231 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1232 (longitude (cdr (assoc :longitude data
)))
1233 (latitude (cdr (assoc :latitude data
)))
1234 (count (cdr (assoc :count data
)))
1236 (format nil
"POINT(~F ~F)" longitude latitude
))
1237 (snap-distance 1e-3) ;about 100 m, TODO: make this a defparameter
1239 (format nil
"~A,~A,~A,~A"
1240 (- longitude snap-distance
)
1241 (- latitude snap-distance
)
1242 (+ longitude snap-distance
)
1243 (+ latitude snap-distance
))))
1244 (encode-geojson-to-string
1246 (with-connection *postgresql-aux-credentials
*
1253 (:as
(:st_x
'coordinates
) 'x
)
1254 (:as
(:st_y
'coordinates
) 'y
)
1255 (:as
(:st_z
'coordinates
) 'z
)
1262 ,*spherical-mercator
*)
1264 (:st_geomfromtext
,point-form
,*standard-coordinates
*)
1265 ,*spherical-mercator
*))
1267 :from
',aux-view-name
1268 :where
(:&& 'coordinates
1270 ,(box3d bounding-box
) box3d
)
1271 ,*standard-coordinates
*)))
1276 (defun nillify-null (x)
1277 "Replace occurences of :null in nested sequence x by nil."
1278 (cond ((eq :null x
) nil
)
1282 (t (map (type-of x
) #'nillify-null x
))))
1284 (defun nullify-nil (x)
1285 "Replace occurences of nil in nested sequence x by :null."
1286 (cond ((null x
) :null
)
1290 (t (map (type-of x
) #'nullify-nil x
))))
1292 (hunchentoot:define-easy-handler
1293 (aux-local-linestring :uri
"/phoros/lib/aux-local-linestring.json"
1294 :default-request-type
:post
)
1296 "Receive longitude, latitude, radius, and step-size; respond
1297 with a JSON object comprising the elements linestring (a WKT
1298 linestring stitched together of the nearest auxiliary points from
1299 within radius around coordinates), current-point (the point on
1300 linestring closest to coordinates), and previous-point and next-point
1301 \(points on linestring step-size before and after current-point
1302 respectively). Wipe away any unfinished business first."
1303 (assert-authentication)
1304 (dolist (old-thread (hunchentoot:session-value
'recent-threads
))
1306 (bt:interrupt-thread old-thread
1307 #'(lambda () (signal 'superseded
)))))
1308 (setf (hunchentoot:session-value
'recent-threads
) nil
)
1309 (setf (hunchentoot:session-value
'number-of-threads
) 1)
1310 (push (bt:current-thread
) (hunchentoot:session-value
'recent-threads
))
1311 (setf (hunchentoot:content-type
*) "application/json")
1313 (let* ((thread-aux-points-function-name
1314 (thread-aux-points-function-name (hunchentoot:session-value
1315 'presentation-project-name
)))
1316 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1317 (longitude (cdr (assoc :longitude data
)))
1318 (latitude (cdr (assoc :latitude data
)))
1319 (radius (cdr (assoc :radius data
)))
1320 (step-size (cdr (assoc :step-size data
)))
1321 (azimuth (if (numberp (cdr (assoc :azimuth data
)))
1322 (cdr (assoc :azimuth data
))
1325 (format nil
"POINT(~F ~F)" longitude latitude
))
1328 (with-connection *postgresql-aux-credentials
*
1333 (,thread-aux-points-function-name
1335 ,point-form
,*standard-coordinates
*)
1337 ,*number-of-points-per-aux-linestring
*
1340 ,(proj:degrees-to-radians
91))))
1342 (with-output-to-string (s)
1343 (json:with-object
(s)
1344 (json:encode-object-member
1345 :linestring
(getf sql-response
:threaded-points
) s
)
1346 (json:encode-object-member
1347 :current-point
(getf sql-response
:current-point
) s
)
1348 (json:encode-object-member
1349 :previous-point
(getf sql-response
:back-point
) s
)
1350 (json:encode-object-member
1351 :next-point
(getf sql-response
:forward-point
) s
)
1352 (json:encode-object-member
1353 :azimuth
(getf sql-response
:new-azimuth
) s
))))
1355 ;; (setf (hunchentoot:return-code*) hunchentoot:+http-gateway-time-out+)
1358 (defun get-user-points (user-point-table-name &key
1359 (bounding-box "-180,-90,180,90")
1361 (order-criterion 'id
)
1363 "Return limit points from user-point-table-name in GeoJSON format,
1364 and the number of points returned."
1365 (let ((user-point-plist
1371 (:as
(:st_x
'coordinates
) 'x
)
1372 (:as
(:st_y
'coordinates
) 'y
)
1373 (:as
(:st_z
'coordinates
) 'z
)
1374 (:as
'user-point-id
'id
) ;becomes fid in OpenLayers
1375 ;; 'stdx-global 'stdy-global 'stdz-global
1377 'kind
'description
'numeric-description
1379 (:as
(:to-char
'creation-date
1380 ,*user-point-creation-date-format
*)
1382 'aux-numeric
'aux-text
1383 :from
,user-point-table-name
:natural
:left-join
'sys-user
1384 :where
(:&& 'coordinates
1385 (:st_setsrid
(:type
,(box3d bounding-box
) box3d
)
1386 ,*standard-coordinates
*)))
1393 (encode-geojson-to-string (nillify-null user-point-plist
)))
1394 (encode-geojson-to-string (nillify-null user-point-plist
)))
1395 (length user-point-plist
))))
1397 (hunchentoot:define-easy-handler
1398 (user-points :uri
"/phoros/lib/user-points.json")
1400 "Send *number-of-features-per-layer* randomly chosen GeoJSON-encoded
1401 points from inside bbox to client. If there is no bbox parameter,
1402 send all points and indent GeoJSON to make it more readable."
1403 (assert-authentication)
1404 (setf (hunchentoot:content-type
*) "application/json")
1406 (let ((bounding-box (or bbox
"-180,-90,180,90"))
1408 (limit (if bbox
*number-of-features-per-layer
* :null
))
1409 (order-criterion (if bbox
'(:random
) 'id
))
1410 (user-point-table-name
1411 (user-point-table-name (hunchentoot:session-value
1412 'presentation-project-name
))))
1413 (with-connection *postgresql-credentials
*
1414 (nth-value 0 (get-user-points user-point-table-name
1415 :bounding-box bounding-box
1417 :order-criterion order-criterion
1421 :error
"While fetching user-points~@[ from inside bbox ~S~]: ~A"
1424 (hunchentoot:define-easy-handler
1425 (user-point-attributes :uri
"/phoros/lib/user-point-attributes.json")
1427 "Send JSON object comprising arrays kinds and descriptions,
1428 each containing unique values called kind and description
1429 respectively, and count being the frequency of value in the user point
1431 (assert-authentication)
1432 (setf (hunchentoot:content-type
*) "application/json")
1434 (let ((user-point-table-name
1435 (user-point-table-name (hunchentoot:session-value
1436 'presentation-project-name
))))
1437 (with-connection *postgresql-credentials
*
1438 (with-output-to-string (s)
1439 (json:with-object
(s)
1440 (json:as-object-member
(:descriptions s
)
1441 (json:with-array
(s)
1442 (mapcar #'(lambda (x) (json:as-array-member
(s)
1443 (json:encode-json-plist x s
)))
1447 (:select
'description
1448 (:count
'description
)
1449 :from user-point-table-name
1450 :group-by
'description
)
1454 (json:as-object-member
(:kinds s
)
1455 (json:with-array
(s)
1456 (mapcar #'(lambda (x) (json:as-array-member
(s)
1457 (json:encode-json-plist x s
)))
1458 (query (format nil
"~
1459 (SELECT kind, count(kind) ~
1460 FROM ((SELECT kind FROM ~A) ~
1463 FROM (VALUES ('solitary'), ~
1466 AS defaults(kind))) ~
1467 AS kinds_union(kind) ~
1469 ORDER BY kind LIMIT 100"
1470 ;; Counts of solitary,
1471 ;; polyline, polygon may be
1472 ;; too big by one if we
1473 ;; collect them like this.
1474 (s-sql:to-sql-name user-point-table-name
))
1478 :error
"While fetching user-point-attributes: ~A"
1481 (hunchentoot:define-easy-handler photo-handler
1482 ((bayer-pattern :init-form
"65280,16711680")
1483 (color-raiser :init-form
"1,1,1")
1484 (mounting-angle :init-form
"0")
1486 "Serve an image from a .pictures file."
1487 (assert-authentication)
1491 (push (bt:current-thread
)
1492 (hunchentoot:session-value
'recent-threads
))
1493 (incf (hunchentoot:session-value
'number-of-threads
)))
1495 (cl-utilities:split-sequence
#\
/
1496 (hunchentoot:script-name
*)
1497 :remove-empty-subseqs t
))
1499 (cdddr ;remove leading phoros, lib, photo
1502 (cl-utilities:split-sequence
#\.
(first (last s
2))))
1504 (parse-integer (car (last s
)) :junk-allowed t
))
1509 :directory
(append (pathname-directory *common-root
*)
1512 :name
(first file-name-and-type
)
1513 :type
(second file-name-and-type
)))))
1515 (flex:with-output-to-sequence
(stream)
1517 stream path-to-file byte-position
1519 (apply #'vector
(mapcar
1521 (cl-utilities:split-sequence
1522 #\
, bayer-pattern
)))
1524 (apply #'vector
(mapcar
1525 #'parse-number
:parse-positive-real-number
1526 (cl-utilities:split-sequence
1529 :reversep
(= 180 (parse-integer mounting-angle
))
1530 :brightenp brightenp
))))
1531 (setf (hunchentoot:header-out
'cache-control
)
1532 (format nil
"max-age=~D" *browser-cache-max-age
*))
1533 (setf (hunchentoot:content-type
*) "image/png")
1535 (decf (hunchentoot:session-value
'number-of-threads
)))
1537 (setf (hunchentoot:return-code
*) hunchentoot
:+http-gateway-time-out
+)
1541 :error
"While serving image ~S: ~A" (hunchentoot:request-uri
*) c
))))
1543 (pushnew (hunchentoot:create-prefix-dispatcher
"/phoros/lib/photo"
1545 hunchentoot
:*dispatch-table
*)
1547 ;;; for debugging; this is the multi-file OpenLayers
1548 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1549 "/phoros/lib/openlayers/" "OpenLayers-2.10/")
1550 hunchentoot
:*dispatch-table
*)
1552 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1553 "/phoros/lib/ol/" "ol/")
1554 hunchentoot
:*dispatch-table
*)
1556 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1557 "/phoros/lib/public_html/" "public_html/")
1558 hunchentoot
:*dispatch-table
*)
1560 (pushnew (hunchentoot:create-static-file-dispatcher-and-handler
1561 "/favicon.ico" "public_html/favicon.ico")
1562 hunchentoot
:*dispatch-table
*)
1564 (hunchentoot:define-easy-handler
1565 (view :uri
(format nil
"/phoros/lib/view-~A" (phoros-version))
1566 :default-request-type
:post
)
1568 "Serve the client their main workspace."
1570 (hunchentoot:session-value
'authenticated-p
)
1571 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
1577 "Phoros: " (hunchentoot:session-value
1578 'presentation-project-name
))))
1579 (if (cli:verbosity-level
:use-multi-file-openlayers
)
1582 :src
(format nil
"/~A/lib/openlayers/lib/Firebug/firebug.js"
1585 :src
(format nil
"/~A/lib/openlayers/lib/OpenLayers.js"
1589 :src
(format nil
"/~A/lib/ol/OpenLayers.js"
1591 (:link
:rel
"stylesheet"
1592 :href
(format nil
"/~A/lib/css-~A/style.css"
1596 (:script
:src
(format ;variability in script name is
1597 nil
; supposed to fight browser cache
1598 "/~A/lib/phoros-~A-~A-~A.js"
1601 (hunchentoot:session-value
'user-name
)
1602 (hunchentoot:session-value
'presentation-project-name
)))
1603 (:script
:src
"http://maps.google.com/maps/api/js?sensor=false"))
1606 (:noscript
(:b
(:em
"You can't do much without JavaScript here.")))
1609 "Phoros: " (who:str
(hunchentoot:session-value
'user-full-name
))
1610 (who:fmt
" (~A)" (hunchentoot:session-value
'user-name
))
1611 "with " (:span
:id
"user-role"
1612 (who:str
(hunchentoot:session-value
'user-role
)))
1614 (:span
:id
"presentation-project-name"
1615 (who:str
(hunchentoot:session-value
1616 'presentation-project-name
)))
1617 (:span
:id
"presentation-project-emptiness")
1618 (:span
:id
"recommend-fresh-login")
1619 (:span
:class
"h1-right"
1620 (:span
:id
"caching-indicator")
1621 (:span
:id
"phoros-version"
1622 (who:fmt
"v~A" (phoros-version)))))
1623 ;; streetmap area (northwest)
1625 :class
"controlled-streetmap"
1626 (:div
:id
"streetmap" :class
"streetmap" :style
"cursor:crosshair")
1627 (:div
:id
"streetmap-controls" :class
"streetmap-controls"
1628 (:div
:id
"streetmap-vertical-strut"
1629 :class
"streetmap-vertical-strut")
1630 (:div
:id
"streetmap-layer-switcher"
1631 :class
"streetmap-layer-switcher")
1632 (:button
:id
"unselect-all-restrictions-button"
1634 :onclick
(ps-inline (unselect-all-restrictions))
1636 (:select
:id
"restriction-select"
1637 :name
"restriction-select"
1640 :onchange
(ps-inline (request-photos)))
1641 (:div
:id
"streetmap-overview" :class
"streetmap-overview")
1642 (:div
:id
"streetmap-mouse-position"
1643 :class
"streetmap-mouse-position")
1644 (:div
:id
"streetmap-zoom" :class
"streetmap-zoom")))
1645 ;; control area (north)
1647 :class
"phoros-controls" :id
"phoros-controls"
1648 (:div
:id
"real-phoros-controls"
1649 (:h2
:class
"point-creator h2-phoros-controls"
1651 (:h2
:class
"point-editor h2-phoros-controls"
1653 (:span
:id
"creator"))
1654 (:h2
:class
"point-viewer h2-phoros-controls"
1656 (:span
:id
"creator"))
1657 (:h2
:class
"aux-data-viewer h2-phoros-controls"
1658 "View Auxiliary Data")
1659 (:h2
:class
"multiple-points-viewer"
1660 "Multiple Points Selected")
1661 (:div
:class
"multiple-points-viewer"
1662 (:p
"You have selected multiple user points.")
1663 (:p
"Unselect all but one to edit or view its properties."))
1664 (:span
:class
"point-creator point-editor point-viewer"
1669 :id
"point-kind-select"
1670 :name
"point-kind-select"
1671 :class
"combobox-select write-permission-dependent"
1672 :onchange
(ps-inline
1673 (consolidate-combobox
1677 :id
"point-kind-input"
1678 :name
"point-kind-input"
1679 :class
"combobox-input write-permission-dependent"
1680 :onchange
(ps-inline
1681 (unselect-combobox-selection
1685 (:input
:id
"point-numeric-description"
1686 :class
"vanilla-input write-permission-dependent"
1688 :type
"text" :name
"point-numeric-description")
1691 :id
"point-description"
1694 :id
"point-description-select"
1695 :name
"point-description-select"
1696 :class
"combobox-select write-permission-dependent"
1697 :onchange
(ps-inline
1698 (consolidate-combobox
1699 "point-description"))
1702 :id
"point-description-input"
1703 :name
"point-description-input"
1704 :class
"combobox-input write-permission-dependent"
1705 :onchange
(ps-inline
1706 (unselect-combobox-selection
1707 "point-description"))
1710 (:button
:id
"delete-point-button" :disabled t
1712 :onclick
(ps-inline (delete-point))
1714 (:button
:disabled t
:id
"finish-point-button"
1717 (:div
:id
"uniquify-buttons"
1718 (:button
:id
"suggest-unique-button"
1721 (insert-unique-suggestion))
1723 (:button
:id
"force-duplicate-button"
1726 (:div
:id
"aux-point-distance-or-point-creation-date"
1727 (:code
:id
"point-creation-date"
1728 :class
"point-editor point-viewer")
1730 :id
"aux-point-distance" :disabled t
1731 :class
"point-creator aux-data-viewer aux-data-dependent"
1732 :size
1 :name
"aux-point-distance"
1733 :onchange
(ps-inline
1734 (aux-point-distance-selected))
1736 (enable-aux-point-selection)))
1738 :id
"include-aux-data"
1739 :class
"point-creator aux-data-dependent"
1741 (:input
:id
"include-aux-data-p"
1742 :class
"tight-input"
1743 :type
"checkbox" :checked t
1744 :name
"include-aux-data-p"
1745 :onchange
(ps-inline
1746 (flip-aux-data-inclusion)))
1748 (:div
:id
"display-nearest-aux-data"
1749 :class
"aux-data-viewer"
1751 (:input
:id
"display-nearest-aux-data-p"
1752 :class
"tight-input"
1753 :type
"checkbox" :checked t
1754 :name
"display-nearest-aux-data-p"
1755 :onchange
(ps-inline
1756 (flip-nearest-aux-data-display)))
1760 :class
"point-creator point-editor point-viewer aux-data-viewer"
1761 (:div
:id
"aux-numeric-list")
1762 (:div
:id
"aux-text-list")))
1763 (:div
:class
"walk-mode-controls"
1764 (:div
:id
"walk-mode"
1765 :class
"aux-data-dependent"
1766 (:input
:id
"walk-p"
1767 :class
"tight-input"
1768 :type
"checkbox" :checked nil
1769 :onchange
(ps-inline
1771 (:label
:for
"walk-p"
1773 (:div
:id
"decrease-step-size"
1774 :class
"aux-data-dependent"
1775 :onclick
(ps-inline (decrease-step-size)))
1776 (:div
:id
"step-size"
1777 :class
"aux-data-dependent"
1778 :onclick
(ps-inline (increase-step-size))
1780 (:div
:id
"increase-step-size"
1781 :class
"aux-data-dependent"
1782 :onclick
(ps-inline (increase-step-size))
1783 :ondblclick
(ps-inline (increase-step-size)
1784 (increase-step-size)))
1785 (:div
:id
"step-button" :disabled nil
1786 :class
"aux-data-dependent"
1787 :onclick
(ps-inline (step))
1788 :ondblclick
(ps-inline (step t
))
1790 (:div
:class
"image-main-controls"
1791 (:div
:id
"auto-zoom"
1792 (:input
:id
"zoom-to-point-p"
1793 :class
"tight-input"
1794 :type
"checkbox" :checked t
)
1795 (:label
:for
"zoom-to-point-p"
1797 (:div
:id
"brighten-images"
1798 (:input
:id
"brighten-images-p"
1799 :class
"tight-input"
1800 :type
"checkbox" :checked nil
)
1801 (:label
:for
"brighten-images-p"
1803 (:div
:id
"zoom-images-to-max-extent"
1804 :onclick
(ps-inline (zoom-images-to-max-extent)))
1805 (:div
:id
"no-footprints-p"
1807 (:div
:id
"remove-work-layers-button" :disabled t
1808 :onclick
(ps-inline (reset-layers-and-controls))
1810 ;; help area (northeast)
1814 :id
"download-user-points-button"
1816 :onclick
(format nil
1817 "self.location.href = \"/~A/lib/user-points.json\""
1819 "download points") ;TODO: offer other formats and maybe projections
1828 "/lib/blurb?openlayers-version="
1829 (@ *open-layers
*version_number
*))
1831 (:img
:src
(format nil
"/~A/lib/public_html/phoros-logo-plain.png"
1833 :alt
"Phoros" :style
"vertical-align:middle"
1835 (:button
:id
"logout-button"
1837 :onclick
(ps-inline (bye))
1839 (:h2
:id
"h2-help" "Help")
1840 (:div
:id
"help-display"))
1841 ;; image area (south)
1842 (:div
:id
"images" :style
"clear:both"
1844 for i from
0 below
*number-of-images
* do
1846 (:div
:class
"controlled-image"
1847 (:div
:id
(format nil
"image-~S-controls" i
)
1848 :class
"image-controls"
1849 (:div
:id
(format nil
"image-~S-zoom" i
)
1850 :class
"image-zoom")
1851 (:div
:id
(format nil
"image-~S-layer-switcher" i
)
1852 :class
"image-layer-switcher")
1853 (:div
:id
(format nil
"image-~S-usable" i
)
1854 :class
"image-usable"
1856 (:div
:id
(format nil
"image-~S-trigger-time" i
)
1857 :class
"image-trigger-time"))
1858 (:div
:id
(format nil
"image-~S" i
)
1859 :class
"image" :style
"cursor:crosshair"))))))))
1860 (hunchentoot:redirect
1861 (format nil
"/~A/~A"
1863 (hunchentoot:session-value
'presentation-project-name
))
1864 :add-session-id t
)))
1866 (hunchentoot:define-easy-handler
1867 (epipolar-line :uri
"/phoros/lib/epipolar-line")
1869 "Receive vector of two sets of picture parameters, the first of
1870 which containing coordinates (m, n) of a clicked point. Respond with a
1871 JSON encoded epipolar-line."
1872 (assert-authentication)
1873 (setf (hunchentoot:content-type
*) "application/json")
1874 (let* ((data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
1875 (json:encode-json-to-string
1876 (photogrammetry :epipolar-line
(first data
) (second data
)))))
1878 (hunchentoot:define-easy-handler
1879 (estimated-positions :uri
"/phoros/lib/estimated-positions")
1881 "Receive a two-part JSON vector comprising (1) a vector containing
1882 sets of picture-parameters with clicked (\"active\") points
1883 stored in :m, :n; and (2) a vector containing sets of
1884 picture-parameters; respond with a JSON encoded two-part vector
1885 comprising (1) a point in global coordinates; and (2) a vector of
1886 image coordinates (m, n) for the global point that correspond to the
1887 images from the received second vector. TODO: report error on bad
1888 data (ex: points too far apart)."
1889 ;; TODO: global-point-for-display should probably contain a proj string in order to make sense of the (cartesian) standard deviations.
1890 (assert-authentication)
1891 (setf (hunchentoot:content-type
*) "application/json")
1893 (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1894 (active-point-photo-parameters
1896 (number-of-active-points
1897 (length active-point-photo-parameters
))
1898 (destination-photo-parameters
1901 (cdr (assoc :cartesian-system
1902 (first active-point-photo-parameters
))))
1903 (global-point-cartesian
1905 :multi-position-intersection active-point-photo-parameters
))
1906 (global-point-geographic-radians
1907 (proj:cs2cs
(list (cdr (assoc :x-global global-point-cartesian
))
1908 (cdr (assoc :y-global global-point-cartesian
))
1909 (cdr (assoc :z-global global-point-cartesian
)))
1910 :source-cs cartesian-system
))
1911 (global-point-for-display ;points geographic cs, degrees; std deviations in cartesian cs
1912 (pairlis '(:longitude
:latitude
:ellipsoid-height
1913 ;; :stdx-global :stdy-global :stdz-global
1916 (proj:radians-to-degrees
1917 (first global-point-geographic-radians
))
1918 (proj:radians-to-degrees
1919 (second global-point-geographic-radians
))
1920 (third global-point-geographic-radians
)
1921 ;; (cdr (assoc :stdx-global global-point-cartesian))
1922 ;; (cdr (assoc :stdy-global global-point-cartesian))
1923 ;; (cdr (assoc :stdz-global global-point-cartesian))
1924 number-of-active-points
)))
1927 for i in destination-photo-parameters
1930 (photogrammetry :reprojection i global-point-cartesian
)))))
1931 (json:encode-json-to-string
1932 (list global-point-for-display image-coordinates
))))
1934 (hunchentoot:define-easy-handler
1935 (user-point-positions :uri
"/phoros/lib/user-point-positions")
1937 "Receive a two-part JSON vector comprising
1938 - a vector of user-point-id's and
1939 - a vector containing sets of picture-parameters;
1940 respond with a JSON object comprising the elements
1941 - image-points, a vector whose elements
1942 - correspond to the elements of the picture-parameters vector
1944 - are GeoJSON feature collections containing one point (in picture
1945 coordinates) for each user-point-id received;
1946 - user-point-count, the number of user-points we tried to fetch
1948 (assert-authentication)
1949 (setf (hunchentoot:content-type
*) "application/json")
1950 (with-connection *postgresql-credentials
*
1951 (let* ((user-point-table-name
1952 (user-point-table-name (hunchentoot:session-value
1953 'presentation-project-name
)))
1954 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1955 (user-point-ids (first data
))
1956 (user-point-count (length user-point-ids
))
1957 (destination-photo-parameters (second data
))
1959 (cdr (assoc :cartesian-system
1960 (first destination-photo-parameters
)))) ;TODO: in rare cases, coordinate systems of the images shown may differ
1964 (:as
(:st_x
'coordinates
) 'longitude
)
1965 (:as
(:st_y
'coordinates
) 'latitude
)
1966 (:as
(:st_z
'coordinates
) 'ellipsoid-height
)
1967 (:as
'user-point-id
'id
) ;becomes fid on client
1970 'numeric-description
1972 (:as
(:to-char
'creation-date
"IYYY-MM-DD HH24:MI:SS TZ")
1976 :from user-point-table-name
:natural
:left-join
'sys-user
1977 :where
(:in
'user-point-id
(:set user-point-ids
)))
1979 (global-points-cartesian
1981 for global-point-geographic in user-points
1983 (ignore-errors ;in case no destination-photo-parameters have been sent
1984 (pairlis '(:x-global
:y-global
:z-global
)
1987 (proj:degrees-to-radians
1988 (getf global-point-geographic
:longitude
))
1989 (proj:degrees-to-radians
1990 (getf global-point-geographic
:latitude
))
1991 (getf global-point-geographic
:ellipsoid-height
))
1992 :destination-cs cartesian-system
)))))
1995 for photo-parameter-set in destination-photo-parameters
1997 (encode-geojson-to-string
1999 for global-point-cartesian in global-points-cartesian
2000 for user-point in user-points
2002 (when (point-within-image-p
2003 (getf user-point
:id
)
2004 (hunchentoot:session-value
'presentation-project-name
)
2005 (cdr (assoc :byte-position photo-parameter-set
))
2006 (cdr (assoc :filename photo-parameter-set
))
2007 (cdr (assoc :measurement-id photo-parameter-set
)))
2009 (let ((photo-coordinates
2010 (photogrammetry :reprojection
2012 global-point-cartesian
))
2015 (setf (getf photo-point
:x
)
2016 (cdr (assoc :m photo-coordinates
)))
2017 (setf (getf photo-point
:y
)
2018 (cdr (assoc :n photo-coordinates
)))
2020 :junk-keys
'(:longitude
:latitude
:ellipsoid-height
)))))
2021 (with-output-to-string (s)
2022 (json:with-object
(s)
2023 (json:encode-object-member
:user-point-count user-point-count s
)
2024 (json:as-object-member
(:image-points s
)
2025 (json:with-array
(s)
2026 (loop for i in image-coordinates do
2027 (json:as-array-member
(s) (princ i s
))))))))))
2029 (defun point-within-image-p (user-point-id presentation-project-name
2030 byte-position filename measurement-id
)
2031 "Return t if either point with user-point-id is inside the footprint
2032 of the image described by byte-position, filename, and measurement-id;
2033 or if that image doesn't have a footprint. Return nil otherwise."
2034 (let* ((user-point-table-name (user-point-table-name
2035 presentation-project-name
))
2036 (presentation-project-id (presentation-project-id-from-name
2037 presentation-project-name
))
2038 (common-table-names (common-table-names presentation-project-id
)))
2043 for common-table-name in common-table-names
2044 for aggregate-view-name
2045 = (aggregate-view-name common-table-name
)
2049 :from
',aggregate-view-name
2050 :where
(:and
(:= 'byte-position
,byte-position
)
2051 (:= 'filename
,filename
)
2052 (:= 'measurement-id
,measurement-id
)
2053 (:or
(:is-null
'footprint
)
2055 (:select
'coordinates
2056 :from
,user-point-table-name
2057 :where
(:= 'user-point-id
2062 (hunchentoot:define-easy-handler
2063 (multi-position-intersection :uri
"/phoros/lib/intersection")
2065 "Receive vector of sets of picture parameters, respond with stuff."
2066 (assert-authentication)
2067 (setf (hunchentoot:content-type
*) "application/json")
2068 (let* ((data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
2069 (json:encode-json-to-string
2070 (photogrammetry :multi-position-intersection data
))))