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