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