?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Exit gracefully when closed by window manger
[phoros.git] / phoros.lisp
blob3a7f089d778f68c96d16e03a222702035edd903b
1 ;;; PHOROS -- Photogrammetric Road Survey
2 ;;; Copyright (C) 2010, 2011, 2012, 2016 Bert Burgemeister
3 ;;;
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.
8 ;;;
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.
13 ;;;
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.
17
18 (in-package :phoros)
19
20 (setf *js-target-version* 1.8)
21
22 ;;; Debug helpers. TODO: remove them.
23 (defparameter *t* nil)
24 (defparameter *tt* nil)
25
26 (cffi:define-foreign-library phoml
27 (:unix (:or "./libphoml.so"
28 "./phoml/lib/libphoml.so"))
29 (t (:default "libphoml")))
30
31 (defparameter *standard-coordinates* 4326
32 "EPSG code of the coordinate system that we use for communication.")
33
34 (defparameter *spherical-mercator* 900913
35 "EPSG code of the coordinate system used for some distance calculations.")
36
37 (defvar *postgresql-credentials* nil
38 "A list: (database user password host &key (port 5432) use-ssl).")
39
40 (defvar *postgresql-aux-credentials* nil
41 "A list: (database user password host &key (port 5432) use-ssl).")
42
43 (defparameter *photogrammetry-mutex* (bt:make-lock "photogrammetry"))
44
45 (setf *read-default-float-format* 'double-float)
46
47 (defparameter *phoros-server* nil "Hunchentoot acceptor.")
48
49 (defparameter *common-root* nil
50 "Root directory; contains directories of measuring data.")
51
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.")
55
56 (defparameter *login-intro* nil
57 "A few friendly words to be shown below the login form.")
58
59 (defparameter *number-of-images* 4
60 "Number of photos shown to the HTTP client.")
61
62 (defparameter *aux-numeric-labels* nil
63 "Labels for auxiliary numeric data rows shown to the HTTP client.")
64
65 (defparameter *aux-text-labels* nil
66 "Labels for auxiliary text data rows shown to the HTTP client.")
67
68 (defparameter *browser-cache-max-age* (* 3600 24 7)
69 "Value x for Cache-Control:max-age=x, for images on client.")
70
71 (defparameter *number-of-features-per-layer* 500
72 "What we think a browser can swallow.")
73
74 (defparameter *number-of-points-per-aux-linestring* 500
75 "What we think a browser can swallow.")
76
77 (defparameter *user-point-creation-date-format* "IYYY-MM-DD HH24:MI:SS TZ"
78 "SQL date format used for display and GeoJSON export of user points.")
79
80 (defparameter *phoros-version*
81 (asdf:component-version (asdf:find-system :phoros))
82 "Phoros version as defined in system definition.")
83
84 (defparameter *aggregate-view-columns*
85 (list 'usable
86 'recorded-device-id ;debug
87 'device-stage-of-life-id ;debug
88 'generic-device-id ;debug
89 'directory
90 'measurement-id
91 'filename 'byte-position 'point-id
92 'trigger-time
93 ;;'coordinates ;the search target
94 'longitude 'latitude 'ellipsoid-height
95 'cartesian-system
96 'east-sd 'north-sd 'height-sd
97 'roll 'pitch 'heading
98 'roll-sd 'pitch-sd 'heading-sd
99 'sensor-width-pix 'sensor-height-pix
100 'pix-size
101 'bayer-pattern 'color-raiser
102 'mounting-angle
103 'dx 'dy 'dz 'omega 'phi 'kappa
104 'c 'xh 'yh 'a1 'a2 'a3 'b1 'b2 'c1 'c2 'r0
105 'b-dx 'b-dy 'b-dz 'b-rotx 'b-roty 'b-rotz
106 'b-ddx 'b-ddy 'b-ddz
107 'b-drotx 'b-droty 'b-drotz)
108 "Most of the column names of aggregate-view.")
109
110 (defun version-number-parts (dotted-string)
111 "Return the three version number components of something like
112 \"11.22.33\"."
113 (when dotted-string
114 (values-list (mapcar #'parse-integer
115 (cl-utilities:split-sequence #\. dotted-string)))))
116
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)
123 (minor minor-number)
124 (revision revision-number)
125 (t *phoros-version*))))
126
127 (defun check-dependencies ()
128 "Say OK if the necessary external dependencies are available."
129 (handler-case
130 (progn
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))))
136
137 (defun muffle-postgresql-warnings ()
138 "For current DB, silence PostgreSQL's warnings about implicitly
139 created stuff."
140 (unless (cli:verbosity-level :postgresql-warnings)
141 (execute "SET client_min_messages TO ERROR;")))
142
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)."
147 (let (connection)
148 (handler-case
149 (setf connection (apply #'connect db-credentials))
150 (error (e) (format *error-output* "Database connection ~S failed: ~A~&"
151 db-credentials e)))
152 (when connection
153 (disconnect connection)
154 t)))
155
156 (defun ignore-warnings (c) (declare (ignore c)) (muffle-warning))
157
158 (defmethod hunchentoot:session-cookie-name (acceptor)
159 (declare (ignore acceptor))
160 "phoros-session")
161
162 (defun start-server (&key (proxy-root "phoros") (http-port 8080) address
163 (common-root "/"))
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
168 :port http-port
169 :address address
170 :document-root (ensure-directories-exist
171 "unexpected_html/")
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*))
182
183 (defun stop-server () (hunchentoot:stop *phoros-server*))
184
185 (eval-when (:compile-toplevel :load-toplevel :execute)
186 (register-sql-operators :2+-ary :&& :overlaps))
187
188 (hunchentoot:define-easy-handler phoros-handler ()
189 "First HTTP contact: if necessary, check credentials, establish new
190 session."
191 (with-connection *postgresql-credentials*
192 (let* ((s (cl-utilities:split-sequence
193 #\/
194 (hunchentoot:script-name*)
195 :remove-empty-subseqs t))
196 (presentation-project-name (second s))
197 (presentation-project-id
198 (ignore-errors
199 (presentation-project-id-from-name presentation-project-name))))
200
201 ;; TODO: remove the following line (which seems to function as a
202 ;; wakeup call of sorts)...
203 (get-dao 'sys-user-role 0 0)
204 ;; ...and make sure the following error doesn't occur any longer
205 ;; while accessing the HTTP server:
206 ;; #<POSTMODERN:DAO-CLASS PHOROS::SYS-USER-ROLE> cannot be printed readably.
207
208 (cond
209 ((null presentation-project-id)
210 (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+))
211 ((and (equal (hunchentoot:session-value 'presentation-project-name)
212 presentation-project-name)
213 (hunchentoot:session-value 'authenticated-p))
214 (hunchentoot:redirect
215 (format nil "/~A/lib/view-~A"
216 ;; *proxy-root*
217 "phoros"
218 (phoros-version))
219 :add-session-id t))
220 (t
221 (progn
222 (setf (hunchentoot:session-value 'presentation-project-name)
223 presentation-project-name)
224 (setf (hunchentoot:session-value 'presentation-project-id)
225 presentation-project-id)
226 (setf (hunchentoot:session-value 'presentation-project-bbox)
227 (let ((bbox
228 (ignore-errors
229 (bounding-box (get-dao 'sys-presentation-project
230 presentation-project-name)))))
231 (if (or (null bbox) (eq :null bbox))
232 nil
233 bbox)))
234 (setf (hunchentoot:session-value 'aux-data-p)
235 (with-connection *postgresql-aux-credentials*
236 (view-exists-p (aux-point-view-name
237 presentation-project-name))))
238 (setf (hunchentoot:session-value 'number-of-threads) 0)
239 (who:with-html-output-to-string (s nil :prologue t :indent t)
240 (:body
241 :style "font-family:sans-serif;"
242 (:form
243 :method "post" :enctype "multipart/form-data"
244 :action (format nil "/~A/lib/authenticate"
245 *proxy-root*)
246 :name "login-form"
247 (:fieldset
248 (:legend (:b (:a :href "http://phoros.boundp.org"
249 :style "text-decoration:none;"
250 "Phoros")
251 (who:fmt "&nbsp;[~A]" presentation-project-name)))
252 (:noscript
253 (:b (:em "You can't do much without JavaScript there.")))
254 (:p "User:"
255 :br
256 (:input :type "text" :name "user-name"))
257 (:p "Password:"
258 :br
259 (:input :type "password" :name "user-password")
260 "&nbsp;&nbsp;&nbsp;"
261 (:span :id "cackle"))
262 (:input :type "submit" :value "Submit"
263 :onclick (ps-inline
264 (setf (chain document
265 (get-element-by-id "cackle")
266 inner-h-t-m-l)
267 "Ok, let&#039;s see&#8230;"))))
268 (:script :type "text/javascript"
269 (who:str (ps (chain document
270 :login-form
271 :user-name
272 (focus))))))
273 (loop
274 for i in *login-intro*
275 do (who:htm (:p (who:str i))))))))))))
276
277 (pushnew (hunchentoot:create-regex-dispatcher "/phoros/(?!lib/)"
278 'phoros-handler)
279 hunchentoot:*dispatch-table*)
280
281 (defun stored-bbox ()
282 "Return stored bounding box for user and presentation project of
283 current session."
284 (with-connection *postgresql-credentials*
285 (let ((bbox (bounding-box
286 (get-dao 'sys-user-role
287 (hunchentoot:session-value
288 'user-id)
289 (hunchentoot:session-value
290 'presentation-project-id)))))
291 (if (eq :null bbox)
292 (hunchentoot:session-value 'presentation-project-bbox)
293 bbox))))
294
295 (defun stored-cursor ()
296 "Return stored cursor position for user and presentation project of
297 current session."
298 (with-connection *postgresql-credentials*
299 (let ((cursor
300 (query
301 (:select (:st_x 'cursor) (:st_y 'cursor)
302 :from 'sys-user-role
303 :where (:and (:= 'user-id
304 (hunchentoot:session-value 'user-id))
305 (:= 'presentation-project-id
306 (hunchentoot:session-value
307 'presentation-project-id))
308 (:raw "cursor IS NOT NULL")))
309 :list)))
310 (when cursor
311 (format nil "~{~F~#^,~}" cursor)))))
312
313
314 (hunchentoot:define-easy-handler
315 (authenticate-handler :uri "/phoros/lib/authenticate"
316 :default-request-type :post)
317 ()
318 "Check user credentials."
319 (with-connection *postgresql-credentials*
320 (let* ((user-name (hunchentoot:post-parameter "user-name"))
321 (user-password (hunchentoot:post-parameter "user-password"))
322 (presentation-project-id (hunchentoot:session-value
323 'presentation-project-id))
324 (user-info
325 (when presentation-project-id
326 (query
327 (:select
328 'sys-user.user-full-name
329 'sys-user.user-id
330 'sys-user-role.user-role
331 :from 'sys-user-role 'sys-user
332 :where (:and
333 (:= 'presentation-project-id presentation-project-id)
334 (:= 'sys-user-role.user-id 'sys-user.user-id)
335 (:= 'user-name user-name)
336 (:= 'user-password user-password)))
337 :row)))
338 (user-full-name (first user-info))
339 (user-id (second user-info))
340 (user-role (third user-info)))
341 (if user-role
342 (progn
343 (setf (hunchentoot:session-value 'authenticated-p) t
344 (hunchentoot:session-value 'user-name) user-name
345 (hunchentoot:session-value 'user-full-name) user-full-name
346 (hunchentoot:session-value 'user-id) user-id
347 (hunchentoot:session-value 'user-role) user-role)
348 (hunchentoot:redirect
349 (format nil "/~A/lib/view-~A"
350 ;; *proxy-root*
351 "phoros"
352 (phoros-version))
353 :add-session-id t))
354 (who:with-html-output-to-string (s nil :prologue t :indent t)
355 (:body
356 :style "font-family:sans-serif;"
357 (:b "Rejected. ")
358 (:a :href (format nil "/~A/~A/"
359 *proxy-root*
360 (hunchentoot:session-value
361 'presentation-project-name))
362 "Retry?")))))))
363
364 (defun assert-authentication ()
365 "Abort request handler on unauthorized access."
366 (unless (hunchentoot:session-value 'authenticated-p)
367 (setf (hunchentoot:return-code*) hunchentoot:+http-precondition-failed+)
368 (hunchentoot:abort-request-handler)))
369
370 (hunchentoot:define-easy-handler logout-handler (bbox longitude latitude)
371 (if (hunchentoot:session-value 'authenticated-p)
372 (with-connection *postgresql-credentials*
373 (let ((presentation-project-name
374 (hunchentoot:session-value 'presentation-project-name))
375 (sys-user-role
376 (get-dao 'sys-user-role
377 (hunchentoot:session-value 'user-id)
378 (hunchentoot:session-value 'presentation-project-id))))
379 (when sys-user-role
380 (when bbox
381 (setf (bounding-box sys-user-role) bbox))
382 (when (and longitude latitude)
383 (let* ;; kludge: should be done by some library, not by DB query
384 ((point-form (format nil "POINT(~F ~F)" longitude latitude))
385 (point-wkb (query (:select
386 (:st_geomfromtext point-form))
387 :single)))
388 (setf (cursor sys-user-role) point-wkb)))
389 (update-dao sys-user-role))
390 (hunchentoot:remove-session hunchentoot:*session*)
391 (who:with-html-output-to-string (s nil :prologue t :indent t)
392 (:html
393 (:head
394 (:title (who:str
395 (concatenate
396 'string
397 "Phoros: logged out" )))
398 (:link :rel "stylesheet"
399 :href (format nil "/~A/lib/css-~A/style.css"
400 *proxy-root*
401 (phoros-version))
402 :type "text/css"))
403 (:body
404 (:h1 :id "title" "Phoros: logged out")
405 (:p "Log back in to project "
406 (:a :href (format nil "/~A/~A"
407 *proxy-root*
408 presentation-project-name)
409 (who:fmt "~A." presentation-project-name))))))))
410 "Bye (again)."))
411
412 (pushnew (hunchentoot:create-regex-dispatcher "/logout" 'logout-handler)
413 hunchentoot:*dispatch-table*)
414
415 (hunchentoot:define-easy-handler set-cursor-handler (bbox longitude latitude)
416 (assert-authentication)
417 (with-connection *postgresql-credentials*
418 (let ((presentation-project-name
419 (hunchentoot:session-value 'presentation-project-name))
420 (sys-user-role
421 (get-dao 'sys-user-role
422 (hunchentoot:session-value 'user-id)
423 (hunchentoot:session-value 'presentation-project-id))))
424 (when sys-user-role
425 (when bbox
426 (setf (bounding-box sys-user-role) bbox))
427 (when (and longitude latitude)
428 (let* ;; kludge: should be done by some library, not by DB query
429 ((point-form (format nil "POINT(~F ~F)" longitude latitude))
430 (point-wkb (query (:select
431 (:st_geomfromtext point-form))
432 :single)))
433 (setf (cursor sys-user-role) point-wkb)))
434 (update-dao sys-user-role))))
435 "cursor set")
436
437 (pushnew (hunchentoot:create-regex-dispatcher "/set-cursor" 'set-cursor-handler)
438 hunchentoot:*dispatch-table*)
439
440 (define-condition superseded () ()
441 (:documentation
442 "Tell a thread to finish as soon as possible taking any shortcuts
443 available."))
444
445 (hunchentoot:define-easy-handler
446 (selectable-restrictions :uri "/phoros/lib/selectable-restrictions.json"
447 :default-request-type :post)
448 ()
449 "Respond with a list of restrictions the user may choose from."
450 (assert-authentication)
451 (setf (hunchentoot:content-type*) "application/json")
452 (with-connection *postgresql-credentials*
453 (json:encode-json-to-string
454 (query
455 (:order-by
456 (:select 'restriction-id
457 :from 'sys-selectable-restriction
458 :where (:= 'presentation-project-id
459 (hunchentoot:session-value
460 'presentation-project-id)))
461 'restriction-id)
462 :column))))
463
464 (defun selected-restrictions (presentation-project-id selected-restriction-ids)
465 "Get from current database connection a list of restriction clauses
466 belonging to presentation-project-id and ids from list
467 selected-restriction-ids."
468 (query
469 (sql-compile
470 `(:select 'sql-clause
471 :from 'sys-selectable-restriction
472 :where (:and (:= 'presentation-project-id
473 ,presentation-project-id)
474 (:or
475 ,@(loop for i in selected-restriction-ids
476 collect (list := 'restriction-id i))))))
477 :column))
478
479 (defun sql-where-conjunction (sql-boolean-clauses)
480 "Parenthesize sql-boolean-clauses and concatenate them into a
481 string, separated by \"AND\". Return \" TRUE \" if
482 sql-boolean-clauses is nil."
483 (if sql-boolean-clauses
484 (apply #'concatenate 'string (butlast (loop
485 for i in sql-boolean-clauses
486 collect " ("
487 collect i
488 collect ") "
489 collect "AND")))
490 " TRUE "))
491
492 (hunchentoot:define-easy-handler
493 (nearest-image-data :uri "/phoros/lib/nearest-image-data"
494 :default-request-type :post)
495 ()
496 "Receive coordinates, respond with the count nearest json objects
497 containing picture url, calibration parameters, and car position,
498 wrapped in an array. Wipe away any unfinished business first."
499 (assert-authentication)
500 (dolist (old-thread (hunchentoot:session-value 'recent-threads))
501 (ignore-errors
502 (bt:interrupt-thread old-thread
503 #'(lambda () (signal 'superseded)))))
504 (setf (hunchentoot:session-value 'recent-threads) nil)
505 (setf (hunchentoot:session-value 'number-of-threads) 1)
506 (push (bt:current-thread) (hunchentoot:session-value 'recent-threads))
507 (setf (hunchentoot:content-type*) "application/json")
508 (with-connection *postgresql-credentials*
509 (let* ((presentation-project-id (hunchentoot:session-value
510 'presentation-project-id))
511 (common-table-names (common-table-names
512 presentation-project-id))
513 (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
514 (longitude (cdr (assoc :longitude data)))
515 (latitude (cdr (assoc :latitude data)))
516 (count (cdr (assoc :count data)))
517 (zoom (cdr (assoc :zoom data)))
518 (snap-distance ;bogus distance in degrees,
519 (* 100e-5 ; assuming geographic
520 (expt 2 (- ; coordinates
521 14 ; (1m = 1e-5 degrees)
522 (max 13
523 (min 18 zoom))))))
524 (point-form (format nil "POINT(~F ~F)" longitude latitude))
525 (selected-restrictions-conjunction
526 (sql-where-conjunction
527 (selected-restrictions presentation-project-id
528 (cdr (assoc :selected-restriction-ids
529 data)))))
530 (nearest-footprint-centroid-query
531 ;; Inserting the following into
532 ;; image-data-with-footprints-query as a subquery would
533 ;; work correctly but is way too slow.
534 (sql-compile
535 `(:limit
536 (:select
537 'centroid
538 ,@*aggregate-view-columns*
539 :from
540 (:as
541 (:order-by
542 (:union
543 ,@(loop
544 for common-table-name
545 in common-table-names
546 for aggregate-view-name
547 = (aggregate-view-name
548 common-table-name)
549 collect
550 `(:select
551 (:as
552 (:st_distance
553 (:st_centroid 'footprint)
554 (:st_geomfromtext
555 ,point-form
556 ,*standard-coordinates*))
557 'distance)
558 (:as (:st_centroid 'footprint)
559 'centroid)
560 ,@*aggregate-view-columns*
561 :from (:as
562 (:select
563 '*
564 ;; no-ops wrt self-references in
565 ;; selected-restrictions-conjunction
566 ,@(postmodern-as-clauses
567 (pairlis *aggregate-view-columns*
568 *aggregate-view-columns*))
569 :from ',aggregate-view-name)
570 'images-of-acquisition-project)
571 :where
572 (:and
573 (:= 'presentation-project-id
574 ,presentation-project-id)
575 (:st_dwithin
576 'footprint
577 (:st_geomfromtext
578 ,point-form
579 ,*standard-coordinates*)
580 ,snap-distance)
581 (:raw ,selected-restrictions-conjunction)))))
582 'distance)
583 'centroids))
584 1)))
585 (nearest-footprint-image
586 (ignore-errors (logged-query "centroid of nearest footprint"
587 nearest-footprint-centroid-query
588 :alist)))
589 (nearest-footprint-centroid
590 (cdr (assoc :centroid nearest-footprint-image)))
591 (image-data-with-footprints-query
592 (sql-compile
593 `(:limit
594 (:order-by
595 (:union
596 ,@(loop
597 for common-table-name in common-table-names
598 for aggregate-view-name
599 = (aggregate-view-name common-table-name)
600 collect
601 `(:select
602 ,@*aggregate-view-columns*
603 (:as (:st_distance
604 (:case
605 ((:is-null 'footprint) 'coordinates)
606 (t (:st_centroid 'footprint)))
607 ,nearest-footprint-centroid)
608 'distance)
609 (:as (:not (:is-null 'footprint))
610 'footprintp)
611 ,(when (cli:verbosity-level :render-footprints)
612 '(:as (:st_asewkt 'footprint)
613 'footprint-wkt))
614 :from (:as
615 (:select
616 '*
617 ,@(postmodern-as-clauses
618 nearest-footprint-image)
619 :from ',aggregate-view-name)
620 'images-of-acquisition-project-plus-reference-image)
621 :where
622 (:and
623 (:= 'presentation-project-id
624 ,presentation-project-id)
625 (:st_contains 'footprint
626 ,nearest-footprint-centroid)
627 (:raw ,selected-restrictions-conjunction)))))
628 'distance)
629 ,count)))
630 (nearest-image-without-footprints-query
631 (sql-compile
632 `(:limit
633 (:order-by
634 (:union
635 ,@(loop
636 for common-table-name in common-table-names
637 for aggregate-view-name
638 = (aggregate-view-name common-table-name)
639 collect
640 `(:select
641 ,@*aggregate-view-columns*
642 (:as (:st_distance 'coordinates
643 (:st_geomfromtext
644 ,point-form
645 ,*standard-coordinates*))
646 'distance)
647 (:as (:not (:is-null 'footprint))
648 'footprintp)
649 :from (:as
650 (:select
651 '*
652 ;; no-ops wrt self-references in
653 ;; selected-restrictions-conjunction
654 ,@(postmodern-as-clauses
655 (pairlis *aggregate-view-columns*
656 *aggregate-view-columns*))
657 :from ',aggregate-view-name)
658 'images-of-acquisition-project)
659 :where
660 (:and (:= 'presentation-project-id
661 ,presentation-project-id)
662 (:st_dwithin 'coordinates
663 (:st_geomfromtext
664 ,point-form
665 ,*standard-coordinates*)
666 ,snap-distance)
667 (:raw ,selected-restrictions-conjunction)))))
668 'distance)
669 1)))
670 (nearest-image-without-footprint
671 (unless nearest-footprint-centroid ;otherwise save time
672 (ignore-errors (logged-query "no footprint, first image"
673 nearest-image-without-footprints-query
674 :alist))))
675 (image-data-without-footprints-query
676 (sql-compile
677 `(:limit
678 (:order-by
679 (:union
680 ,@(loop
681 for common-table-name in common-table-names
682 for aggregate-view-name
683 = (aggregate-view-name common-table-name)
684 collect
685 `(:select
686 ,@*aggregate-view-columns*
687 (:as (:st_distance 'coordinates
688 (:st_geomfromtext
689 ,point-form
690 ,*standard-coordinates*))
691 'distance)
692 (:as (:not (:is-null 'footprint))
693 'footprintp)
694 :from (:as
695 (:select
696 '*
697 ,@(postmodern-as-clauses
698 nearest-image-without-footprint)
699 :from ',aggregate-view-name)
700 'images-of-acquisition-project)
701 :where
702 (:and (:= 'presentation-project-id
703 ,presentation-project-id)
704 (:st_dwithin 'coordinates
705 (:st_geomfromtext
706 ,point-form
707 ,*standard-coordinates*)
708 ,snap-distance)
709 (:raw ,selected-restrictions-conjunction)))))
710 'distance)
711 ,count)))
712 (result
713 (handler-case
714 (ignore-errors
715 (if nearest-footprint-centroid
716 (logged-query "footprints are ready"
717 image-data-with-footprints-query
718 :alists)
719 (logged-query "no footprints yet"
720 image-data-without-footprints-query
721 :alists)))
722 (superseded () nil))))
723 (when (cli:verbosity-level :render-footprints)
724 (setf
725 result
726 (loop
727 for photo-parameter-set in result
728 for footprint-vertices = ;something like this:
729 ;; "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))"
730 (ignore-errors ;probably no :footprint-wkt
731 (mapcar (lambda (p)
732 (mapcar (lambda (x)
733 (parse-number:parse-real-number x))
734 (cl-utilities:split-sequence #\Space p)))
735 (subseq
736 (cl-utilities:split-sequence-if
737 (lambda (x)
738 (or (eq x #\,)
739 (eq x #\()
740 (eq x #\))))
741 (cdr (assoc :footprint-wkt photo-parameter-set)))
742 2 7)))
743 collect
744 (if footprint-vertices
745 (acons
746 :rendered-footprint
747 (pairlis
748 '(:type :coordinates)
749 (list
750 :line-string
751 (loop
752 for footprint-vertex in footprint-vertices
753 for reprojected-vertex =
754 (photogrammetry
755 :reprojection
756 ;; KLUDGE: translate keys, e.g. a1 -> a_1
757 (json:decode-json-from-string
758 (json:encode-json-to-string photo-parameter-set))
759 (pairlis '(:x-global :y-global :z-global)
760 (proj:cs2cs
761 (list (proj:degrees-to-radians
762 (first footprint-vertex))
763 (proj:degrees-to-radians
764 (second footprint-vertex))
765 (third footprint-vertex))
766 :destination-cs
767 (cdr (assoc :cartesian-system
768 photo-parameter-set)))))
769 collect
770 (list (cdr (assoc :m reprojected-vertex))
771 (cdr (assoc :n reprojected-vertex))))))
772 photo-parameter-set)
773 photo-parameter-set))))
774 (decf (hunchentoot:session-value 'number-of-threads))
775 (json:encode-json-to-string result))))
776
777 (hunchentoot:define-easy-handler
778 (nearest-image-urls :uri "/phoros/lib/nearest-image-urls"
779 :default-request-type :post)
780 ()
781 "Receive coordinates, respond with a json array of the necessary
782 ingredients for the URLs of the 256 nearest images."
783 (assert-authentication)
784 (when (cli:verbosity-level :suppress-preemptive-caching)
785 (return-from nearest-image-urls ""))
786 (push (bt:current-thread) (hunchentoot:session-value 'recent-threads))
787 (if (<= (hunchentoot:session-value 'number-of-threads)
788 0) ;only stuff cache if everything else is done
789 (progn
790 (incf (hunchentoot:session-value 'number-of-threads))
791 (setf (hunchentoot:content-type*) "application/json")
792 (with-connection *postgresql-credentials*
793 (let* ((presentation-project-id (hunchentoot:session-value
794 'presentation-project-id))
795 (common-table-names (common-table-names
796 presentation-project-id))
797 (data (json:decode-json-from-string
798 (hunchentoot:raw-post-data)))
799 (longitude (cdr (assoc :longitude data)))
800 (latitude (cdr (assoc :latitude data)))
801 (count 256)
802 (radius (* 5d-4)) ; assuming geographic coordinates
803 (point-form (format nil "POINT(~F ~F)" longitude latitude))
804 (result
805 (handler-case
806 (ignore-errors
807 (query
808 (sql-compile
809 `(:limit
810 (:select
811 'directory 'filename 'byte-position
812 'bayer-pattern 'color-raiser 'mounting-angle
813 :from
814 (:as
815 (:order-by
816 (:union
817 ,@(loop
818 for common-table-name
819 in common-table-names
820 for aggregate-view-name
821 = (aggregate-view-name common-table-name)
822 collect
823 `(:select
824 'directory
825 'filename 'byte-position
826 'bayer-pattern 'color-raiser
827 'mounting-angle
828 (:as (:st_distance
829 'coordinates
830 (:st_geomfromtext
831 ,point-form
832 ,*standard-coordinates*))
833 'distance)
834 :from
835 ',aggregate-view-name
836 :where
837 (:and (:= 'presentation-project-id
838 ,presentation-project-id)
839 (:st_dwithin
840 'coordinates
841 (:st_geomfromtext
842 ,point-form
843 ,*standard-coordinates*)
844 ,radius)))))
845 'distance)
846 'raw-image-urls))
847 ,count))
848 :alists))
849 (superseded ()
850 (setf (hunchentoot:return-code*)
851 hunchentoot:+http-gateway-time-out+)
852 nil))))
853 (decf (hunchentoot:session-value 'number-of-threads))
854 (json:encode-json-to-string result))))
855 ;; (setf (hunchentoot:return-code*) hunchentoot:+http-gateway-time-out+)
856 ))
857
858 (hunchentoot:define-easy-handler
859 (store-point :uri "/phoros/lib/store-point" :default-request-type :post)
860 ()
861 "Receive point sent by user; store it into database."
862 (assert-authentication)
863 (let* ((presentation-project-name (hunchentoot:session-value
864 'presentation-project-name))
865 (user-id (hunchentoot:session-value 'user-id))
866 (user-role (hunchentoot:session-value 'user-role))
867 (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
868 (longitude (cdr (assoc :longitude data)))
869 (latitude (cdr (assoc :latitude data)))
870 (ellipsoid-height (cdr (assoc :ellipsoid-height data)))
871 ;; (stdx-global (cdr (assoc :stdx-global data)))
872 ;; (stdy-global (cdr (assoc :stdy-global data)))
873 ;; (stdz-global (cdr (assoc :stdz-global data)))
874 (input-size (cdr (assoc :input-size data)))
875 (kind (cdr (assoc :kind data)))
876 (description (cdr (assoc :description data)))
877 (numeric-description (cdr (assoc :numeric-description data)))
878 (point-form
879 (format nil "SRID=4326; POINT(~S ~S ~S)"
880 longitude latitude ellipsoid-height))
881 (aux-numeric-raw (cdr (assoc :aux-numeric data)))
882 (aux-text-raw (cdr (assoc :aux-text data)))
883 (aux-numeric (if aux-numeric-raw
884 (nullify-nil (apply #'vector aux-numeric-raw))
885 :null))
886 (aux-text (if aux-text-raw
887 (nullify-nil (apply #'vector aux-text-raw))
888 :null))
889 (user-point-table-name
890 (user-point-table-name presentation-project-name)))
891 (assert
892 (not (string-equal user-role "read")) ;that is, "write" or "admin"
893 () "No write permission.")
894 (with-connection *postgresql-credentials*
895 (assert
896 (= 1 (execute (:insert-into user-point-table-name :set
897 'user-id user-id
898 'kind kind
899 'description description
900 'numeric-description numeric-description
901 'creation-date 'current-timestamp
902 'coordinates (:st_geomfromewkt point-form)
903 ;; 'stdx-global stdx-global
904 ;; 'stdy-global stdy-global
905 ;; 'stdz-global stdz-global
906 'input-size input-size
907 'aux-numeric aux-numeric
908 'aux-text aux-text)))
909 () "No point stored. This should not happen."))))
910
911 (hunchentoot:define-easy-handler
912 (update-point :uri "/phoros/lib/update-point" :default-request-type :post)
913 ()
914 "Update point sent by user in database."
915 (assert-authentication)
916 (let* ((presentation-project-name (hunchentoot:session-value
917 'presentation-project-name))
918 (user-id (hunchentoot:session-value 'user-id))
919 (user-role (hunchentoot:session-value 'user-role))
920 (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
921 (user-point-id (cdr (assoc :user-point-id data)))
922 (kind (cdr (assoc :kind data)))
923 (description (cdr (assoc :description data)))
924 (numeric-description (cdr (assoc :numeric-description data)))
925 (user-point-table-name
926 (user-point-table-name presentation-project-name)))
927 (assert
928 (not (string-equal user-role "read")) ;that is, "write" or "admin"
929 () "No write permission.")
930 (with-connection *postgresql-credentials*
931 (assert
932 (= 1 (execute
933 (:update user-point-table-name :set
934 'user-id user-id
935 'kind kind
936 'description description
937 'numeric-description numeric-description
938 'creation-date 'current-timestamp
939 :where (:and (:= 'user-point-id user-point-id)
940 (:or (:= (if (string-equal user-role
941 "admin")
942 user-id
943 'user-id)
944 user-id)
945 (:is-null 'user-id)
946 (:exists
947 (:select 'user-name
948 :from 'sys-user
949 :where (:= 'user-id
950 user-id))))))))
951 () "No point stored. Did you try to update someone else's point ~
952 without having admin permission?"))))
953
954 (defun increment-numeric-string (text)
955 "Increment rightmost numeric part of text if any; otherwise append a
956 three-digit numeric part."
957 (let* ((end-of-number
958 (1+ (or (position-if #'digit-char-p text :from-end t)
959 (1- (length text)))))
960 (start-of-number
961 (1+ (or (position-if-not #'digit-char-p text :from-end t
962 :end end-of-number)
963 -1)))
964 (width-of-number (- end-of-number start-of-number))
965 (prefix-text (subseq text 0 start-of-number))
966 (suffix-text (subseq text end-of-number)))
967 (when (zerop width-of-number)
968 (setf width-of-number 3))
969 (format nil "~A~V,'0D~A"
970 prefix-text
971 width-of-number
972 (1+ (or (ignore-errors
973 (parse-integer
974 text
975 :start start-of-number :end end-of-number))
976 0))
977 suffix-text)))
978
979 (hunchentoot:define-easy-handler
980 (uniquify-point-attributes :uri "/phoros/lib/uniquify-point-attributes"
981 :default-request-type :post)
982 ()
983 "Check if received set of point-attributes are unique. If so,
984 return null; otherwise return (as a suggestion) a uniquified version
985 of point-attributes by modifying element numeric-description."
986 (assert-authentication)
987 (setf (hunchentoot:content-type*) "application/json")
988 (let* ((presentation-project-name (hunchentoot:session-value
989 'presentation-project-name))
990 (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
991 (user-point-id (cdr (assoc :user-point-id data)))
992 (kind (cdr (assoc :kind data)))
993 (description (cdr (assoc :description data)))
994 (numeric-description (cdr (assoc :numeric-description data)))
995 (user-point-table-name
996 (user-point-table-name presentation-project-name)))
997 (flet ((uniquep (user-point-id kind description numeric-description)
998 "Check if given set of user-point attributes will be
999 unique in database"
1000 (not
1001 (if user-point-id
1002 (query
1003 (:select
1004 (:exists
1005 (:select
1006 '*
1007 :from user-point-table-name
1008 :where (:and (:!= 'user-point-id user-point-id)
1009 (:= 'kind kind)
1010 (:= 'description description)
1011 (:= 'numeric-description
1012 numeric-description)))))
1013 :single!)
1014 (query
1015 (:select
1016 (:exists
1017 (:select
1018 '*
1019 :from user-point-table-name
1020 :where (:and (:= 'kind kind)
1021 (:= 'description description)
1022 (:= 'numeric-description
1023 numeric-description)))))
1024 :single!)))))
1025 (with-connection *postgresql-credentials*
1026 (json:encode-json-to-string
1027 (unless (uniquep
1028 user-point-id kind description numeric-description)
1029 (loop
1030 for s = numeric-description
1031 then (increment-numeric-string s)
1032 until (uniquep user-point-id kind description s)
1033 finally
1034 (setf (cdr (assoc :numeric-description data))
1035 s)
1036 (return data))))))))
1037
1038 (hunchentoot:define-easy-handler
1039 (delete-point :uri "/phoros/lib/delete-point" :default-request-type :post)
1040 ()
1041 "Delete user point if user is allowed to do so."
1042 (assert-authentication)
1043 (let* ((presentation-project-name (hunchentoot:session-value
1044 'presentation-project-name))
1045 (user-id (hunchentoot:session-value 'user-id))
1046 (user-role (hunchentoot:session-value 'user-role))
1047 (user-point-table-name
1048 (user-point-table-name presentation-project-name))
1049 (data (json:decode-json-from-string (hunchentoot:raw-post-data))))
1050 (with-connection *postgresql-credentials*
1051 (assert
1052 (eql 1 (cond ((string-equal user-role "admin")
1053 (execute (:delete-from user-point-table-name
1054 :where (:= 'user-point-id data))))
1055 ((string-equal user-role "write")
1056 (execute
1057 (:delete-from
1058 user-point-table-name
1059 :where (:and
1060 (:= 'user-point-id data)
1061 (:or (:= 'user-id user-id)
1062 (:is-null 'user-id)
1063 (:exists
1064 (:select 'user-name
1065 :from 'sys-user
1066 :where (:= 'user-id
1067 user-id))))))))))
1068 () "No point deleted. This should not happen."))))
1069
1070 (defun common-table-names (presentation-project-id)
1071 "Return a list of common-table-names of table sets that contain data
1072 of presentation project with presentation-project-id."
1073 (handler-case
1074 (query
1075 (:select 'common-table-name
1076 :distinct
1077 :from 'sys-presentation 'sys-measurement 'sys-acquisition-project
1078 :where (:and
1079 (:= 'sys-presentation.presentation-project-id
1080 presentation-project-id)
1081 (:= 'sys-presentation.measurement-id
1082 'sys-measurement.measurement-id)
1083 (:= 'sys-measurement.acquisition-project-id
1084 'sys-acquisition-project.acquisition-project-id)))
1085 :column)
1086 (condition (c)
1087 (cl-log:log-message
1088 :error
1089 "While fetching common-table-names of presentation-project-id ~D: ~A"
1090 presentation-project-id c))))
1091
1092 (defun encode-geojson-to-string (features &key junk-keys)
1093 "Encode a list of property lists into a GeoJSON FeatureCollection.
1094 Each property list must contain keys for coordinates, :x, :y, :z; it
1095 may contain a numeric point :id and zero or more pieces of extra
1096 information. The extra information is stored as GeoJSON Feature
1097 properties. Exclude property list elements with keys that are in
1098 junk-keys."
1099 (with-output-to-string (s)
1100 (json:with-object (s)
1101 (json:encode-object-member :type :*feature-collection s)
1102 (json:as-object-member (:features s)
1103 (json:with-array (s)
1104 (mapcar
1105 #'(lambda (point-with-properties)
1106 (dolist (junk-key junk-keys)
1107 (remf point-with-properties junk-key))
1108 (destructuring-bind (&key x y z id &allow-other-keys) ;TODO: z probably bogus
1109 point-with-properties
1110 (json:as-array-member (s)
1111 (json:with-object (s)
1112 (json:encode-object-member :type :*feature s)
1113 (json:as-object-member (:geometry s)
1114 (json:with-object (s)
1115 (json:encode-object-member :type :*point s)
1116 (json:as-object-member (:coordinates s)
1117 (json:encode-json (list x y z) s))))
1118 (json:encode-object-member :id id s)
1119 (json:as-object-member (:properties s)
1120 (dolist (key '(:x :y :z :id))
1121 (remf point-with-properties key))
1122 (json:encode-json-plist point-with-properties s))))))
1123 features)))
1124 (json:encode-object-member :phoros-version (phoros-version) s))))
1125
1126 (defun box3d (bbox)
1127 "Return a WKT-compliant BOX3D string from string bbox."
1128 (concatenate 'string "BOX3D("
1129 (substitute #\Space #\,
1130 (substitute #\Space #\, bbox :count 1)
1131 :from-end t :count 1)
1132 ")"))
1133
1134 (hunchentoot:define-easy-handler (points :uri "/phoros/lib/points.json") (bbox)
1135 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
1136 (assert-authentication)
1137 (setf (hunchentoot:content-type*) "application/json")
1138 (handler-case
1139 (with-connection *postgresql-credentials*
1140 (let* ((presentation-project-id
1141 (hunchentoot:session-value 'presentation-project-id))
1142 (common-table-names
1143 (common-table-names presentation-project-id)))
1144 (encode-geojson-to-string
1145 (query
1146 (sql-compile
1147 `(:limit
1148 (:order-by
1149 (:union
1150 ,@(loop
1151 for common-table-name in common-table-names
1152 for aggregate-view-name
1153 = (point-data-table-name common-table-name)
1154 ;; would have been nice, was too slow:
1155 ;; = (aggregate-view-name common-table-name)
1156 collect
1157 `(:select
1158 (:as (:st_x 'coordinates) x)
1159 (:as (:st_y 'coordinates) y)
1160 (:as (:st_z 'coordinates) z)
1161 (:as 'point-id 'id) ;becomes fid on client
1162 'random
1163 :distinct-on 'random
1164 :from ',aggregate-view-name
1165 :natural :left-join 'sys-presentation
1166 :where
1167 (:and
1168 (:= 'presentation-project-id
1169 ,presentation-project-id)
1170 (:&&
1171 'coordinates
1172 (:st_setsrid (:type ,(box3d bbox) box3d)
1173 ,*standard-coordinates*))))))
1174 random)
1175 ,*number-of-features-per-layer*))
1176 :plists)
1177 :junk-keys '(:random))))
1178 (condition (c)
1179 (cl-log:log-message
1180 :error "While fetching points from inside bbox ~S: ~A"
1181 bbox c))))
1182
1183 (hunchentoot:define-easy-handler
1184 (aux-points :uri "/phoros/lib/aux-points.json")
1185 (bbox)
1186 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
1187 (assert-authentication)
1188 (setf (hunchentoot:content-type*) "application/json")
1189 (handler-case
1190 (let ((limit *number-of-features-per-layer*)
1191 (aux-view-name
1192 (aux-point-view-name (hunchentoot:session-value
1193 'presentation-project-name))))
1194 (encode-geojson-to-string
1195 (with-connection *postgresql-aux-credentials*
1196 (query
1197 (s-sql:sql-compile
1198 `(:limit
1199 (:order-by
1200 (:select
1201 (:as (:st_x 'coordinates) 'x)
1202 (:as (:st_y 'coordinates) 'y)
1203 (:as (:st_z 'coordinates) 'z)
1204 :from ,aux-view-name
1205 :where (:&&
1206 'coordinates
1207 (:st_setsrid (:type ,(box3d bbox) box3d)
1208 ,*standard-coordinates*)))
1209 (:random))
1210 ,limit))
1211 :plists))))
1212 (condition (c)
1213 (cl-log:log-message
1214 :error "While fetching aux-points from inside bbox ~S: ~A"
1215 bbox c))))
1216
1217 (hunchentoot:define-easy-handler
1218 (aux-local-data :uri "/phoros/lib/aux-local-data"
1219 :default-request-type :post)
1220 ()
1221 "Receive coordinates, respond with the count nearest json objects
1222 containing arrays aux-numeric, aux-text, and distance to the
1223 coordinates received, wrapped in an array."
1224 (assert-authentication)
1225 (setf (hunchentoot:content-type*) "application/json")
1226 (let* ((aux-view-name
1227 (aux-point-view-name (hunchentoot:session-value
1228 'presentation-project-name)))
1229 (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
1230 (longitude (cdr (assoc :longitude data)))
1231 (latitude (cdr (assoc :latitude data)))
1232 (count (cdr (assoc :count data)))
1233 (point-form
1234 (format nil "POINT(~F ~F)" longitude latitude))
1235 (snap-distance 1e-3) ;about 100 m, TODO: make this a defparameter
1236 (bounding-box
1237 (format nil "~A,~A,~A,~A"
1238 (- longitude snap-distance)
1239 (- latitude snap-distance)
1240 (+ longitude snap-distance)
1241 (+ latitude snap-distance))))
1242 (encode-geojson-to-string
1243 (ignore-errors
1244 (with-connection *postgresql-aux-credentials*
1245 (nillify-null
1246 (query
1247 (s-sql:sql-compile
1248 `(:limit
1249 (:order-by
1250 (:select
1251 (:as (:st_x 'coordinates) 'x)
1252 (:as (:st_y 'coordinates) 'y)
1253 (:as (:st_z 'coordinates) 'z)
1254 aux-numeric
1255 aux-text
1256 (:as
1257 (:st_distance
1258 (:st_transform
1259 'coordinates
1260 ,*spherical-mercator*)
1261 (:st_transform
1262 (:st_geomfromtext ,point-form ,*standard-coordinates*)
1263 ,*spherical-mercator*))
1264 distance)
1265 :from ',aux-view-name
1266 :where (:&& 'coordinates
1267 (:st_setsrid (:type
1268 ,(box3d bounding-box) box3d)
1269 ,*standard-coordinates*)))
1270 'distance)
1271 ,count))
1272 :plists)))))))
1273
1274 (defun nillify-null (x)
1275 "Replace occurences of :null in nested sequence x by nil."
1276 (cond ((eq :null x) nil)
1277 ((stringp x) x)
1278 ((numberp x) x)
1279 ((symbolp x) x)
1280 (t (map (type-of x) #'nillify-null x))))
1281
1282 (defun nullify-nil (x)
1283 "Replace occurences of nil in nested sequence x by :null."
1284 (cond ((null x) :null)
1285 ((stringp x) x)
1286 ((numberp x) x)
1287 ((symbolp x) x)
1288 (t (map (type-of x) #'nullify-nil x))))
1289
1290 (hunchentoot:define-easy-handler
1291 (aux-local-linestring :uri "/phoros/lib/aux-local-linestring.json"
1292 :default-request-type :post)
1293 ()
1294 "Receive longitude, latitude, radius, and step-size; respond
1295 with a JSON object comprising the elements linestring (a WKT
1296 linestring stitched together of the nearest auxiliary points from
1297 within radius around coordinates), current-point (the point on
1298 linestring closest to coordinates), and previous-point and next-point
1299 \(points on linestring step-size before and after current-point
1300 respectively). Wipe away any unfinished business first."
1301 (assert-authentication)
1302 (dolist (old-thread (hunchentoot:session-value 'recent-threads))
1303 (ignore-errors
1304 (bt:interrupt-thread old-thread
1305 #'(lambda () (signal 'superseded)))))
1306 (setf (hunchentoot:session-value 'recent-threads) nil)
1307 (setf (hunchentoot:session-value 'number-of-threads) 1)
1308 (push (bt:current-thread) (hunchentoot:session-value 'recent-threads))
1309 (setf (hunchentoot:content-type*) "application/json")
1310 (handler-case
1311 (let* ((thread-aux-points-function-name
1312 (thread-aux-points-function-name (hunchentoot:session-value
1313 'presentation-project-name)))
1314 (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
1315 (longitude (cdr (assoc :longitude data)))
1316 (latitude (cdr (assoc :latitude data)))
1317 (radius (cdr (assoc :radius data)))
1318 (step-size (cdr (assoc :step-size data)))
1319 (azimuth (if (numberp (cdr (assoc :azimuth data)))
1320 (cdr (assoc :azimuth data))
1321 0))
1322 (point-form
1323 (format nil "POINT(~F ~F)" longitude latitude))
1324 (sql-response
1325 (ignore-errors
1326 (with-connection *postgresql-aux-credentials*
1327 (nillify-null
1328 (query
1329 (sql-compile
1330 `(:select '* :from
1331 (,thread-aux-points-function-name
1332 (:st_geomfromtext
1333 ,point-form ,*standard-coordinates*)
1334 ,radius
1335 ,*number-of-points-per-aux-linestring*
1336 ,step-size
1337 ,azimuth
1338 ,(proj:degrees-to-radians 91))))
1339 :plist))))))
1340 (with-output-to-string (s)
1341 (json:with-object (s)
1342 (json:encode-object-member
1343 :linestring (getf sql-response :threaded-points) s)
1344 (json:encode-object-member
1345 :current-point (getf sql-response :current-point) s)
1346 (json:encode-object-member
1347 :previous-point (getf sql-response :back-point) s)
1348 (json:encode-object-member
1349 :next-point (getf sql-response :forward-point) s)
1350 (json:encode-object-member
1351 :azimuth (getf sql-response :new-azimuth) s))))
1352 (superseded ()
1353 ;; (setf (hunchentoot:return-code*) hunchentoot:+http-gateway-time-out+)
1354 nil)))
1355
1356 (defun get-user-points (user-point-table-name &key
1357 (bounding-box "-180,-90,180,90")
1358 (limit :null)
1359 (order-criterion 'id)
1360 indent)
1361 "Return limit points from user-point-table-name in GeoJSON format,
1362 and the number of points returned."
1363 (let ((user-point-plist
1364 (query
1365 (s-sql:sql-compile
1366 `(:limit
1367 (:order-by
1368 (:select
1369 (:as (:st_x 'coordinates) 'x)
1370 (:as (:st_y 'coordinates) 'y)
1371 (:as (:st_z 'coordinates) 'z)
1372 (:as 'user-point-id 'id) ;becomes fid in OpenLayers
1373 ;; 'stdx-global 'stdy-global 'stdz-global
1374 'input-size
1375 'kind 'description 'numeric-description
1376 'user-name
1377 (:as (:to-char 'creation-date
1378 ,*user-point-creation-date-format*)
1379 'creation-date)
1380 'aux-numeric 'aux-text
1381 :from ,user-point-table-name :natural :left-join 'sys-user
1382 :where (:&& 'coordinates
1383 (:st_setsrid (:type ,(box3d bounding-box) box3d)
1384 ,*standard-coordinates*)))
1385 ,order-criterion)
1386 ,limit))
1387 :plists)))
1388 (values
1389 (if indent
1390 (indent-json
1391 (encode-geojson-to-string (nillify-null user-point-plist)))
1392 (encode-geojson-to-string (nillify-null user-point-plist)))
1393 (length user-point-plist))))
1394
1395 (hunchentoot:define-easy-handler
1396 (user-points :uri "/phoros/lib/user-points.json")
1397 (bbox)
1398 "Send *number-of-features-per-layer* randomly chosen GeoJSON-encoded
1399 points from inside bbox to client. If there is no bbox parameter,
1400 send all points and indent GeoJSON to make it more readable."
1401 (assert-authentication)
1402 (setf (hunchentoot:content-type*) "application/json")
1403 (handler-case
1404 (let ((bounding-box (or bbox "-180,-90,180,90"))
1405 (indent (not bbox))
1406 (limit (if bbox *number-of-features-per-layer* :null))
1407 (order-criterion (if bbox '(:random) 'id))
1408 (user-point-table-name
1409 (user-point-table-name (hunchentoot:session-value
1410 'presentation-project-name))))
1411 (with-connection *postgresql-credentials*
1412 (nth-value 0 (get-user-points user-point-table-name
1413 :bounding-box bounding-box
1414 :limit limit
1415 :order-criterion order-criterion
1416 :indent indent))))
1417 (condition (c)
1418 (cl-log:log-message
1419 :error "While fetching user-points~@[ from inside bbox ~S~]: ~A"
1420 bbox c))))
1421
1422 (hunchentoot:define-easy-handler
1423 (user-point-attributes :uri "/phoros/lib/user-point-attributes.json")
1424 ()
1425 "Send JSON object comprising arrays kinds and descriptions,
1426 each containing unique values called kind and description
1427 respectively, and count being the frequency of value in the user point
1428 table."
1429 (assert-authentication)
1430 (setf (hunchentoot:content-type*) "application/json")
1431 (handler-case
1432 (let ((user-point-table-name
1433 (user-point-table-name (hunchentoot:session-value
1434 'presentation-project-name))))
1435 (with-connection *postgresql-credentials*
1436 (with-output-to-string (s)
1437 (json:with-object (s)
1438 (json:as-object-member (:descriptions s)
1439 (json:with-array (s)
1440 (mapcar #'(lambda (x) (json:as-array-member (s)
1441 (json:encode-json-plist x s)))
1442 (query
1443 (:limit
1444 (:order-by
1445 (:select 'description
1446 (:count 'description)
1447 :from user-point-table-name
1448 :group-by 'description)
1449 'description)
1450 100)
1451 :plists))))
1452 (json:as-object-member (:kinds s)
1453 (json:with-array (s)
1454 (mapcar #'(lambda (x) (json:as-array-member (s)
1455 (json:encode-json-plist x s)))
1456 (query (format nil "~
1457 (SELECT kind, count(kind) ~
1458 FROM ((SELECT kind FROM ~A) ~
1459 UNION ALL ~
1460 (SELECT kind ~
1461 FROM (VALUES ('solitary'), ~
1462 ('polyline'), ~
1463 ('polygon')) ~
1464 AS defaults(kind))) ~
1465 AS kinds_union(kind) ~
1466 GROUP BY kind) ~
1467 ORDER BY kind LIMIT 100"
1468 ;; Counts of solitary,
1469 ;; polyline, polygon may be
1470 ;; too big by one if we
1471 ;; collect them like this.
1472 (s-sql:to-sql-name user-point-table-name))
1473 :plists))))))))
1474 (condition (c)
1475 (cl-log:log-message
1476 :error "While fetching user-point-attributes: ~A"
1477 c))))
1478
1479 (hunchentoot:define-easy-handler photo-handler
1480 ((bayer-pattern :init-form "65280,16711680")
1481 (color-raiser :init-form "1,1,1")
1482 (mounting-angle :init-form "0")
1483 brightenp)
1484 "Serve an image from a .pictures file."
1485 (assert-authentication)
1486 (handler-case
1487 (prog2
1488 (progn
1489 (push (bt:current-thread)
1490 (hunchentoot:session-value 'recent-threads))
1491 (incf (hunchentoot:session-value 'number-of-threads)))
1492 (let* ((s
1493 (cl-utilities:split-sequence #\/
1494 (hunchentoot:script-name*)
1495 :remove-empty-subseqs t))
1496 (directory
1497 (cdddr ;remove leading phoros, lib, photo
1498 (butlast s 2)))
1499 (file-name-and-type
1500 (cl-utilities:split-sequence #\. (first (last s 2))))
1501 (byte-position
1502 (parse-integer (car (last s)) :junk-allowed t))
1503 (path-to-file
1504 (car
1505 (directory
1506 (make-pathname
1507 :directory (append (pathname-directory *common-root*)
1508 directory
1509 '(:wild-inferiors))
1510 :name (first file-name-and-type)
1511 :type (second file-name-and-type)))))
1512 (result
1513 (flex:with-output-to-sequence (stream)
1514 (img:send-png
1515 stream path-to-file byte-position
1516 :bayer-pattern
1517 (apply #'vector (mapcar
1518 #'parse-integer
1519 (cl-utilities:split-sequence
1520 #\, bayer-pattern)))
1521 :color-raiser
1522 (apply #'vector (mapcar
1523 #'parse-number:parse-positive-real-number
1524 (cl-utilities:split-sequence
1525 #\,
1526 color-raiser)))
1527 :reversep (= 180 (parse-integer mounting-angle))
1528 :brightenp brightenp))))
1529 (setf (hunchentoot:header-out 'cache-control)
1530 (format nil "max-age=~D" *browser-cache-max-age*))
1531 (setf (hunchentoot:content-type*) "image/png")
1532 result)
1533 (decf (hunchentoot:session-value 'number-of-threads)))
1534 (superseded ()
1535 (setf (hunchentoot:return-code*) hunchentoot:+http-gateway-time-out+)
1536 nil)
1537 (condition (c)
1538 (cl-log:log-message
1539 :error "While serving image ~S: ~A" (hunchentoot:request-uri*) c))))
1540
1541 (pushnew (hunchentoot:create-prefix-dispatcher "/phoros/lib/photo"
1542 'photo-handler)
1543 hunchentoot:*dispatch-table*)
1544
1545 ;;; for debugging; this is the multi-file OpenLayers
1546 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1547 "/phoros/lib/openlayers/" "OpenLayers-2.10/")
1548 hunchentoot:*dispatch-table*)
1549
1550 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1551 "/phoros/lib/ol/" "ol/")
1552 hunchentoot:*dispatch-table*)
1553
1554 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1555 "/phoros/lib/public_html/" "public_html/")
1556 hunchentoot:*dispatch-table*)
1557
1558 (pushnew (hunchentoot:create-static-file-dispatcher-and-handler
1559 "/favicon.ico" "public_html/favicon.ico")
1560 hunchentoot:*dispatch-table*)
1561
1562 (hunchentoot:define-easy-handler
1563 (view :uri (format nil "/phoros/lib/view-~A" (phoros-version))
1564 :default-request-type :post)
1565 ()
1566 "Serve the client their main workspace."
1567 (if
1568 (hunchentoot:session-value 'authenticated-p)
1569 (who:with-html-output-to-string (s nil :prologue t :indent t)
1570 (:html
1571 (:head
1572 (:title (who:str
1573 (concatenate
1574 'string
1575 "Phoros: " (hunchentoot:session-value
1576 'presentation-project-name))))
1577 (if (cli:verbosity-level :use-multi-file-openlayers)
1578 (who:htm
1579 (:script
1580 :src (format nil "/~A/lib/openlayers/lib/Firebug/firebug.js"
1581 *proxy-root*))
1582 (:script
1583 :src (format nil "/~A/lib/openlayers/lib/OpenLayers.js"
1584 *proxy-root*)))
1585 (who:htm
1586 (:script
1587 :src (format nil "/~A/lib/ol/OpenLayers.js"
1588 *proxy-root*))))
1589 (:link :rel "stylesheet"
1590 :href (format nil "/~A/lib/css-~A/style.css"
1591 *proxy-root*
1592 (phoros-version))
1593 :type "text/css")
1594 (:script :src (format ;variability in script name is
1595 nil ; supposed to fight browser cache
1596 "/~A/lib/phoros-~A-~A-~A.js"
1597 *proxy-root*
1598 (phoros-version)
1599 (hunchentoot:session-value 'user-name)
1600 (hunchentoot:session-value 'presentation-project-name)))
1601 (:script :src "http://maps.google.com/maps/api/js?sensor=false"))
1602 (:body
1603 :onload (ps (init))
1604 (:noscript (:b (:em "You can't do much without JavaScript here.")))
1605 ;; main header line
1606 (:h1 :id "title"
1607 "Phoros: " (who:str (hunchentoot:session-value 'user-full-name))
1608 (who:fmt " (~A)" (hunchentoot:session-value 'user-name))
1609 "with " (:span :id "user-role"
1610 (who:str (hunchentoot:session-value 'user-role)))
1611 "permission on "
1612 (:span :id "presentation-project-name"
1613 (who:str (hunchentoot:session-value
1614 'presentation-project-name)))
1615 (:span :id "presentation-project-emptiness")
1616 (:span :id "recommend-fresh-login")
1617 (:span :class "h1-right"
1618 (:span :id "caching-indicator")
1619 (:span :id "phoros-version"
1620 (who:fmt "v~A" (phoros-version)))))
1621 ;; streetmap area (northwest)
1622 (:div
1623 :class "controlled-streetmap"
1624 (:div :id "streetmap" :class "streetmap" :style "cursor:crosshair")
1625 (:div :id "streetmap-controls" :class "streetmap-controls"
1626 (:div :id "streetmap-vertical-strut"
1627 :class "streetmap-vertical-strut")
1628 (:div :id "streetmap-layer-switcher"
1629 :class "streetmap-layer-switcher")
1630 (:button :id "unselect-all-restrictions-button"
1631 :type "button"
1632 :onclick (ps-inline (unselect-all-restrictions))
1633 "clear" :br "all")
1634 (:select :id "restriction-select"
1635 :name "restriction-select"
1636 :size 3
1637 :multiple t
1638 :onchange (ps-inline (request-photos)))
1639 (:div :id "streetmap-overview" :class "streetmap-overview")
1640 (:div :id "streetmap-mouse-position"
1641 :class "streetmap-mouse-position")
1642 (:div :id "streetmap-zoom" :class "streetmap-zoom")))
1643 ;; control area (north)
1644 (:div
1645 :class "phoros-controls" :id "phoros-controls"
1646 (:div :id "real-phoros-controls"
1647 (:h2 :class "point-creator h2-phoros-controls"
1648 "Create Point")
1649 (:h2 :class "point-editor h2-phoros-controls"
1650 "Edit Point"
1651 (:span :id "creator"))
1652 (:h2 :class "point-viewer h2-phoros-controls"
1653 "View Point"
1654 (:span :id "creator"))
1655 (:h2 :class "aux-data-viewer h2-phoros-controls"
1656 "View Auxiliary Data")
1657 (:h2 :class "multiple-points-viewer"
1658 "Multiple Points Selected")
1659 (:div :class "multiple-points-viewer"
1660 (:p "You have selected multiple user points.")
1661 (:p "Unselect all but one to edit or view its properties."))
1662 (:span :class "point-creator point-editor point-viewer"
1663 (:div
1664 :id "point-kind"
1665 :class "combobox"
1666 (:select
1667 :id "point-kind-select"
1668 :name "point-kind-select"
1669 :class "combobox-select write-permission-dependent"
1670 :onchange (ps-inline
1671 (consolidate-combobox
1672 "point-kind"))
1673 :disabled t)
1674 (:input
1675 :id "point-kind-input"
1676 :name "point-kind-input"
1677 :class "combobox-input write-permission-dependent"
1678 :onchange (ps-inline
1679 (unselect-combobox-selection
1680 "point-kind"))
1681 :disabled t
1682 :type "text"))
1683 (:input :id "point-numeric-description"
1684 :class "vanilla-input write-permission-dependent"
1685 :disabled t
1686 :type "text" :name "point-numeric-description")
1687
1688 (:div
1689 :id "point-description"
1690 :class "combobox"
1691 (:select
1692 :id "point-description-select"
1693 :name "point-description-select"
1694 :class "combobox-select write-permission-dependent"
1695 :onchange (ps-inline
1696 (consolidate-combobox
1697 "point-description"))
1698 :disabled t)
1699 (:input
1700 :id "point-description-input"
1701 :name "point-description-input"
1702 :class "combobox-input write-permission-dependent"
1703 :onchange (ps-inline
1704 (unselect-combobox-selection
1705 "point-description"))
1706 :disabled t
1707 :type "text"))
1708 (:button :id "delete-point-button" :disabled t
1709 :type "button"
1710 :onclick (ps-inline (delete-point))
1711 "del")
1712 (:button :disabled t :id "finish-point-button"
1713 :type "button"
1714 (:b "finish"))
1715 (:div :id "uniquify-buttons"
1716 (:button :id "suggest-unique-button"
1717 :type "button"
1718 :onclick (ps-inline
1719 (insert-unique-suggestion))
1720 (:b "suggest"))
1721 (:button :id "force-duplicate-button"
1722 :type "button"
1723 "push")))
1724 (:div :id "aux-point-distance-or-point-creation-date"
1725 (:code :id "point-creation-date"
1726 :class "point-editor point-viewer")
1727 (:select
1728 :id "aux-point-distance" :disabled t
1729 :class "point-creator aux-data-viewer aux-data-dependent"
1730 :size 1 :name "aux-point-distance"
1731 :onchange (ps-inline
1732 (aux-point-distance-selected))
1733 :onclick (ps-inline
1734 (enable-aux-point-selection)))
1735 (:div
1736 :id "include-aux-data"
1737 :class "point-creator aux-data-dependent"
1738 (:label
1739 (:input :id "include-aux-data-p"
1740 :class "tight-input"
1741 :type "checkbox" :checked t
1742 :name "include-aux-data-p"
1743 :onchange (ps-inline
1744 (flip-aux-data-inclusion)))
1745 "aux data"))
1746 (:div :id "display-nearest-aux-data"
1747 :class "aux-data-viewer"
1748 (:label
1749 (:input :id "display-nearest-aux-data-p"
1750 :class "tight-input"
1751 :type "checkbox" :checked t
1752 :name "display-nearest-aux-data-p"
1753 :onchange (ps-inline
1754 (flip-nearest-aux-data-display)))
1755 "display")))
1756 (:div
1757 :id "aux-data"
1758 :class "point-creator point-editor point-viewer aux-data-viewer"
1759 (:div :id "aux-numeric-list")
1760 (:div :id "aux-text-list")))
1761 (:div :class "walk-mode-controls"
1762 (:div :id "walk-mode"
1763 :class "aux-data-dependent"
1764 (:input :id "walk-p"
1765 :class "tight-input"
1766 :type "checkbox" :checked nil
1767 :onchange (ps-inline
1768 (flip-walk-mode)))
1769 (:label :for "walk-p"
1770 "snap+walk"))
1771 (:div :id "decrease-step-size"
1772 :class "aux-data-dependent"
1773 :onclick (ps-inline (decrease-step-size)))
1774 (:div :id "step-size"
1775 :class "aux-data-dependent"
1776 :onclick (ps-inline (increase-step-size))
1777 "4")
1778 (:div :id "increase-step-size"
1779 :class "aux-data-dependent"
1780 :onclick (ps-inline (increase-step-size))
1781 :ondblclick (ps-inline (increase-step-size)
1782 (increase-step-size)))
1783 (:div :id "step-button" :disabled nil
1784 :class "aux-data-dependent"
1785 :onclick (ps-inline (step))
1786 :ondblclick (ps-inline (step t))
1787 "step"))
1788 (:div :class "image-main-controls"
1789 (:div :id "auto-zoom"
1790 (:input :id "zoom-to-point-p"
1791 :class "tight-input"
1792 :type "checkbox" :checked t)
1793 (:label :for "zoom-to-point-p"
1794 "auto"))
1795 (:div :id "brighten-images"
1796 (:input :id "brighten-images-p"
1797 :class "tight-input"
1798 :type "checkbox" :checked nil)
1799 (:label :for "brighten-images-p"
1800 "bright"))
1801 (:div :id "zoom-images-to-max-extent"
1802 :onclick (ps-inline (zoom-images-to-max-extent)))
1803 (:div :id "no-footprints-p"
1804 (:b "?"))
1805 (:div :id "remove-work-layers-button" :disabled t
1806 :onclick (ps-inline (reset-layers-and-controls))
1807 "restart")))
1808 ;; help area (northeast)
1809 (:div
1810 :class "help-div"
1811 (:button
1812 :id "download-user-points-button"
1813 :type "button"
1814 :onclick (format nil
1815 "self.location.href = \"/~A/lib/user-points.json\""
1816 *proxy-root*)
1817 "download points") ;TODO: offer other formats and maybe projections
1818 (:button
1819 :id "blurb-button"
1820 :type "button"
1821 :onclick (ps-inline
1822 (chain window
1823 (open
1824 (+ "/"
1825 +proxy-root+
1826 "/lib/blurb?openlayers-version="
1827 (@ *open-layers *version_number*))
1828 "About Phoros")))
1829 (:img :src (format nil "/~A/lib/public_html/phoros-logo-plain.png"
1830 *proxy-root*)
1831 :alt "Phoros" :style "vertical-align:middle"
1832 :height 20))
1833 (:button :id "logout-button"
1834 :type "button"
1835 :onclick (ps-inline (bye))
1836 "bye")
1837 (:h2 :id "h2-help" "Help")
1838 (:div :id "help-display"))
1839 ;; image area (south)
1840 (:div :id "images" :style "clear:both"
1841 (loop
1842 for i from 0 below *number-of-images* do
1843 (who:htm
1844 (:div :class "controlled-image"
1845 (:div :id (format nil "image-~S-controls" i)
1846 :class "image-controls"
1847 (:div :id (format nil "image-~S-zoom" i)
1848 :class "image-zoom")
1849 (:div :id (format nil "image-~S-layer-switcher" i)
1850 :class "image-layer-switcher")
1851 (:div :id (format nil "image-~S-usable" i)
1852 :class "image-usable"
1853 (:b "!"))
1854 (:div :id (format nil "image-~S-trigger-time" i)
1855 :class "image-trigger-time"))
1856 (:div :id (format nil "image-~S" i)
1857 :class "image" :style "cursor:crosshair"))))))))
1858 (hunchentoot:redirect
1859 (format nil "/~A/~A"
1860 *proxy-root*
1861 (hunchentoot:session-value 'presentation-project-name))
1862 :add-session-id t)))
1863
1864 (hunchentoot:define-easy-handler
1865 (epipolar-line :uri "/phoros/lib/epipolar-line")
1866 ()
1867 "Receive vector of two sets of picture parameters, the first of
1868 which containing coordinates (m, n) of a clicked point. Respond with a
1869 JSON encoded epipolar-line."
1870 (assert-authentication)
1871 (setf (hunchentoot:content-type*) "application/json")
1872 (let* ((data (json:decode-json-from-string (hunchentoot:raw-post-data))))
1873 (json:encode-json-to-string
1874 (photogrammetry :epipolar-line (first data) (second data)))))
1875
1876 (hunchentoot:define-easy-handler
1877 (estimated-positions :uri "/phoros/lib/estimated-positions")
1878 ()
1879 "Receive a two-part JSON vector comprising (1) a vector containing
1880 sets of picture-parameters with clicked (\"active\") points
1881 stored in :m, :n; and (2) a vector containing sets of
1882 picture-parameters; respond with a JSON encoded two-part vector
1883 comprising (1) a point in global coordinates; and (2) a vector of
1884 image coordinates (m, n) for the global point that correspond to the
1885 images from the received second vector. TODO: report error on bad
1886 data (ex: points too far apart)."
1887 ;; TODO: global-point-for-display should probably contain a proj string in order to make sense of the (cartesian) standard deviations.
1888 (assert-authentication)
1889 (setf (hunchentoot:content-type*) "application/json")
1890 (let* ((data
1891 (json:decode-json-from-string (hunchentoot:raw-post-data)))
1892 (active-point-photo-parameters
1893 (first data))
1894 (number-of-active-points
1895 (length active-point-photo-parameters))
1896 (destination-photo-parameters
1897 (second data))
1898 (cartesian-system
1899 (cdr (assoc :cartesian-system
1900 (first active-point-photo-parameters))))
1901 (global-point-cartesian
1902 (photogrammetry
1903 :multi-position-intersection active-point-photo-parameters))
1904 (global-point-geographic-radians
1905 (proj:cs2cs (list (cdr (assoc :x-global global-point-cartesian))
1906 (cdr (assoc :y-global global-point-cartesian))
1907 (cdr (assoc :z-global global-point-cartesian)))
1908 :source-cs cartesian-system))
1909 (global-point-for-display ;points geographic cs, degrees; std deviations in cartesian cs
1910 (pairlis '(:longitude :latitude :ellipsoid-height
1911 ;; :stdx-global :stdy-global :stdz-global
1912 :input-size)
1913 (list
1914 (proj:radians-to-degrees
1915 (first global-point-geographic-radians))
1916 (proj:radians-to-degrees
1917 (second global-point-geographic-radians))
1918 (third global-point-geographic-radians)
1919 ;; (cdr (assoc :stdx-global global-point-cartesian))
1920 ;; (cdr (assoc :stdy-global global-point-cartesian))
1921 ;; (cdr (assoc :stdz-global global-point-cartesian))
1922 number-of-active-points)))
1923 (image-coordinates
1924 (loop
1925 for i in destination-photo-parameters
1926 collect
1927 (ignore-errors
1928 (photogrammetry :reprojection i global-point-cartesian)))))
1929 (json:encode-json-to-string
1930 (list global-point-for-display image-coordinates))))
1931
1932 (hunchentoot:define-easy-handler
1933 (user-point-positions :uri "/phoros/lib/user-point-positions")
1934 ()
1935 "Receive a two-part JSON vector comprising
1936 - a vector of user-point-id's and
1937 - a vector containing sets of picture-parameters;
1938 respond with a JSON object comprising the elements
1939 - image-points, a vector whose elements
1940 - correspond to the elements of the picture-parameters vector
1941 received and
1942 - are GeoJSON feature collections containing one point (in picture
1943 coordinates) for each user-point-id received;
1944 - user-point-count, the number of user-points we tried to fetch
1945 image-points for."
1946 (assert-authentication)
1947 (setf (hunchentoot:content-type*) "application/json")
1948 (with-connection *postgresql-credentials*
1949 (let* ((user-point-table-name
1950 (user-point-table-name (hunchentoot:session-value
1951 'presentation-project-name)))
1952 (data (json:decode-json-from-string (hunchentoot:raw-post-data)))
1953 (user-point-ids (first data))
1954 (user-point-count (length user-point-ids))
1955 (destination-photo-parameters (second data))
1956 (cartesian-system
1957 (cdr (assoc :cartesian-system
1958 (first destination-photo-parameters)))) ;TODO: in rare cases, coordinate systems of the images shown may differ
1959 (user-points
1960 (query
1961 (:select
1962 (:as (:st_x 'coordinates) 'longitude)
1963 (:as (:st_y 'coordinates) 'latitude)
1964 (:as (:st_z 'coordinates) 'ellipsoid-height)
1965 (:as 'user-point-id 'id) ;becomes fid on client
1966 'kind
1967 'description
1968 'numeric-description
1969 'user-name
1970 (:as (:to-char 'creation-date "IYYY-MM-DD HH24:MI:SS TZ")
1971 'creation-date)
1972 'aux-numeric
1973 'aux-text
1974 :from user-point-table-name :natural :left-join 'sys-user
1975 :where (:in 'user-point-id (:set user-point-ids)))
1976 :plists))
1977 (global-points-cartesian
1978 (loop
1979 for global-point-geographic in user-points
1980 collect
1981 (ignore-errors ;in case no destination-photo-parameters have been sent
1982 (pairlis '(:x-global :y-global :z-global)
1983 (proj:cs2cs
1984 (list
1985 (proj:degrees-to-radians
1986 (getf global-point-geographic :longitude))
1987 (proj:degrees-to-radians
1988 (getf global-point-geographic :latitude))
1989 (getf global-point-geographic :ellipsoid-height))
1990 :destination-cs cartesian-system)))))
1991 (image-coordinates
1992 (loop
1993 for photo-parameter-set in destination-photo-parameters
1994 collect
1995 (encode-geojson-to-string
1996 (loop
1997 for global-point-cartesian in global-points-cartesian
1998 for user-point in user-points
1999 collect
2000 (when (point-within-image-p
2001 (getf user-point :id)
2002 (hunchentoot:session-value 'presentation-project-name)
2003 (cdr (assoc :byte-position photo-parameter-set))
2004 (cdr (assoc :filename photo-parameter-set))
2005 (cdr (assoc :measurement-id photo-parameter-set)))
2006 (ignore-errors
2007 (let ((photo-coordinates
2008 (photogrammetry :reprojection
2009 photo-parameter-set
2010 global-point-cartesian))
2011 (photo-point
2012 user-point))
2013 (setf (getf photo-point :x)
2014 (cdr (assoc :m photo-coordinates)))
2015 (setf (getf photo-point :y)
2016 (cdr (assoc :n photo-coordinates)))
2017 photo-point))))
2018 :junk-keys '(:longitude :latitude :ellipsoid-height)))))
2019 (with-output-to-string (s)
2020 (json:with-object (s)
2021 (json:encode-object-member :user-point-count user-point-count s)
2022 (json:as-object-member (:image-points s)
2023 (json:with-array (s)
2024 (loop for i in image-coordinates do
2025 (json:as-array-member (s) (princ i s))))))))))
2026
2027 (defun point-within-image-p (user-point-id presentation-project-name
2028 byte-position filename measurement-id)
2029 "Return t if either point with user-point-id is inside the footprint
2030 of the image described by byte-position, filename, and measurement-id;
2031 or if that image doesn't have a footprint. Return nil otherwise."
2032 (let* ((user-point-table-name (user-point-table-name
2033 presentation-project-name))
2034 (presentation-project-id (presentation-project-id-from-name
2035 presentation-project-name))
2036 (common-table-names (common-table-names presentation-project-id)))
2037 (query
2038 (sql-compile
2039 `(:union
2040 ,@(loop
2041 for common-table-name in common-table-names
2042 for aggregate-view-name
2043 = (aggregate-view-name common-table-name)
2044 collect
2045 `(:select
2046 t
2047 :from ',aggregate-view-name
2048 :where (:and (:= 'byte-position ,byte-position)
2049 (:= 'filename ,filename)
2050 (:= 'measurement-id ,measurement-id)
2051 (:or (:is-null 'footprint)
2052 (:st_within
2053 (:select 'coordinates
2054 :from ,user-point-table-name
2055 :where (:= 'user-point-id
2056 ,user-point-id))
2057 'footprint)))))))
2058 :single)))
2059
2060 (hunchentoot:define-easy-handler
2061 (multi-position-intersection :uri "/phoros/lib/intersection")
2062 ()
2063 "Receive vector of sets of picture parameters, respond with stuff."
2064 (assert-authentication)
2065 (setf (hunchentoot:content-type*) "application/json")
2066 (let* ((data (json:decode-json-from-string (hunchentoot:raw-post-data))))
2067 (json:encode-json-to-string
2068 (photogrammetry :multi-position-intersection data))))
A Tool for Photogrammetric Road Survey