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