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 (defvar *unix-exit-code
* 0
34 (defparameter *standard-coordinates
* 4326
35 "EPSG code of the coordinate system that we use for communication.")
37 (defparameter *spherical-mercator
* 900913
38 "EPSG code of the coordinate system used for some distance calculations.")
40 (defvar *verbosity
* nil
41 "List of strings like \"topic:7\".")
44 "String containing octal representation of Phoros' umask")
46 (defvar *postgresql-credentials
* nil
47 "A list: (database user password host &key (port 5432) use-ssl).")
49 (defvar *postgresql-aux-credentials
* nil
50 "A list: (database user password host &key (port 5432) use-ssl).")
52 (defparameter *photogrammetry-mutex
* (bt:make-lock
"photogrammetry"))
54 (setf *read-default-float-format
* 'double-float
)
56 (defparameter *phoros-server
* nil
"Hunchentoot acceptor.")
58 (defparameter *common-root
* nil
59 "Root directory; contains directories of measuring data.")
61 (defparameter *proxy-root
* "phoros"
62 "First directory element of the server URL. Must correspond to the
63 proxy configuration if Phoros is hidden behind a proxy.")
65 (defparameter *login-intro
* nil
66 "A few friendly words to be shown below the login form.")
68 (defparameter *number-of-images
* 4
69 "Number of photos shown to the HTTP client.")
71 (defparameter *aux-numeric-labels
* nil
72 "Labels for auxiliary numeric data rows shown to the HTTP client.")
74 (defparameter *aux-text-labels
* nil
75 "Labels for auxiliary text data rows shown to the HTTP client.")
77 (defparameter *browser-cache-max-age
* (* 3600 24 7)
78 "Value x for Cache-Control:max-age=x, for images on client.")
80 (defparameter *number-of-features-per-layer
* 500
81 "What we think a browser can swallow.")
83 (defparameter *number-of-points-per-aux-linestring
* 500
84 "What we think a browser can swallow.")
86 (defparameter *user-point-creation-date-format
* "IYYY-MM-DD HH24:MI:SS TZ"
87 "SQL date format used for display and GeoJSON export of user points.")
89 (defparameter *phoros-version
*
90 (asdf:component-version
(asdf:find-system
:phoros
))
91 "Phoros version as defined in system definition.")
93 (defparameter *phoros-description
*
94 (asdf:system-description
(asdf:find-system
:phoros
))
95 "Phoros description as defined in system definition.")
97 (defparameter *phoros-long-description
*
98 (substitute #\Space
#\Newline
99 (asdf:system-long-description
(asdf:find-system
:phoros
)))
100 "Phoros long-description as defined in system definition.")
102 (defparameter *phoros-licence
*
103 (asdf:system-licence
(asdf:find-system
:phoros
))
104 "Phoros licence as defined in system definition.")
106 (defparameter *aggregate-view-columns
*
108 'recorded-device-id
;debug
109 'device-stage-of-life-id
;debug
110 'generic-device-id
;debug
113 'filename
'byte-position
'point-id
115 ;;'coordinates ;the search target
116 'longitude
'latitude
'ellipsoid-height
118 'east-sd
'north-sd
'height-sd
119 'roll
'pitch
'heading
120 'roll-sd
'pitch-sd
'heading-sd
121 'sensor-width-pix
'sensor-height-pix
123 'bayer-pattern
'color-raiser
125 'dx
'dy
'dz
'omega
'phi
'kappa
126 'c
'xh
'yh
'a1
'a2
'a3
'b1
'b2
'c1
'c2
'r0
127 'b-dx
'b-dy
'b-dz
'b-rotx
'b-roty
'b-rotz
129 'b-drotx
'b-droty
'b-drotz
)
130 "Most of the column names of aggregate-view.")
132 (defun version-number-parts (dotted-string)
133 "Return the three version number components of something like
136 (values-list (mapcar #'parse-integer
137 (cl-utilities:split-sequence
#\. dotted-string
)))))
139 (defun phoros-version (&key major minor revision
)
140 "Return version of this program, either one integer part as denoted by
141 the key argument, or the whole dotted string."
142 (multiple-value-bind (major-number minor-number revision-number
)
143 (version-number-parts *phoros-version
*)
144 (cond (major major-number
)
146 (revision revision-number
)
147 (t *phoros-version
*))))
149 (defun check-dependencies ()
150 "Say OK if the necessary external dependencies are available."
153 (geographic-to-utm 33 13 52) ;check cs2cs
154 (phoros-photogrammetry:del-all
) ;check photogrammetry
155 (initialize-leap-seconds) ;check source of leap second info
156 (format *error-output
* "~&OK~%"))
157 (error (e) (format *error-output
* "~A~&" e
))))
159 (defun muffle-postgresql-warnings ()
160 "For current DB, silence PostgreSQL's warnings about implicitly
162 (unless (cli:verbosity-level
:postgresql-warnings
)
163 (execute "SET client_min_messages TO ERROR;")))
165 (defun check-db (db-credentials)
166 "Check postgresql connection. Return t if successful; show error on
167 *error-output* otherwise. db-credentials is a list like so: (database
168 user password host &key (port 5432) use-ssl)."
171 (setf connection
(apply #'connect db-credentials
))
172 (error (e) (format *error-output
* "Database connection ~S failed: ~A~&"
175 (disconnect connection
)
178 (defun ignore-warnings (c) (declare (ignore c
)) (muffle-warning))
180 (defmethod hunchentoot:session-cookie-name
(acceptor)
181 (declare (ignore acceptor
))
184 (defun start-server (&key
(proxy-root "phoros") (http-port 8080) address
186 "Start the presentation project server which listens on http-port
187 at address. Address defaults to all addresses of the local machine."
188 (setf *phoros-server
*
189 (make-instance 'hunchentoot
:easy-acceptor
192 :document-root
(ensure-directories-exist
194 :error-template-directory
(ensure-directories-exist
195 "unexpected_html/errors/")))
196 (setf hunchentoot
:*session-max-time
* (* 3600 24))
197 (setf *proxy-root
* proxy-root
)
198 (setf *common-root
* common-root
)
199 (check-db *postgresql-credentials
*)
200 (with-connection *postgresql-credentials
*
201 (assert-phoros-db-major-version))
202 (hunchentoot:reset-session-secret
)
203 (hunchentoot:start
*phoros-server
*))
205 (defun stop-server () (hunchentoot:stop
*phoros-server
*))
207 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
208 (register-sql-operators :2+-ary
:&& :overlaps
))
210 (hunchentoot:define-easy-handler phoros-handler
()
211 "First HTTP contact: if necessary, check credentials, establish new
213 (with-connection *postgresql-credentials
*
214 (let* ((s (cl-utilities:split-sequence
216 (hunchentoot:script-name
*)
217 :remove-empty-subseqs t
))
218 (presentation-project-name (second s
))
219 (presentation-project-id
221 (presentation-project-id-from-name presentation-project-name
))))
223 ;; TODO: remove the following line (which seems to function as a
224 ;; wakeup call of sorts)...
225 (get-dao 'sys-user-role
0 0)
226 ;; ...and make sure the following error doesn't occur any longer
227 ;; while accessing the HTTP server:
228 ;; #<POSTMODERN:DAO-CLASS PHOROS::SYS-USER-ROLE> cannot be printed readably.
231 ((null presentation-project-id
)
232 (setf (hunchentoot:return-code
*) hunchentoot
:+http-not-found
+))
233 ((and (equal (hunchentoot:session-value
'presentation-project-name
)
234 presentation-project-name
)
235 (hunchentoot:session-value
'authenticated-p
))
236 (hunchentoot:redirect
237 (format nil
"/~A/lib/view-~A"
244 (setf (hunchentoot:session-value
'presentation-project-name
)
245 presentation-project-name
)
246 (setf (hunchentoot:session-value
'presentation-project-id
)
247 presentation-project-id
)
248 (setf (hunchentoot:session-value
'presentation-project-bbox
)
251 (bounding-box (get-dao 'sys-presentation-project
252 presentation-project-name
)))))
253 (if (or (null bbox
) (eq :null bbox
))
256 (setf (hunchentoot:session-value
'aux-data-p
)
257 (with-connection *postgresql-aux-credentials
*
258 (view-exists-p (aux-point-view-name
259 presentation-project-name
))))
260 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
262 :style
"font-family:sans-serif;"
264 :method
"post" :enctype
"multipart/form-data"
265 :action
(format nil
"/~A/lib/authenticate"
269 (:legend
(:b
(:a
:href
"http://phoros.boundp.org"
270 :style
"text-decoration:none;"
272 (who:fmt
" [~A]" presentation-project-name
)))
274 (:b
(:em
"You can't do much without JavaScript there.")))
277 (:input
:type
"text" :name
"user-name"))
280 (:input
:type
"password" :name
"user-password")
282 (:span
:id
"cackle"))
283 (:input
:type
"submit" :value
"Submit"
285 (setf (chain document
286 (get-element-by-id "cackle")
288 "Ok, let's see…"))))
289 (:script
:type
"text/javascript"
290 (who:str
(ps (chain document
295 for i in
*login-intro
*
296 do
(who:htm
(:p
(who:str i
))))))))))))
298 (pushnew (hunchentoot:create-regex-dispatcher
"/phoros/(?!lib/)"
300 hunchentoot
:*dispatch-table
*)
302 (defun stored-bbox ()
303 "Return stored bounding box for user and presentation project of
305 (with-connection *postgresql-credentials
*
306 (let ((bbox (bounding-box
307 (get-dao 'sys-user-role
308 (hunchentoot:session-value
310 (hunchentoot:session-value
311 'presentation-project-id
)))))
313 (hunchentoot:session-value
'presentation-project-bbox
)
316 (defun stored-cursor ()
317 "Return stored cursor position for user and presentation project of
319 (with-connection *postgresql-credentials
*
322 (:select
(:st_x
'cursor
) (:st_y
'cursor
)
324 :where
(:and
(:= 'user-id
325 (hunchentoot:session-value
'user-id
))
326 (:= 'presentation-project-id
327 (hunchentoot:session-value
328 'presentation-project-id
))
329 (:raw
"cursor IS NOT NULL")))
332 (format nil
"~{~F~#^,~}" cursor
)))))
335 (hunchentoot:define-easy-handler
336 (authenticate-handler :uri
"/phoros/lib/authenticate"
337 :default-request-type
:post
)
339 "Check user credentials."
340 (with-connection *postgresql-credentials
*
341 (let* ((user-name (hunchentoot:post-parameter
"user-name"))
342 (user-password (hunchentoot:post-parameter
"user-password"))
343 (presentation-project-id (hunchentoot:session-value
344 'presentation-project-id
))
346 (when presentation-project-id
349 'sys-user.user-full-name
351 'sys-user-role.user-role
352 :from
'sys-user-role
'sys-user
354 (:= 'presentation-project-id presentation-project-id
)
355 (:= 'sys-user-role.user-id
'sys-user.user-id
)
356 (:= 'user-name user-name
)
357 (:= 'user-password user-password
)))
359 (user-full-name (first user-info
))
360 (user-id (second user-info
))
361 (user-role (third user-info
)))
364 (setf (hunchentoot:session-value
'authenticated-p
) t
365 (hunchentoot:session-value
'user-name
) user-name
366 (hunchentoot:session-value
'user-full-name
) user-full-name
367 (hunchentoot:session-value
'user-id
) user-id
368 (hunchentoot:session-value
'user-role
) user-role
)
369 (hunchentoot:redirect
370 (format nil
"/~A/lib/view-~A"
375 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
377 :style
"font-family:sans-serif;"
379 (:a
:href
(format nil
"/~A/~A/"
381 (hunchentoot:session-value
382 'presentation-project-name
))
385 (defun assert-authentication ()
386 "Abort request handler on unauthorized access."
387 (unless (hunchentoot:session-value
'authenticated-p
)
388 (setf (hunchentoot:return-code
*) hunchentoot
:+http-precondition-failed
+)
389 (hunchentoot:abort-request-handler
)))
391 (hunchentoot:define-easy-handler logout-handler
(bbox longitude latitude
)
392 (if (hunchentoot:session-value
'authenticated-p
)
393 (with-connection *postgresql-credentials
*
394 (let ((presentation-project-name
395 (hunchentoot:session-value
'presentation-project-name
))
397 (get-dao 'sys-user-role
398 (hunchentoot:session-value
'user-id
)
399 (hunchentoot:session-value
'presentation-project-id
))))
402 (setf (bounding-box sys-user-role
) bbox
))
403 (when (and longitude latitude
)
404 (let* ;; kludge: should be done by some library, not by DB query
405 ((point-form (format nil
"POINT(~F ~F)" longitude latitude
))
406 (point-wkb (query (:select
407 (:st_geomfromtext point-form
))
409 (setf (cursor sys-user-role
) point-wkb
)))
410 (update-dao sys-user-role
))
411 (hunchentoot:remove-session hunchentoot
:*session
*)
412 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
418 "Phoros: logged out" )))
419 (:link
:rel
"stylesheet"
420 :href
(format nil
"/~A/lib/css-~A/style.css"
425 (:h1
:id
"title" "Phoros: logged out")
426 (:p
"Log back in to project "
427 (:a
:href
(format nil
"/~A/~A"
429 presentation-project-name
)
430 (who:fmt
"~A." presentation-project-name
))))))))
433 (pushnew (hunchentoot:create-regex-dispatcher
"/logout" 'logout-handler
)
434 hunchentoot
:*dispatch-table
*)
436 (define-condition superseded
() ()
438 "Tell a thread to finish as soon as possible taking any shortcuts
441 (hunchentoot:define-easy-handler
442 (selectable-restrictions :uri
"/phoros/lib/selectable-restrictions.json"
443 :default-request-type
:post
)
445 "Respond with a list of restrictions the user may choose from."
446 (assert-authentication)
447 (setf (hunchentoot:content-type
*) "application/json")
448 (with-connection *postgresql-credentials
*
449 (json:encode-json-to-string
452 (:select
'restriction-id
453 :from
'sys-selectable-restriction
454 :where
(:= 'presentation-project-id
455 (hunchentoot:session-value
456 'presentation-project-id
)))
460 (defun selected-restrictions (presentation-project-id selected-restriction-ids
)
461 "Get from current database connection a list of restriction clauses
462 belonging to presentation-project-id and ids from list
463 selected-restriction-ids."
466 `(:select
'sql-clause
467 :from
'sys-selectable-restriction
468 :where
(:and
(:= 'presentation-project-id
469 ,presentation-project-id
)
471 ,@(loop for i in selected-restriction-ids
472 collect
(list := 'restriction-id i
))))))
475 (defun sql-where-conjunction (sql-boolean-clauses)
476 "Parenthesize sql-boolean-clauses and concatenate them into a
477 string, separated by \"AND\". Return \" TRUE \" if
478 sql-boolean-clauses is nil."
479 (if sql-boolean-clauses
480 (apply #'concatenate
'string
(butlast (loop
481 for i in sql-boolean-clauses
488 (hunchentoot:define-easy-handler
489 (nearest-image-data :uri
"/phoros/lib/nearest-image-data"
490 :default-request-type
:post
)
492 "Receive coordinates, respond with the count nearest json objects
493 containing picture url, calibration parameters, and car position,
494 wrapped in an array. Wipe away any unfinished business first."
495 (assert-authentication)
496 (dolist (old-thread (hunchentoot:session-value
'recent-threads
))
498 (bt:interrupt-thread old-thread
499 #'(lambda () (signal 'superseded
)))))
500 (setf (hunchentoot:session-value
'recent-threads
) nil
)
501 (setf (hunchentoot:session-value
'number-of-threads
) 1)
502 (push (bt:current-thread
) (hunchentoot:session-value
'recent-threads
))
503 (setf (hunchentoot:content-type
*) "application/json")
504 (with-connection *postgresql-credentials
*
505 (let* ((presentation-project-id (hunchentoot:session-value
506 'presentation-project-id
))
507 (common-table-names (common-table-names
508 presentation-project-id
))
509 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
510 (longitude (cdr (assoc :longitude data
)))
511 (latitude (cdr (assoc :latitude data
)))
512 (count (cdr (assoc :count data
)))
513 (zoom (cdr (assoc :zoom data
)))
514 (snap-distance ;bogus distance in degrees,
515 (* 100e-5 ; assuming geographic
516 (expt 2 (- ; coordinates
517 14 ; (1m = 1e-5 degrees)
520 (point-form (format nil
"POINT(~F ~F)" longitude latitude
))
521 (selected-restrictions-conjunction
522 (sql-where-conjunction
523 (selected-restrictions presentation-project-id
524 (cdr (assoc :selected-restriction-ids
526 (nearest-footprint-centroid-query
527 ;; Inserting the following into
528 ;; image-data-with-footprints-query as a subquery would
529 ;; work correctly but is way too slow.
534 ,@*aggregate-view-columns
*
540 for common-table-name
541 in common-table-names
542 for aggregate-view-name
543 = (aggregate-view-name
549 (:st_centroid
'footprint
)
552 ,*standard-coordinates
*))
554 (:as
(:st_centroid
'footprint
)
556 ,@*aggregate-view-columns
*
560 ;; no-ops wrt self-references in
561 ;; selected-restrictions-conjunction
562 ,@(postmodern-as-clauses
563 (pairlis *aggregate-view-columns
*
564 *aggregate-view-columns
*))
565 :from
',aggregate-view-name
)
566 'images-of-acquisition-project
)
569 (:= 'presentation-project-id
570 ,presentation-project-id
)
575 ,*standard-coordinates
*)
577 (:raw
,selected-restrictions-conjunction
)))))
581 (nearest-footprint-image
582 (ignore-errors (logged-query "centroid of nearest footprint"
583 nearest-footprint-centroid-query
585 (nearest-footprint-centroid
586 (cdr (assoc :centroid nearest-footprint-image
)))
587 (image-data-with-footprints-query
593 for common-table-name in common-table-names
594 for aggregate-view-name
595 = (aggregate-view-name common-table-name
)
598 ,@*aggregate-view-columns
*
599 (:as
(:st_distance
'coordinates
600 ,nearest-footprint-centroid
)
602 (:as
(:not
(:is-null
'footprint
))
604 ,(when (cli:verbosity-level
:render-footprints
)
605 '(:as
(:st_asewkt
'footprint
)
610 ,@(postmodern-as-clauses
611 nearest-footprint-image
)
612 :from
',aggregate-view-name
)
613 'images-of-acquisition-project-plus-reference-image
)
616 (:= 'presentation-project-id
617 ,presentation-project-id
)
618 (:st_contains
'footprint
619 ,nearest-footprint-centroid
)
620 (:raw
,selected-restrictions-conjunction
)))))
623 (nearest-image-without-footprints-query
629 for common-table-name in common-table-names
630 for aggregate-view-name
631 = (aggregate-view-name common-table-name
)
634 ,@*aggregate-view-columns
*
635 (:as
(:st_distance
'coordinates
638 ,*standard-coordinates
*))
640 (:as
(:not
(:is-null
'footprint
))
645 ;; no-ops wrt self-references in
646 ;; selected-restrictions-conjunction
647 ,@(postmodern-as-clauses
648 (pairlis *aggregate-view-columns
*
649 *aggregate-view-columns
*))
650 :from
',aggregate-view-name
)
651 'images-of-acquisition-project
)
653 (:and
(:= 'presentation-project-id
654 ,presentation-project-id
)
655 (:st_dwithin
'coordinates
658 ,*standard-coordinates
*)
660 (:raw
,selected-restrictions-conjunction
)))))
663 (nearest-image-without-footprint
664 (unless nearest-footprint-centroid
;otherwise save time
665 (ignore-errors (logged-query "no footprint, first image"
666 nearest-image-without-footprints-query
668 (image-data-without-footprints-query
674 for common-table-name in common-table-names
675 for aggregate-view-name
676 = (aggregate-view-name common-table-name
)
679 ,@*aggregate-view-columns
*
680 (:as
(:st_distance
'coordinates
683 ,*standard-coordinates
*))
685 (:as
(:not
(:is-null
'footprint
))
690 ,@(postmodern-as-clauses
691 nearest-image-without-footprint
)
692 :from
',aggregate-view-name
)
693 'images-of-acquisition-project
)
695 (:and
(:= 'presentation-project-id
696 ,presentation-project-id
)
697 (:st_dwithin
'coordinates
700 ,*standard-coordinates
*)
702 (:raw
,selected-restrictions-conjunction
)))))
708 (if nearest-footprint-centroid
709 (logged-query "footprints are ready"
710 image-data-with-footprints-query
712 (logged-query "no footprints yet"
713 image-data-without-footprints-query
715 (superseded () nil
))))
716 (when (cli:verbosity-level
:render-footprints
)
720 for photo-parameter-set in result
721 for footprint-vertices
= ;something like this:
722 ;; "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))"
723 (ignore-errors ;probably no :footprint-wkt
726 (parse-number:parse-real-number x
))
727 (cl-utilities:split-sequence
#\Space p
)))
729 (cl-utilities:split-sequence-if
734 (cdr (assoc :footprint-wkt photo-parameter-set
)))
737 (if footprint-vertices
741 '(:type
:coordinates
)
745 for footprint-vertex in footprint-vertices
746 for reprojected-vertex
=
749 ;; KLUDGE: translate keys, e.g. a1 -> a_1
750 (json:decode-json-from-string
751 (json:encode-json-to-string photo-parameter-set
))
752 (pairlis '(:x-global
:y-global
:z-global
)
754 (list (proj:degrees-to-radians
755 (first footprint-vertex
))
756 (proj:degrees-to-radians
757 (second footprint-vertex
))
758 (third footprint-vertex
))
760 (cdr (assoc :cartesian-system
761 photo-parameter-set
)))))
763 (list (cdr (assoc :m reprojected-vertex
))
764 (cdr (assoc :n reprojected-vertex
))))))
766 photo-parameter-set
))))
767 (decf (hunchentoot:session-value
'number-of-threads
))
768 (json:encode-json-to-string result
))))
770 (hunchentoot:define-easy-handler
771 (nearest-image-urls :uri
"/phoros/lib/nearest-image-urls"
772 :default-request-type
:post
)
774 "Receive coordinates, respond with a json array of the necessary
775 ingredients for the URLs of the 256 nearest images."
776 (assert-authentication)
777 (when (cli:verbosity-level
:suppress-preemptive-caching
)
778 (return-from nearest-image-urls
""))
779 (push (bt:current-thread
) (hunchentoot:session-value
'recent-threads
))
780 (if (<= (hunchentoot:session-value
'number-of-threads
)
781 0) ;only stuff cache if everything else is done
783 (incf (hunchentoot:session-value
'number-of-threads
))
784 (setf (hunchentoot:content-type
*) "application/json")
785 (with-connection *postgresql-credentials
*
786 (let* ((presentation-project-id (hunchentoot:session-value
787 'presentation-project-id
))
788 (common-table-names (common-table-names
789 presentation-project-id
))
790 (data (json:decode-json-from-string
791 (hunchentoot:raw-post-data
)))
792 (longitude (cdr (assoc :longitude data
)))
793 (latitude (cdr (assoc :latitude data
)))
795 (radius (* 5d-4
)) ; assuming geographic coordinates
796 (point-form (format nil
"POINT(~F ~F)" longitude latitude
))
804 'directory
'filename
'byte-position
805 'bayer-pattern
'color-raiser
'mounting-angle
811 for common-table-name
812 in common-table-names
813 for aggregate-view-name
814 = (aggregate-view-name common-table-name
)
818 'filename
'byte-position
819 'bayer-pattern
'color-raiser
825 ,*standard-coordinates
*))
828 ',aggregate-view-name
830 (:and
(:= 'presentation-project-id
831 ,presentation-project-id
)
836 ,*standard-coordinates
*)
843 (setf (hunchentoot:return-code
*)
844 hunchentoot
:+http-gateway-time-out
+)
846 (decf (hunchentoot:session-value
'number-of-threads
))
847 (json:encode-json-to-string result
))))
848 (setf (hunchentoot:return-code
*) hunchentoot
:+http-gateway-time-out
+)))
850 (hunchentoot:define-easy-handler
851 (store-point :uri
"/phoros/lib/store-point" :default-request-type
:post
)
853 "Receive point sent by user; store it into database."
854 (assert-authentication)
855 (let* ((presentation-project-name (hunchentoot:session-value
856 'presentation-project-name
))
857 (user-id (hunchentoot:session-value
'user-id
))
858 (user-role (hunchentoot:session-value
'user-role
))
859 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
860 (longitude (cdr (assoc :longitude data
)))
861 (latitude (cdr (assoc :latitude data
)))
862 (ellipsoid-height (cdr (assoc :ellipsoid-height data
)))
863 ;; (stdx-global (cdr (assoc :stdx-global data)))
864 ;; (stdy-global (cdr (assoc :stdy-global data)))
865 ;; (stdz-global (cdr (assoc :stdz-global data)))
866 (input-size (cdr (assoc :input-size data
)))
867 (kind (cdr (assoc :kind data
)))
868 (description (cdr (assoc :description data
)))
869 (numeric-description (cdr (assoc :numeric-description data
)))
871 (format nil
"SRID=4326; POINT(~S ~S ~S)"
872 longitude latitude ellipsoid-height
))
873 (aux-numeric-raw (setf *t
* (cdr (assoc :aux-numeric data
))))
874 (aux-text-raw (cdr (assoc :aux-text data
)))
875 (aux-numeric (if aux-numeric-raw
876 (nullify-nil (apply #'vector aux-numeric-raw
))
878 (aux-text (if aux-text-raw
879 (nullify-nil (apply #'vector aux-text-raw
))
881 (user-point-table-name
882 (user-point-table-name presentation-project-name
)))
884 (not (string-equal user-role
"read")) ;that is, "write" or "admin"
885 () "No write permission.")
886 (with-connection *postgresql-credentials
*
888 (= 1 (execute (:insert-into user-point-table-name
:set
891 'description description
892 'numeric-description numeric-description
893 'creation-date
'current-timestamp
894 'coordinates
(:st_geomfromewkt point-form
)
895 ;; 'stdx-global stdx-global
896 ;; 'stdy-global stdy-global
897 ;; 'stdz-global stdz-global
898 'input-size input-size
899 'aux-numeric aux-numeric
900 'aux-text aux-text
)))
901 () "No point stored. This should not happen."))))
903 (hunchentoot:define-easy-handler
904 (update-point :uri
"/phoros/lib/update-point" :default-request-type
:post
)
906 "Update point sent by user in database."
907 (assert-authentication)
908 (let* ((presentation-project-name (hunchentoot:session-value
909 'presentation-project-name
))
910 (user-id (hunchentoot:session-value
'user-id
))
911 (user-role (hunchentoot:session-value
'user-role
))
912 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
913 (user-point-id (cdr (assoc :user-point-id data
)))
914 (kind (cdr (assoc :kind data
)))
915 (description (cdr (assoc :description data
)))
916 (numeric-description (cdr (assoc :numeric-description data
)))
917 (user-point-table-name
918 (user-point-table-name presentation-project-name
)))
920 (not (string-equal user-role
"read")) ;that is, "write" or "admin"
921 () "No write permission.")
922 (with-connection *postgresql-credentials
*
925 (:update user-point-table-name
:set
928 'description description
929 'numeric-description numeric-description
930 'creation-date
'current-timestamp
931 :where
(:and
(:= 'user-point-id user-point-id
)
932 (:or
(:= (if (string-equal user-role
943 () "No point stored. Did you try to update someone else's point ~
944 without having admin permission?"))))
946 (defun increment-numeric-string (text)
947 "Increment rightmost numeric part of text if any; otherwise append a
948 three-digit numeric part."
949 (let* ((end-of-number
950 (1+ (or (position-if #'digit-char-p text
:from-end t
)
951 (1- (length text
)))))
953 (1+ (or (position-if-not #'digit-char-p text
:from-end t
956 (width-of-number (- end-of-number start-of-number
))
957 (prefix-text (subseq text
0 start-of-number
))
958 (suffix-text (subseq text end-of-number
)))
959 (when (zerop width-of-number
)
960 (setf width-of-number
3))
961 (format nil
"~A~V,'0D~A"
964 (1+ (or (ignore-errors
967 :start start-of-number
:end end-of-number
))
971 (hunchentoot:define-easy-handler
972 (uniquify-point-attributes :uri
"/phoros/lib/uniquify-point-attributes"
973 :default-request-type
:post
)
975 "Check if received set of point-attributes are unique. If so,
976 return null; otherwise return (as a suggestion) a uniquified version
977 of point-attributes by modifying element numeric-description."
978 (assert-authentication)
979 (setf (hunchentoot:content-type
*) "application/json")
980 (let* ((presentation-project-name (hunchentoot:session-value
981 'presentation-project-name
))
982 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
983 (user-point-id (cdr (assoc :user-point-id data
)))
984 (kind (cdr (assoc :kind data
)))
985 (description (cdr (assoc :description data
)))
986 (numeric-description (cdr (assoc :numeric-description data
)))
987 (user-point-table-name
988 (user-point-table-name presentation-project-name
)))
989 (flet ((uniquep (user-point-id kind description numeric-description
)
990 "Check if given set of user-point attributes will be
999 :from user-point-table-name
1000 :where
(:and
(:!= 'user-point-id user-point-id
)
1002 (:= 'description description
)
1003 (:= 'numeric-description
1004 numeric-description
)))))
1011 :from user-point-table-name
1012 :where
(:and
(:= 'kind kind
)
1013 (:= 'description description
)
1014 (:= 'numeric-description
1015 numeric-description
)))))
1017 (with-connection *postgresql-credentials
*
1018 (json:encode-json-to-string
1020 user-point-id kind description numeric-description
)
1022 for s
= numeric-description
1023 then
(increment-numeric-string s
)
1024 until
(uniquep user-point-id kind description s
)
1026 (setf (cdr (assoc :numeric-description data
))
1028 (return data
))))))))
1030 (hunchentoot:define-easy-handler
1031 (delete-point :uri
"/phoros/lib/delete-point" :default-request-type
:post
)
1033 "Delete user point if user is allowed to do so."
1034 (assert-authentication)
1035 (let* ((presentation-project-name (hunchentoot:session-value
1036 'presentation-project-name
))
1037 (user-id (hunchentoot:session-value
'user-id
))
1038 (user-role (hunchentoot:session-value
'user-role
))
1039 (user-point-table-name
1040 (user-point-table-name presentation-project-name
))
1041 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
1042 (with-connection *postgresql-credentials
*
1044 (eql 1 (cond ((string-equal user-role
"admin")
1045 (execute (:delete-from user-point-table-name
1046 :where
(:= 'user-point-id data
))))
1047 ((string-equal user-role
"write")
1050 user-point-table-name
1052 (:= 'user-point-id data
)
1053 (:or
(:= 'user-id user-id
)
1060 () "No point deleted. This should not happen."))))
1062 (defun common-table-names (presentation-project-id)
1063 "Return a list of common-table-names of table sets that contain data
1064 of presentation project with presentation-project-id."
1067 (:select
'common-table-name
1069 :from
'sys-presentation
'sys-measurement
'sys-acquisition-project
1071 (:= 'sys-presentation.presentation-project-id
1072 presentation-project-id
)
1073 (:= 'sys-presentation.measurement-id
1074 'sys-measurement.measurement-id
)
1075 (:= 'sys-measurement.acquisition-project-id
1076 'sys-acquisition-project.acquisition-project-id
)))
1081 "While fetching common-table-names of presentation-project-id ~D: ~A"
1082 presentation-project-id c
))))
1084 (defun encode-geojson-to-string (features &key junk-keys
)
1085 "Encode a list of property lists into a GeoJSON FeatureCollection.
1086 Each property list must contain keys for coordinates, :x, :y, :z; it
1087 may contain a numeric point :id and zero or more pieces of extra
1088 information. The extra information is stored as GeoJSON Feature
1089 properties. Exclude property list elements with keys that are in
1091 (with-output-to-string (s)
1092 (json:with-object
(s)
1093 (json:encode-object-member
:type
:*feature-collection s
)
1094 (json:as-object-member
(:features s
)
1095 (json:with-array
(s)
1097 #'(lambda (point-with-properties)
1098 (dolist (junk-key junk-keys
)
1099 (remf point-with-properties junk-key
))
1100 (destructuring-bind (&key x y z id
&allow-other-keys
) ;TODO: z probably bogus
1101 point-with-properties
1102 (json:as-array-member
(s)
1103 (json:with-object
(s)
1104 (json:encode-object-member
:type
:*feature s
)
1105 (json:as-object-member
(:geometry s
)
1106 (json:with-object
(s)
1107 (json:encode-object-member
:type
:*point s
)
1108 (json:as-object-member
(:coordinates s
)
1109 (json:encode-json
(list x y z
) s
))))
1110 (json:encode-object-member
:id id s
)
1111 (json:as-object-member
(:properties s
)
1112 (dolist (key '(:x
:y
:z
:id
))
1113 (remf point-with-properties key
))
1114 (json:encode-json-plist point-with-properties s
))))))
1116 (json:encode-object-member
:phoros-version
(phoros-version) s
))))
1119 "Return a WKT-compliant BOX3D string from string bbox."
1120 (concatenate 'string
"BOX3D("
1121 (substitute #\Space
#\
,
1122 (substitute #\Space
#\
, bbox
:count
1)
1123 :from-end t
:count
1)
1126 (hunchentoot:define-easy-handler
(points :uri
"/phoros/lib/points.json") (bbox)
1127 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
1128 (assert-authentication)
1129 (setf (hunchentoot:content-type
*) "application/json")
1131 (with-connection *postgresql-credentials
*
1132 (let* ((presentation-project-id
1133 (hunchentoot:session-value
'presentation-project-id
))
1135 (common-table-names presentation-project-id
)))
1136 (encode-geojson-to-string
1143 for common-table-name in common-table-names
1144 for aggregate-view-name
1145 = (point-data-table-name common-table-name
)
1146 ;; would have been nice, was too slow:
1147 ;; = (aggregate-view-name common-table-name)
1150 (:as
(:st_x
'coordinates
) x
)
1151 (:as
(:st_y
'coordinates
) y
)
1152 (:as
(:st_z
'coordinates
) z
)
1153 (:as
'point-id
'id
) ;becomes fid on client
1155 :distinct-on
'random
1156 :from
',aggregate-view-name
1157 :natural
:left-join
'sys-presentation
1160 (:= 'presentation-project-id
1161 ,presentation-project-id
)
1164 (:st_setsrid
(:type
,(box3d bbox
) box3d
)
1165 ,*standard-coordinates
*))))))
1167 ,*number-of-features-per-layer
*))
1169 :junk-keys
'(:random
))))
1172 :error
"While fetching points from inside bbox ~S: ~A"
1175 (hunchentoot:define-easy-handler
1176 (aux-points :uri
"/phoros/lib/aux-points.json")
1178 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
1179 (assert-authentication)
1180 (setf (hunchentoot:content-type
*) "application/json")
1182 (let ((limit *number-of-features-per-layer
*)
1184 (aux-point-view-name (hunchentoot:session-value
1185 'presentation-project-name
))))
1186 (encode-geojson-to-string
1187 (with-connection *postgresql-aux-credentials
*
1193 (:as
(:st_x
'coordinates
) 'x
)
1194 (:as
(:st_y
'coordinates
) 'y
)
1195 (:as
(:st_z
'coordinates
) 'z
)
1196 :from
,aux-view-name
1199 (:st_setsrid
(:type
,(box3d bbox
) box3d
)
1200 ,*standard-coordinates
*)))
1206 :error
"While fetching aux-points from inside bbox ~S: ~A"
1209 (hunchentoot:define-easy-handler
1210 (aux-local-data :uri
"/phoros/lib/aux-local-data"
1211 :default-request-type
:post
)
1213 "Receive coordinates, respond with the count nearest json objects
1214 containing arrays aux-numeric, aux-text, and distance to the
1215 coordinates received, wrapped in an array."
1216 (assert-authentication)
1217 (setf (hunchentoot:content-type
*) "application/json")
1218 (let* ((aux-view-name
1219 (aux-point-view-name (hunchentoot:session-value
1220 'presentation-project-name
)))
1221 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1222 (longitude (cdr (assoc :longitude data
)))
1223 (latitude (cdr (assoc :latitude data
)))
1224 (count (cdr (assoc :count data
)))
1226 (format nil
"POINT(~F ~F)" longitude latitude
))
1227 (snap-distance 1e-3) ;about 100 m, TODO: make this a defparameter
1229 (format nil
"~A,~A,~A,~A"
1230 (- longitude snap-distance
)
1231 (- latitude snap-distance
)
1232 (+ longitude snap-distance
)
1233 (+ latitude snap-distance
))))
1234 (encode-geojson-to-string
1236 (with-connection *postgresql-aux-credentials
*
1243 (:as
(:st_x
'coordinates
) 'x
)
1244 (:as
(:st_y
'coordinates
) 'y
)
1245 (:as
(:st_z
'coordinates
) 'z
)
1252 ,*spherical-mercator
*)
1254 (:st_geomfromtext
,point-form
,*standard-coordinates
*)
1255 ,*spherical-mercator
*))
1257 :from
',aux-view-name
1258 :where
(:&& 'coordinates
1260 ,(box3d bounding-box
) box3d
)
1261 ,*standard-coordinates
*)))
1266 (defun nillify-null (x)
1267 "Replace occurences of :null in nested sequence x by nil."
1268 (cond ((eq :null x
) nil
)
1272 (t (map (type-of x
) #'nillify-null x
))))
1274 (defun nullify-nil (x)
1275 "Replace occurences of nil in nested sequence x by :null."
1276 (cond ((null x
) :null
)
1280 (t (map (type-of x
) #'nullify-nil x
))))
1282 (hunchentoot:define-easy-handler
1283 (aux-local-linestring :uri
"/phoros/lib/aux-local-linestring.json"
1284 :default-request-type
:post
)
1286 "Receive longitude, latitude, radius, and step-size; respond
1287 with a JSON object comprising the elements linestring (a WKT
1288 linestring stitched together of the nearest auxiliary points from
1289 within radius around coordinates), current-point (the point on
1290 linestring closest to coordinates), and previous-point and next-point
1291 \(points on linestring step-size before and after current-point
1292 respectively). Wipe away any unfinished business first."
1293 (assert-authentication)
1294 (dolist (old-thread (hunchentoot:session-value
'recent-threads
))
1296 (bt:interrupt-thread old-thread
1297 #'(lambda () (signal 'superseded
)))))
1298 (setf (hunchentoot:session-value
'recent-threads
) nil
)
1299 (setf (hunchentoot:session-value
'number-of-threads
) 1)
1300 (push (bt:current-thread
) (hunchentoot:session-value
'recent-threads
))
1301 (setf (hunchentoot:content-type
*) "application/json")
1303 (let* ((thread-aux-points-function-name
1304 (thread-aux-points-function-name (hunchentoot:session-value
1305 'presentation-project-name
)))
1306 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1307 (longitude (cdr (assoc :longitude data
)))
1308 (latitude (cdr (assoc :latitude data
)))
1309 (radius (cdr (assoc :radius data
)))
1310 (step-size (cdr (assoc :step-size data
)))
1311 (azimuth (if (numberp (cdr (assoc :azimuth data
)))
1312 (cdr (assoc :azimuth data
))
1315 (format nil
"POINT(~F ~F)" longitude latitude
))
1318 (with-connection *postgresql-aux-credentials
*
1323 (,thread-aux-points-function-name
1325 ,point-form
,*standard-coordinates
*)
1327 ,*number-of-points-per-aux-linestring
*
1330 ,(proj:degrees-to-radians
91))))
1332 (with-output-to-string (s)
1333 (json:with-object
(s)
1334 (json:encode-object-member
1335 :linestring
(getf sql-response
:threaded-points
) s
)
1336 (json:encode-object-member
1337 :current-point
(getf sql-response
:current-point
) s
)
1338 (json:encode-object-member
1339 :previous-point
(getf sql-response
:back-point
) s
)
1340 (json:encode-object-member
1341 :next-point
(getf sql-response
:forward-point
) s
)
1342 (json:encode-object-member
1343 :azimuth
(getf sql-response
:new-azimuth
) s
))))
1345 ;; (setf (hunchentoot:return-code*) hunchentoot:+http-gateway-time-out+)
1348 (defun get-user-points (user-point-table-name &key
1349 (bounding-box "-180,-90,180,90")
1351 (order-criterion 'id
)
1353 "Return limit points from user-point-table-name in GeoJSON format,
1354 and the number of points returned."
1355 (let ((user-point-plist
1361 (:as
(:st_x
'coordinates
) 'x
)
1362 (:as
(:st_y
'coordinates
) 'y
)
1363 (:as
(:st_z
'coordinates
) 'z
)
1364 (:as
'user-point-id
'id
) ;becomes fid in OpenLayers
1365 ;; 'stdx-global 'stdy-global 'stdz-global
1367 'kind
'description
'numeric-description
1369 (:as
(:to-char
'creation-date
1370 ,*user-point-creation-date-format
*)
1372 'aux-numeric
'aux-text
1373 :from
,user-point-table-name
:natural
:left-join
'sys-user
1374 :where
(:&& 'coordinates
1375 (:st_setsrid
(:type
,(box3d bounding-box
) box3d
)
1376 ,*standard-coordinates
*)))
1383 (encode-geojson-to-string (nillify-null user-point-plist
)))
1384 (encode-geojson-to-string (nillify-null user-point-plist
)))
1385 (length user-point-plist
))))
1387 (hunchentoot:define-easy-handler
1388 (user-points :uri
"/phoros/lib/user-points.json")
1390 "Send *number-of-features-per-layer* randomly chosen GeoJSON-encoded
1391 points from inside bbox to client. If there is no bbox parameter,
1392 send all points and indent GeoJSON to make it more readable."
1393 (assert-authentication)
1394 (setf (hunchentoot:content-type
*) "application/json")
1396 (let ((bounding-box (or bbox
"-180,-90,180,90"))
1398 (limit (if bbox
*number-of-features-per-layer
* :null
))
1399 (order-criterion (if bbox
'(:random
) 'id
))
1400 (user-point-table-name
1401 (user-point-table-name (hunchentoot:session-value
1402 'presentation-project-name
))))
1403 (with-connection *postgresql-credentials
*
1404 (nth-value 0 (get-user-points user-point-table-name
1405 :bounding-box bounding-box
1407 :order-criterion order-criterion
1411 :error
"While fetching user-points~@[ from inside bbox ~S~]: ~A"
1414 (hunchentoot:define-easy-handler
1415 (user-point-attributes :uri
"/phoros/lib/user-point-attributes.json")
1417 "Send JSON object comprising arrays kinds and descriptions,
1418 each containing unique values called kind and description
1419 respectively, and count being the frequency of value in the user point
1421 (assert-authentication)
1422 (setf (hunchentoot:content-type
*) "application/json")
1424 (let ((user-point-table-name
1425 (user-point-table-name (hunchentoot:session-value
1426 'presentation-project-name
))))
1427 (with-connection *postgresql-credentials
*
1428 (with-output-to-string (s)
1429 (json:with-object
(s)
1430 (json:as-object-member
(:descriptions s
)
1431 (json:with-array
(s)
1432 (mapcar #'(lambda (x) (json:as-array-member
(s)
1433 (json:encode-json-plist x s
)))
1437 (:select
'description
1438 (:count
'description
)
1439 :from user-point-table-name
1440 :group-by
'description
)
1444 (json:as-object-member
(:kinds s
)
1445 (json:with-array
(s)
1446 (mapcar #'(lambda (x) (json:as-array-member
(s)
1447 (json:encode-json-plist x s
)))
1448 (query (format nil
"~
1449 (SELECT kind, count(kind) ~
1450 FROM ((SELECT kind FROM ~A) ~
1453 FROM (VALUES ('solitary'), ~
1456 AS defaults(kind))) ~
1457 AS kinds_union(kind) ~
1459 ORDER BY kind LIMIT 100"
1460 ;; Counts of solitary,
1461 ;; polyline, polygon may be
1462 ;; too big by one if we
1463 ;; collect them like this.
1464 (s-sql:to-sql-name user-point-table-name
))
1468 :error
"While fetching user-point-attributes: ~A"
1471 (hunchentoot:define-easy-handler photo-handler
1472 ((bayer-pattern :init-form
"65280,16711680")
1473 (color-raiser :init-form
"1,1,1")
1474 (mounting-angle :init-form
"0")
1476 "Serve an image from a .pictures file."
1477 (assert-authentication)
1481 (push (bt:current-thread
)
1482 (hunchentoot:session-value
'recent-threads
))
1483 (incf (hunchentoot:session-value
'number-of-threads
)))
1485 (cl-utilities:split-sequence
#\
/
1486 (hunchentoot:script-name
*)
1487 :remove-empty-subseqs t
))
1489 (cdddr ;remove leading phoros, lib, photo
1492 (cl-utilities:split-sequence
#\.
(first (last s
2))))
1494 (parse-integer (car (last s
)) :junk-allowed t
))
1499 :directory
(append (pathname-directory *common-root
*)
1502 :name
(first file-name-and-type
)
1503 :type
(second file-name-and-type
)))))
1505 (flex:with-output-to-sequence
(stream)
1507 stream path-to-file byte-position
1509 (apply #'vector
(mapcar
1511 (cl-utilities:split-sequence
1512 #\
, bayer-pattern
)))
1514 (apply #'vector
(mapcar
1515 #'parse-number
:parse-positive-real-number
1516 (cl-utilities:split-sequence
1519 :reversep
(= 180 (parse-integer mounting-angle
))
1520 :brightenp brightenp
))))
1521 (setf (hunchentoot:header-out
'cache-control
)
1522 (format nil
"max-age=~D" *browser-cache-max-age
*))
1523 (setf (hunchentoot:content-type
*) "image/png")
1525 (decf (hunchentoot:session-value
'number-of-threads
)))
1527 (setf (hunchentoot:return-code
*) hunchentoot
:+http-gateway-time-out
+)
1531 :error
"While serving image ~S: ~A" (hunchentoot:request-uri
*) c
))))
1533 (pushnew (hunchentoot:create-prefix-dispatcher
"/phoros/lib/photo"
1535 hunchentoot
:*dispatch-table
*)
1537 ;;; for debugging; this is the multi-file OpenLayers
1538 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1539 "/phoros/lib/openlayers/" "OpenLayers-2.10/")
1540 hunchentoot
:*dispatch-table
*)
1542 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1543 "/phoros/lib/ol/" "ol/")
1544 hunchentoot
:*dispatch-table
*)
1546 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1547 "/phoros/lib/public_html/" "public_html/")
1548 hunchentoot
:*dispatch-table
*)
1550 (pushnew (hunchentoot:create-static-file-dispatcher-and-handler
1551 "/favicon.ico" "public_html/favicon.ico")
1552 hunchentoot
:*dispatch-table
*)
1554 (hunchentoot:define-easy-handler
1555 (view :uri
(format nil
"/phoros/lib/view-~A" (phoros-version))
1556 :default-request-type
:post
)
1558 "Serve the client their main workspace."
1560 (hunchentoot:session-value
'authenticated-p
)
1561 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
1567 "Phoros: " (hunchentoot:session-value
1568 'presentation-project-name
))))
1569 (if (cli:verbosity-level
:use-multi-file-openlayers
)
1572 :src
(format nil
"/~A/lib/openlayers/lib/Firebug/firebug.js"
1575 :src
(format nil
"/~A/lib/openlayers/lib/OpenLayers.js"
1579 :src
(format nil
"/~A/lib/ol/OpenLayers.js"
1581 (:link
:rel
"stylesheet"
1582 :href
(format nil
"/~A/lib/css-~A/style.css"
1586 (:script
:src
(format ;variability in script name is
1587 nil
; supposed to fight browser cache
1588 "/~A/lib/phoros-~A-~A-~A.js"
1591 (hunchentoot:session-value
'user-name
)
1592 (hunchentoot:session-value
'presentation-project-name
)))
1593 (:script
:src
"http://maps.google.com/maps/api/js?sensor=false"))
1596 (:noscript
(:b
(:em
"You can't do much without JavaScript here.")))
1599 "Phoros: " (who:str
(hunchentoot:session-value
'user-full-name
))
1600 (who:fmt
" (~A)" (hunchentoot:session-value
'user-name
))
1601 "with " (:span
:id
"user-role"
1602 (who:str
(hunchentoot:session-value
'user-role
)))
1604 (:span
:id
"presentation-project-name"
1605 (who:str
(hunchentoot:session-value
1606 'presentation-project-name
)))
1607 (:span
:id
"presentation-project-emptiness")
1608 (:span
:id
"recommend-fresh-login")
1609 (:span
:class
"h1-right"
1610 (:span
:id
"caching-indicator")
1611 (:span
:id
"phoros-version"
1612 (who:fmt
"v~A" (phoros-version)))))
1613 ;; streetmap area (northwest)
1615 :class
"controlled-streetmap"
1616 (:div
:id
"streetmap" :class
"streetmap" :style
"cursor:crosshair")
1617 (:div
:id
"streetmap-controls" :class
"streetmap-controls"
1618 (:div
:id
"streetmap-vertical-strut"
1619 :class
"streetmap-vertical-strut")
1620 (:div
:id
"streetmap-layer-switcher"
1621 :class
"streetmap-layer-switcher")
1622 (:button
:id
"unselect-all-restrictions-button"
1624 :onclick
(ps-inline (unselect-all-restrictions))
1626 (:select
:id
"restriction-select"
1627 :name
"restriction-select"
1630 :onchange
(ps-inline (request-photos)))
1631 (:div
:id
"streetmap-overview" :class
"streetmap-overview")
1632 (:div
:id
"streetmap-mouse-position"
1633 :class
"streetmap-mouse-position")
1634 (:div
:id
"streetmap-zoom" :class
"streetmap-zoom")))
1635 ;; control area (north)
1637 :class
"phoros-controls" :id
"phoros-controls"
1638 (:div
:id
"real-phoros-controls"
1639 (:h2
:class
"point-creator h2-phoros-controls"
1641 (:h2
:class
"point-editor h2-phoros-controls"
1643 (:span
:id
"creator"))
1644 (:h2
:class
"point-viewer h2-phoros-controls"
1646 (:span
:id
"creator"))
1647 (:h2
:class
"aux-data-viewer h2-phoros-controls"
1648 "View Auxiliary Data")
1649 (:h2
:class
"multiple-points-viewer"
1650 "Multiple Points Selected")
1651 (:div
:class
"multiple-points-viewer"
1652 (:p
"You have selected multiple user points.")
1653 (:p
"Unselect all but one to edit or view its properties."))
1654 (:span
:class
"point-creator point-editor point-viewer"
1659 :id
"point-kind-select"
1660 :name
"point-kind-select"
1661 :class
"combobox-select write-permission-dependent"
1662 :onchange
(ps-inline
1663 (consolidate-combobox
1667 :id
"point-kind-input"
1668 :name
"point-kind-input"
1669 :class
"combobox-input write-permission-dependent"
1670 :onchange
(ps-inline
1671 (unselect-combobox-selection
1675 (:input
:id
"point-numeric-description"
1676 :class
"vanilla-input write-permission-dependent"
1678 :type
"text" :name
"point-numeric-description")
1681 :id
"point-description"
1684 :id
"point-description-select"
1685 :name
"point-description-select"
1686 :class
"combobox-select write-permission-dependent"
1687 :onchange
(ps-inline
1688 (consolidate-combobox
1689 "point-description"))
1692 :id
"point-description-input"
1693 :name
"point-description-input"
1694 :class
"combobox-input write-permission-dependent"
1695 :onchange
(ps-inline
1696 (unselect-combobox-selection
1697 "point-description"))
1700 (:button
:id
"delete-point-button" :disabled t
1702 :onclick
(ps-inline (delete-point))
1704 (:button
:disabled t
:id
"finish-point-button"
1707 (:div
:id
"uniquify-buttons"
1708 (:button
:id
"suggest-unique-button"
1711 (insert-unique-suggestion))
1713 (:button
:id
"force-duplicate-button"
1716 (:div
:id
"aux-point-distance-or-point-creation-date"
1717 (:code
:id
"point-creation-date"
1718 :class
"point-editor point-viewer")
1720 :id
"aux-point-distance" :disabled t
1721 :class
"point-creator aux-data-viewer aux-data-dependent"
1722 :size
1 :name
"aux-point-distance"
1723 :onchange
(ps-inline
1724 (aux-point-distance-selected))
1726 (enable-aux-point-selection)))
1728 :id
"include-aux-data"
1729 :class
"point-creator aux-data-dependent"
1731 (:input
:id
"include-aux-data-p"
1732 :class
"tight-input"
1733 :type
"checkbox" :checked t
1734 :name
"include-aux-data-p"
1735 :onchange
(ps-inline
1736 (flip-aux-data-inclusion)))
1738 (:div
:id
"display-nearest-aux-data"
1739 :class
"aux-data-viewer"
1741 (:input
:id
"display-nearest-aux-data-p"
1742 :class
"tight-input"
1743 :type
"checkbox" :checked t
1744 :name
"display-nearest-aux-data-p"
1745 :onchange
(ps-inline
1746 (flip-nearest-aux-data-display)))
1750 :class
"point-creator point-editor point-viewer aux-data-viewer"
1751 (:div
:id
"aux-numeric-list")
1752 (:div
:id
"aux-text-list")))
1753 (:div
:class
"walk-mode-controls"
1754 (:div
:id
"walk-mode"
1755 :class
"aux-data-dependent"
1756 (:input
:id
"walk-p"
1757 :class
"tight-input"
1758 :type
"checkbox" :checked nil
1759 :onchange
(ps-inline
1761 (:label
:for
"walk-p"
1763 (:div
:id
"decrease-step-size"
1764 :class
"aux-data-dependent"
1765 :onclick
(ps-inline (decrease-step-size)))
1766 (:div
:id
"step-size"
1767 :class
"aux-data-dependent"
1768 :onclick
(ps-inline (increase-step-size))
1770 (:div
:id
"increase-step-size"
1771 :class
"aux-data-dependent"
1772 :onclick
(ps-inline (increase-step-size))
1773 :ondblclick
(ps-inline (increase-step-size)
1774 (increase-step-size)))
1775 (:div
:id
"step-button" :disabled nil
1776 :class
"aux-data-dependent"
1777 :onclick
(ps-inline (step))
1778 :ondblclick
(ps-inline (step t
))
1780 (:div
:class
"image-main-controls"
1781 (:div
:id
"auto-zoom"
1782 (:input
:id
"zoom-to-point-p"
1783 :class
"tight-input"
1784 :type
"checkbox" :checked t
)
1785 (:label
:for
"zoom-to-point-p"
1787 (:div
:id
"brighten-images"
1788 (:input
:id
"brighten-images-p"
1789 :class
"tight-input"
1790 :type
"checkbox" :checked nil
)
1791 (:label
:for
"brighten-images-p"
1793 (:div
:id
"zoom-images-to-max-extent"
1794 :onclick
(ps-inline (zoom-images-to-max-extent)))
1795 (:div
:id
"no-footprints-p"
1797 (:div
:id
"remove-work-layers-button" :disabled t
1798 :onclick
(ps-inline (reset-layers-and-controls))
1800 ;; help area (northeast)
1804 :id
"download-user-points-button"
1806 :onclick
(format nil
1807 "self.location.href = \"/~A/lib/user-points.json\""
1809 "download points") ;TODO: offer other formats and maybe projections
1818 "/lib/blurb?openlayers-version="
1819 (@ *open-layers
*version_number
*))
1821 (:img
:src
(format nil
"/~A/lib/public_html/phoros-logo-plain.png"
1823 :alt
"Phoros" :style
"vertical-align:middle"
1825 (:button
:id
"logout-button"
1827 :onclick
(ps-inline (bye))
1829 (:h2
:id
"h2-help" "Help")
1830 (:div
:id
"help-display"))
1831 ;; image area (south)
1832 (:div
:id
"images" :style
"clear:both"
1834 for i from
0 below
*number-of-images
* do
1836 (:div
:class
"controlled-image"
1837 (:div
:id
(format nil
"image-~S-controls" i
)
1838 :class
"image-controls"
1839 (:div
:id
(format nil
"image-~S-zoom" i
)
1840 :class
"image-zoom")
1841 (:div
:id
(format nil
"image-~S-layer-switcher" i
)
1842 :class
"image-layer-switcher")
1843 (:div
:id
(format nil
"image-~S-usable" i
)
1844 :class
"image-usable"
1846 (:div
:id
(format nil
"image-~S-trigger-time" i
)
1847 :class
"image-trigger-time"))
1848 (:div
:id
(format nil
"image-~S" i
)
1849 :class
"image" :style
"cursor:crosshair"))))))))
1850 (hunchentoot:redirect
1851 (format nil
"/~A/~A"
1853 (hunchentoot:session-value
'presentation-project-name
))
1854 :add-session-id t
)))
1856 (hunchentoot:define-easy-handler
1857 (epipolar-line :uri
"/phoros/lib/epipolar-line")
1859 "Receive vector of two sets of picture parameters, the first of
1860 which containing coordinates (m, n) of a clicked point. Respond with a
1861 JSON encoded epipolar-line."
1862 (assert-authentication)
1863 (setf (hunchentoot:content-type
*) "application/json")
1864 (let* ((data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
1865 (json:encode-json-to-string
1866 (photogrammetry :epipolar-line
(first data
) (second data
)))))
1868 (hunchentoot:define-easy-handler
1869 (estimated-positions :uri
"/phoros/lib/estimated-positions")
1871 "Receive a two-part JSON vector comprising (1) a vector containing
1872 sets of picture-parameters with clicked (\"active\") points
1873 stored in :m, :n; and (2) a vector containing sets of
1874 picture-parameters; respond with a JSON encoded two-part vector
1875 comprising (1) a point in global coordinates; and (2) a vector of
1876 image coordinates (m, n) for the global point that correspond to the
1877 images from the received second vector. TODO: report error on bad
1878 data (ex: points too far apart)."
1879 ;; TODO: global-point-for-display should probably contain a proj string in order to make sense of the (cartesian) standard deviations.
1880 (assert-authentication)
1881 (setf (hunchentoot:content-type
*) "application/json")
1883 (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1884 (active-point-photo-parameters
1886 (number-of-active-points
1887 (length active-point-photo-parameters
))
1888 (destination-photo-parameters
1891 (cdr (assoc :cartesian-system
1892 (first active-point-photo-parameters
))))
1893 (global-point-cartesian
1895 :multi-position-intersection active-point-photo-parameters
))
1896 (global-point-geographic-radians
1897 (proj:cs2cs
(list (cdr (assoc :x-global global-point-cartesian
))
1898 (cdr (assoc :y-global global-point-cartesian
))
1899 (cdr (assoc :z-global global-point-cartesian
)))
1900 :source-cs cartesian-system
))
1901 (global-point-for-display ;points geographic cs, degrees; std deviations in cartesian cs
1902 (pairlis '(:longitude
:latitude
:ellipsoid-height
1903 ;; :stdx-global :stdy-global :stdz-global
1906 (proj:radians-to-degrees
1907 (first global-point-geographic-radians
))
1908 (proj:radians-to-degrees
1909 (second global-point-geographic-radians
))
1910 (third global-point-geographic-radians
)
1911 ;; (cdr (assoc :stdx-global global-point-cartesian))
1912 ;; (cdr (assoc :stdy-global global-point-cartesian))
1913 ;; (cdr (assoc :stdz-global global-point-cartesian))
1914 number-of-active-points
)))
1917 for i in destination-photo-parameters
1920 (photogrammetry :reprojection i global-point-cartesian
)))))
1921 (json:encode-json-to-string
1922 (list global-point-for-display image-coordinates
))))
1924 (hunchentoot:define-easy-handler
1925 (user-point-positions :uri
"/phoros/lib/user-point-positions")
1927 "Receive a two-part JSON vector comprising
1928 - a vector of user-point-id's and
1929 - a vector containing sets of picture-parameters;
1930 respond with a JSON object comprising the elements
1931 - image-points, a vector whose elements
1932 - correspond to the elements of the picture-parameters vector
1934 - are GeoJSON feature collections containing one point (in picture
1935 coordinates) for each user-point-id received;
1936 - user-point-count, the number of user-points we tried to fetch
1938 (assert-authentication)
1939 (setf (hunchentoot:content-type
*) "application/json")
1940 (with-connection *postgresql-credentials
*
1941 (let* ((user-point-table-name
1942 (user-point-table-name (hunchentoot:session-value
1943 'presentation-project-name
)))
1944 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1945 (user-point-ids (first data
))
1946 (user-point-count (length user-point-ids
))
1947 (destination-photo-parameters (second data
))
1949 (cdr (assoc :cartesian-system
1950 (first destination-photo-parameters
)))) ;TODO: in rare cases, coordinate systems of the images shown may differ
1954 (:as
(:st_x
'coordinates
) 'longitude
)
1955 (:as
(:st_y
'coordinates
) 'latitude
)
1956 (:as
(:st_z
'coordinates
) 'ellipsoid-height
)
1957 (:as
'user-point-id
'id
) ;becomes fid on client
1960 'numeric-description
1962 (:as
(:to-char
'creation-date
"IYYY-MM-DD HH24:MI:SS TZ")
1966 :from user-point-table-name
:natural
:left-join
'sys-user
1967 :where
(:in
'user-point-id
(:set user-point-ids
)))
1969 (global-points-cartesian
1971 for global-point-geographic in user-points
1973 (ignore-errors ;in case no destination-photo-parameters have been sent
1974 (pairlis '(:x-global
:y-global
:z-global
)
1977 (proj:degrees-to-radians
1978 (getf global-point-geographic
:longitude
))
1979 (proj:degrees-to-radians
1980 (getf global-point-geographic
:latitude
))
1981 (getf global-point-geographic
:ellipsoid-height
))
1982 :destination-cs cartesian-system
)))))
1985 for photo-parameter-set in destination-photo-parameters
1987 (encode-geojson-to-string
1989 for global-point-cartesian in global-points-cartesian
1990 for user-point in user-points
1992 (when (point-within-image-p
1993 (getf user-point
:id
)
1994 (hunchentoot:session-value
'presentation-project-name
)
1995 (cdr (assoc :byte-position photo-parameter-set
))
1996 (cdr (assoc :filename photo-parameter-set
))
1997 (cdr (assoc :measurement-id photo-parameter-set
)))
1999 (let ((photo-coordinates
2000 (photogrammetry :reprojection
2002 global-point-cartesian
))
2005 (setf (getf photo-point
:x
)
2006 (cdr (assoc :m photo-coordinates
)))
2007 (setf (getf photo-point
:y
)
2008 (cdr (assoc :n photo-coordinates
)))
2010 :junk-keys
'(:longitude
:latitude
:ellipsoid-height
)))))
2011 (with-output-to-string (s)
2012 (json:with-object
(s)
2013 (json:encode-object-member
:user-point-count user-point-count s
)
2014 (json:as-object-member
(:image-points s
)
2015 (json:with-array
(s)
2016 (loop for i in image-coordinates do
2017 (json:as-array-member
(s) (princ i s
))))))))))
2019 (defun point-within-image-p (user-point-id presentation-project-name
2020 byte-position filename measurement-id
)
2021 "Return t if either point with user-point-id is inside the footprint
2022 of the image described by byte-position, filename, and measurement-id;
2023 or if that image doesn't have a footprint. Return nil otherwise."
2024 (let* ((user-point-table-name (user-point-table-name
2025 presentation-project-name
))
2026 (presentation-project-id (presentation-project-id-from-name
2027 presentation-project-name
))
2028 (common-table-names (common-table-names presentation-project-id
)))
2033 for common-table-name in common-table-names
2034 for aggregate-view-name
2035 = (aggregate-view-name common-table-name
)
2039 :from
',aggregate-view-name
2040 :where
(:and
(:= 'byte-position
,byte-position
)
2041 (:= 'filename
,filename
)
2042 (:= 'measurement-id
,measurement-id
)
2043 (:or
(:is-null
'footprint
)
2045 (:select
'coordinates
2046 :from
,user-point-table-name
2047 :where
(:= 'user-point-id
2052 (hunchentoot:define-easy-handler
2053 (multi-position-intersection :uri
"/phoros/lib/intersection")
2055 "Receive vector of sets of picture parameters, respond with stuff."
2056 (assert-authentication)
2057 (setf (hunchentoot:content-type
*) "application/json")
2058 (let* ((data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
2059 (json:encode-json-to-string
2060 (photogrammetry :multi-position-intersection data
))))