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