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
200 (:select
'presentation-project-id
201 :from
'sys-presentation-project
202 :where
(:= 'presentation-project-name
203 presentation-project-name
))
206 ;; TODO: remove the following line (which seems to function as a
207 ;; wakeup call of sorts)...
208 (get-dao 'sys-user-role
0 0)
209 ;; ...and make sure the following error doesn't occur any longer
210 ;; while accessing the HTTP server:
211 ;; #<POSTMODERN:DAO-CLASS PHOROS::SYS-USER-ROLE> cannot be printed readably.
214 ((null presentation-project-id
)
215 (setf (hunchentoot:return-code
*) hunchentoot
:+http-not-found
+))
216 ((and (equal (hunchentoot:session-value
'presentation-project-name
)
217 presentation-project-name
)
218 (hunchentoot:session-value
'authenticated-p
))
219 (hunchentoot:redirect
220 (format nil
"/~A/lib/view-~A"
227 (setf (hunchentoot:session-value
'presentation-project-name
)
228 presentation-project-name
)
229 (setf (hunchentoot:session-value
'presentation-project-id
)
230 presentation-project-id
)
231 (setf (hunchentoot:session-value
'presentation-project-bbox
)
234 (bounding-box (get-dao 'sys-presentation-project
235 presentation-project-name
)))))
236 (if (or (null bbox
) (eq :null bbox
))
239 (setf (hunchentoot:session-value
'aux-data-p
)
240 (with-connection *postgresql-aux-credentials
*
241 (view-exists-p (aux-point-view-name
242 presentation-project-name
))))
243 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
245 :style
"font-family:sans-serif;"
247 :method
"post" :enctype
"multipart/form-data"
248 :action
(format nil
"/~A/lib/authenticate"
252 (:legend
(:b
(:a
:href
"http://phoros.boundp.org"
253 :style
"text-decoration:none;"
255 (who:fmt
" [~A]" presentation-project-name
)))
257 (:b
(:em
"You can't do much without JavaScript there.")))
260 (:input
:type
"text" :name
"user-name"))
263 (:input
:type
"password" :name
"user-password")
265 (:span
:id
"cackle"))
266 (:input
:type
"submit" :value
"Submit"
268 (setf (chain document
269 (get-element-by-id "cackle")
271 "Ok, let's see…"))))
272 (:script
:type
"text/javascript"
273 (who:str
(ps (chain document
278 for i in
*login-intro
*
279 do
(who:htm
(:p
(who:str i
))))))))))))
281 (pushnew (hunchentoot:create-regex-dispatcher
"/phoros/(?!lib/)"
283 hunchentoot
:*dispatch-table
*)
285 (defun stored-bbox ()
286 "Return stored bounding box for user and presentation project of
288 (with-connection *postgresql-credentials
*
289 (let ((bbox (bounding-box
290 (get-dao 'sys-user-role
291 (hunchentoot:session-value
293 (hunchentoot:session-value
294 'presentation-project-id
)))))
296 (hunchentoot:session-value
'presentation-project-bbox
)
299 (defun stored-cursor ()
300 "Return stored cursor position for user and presentation project of
302 (with-connection *postgresql-credentials
*
305 (:select
(:st_x
'cursor
) (:st_y
'cursor
)
307 :where
(:and
(:= 'user-id
308 (hunchentoot:session-value
'user-id
))
309 (:= 'presentation-project-id
310 (hunchentoot:session-value
311 'presentation-project-id
))
312 (:raw
"cursor IS NOT NULL")))
315 (format nil
"~{~F~#^,~}" cursor
)))))
318 (hunchentoot:define-easy-handler
319 (authenticate-handler :uri
"/phoros/lib/authenticate"
320 :default-request-type
:post
)
322 "Check user credentials."
323 (with-connection *postgresql-credentials
*
324 (let* ((user-name (hunchentoot:post-parameter
"user-name"))
325 (user-password (hunchentoot:post-parameter
"user-password"))
326 (presentation-project-id (hunchentoot:session-value
327 'presentation-project-id
))
329 (when presentation-project-id
332 'sys-user.user-full-name
334 'sys-user-role.user-role
335 :from
'sys-user-role
'sys-user
337 (:= 'presentation-project-id presentation-project-id
)
338 (:= 'sys-user-role.user-id
'sys-user.user-id
)
339 (:= 'user-name user-name
)
340 (:= 'user-password user-password
)))
342 (user-full-name (first user-info
))
343 (user-id (second user-info
))
344 (user-role (third user-info
)))
347 (setf (hunchentoot:session-value
'authenticated-p
) t
348 (hunchentoot:session-value
'user-name
) user-name
349 (hunchentoot:session-value
'user-full-name
) user-full-name
350 (hunchentoot:session-value
'user-id
) user-id
351 (hunchentoot:session-value
'user-role
) user-role
)
352 (hunchentoot:redirect
353 (format nil
"/~A/lib/view-~A"
358 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
360 :style
"font-family:sans-serif;"
362 (:a
:href
(format nil
"/~A/~A/"
364 (hunchentoot:session-value
365 'presentation-project-name
))
368 (defun assert-authentication ()
369 "Abort request handler on unauthorized access."
370 (unless (hunchentoot:session-value
'authenticated-p
)
371 (setf (hunchentoot:return-code
*) hunchentoot
:+http-precondition-failed
+)
372 (hunchentoot:abort-request-handler
)))
374 (hunchentoot:define-easy-handler logout-handler
(bbox longitude latitude
)
375 (if (hunchentoot:session-value
'authenticated-p
)
376 (with-connection *postgresql-credentials
*
377 (let ((presentation-project-name
378 (hunchentoot:session-value
'presentation-project-name
))
380 (get-dao 'sys-user-role
381 (hunchentoot:session-value
'user-id
)
382 (hunchentoot:session-value
'presentation-project-id
))))
385 (setf (bounding-box sys-user-role
) bbox
))
386 (when (and longitude latitude
)
387 (let* ;; kludge: should be done by some library, not by DB query
388 ((point-form (format nil
"POINT(~F ~F)" longitude latitude
))
389 (point-wkb (query (:select
390 (:st_geomfromtext point-form
))
392 (setf (cursor sys-user-role
) point-wkb
)))
393 (update-dao sys-user-role
))
394 (hunchentoot:remove-session hunchentoot
:*session
*)
395 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
401 "Phoros: logged out" )))
402 (:link
:rel
"stylesheet"
403 :href
(format nil
"/~A/lib/css-~A/style.css"
408 (:h1
:id
"title" "Phoros: logged out")
409 (:p
"Log back in to project "
410 (:a
:href
(format nil
"/~A/~A"
412 presentation-project-name
)
413 (who:fmt
"~A." presentation-project-name
))))))))
416 (pushnew (hunchentoot:create-regex-dispatcher
"/logout" 'logout-handler
)
417 hunchentoot
:*dispatch-table
*)
419 (define-condition superseded
() ()
421 "Tell a thread to finish as soon as possible taking any shortcuts
424 (hunchentoot:define-easy-handler
425 (selectable-restrictions :uri
"/phoros/lib/selectable-restrictions.json"
426 :default-request-type
:post
)
428 "Respond with a list of restrictions the user may choose from."
429 (assert-authentication)
430 (setf (hunchentoot:content-type
*) "application/json")
431 (with-connection *postgresql-credentials
*
432 (json:encode-json-to-string
435 (:select
'restriction-id
436 :from
'sys-selectable-restriction
437 :where
(:= 'presentation-project-id
438 (hunchentoot:session-value
439 'presentation-project-id
)))
443 (defun selected-restrictions (presentation-project-id selected-restriction-ids
)
444 "Get from current database connection a list of restriction clauses
445 belonging to presentation-project-id and ids from list
446 selected-restriction-ids."
449 `(:select
'sql-clause
450 :from
'sys-selectable-restriction
451 :where
(:and
(:= 'presentation-project-id
452 ,presentation-project-id
)
454 ,@(loop for i in selected-restriction-ids
455 collect
(list := 'restriction-id i
))))))
458 (defun sql-where-conjunction (sql-boolean-clauses)
459 "Parenthesize sql-boolean-clauses and concatenate them into a
460 string, separated by \"AND\". Return \" TRUE \" if
461 sql-boolean-clauses is nil."
462 (if sql-boolean-clauses
463 (apply #'concatenate
'string
(butlast (loop
464 for i in sql-boolean-clauses
471 (hunchentoot:define-easy-handler
472 (nearest-image-data :uri
"/phoros/lib/nearest-image-data"
473 :default-request-type
:post
)
475 "Receive coordinates, respond with the count nearest json objects
476 containing picture url, calibration parameters, and car position,
477 wrapped in an array. Wipe away any unfinished business first."
478 (assert-authentication)
479 (dolist (old-thread (hunchentoot:session-value
'recent-threads
))
481 (bt:interrupt-thread old-thread
482 #'(lambda () (signal 'superseded
)))))
483 (setf (hunchentoot:session-value
'recent-threads
) nil
)
484 (setf (hunchentoot:session-value
'number-of-threads
) 1)
485 (push (bt:current-thread
) (hunchentoot:session-value
'recent-threads
))
486 (setf (hunchentoot:content-type
*) "application/json")
487 (with-connection *postgresql-credentials
*
488 (let* ((presentation-project-id (hunchentoot:session-value
489 'presentation-project-id
))
490 (common-table-names (common-table-names
491 presentation-project-id
))
492 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
493 (longitude (cdr (assoc :longitude data
)))
494 (latitude (cdr (assoc :latitude data
)))
495 (count (cdr (assoc :count data
)))
496 (zoom (cdr (assoc :zoom data
)))
497 (snap-distance ;bogus distance in degrees,
498 (* 100e-5 ; assuming geographic
499 (expt 2 (- ; coordinates
500 14 ; (1m = 1e-5 degrees)
503 (point-form (format nil
"POINT(~F ~F)" longitude latitude
))
504 (selected-restrictions-conjunction
505 (sql-where-conjunction
506 (selected-restrictions presentation-project-id
507 (cdr (assoc :selected-restriction-ids
509 (nearest-footprint-centroid-query
510 ;; Inserting the following into
511 ;; image-data-with-footprints-query as a subquery would
512 ;; work correctly but is way too slow.
521 for common-table-name
522 in common-table-names
523 for aggregate-view-name
524 = (aggregate-view-name
530 (:st_centroid
'footprint
)
533 ,*standard-coordinates
*))
535 (:as
(:st_centroid
'footprint
)
538 ',aggregate-view-name
541 (:= 'presentation-project-id
542 ,presentation-project-id
)
547 ,*standard-coordinates
*)
549 (:raw
,selected-restrictions-conjunction
)))))
553 (nearest-footprint-centroid
554 (ignore-errors (logged-query "centroid of nearest footprint"
555 nearest-footprint-centroid-query
557 (image-data-with-footprints-query
563 for common-table-name in common-table-names
564 for aggregate-view-name
565 = (aggregate-view-name common-table-name
)
568 (:as
(:st_distance
'coordinates
569 ,nearest-footprint-centroid
)
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
))
579 ,(when *render-footprints-p
*
580 '(:as
(:st_asewkt
'footprint
)
583 ;;'coordinates ;the search target
584 'longitude
'latitude
'ellipsoid-height
586 'east-sd
'north-sd
'height-sd
587 'roll
'pitch
'heading
588 'roll-sd
'pitch-sd
'heading-sd
589 'sensor-width-pix
'sensor-height-pix
591 'bayer-pattern
'color-raiser
593 'dx
'dy
'dz
'omega
'phi
'kappa
594 'c
'xh
'yh
'a1
'a2
'a3
'b1
'b2
'c1
'c2
'r0
595 'b-dx
'b-dy
'b-dz
'b-rotx
'b-roty
'b-rotz
597 'b-drotx
'b-droty
'b-drotz
599 ',aggregate-view-name
602 (:= 'presentation-project-id
603 ,presentation-project-id
)
604 (:st_contains
'footprint
605 ,nearest-footprint-centroid
)
606 (:raw
,selected-restrictions-conjunction
)))))
609 (image-data-without-footprints-query
615 for common-table-name in common-table-names
616 for aggregate-view-name
617 = (aggregate-view-name common-table-name
)
620 (:as
(:st_distance
'coordinates
623 ,*standard-coordinates
*))
626 'recorded-device-id
;debug
627 'device-stage-of-life-id
;debug
628 'generic-device-id
;debug
630 'filename
'byte-position
'point-id
631 (:as
(:not
(:is-null
'footprint
))
634 ;;'coordinates ;the search target
635 'longitude
'latitude
'ellipsoid-height
637 'east-sd
'north-sd
'height-sd
638 'roll
'pitch
'heading
639 'roll-sd
'pitch-sd
'heading-sd
640 'sensor-width-pix
'sensor-height-pix
642 'bayer-pattern
'color-raiser
644 'dx
'dy
'dz
'omega
'phi
'kappa
645 'c
'xh
'yh
'a1
'a2
'a3
'b1
'b2
'c1
'c2
'r0
646 'b-dx
'b-dy
'b-dz
'b-rotx
'b-roty
'b-rotz
648 'b-drotx
'b-droty
'b-drotz
650 ',aggregate-view-name
652 (:and
(:= 'presentation-project-id
653 ,presentation-project-id
)
654 (:st_dwithin
'coordinates
657 ,*standard-coordinates
*)
659 (:raw
,selected-restrictions-conjunction
)))))
665 (if nearest-footprint-centroid
666 (logged-query "footprints are ready"
667 image-data-with-footprints-query
669 (logged-query "no footprints yet"
670 image-data-without-footprints-query
672 (superseded () nil
))))
673 (when *render-footprints-p
*
677 for photo-parameter-set in result
678 for footprint-vertices
= ;something like this:
679 ;; "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))"
680 (ignore-errors ;probably no :footprint-wkt
683 (parse-number:parse-real-number x
))
684 (cl-utilities:split-sequence
#\Space p
)))
686 (cl-utilities:split-sequence-if
691 (cdr (assoc :footprint-wkt photo-parameter-set
)))
694 (if footprint-vertices
698 '(:type
:coordinates
)
702 for footprint-vertex in footprint-vertices
703 for reprojected-vertex
=
706 ;; KLUDGE: translate keys, e.g. a1 -> a_1
707 (json:decode-json-from-string
708 (json:encode-json-to-string photo-parameter-set
))
709 (pairlis '(:x-global
:y-global
:z-global
)
711 (list (proj:degrees-to-radians
712 (first footprint-vertex
))
713 (proj:degrees-to-radians
714 (second footprint-vertex
))
715 (third footprint-vertex
))
717 (cdr (assoc :cartesian-system
718 photo-parameter-set
)))))
720 (list (cdr (assoc :m reprojected-vertex
))
721 (cdr (assoc :n reprojected-vertex
))))))
723 photo-parameter-set
))))
724 (decf (hunchentoot:session-value
'number-of-threads
))
725 (json:encode-json-to-string result
))))
727 (hunchentoot:define-easy-handler
728 (nearest-image-urls :uri
"/phoros/lib/nearest-image-urls"
729 :default-request-type
:post
)
731 "Receive coordinates, respond with a json array of the necessary
732 ingredients for the URLs of the 256 nearest images."
733 (assert-authentication)
734 (push (bt:current-thread
) (hunchentoot:session-value
'recent-threads
))
735 (if (<= (hunchentoot:session-value
'number-of-threads
)
736 0) ;only stuff cache if everything else is done
738 (incf (hunchentoot:session-value
'number-of-threads
))
739 (setf (hunchentoot:content-type
*) "application/json")
740 (with-connection *postgresql-credentials
*
741 (let* ((presentation-project-id (hunchentoot:session-value
742 'presentation-project-id
))
743 (common-table-names (common-table-names
744 presentation-project-id
))
745 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
746 (longitude (cdr (assoc :longitude data
)))
747 (latitude (cdr (assoc :latitude data
)))
749 (radius (* 5d-4
)) ; assuming geographic coordinates
750 (point-form (format nil
"POINT(~F ~F)" longitude latitude
))
759 'directory
'filename
'byte-position
760 'bayer-pattern
'color-raiser
'mounting-angle
766 for common-table-name
767 in common-table-names
768 for aggregate-view-name
769 = (aggregate-view-name common-table-name
)
773 'filename
'byte-position
774 'bayer-pattern
'color-raiser
780 ,*standard-coordinates
*))
783 ',aggregate-view-name
785 (:and
(:= 'presentation-project-id
786 ,presentation-project-id
)
791 ,*standard-coordinates
*)
798 (setf (hunchentoot:return-code
*)
799 hunchentoot
:+http-gateway-time-out
+)
800 ;; (decf (hunchentoot:session-value 'number-of-threads))
802 (decf (hunchentoot:session-value
'number-of-threads
))
803 (json:encode-json-to-string result
))))
804 (setf (hunchentoot:return-code
*) hunchentoot
:+http-gateway-time-out
+)))
806 (hunchentoot:define-easy-handler
807 (store-point :uri
"/phoros/lib/store-point" :default-request-type
:post
)
809 "Receive point sent by user; store it into database."
810 (assert-authentication)
811 (let* ((presentation-project-name (hunchentoot:session-value
812 'presentation-project-name
))
813 (user-id (hunchentoot:session-value
'user-id
))
814 (user-role (hunchentoot:session-value
'user-role
))
815 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
816 (longitude (cdr (assoc :longitude data
)))
817 (latitude (cdr (assoc :latitude data
)))
818 (ellipsoid-height (cdr (assoc :ellipsoid-height data
)))
819 ;; (stdx-global (cdr (assoc :stdx-global data)))
820 ;; (stdy-global (cdr (assoc :stdy-global data)))
821 ;; (stdz-global (cdr (assoc :stdz-global data)))
822 (input-size (cdr (assoc :input-size data
)))
823 (kind (cdr (assoc :kind data
)))
824 (description (cdr (assoc :description data
)))
825 (numeric-description (cdr (assoc :numeric-description data
)))
827 (format nil
"SRID=4326; POINT(~S ~S ~S)"
828 longitude latitude ellipsoid-height
))
829 (aux-numeric-raw (cdr (assoc :aux-numeric data
)))
830 (aux-text-raw (cdr (assoc :aux-text data
)))
831 (aux-numeric (if aux-numeric-raw
832 (apply #'vector aux-numeric-raw
)
834 (aux-text (if aux-text-raw
835 (apply #'vector aux-text-raw
)
837 (user-point-table-name
838 (user-point-table-name presentation-project-name
)))
840 (not (string-equal user-role
"read")) ;that is, "write" or "admin"
841 () "No write permission.")
842 (with-connection *postgresql-credentials
*
844 (= 1 (execute (:insert-into user-point-table-name
:set
847 'description description
848 'numeric-description numeric-description
849 'creation-date
'current-timestamp
850 'coordinates
(:st_geomfromewkt point-form
)
851 ;; 'stdx-global stdx-global
852 ;; 'stdy-global stdy-global
853 ;; 'stdz-global stdz-global
854 'input-size input-size
855 'aux-numeric aux-numeric
856 'aux-text aux-text
)))
857 () "No point stored. This should not happen."))))
859 (hunchentoot:define-easy-handler
860 (update-point :uri
"/phoros/lib/update-point" :default-request-type
:post
)
862 "Update point sent by user in database."
863 (assert-authentication)
864 (let* ((presentation-project-name (hunchentoot:session-value
865 'presentation-project-name
))
866 (user-id (hunchentoot:session-value
'user-id
))
867 (user-role (hunchentoot:session-value
'user-role
))
868 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
869 (user-point-id (cdr (assoc :user-point-id data
)))
870 (kind (cdr (assoc :kind data
)))
871 (description (cdr (assoc :description data
)))
872 (numeric-description (cdr (assoc :numeric-description data
)))
873 (user-point-table-name
874 (user-point-table-name presentation-project-name
)))
876 (not (string-equal user-role
"read")) ;that is, "write" or "admin"
877 () "No write permission.")
878 (with-connection *postgresql-credentials
*
881 (:update user-point-table-name
:set
884 'description description
885 'numeric-description numeric-description
886 'creation-date
'current-timestamp
887 :where
(:and
(:= 'user-point-id user-point-id
)
888 (:or
(:= (if (string-equal user-role
899 () "No point stored. Did you try to update someone else's point ~
900 without having admin permission?"))))
902 (defun increment-numeric-string (text)
903 "Increment rightmost numeric part of text if any; otherwise append a
904 three-digit numeric part."
905 (let* ((end-of-number
906 (1+ (or (position-if #'digit-char-p text
:from-end t
)
907 (1- (length text
)))))
909 (1+ (or (position-if-not #'digit-char-p text
:from-end t
912 (width-of-number (- end-of-number start-of-number
))
913 (prefix-text (subseq text
0 start-of-number
))
914 (suffix-text (subseq text end-of-number
)))
915 (when (zerop width-of-number
)
916 (setf width-of-number
3))
917 (format nil
"~A~V,'0D~A"
920 (1+ (or (ignore-errors
923 :start start-of-number
:end end-of-number
))
927 (hunchentoot:define-easy-handler
928 (uniquify-point-attributes :uri
"/phoros/lib/uniquify-point-attributes"
929 :default-request-type
:post
)
931 "Check if received set of point-attributes are unique. If so,
932 return null; otherwise return (as a suggestion) a uniquified version
933 of point-attributes by modifying element numeric-description."
934 (assert-authentication)
935 (setf (hunchentoot:content-type
*) "application/json")
936 (let* ((presentation-project-name (hunchentoot:session-value
937 'presentation-project-name
))
938 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
939 (user-point-id (cdr (assoc :user-point-id data
)))
940 (kind (cdr (assoc :kind data
)))
941 (description (cdr (assoc :description data
)))
942 (numeric-description (cdr (assoc :numeric-description data
)))
943 (user-point-table-name
944 (user-point-table-name presentation-project-name
)))
945 (flet ((uniquep (user-point-id kind description numeric-description
)
946 "Check if given set of user-point attributes will be
955 :from user-point-table-name
956 :where
(:and
(:!= 'user-point-id user-point-id
)
958 (:= 'description description
)
959 (:= 'numeric-description
960 numeric-description
)))))
967 :from user-point-table-name
968 :where
(:and
(:= 'kind kind
)
969 (:= 'description description
)
970 (:= 'numeric-description
971 numeric-description
)))))
973 (with-connection *postgresql-credentials
*
974 (json:encode-json-to-string
976 user-point-id kind description numeric-description
)
978 for s
= numeric-description
979 then
(increment-numeric-string s
)
980 until
(uniquep user-point-id kind description s
)
982 (setf (cdr (assoc :numeric-description data
))
986 (hunchentoot:define-easy-handler
987 (delete-point :uri
"/phoros/lib/delete-point" :default-request-type
:post
)
989 "Delete user point if user is allowed to do so."
990 (assert-authentication)
991 (let* ((presentation-project-name (hunchentoot:session-value
992 'presentation-project-name
))
993 (user-id (hunchentoot:session-value
'user-id
))
994 (user-role (hunchentoot:session-value
'user-role
))
995 (user-point-table-name
996 (user-point-table-name presentation-project-name
))
997 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
998 (with-connection *postgresql-credentials
*
1000 (eql 1 (cond ((string-equal user-role
"admin")
1001 (execute (:delete-from user-point-table-name
1002 :where
(:= 'user-point-id data
))))
1003 ((string-equal user-role
"write")
1006 user-point-table-name
1008 (:= 'user-point-id data
)
1009 (:or
(:= 'user-id user-id
)
1016 () "No point deleted. This should not happen."))))
1018 (defun common-table-names (presentation-project-id)
1019 "Return a list of common-table-names of table sets that contain data
1020 of presentation project with presentation-project-id."
1023 (:select
'common-table-name
1025 :from
'sys-presentation
'sys-measurement
'sys-acquisition-project
1027 (:= 'sys-presentation.presentation-project-id
1028 presentation-project-id
)
1029 (:= 'sys-presentation.measurement-id
1030 'sys-measurement.measurement-id
)
1031 (:= 'sys-measurement.acquisition-project-id
1032 'sys-acquisition-project.acquisition-project-id
)))
1037 "While fetching common-table-names of presentation-project-id ~D: ~A"
1038 presentation-project-id c
))))
1040 (defun encode-geojson-to-string (features &key junk-keys
)
1041 "Encode a list of property lists into a GeoJSON FeatureCollection.
1042 Each property list must contain keys for coordinates, :x, :y, :z; it
1043 may contain a numeric point :id and zero or more pieces of extra
1044 information. The extra information is stored as GeoJSON Feature
1045 properties. Exclude property list elements with keys that are in
1047 (with-output-to-string (s)
1048 (json:with-object
(s)
1049 (json:encode-object-member
:type
:*feature-collection s
)
1050 (json:as-object-member
(:features s
)
1051 (json:with-array
(s)
1053 #'(lambda (point-with-properties)
1054 (dolist (junk-key junk-keys
)
1055 (remf point-with-properties junk-key
))
1056 (destructuring-bind (&key x y z id
&allow-other-keys
) ;TODO: z probably bogus
1057 point-with-properties
1058 (json:as-array-member
(s)
1059 (json:with-object
(s)
1060 (json:encode-object-member
:type
:*feature s
)
1061 (json:as-object-member
(:geometry s
)
1062 (json:with-object
(s)
1063 (json:encode-object-member
:type
:*point s
)
1064 (json:as-object-member
(:coordinates s
)
1065 (json:encode-json
(list x y z
) s
))))
1066 (json:encode-object-member
:id id s
)
1067 (json:as-object-member
(:properties s
)
1068 (dolist (key '(:x
:y
:z
:id
))
1069 (remf point-with-properties key
))
1070 (json:encode-json-plist point-with-properties s
))))))
1072 (json:encode-object-member
:phoros-version
(phoros-version) s
))))
1075 "Return a WKT-compliant BOX3D string from string bbox."
1076 (concatenate 'string
"BOX3D("
1077 (substitute #\Space
#\
,
1078 (substitute #\Space
#\
, bbox
:count
1)
1079 :from-end t
:count
1)
1082 (hunchentoot:define-easy-handler
(points :uri
"/phoros/lib/points.json") (bbox)
1083 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
1084 (assert-authentication)
1085 (setf (hunchentoot:content-type
*) "application/json")
1087 (with-connection *postgresql-credentials
*
1088 (let* ((presentation-project-id
1089 (hunchentoot:session-value
'presentation-project-id
))
1091 (common-table-names presentation-project-id
)))
1092 (encode-geojson-to-string
1099 for common-table-name in common-table-names
1100 for aggregate-view-name
1101 = (point-data-table-name common-table-name
)
1102 ;; would have been nice, was too slow:
1103 ;; = (aggregate-view-name common-table-name)
1106 (:as
(:st_x
'coordinates
) x
)
1107 (:as
(:st_y
'coordinates
) y
)
1108 (:as
(:st_z
'coordinates
) z
)
1109 (:as
'point-id
'id
) ;becomes fid on client
1111 :distinct-on
'random
1112 :from
',aggregate-view-name
1113 :natural
:left-join
'sys-presentation
1116 (:= 'presentation-project-id
1117 ,presentation-project-id
)
1120 (:st_setsrid
(:type
,(box3d bbox
) box3d
)
1121 ,*standard-coordinates
*))))))
1123 ,*number-of-features-per-layer
*))
1125 :junk-keys
'(:random
))))
1128 :error
"While fetching points from inside bbox ~S: ~A"
1131 (hunchentoot:define-easy-handler
1132 (aux-points :uri
"/phoros/lib/aux-points.json")
1134 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
1135 (assert-authentication)
1136 (setf (hunchentoot:content-type
*) "application/json")
1138 (let ((limit *number-of-features-per-layer
*)
1140 (aux-point-view-name (hunchentoot:session-value
1141 'presentation-project-name
))))
1142 (encode-geojson-to-string
1143 (with-connection *postgresql-aux-credentials
*
1149 (:as
(:st_x
'coordinates
) 'x
)
1150 (:as
(:st_y
'coordinates
) 'y
)
1151 (:as
(:st_z
'coordinates
) 'z
)
1152 :from
,aux-view-name
1155 (:st_setsrid
(:type
,(box3d bbox
) box3d
)
1156 ,*standard-coordinates
*)))
1162 :error
"While fetching aux-points from inside bbox ~S: ~A"
1165 (hunchentoot:define-easy-handler
1166 (aux-local-data :uri
"/phoros/lib/aux-local-data"
1167 :default-request-type
:post
)
1169 "Receive coordinates, respond with the count nearest json objects
1170 containing arrays aux-numeric, aux-text, and distance to the
1171 coordinates received, wrapped in an array."
1172 (assert-authentication)
1173 (setf (hunchentoot:content-type
*) "application/json")
1174 (let* ((aux-view-name
1175 (aux-point-view-name (hunchentoot:session-value
1176 'presentation-project-name
)))
1177 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1178 (longitude (cdr (assoc :longitude data
)))
1179 (latitude (cdr (assoc :latitude data
)))
1180 (count (cdr (assoc :count data
)))
1182 (format nil
"POINT(~F ~F)" longitude latitude
))
1183 (snap-distance 1e-3) ;about 100 m, TODO: make this a defparameter
1185 (format nil
"~A,~A,~A,~A"
1186 (- longitude snap-distance
)
1187 (- latitude snap-distance
)
1188 (+ longitude snap-distance
)
1189 (+ latitude snap-distance
))))
1190 (encode-geojson-to-string
1192 (with-connection *postgresql-aux-credentials
*
1200 (:as
(:st_x
'coordinates
) 'x
)
1201 (:as
(:st_y
'coordinates
) 'y
)
1202 (:as
(:st_z
'coordinates
) 'z
)
1209 ,*spherical-mercator
*)
1211 (:st_geomfromtext
,point-form
,*standard-coordinates
*)
1212 ,*spherical-mercator
*))
1214 :from
',aux-view-name
1215 :where
(:&& 'coordinates
1217 ,(box3d bounding-box
) box3d
)
1218 ,*standard-coordinates
*)))
1223 (hunchentoot:define-easy-handler
1224 (aux-local-linestring :uri
"/phoros/lib/aux-local-linestring.json"
1225 :default-request-type
:post
)
1227 "Receive longitude, latitude, radius, and step-size; respond
1228 with the a JSON object comprising the elements linestring (a WKT
1229 linestring stitched together of the nearest auxiliary points from
1230 within radius around coordinates), current-point (the point on
1231 linestring closest to coordinates), and previous-point and next-point
1232 \(points on linestring step-size before and after current-point
1234 (assert-authentication)
1235 (setf (hunchentoot:content-type
*) "application/json")
1236 (let* ((thread-aux-points-function-name
1237 (thread-aux-points-function-name (hunchentoot:session-value
1238 'presentation-project-name
)))
1239 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1240 (longitude (cdr (assoc :longitude data
)))
1241 (latitude (cdr (assoc :latitude data
)))
1242 (radius (cdr (assoc :radius data
)))
1243 (step-size (cdr (assoc :step-size data
)))
1244 (azimuth (if (numberp (cdr (assoc :azimuth data
)))
1245 (cdr (assoc :azimuth data
))
1248 (format nil
"POINT(~F ~F)" longitude latitude
))
1251 (with-connection *postgresql-aux-credentials
*
1257 (,thread-aux-points-function-name
1259 ,point-form
,*standard-coordinates
*)
1261 ,*number-of-points-per-aux-linestring
*
1264 ,(proj:degrees-to-radians
91))))
1266 (with-output-to-string (s)
1267 (json:with-object
(s)
1268 (json:encode-object-member
1269 :linestring
(getf sql-response
:threaded-points
) s
)
1270 (json:encode-object-member
1271 :current-point
(getf sql-response
:current-point
) s
)
1272 (json:encode-object-member
1273 :previous-point
(getf sql-response
:back-point
) s
)
1274 (json:encode-object-member
1275 :next-point
(getf sql-response
:forward-point
) s
)
1276 (json:encode-object-member
1277 :azimuth
(getf sql-response
:new-azimuth
) s
)))))
1279 (defun get-user-points (user-point-table-name &key
1280 (bounding-box "-180,-90,180,90")
1282 (order-criterion 'id
))
1283 "Return limit points from user-point-table-name in GeoJSON format,
1284 and the number of points returned."
1285 (let ((user-point-plist
1291 (:as
(:st_x
'coordinates
) 'x
)
1292 (:as
(:st_y
'coordinates
) 'y
)
1293 (:as
(:st_z
'coordinates
) 'z
)
1294 (:as
'user-point-id
'id
) ;becomes fid in OpenLayers
1295 ;; 'stdx-global 'stdy-global 'stdz-global
1297 'kind
'description
'numeric-description
1299 (:as
(:to-char
'creation-date
1300 ,*user-point-creation-date-format
*)
1302 'aux-numeric
'aux-text
1303 :from
,user-point-table-name
:natural
:left-join
'sys-user
1304 :where
(:&& 'coordinates
1305 (:st_setsrid
(:type
,(box3d bounding-box
) box3d
)
1306 ,*standard-coordinates
*)))
1311 (encode-geojson-to-string (nsubst nil
:null user-point-plist
))
1312 (length user-point-plist
))))
1314 (hunchentoot:define-easy-handler
1315 (user-points :uri
"/phoros/lib/user-points.json")
1317 "Send *number-of-features-per-layer* randomly chosen GeoJSON-encoded
1318 points from inside bbox to client. If there is no bbox parameter,
1320 (assert-authentication)
1321 (setf (hunchentoot:content-type
*) "application/json")
1323 (let ((bounding-box (or bbox
"-180,-90,180,90"))
1324 (limit (if bbox
*number-of-features-per-layer
* :null
))
1325 (order-criterion (if bbox
'(:random
) 'id
))
1326 (user-point-table-name
1327 (user-point-table-name (hunchentoot:session-value
1328 'presentation-project-name
))))
1329 (with-connection *postgresql-credentials
*
1330 (nth-value 0 (get-user-points user-point-table-name
1331 :bounding-box bounding-box
1333 :order-criterion order-criterion
))))
1336 :error
"While fetching user-points~@[ from inside bbox ~S~]: ~A"
1339 (hunchentoot:define-easy-handler
1340 (user-point-attributes :uri
"/phoros/lib/user-point-attributes.json")
1342 "Send JSON object comprising arrays kinds and descriptions,
1343 each containing unique values called kind and description
1344 respectively, and count being the frequency of value in the user point
1346 (assert-authentication)
1347 (setf (hunchentoot:content-type
*) "application/json")
1349 (let ((user-point-table-name
1350 (user-point-table-name (hunchentoot:session-value
1351 'presentation-project-name
))))
1352 (with-connection *postgresql-credentials
*
1353 (with-output-to-string (s)
1354 (json:with-object
(s)
1355 (json:as-object-member
(:descriptions s
)
1356 (json:with-array
(s)
1357 (mapcar #'(lambda (x) (json:as-array-member
(s)
1358 (json:encode-json-plist x s
)))
1362 (:select
'description
1363 (:count
'description
)
1364 :from user-point-table-name
1365 :group-by
'description
)
1369 (json:as-object-member
(:kinds s
)
1370 (json:with-array
(s)
1371 (mapcar #'(lambda (x) (json:as-array-member
(s)
1372 (json:encode-json-plist x s
)))
1373 (query (format nil
"~
1374 (SELECT kind, count(kind) ~
1375 FROM ((SELECT kind FROM ~A) ~
1378 FROM (VALUES ('solitary'), ~
1381 AS defaults(kind))) ~
1382 AS kinds_union(kind) ~
1384 ORDER BY kind LIMIT 100"
1385 ;; Counts of solitary,
1386 ;; polyline, polygon may be
1387 ;; too big by one if we
1388 ;; collect them like this.
1389 (s-sql:to-sql-name user-point-table-name
))
1393 :error
"While fetching user-point-attributes: ~A"
1396 (hunchentoot:define-easy-handler photo-handler
1397 ((bayer-pattern :init-form
"65280,16711680")
1398 (color-raiser :init-form
"1,1,1")
1399 (mounting-angle :init-form
"0")
1401 "Serve an image from a .pictures file."
1402 (assert-authentication)
1406 (push (bt:current-thread
)
1407 (hunchentoot:session-value
'recent-threads
))
1408 (incf (hunchentoot:session-value
'number-of-threads
)))
1410 (cl-utilities:split-sequence
#\
/
1411 (hunchentoot:script-name
*)
1412 :remove-empty-subseqs t
))
1414 (cdddr ;remove leading phoros, lib, photo
1417 (cl-utilities:split-sequence
#\.
(first (last s
2))))
1419 (parse-integer (car (last s
)) :junk-allowed t
))
1424 :directory
(append (pathname-directory *common-root
*)
1427 :name
(first file-name-and-type
)
1428 :type
(second file-name-and-type
)))))
1430 (flex:with-output-to-sequence
(stream)
1432 stream path-to-file byte-position
1434 (apply #'vector
(mapcar
1436 (cl-utilities:split-sequence
1437 #\
, bayer-pattern
)))
1439 (apply #'vector
(mapcar
1440 #'parse-number
:parse-positive-real-number
1441 (cl-utilities:split-sequence
1444 :reversep
(= 180 (parse-integer mounting-angle
))
1445 :brightenp brightenp
))))
1446 (setf (hunchentoot:header-out
'cache-control
)
1447 (format nil
"max-age=~D" *browser-cache-max-age
*))
1448 (setf (hunchentoot:content-type
*) "image/png")
1450 (decf (hunchentoot:session-value
'number-of-threads
)))
1452 (setf (hunchentoot:return-code
*) hunchentoot
:+http-gateway-time-out
+)
1453 ;; (decf (hunchentoot:session-value 'number-of-threads))
1457 :error
"While serving image ~S: ~A" (hunchentoot:request-uri
*) c
))))
1459 (pushnew (hunchentoot:create-prefix-dispatcher
"/phoros/lib/photo"
1461 hunchentoot
:*dispatch-table
*)
1463 ;;; for debugging; this is the multi-file OpenLayers
1464 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1465 "/phoros/lib/openlayers/" "OpenLayers-2.10/")
1466 hunchentoot
:*dispatch-table
*)
1468 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1469 "/phoros/lib/ol/" "ol/")
1470 hunchentoot
:*dispatch-table
*)
1472 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1473 "/phoros/lib/public_html/" "public_html/")
1474 hunchentoot
:*dispatch-table
*)
1476 (pushnew (hunchentoot:create-static-file-dispatcher-and-handler
1477 "/favicon.ico" "public_html/favicon.ico")
1478 hunchentoot
:*dispatch-table
*)
1480 (hunchentoot:define-easy-handler
1481 (view :uri
(format nil
"/phoros/lib/view-~A" (phoros-version))
1482 :default-request-type
:post
)
1484 "Serve the client their main workspace."
1486 (hunchentoot:session-value
'authenticated-p
)
1487 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
1493 "Phoros: " (hunchentoot:session-value
1494 'presentation-project-name
))))
1495 (if *use-multi-file-openlayers
*
1498 :src
(format nil
"/~A/lib/openlayers/lib/Firebug/firebug.js"
1501 :src
(format nil
"/~A/lib/openlayers/lib/OpenLayers.js"
1505 :src
(format nil
"/~A/lib/ol/OpenLayers.js"
1507 (:link
:rel
"stylesheet"
1508 :href
(format nil
"/~A/lib/css-~A/style.css"
1512 (:script
:src
(format ;variability in script name is
1513 nil
; supposed to fight browser cache
1514 "/~A/lib/phoros-~A-~A-~A.js"
1517 (hunchentoot:session-value
'user-name
)
1518 (hunchentoot:session-value
'presentation-project-name
)))
1519 (:script
:src
"http://maps.google.com/maps/api/js?sensor=false"))
1522 (:noscript
(:b
(:em
"You can't do much without JavaScript here.")))
1524 "Phoros: " (who:str
(hunchentoot:session-value
'user-full-name
))
1525 (who:fmt
" (~A)" (hunchentoot:session-value
'user-name
))
1526 "with " (:span
:id
"user-role"
1527 (who:str
(hunchentoot:session-value
'user-role
)))
1529 (:span
:id
"presentation-project-name"
1530 (who:str
(hunchentoot:session-value
1531 'presentation-project-name
)))
1532 (:span
:id
"presentation-project-emptiness")
1533 (:span
:id
"recommend-fresh-login")
1534 (:span
:class
"h1-right"
1535 (:span
:id
"caching-indicator")
1536 (:span
:id
"phoros-version"
1537 (who:fmt
"v~A" (phoros-version)))))
1538 (:div
:class
"controlled-streetmap"
1539 (:div
:id
"streetmap" :class
"streetmap" :style
"cursor:crosshair")
1540 (:div
:id
"streetmap-controls" :class
"streetmap-controls"
1541 (:div
:id
"streetmap-vertical-strut"
1542 :class
"streetmap-vertical-strut")
1543 (:div
:id
"streetmap-layer-switcher"
1544 :class
"streetmap-layer-switcher")
1545 (:button
:id
"unselect-all-restrictions-button"
1547 :onclick
(ps-inline (unselect-all-restrictions))
1549 (:select
:id
"restriction-select"
1550 :name
"restriction-select"
1553 :onchange
(ps-inline (request-photos)))
1554 (:div
:id
"streetmap-overview" :class
"streetmap-overview")
1555 (:div
:id
"streetmap-mouse-position"
1556 :class
"streetmap-mouse-position")
1557 (:div
:id
"streetmap-zoom" :class
"streetmap-zoom")))
1558 (:div
:class
"phoros-controls" :id
"phoros-controls"
1559 (:div
:id
"real-phoros-controls"
1560 (:h2
(:span
:id
"h2-controls") (:span
:id
"creator"))
1561 (:div
:id
"point-kind"
1563 (:select
:id
"point-kind-select"
1564 :name
"point-kind-select"
1565 :class
"combobox-select"
1566 :onchange
(ps-inline
1567 (consolidate-combobox
1570 (:input
:id
"point-kind-input"
1571 :name
"point-kind-input"
1572 :class
"combobox-input"
1573 :onchange
(ps-inline
1574 (unselect-combobox-selection
1578 (:input
:id
"point-numeric-description"
1579 :class
"vanilla-input"
1581 :type
"text" :name
"point-numeric-description")
1583 (:div
:id
"point-description"
1585 (:select
:id
"point-description-select"
1586 :name
"point-description-select"
1587 :class
"combobox-select"
1588 :onchange
(ps-inline
1589 (consolidate-combobox
1590 "point-description"))
1592 (:input
:id
"point-description-input"
1593 :name
"point-description-input"
1594 :class
"combobox-input"
1595 :onchange
(ps-inline
1596 (unselect-combobox-selection
1597 "point-description"))
1600 (:button
:id
"delete-point-button" :disabled t
1602 :onclick
(ps-inline (delete-point))
1604 (:button
:disabled t
:id
"finish-point-button"
1607 (:div
:id
"uniquify-buttons"
1608 (:button
:id
"suggest-unique-button"
1611 (insert-unique-suggestion))
1613 (:button
:id
"force-duplicate-button"
1616 (:div
:id
"aux-point-distance-or-point-creation-date"
1617 (:code
:id
"point-creation-date")
1618 (:select
:id
"aux-point-distance" :disabled t
1619 :size
1 :name
"aux-point-distance"
1620 :onchange
(ps-inline
1621 (aux-point-distance-selected))
1623 (enable-aux-point-selection)))
1624 (:div
:id
"include-aux-data"
1626 (:input
:id
"include-aux-data-p"
1627 :class
"tight-input"
1628 :type
"checkbox" :checked t
1629 :name
"include-aux-data-p"
1630 :onchange
(ps-inline
1631 (flip-aux-data-inclusion)))
1633 (:div
:id
"aux-data"
1634 (:div
:id
"aux-numeric-list")
1635 (:div
:id
"aux-text-list")))
1636 (:div
:id
"multiple-points-phoros-controls"
1637 (:h2
"Multiple Points Selected")
1638 (:p
"You have selected multiple user points.")
1639 (:p
"Unselect all but one to edit or view its properties."))
1640 (:div
:class
"walk-mode-controls"
1641 (:div
:id
"walk-mode"
1642 (:input
:id
"walk-p"
1643 :class
"tight-input"
1644 :type
"checkbox" :checked nil
1645 :onchange
(ps-inline
1647 (:label
:for
"walk-p"
1649 (:div
:id
"decrease-step-size"
1650 :onclick
(ps-inline (decrease-step-size)))
1651 (:div
:id
"step-size"
1652 :onclick
(ps-inline (increase-step-size))
1654 (:div
:id
"increase-step-size"
1655 :onclick
(ps-inline (increase-step-size))
1656 :ondblclick
(ps-inline (increase-step-size)
1657 (increase-step-size)))
1658 (:div
:id
"step-button" :disabled nil
1659 :onclick
(ps-inline (step))
1660 :ondblclick
(ps-inline (step t
))
1662 (:div
:class
"image-main-controls"
1663 (:div
:id
"auto-zoom"
1664 (:input
:id
"zoom-to-point-p"
1665 :class
"tight-input"
1666 :type
"checkbox" :checked t
)
1667 (:label
:for
"zoom-to-point-p"
1669 (:div
:id
"brighten-images"
1670 (:input
:id
"brighten-images-p"
1671 :class
"tight-input"
1672 :type
"checkbox" :checked nil
)
1673 (:label
:for
"brighten-images-p"
1675 (:div
:id
"zoom-images-to-max-extent"
1676 :onclick
(ps-inline (zoom-images-to-max-extent)))
1677 (:div
:id
"no-footprints-p"
1679 (:div
:id
"remove-work-layers-button" :disabled t
1680 :onclick
(ps-inline (reset-layers-and-controls))
1682 (:div
:class
"help-div"
1683 (:button
:id
"download-user-points-button"
1685 :onclick
(format nil
"self.location.href = \"/~A/lib/user-points.json\""
1687 "download points") ;TODO: offer other formats and maybe projections
1688 (:button
:id
"blurb-button"
1695 "/lib/blurb?openlayers-version="
1696 (@ *open-layers
*version_number
*))
1698 (:img
:src
(format nil
"/~A/lib/public_html/phoros-logo-plain.png"
1700 :alt
"Phoros" :style
"vertical-align:middle"
1702 (:button
:id
"logout-button"
1704 :onclick
(ps-inline (bye))
1706 (:h2
:id
"h2-help" "Help")
1707 (:div
:id
"help-display"))
1708 (:div
:id
"images" :style
"clear:both"
1710 for i from
0 below
*number-of-images
* do
1712 (:div
:class
"controlled-image"
1713 (:div
:id
(format nil
"image-~S-controls" i
)
1714 :class
"image-controls"
1715 (:div
:id
(format nil
"image-~S-zoom" i
)
1716 :class
"image-zoom")
1717 (:div
:id
(format nil
"image-~S-layer-switcher" i
)
1718 :class
"image-layer-switcher")
1719 (:div
:id
(format nil
"image-~S-usable" i
)
1720 :class
"image-usable"
1722 (:div
:id
(format nil
"image-~S-trigger-time" i
)
1723 :class
"image-trigger-time"))
1724 (:div
:id
(format nil
"image-~S" i
)
1725 :class
"image" :style
"cursor:crosshair"))))))))
1726 (hunchentoot:redirect
1727 (format nil
"/~A/~A"
1729 (hunchentoot:session-value
'presentation-project-name
))
1730 :add-session-id t
)))
1732 (hunchentoot:define-easy-handler
1733 (epipolar-line :uri
"/phoros/lib/epipolar-line")
1735 "Receive vector of two sets of picture parameters, the first of
1736 which containing coordinates (m, n) of a clicked point. Respond with a
1737 JSON encoded epipolar-line."
1738 (assert-authentication)
1739 (setf (hunchentoot:content-type
*) "application/json")
1740 (let* ((data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
1741 (json:encode-json-to-string
1742 (photogrammetry :epipolar-line
(first data
) (second data
)))))
1744 (hunchentoot:define-easy-handler
1745 (estimated-positions :uri
"/phoros/lib/estimated-positions")
1747 "Receive a two-part JSON vector comprising (1) a vector containing
1748 sets of picture-parameters with clicked (\"active\") points
1749 stored in :m, :n; and (2) a vector containing sets of
1750 picture-parameters; respond with a JSON encoded two-part vector
1751 comprising (1) a point in global coordinates; and (2) a vector of
1752 image coordinates (m, n) for the global point that correspond to the
1753 images from the received second vector. TODO: report error on bad
1754 data (ex: points too far apart)."
1755 ;; TODO: global-point-for-display should probably contain a proj string in order to make sense of the (cartesian) standard deviations.
1756 (assert-authentication)
1757 (setf (hunchentoot:content-type
*) "application/json")
1759 (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1760 (active-point-photo-parameters
1762 (number-of-active-points
1763 (length active-point-photo-parameters
))
1764 (destination-photo-parameters
1767 (cdr (assoc :cartesian-system
1768 (first active-point-photo-parameters
))))
1769 (global-point-cartesian
1771 :multi-position-intersection active-point-photo-parameters
))
1772 (global-point-geographic-radians
1773 (proj:cs2cs
(list (cdr (assoc :x-global global-point-cartesian
))
1774 (cdr (assoc :y-global global-point-cartesian
))
1775 (cdr (assoc :z-global global-point-cartesian
)))
1776 :source-cs cartesian-system
))
1777 (global-point-for-display ;points geographic cs, degrees; std deviations in cartesian cs
1778 (pairlis '(:longitude
:latitude
:ellipsoid-height
1779 ;; :stdx-global :stdy-global :stdz-global
1782 (proj:radians-to-degrees
1783 (first global-point-geographic-radians
))
1784 (proj:radians-to-degrees
1785 (second global-point-geographic-radians
))
1786 (third global-point-geographic-radians
)
1787 ;; (cdr (assoc :stdx-global global-point-cartesian))
1788 ;; (cdr (assoc :stdy-global global-point-cartesian))
1789 ;; (cdr (assoc :stdz-global global-point-cartesian))
1790 number-of-active-points
)))
1793 for i in destination-photo-parameters
1796 (photogrammetry :reprojection i global-point-cartesian
)))))
1797 (json:encode-json-to-string
1798 (list global-point-for-display image-coordinates
))))
1800 (hunchentoot:define-easy-handler
1801 (user-point-positions :uri
"/phoros/lib/user-point-positions")
1803 "Receive a two-part JSON vector comprising
1804 - a vector of user-point-id's and
1805 - a vector containing sets of picture-parameters;
1806 respond with a JSON object comprising the elements
1807 - image-points, a vector whose elements
1808 - correspond to the elements of the picture-parameters vector
1810 - are GeoJSON feature collections containing one point (in picture
1811 coordinates) for each user-point-id received;
1812 - user-point-count, the number of user-points we tried to fetch
1814 (assert-authentication)
1815 (setf (hunchentoot:content-type
*) "application/json")
1816 (let* ((user-point-table-name
1817 (user-point-table-name (hunchentoot:session-value
1818 'presentation-project-name
)))
1819 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1820 (user-point-ids (first data
))
1821 (user-point-count (length user-point-ids
))
1822 (destination-photo-parameters (second data
))
1824 (cdr (assoc :cartesian-system
1825 (first destination-photo-parameters
)))) ;TODO: in rare cases, coordinate systems of the images shown may differ
1827 (with-connection *postgresql-credentials
*
1830 (:as
(:st_x
'coordinates
) 'longitude
)
1831 (:as
(:st_y
'coordinates
) 'latitude
)
1832 (:as
(:st_z
'coordinates
) 'ellipsoid-height
)
1833 (:as
'user-point-id
'id
) ;becomes fid on client
1836 'numeric-description
1838 (:as
(:to-char
'creation-date
"IYYY-MM-DD HH24:MI:SS TZ")
1842 :from user-point-table-name
:natural
:left-join
'sys-user
1843 :where
(:in
'user-point-id
(:set user-point-ids
)))
1845 (global-points-cartesian
1847 for global-point-geographic in user-points
1849 (ignore-errors ;in case no destination-photo-parameters have been sent
1850 (pairlis '(:x-global
:y-global
:z-global
)
1853 (proj:degrees-to-radians
1854 (getf global-point-geographic
:longitude
))
1855 (proj:degrees-to-radians
1856 (getf global-point-geographic
:latitude
))
1857 (getf global-point-geographic
:ellipsoid-height
))
1858 :destination-cs cartesian-system
)))))
1861 for photo-parameter-set in destination-photo-parameters
1863 (encode-geojson-to-string
1865 for global-point-cartesian in global-points-cartesian
1866 for user-point in user-points
1869 (let ((photo-coordinates
1870 (photogrammetry :reprojection
1872 global-point-cartesian
))
1875 (setf (getf photo-point
:x
)
1876 (cdr (assoc :m photo-coordinates
)))
1877 (setf (getf photo-point
:y
)
1878 (cdr (assoc :n photo-coordinates
)))
1880 :junk-keys
'(:longitude
:latitude
:ellipsoid-height
)))))
1881 (with-output-to-string (s)
1882 (json:with-object
(s)
1883 (json:encode-object-member
:user-point-count user-point-count s
)
1884 (json:as-object-member
(:image-points s
)
1885 (json:with-array
(s)
1886 (loop for i in image-coordinates do
1887 (json:as-array-member
(s) (princ i s
)))))))))
1889 (hunchentoot:define-easy-handler
1890 (multi-position-intersection :uri
"/phoros/lib/intersection")
1892 "Receive vector of sets of picture parameters, respond with stuff."
1893 (assert-authentication)
1894 (setf (hunchentoot:content-type
*) "application/json")
1895 (let* ((data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
1896 (json:encode-json-to-string
1897 (photogrammetry :multi-position-intersection data
))))