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