1 ;;; PHOROS -- Photogrammetric Road Survey
2 ;;; Copyright (C) 2010, 2011, 2012 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 *log-sql-p
* nil
60 "If t, log SQL queries and results.")
62 (defparameter *postgresql-warnings
* nil
63 "If t, show PostgreSQL's WARNINGs and NOTICEs.")
65 (defparameter *render-footprints-p
* nil
66 "If t, put image footprints into images on client.")
68 (defparameter *use-multi-file-openlayers
* nil
69 "If t, use OpenLayers uncompiled from openlayers/*, which makes
70 debugging easier. Otherwise use a single-file shrunk
73 (defparameter *number-of-images
* 4
74 "Number of photos shown to the HTTP client.")
76 (defparameter *aux-numeric-labels
* nil
77 "Labels for auxiliary numeric data rows shown to the HTTP client.")
79 (defparameter *aux-text-labels
* nil
80 "Labels for auxiliary text data rows shown to the HTTP client.")
82 (defparameter *browser-cache-max-age
* (* 3600 24 7)
83 "Value x for Cache-Control:max-age=x, for images on client.")
85 (defparameter *number-of-features-per-layer
* 500
86 "What we think a browser can swallow.")
88 (defparameter *number-of-points-per-aux-linestring
* 500
89 "What we think a browser can swallow.")
91 (defparameter *user-point-creation-date-format
* "IYYY-MM-DD HH24:MI:SS TZ"
92 "SQL date format used for display and GeoJSON export of user points.")
94 (defparameter *phoros-version
*
95 (asdf:component-version
(asdf:find-system
:phoros
))
96 "Phoros version as defined in system definition.")
98 (defparameter *phoros-description
*
99 (asdf:system-description
(asdf:find-system
:phoros
))
100 "Phoros description as defined in system definition.")
102 (defparameter *phoros-long-description
*
103 (asdf:system-long-description
(asdf:find-system
:phoros
))
104 "Phoros long-description as defined in system definition.")
106 (defparameter *phoros-licence
*
107 (asdf:system-licence
(asdf:find-system
:phoros
))
108 "Phoros licence as defined in system definition.")
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 (initialize-leap-seconds) ;check source of leap second info
134 (format *error-output
* "~&OK~%"))
135 (error (e) (format *error-output
* "~A~&" e
))))
137 (defun muffle-postgresql-warnings ()
138 "For current DB, silence PostgreSQL's warnings about implicitly
140 (unless *postgresql-warnings
*
141 (execute "SET client_min_messages TO ERROR;")))
143 (defun check-db (db-credentials)
144 "Check postgresql connection. Return t if successful; show error on
145 *error-output* otherwise. db-credentials is a list like so: (database
146 user password host &key (port 5432) use-ssl)."
149 (setf connection
(apply #'connect db-credentials
))
150 (error (e) (format *error-output
* "Database connection ~S failed: ~A~&"
153 (disconnect connection
)
156 (defun ignore-warnings (c) (declare (ignore c
)) (muffle-warning))
158 (defmethod hunchentoot:session-cookie-name
(acceptor)
159 (declare (ignore acceptor
))
162 (defun start-server (&key
(proxy-root "phoros") (http-port 8080) address
164 "Start the presentation project server which listens on http-port
165 at address. Address defaults to all addresses of the local machine."
166 (setf *phoros-server
*
167 (make-instance 'hunchentoot
:easy-acceptor
170 :document-root
(ensure-directories-exist
172 :error-template-directory
(ensure-directories-exist
173 "unexpected_html/errors/")))
174 (setf hunchentoot
:*session-max-time
* (* 3600 24))
175 (setf *proxy-root
* proxy-root
)
176 (setf *common-root
* common-root
)
177 (check-db *postgresql-credentials
*)
178 (with-connection *postgresql-credentials
*
179 (assert-phoros-db-major-version))
180 (hunchentoot:reset-session-secret
)
181 (hunchentoot:start
*phoros-server
*))
183 (defun stop-server () (hunchentoot:stop
*phoros-server
*))
185 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
186 (register-sql-operators :2+-ary
:&& :overlaps
))
188 (hunchentoot:define-easy-handler phoros-handler
()
189 "First HTTP contact: if necessary, check credentials, establish new
191 (with-connection *postgresql-credentials
*
192 (let* ((s (cl-utilities:split-sequence
194 (hunchentoot:script-name
*)
195 :remove-empty-subseqs t
))
196 (presentation-project-name (second s
))
197 (presentation-project-id
199 (presentation-project-id-from-name presentation-project-name
))))
201 ;; TODO: remove the following line (which seems to function as a
202 ;; wakeup call of sorts)...
203 (get-dao 'sys-user-role
0 0)
204 ;; ...and make sure the following error doesn't occur any longer
205 ;; while accessing the HTTP server:
206 ;; #<POSTMODERN:DAO-CLASS PHOROS::SYS-USER-ROLE> cannot be printed readably.
209 ((null presentation-project-id
)
210 (setf (hunchentoot:return-code
*) hunchentoot
:+http-not-found
+))
211 ((and (equal (hunchentoot:session-value
'presentation-project-name
)
212 presentation-project-name
)
213 (hunchentoot:session-value
'authenticated-p
))
214 (hunchentoot:redirect
215 (format nil
"/~A/lib/view-~A"
222 (setf (hunchentoot:session-value
'presentation-project-name
)
223 presentation-project-name
)
224 (setf (hunchentoot:session-value
'presentation-project-id
)
225 presentation-project-id
)
226 (setf (hunchentoot:session-value
'presentation-project-bbox
)
229 (bounding-box (get-dao 'sys-presentation-project
230 presentation-project-name
)))))
231 (if (or (null bbox
) (eq :null bbox
))
234 (setf (hunchentoot:session-value
'aux-data-p
)
235 (with-connection *postgresql-aux-credentials
*
236 (view-exists-p (aux-point-view-name
237 presentation-project-name
))))
238 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
240 :style
"font-family:sans-serif;"
242 :method
"post" :enctype
"multipart/form-data"
243 :action
(format nil
"/~A/lib/authenticate"
247 (:legend
(:b
(:a
:href
"http://phoros.boundp.org"
248 :style
"text-decoration:none;"
250 (who:fmt
" [~A]" presentation-project-name
)))
252 (:b
(:em
"You can't do much without JavaScript there.")))
255 (:input
:type
"text" :name
"user-name"))
258 (:input
:type
"password" :name
"user-password")
260 (:span
:id
"cackle"))
261 (:input
:type
"submit" :value
"Submit"
263 (setf (chain document
264 (get-element-by-id "cackle")
266 "Ok, let's see…"))))
267 (:script
:type
"text/javascript"
268 (who:str
(ps (chain document
273 for i in
*login-intro
*
274 do
(who:htm
(:p
(who:str i
))))))))))))
276 (pushnew (hunchentoot:create-regex-dispatcher
"/phoros/(?!lib/)"
278 hunchentoot
:*dispatch-table
*)
280 (defun stored-bbox ()
281 "Return stored bounding box for user and presentation project of
283 (with-connection *postgresql-credentials
*
284 (let ((bbox (bounding-box
285 (get-dao 'sys-user-role
286 (hunchentoot:session-value
288 (hunchentoot:session-value
289 'presentation-project-id
)))))
291 (hunchentoot:session-value
'presentation-project-bbox
)
294 (defun stored-cursor ()
295 "Return stored cursor position for user and presentation project of
297 (with-connection *postgresql-credentials
*
300 (:select
(:st_x
'cursor
) (:st_y
'cursor
)
302 :where
(:and
(:= 'user-id
303 (hunchentoot:session-value
'user-id
))
304 (:= 'presentation-project-id
305 (hunchentoot:session-value
306 'presentation-project-id
))
307 (:raw
"cursor IS NOT NULL")))
310 (format nil
"~{~F~#^,~}" cursor
)))))
313 (hunchentoot:define-easy-handler
314 (authenticate-handler :uri
"/phoros/lib/authenticate"
315 :default-request-type
:post
)
317 "Check user credentials."
318 (with-connection *postgresql-credentials
*
319 (let* ((user-name (hunchentoot:post-parameter
"user-name"))
320 (user-password (hunchentoot:post-parameter
"user-password"))
321 (presentation-project-id (hunchentoot:session-value
322 'presentation-project-id
))
324 (when presentation-project-id
327 'sys-user.user-full-name
329 'sys-user-role.user-role
330 :from
'sys-user-role
'sys-user
332 (:= 'presentation-project-id presentation-project-id
)
333 (:= 'sys-user-role.user-id
'sys-user.user-id
)
334 (:= 'user-name user-name
)
335 (:= 'user-password user-password
)))
337 (user-full-name (first user-info
))
338 (user-id (second user-info
))
339 (user-role (third user-info
)))
342 (setf (hunchentoot:session-value
'authenticated-p
) t
343 (hunchentoot:session-value
'user-name
) user-name
344 (hunchentoot:session-value
'user-full-name
) user-full-name
345 (hunchentoot:session-value
'user-id
) user-id
346 (hunchentoot:session-value
'user-role
) user-role
)
347 (hunchentoot:redirect
348 (format nil
"/~A/lib/view-~A"
353 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
355 :style
"font-family:sans-serif;"
357 (:a
:href
(format nil
"/~A/~A/"
359 (hunchentoot:session-value
360 'presentation-project-name
))
363 (defun assert-authentication ()
364 "Abort request handler on unauthorized access."
365 (unless (hunchentoot:session-value
'authenticated-p
)
366 (setf (hunchentoot:return-code
*) hunchentoot
:+http-precondition-failed
+)
367 (hunchentoot:abort-request-handler
)))
369 (hunchentoot:define-easy-handler logout-handler
(bbox longitude latitude
)
370 (if (hunchentoot:session-value
'authenticated-p
)
371 (with-connection *postgresql-credentials
*
372 (let ((presentation-project-name
373 (hunchentoot:session-value
'presentation-project-name
))
375 (get-dao 'sys-user-role
376 (hunchentoot:session-value
'user-id
)
377 (hunchentoot:session-value
'presentation-project-id
))))
380 (setf (bounding-box sys-user-role
) bbox
))
381 (when (and longitude latitude
)
382 (let* ;; kludge: should be done by some library, not by DB query
383 ((point-form (format nil
"POINT(~F ~F)" longitude latitude
))
384 (point-wkb (query (:select
385 (:st_geomfromtext point-form
))
387 (setf (cursor sys-user-role
) point-wkb
)))
388 (update-dao sys-user-role
))
389 (hunchentoot:remove-session hunchentoot
:*session
*)
390 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
396 "Phoros: logged out" )))
397 (:link
:rel
"stylesheet"
398 :href
(format nil
"/~A/lib/css-~A/style.css"
403 (:h1
:id
"title" "Phoros: logged out")
404 (:p
"Log back in to project "
405 (:a
:href
(format nil
"/~A/~A"
407 presentation-project-name
)
408 (who:fmt
"~A." presentation-project-name
))))))))
411 (pushnew (hunchentoot:create-regex-dispatcher
"/logout" 'logout-handler
)
412 hunchentoot
:*dispatch-table
*)
414 (define-condition superseded
() ()
416 "Tell a thread to finish as soon as possible taking any shortcuts
419 (hunchentoot:define-easy-handler
420 (selectable-restrictions :uri
"/phoros/lib/selectable-restrictions.json"
421 :default-request-type
:post
)
423 "Respond with a list of restrictions the user may choose from."
424 (assert-authentication)
425 (setf (hunchentoot:content-type
*) "application/json")
426 (with-connection *postgresql-credentials
*
427 (json:encode-json-to-string
430 (:select
'restriction-id
431 :from
'sys-selectable-restriction
432 :where
(:= 'presentation-project-id
433 (hunchentoot:session-value
434 'presentation-project-id
)))
438 (defun selected-restrictions (presentation-project-id selected-restriction-ids
)
439 "Get from current database connection a list of restriction clauses
440 belonging to presentation-project-id and ids from list
441 selected-restriction-ids."
444 `(:select
'sql-clause
445 :from
'sys-selectable-restriction
446 :where
(:and
(:= 'presentation-project-id
447 ,presentation-project-id
)
449 ,@(loop for i in selected-restriction-ids
450 collect
(list := 'restriction-id i
))))))
453 (defun sql-where-conjunction (sql-boolean-clauses)
454 "Parenthesize sql-boolean-clauses and concatenate them into a
455 string, separated by \"AND\". Return \" TRUE \" if
456 sql-boolean-clauses is nil."
457 (if sql-boolean-clauses
458 (apply #'concatenate
'string
(butlast (loop
459 for i in sql-boolean-clauses
466 (hunchentoot:define-easy-handler
467 (nearest-image-data :uri
"/phoros/lib/nearest-image-data"
468 :default-request-type
:post
)
470 "Receive coordinates, respond with the count nearest json objects
471 containing picture url, calibration parameters, and car position,
472 wrapped in an array. Wipe away any unfinished business first."
473 (assert-authentication)
474 (dolist (old-thread (hunchentoot:session-value
'recent-threads
))
476 (bt:interrupt-thread old-thread
477 #'(lambda () (signal 'superseded
)))))
478 (setf (hunchentoot:session-value
'recent-threads
) nil
)
479 (setf (hunchentoot:session-value
'number-of-threads
) 1)
480 (push (bt:current-thread
) (hunchentoot:session-value
'recent-threads
))
481 (setf (hunchentoot:content-type
*) "application/json")
482 (with-connection *postgresql-credentials
*
483 (let* ((presentation-project-id (hunchentoot:session-value
484 'presentation-project-id
))
485 (common-table-names (common-table-names
486 presentation-project-id
))
487 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
488 (longitude (cdr (assoc :longitude data
)))
489 (latitude (cdr (assoc :latitude data
)))
490 (count (cdr (assoc :count data
)))
491 (zoom (cdr (assoc :zoom data
)))
492 (snap-distance ;bogus distance in degrees,
493 (* 100e-5 ; assuming geographic
494 (expt 2 (- ; coordinates
495 14 ; (1m = 1e-5 degrees)
498 (point-form (format nil
"POINT(~F ~F)" longitude latitude
))
499 (selected-restrictions-conjunction
500 (sql-where-conjunction
501 (selected-restrictions presentation-project-id
502 (cdr (assoc :selected-restriction-ids
504 (nearest-footprint-centroid-query
505 ;; Inserting the following into
506 ;; image-data-with-footprints-query as a subquery would
507 ;; work correctly but is way too slow.
516 for common-table-name
517 in common-table-names
518 for aggregate-view-name
519 = (aggregate-view-name
525 (:st_centroid
'footprint
)
528 ,*standard-coordinates
*))
530 (:as
(:st_centroid
'footprint
)
533 ',aggregate-view-name
536 (:= 'presentation-project-id
537 ,presentation-project-id
)
542 ,*standard-coordinates
*)
544 (:raw
,selected-restrictions-conjunction
)))))
548 (nearest-footprint-centroid
549 (ignore-errors (logged-query "centroid of nearest footprint"
550 nearest-footprint-centroid-query
552 (image-data-with-footprints-query
558 for common-table-name in common-table-names
559 for aggregate-view-name
560 = (aggregate-view-name common-table-name
)
563 (:as
(:st_distance
'coordinates
564 ,nearest-footprint-centroid
)
567 'recorded-device-id
;debug
568 'device-stage-of-life-id
;debug
569 'generic-device-id
;debug
572 'filename
'byte-position
'point-id
573 (:as
(:not
(:is-null
'footprint
))
575 ,(when *render-footprints-p
*
576 '(:as
(:st_asewkt
'footprint
)
579 ;;'coordinates ;the search target
580 'longitude
'latitude
'ellipsoid-height
582 'east-sd
'north-sd
'height-sd
583 'roll
'pitch
'heading
584 'roll-sd
'pitch-sd
'heading-sd
585 'sensor-width-pix
'sensor-height-pix
587 'bayer-pattern
'color-raiser
589 'dx
'dy
'dz
'omega
'phi
'kappa
590 'c
'xh
'yh
'a1
'a2
'a3
'b1
'b2
'c1
'c2
'r0
591 'b-dx
'b-dy
'b-dz
'b-rotx
'b-roty
'b-rotz
593 'b-drotx
'b-droty
'b-drotz
595 ',aggregate-view-name
598 (:= 'presentation-project-id
599 ,presentation-project-id
)
600 (:st_contains
'footprint
601 ,nearest-footprint-centroid
)
602 (:raw
,selected-restrictions-conjunction
)))))
605 (image-data-without-footprints-query
611 for common-table-name in common-table-names
612 for aggregate-view-name
613 = (aggregate-view-name common-table-name
)
616 (:as
(:st_distance
'coordinates
619 ,*standard-coordinates
*))
622 'recorded-device-id
;debug
623 'device-stage-of-life-id
;debug
624 'generic-device-id
;debug
627 'filename
'byte-position
'point-id
628 (:as
(:not
(:is-null
'footprint
))
631 ;;'coordinates ;the search target
632 'longitude
'latitude
'ellipsoid-height
634 'east-sd
'north-sd
'height-sd
635 'roll
'pitch
'heading
636 'roll-sd
'pitch-sd
'heading-sd
637 'sensor-width-pix
'sensor-height-pix
639 'bayer-pattern
'color-raiser
641 'dx
'dy
'dz
'omega
'phi
'kappa
642 'c
'xh
'yh
'a1
'a2
'a3
'b1
'b2
'c1
'c2
'r0
643 'b-dx
'b-dy
'b-dz
'b-rotx
'b-roty
'b-rotz
645 'b-drotx
'b-droty
'b-drotz
647 ',aggregate-view-name
649 (:and
(:= 'presentation-project-id
650 ,presentation-project-id
)
651 (:st_dwithin
'coordinates
654 ,*standard-coordinates
*)
656 (:raw
,selected-restrictions-conjunction
)))))
662 (if nearest-footprint-centroid
663 (logged-query "footprints are ready"
664 image-data-with-footprints-query
666 (logged-query "no footprints yet"
667 image-data-without-footprints-query
669 (superseded () nil
))))
670 (when *render-footprints-p
*
674 for photo-parameter-set in result
675 for footprint-vertices
= ;something like this:
676 ;; "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))"
677 (ignore-errors ;probably no :footprint-wkt
680 (parse-number:parse-real-number x
))
681 (cl-utilities:split-sequence
#\Space p
)))
683 (cl-utilities:split-sequence-if
688 (cdr (assoc :footprint-wkt photo-parameter-set
)))
691 (if footprint-vertices
695 '(:type
:coordinates
)
699 for footprint-vertex in footprint-vertices
700 for reprojected-vertex
=
703 ;; KLUDGE: translate keys, e.g. a1 -> a_1
704 (json:decode-json-from-string
705 (json:encode-json-to-string photo-parameter-set
))
706 (pairlis '(:x-global
:y-global
:z-global
)
708 (list (proj:degrees-to-radians
709 (first footprint-vertex
))
710 (proj:degrees-to-radians
711 (second footprint-vertex
))
712 (third footprint-vertex
))
714 (cdr (assoc :cartesian-system
715 photo-parameter-set
)))))
717 (list (cdr (assoc :m reprojected-vertex
))
718 (cdr (assoc :n reprojected-vertex
))))))
720 photo-parameter-set
))))
721 (decf (hunchentoot:session-value
'number-of-threads
))
722 (json:encode-json-to-string result
))))
724 (hunchentoot:define-easy-handler
725 (nearest-image-urls :uri
"/phoros/lib/nearest-image-urls"
726 :default-request-type
:post
)
728 "Receive coordinates, respond with a json array of the necessary
729 ingredients for the URLs of the 256 nearest images."
730 (assert-authentication)
731 (push (bt:current-thread
) (hunchentoot:session-value
'recent-threads
))
732 (if (<= (hunchentoot:session-value
'number-of-threads
)
733 0) ;only stuff cache if everything else is done
735 (incf (hunchentoot:session-value
'number-of-threads
))
736 (setf (hunchentoot:content-type
*) "application/json")
737 (with-connection *postgresql-credentials
*
738 (let* ((presentation-project-id (hunchentoot:session-value
739 'presentation-project-id
))
740 (common-table-names (common-table-names
741 presentation-project-id
))
742 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
743 (longitude (cdr (assoc :longitude data
)))
744 (latitude (cdr (assoc :latitude data
)))
746 (radius (* 5d-4
)) ; assuming geographic coordinates
747 (point-form (format nil
"POINT(~F ~F)" longitude latitude
))
756 'directory
'filename
'byte-position
757 'bayer-pattern
'color-raiser
'mounting-angle
763 for common-table-name
764 in common-table-names
765 for aggregate-view-name
766 = (aggregate-view-name common-table-name
)
770 'filename
'byte-position
771 'bayer-pattern
'color-raiser
777 ,*standard-coordinates
*))
780 ',aggregate-view-name
782 (:and
(:= 'presentation-project-id
783 ,presentation-project-id
)
788 ,*standard-coordinates
*)
795 (setf (hunchentoot:return-code
*)
796 hunchentoot
:+http-gateway-time-out
+)
797 ;; (decf (hunchentoot:session-value 'number-of-threads))
799 (decf (hunchentoot:session-value
'number-of-threads
))
800 (json:encode-json-to-string result
))))
801 (setf (hunchentoot:return-code
*) hunchentoot
:+http-gateway-time-out
+)))
803 (hunchentoot:define-easy-handler
804 (store-point :uri
"/phoros/lib/store-point" :default-request-type
:post
)
806 "Receive point sent by user; store it into database."
807 (assert-authentication)
808 (let* ((presentation-project-name (hunchentoot:session-value
809 'presentation-project-name
))
810 (user-id (hunchentoot:session-value
'user-id
))
811 (user-role (hunchentoot:session-value
'user-role
))
812 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
813 (longitude (cdr (assoc :longitude data
)))
814 (latitude (cdr (assoc :latitude data
)))
815 (ellipsoid-height (cdr (assoc :ellipsoid-height data
)))
816 ;; (stdx-global (cdr (assoc :stdx-global data)))
817 ;; (stdy-global (cdr (assoc :stdy-global data)))
818 ;; (stdz-global (cdr (assoc :stdz-global data)))
819 (input-size (cdr (assoc :input-size data
)))
820 (kind (cdr (assoc :kind data
)))
821 (description (cdr (assoc :description data
)))
822 (numeric-description (cdr (assoc :numeric-description data
)))
824 (format nil
"SRID=4326; POINT(~S ~S ~S)"
825 longitude latitude ellipsoid-height
))
826 (aux-numeric-raw (setf *t
* (cdr (assoc :aux-numeric data
))))
827 (aux-text-raw (cdr (assoc :aux-text data
)))
828 (aux-numeric (if aux-numeric-raw
829 (nullify-nil (apply #'vector aux-numeric-raw
))
831 (aux-text (if aux-text-raw
832 (nullify-nil (apply #'vector aux-text-raw
))
834 (user-point-table-name
835 (user-point-table-name presentation-project-name
)))
837 (not (string-equal user-role
"read")) ;that is, "write" or "admin"
838 () "No write permission.")
839 (with-connection *postgresql-credentials
*
841 (= 1 (execute (:insert-into user-point-table-name
:set
844 'description description
845 'numeric-description numeric-description
846 'creation-date
'current-timestamp
847 'coordinates
(:st_geomfromewkt point-form
)
848 ;; 'stdx-global stdx-global
849 ;; 'stdy-global stdy-global
850 ;; 'stdz-global stdz-global
851 'input-size input-size
852 'aux-numeric aux-numeric
853 'aux-text aux-text
)))
854 () "No point stored. This should not happen."))))
856 (hunchentoot:define-easy-handler
857 (update-point :uri
"/phoros/lib/update-point" :default-request-type
:post
)
859 "Update point sent by user in database."
860 (assert-authentication)
861 (let* ((presentation-project-name (hunchentoot:session-value
862 'presentation-project-name
))
863 (user-id (hunchentoot:session-value
'user-id
))
864 (user-role (hunchentoot:session-value
'user-role
))
865 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
866 (user-point-id (cdr (assoc :user-point-id data
)))
867 (kind (cdr (assoc :kind data
)))
868 (description (cdr (assoc :description data
)))
869 (numeric-description (cdr (assoc :numeric-description data
)))
870 (user-point-table-name
871 (user-point-table-name presentation-project-name
)))
873 (not (string-equal user-role
"read")) ;that is, "write" or "admin"
874 () "No write permission.")
875 (with-connection *postgresql-credentials
*
878 (:update user-point-table-name
:set
881 'description description
882 'numeric-description numeric-description
883 'creation-date
'current-timestamp
884 :where
(:and
(:= 'user-point-id user-point-id
)
885 (:or
(:= (if (string-equal user-role
896 () "No point stored. Did you try to update someone else's point ~
897 without having admin permission?"))))
899 (defun increment-numeric-string (text)
900 "Increment rightmost numeric part of text if any; otherwise append a
901 three-digit numeric part."
902 (let* ((end-of-number
903 (1+ (or (position-if #'digit-char-p text
:from-end t
)
904 (1- (length text
)))))
906 (1+ (or (position-if-not #'digit-char-p text
:from-end t
909 (width-of-number (- end-of-number start-of-number
))
910 (prefix-text (subseq text
0 start-of-number
))
911 (suffix-text (subseq text end-of-number
)))
912 (when (zerop width-of-number
)
913 (setf width-of-number
3))
914 (format nil
"~A~V,'0D~A"
917 (1+ (or (ignore-errors
920 :start start-of-number
:end end-of-number
))
924 (hunchentoot:define-easy-handler
925 (uniquify-point-attributes :uri
"/phoros/lib/uniquify-point-attributes"
926 :default-request-type
:post
)
928 "Check if received set of point-attributes are unique. If so,
929 return null; otherwise return (as a suggestion) a uniquified version
930 of point-attributes by modifying element numeric-description."
931 (assert-authentication)
932 (setf (hunchentoot:content-type
*) "application/json")
933 (let* ((presentation-project-name (hunchentoot:session-value
934 'presentation-project-name
))
935 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
936 (user-point-id (cdr (assoc :user-point-id data
)))
937 (kind (cdr (assoc :kind data
)))
938 (description (cdr (assoc :description data
)))
939 (numeric-description (cdr (assoc :numeric-description data
)))
940 (user-point-table-name
941 (user-point-table-name presentation-project-name
)))
942 (flet ((uniquep (user-point-id kind description numeric-description
)
943 "Check if given set of user-point attributes will be
952 :from user-point-table-name
953 :where
(:and
(:!= 'user-point-id user-point-id
)
955 (:= 'description description
)
956 (:= 'numeric-description
957 numeric-description
)))))
964 :from user-point-table-name
965 :where
(:and
(:= 'kind kind
)
966 (:= 'description description
)
967 (:= 'numeric-description
968 numeric-description
)))))
970 (with-connection *postgresql-credentials
*
971 (json:encode-json-to-string
973 user-point-id kind description numeric-description
)
975 for s
= numeric-description
976 then
(increment-numeric-string s
)
977 until
(uniquep user-point-id kind description s
)
979 (setf (cdr (assoc :numeric-description data
))
983 (hunchentoot:define-easy-handler
984 (delete-point :uri
"/phoros/lib/delete-point" :default-request-type
:post
)
986 "Delete user point if user is allowed to do so."
987 (assert-authentication)
988 (let* ((presentation-project-name (hunchentoot:session-value
989 'presentation-project-name
))
990 (user-id (hunchentoot:session-value
'user-id
))
991 (user-role (hunchentoot:session-value
'user-role
))
992 (user-point-table-name
993 (user-point-table-name presentation-project-name
))
994 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
995 (with-connection *postgresql-credentials
*
997 (eql 1 (cond ((string-equal user-role
"admin")
998 (execute (:delete-from user-point-table-name
999 :where
(:= 'user-point-id data
))))
1000 ((string-equal user-role
"write")
1003 user-point-table-name
1005 (:= 'user-point-id data
)
1006 (:or
(:= 'user-id user-id
)
1013 () "No point deleted. This should not happen."))))
1015 (defun common-table-names (presentation-project-id)
1016 "Return a list of common-table-names of table sets that contain data
1017 of presentation project with presentation-project-id."
1020 (:select
'common-table-name
1022 :from
'sys-presentation
'sys-measurement
'sys-acquisition-project
1024 (:= 'sys-presentation.presentation-project-id
1025 presentation-project-id
)
1026 (:= 'sys-presentation.measurement-id
1027 'sys-measurement.measurement-id
)
1028 (:= 'sys-measurement.acquisition-project-id
1029 'sys-acquisition-project.acquisition-project-id
)))
1034 "While fetching common-table-names of presentation-project-id ~D: ~A"
1035 presentation-project-id c
))))
1037 (defun encode-geojson-to-string (features &key junk-keys
)
1038 "Encode a list of property lists into a GeoJSON FeatureCollection.
1039 Each property list must contain keys for coordinates, :x, :y, :z; it
1040 may contain a numeric point :id and zero or more pieces of extra
1041 information. The extra information is stored as GeoJSON Feature
1042 properties. Exclude property list elements with keys that are in
1044 (with-output-to-string (s)
1045 (json:with-object
(s)
1046 (json:encode-object-member
:type
:*feature-collection s
)
1047 (json:as-object-member
(:features s
)
1048 (json:with-array
(s)
1050 #'(lambda (point-with-properties)
1051 (dolist (junk-key junk-keys
)
1052 (remf point-with-properties junk-key
))
1053 (destructuring-bind (&key x y z id
&allow-other-keys
) ;TODO: z probably bogus
1054 point-with-properties
1055 (json:as-array-member
(s)
1056 (json:with-object
(s)
1057 (json:encode-object-member
:type
:*feature s
)
1058 (json:as-object-member
(:geometry s
)
1059 (json:with-object
(s)
1060 (json:encode-object-member
:type
:*point s
)
1061 (json:as-object-member
(:coordinates s
)
1062 (json:encode-json
(list x y z
) s
))))
1063 (json:encode-object-member
:id id s
)
1064 (json:as-object-member
(:properties s
)
1065 (dolist (key '(:x
:y
:z
:id
))
1066 (remf point-with-properties key
))
1067 (json:encode-json-plist point-with-properties s
))))))
1069 (json:encode-object-member
:phoros-version
(phoros-version) s
))))
1072 "Return a WKT-compliant BOX3D string from string bbox."
1073 (concatenate 'string
"BOX3D("
1074 (substitute #\Space
#\
,
1075 (substitute #\Space
#\
, bbox
:count
1)
1076 :from-end t
:count
1)
1079 (hunchentoot:define-easy-handler
(points :uri
"/phoros/lib/points.json") (bbox)
1080 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
1081 (assert-authentication)
1082 (setf (hunchentoot:content-type
*) "application/json")
1084 (with-connection *postgresql-credentials
*
1085 (let* ((presentation-project-id
1086 (hunchentoot:session-value
'presentation-project-id
))
1088 (common-table-names presentation-project-id
)))
1089 (encode-geojson-to-string
1096 for common-table-name in common-table-names
1097 for aggregate-view-name
1098 = (point-data-table-name common-table-name
)
1099 ;; would have been nice, was too slow:
1100 ;; = (aggregate-view-name common-table-name)
1103 (:as
(:st_x
'coordinates
) x
)
1104 (:as
(:st_y
'coordinates
) y
)
1105 (:as
(:st_z
'coordinates
) z
)
1106 (:as
'point-id
'id
) ;becomes fid on client
1108 :distinct-on
'random
1109 :from
',aggregate-view-name
1110 :natural
:left-join
'sys-presentation
1113 (:= 'presentation-project-id
1114 ,presentation-project-id
)
1117 (:st_setsrid
(:type
,(box3d bbox
) box3d
)
1118 ,*standard-coordinates
*))))))
1120 ,*number-of-features-per-layer
*))
1122 :junk-keys
'(:random
))))
1125 :error
"While fetching points from inside bbox ~S: ~A"
1128 (hunchentoot:define-easy-handler
1129 (aux-points :uri
"/phoros/lib/aux-points.json")
1131 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
1132 (assert-authentication)
1133 (setf (hunchentoot:content-type
*) "application/json")
1135 (let ((limit *number-of-features-per-layer
*)
1137 (aux-point-view-name (hunchentoot:session-value
1138 'presentation-project-name
))))
1139 (encode-geojson-to-string
1140 (with-connection *postgresql-aux-credentials
*
1146 (:as
(:st_x
'coordinates
) 'x
)
1147 (:as
(:st_y
'coordinates
) 'y
)
1148 (:as
(:st_z
'coordinates
) 'z
)
1149 :from
,aux-view-name
1152 (:st_setsrid
(:type
,(box3d bbox
) box3d
)
1153 ,*standard-coordinates
*)))
1159 :error
"While fetching aux-points from inside bbox ~S: ~A"
1162 (hunchentoot:define-easy-handler
1163 (aux-local-data :uri
"/phoros/lib/aux-local-data"
1164 :default-request-type
:post
)
1166 "Receive coordinates, respond with the count nearest json objects
1167 containing arrays aux-numeric, aux-text, and distance to the
1168 coordinates received, wrapped in an array."
1169 (assert-authentication)
1170 (setf (hunchentoot:content-type
*) "application/json")
1171 (let* ((aux-view-name
1172 (aux-point-view-name (hunchentoot:session-value
1173 'presentation-project-name
)))
1174 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1175 (longitude (cdr (assoc :longitude data
)))
1176 (latitude (cdr (assoc :latitude data
)))
1177 (count (cdr (assoc :count data
)))
1179 (format nil
"POINT(~F ~F)" longitude latitude
))
1180 (snap-distance 1e-3) ;about 100 m, TODO: make this a defparameter
1182 (format nil
"~A,~A,~A,~A"
1183 (- longitude snap-distance
)
1184 (- latitude snap-distance
)
1185 (+ longitude snap-distance
)
1186 (+ latitude snap-distance
))))
1187 (encode-geojson-to-string
1189 (with-connection *postgresql-aux-credentials
*
1196 (:as
(:st_x
'coordinates
) 'x
)
1197 (:as
(:st_y
'coordinates
) 'y
)
1198 (:as
(:st_z
'coordinates
) 'z
)
1205 ,*spherical-mercator
*)
1207 (:st_geomfromtext
,point-form
,*standard-coordinates
*)
1208 ,*spherical-mercator
*))
1210 :from
',aux-view-name
1211 :where
(:&& 'coordinates
1213 ,(box3d bounding-box
) box3d
)
1214 ,*standard-coordinates
*)))
1219 (defun nillify-null (x)
1220 "Replace occurences of :null in nested sequence x by nil."
1221 (cond ((eq :null x
) nil
)
1225 (t (map (type-of x
) #'nillify-null x
))))
1227 (defun nullify-nil (x)
1228 "Replace occurences of nil in nested sequence x by :null."
1229 (cond ((null x
) :null
)
1233 (t (map (type-of x
) #'nullify-nil x
))))
1235 (hunchentoot:define-easy-handler
1236 (aux-local-linestring :uri
"/phoros/lib/aux-local-linestring.json"
1237 :default-request-type
:post
)
1239 "Receive longitude, latitude, radius, and step-size; respond
1240 with a JSON object comprising the elements linestring (a WKT
1241 linestring stitched together of the nearest auxiliary points from
1242 within radius around coordinates), current-point (the point on
1243 linestring closest to coordinates), and previous-point and next-point
1244 \(points on linestring step-size before and after current-point
1245 respectively). Wipe away any unfinished business first."
1246 (assert-authentication)
1247 (dolist (old-thread (hunchentoot:session-value
'recent-threads
))
1249 (bt:interrupt-thread old-thread
1250 #'(lambda () (signal 'superseded
)))))
1251 (setf (hunchentoot:session-value
'recent-threads
) nil
)
1252 (setf (hunchentoot:session-value
'number-of-threads
) 1)
1253 (push (bt:current-thread
) (hunchentoot:session-value
'recent-threads
))
1254 (setf (hunchentoot:content-type
*) "application/json")
1255 (let* ((thread-aux-points-function-name
1256 (thread-aux-points-function-name (hunchentoot:session-value
1257 'presentation-project-name
)))
1258 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1259 (longitude (cdr (assoc :longitude data
)))
1260 (latitude (cdr (assoc :latitude data
)))
1261 (radius (cdr (assoc :radius data
)))
1262 (step-size (cdr (assoc :step-size data
)))
1263 (azimuth (if (numberp (cdr (assoc :azimuth data
)))
1264 (cdr (assoc :azimuth data
))
1267 (format nil
"POINT(~F ~F)" longitude latitude
))
1270 (with-connection *postgresql-aux-credentials
*
1275 (,thread-aux-points-function-name
1277 ,point-form
,*standard-coordinates
*)
1279 ,*number-of-points-per-aux-linestring
*
1282 ,(proj:degrees-to-radians
91))))
1284 (with-output-to-string (s)
1285 (json:with-object
(s)
1286 (json:encode-object-member
1287 :linestring
(getf sql-response
:threaded-points
) s
)
1288 (json:encode-object-member
1289 :current-point
(getf sql-response
:current-point
) s
)
1290 (json:encode-object-member
1291 :previous-point
(getf sql-response
:back-point
) s
)
1292 (json:encode-object-member
1293 :next-point
(getf sql-response
:forward-point
) s
)
1294 (json:encode-object-member
1295 :azimuth
(getf sql-response
:new-azimuth
) s
)))))
1297 (defun get-user-points (user-point-table-name &key
1298 (bounding-box "-180,-90,180,90")
1300 (order-criterion 'id
)
1302 "Return limit points from user-point-table-name in GeoJSON format,
1303 and the number of points returned."
1304 (let ((user-point-plist
1310 (:as
(:st_x
'coordinates
) 'x
)
1311 (:as
(:st_y
'coordinates
) 'y
)
1312 (:as
(:st_z
'coordinates
) 'z
)
1313 (:as
'user-point-id
'id
) ;becomes fid in OpenLayers
1314 ;; 'stdx-global 'stdy-global 'stdz-global
1316 'kind
'description
'numeric-description
1318 (:as
(:to-char
'creation-date
1319 ,*user-point-creation-date-format
*)
1321 'aux-numeric
'aux-text
1322 :from
,user-point-table-name
:natural
:left-join
'sys-user
1323 :where
(:&& 'coordinates
1324 (:st_setsrid
(:type
,(box3d bounding-box
) box3d
)
1325 ,*standard-coordinates
*)))
1332 (encode-geojson-to-string (nillify-null user-point-plist
)))
1333 (encode-geojson-to-string (nillify-null user-point-plist
)))
1334 (length user-point-plist
))))
1336 (hunchentoot:define-easy-handler
1337 (user-points :uri
"/phoros/lib/user-points.json")
1339 "Send *number-of-features-per-layer* randomly chosen GeoJSON-encoded
1340 points from inside bbox to client. If there is no bbox parameter,
1341 send all points and indent GeoJSON to make it more readable."
1342 (assert-authentication)
1343 (setf (hunchentoot:content-type
*) "application/json")
1345 (let ((bounding-box (or bbox
"-180,-90,180,90"))
1347 (limit (if bbox
*number-of-features-per-layer
* :null
))
1348 (order-criterion (if bbox
'(:random
) 'id
))
1349 (user-point-table-name
1350 (user-point-table-name (hunchentoot:session-value
1351 'presentation-project-name
))))
1352 (with-connection *postgresql-credentials
*
1353 (nth-value 0 (get-user-points user-point-table-name
1354 :bounding-box bounding-box
1356 :order-criterion order-criterion
1360 :error
"While fetching user-points~@[ from inside bbox ~S~]: ~A"
1363 (hunchentoot:define-easy-handler
1364 (user-point-attributes :uri
"/phoros/lib/user-point-attributes.json")
1366 "Send JSON object comprising arrays kinds and descriptions,
1367 each containing unique values called kind and description
1368 respectively, and count being the frequency of value in the user point
1370 (assert-authentication)
1371 (setf (hunchentoot:content-type
*) "application/json")
1373 (let ((user-point-table-name
1374 (user-point-table-name (hunchentoot:session-value
1375 'presentation-project-name
))))
1376 (with-connection *postgresql-credentials
*
1377 (with-output-to-string (s)
1378 (json:with-object
(s)
1379 (json:as-object-member
(:descriptions s
)
1380 (json:with-array
(s)
1381 (mapcar #'(lambda (x) (json:as-array-member
(s)
1382 (json:encode-json-plist x s
)))
1386 (:select
'description
1387 (:count
'description
)
1388 :from user-point-table-name
1389 :group-by
'description
)
1393 (json:as-object-member
(:kinds s
)
1394 (json:with-array
(s)
1395 (mapcar #'(lambda (x) (json:as-array-member
(s)
1396 (json:encode-json-plist x s
)))
1397 (query (format nil
"~
1398 (SELECT kind, count(kind) ~
1399 FROM ((SELECT kind FROM ~A) ~
1402 FROM (VALUES ('solitary'), ~
1405 AS defaults(kind))) ~
1406 AS kinds_union(kind) ~
1408 ORDER BY kind LIMIT 100"
1409 ;; Counts of solitary,
1410 ;; polyline, polygon may be
1411 ;; too big by one if we
1412 ;; collect them like this.
1413 (s-sql:to-sql-name user-point-table-name
))
1417 :error
"While fetching user-point-attributes: ~A"
1420 (hunchentoot:define-easy-handler photo-handler
1421 ((bayer-pattern :init-form
"65280,16711680")
1422 (color-raiser :init-form
"1,1,1")
1423 (mounting-angle :init-form
"0")
1425 "Serve an image from a .pictures file."
1426 (assert-authentication)
1430 (push (bt:current-thread
)
1431 (hunchentoot:session-value
'recent-threads
))
1432 (incf (hunchentoot:session-value
'number-of-threads
)))
1434 (cl-utilities:split-sequence
#\
/
1435 (hunchentoot:script-name
*)
1436 :remove-empty-subseqs t
))
1438 (cdddr ;remove leading phoros, lib, photo
1441 (cl-utilities:split-sequence
#\.
(first (last s
2))))
1443 (parse-integer (car (last s
)) :junk-allowed t
))
1448 :directory
(append (pathname-directory *common-root
*)
1451 :name
(first file-name-and-type
)
1452 :type
(second file-name-and-type
)))))
1454 (flex:with-output-to-sequence
(stream)
1456 stream path-to-file byte-position
1458 (apply #'vector
(mapcar
1460 (cl-utilities:split-sequence
1461 #\
, bayer-pattern
)))
1463 (apply #'vector
(mapcar
1464 #'parse-number
:parse-positive-real-number
1465 (cl-utilities:split-sequence
1468 :reversep
(= 180 (parse-integer mounting-angle
))
1469 :brightenp brightenp
))))
1470 (setf (hunchentoot:header-out
'cache-control
)
1471 (format nil
"max-age=~D" *browser-cache-max-age
*))
1472 (setf (hunchentoot:content-type
*) "image/png")
1474 (decf (hunchentoot:session-value
'number-of-threads
)))
1476 (setf (hunchentoot:return-code
*) hunchentoot
:+http-gateway-time-out
+)
1477 ;; (decf (hunchentoot:session-value 'number-of-threads))
1481 :error
"While serving image ~S: ~A" (hunchentoot:request-uri
*) c
))))
1483 (pushnew (hunchentoot:create-prefix-dispatcher
"/phoros/lib/photo"
1485 hunchentoot
:*dispatch-table
*)
1487 ;;; for debugging; this is the multi-file OpenLayers
1488 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1489 "/phoros/lib/openlayers/" "OpenLayers-2.10/")
1490 hunchentoot
:*dispatch-table
*)
1492 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1493 "/phoros/lib/ol/" "ol/")
1494 hunchentoot
:*dispatch-table
*)
1496 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1497 "/phoros/lib/public_html/" "public_html/")
1498 hunchentoot
:*dispatch-table
*)
1500 (pushnew (hunchentoot:create-static-file-dispatcher-and-handler
1501 "/favicon.ico" "public_html/favicon.ico")
1502 hunchentoot
:*dispatch-table
*)
1504 (hunchentoot:define-easy-handler
1505 (view :uri
(format nil
"/phoros/lib/view-~A" (phoros-version))
1506 :default-request-type
:post
)
1508 "Serve the client their main workspace."
1510 (hunchentoot:session-value
'authenticated-p
)
1511 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
1517 "Phoros: " (hunchentoot:session-value
1518 'presentation-project-name
))))
1519 (if *use-multi-file-openlayers
*
1522 :src
(format nil
"/~A/lib/openlayers/lib/Firebug/firebug.js"
1525 :src
(format nil
"/~A/lib/openlayers/lib/OpenLayers.js"
1529 :src
(format nil
"/~A/lib/ol/OpenLayers.js"
1531 (:link
:rel
"stylesheet"
1532 :href
(format nil
"/~A/lib/css-~A/style.css"
1536 (:script
:src
(format ;variability in script name is
1537 nil
; supposed to fight browser cache
1538 "/~A/lib/phoros-~A-~A-~A.js"
1541 (hunchentoot:session-value
'user-name
)
1542 (hunchentoot:session-value
'presentation-project-name
)))
1543 (:script
:src
"http://maps.google.com/maps/api/js?sensor=false"))
1546 (:noscript
(:b
(:em
"You can't do much without JavaScript here.")))
1549 "Phoros: " (who:str
(hunchentoot:session-value
'user-full-name
))
1550 (who:fmt
" (~A)" (hunchentoot:session-value
'user-name
))
1551 "with " (:span
:id
"user-role"
1552 (who:str
(hunchentoot:session-value
'user-role
)))
1554 (:span
:id
"presentation-project-name"
1555 (who:str
(hunchentoot:session-value
1556 'presentation-project-name
)))
1557 (:span
:id
"presentation-project-emptiness")
1558 (:span
:id
"recommend-fresh-login")
1559 (:span
:class
"h1-right"
1560 (:span
:id
"caching-indicator")
1561 (:span
:id
"phoros-version"
1562 (who:fmt
"v~A" (phoros-version)))))
1563 ;; streetmap area (northwest)
1565 :class
"controlled-streetmap"
1566 (:div
:id
"streetmap" :class
"streetmap" :style
"cursor:crosshair")
1567 (:div
:id
"streetmap-controls" :class
"streetmap-controls"
1568 (:div
:id
"streetmap-vertical-strut"
1569 :class
"streetmap-vertical-strut")
1570 (:div
:id
"streetmap-layer-switcher"
1571 :class
"streetmap-layer-switcher")
1572 (:button
:id
"unselect-all-restrictions-button"
1574 :onclick
(ps-inline (unselect-all-restrictions))
1576 (:select
:id
"restriction-select"
1577 :name
"restriction-select"
1580 :onchange
(ps-inline (request-photos)))
1581 (:div
:id
"streetmap-overview" :class
"streetmap-overview")
1582 (:div
:id
"streetmap-mouse-position"
1583 :class
"streetmap-mouse-position")
1584 (:div
:id
"streetmap-zoom" :class
"streetmap-zoom")))
1585 ;; control area (north)
1587 :class
"phoros-controls" :id
"phoros-controls"
1588 (:div
:id
"real-phoros-controls"
1589 (:h2
:class
"point-creator h2-phoros-controls"
1591 (:h2
:class
"point-editor h2-phoros-controls"
1593 (:span
:id
"creator"))
1594 (:h2
:class
"point-viewer h2-phoros-controls"
1596 (:span
:id
"creator"))
1597 (:h2
:class
"aux-data-viewer h2-phoros-controls"
1598 "View Auxiliary Data")
1599 (:h2
:class
"multiple-points-viewer"
1600 "Multiple Points Selected")
1601 (:div
:class
"multiple-points-viewer"
1602 (:p
"You have selected multiple user points.")
1603 (:p
"Unselect all but one to edit or view its properties."))
1604 (:span
:class
"point-creator point-editor point-viewer"
1609 :id
"point-kind-select"
1610 :name
"point-kind-select"
1611 :class
"combobox-select write-permission-dependent"
1612 :onchange
(ps-inline
1613 (consolidate-combobox
1617 :id
"point-kind-input"
1618 :name
"point-kind-input"
1619 :class
"combobox-input write-permission-dependent"
1620 :onchange
(ps-inline
1621 (unselect-combobox-selection
1625 (:input
:id
"point-numeric-description"
1626 :class
"vanilla-input write-permission-dependent"
1628 :type
"text" :name
"point-numeric-description")
1631 :id
"point-description"
1634 :id
"point-description-select"
1635 :name
"point-description-select"
1636 :class
"combobox-select write-permission-dependent"
1637 :onchange
(ps-inline
1638 (consolidate-combobox
1639 "point-description"))
1642 :id
"point-description-input"
1643 :name
"point-description-input"
1644 :class
"combobox-input write-permission-dependent"
1645 :onchange
(ps-inline
1646 (unselect-combobox-selection
1647 "point-description"))
1650 (:button
:id
"delete-point-button" :disabled t
1652 :onclick
(ps-inline (delete-point))
1654 (:button
:disabled t
:id
"finish-point-button"
1657 (:div
:id
"uniquify-buttons"
1658 (:button
:id
"suggest-unique-button"
1661 (insert-unique-suggestion))
1663 (:button
:id
"force-duplicate-button"
1666 (:div
:id
"aux-point-distance-or-point-creation-date"
1667 (:code
:id
"point-creation-date"
1668 :class
"point-editor point-viewer")
1670 :id
"aux-point-distance" :disabled t
1671 :class
"point-creator aux-data-viewer aux-data-dependent"
1672 :size
1 :name
"aux-point-distance"
1673 :onchange
(ps-inline
1674 (aux-point-distance-selected))
1676 (enable-aux-point-selection)))
1678 :id
"include-aux-data"
1679 :class
"point-creator aux-data-dependent"
1681 (:input
:id
"include-aux-data-p"
1682 :class
"tight-input"
1683 :type
"checkbox" :checked t
1684 :name
"include-aux-data-p"
1685 :onchange
(ps-inline
1686 (flip-aux-data-inclusion)))
1688 (:div
:id
"display-nearest-aux-data"
1689 :class
"aux-data-viewer"
1691 (:input
:id
"display-nearest-aux-data-p"
1692 :class
"tight-input"
1693 :type
"checkbox" :checked t
1694 :name
"display-nearest-aux-data-p"
1695 :onchange
(ps-inline
1696 (flip-nearest-aux-data-display)))
1700 :class
"point-creator point-editor point-viewer aux-data-viewer"
1701 (:div
:id
"aux-numeric-list")
1702 (:div
:id
"aux-text-list")))
1703 (:div
:class
"walk-mode-controls"
1704 (:div
:id
"walk-mode"
1705 :class
"aux-data-dependent"
1706 (:input
:id
"walk-p"
1707 :class
"tight-input"
1708 :type
"checkbox" :checked nil
1709 :onchange
(ps-inline
1711 (:label
:for
"walk-p"
1713 (:div
:id
"decrease-step-size"
1714 :class
"aux-data-dependent"
1715 :onclick
(ps-inline (decrease-step-size)))
1716 (:div
:id
"step-size"
1717 :class
"aux-data-dependent"
1718 :onclick
(ps-inline (increase-step-size))
1720 (:div
:id
"increase-step-size"
1721 :class
"aux-data-dependent"
1722 :onclick
(ps-inline (increase-step-size))
1723 :ondblclick
(ps-inline (increase-step-size)
1724 (increase-step-size)))
1725 (:div
:id
"step-button" :disabled nil
1726 :class
"aux-data-dependent"
1727 :onclick
(ps-inline (step))
1728 :ondblclick
(ps-inline (step t
))
1730 (:div
:class
"image-main-controls"
1731 (:div
:id
"auto-zoom"
1732 (:input
:id
"zoom-to-point-p"
1733 :class
"tight-input"
1734 :type
"checkbox" :checked t
)
1735 (:label
:for
"zoom-to-point-p"
1737 (:div
:id
"brighten-images"
1738 (:input
:id
"brighten-images-p"
1739 :class
"tight-input"
1740 :type
"checkbox" :checked nil
)
1741 (:label
:for
"brighten-images-p"
1743 (:div
:id
"zoom-images-to-max-extent"
1744 :onclick
(ps-inline (zoom-images-to-max-extent)))
1745 (:div
:id
"no-footprints-p"
1747 (:div
:id
"remove-work-layers-button" :disabled t
1748 :onclick
(ps-inline (reset-layers-and-controls))
1750 ;; help area (northeast)
1754 :id
"download-user-points-button"
1756 :onclick
(format nil
1757 "self.location.href = \"/~A/lib/user-points.json\""
1759 "download points") ;TODO: offer other formats and maybe projections
1768 "/lib/blurb?openlayers-version="
1769 (@ *open-layers
*version_number
*))
1771 (:img
:src
(format nil
"/~A/lib/public_html/phoros-logo-plain.png"
1773 :alt
"Phoros" :style
"vertical-align:middle"
1775 (:button
:id
"logout-button"
1777 :onclick
(ps-inline (bye))
1779 (:h2
:id
"h2-help" "Help")
1780 (:div
:id
"help-display"))
1781 ;; image area (south)
1782 (:div
:id
"images" :style
"clear:both"
1784 for i from
0 below
*number-of-images
* do
1786 (:div
:class
"controlled-image"
1787 (:div
:id
(format nil
"image-~S-controls" i
)
1788 :class
"image-controls"
1789 (:div
:id
(format nil
"image-~S-zoom" i
)
1790 :class
"image-zoom")
1791 (:div
:id
(format nil
"image-~S-layer-switcher" i
)
1792 :class
"image-layer-switcher")
1793 (:div
:id
(format nil
"image-~S-usable" i
)
1794 :class
"image-usable"
1796 (:div
:id
(format nil
"image-~S-trigger-time" i
)
1797 :class
"image-trigger-time"))
1798 (:div
:id
(format nil
"image-~S" i
)
1799 :class
"image" :style
"cursor:crosshair"))))))))
1800 (hunchentoot:redirect
1801 (format nil
"/~A/~A"
1803 (hunchentoot:session-value
'presentation-project-name
))
1804 :add-session-id t
)))
1806 (hunchentoot:define-easy-handler
1807 (epipolar-line :uri
"/phoros/lib/epipolar-line")
1809 "Receive vector of two sets of picture parameters, the first of
1810 which containing coordinates (m, n) of a clicked point. Respond with a
1811 JSON encoded epipolar-line."
1812 (assert-authentication)
1813 (setf (hunchentoot:content-type
*) "application/json")
1814 (let* ((data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
1815 (json:encode-json-to-string
1816 (photogrammetry :epipolar-line
(first data
) (second data
)))))
1818 (hunchentoot:define-easy-handler
1819 (estimated-positions :uri
"/phoros/lib/estimated-positions")
1821 "Receive a two-part JSON vector comprising (1) a vector containing
1822 sets of picture-parameters with clicked (\"active\") points
1823 stored in :m, :n; and (2) a vector containing sets of
1824 picture-parameters; respond with a JSON encoded two-part vector
1825 comprising (1) a point in global coordinates; and (2) a vector of
1826 image coordinates (m, n) for the global point that correspond to the
1827 images from the received second vector. TODO: report error on bad
1828 data (ex: points too far apart)."
1829 ;; TODO: global-point-for-display should probably contain a proj string in order to make sense of the (cartesian) standard deviations.
1830 (assert-authentication)
1831 (setf (hunchentoot:content-type
*) "application/json")
1833 (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1834 (active-point-photo-parameters
1836 (number-of-active-points
1837 (length active-point-photo-parameters
))
1838 (destination-photo-parameters
1841 (cdr (assoc :cartesian-system
1842 (first active-point-photo-parameters
))))
1843 (global-point-cartesian
1845 :multi-position-intersection active-point-photo-parameters
))
1846 (global-point-geographic-radians
1847 (proj:cs2cs
(list (cdr (assoc :x-global global-point-cartesian
))
1848 (cdr (assoc :y-global global-point-cartesian
))
1849 (cdr (assoc :z-global global-point-cartesian
)))
1850 :source-cs cartesian-system
))
1851 (global-point-for-display ;points geographic cs, degrees; std deviations in cartesian cs
1852 (pairlis '(:longitude
:latitude
:ellipsoid-height
1853 ;; :stdx-global :stdy-global :stdz-global
1856 (proj:radians-to-degrees
1857 (first global-point-geographic-radians
))
1858 (proj:radians-to-degrees
1859 (second global-point-geographic-radians
))
1860 (third global-point-geographic-radians
)
1861 ;; (cdr (assoc :stdx-global global-point-cartesian))
1862 ;; (cdr (assoc :stdy-global global-point-cartesian))
1863 ;; (cdr (assoc :stdz-global global-point-cartesian))
1864 number-of-active-points
)))
1867 for i in destination-photo-parameters
1870 (photogrammetry :reprojection i global-point-cartesian
)))))
1871 (json:encode-json-to-string
1872 (list global-point-for-display image-coordinates
))))
1874 (hunchentoot:define-easy-handler
1875 (user-point-positions :uri
"/phoros/lib/user-point-positions")
1877 "Receive a two-part JSON vector comprising
1878 - a vector of user-point-id's and
1879 - a vector containing sets of picture-parameters;
1880 respond with a JSON object comprising the elements
1881 - image-points, a vector whose elements
1882 - correspond to the elements of the picture-parameters vector
1884 - are GeoJSON feature collections containing one point (in picture
1885 coordinates) for each user-point-id received;
1886 - user-point-count, the number of user-points we tried to fetch
1888 (assert-authentication)
1889 (setf (hunchentoot:content-type
*) "application/json")
1890 (with-connection *postgresql-credentials
*
1891 (let* ((user-point-table-name
1892 (user-point-table-name (hunchentoot:session-value
1893 'presentation-project-name
)))
1894 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1895 (user-point-ids (first data
))
1896 (user-point-count (length user-point-ids
))
1897 (destination-photo-parameters (second data
))
1899 (cdr (assoc :cartesian-system
1900 (first destination-photo-parameters
)))) ;TODO: in rare cases, coordinate systems of the images shown may differ
1904 (:as
(:st_x
'coordinates
) 'longitude
)
1905 (:as
(:st_y
'coordinates
) 'latitude
)
1906 (:as
(:st_z
'coordinates
) 'ellipsoid-height
)
1907 (:as
'user-point-id
'id
) ;becomes fid on client
1910 'numeric-description
1912 (:as
(:to-char
'creation-date
"IYYY-MM-DD HH24:MI:SS TZ")
1916 :from user-point-table-name
:natural
:left-join
'sys-user
1917 :where
(:in
'user-point-id
(:set user-point-ids
)))
1919 (global-points-cartesian
1921 for global-point-geographic in user-points
1923 (ignore-errors ;in case no destination-photo-parameters have been sent
1924 (pairlis '(:x-global
:y-global
:z-global
)
1927 (proj:degrees-to-radians
1928 (getf global-point-geographic
:longitude
))
1929 (proj:degrees-to-radians
1930 (getf global-point-geographic
:latitude
))
1931 (getf global-point-geographic
:ellipsoid-height
))
1932 :destination-cs cartesian-system
)))))
1935 for photo-parameter-set in destination-photo-parameters
1937 (encode-geojson-to-string
1939 for global-point-cartesian in global-points-cartesian
1940 for user-point in user-points
1942 (when (point-within-image-p
1943 (getf user-point
:id
)
1944 (hunchentoot:session-value
'presentation-project-name
)
1945 (cdr (assoc :byte-position photo-parameter-set
))
1946 (cdr (assoc :filename photo-parameter-set
))
1947 (cdr (assoc :measurement-id photo-parameter-set
)))
1949 (let ((photo-coordinates
1950 (photogrammetry :reprojection
1952 global-point-cartesian
))
1955 (setf (getf photo-point
:x
)
1956 (cdr (assoc :m photo-coordinates
)))
1957 (setf (getf photo-point
:y
)
1958 (cdr (assoc :n photo-coordinates
)))
1960 :junk-keys
'(:longitude
:latitude
:ellipsoid-height
)))))
1961 (with-output-to-string (s)
1962 (json:with-object
(s)
1963 (json:encode-object-member
:user-point-count user-point-count s
)
1964 (json:as-object-member
(:image-points s
)
1965 (json:with-array
(s)
1966 (loop for i in image-coordinates do
1967 (json:as-array-member
(s) (princ i s
))))))))))
1969 (defun point-within-image-p (user-point-id presentation-project-name
1970 byte-position filename measurement-id
)
1971 "Return t if either point with user-point-id is inside the footprint
1972 of the image described by byte-position, filename, and measurement-id;
1973 or if that image doesn't have a footprint. Return nil otherwise."
1974 (let* ((user-point-table-name (user-point-table-name
1975 presentation-project-name
))
1976 (presentation-project-id (presentation-project-id-from-name
1977 presentation-project-name
))
1978 (common-table-names (common-table-names presentation-project-id
)))
1983 for common-table-name in common-table-names
1984 for aggregate-view-name
1985 = (aggregate-view-name common-table-name
)
1989 :from
',aggregate-view-name
1990 :where
(:and
(:= 'byte-position
,byte-position
)
1991 (:= 'filename
,filename
)
1992 (:= 'measurement-id
,measurement-id
)
1993 (:or
(:is-null
'footprint
)
1995 (:select
'coordinates
1996 :from
,user-point-table-name
1997 :where
(:= 'user-point-id
2002 (hunchentoot:define-easy-handler
2003 (multi-position-intersection :uri
"/phoros/lib/intersection")
2005 "Receive vector of sets of picture parameters, respond with stuff."
2006 (assert-authentication)
2007 (setf (hunchentoot:content-type
*) "application/json")
2008 (let* ((data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
2009 (json:encode-json-to-string
2010 (photogrammetry :multi-position-intersection data
))))