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 phoros-version (&key major minor revision
)
111 "Return version of this program, either one integer part as denoted by
112 the key argument, or the whole dotted string."
113 (let ((version-components
114 (mapcar #'parse-integer
115 (cl-utilities:split-sequence
#\.
*phoros-version
*))))
116 (cond (major (first version-components
))
117 (minor (second version-components
))
118 (revision (third version-components
))
119 (t *phoros-version
*))))
121 (defun check-dependencies ()
122 "Say OK if the necessary external dependencies are available."
125 (geographic-to-utm 33 13 52) ;check cs2cs
126 (phoros-photogrammetry:del-all
) ;check photogrammetry
127 (initialize-leap-seconds) ;check source of leap second info
128 (format *error-output
* "~&OK~%"))
129 (error (e) (format *error-output
* "~A~&" e
))))
131 (defun muffle-postgresql-warnings ()
132 "For current DB, silence PostgreSQL's warnings about implicitly
134 (unless *postgresql-warnings
*
135 (execute "SET client_min_messages TO ERROR;")))
137 (defun check-db (db-credentials)
138 "Check postgresql connection. Return t if successful; show error on
139 *error-output* otherwise. db-credentials is a list like so: (database
140 user password host &key (port 5432) use-ssl)."
143 (setf connection
(apply #'connect db-credentials
))
144 (error (e) (format *error-output
* "Database connection ~S failed: ~A~&"
147 (disconnect connection
)
150 (defun ignore-warnings (c) (declare (ignore c
)) (muffle-warning))
152 (defmethod hunchentoot:session-cookie-name
(acceptor)
153 (declare (ignore acceptor
))
156 (defun start-server (&key
(proxy-root "phoros") (http-port 8080) address
(common-root "/"))
157 "Start the presentation project server which listens on http-port
158 at address. Address defaults to all addresses of the local machine."
159 (setf *phoros-server
*
160 (make-instance 'hunchentoot
:acceptor
163 :access-logger
#'log-http-access
164 :message-logger
#'log-hunchentoot-message
))
165 (setf hunchentoot
:*session-max-time
* (* 3600 24))
166 (setf *proxy-root
* proxy-root
)
167 (setf *common-root
* common-root
)
168 (check-db *postgresql-credentials
*)
169 (with-connection *postgresql-credentials
*
170 (assert-phoros-db-major-version))
171 (hunchentoot:reset-session-secret
)
172 (hunchentoot:start
*phoros-server
*))
174 (defun stop-server () (hunchentoot:stop
*phoros-server
*))
176 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
177 (register-sql-operators :2+-ary
:&& :overlaps
))
179 (setf hunchentoot
:*default-handler
*
181 "Http default response."
182 (setf (hunchentoot:return-code
*) hunchentoot
:+http-not-found
+)))
184 (hunchentoot:define-easy-handler phoros-handler
()
185 "First HTTP contact: if necessary, check credentials, establish new
187 (with-connection *postgresql-credentials
*
188 (let* ((s (cl-utilities:split-sequence
190 (hunchentoot:script-name
*)
191 :remove-empty-subseqs t
))
192 (presentation-project-name (second s
))
193 (presentation-project-id
196 (:select
'presentation-project-id
197 :from
'sys-presentation-project
198 :where
(:= 'presentation-project-name
199 presentation-project-name
))
202 ;; TODO: remove the following line (which seems to function as a
203 ;; wakeup call of sorts)...
204 (get-dao 'sys-user-role
0 0)
205 ;; ...and make sure the following error doesn't occur any longer
206 ;; while accessing the HTTP server:
207 ;; #<POSTMODERN:DAO-CLASS PHOROS::SYS-USER-ROLE> cannot be printed readably.
210 ((null presentation-project-id
)
211 (setf (hunchentoot:return-code
*) hunchentoot
:+http-not-found
+))
212 ((and (equal (hunchentoot:session-value
'presentation-project-name
)
213 presentation-project-name
)
214 (hunchentoot:session-value
'authenticated-p
))
215 (hunchentoot:redirect
216 (format nil
"/~A/lib/view-~A"
223 (setf (hunchentoot:session-value
'presentation-project-name
)
224 presentation-project-name
)
225 (setf (hunchentoot:session-value
'presentation-project-id
)
226 presentation-project-id
)
227 (setf (hunchentoot:session-value
'presentation-project-bbox
)
230 (bounding-box (get-dao 'sys-presentation-project
231 presentation-project-name
)))))
232 (if (or (null bbox
) (eq :null bbox
))
235 (setf (hunchentoot:session-value
'aux-data-p
)
236 (with-connection *postgresql-aux-credentials
*
237 (view-exists-p (aux-point-view-name
238 presentation-project-name
))))
239 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
241 :style
"font-family:sans-serif;"
243 :method
"post" :enctype
"multipart/form-data"
244 :action
(format nil
"/~A/lib/authenticate"
248 (:legend
(:b
(:a
:href
"http://phoros.boundp.org"
249 :style
"text-decoration:none;"
251 (who:fmt
" [~A]" presentation-project-name
)))
253 (:b
(:em
"You can't do much without JavaScript there.")))
256 (:input
:type
"text" :name
"user-name"))
259 (:input
:type
"password" :name
"user-password")
261 (:span
:id
"cackle"))
262 (:input
:type
"submit" :value
"Submit"
264 (setf (chain document
265 (get-element-by-id "cackle")
267 "Ok, let's see…"))))
268 (:script
:type
"text/javascript"
269 (who:str
(ps (chain document
274 for i in
*login-intro
*
275 do
(who:htm
(:p
(who:str i
))))))))))))
277 (pushnew (hunchentoot:create-regex-dispatcher
"/phoros/(?!lib/)"
279 hunchentoot
:*dispatch-table
*)
281 (defun stored-bbox ()
282 "Return stored bounding box for user and presentation project of
284 (with-connection *postgresql-credentials
*
285 (let ((bbox (bounding-box
286 (get-dao 'sys-user-role
287 (hunchentoot:session-value
289 (hunchentoot:session-value
290 'presentation-project-id
)))))
292 (hunchentoot:session-value
'presentation-project-bbox
)
295 (defun stored-cursor ()
296 "Return stored cursor position for user and presentation project of
298 (with-connection *postgresql-credentials
*
301 (:select
(:st_x
'cursor
) (:st_y
'cursor
)
303 :where
(:and
(:= 'user-id
304 (hunchentoot:session-value
'user-id
))
305 (:= 'presentation-project-id
306 (hunchentoot:session-value
307 'presentation-project-id
))
308 (:raw
"cursor IS NOT NULL")))
311 (format nil
"~{~F~#^,~}" cursor
)))))
314 (hunchentoot:define-easy-handler
315 (authenticate-handler :uri
"/phoros/lib/authenticate"
316 :default-request-type
:post
)
318 "Check user credentials."
319 (with-connection *postgresql-credentials
*
320 (let* ((user-name (hunchentoot:post-parameter
"user-name"))
321 (user-password (hunchentoot:post-parameter
"user-password"))
322 (presentation-project-id (hunchentoot:session-value
323 'presentation-project-id
))
325 (when presentation-project-id
328 'sys-user.user-full-name
330 'sys-user-role.user-role
331 :from
'sys-user-role
'sys-user
333 (:= 'presentation-project-id presentation-project-id
)
334 (:= 'sys-user-role.user-id
'sys-user.user-id
)
335 (:= 'user-name user-name
)
336 (:= 'user-password user-password
)))
338 (user-full-name (first user-info
))
339 (user-id (second user-info
))
340 (user-role (third user-info
)))
343 (setf (hunchentoot:session-value
'authenticated-p
) t
344 (hunchentoot:session-value
'user-name
) user-name
345 (hunchentoot:session-value
'user-full-name
) user-full-name
346 (hunchentoot:session-value
'user-id
) user-id
347 (hunchentoot:session-value
'user-role
) user-role
)
348 (hunchentoot:redirect
349 (format nil
"/~A/lib/view-~A"
354 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
356 :style
"font-family:sans-serif;"
358 (:a
:href
(format nil
"/~A/~A/"
360 (hunchentoot:session-value
361 'presentation-project-name
))
364 (defun assert-authentication ()
365 "Abort request handler on unauthorized access."
366 (unless (hunchentoot:session-value
'authenticated-p
)
367 (setf (hunchentoot:return-code
*) hunchentoot
:+http-precondition-failed
+)
368 (hunchentoot:abort-request-handler
)))
370 (hunchentoot:define-easy-handler logout-handler
(bbox longitude latitude
)
371 (if (hunchentoot:session-value
'authenticated-p
)
372 (with-connection *postgresql-credentials
*
373 (let ((presentation-project-name
374 (hunchentoot:session-value
'presentation-project-name
))
376 (get-dao 'sys-user-role
377 (hunchentoot:session-value
'user-id
)
378 (hunchentoot:session-value
'presentation-project-id
))))
381 (setf (bounding-box sys-user-role
) bbox
))
382 (when (and longitude latitude
)
383 (let* ;; kludge: should be done by some library, not by DB query
384 ((point-form (format nil
"POINT(~F ~F)" longitude latitude
))
385 (point-wkb (query (:select
386 (:st_geomfromtext point-form
))
388 (setf (cursor sys-user-role
) point-wkb
)))
389 (update-dao sys-user-role
))
390 (hunchentoot:remove-session hunchentoot
:*session
*)
391 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
397 "Phoros: logged out" )))
398 (:link
:rel
"stylesheet"
399 :href
(format nil
"/~A/lib/css-~A/style.css"
404 (:h1
:id
"title" "Phoros: logged out")
405 (:p
"Log back in to project "
406 (:a
:href
(format nil
"/~A/~A"
408 presentation-project-name
)
409 (who:fmt
"~A." presentation-project-name
))))))))
412 (pushnew (hunchentoot:create-regex-dispatcher
"/logout" 'logout-handler
)
413 hunchentoot
:*dispatch-table
*)
415 (define-condition superseded
() ()
417 "Tell a thread to finish as soon as possible taking any shortcuts
420 (hunchentoot:define-easy-handler
421 (nearest-image-data :uri
"/phoros/lib/nearest-image-data"
422 :default-request-type
:post
)
424 "Receive coordinates, respond with the count nearest json objects
425 containing picture url, calibration parameters, and car position,
426 wrapped in an array. Wipe away any unfinished business first."
427 (assert-authentication)
428 (dolist (old-thread (hunchentoot:session-value
'recent-threads
))
430 (bt:interrupt-thread old-thread
431 #'(lambda () (signal 'superseded
)))))
432 (setf (hunchentoot:session-value
'recent-threads
) nil
)
433 (setf (hunchentoot:session-value
'number-of-threads
) 1)
434 (push (bt:current-thread
) (hunchentoot:session-value
'recent-threads
))
435 (setf (hunchentoot:content-type
*) "application/json")
436 (with-connection *postgresql-credentials
*
437 (let* ((presentation-project-id (hunchentoot:session-value
438 'presentation-project-id
))
439 (common-table-names (common-table-names
440 presentation-project-id
))
441 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
442 (longitude (cdr (assoc :longitude data
)))
443 (latitude (cdr (assoc :latitude data
)))
444 (count (cdr (assoc :count data
)))
445 (zoom (cdr (assoc :zoom data
)))
446 (snap-distance ;bogus distance in degrees,
447 (* 100e-5 ; assuming geographic
448 (expt 2 (- ; coordinates
449 14 ; (1m = 1e-5 degrees)
452 (point-form (format nil
"POINT(~F ~F)" longitude latitude
))
453 (nearest-footprint-centroid-query
454 ;; Inserting the following into
455 ;; image-data-with-footprints-query as a subquery would
456 ;; work correctly but is way too slow.
465 for common-table-name
466 in common-table-names
467 for aggregate-view-name
468 = (aggregate-view-name
474 (:st_centroid
'footprint
)
477 ,*standard-coordinates
*))
479 (:as
(:st_centroid
'footprint
)
482 ',aggregate-view-name
485 (:= 'presentation-project-id
486 ,presentation-project-id
)
491 ,*standard-coordinates
*)
496 (nearest-footprint-centroid
497 (ignore-errors (logged-query "centroid of nearest footprint"
498 nearest-footprint-centroid-query
500 (image-data-with-footprints-query
506 for common-table-name in common-table-names
507 for aggregate-view-name
508 = (aggregate-view-name common-table-name
)
511 (:as
(:st_distance
'coordinates
514 ;; ,*standard-coordinates*)
515 ,nearest-footprint-centroid
519 'recorded-device-id
;debug
520 'device-stage-of-life-id
;debug
521 'generic-device-id
;debug
523 'filename
'byte-position
'point-id
524 (:as
(:not
(:is-null
'footprint
))
526 ,(when *render-footprints-p
*
527 '(:as
(:st_asewkt
'footprint
)
530 ;;'coordinates ;the search target
531 'longitude
'latitude
'ellipsoid-height
533 'east-sd
'north-sd
'height-sd
534 'roll
'pitch
'heading
535 'roll-sd
'pitch-sd
'heading-sd
536 'sensor-width-pix
'sensor-height-pix
538 'bayer-pattern
'color-raiser
540 'dx
'dy
'dz
'omega
'phi
'kappa
541 'c
'xh
'yh
'a1
'a2
'a3
'b1
'b2
'c1
'c2
'r0
542 'b-dx
'b-dy
'b-dz
'b-rotx
'b-roty
'b-rotz
544 'b-drotx
'b-droty
'b-drotz
546 ',aggregate-view-name
549 (:= 'presentation-project-id
550 ,presentation-project-id
)
551 (:st_contains
'footprint
552 ,nearest-footprint-centroid
)))))
555 (image-data-without-footprints-query
561 for common-table-name in common-table-names
562 for aggregate-view-name
563 = (aggregate-view-name common-table-name
)
566 (:as
(:st_distance
'coordinates
569 ,*standard-coordinates
*))
572 'recorded-device-id
;debug
573 'device-stage-of-life-id
;debug
574 'generic-device-id
;debug
576 'filename
'byte-position
'point-id
577 (:as
(:not
(:is-null
'footprint
))
580 ;;'coordinates ;the search target
581 'longitude
'latitude
'ellipsoid-height
583 'east-sd
'north-sd
'height-sd
584 'roll
'pitch
'heading
585 'roll-sd
'pitch-sd
'heading-sd
586 'sensor-width-pix
'sensor-height-pix
588 'bayer-pattern
'color-raiser
590 'dx
'dy
'dz
'omega
'phi
'kappa
591 'c
'xh
'yh
'a1
'a2
'a3
'b1
'b2
'c1
'c2
'r0
592 'b-dx
'b-dy
'b-dz
'b-rotx
'b-roty
'b-rotz
594 'b-drotx
'b-droty
'b-drotz
596 ',aggregate-view-name
598 (:and
(:= 'presentation-project-id
599 ,presentation-project-id
)
600 (:st_dwithin
'coordinates
603 ,*standard-coordinates
*)
610 (if nearest-footprint-centroid
612 "footprints are ready"
613 image-data-with-footprints-query
:alists
)
616 image-data-without-footprints-query
:alists
)))
617 (superseded () nil
))))
618 (when *render-footprints-p
*
622 for photo-parameter-set in result
623 for footprint-vertices
= ;something like this:
624 ;; "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))"
625 (ignore-errors ;probably no :footprint-wkt
628 (parse-number:parse-real-number x
))
629 (cl-utilities:split-sequence
#\Space p
)))
631 (cl-utilities:split-sequence-if
636 (cdr (assoc :footprint-wkt photo-parameter-set
)))
639 (if footprint-vertices
643 '(:type
:coordinates
)
647 for footprint-vertex in footprint-vertices
648 for reprojected-vertex
=
651 ;; KLUDGE: translate keys, e.g. a1 -> a_1
652 (json:decode-json-from-string
653 (json:encode-json-to-string photo-parameter-set
))
654 (pairlis '(:x-global
:y-global
:z-global
)
656 (list (proj:degrees-to-radians
657 (first footprint-vertex
))
658 (proj:degrees-to-radians
659 (second footprint-vertex
))
660 (third footprint-vertex
))
662 (cdr (assoc :cartesian-system
663 photo-parameter-set
)))))
665 (list (cdr (assoc :m reprojected-vertex
))
666 (cdr (assoc :n reprojected-vertex
))))))
668 photo-parameter-set
))))
669 (decf (hunchentoot:session-value
'number-of-threads
))
670 (json:encode-json-to-string result
))))
672 (hunchentoot:define-easy-handler
673 (nearest-image-urls :uri
"/phoros/lib/nearest-image-urls"
674 :default-request-type
:post
)
676 "Receive coordinates, respond with a json array of the necessary
677 ingredients for the URLs of the 256 nearest images."
678 (assert-authentication)
679 (push (bt:current-thread
) (hunchentoot:session-value
'recent-threads
))
680 (if (<= (hunchentoot:session-value
'number-of-threads
)
681 0) ;only stuff cache if everything else is done
683 (incf (hunchentoot:session-value
'number-of-threads
))
684 (setf (hunchentoot:content-type
*) "application/json")
685 (with-connection *postgresql-credentials
*
686 (let* ((presentation-project-id (hunchentoot:session-value
687 'presentation-project-id
))
688 (common-table-names (common-table-names
689 presentation-project-id
))
690 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
691 (longitude (cdr (assoc :longitude data
)))
692 (latitude (cdr (assoc :latitude data
)))
694 (radius (* 5d-4
)) ; assuming geographic coordinates
695 (point-form (format nil
"POINT(~F ~F)" longitude latitude
))
704 'directory
'filename
'byte-position
705 'bayer-pattern
'color-raiser
'mounting-angle
711 for common-table-name
712 in common-table-names
713 for aggregate-view-name
714 = (aggregate-view-name common-table-name
)
718 'filename
'byte-position
719 'bayer-pattern
'color-raiser
725 ,*standard-coordinates
*))
728 ',aggregate-view-name
730 (:and
(:= 'presentation-project-id
731 ,presentation-project-id
)
736 ,*standard-coordinates
*)
743 (setf (hunchentoot:return-code
*)
744 hunchentoot
:+http-gateway-time-out
+)
745 ;; (decf (hunchentoot:session-value 'number-of-threads))
747 (decf (hunchentoot:session-value
'number-of-threads
))
748 (json:encode-json-to-string result
))))
749 (setf (hunchentoot:return-code
*) hunchentoot
:+http-gateway-time-out
+)))
751 (hunchentoot:define-easy-handler
752 (store-point :uri
"/phoros/lib/store-point" :default-request-type
:post
)
754 "Receive point sent by user; store it into database."
755 (assert-authentication)
756 (let* ((presentation-project-name (hunchentoot:session-value
757 'presentation-project-name
))
758 (user-id (hunchentoot:session-value
'user-id
))
759 (user-role (hunchentoot:session-value
'user-role
))
760 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
761 (longitude (cdr (assoc :longitude data
)))
762 (latitude (cdr (assoc :latitude data
)))
763 (ellipsoid-height (cdr (assoc :ellipsoid-height data
)))
764 (stdx-global (cdr (assoc :stdx-global data
)))
765 (stdy-global (cdr (assoc :stdy-global data
)))
766 (stdz-global (cdr (assoc :stdz-global data
)))
767 (input-size (cdr (assoc :input-size data
)))
768 (attribute (cdr (assoc :attribute data
)))
769 (description (cdr (assoc :description data
)))
770 (numeric-description (cdr (assoc :numeric-description data
)))
772 (format nil
"SRID=4326; POINT(~S ~S ~S)"
773 longitude latitude ellipsoid-height
))
774 (aux-numeric-raw (cdr (assoc :aux-numeric data
)))
775 (aux-text-raw (cdr (assoc :aux-text data
)))
776 (aux-numeric (if aux-numeric-raw
777 (apply #'vector aux-numeric-raw
)
779 (aux-text (if aux-text-raw
780 (apply #'vector aux-text-raw
)
782 (user-point-table-name
783 (user-point-table-name presentation-project-name
)))
785 (not (string-equal user-role
"read")) ;that is, "write" or "admin"
786 () "No write permission.")
787 (with-connection *postgresql-credentials
*
789 (= 1 (execute (:insert-into user-point-table-name
:set
792 'description description
793 'numeric-description numeric-description
794 'creation-date
'current-timestamp
795 'coordinates
(:st_geomfromewkt point-form
)
796 'stdx-global stdx-global
797 'stdy-global stdy-global
798 'stdz-global stdz-global
799 'input-size input-size
800 'aux-numeric aux-numeric
801 'aux-text aux-text
)))
802 () "No point stored. This should not happen."))))
804 (hunchentoot:define-easy-handler
805 (update-point :uri
"/phoros/lib/update-point" :default-request-type
:post
)
807 "Update point sent by user in database."
808 (assert-authentication)
809 (let* ((presentation-project-name (hunchentoot:session-value
810 'presentation-project-name
))
811 (user-id (hunchentoot:session-value
'user-id
))
812 (user-role (hunchentoot:session-value
'user-role
))
813 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
814 (user-point-id (cdr (assoc :user-point-id data
)))
815 (attribute (cdr (assoc :attribute data
)))
816 (description (cdr (assoc :description data
)))
817 (numeric-description (cdr (assoc :numeric-description data
)))
818 (user-point-table-name
819 (user-point-table-name presentation-project-name
)))
821 (not (string-equal user-role
"read")) ;that is, "write" or "admin"
822 () "No write permission.")
823 (with-connection *postgresql-credentials
*
826 (:update user-point-table-name
:set
829 'description description
830 'numeric-description numeric-description
831 'creation-date
'current-timestamp
832 :where
(:and
(:= 'user-point-id user-point-id
)
833 (:or
(:= (if (string-equal user-role
844 () "No point stored. Did you try to update someone else's point ~
845 without having admin permission?"))))
847 (defun increment-numeric-string (text)
848 "Increment rightmost numeric part of text if any; otherwise append a
849 three-digit numeric part."
850 (let* ((end-of-number
851 (1+ (or (position-if #'digit-char-p text
:from-end t
)
852 (1- (length text
)))))
854 (1+ (or (position-if-not #'digit-char-p text
:from-end t
857 (width-of-number (- end-of-number start-of-number
))
858 (prefix-text (subseq text
0 start-of-number
))
859 (suffix-text (subseq text end-of-number
)))
860 (when (zerop width-of-number
)
861 (setf width-of-number
3))
862 (format nil
"~A~V,'0D~A"
865 (1+ (or (ignore-errors
868 :start start-of-number
:end end-of-number
))
872 (hunchentoot:define-easy-handler
873 (uniquify-point-attributes :uri
"/phoros/lib/uniquify-point-attributes"
874 :default-request-type
:post
)
876 "Check if received set of point-attributes are unique. If so,
877 return null; otherwise return (as a suggestion) a uniquified version
878 of point-attributes by modifying element numeric-description."
879 (assert-authentication)
880 (setf (hunchentoot:content-type
*) "application/json")
881 (let* ((presentation-project-name (hunchentoot:session-value
882 'presentation-project-name
))
883 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
884 (user-point-id (cdr (assoc :user-point-id data
)))
885 (attribute (cdr (assoc :attribute data
)))
886 (description (cdr (assoc :description data
)))
887 (numeric-description (cdr (assoc :numeric-description data
)))
888 (user-point-table-name
889 (user-point-table-name presentation-project-name
)))
890 (flet ((uniquep (user-point-id attribute description numeric-description
)
891 "Check if given set of user-point attributes will be
900 :from user-point-table-name
901 :where
(:and
(:!= 'user-point-id user-point-id
)
902 (:= 'attribute attribute
)
903 (:= 'description description
)
904 (:= 'numeric-description
905 numeric-description
)))))
912 :from user-point-table-name
913 :where
(:and
(:= 'attribute attribute
)
914 (:= 'description description
)
915 (:= 'numeric-description
916 numeric-description
)))))
918 (with-connection *postgresql-credentials
*
919 (json:encode-json-to-string
921 user-point-id attribute description numeric-description
)
923 for s
= numeric-description
924 then
(increment-numeric-string s
)
925 until
(uniquep user-point-id attribute description s
)
927 (setf (cdr (assoc :numeric-description data
))
931 (hunchentoot:define-easy-handler
932 (delete-point :uri
"/phoros/lib/delete-point" :default-request-type
:post
)
934 "Delete user point if user is allowed to do so."
935 (assert-authentication)
936 (let* ((presentation-project-name (hunchentoot:session-value
937 'presentation-project-name
))
938 (user-id (hunchentoot:session-value
'user-id
))
939 (user-role (hunchentoot:session-value
'user-role
))
940 (user-point-table-name
941 (user-point-table-name presentation-project-name
))
942 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
943 (with-connection *postgresql-credentials
*
945 (eql 1 (cond ((string-equal user-role
"admin")
946 (execute (:delete-from user-point-table-name
947 :where
(:= 'user-point-id data
))))
948 ((string-equal user-role
"write")
951 user-point-table-name
953 (:= 'user-point-id data
)
954 (:or
(:= 'user-id user-id
)
961 () "No point deleted. This should not happen."))))
963 (defun common-table-names (presentation-project-id)
964 "Return a list of common-table-names of table sets that contain data
965 of presentation project with presentation-project-id."
968 (:select
'common-table-name
970 :from
'sys-presentation
'sys-measurement
'sys-acquisition-project
972 (:= 'sys-presentation.presentation-project-id
973 presentation-project-id
)
974 (:= 'sys-presentation.measurement-id
975 'sys-measurement.measurement-id
)
976 (:= 'sys-measurement.acquisition-project-id
977 'sys-acquisition-project.acquisition-project-id
)))
982 "While fetching common-table-names of presentation-project-id ~D: ~A"
983 presentation-project-id c
))))
985 (defun encode-geojson-to-string (features &key junk-keys
)
986 "Encode a list of property lists into a GeoJSON FeatureCollection.
987 Each property list must contain keys for coordinates, :x, :y, :z; it
988 may contain a numeric point :id and zero or more pieces of extra
989 information. The extra information is stored as GeoJSON Feature
990 properties. Exclude property list elements with keys that are in
992 (with-output-to-string (s)
993 (json:with-object
(s)
994 (json:encode-object-member
:type
:*feature-collection s
)
995 (json:as-object-member
(:features s
)
998 #'(lambda (point-with-properties)
999 (dolist (junk-key junk-keys
)
1000 (remf point-with-properties junk-key
))
1001 (destructuring-bind (&key x y z id
&allow-other-keys
) ;TODO: z probably bogus
1002 point-with-properties
1003 (json:as-array-member
(s)
1004 (json:with-object
(s)
1005 (json:encode-object-member
:type
:*feature s
)
1006 (json:as-object-member
(:geometry s
)
1007 (json:with-object
(s)
1008 (json:encode-object-member
:type
:*point s
)
1009 (json:as-object-member
(:coordinates s
)
1010 (json:encode-json
(list x y z
) s
))))
1011 (json:encode-object-member
:id id s
)
1012 (json:as-object-member
(:properties s
)
1013 (dolist (key '(:x
:y
:z
:id
))
1014 (remf point-with-properties key
))
1015 (json:encode-json-plist point-with-properties s
))))))
1017 (json:encode-object-member
:phoros-version
(phoros-version) s
))))
1020 "Return a WKT-compliant BOX3D string from string bbox."
1021 (concatenate 'string
"BOX3D("
1022 (substitute #\Space
#\
,
1023 (substitute #\Space
#\
, bbox
:count
1)
1024 :from-end t
:count
1)
1027 (hunchentoot:define-easy-handler
(points :uri
"/phoros/lib/points.json") (bbox)
1028 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
1029 (assert-authentication)
1030 (setf (hunchentoot:content-type
*) "application/json")
1032 (with-connection *postgresql-credentials
*
1033 (let* ((presentation-project-id
1034 (hunchentoot:session-value
'presentation-project-id
))
1036 (common-table-names presentation-project-id
)))
1037 (encode-geojson-to-string
1044 for common-table-name in common-table-names
1045 for aggregate-view-name
1046 = (point-data-table-name common-table-name
)
1047 ;; would have been nice, was too slow:
1048 ;; = (aggregate-view-name common-table-name)
1051 (:as
(:st_x
'coordinates
) x
)
1052 (:as
(:st_y
'coordinates
) y
)
1053 (:as
(:st_z
'coordinates
) z
)
1054 (:as
'point-id
'id
) ;becomes fid on client
1056 :distinct-on
'random
1057 :from
',aggregate-view-name
1058 :natural
:left-join
'sys-presentation
1061 (:= 'presentation-project-id
1062 ,presentation-project-id
)
1065 (:st_setsrid
(:type
,(box3d bbox
) box3d
)
1066 ,*standard-coordinates
*))))))
1068 ,*number-of-features-per-layer
*))
1070 :junk-keys
'(:random
))))
1073 :error
"While fetching points from inside bbox ~S: ~A"
1076 (hunchentoot:define-easy-handler
1077 (aux-points :uri
"/phoros/lib/aux-points.json")
1079 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
1080 (assert-authentication)
1081 (setf (hunchentoot:content-type
*) "application/json")
1083 (let ((limit *number-of-features-per-layer
*)
1085 (aux-point-view-name (hunchentoot:session-value
1086 'presentation-project-name
))))
1087 (encode-geojson-to-string
1088 (with-connection *postgresql-aux-credentials
*
1094 (:as
(:st_x
'coordinates
) 'x
)
1095 (:as
(:st_y
'coordinates
) 'y
)
1096 (:as
(:st_z
'coordinates
) 'z
)
1097 :from
,aux-view-name
1100 (:st_setsrid
(:type
,(box3d bbox
) box3d
)
1101 ,*standard-coordinates
*)))
1107 :error
"While fetching aux-points from inside bbox ~S: ~A"
1110 (hunchentoot:define-easy-handler
1111 (aux-local-data :uri
"/phoros/lib/aux-local-data"
1112 :default-request-type
:post
)
1114 "Receive coordinates, respond with the count nearest json objects
1115 containing arrays aux-numeric, aux-text, and distance to the
1116 coordinates received, wrapped in an array."
1117 (assert-authentication)
1118 (setf (hunchentoot:content-type
*) "application/json")
1119 (let* ((aux-view-name
1120 (aux-point-view-name (hunchentoot:session-value
1121 'presentation-project-name
)))
1122 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1123 (longitude (cdr (assoc :longitude data
)))
1124 (latitude (cdr (assoc :latitude data
)))
1125 (count (cdr (assoc :count data
)))
1127 (format nil
"POINT(~F ~F)" longitude latitude
))
1128 (snap-distance 1e-3) ;about 100 m, TODO: make this a defparameter
1130 (format nil
"~A,~A,~A,~A"
1131 (- longitude snap-distance
)
1132 (- latitude snap-distance
)
1133 (+ longitude snap-distance
)
1134 (+ latitude snap-distance
))))
1135 (encode-geojson-to-string
1137 (with-connection *postgresql-aux-credentials
*
1145 (:as
(:st_x
'coordinates
) 'x
)
1146 (:as
(:st_y
'coordinates
) 'y
)
1147 (:as
(:st_z
'coordinates
) 'z
)
1154 ,*spherical-mercator
*)
1156 (:st_geomfromtext
,point-form
,*standard-coordinates
*)
1157 ,*spherical-mercator
*))
1159 :from
',aux-view-name
1160 :where
(:&& 'coordinates
1162 ,(box3d bounding-box
) box3d
)
1163 ,*standard-coordinates
*)))
1168 (hunchentoot:define-easy-handler
1169 (aux-local-linestring :uri
"/phoros/lib/aux-local-linestring.json"
1170 :default-request-type
:post
)
1172 "Receive longitude, latitude, radius, and step-size; respond
1173 with the a JSON object comprising the elements linestring (a WKT
1174 linestring stitched together of the nearest auxiliary points from
1175 within radius around coordinates), current-point (the point on
1176 linestring closest to coordinates), and previous-point and next-point
1177 \(points on linestring step-size before and after current-point
1179 (assert-authentication)
1180 (setf (hunchentoot:content-type
*) "application/json")
1181 (let* ((thread-aux-points-function-name
1182 (thread-aux-points-function-name (hunchentoot:session-value
1183 'presentation-project-name
)))
1184 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1185 (longitude (cdr (assoc :longitude data
)))
1186 (latitude (cdr (assoc :latitude data
)))
1187 (radius (cdr (assoc :radius data
)))
1188 (step-size (cdr (assoc :step-size data
)))
1189 (azimuth (if (numberp (cdr (assoc :azimuth data
)))
1190 (cdr (assoc :azimuth data
))
1193 (format nil
"POINT(~F ~F)" longitude latitude
))
1196 (with-connection *postgresql-aux-credentials
*
1202 (,thread-aux-points-function-name
1204 ,point-form
,*standard-coordinates
*)
1206 ,*number-of-points-per-aux-linestring
*
1209 ,(proj:degrees-to-radians
91))))
1211 (with-output-to-string (s)
1212 (json:with-object
(s)
1213 (json:encode-object-member
1214 :linestring
(getf sql-response
:threaded-points
) s
)
1215 (json:encode-object-member
1216 :current-point
(getf sql-response
:current-point
) s
)
1217 (json:encode-object-member
1218 :previous-point
(getf sql-response
:back-point
) s
)
1219 (json:encode-object-member
1220 :next-point
(getf sql-response
:forward-point
) s
)
1221 (json:encode-object-member
1222 :azimuth
(getf sql-response
:new-azimuth
) s
)))))
1224 (defun get-user-points (user-point-table-name &key
1225 (bounding-box "-180,-90,180,90")
1227 (order-criterion 'id
))
1228 "Return limit points from user-point-table-name in GeoJSON format,
1229 and the number of points returned."
1230 (let ((user-point-plist
1236 (:as
(:st_x
'coordinates
) 'x
)
1237 (:as
(:st_y
'coordinates
) 'y
)
1238 (:as
(:st_z
'coordinates
) 'z
)
1239 (:as
'user-point-id
'id
) ;becomes fid in OpenLayers
1240 'stdx-global
'stdy-global
'stdz-global
1242 'attribute
'description
'numeric-description
1244 (:as
(:to-char
'creation-date
1245 ,*user-point-creation-date-format
*)
1247 'aux-numeric
'aux-text
1248 :from
,user-point-table-name
:natural
:left-join
'sys-user
1249 :where
(:&& 'coordinates
1250 (:st_setsrid
(:type
,(box3d bounding-box
) box3d
)
1251 ,*standard-coordinates
*)))
1256 (encode-geojson-to-string (nsubst nil
:null user-point-plist
))
1257 (length user-point-plist
))))
1259 (hunchentoot:define-easy-handler
1260 (user-points :uri
"/phoros/lib/user-points.json")
1262 "Send *number-of-features-per-layer* randomly chosen GeoJSON-encoded
1263 points from inside bbox to client. If there is no bbox parameter,
1265 (assert-authentication)
1266 (setf (hunchentoot:content-type
*) "application/json")
1268 (let ((bounding-box (or bbox
"-180,-90,180,90"))
1269 (limit (if bbox
*number-of-features-per-layer
* :null
))
1270 (order-criterion (if bbox
'(:random
) 'id
))
1271 (user-point-table-name
1272 (user-point-table-name (hunchentoot:session-value
1273 'presentation-project-name
))))
1274 (with-connection *postgresql-credentials
*
1275 (nth-value 0 (get-user-points user-point-table-name
1276 :bounding-box bounding-box
1278 :order-criterion order-criterion
))))
1281 :error
"While fetching user-points~@[ from inside bbox ~S~]: ~A"
1284 (hunchentoot:define-easy-handler
1285 (user-point-attributes :uri
"/phoros/lib/user-point-attributes.json")
1287 "Send JSON object comprising arrays attributes and descriptions,
1288 each containing unique values called attribute and description
1289 respectively, and count being the frequency of value in the user point
1291 (assert-authentication)
1292 (setf (hunchentoot:content-type
*) "application/json")
1294 (let ((user-point-table-name
1295 (user-point-table-name (hunchentoot:session-value
1296 'presentation-project-name
))))
1297 (with-connection *postgresql-credentials
*
1298 (with-output-to-string (s)
1299 (json:with-object
(s)
1300 (json:as-object-member
(:descriptions s
)
1301 (json:with-array
(s)
1302 (mapcar #'(lambda (x) (json:as-array-member
(s)
1303 (json:encode-json-plist x s
)))
1307 (:select
'description
1308 (:count
'description
)
1309 :from user-point-table-name
1310 :group-by
'description
)
1314 (json:as-object-member
(:attributes s
)
1315 (json:with-array
(s)
1316 (mapcar #'(lambda (x) (json:as-array-member
(s)
1317 (json:encode-json-plist x s
)))
1318 (query (format nil
"~
1319 (SELECT attribute, count(attribute) ~
1320 FROM ((SELECT attribute FROM ~A) ~
1323 FROM (VALUES ('solitary'), ~
1326 AS defaults(attribute))) ~
1327 AS attributes_union(attribute) ~
1328 GROUP BY attribute) ~
1329 ORDER BY attribute LIMIT 100"
1330 ;; Counts of solitary,
1331 ;; polyline, polygon may be
1332 ;; to big by one if we
1333 ;; collect them like this.
1334 (s-sql:to-sql-name user-point-table-name
))
1338 :error
"While fetching user-point-attributes: ~A"
1341 (hunchentoot:define-easy-handler photo-handler
1342 ((bayer-pattern :init-form
"65280,16711680")
1343 (color-raiser :init-form
"1,1,1")
1344 (mounting-angle :init-form
"0")
1346 "Serve an image from a .pictures file."
1347 (assert-authentication)
1351 (push (bt:current-thread
)
1352 (hunchentoot:session-value
'recent-threads
))
1353 (incf (hunchentoot:session-value
'number-of-threads
)))
1355 (cl-utilities:split-sequence
#\
/
1356 (hunchentoot:script-name
*)
1357 :remove-empty-subseqs t
))
1359 (cdddr ;remove leading phoros, lib, photo
1362 (cl-utilities:split-sequence
#\.
(first (last s
2))))
1364 (parse-integer (car (last s
)) :junk-allowed t
))
1369 :directory
(append (pathname-directory *common-root
*)
1372 :name
(first file-name-and-type
)
1373 :type
(second file-name-and-type
)))))
1375 (flex:with-output-to-sequence
(stream)
1377 stream path-to-file byte-position
1379 (apply #'vector
(mapcar
1381 (cl-utilities:split-sequence
1382 #\
, bayer-pattern
)))
1384 (apply #'vector
(mapcar
1385 #'parse-number
:parse-positive-real-number
1386 (cl-utilities:split-sequence
1389 :reversep
(= 180 (parse-integer mounting-angle
))
1390 :brightenp brightenp
))))
1391 (setf (hunchentoot:header-out
'cache-control
)
1392 (format nil
"max-age=~D" *browser-cache-max-age
*))
1393 (setf (hunchentoot:content-type
*) "image/png")
1395 (decf (hunchentoot:session-value
'number-of-threads
)))
1397 (setf (hunchentoot:return-code
*) hunchentoot
:+http-gateway-time-out
+)
1398 ;; (decf (hunchentoot:session-value 'number-of-threads))
1402 :error
"While serving image ~S: ~A" (hunchentoot:request-uri
*) c
))))
1404 (pushnew (hunchentoot:create-prefix-dispatcher
"/phoros/lib/photo"
1406 hunchentoot
:*dispatch-table
*)
1408 ;;; for debugging; this is the multi-file OpenLayers
1409 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1410 "/phoros/lib/openlayers/" "OpenLayers-2.10/")
1411 hunchentoot
:*dispatch-table
*)
1413 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1414 "/phoros/lib/ol/" "ol/")
1415 hunchentoot
:*dispatch-table
*)
1417 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1418 "/phoros/lib/public_html/" "public_html/")
1419 hunchentoot
:*dispatch-table
*)
1421 (pushnew (hunchentoot:create-static-file-dispatcher-and-handler
1422 "/favicon.ico" "public_html/favicon.ico")
1423 hunchentoot
:*dispatch-table
*)
1425 (hunchentoot:define-easy-handler
1426 (view :uri
(format nil
"/phoros/lib/view-~A" (phoros-version))
1427 :default-request-type
:post
)
1429 "Serve the client their main workspace."
1431 (hunchentoot:session-value
'authenticated-p
)
1432 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
1438 "Phoros: " (hunchentoot:session-value
1439 'presentation-project-name
))))
1440 (if *use-multi-file-openlayers
*
1443 :src
(format nil
"/~A/lib/openlayers/lib/Firebug/firebug.js"
1446 :src
(format nil
"/~A/lib/openlayers/lib/OpenLayers.js"
1450 :src
(format nil
"/~A/lib/ol/OpenLayers.js"
1452 (:link
:rel
"stylesheet"
1453 :href
(format nil
"/~A/lib/css-~A/style.css"
1457 (:script
:src
(format ;variability in script name is
1458 nil
; supposed to fight browser cache
1459 "/~A/lib/phoros-~A-~A-~A.js"
1462 (hunchentoot:session-value
'user-name
)
1463 (hunchentoot:session-value
'presentation-project-name
)))
1464 (:script
:src
"http://maps.google.com/maps/api/js?sensor=false"))
1467 (:noscript
(:b
(:em
"You can't do much without JavaScript here.")))
1469 "Phoros: " (who:str
(hunchentoot:session-value
'user-full-name
))
1470 (who:fmt
" (~A)" (hunchentoot:session-value
'user-name
))
1471 "with " (:span
:id
"user-role"
1472 (who:str
(hunchentoot:session-value
'user-role
)))
1474 (:span
:id
"presentation-project-name"
1475 (who:str
(hunchentoot:session-value
1476 'presentation-project-name
)))
1477 (:span
:id
"presentation-project-emptiness")
1478 (:span
:id
"recommend-fresh-login")
1479 (:span
:class
"h1-right"
1480 (:span
:id
"caching-indicator")
1481 (:span
:id
"phoros-version"
1482 (who:fmt
"v~A" (phoros-version)))))
1483 (:div
:class
"controlled-streetmap"
1484 (:div
:id
"streetmap" :class
"streetmap" :style
"cursor:crosshair")
1485 (:div
:id
"streetmap-controls" :class
"streetmap-controls"
1486 (:div
:id
"streetmap-vertical-strut"
1487 :class
"streetmap-vertical-strut")
1488 (:div
:id
"streetmap-layer-switcher"
1489 :class
"streetmap-layer-switcher")
1490 (:div
:id
"streetmap-overview" :class
"streetmap-overview")
1491 (:div
:id
"streetmap-mouse-position"
1492 :class
"streetmap-mouse-position")
1493 (:div
:id
"streetmap-zoom" :class
"streetmap-zoom")))
1494 (:div
:class
"phoros-controls" :id
"phoros-controls"
1495 (:div
:id
"real-phoros-controls"
1496 (:h2
(:span
:id
"h2-controls") (:span
:id
"creator"))
1497 (:div
:id
"point-attribute"
1499 (:select
:id
"point-attribute-select"
1500 :name
"point-attribute-select"
1501 :class
"combobox-select"
1502 :onchange
(ps-inline
1503 (consolidate-combobox
1506 (:input
:id
"point-attribute-input"
1507 :name
"point-attribute-input"
1508 :class
"combobox-input"
1509 :onchange
(ps-inline
1510 (unselect-combobox-selection
1514 (:input
:id
"point-numeric-description"
1515 :class
"vanilla-input"
1517 :type
"text" :name
"point-numeric-description")
1519 (:div
:id
"point-description"
1521 (:select
:id
"point-description-select"
1522 :name
"point-description-select"
1523 :class
"combobox-select"
1524 :onchange
(ps-inline
1525 (consolidate-combobox
1526 "point-description"))
1528 (:input
:id
"point-description-input"
1529 :name
"point-description-input"
1530 :class
"combobox-input"
1531 :onchange
(ps-inline
1532 (unselect-combobox-selection
1533 "point-description"))
1536 (:button
:id
"delete-point-button" :disabled t
1538 :onclick
(ps-inline (delete-point))
1540 (:button
:disabled t
:id
"finish-point-button"
1543 (:div
:id
"uniquify-buttons"
1544 (:button
:id
"suggest-unique-button"
1547 (insert-unique-suggestion))
1549 (:button
:id
"force-duplicate-button"
1552 (:div
:id
"aux-point-distance-or-point-creation-date"
1553 (:code
:id
"point-creation-date")
1554 (:select
:id
"aux-point-distance" :disabled t
1555 :size
1 :name
"aux-point-distance"
1556 :onchange
(ps-inline
1557 (aux-point-distance-selected))
1559 (enable-aux-point-selection)))
1560 (:div
:id
"include-aux-data"
1562 (:input
:id
"include-aux-data-p"
1563 :class
"tight-input"
1564 :type
"checkbox" :checked t
1565 :name
"include-aux-data-p"
1566 :onchange
(ps-inline
1567 (flip-aux-data-inclusion)))
1569 (:div
:id
"aux-data"
1570 (:div
:id
"aux-numeric-list")
1571 (:div
:id
"aux-text-list")))
1572 (:div
:id
"multiple-points-phoros-controls"
1573 (:h2
"Multiple Points Selected")
1574 (:p
"You have selected multiple user points.")
1575 (:p
"Unselect all but one to edit or view its properties."))
1576 (:div
:class
"walk-mode-controls"
1577 (:div
:id
"walk-mode"
1578 (:input
:id
"walk-p"
1579 :class
"tight-input"
1580 :type
"checkbox" :checked nil
1581 :onchange
(ps-inline
1583 (:label
:for
"walk-p"
1585 (:div
:id
"decrease-step-size"
1586 :onclick
(ps-inline (decrease-step-size)))
1587 (:div
:id
"step-size"
1588 :onclick
(ps-inline (increase-step-size))
1590 (:div
:id
"increase-step-size"
1591 :onclick
(ps-inline (increase-step-size))
1592 :ondblclick
(ps-inline (increase-step-size)
1593 (increase-step-size)))
1594 (:div
:id
"step-button" :disabled nil
1595 :onclick
(ps-inline (step))
1596 :ondblclick
(ps-inline (step t
))
1598 (:div
:class
"image-main-controls"
1599 (:div
:id
"auto-zoom"
1600 (:input
:id
"zoom-to-point-p"
1601 :class
"tight-input"
1602 :type
"checkbox" :checked t
)
1603 (:label
:for
"zoom-to-point-p"
1605 (:div
:id
"brighten-images"
1606 (:input
:id
"brighten-images-p"
1607 :class
"tight-input"
1608 :type
"checkbox" :checked nil
)
1609 (:label
:for
"brighten-images-p"
1611 (:div
:id
"zoom-images-to-max-extent"
1612 :onclick
(ps-inline (zoom-images-to-max-extent)))
1613 (:div
:id
"no-footprints-p"
1615 (:div
:id
"remove-work-layers-button" :disabled t
1616 :onclick
(ps-inline (reset-layers-and-controls))
1618 (:div
:class
"help-div"
1619 (:button
:id
"download-user-points-button"
1621 :onclick
(format nil
"self.location.href = \"/~A/lib/user-points.json\""
1623 "download points") ;TODO: offer other formats and maybe projections
1624 (:button
:id
"blurb-button"
1631 "/lib/blurb?openlayers-version="
1632 (@ *open-layers
*version_number
*))
1634 (:img
:src
(format nil
"/~A/lib/public_html/phoros-logo-plain.png"
1636 :alt
"Phoros" :style
"vertical-align:middle"
1638 (:button
:id
"logout-button"
1640 :onclick
(ps-inline (bye))
1642 (:h2
:id
"h2-help" "Help")
1643 (:div
:id
"help-display"))
1644 (:div
:id
"images" :style
"clear:both"
1646 for i from
0 below
*number-of-images
* do
1648 (:div
:class
"controlled-image"
1649 (:div
:id
(format nil
"image-~S-controls" i
)
1650 :class
"image-controls"
1651 (:div
:id
(format nil
"image-~S-zoom" i
)
1652 :class
"image-zoom")
1653 (:div
:id
(format nil
"image-~S-layer-switcher" i
)
1654 :class
"image-layer-switcher")
1655 (:div
:id
(format nil
"image-~S-usable" i
)
1656 :class
"image-usable"
1658 (:div
:id
(format nil
"image-~S-trigger-time" i
)
1659 :class
"image-trigger-time"))
1660 (:div
:id
(format nil
"image-~S" i
)
1661 :class
"image" :style
"cursor:crosshair"))))))))
1662 (hunchentoot:redirect
1663 (format nil
"/~A/~A"
1665 (hunchentoot:session-value
'presentation-project-name
))
1666 :add-session-id t
)))
1668 (hunchentoot:define-easy-handler
1669 (epipolar-line :uri
"/phoros/lib/epipolar-line")
1671 "Receive vector of two sets of picture parameters, the first of
1672 which containing coordinates (m, n) of a clicked point. Respond with a
1673 JSON encoded epipolar-line."
1674 (assert-authentication)
1675 (setf (hunchentoot:content-type
*) "application/json")
1676 (let* ((data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
1677 (json:encode-json-to-string
1678 (photogrammetry :epipolar-line
(first data
) (second data
)))))
1680 (hunchentoot:define-easy-handler
1681 (estimated-positions :uri
"/phoros/lib/estimated-positions")
1683 "Receive a two-part JSON vector comprising (1) a vector containing
1684 sets of picture-parameters with clicked (\"active\") points
1685 stored in :m, :n; and (2) a vector containing sets of
1686 picture-parameters; respond with a JSON encoded two-part vector
1687 comprising (1) a point in global coordinates; and (2) a vector of
1688 image coordinates (m, n) for the global point that correspond to the
1689 images from the received second vector. TODO: report error on bad
1690 data (ex: points too far apart)."
1691 ;; TODO: global-point-for-display should probably contain a proj string in order to make sense of the (cartesian) standard deviations.
1692 (assert-authentication)
1693 (setf (hunchentoot:content-type
*) "application/json")
1695 (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1696 (active-point-photo-parameters
1698 (number-of-active-points
1699 (length active-point-photo-parameters
))
1700 (destination-photo-parameters
1703 (cdr (assoc :cartesian-system
1704 (first active-point-photo-parameters
))))
1705 (global-point-cartesian
1707 :multi-position-intersection active-point-photo-parameters
))
1708 (global-point-geographic-radians
1709 (proj:cs2cs
(list (cdr (assoc :x-global global-point-cartesian
))
1710 (cdr (assoc :y-global global-point-cartesian
))
1711 (cdr (assoc :z-global global-point-cartesian
)))
1712 :source-cs cartesian-system
))
1713 (global-point-for-display ;points geographic cs, degrees; std deviations in cartesian cs
1714 (pairlis '(:longitude
:latitude
:ellipsoid-height
1715 :stdx-global
:stdy-global
:stdz-global
1718 (proj:radians-to-degrees
1719 (first global-point-geographic-radians
))
1720 (proj:radians-to-degrees
1721 (second global-point-geographic-radians
))
1722 (third global-point-geographic-radians
)
1723 (cdr (assoc :stdx-global global-point-cartesian
))
1724 (cdr (assoc :stdy-global global-point-cartesian
))
1725 (cdr (assoc :stdz-global global-point-cartesian
))
1726 number-of-active-points
)))
1729 for i in destination-photo-parameters
1732 (photogrammetry :reprojection i global-point-cartesian
)))))
1733 (json:encode-json-to-string
1734 (list global-point-for-display image-coordinates
))))
1736 (hunchentoot:define-easy-handler
1737 (user-point-positions :uri
"/phoros/lib/user-point-positions")
1739 "Receive a two-part JSON vector comprising
1740 - a vector of user-point-id's and
1741 - a vector containing sets of picture-parameters;
1742 respond with a JSON object comprising the elements
1743 - image-points, a vector whose elements
1744 - correspond to the elements of the picture-parameters vector
1746 - are GeoJSON feature collections containing one point (in picture
1747 coordinates) for each user-point-id received;
1748 - user-point-count, the number of user-points we tried to fetch
1750 (assert-authentication)
1751 (setf (hunchentoot:content-type
*) "application/json")
1752 (let* ((user-point-table-name
1753 (user-point-table-name (hunchentoot:session-value
1754 'presentation-project-name
)))
1755 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1756 (user-point-ids (first data
))
1757 (user-point-count (length user-point-ids
))
1758 (destination-photo-parameters (second data
))
1760 (cdr (assoc :cartesian-system
1761 (first destination-photo-parameters
)))) ;TODO: in rare cases, coordinate systems of the images shown may differ
1763 (with-connection *postgresql-credentials
*
1766 (:as
(:st_x
'coordinates
) 'longitude
)
1767 (:as
(:st_y
'coordinates
) 'latitude
)
1768 (:as
(:st_z
'coordinates
) 'ellipsoid-height
)
1769 (:as
'user-point-id
'id
) ;becomes fid on client
1772 'numeric-description
1774 (:as
(:to-char
'creation-date
"IYYY-MM-DD HH24:MI:SS TZ")
1778 :from user-point-table-name
:natural
:left-join
'sys-user
1779 :where
(:in
'user-point-id
(:set user-point-ids
)))
1781 (global-points-cartesian
1783 for global-point-geographic in user-points
1785 (ignore-errors ;in case no destination-photo-parameters have been sent
1786 (pairlis '(:x-global
:y-global
:z-global
)
1789 (proj:degrees-to-radians
1790 (getf global-point-geographic
:longitude
))
1791 (proj:degrees-to-radians
1792 (getf global-point-geographic
:latitude
))
1793 (getf global-point-geographic
:ellipsoid-height
))
1794 :destination-cs cartesian-system
)))))
1797 for photo-parameter-set in destination-photo-parameters
1799 (encode-geojson-to-string
1801 for global-point-cartesian in global-points-cartesian
1802 for user-point in user-points
1805 (let ((photo-coordinates
1806 (photogrammetry :reprojection
1808 global-point-cartesian
))
1811 (setf (getf photo-point
:x
)
1812 (cdr (assoc :m photo-coordinates
)))
1813 (setf (getf photo-point
:y
)
1814 (cdr (assoc :n photo-coordinates
)))
1816 :junk-keys
'(:longitude
:latitude
:ellipsoid-height
)))))
1817 (with-output-to-string (s)
1818 (json:with-object
(s)
1819 (json:encode-object-member
:user-point-count user-point-count s
)
1820 (json:as-object-member
(:image-points s
)
1821 (json:with-array
(s)
1822 (loop for i in image-coordinates do
1823 (json:as-array-member
(s) (princ i s
)))))))))
1825 (hunchentoot:define-easy-handler
1826 (multi-position-intersection :uri
"/phoros/lib/intersection")
1828 "Receive vector of sets of picture parameters, respond with stuff."
1829 (assert-authentication)
1830 (setf (hunchentoot:content-type
*) "application/json")
1831 (let* ((data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
1832 (json:encode-json-to-string
1833 (photogrammetry :multi-position-intersection data
))))