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