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