1 ;;; PHOROS -- Photogrammetric Road Survey
2 ;;; Copyright (C) 2010, 2011 Bert Burgemeister
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.
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.
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.
20 (setf *js-target-version
* 1.8)
22 ;;; Debug helpers. TODO: remove them.
23 (defparameter *t
* nil
)
24 (defparameter *tt
* nil
)
26 (cffi:define-foreign-library phoml
27 (:unix
(:or
"./libphoml.so"
28 "./phoml/lib/libphoml.so"))
29 (t (:default
"libphoml")))
31 (defparameter *standard-coordinates
* 4326
32 "EPSG code of the coordinate system that we use for communication.")
34 (defparameter *spherical-mercator
* 900913
35 "EPSG code of the coordinate system used for some distance calculations.")
37 (defvar *postgresql-credentials
* nil
38 "A list: (database user password host &key (port 5432) use-ssl).")
40 (defvar *postgresql-aux-credentials
* nil
41 "A list: (database user password host &key (port 5432) use-ssl).")
43 (defparameter *photogrammetry-mutex
* (bt:make-lock
"photogrammetry"))
45 (setf *read-default-float-format
* 'double-float
)
47 (defparameter *phoros-server
* nil
"Hunchentoot acceptor.")
49 (defparameter *common-root
* nil
50 "Root directory; contains directories of measuring data.")
52 (defparameter *login-intro
* nil
53 "A few friendly words to be shown below the login form.")
55 (defparameter *postgresql-warnings
* nil
56 "If t, show PostgreSQL's WARNINGs and NOTICEs.")
58 (defparameter *use-multi-file-openlayers
* nil
59 "If t, use OpenLayers uncompiled from openlayers/*, which makes
60 debugging easier. Otherwise use a single-file shrunk
63 (defparameter *number-of-images
* 4
64 "Number of photos shown to the HTTP client.")
66 (defparameter *number-of-features-per-layer
* 500
67 "What we think a browser can swallow.")
69 (defparameter *number-of-points-per-aux-linestring
* 500
70 "What we think a browser can swallow.")
72 (defparameter *user-point-creation-date-format
* "IYYY-MM-DD HH24:MI:SS TZ"
73 "SQL date format used for display and GeoJSON export of user points.")
75 (defun phoros-version (&key major minor revision
)
76 "Return version of this program, either one integer part as denoted by
77 the key argument, or the whole dotted string."
78 (let* ((version-string
79 (handler-bind ((warning #'ignore-warnings
))
80 (asdf:component-version
(asdf:find-system
:phoros
))))
82 (mapcar #'parse-integer
83 (cl-utilities:split-sequence
#\. version-string
))))
84 (cond (major (first version-components
))
85 (minor (second version-components
))
86 (revision (third version-components
))
89 (defun check-dependencies ()
90 "Say OK if the necessary external dependencies are available."
93 (geographic-to-utm 33 13 52) ;check cs2cs
94 (phoros-photogrammetry:del-all
) ;check photogrammetry
95 (initialize-leap-seconds) ;check source of leap second info
96 (format *error-output
* "~&OK~%"))
97 (error (e) (format *error-output
* "~A~&" e
))))
99 (defun muffle-postgresql-warnings ()
100 "For current DB, silence PostgreSQL's warnings about implicitly
102 (unless *postgresql-warnings
*
103 (execute "SET client_min_messages TO ERROR;")))
105 (defun check-db (db-credentials)
106 "Check postgresql connection. Return t if successful; show error on
107 *error-output* otherwise. db-credentials is a list like so: (database
108 user password host &key (port 5432) use-ssl)."
111 (setf connection
(apply #'connect db-credentials
))
112 (error (e) (format *error-output
* "Database connection ~S failed: ~A~&"
115 (disconnect connection
)
118 (defun ignore-warnings (c) (declare (ignore c
)) (muffle-warning))
120 (defmethod hunchentoot:session-cookie-name
(acceptor)
121 (declare (ignore acceptor
))
124 (defun start-server (&key
(http-port 8080) address
(common-root "/"))
125 "Start the presentation project server which listens on http-port
126 at address. Address defaults to all addresses of the local machine."
127 (setf *phoros-server
*
128 (make-instance 'hunchentoot
:acceptor
131 :access-logger
#'log-http-access
132 :message-logger
#'log-hunchentoot-message
))
133 (setf hunchentoot
:*session-max-time
* (* 3600 24))
134 (setf *common-root
* common-root
)
135 (check-db *postgresql-credentials
*)
136 (with-connection *postgresql-credentials
*
137 (assert-phoros-db-major-version))
138 (hunchentoot:reset-session-secret
)
139 (hunchentoot:start
*phoros-server
*))
141 (defun stop-server () (hunchentoot:stop
*phoros-server
*))
143 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
144 (register-sql-operators :2+-ary
:&& :overlaps
))
146 (setf hunchentoot
:*default-handler
*
148 "Http default response."
149 (setf (hunchentoot:return-code
*) hunchentoot
:+http-not-found
+)))
151 (hunchentoot:define-easy-handler phoros-handler
()
152 "First HTTP contact: if necessary, check credentials, establish new
154 (with-connection *postgresql-credentials
*
155 (let* ((presentation-project-name
156 (second (cl-utilities:split-sequence
157 #\
/ (hunchentoot:script-name
*) :remove-empty-subseqs t
)))
158 (presentation-project-id
161 (:select
'presentation-project-id
162 :from
'sys-presentation-project
163 :where
(:= 'presentation-project-name
164 presentation-project-name
))
167 ((null presentation-project-id
)
168 (setf (hunchentoot:return-code
*) hunchentoot
:+http-not-found
+))
169 ((and (equal (hunchentoot:session-value
'presentation-project-name
)
170 presentation-project-name
)
171 (hunchentoot:session-value
'authenticated-p
))
172 (hunchentoot:redirect
173 (format nil
"/phoros/lib/view-~A" (phoros-version))
177 (setf (hunchentoot:session-value
'presentation-project-name
)
178 presentation-project-name
)
179 (setf (hunchentoot:session-value
'presentation-project-id
)
180 presentation-project-id
)
181 (setf (hunchentoot:session-value
'presentation-project-bbox
)
184 (bounding-box (get-dao 'sys-presentation-project
185 presentation-project-name
)))))
186 (if (or (null bbox
) (eq :null bbox
))
189 (setf (hunchentoot:session-value
'aux-data-p
)
190 (with-connection *postgresql-aux-credentials
*
191 (view-exists-p (aux-point-view-name
192 presentation-project-name
))))
193 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
195 :style
"font-family:sans-serif;"
197 :method
"post" :enctype
"multipart/form-data"
198 :action
"/phoros/lib/authenticate" :name
"login-form"
200 (:legend
(:b
(:a
:href
"http://phoros.berlios.de"
201 :style
"text-decoration:none;"
203 (who:fmt
" [~A]" presentation-project-name
)))
205 (:b
(:em
"You can't do much without JavaScript there.")))
208 (:input
:type
"text" :name
"user-name"))
211 (:input
:type
"password" :name
"user-password")
213 (:span
:id
"cackle"))
214 (:input
:type
"submit" :value
"Submit"
216 (setf (chain document
217 (get-element-by-id "cackle")
219 "Ok, let's see…"))))
220 (:script
:type
"text/javascript"
221 (who:str
(ps (chain document
226 for i in
*login-intro
*
227 do
(who:htm
(:p
(who:str i
))))))))))))
229 (pushnew (hunchentoot:create-regex-dispatcher
"/phoros/(?!lib/)"
231 hunchentoot
:*dispatch-table
*)
233 (defun stored-bbox ()
234 "Return stored bounding box for user and presentation project of
236 (with-connection *postgresql-credentials
*
237 (let ((bbox (bounding-box
238 (get-dao 'sys-user-role
239 (hunchentoot:session-value
241 (hunchentoot:session-value
242 'presentation-project-id
)))))
244 (hunchentoot:session-value
'presentation-project-bbox
)
247 (defun stored-cursor ()
248 "Return stored cursor position for user and presentation project of
250 (with-connection *postgresql-credentials
*
253 (:select
(:st_x
'cursor
) (:st_y
'cursor
)
255 :where
(:and
(:= 'user-id
256 (hunchentoot:session-value
'user-id
))
257 (:= 'presentation-project-id
258 (hunchentoot:session-value
259 'presentation-project-id
))
260 (:raw
"cursor IS NOT NULL")))
263 (format nil
"~{~F~#^,~}" cursor
)))))
266 (hunchentoot:define-easy-handler
267 (authenticate-handler :uri
"/phoros/lib/authenticate"
268 :default-request-type
:post
)
270 "Check user credentials."
271 (with-connection *postgresql-credentials
*
272 (let* ((user-name (hunchentoot:post-parameter
"user-name"))
273 (user-password (hunchentoot:post-parameter
"user-password"))
274 (presentation-project-id (hunchentoot:session-value
275 'presentation-project-id
))
277 (when presentation-project-id
280 'sys-user.user-full-name
282 'sys-user-role.user-role
283 :from
'sys-user-role
'sys-user
285 (:= 'presentation-project-id presentation-project-id
)
286 (:= 'sys-user-role.user-id
'sys-user.user-id
)
287 (:= 'user-name user-name
)
288 (:= 'user-password user-password
)))
290 (user-full-name (first user-info
))
291 (user-id (second user-info
))
292 (user-role (third user-info
)))
295 (setf (hunchentoot:session-value
'authenticated-p
) t
296 (hunchentoot:session-value
'user-name
) user-name
297 (hunchentoot:session-value
'user-full-name
) user-full-name
298 (hunchentoot:session-value
'user-id
) user-id
299 (hunchentoot:session-value
'user-role
) user-role
)
300 (hunchentoot:redirect
(format nil
"/phoros/lib/view-~A"
303 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
305 :style
"font-family:sans-serif;"
307 (:a
:href
(format nil
"/phoros/~A/" (hunchentoot:session-value
308 'presentation-project-name
))
311 (hunchentoot:define-easy-handler logout-handler
(bbox longitude latitude
)
312 (if (hunchentoot:session-value
'authenticated-p
)
313 (with-connection *postgresql-credentials
*
314 (let ((presentation-project-name
315 (hunchentoot:session-value
'presentation-project-name
))
317 (get-dao 'sys-user-role
318 (hunchentoot:session-value
'user-id
)
319 (hunchentoot:session-value
'presentation-project-id
))))
322 (setf (bounding-box sys-user-role
) bbox
))
323 (when (and longitude latitude
)
324 (let* ;; kludge: should be done by some library, not by DB query
325 ((point-form (format nil
"POINT(~F ~F)" longitude latitude
))
326 (point-wkb (query (:select
327 (:st_geomfromtext point-form
))
329 (setf (cursor sys-user-role
) point-wkb
)))
330 (update-dao sys-user-role
))
331 (hunchentoot:remove-session hunchentoot
:*session
*)
332 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
338 "Phoros: logged out" )))
339 (:link
:rel
"stylesheet"
340 :href
(format nil
"/phoros/lib/css-~A/style.css"
344 (:h1
:id
"title" "Phoros: logged out")
345 (:p
"Log back in to project "
346 (:a
:href
(format nil
"/phoros/~A" presentation-project-name
)
347 (who:fmt
"~A." presentation-project-name
))))))))
350 (pushnew (hunchentoot:create-regex-dispatcher
"/logout" 'logout-handler
)
351 hunchentoot
:*dispatch-table
*)
353 (define-condition superseded
() ()
355 "Tell a thread to finish as soon as possible taking any shortcuts
358 (hunchentoot:define-easy-handler
359 (local-data :uri
"/phoros/lib/local-data" :default-request-type
:post
)
361 "Receive coordinates, respond with the count nearest json objects
362 containing picture url, calibration parameters, and car position,
363 wrapped in an array. Wipe away any unfinished business first."
364 (when (hunchentoot:session-value
'authenticated-p
)
365 (dolist (old-thread (hunchentoot:session-value
'recent-threads
))
366 (ignore-errors (bt:interrupt-thread old-thread
#'(lambda () (signal 'superseded
)))))
367 (setf (hunchentoot:session-value
'recent-threads
) nil
)
368 (push (bt:current-thread
) (hunchentoot:session-value
'recent-threads
))
369 (setf (hunchentoot:content-type
*) "application/json")
370 (with-connection *postgresql-credentials
*
371 (let* ((presentation-project-id (hunchentoot:session-value
372 'presentation-project-id
))
373 (common-table-names (common-table-names
374 presentation-project-id
))
375 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
376 (longitude (cdr (assoc :longitude data
)))
377 (latitude (cdr (assoc :latitude data
)))
378 (count (cdr (assoc :count data
)))
379 (zoom (cdr (assoc :zoom data
)))
380 (snap-distance (* 1d-4
(expt 2 (- 22 zoom
)))) ; assuming geographic coordinates
381 (point-form (format nil
"POINT(~F ~F)" longitude latitude
))
392 for common-table-name in common-table-names
393 for aggregate-view-name
394 = (aggregate-view-name common-table-name
)
397 (:as
(:st_distance
'coordinates
400 ,*standard-coordinates
*))
403 'recorded-device-id
;debug
404 'device-stage-of-life-id
;debug
405 'generic-device-id
;debug
407 'filename
'byte-position
'point-id
408 (:as
(:not
(:is-null
'footprint
))
411 ;;'coordinates ;the search target
412 'longitude
'latitude
'ellipsoid-height
414 'east-sd
'north-sd
'height-sd
415 'roll
'pitch
'heading
416 'roll-sd
'pitch-sd
'heading-sd
417 'sensor-width-pix
'sensor-height-pix
419 'bayer-pattern
'color-raiser
421 'dx
'dy
'dz
'omega
'phi
'kappa
422 'c
'xh
'yh
'a1
'a2
'a3
'b1
'b2
'c1
'c2
'r0
423 'b-dx
'b-dy
'b-dz
'b-rotx
'b-roty
'b-rotz
425 'b-drotx
'b-droty
'b-drotz
427 ',aggregate-view-name
430 (:= 'presentation-project-id
431 ,presentation-project-id
)
441 for common-table-name
442 in common-table-names
443 for aggregate-view-name
444 = (aggregate-view-name
450 (:st_centroid
'footprint
)
453 ,*standard-coordinates
*))
455 (:as
(:st_centroid
'footprint
)
458 ',aggregate-view-name
461 (:= 'presentation-project-id
462 ,presentation-project-id
)
467 ,*standard-coordinates
*)
481 for common-table-name in common-table-names
482 for aggregate-view-name
483 = (aggregate-view-name common-table-name
)
486 (:as
(:st_distance
'coordinates
489 ,*standard-coordinates
*))
492 'recorded-device-id
;debug
493 'device-stage-of-life-id
;debug
494 'generic-device-id
;debug
496 'filename
'byte-position
'point-id
497 (:as
(:not
(:is-null
'footprint
))
500 ;;'coordinates ;the search target
501 'longitude
'latitude
'ellipsoid-height
503 'east-sd
'north-sd
'height-sd
504 'roll
'pitch
'heading
505 'roll-sd
'pitch-sd
'heading-sd
506 'sensor-width-pix
'sensor-height-pix
508 'bayer-pattern
'color-raiser
510 'dx
'dy
'dz
'omega
'phi
'kappa
511 'c
'xh
'yh
'a1
'a2
'a3
'b1
'b2
'c1
'c2
'r0
512 'b-dx
'b-dy
'b-dz
'b-rotx
'b-roty
'b-rotz
514 'b-drotx
'b-droty
'b-drotz
516 ',aggregate-view-name
518 (:and
(:= 'presentation-project-id
519 ,presentation-project-id
)
520 (:st_dwithin
'coordinates
523 ,*standard-coordinates
*)
528 (superseded () (terpri) nil
))))
529 (json:encode-json-to-string result
)))))
531 (hunchentoot:define-easy-handler
532 (store-point :uri
"/phoros/lib/store-point" :default-request-type
:post
)
534 "Receive point sent by user; store it into database."
535 (when (hunchentoot:session-value
'authenticated-p
)
536 (let* ((presentation-project-name (hunchentoot:session-value
537 'presentation-project-name
))
538 (user-id (hunchentoot:session-value
'user-id
))
539 (user-role (hunchentoot:session-value
'user-role
))
540 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
541 (longitude (cdr (assoc :longitude data
)))
542 (latitude (cdr (assoc :latitude data
)))
543 (ellipsoid-height (cdr (assoc :ellipsoid-height data
)))
544 (stdx-global (cdr (assoc :stdx-global data
)))
545 (stdy-global (cdr (assoc :stdy-global data
)))
546 (stdz-global (cdr (assoc :stdz-global data
)))
547 (input-size (cdr (assoc :input-size data
)))
548 (attribute (cdr (assoc :attribute data
)))
549 (description (cdr (assoc :description data
)))
550 (numeric-description (cdr (assoc :numeric-description data
)))
552 (format nil
"SRID=4326; POINT(~S ~S ~S)"
553 longitude latitude ellipsoid-height
))
554 (aux-numeric-raw (cdr (assoc :aux-numeric data
)))
555 (aux-text-raw (cdr (assoc :aux-text data
)))
556 (aux-numeric (if aux-numeric-raw
557 (apply #'vector aux-numeric-raw
)
559 (aux-text (if aux-text-raw
560 (apply #'vector aux-text-raw
)
562 (user-point-table-name
563 (user-point-table-name presentation-project-name
)))
565 (not (string-equal user-role
"read")) ;that is, "write" or "admin"
566 () "No write permission.")
567 (with-connection *postgresql-credentials
*
569 (= 1 (execute (:insert-into user-point-table-name
:set
572 'description description
573 'numeric-description numeric-description
574 'creation-date
'current-timestamp
575 'coordinates
(:st_geomfromewkt point-form
)
576 'stdx-global stdx-global
577 'stdy-global stdy-global
578 'stdz-global stdz-global
579 'input-size input-size
580 'aux-numeric aux-numeric
581 'aux-text aux-text
)))
582 () "No point stored. This should not happen.")))))
584 (hunchentoot:define-easy-handler
585 (update-point :uri
"/phoros/lib/update-point" :default-request-type
:post
)
587 "Update point sent by user in database."
588 (when (hunchentoot:session-value
'authenticated-p
)
589 (let* ((presentation-project-name (hunchentoot:session-value
590 'presentation-project-name
))
591 (user-id (hunchentoot:session-value
'user-id
))
592 (user-role (hunchentoot:session-value
'user-role
))
593 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
594 (user-point-id (cdr (assoc :user-point-id data
)))
595 (attribute (cdr (assoc :attribute data
)))
596 (description (cdr (assoc :description data
)))
597 (numeric-description (cdr (assoc :numeric-description data
)))
598 (user-point-table-name
599 (user-point-table-name presentation-project-name
)))
601 (not (string-equal user-role
"read")) ;that is, "write" or "admin"
602 () "No write permission.")
603 (with-connection *postgresql-credentials
*
605 (= 1 (execute (:update user-point-table-name
:set
607 'description description
608 'numeric-description numeric-description
609 'creation-date
'current-timestamp
610 :where
(:and
(:= 'user-point-id user-point-id
)
611 (:= (if (string-equal user-role
616 () "No point stored. Did you try to update someone else's point ~
617 without having admin permission?")))))
619 (hunchentoot:define-easy-handler
620 (delete-point :uri
"/phoros/lib/delete-point" :default-request-type
:post
)
622 "Delete user point if user is allowed to do so."
623 (when (hunchentoot:session-value
'authenticated-p
)
624 (let* ((presentation-project-name (hunchentoot:session-value
625 'presentation-project-name
))
626 (user-id (hunchentoot:session-value
'user-id
))
627 (user-role (hunchentoot:session-value
'user-role
))
628 (user-point-table-name
629 (user-point-table-name presentation-project-name
))
630 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
631 (with-connection *postgresql-credentials
*
633 (eql 1 (cond ((string-equal user-role
"admin")
634 (execute (:delete-from user-point-table-name
635 :where
(:= 'user-point-id data
))))
636 ((string-equal user-role
"write")
637 (execute (:delete-from user-point-table-name
639 (:= 'user-point-id data
)
640 (:= 'user-id user-id
)))))))
641 () "No point deleted. This should not happen.")))))
643 (defun common-table-names (presentation-project-id)
644 "Return a list of common-table-names of table sets that contain data
645 of presentation project with presentation-project-id."
648 (:select
'common-table-name
650 :from
'sys-presentation
'sys-measurement
'sys-acquisition-project
652 (:= 'sys-presentation.presentation-project-id
653 presentation-project-id
)
654 (:= 'sys-presentation.measurement-id
655 'sys-measurement.measurement-id
)
656 (:= 'sys-measurement.acquisition-project-id
657 'sys-acquisition-project.acquisition-project-id
)))
662 "While fetching common-table-names of presentation-project-id ~D: ~A"
663 presentation-project-id c
))))
665 (defun encode-geojson-to-string (features &key junk-keys
)
666 "Encode a list of property lists into a GeoJSON FeatureCollection.
667 Each property list must contain keys for coordinates, :x, :y, :z; it
668 may contain a numeric point :id and zero or more pieces of extra
669 information. The extra information is stored as GeoJSON Feature
670 properties. Exclude property list elements with keys that are in
672 (with-output-to-string (s)
673 (json:with-object
(s)
674 (json:encode-object-member
:type
:*feature-collection s
)
675 (json:as-object-member
(:features s
)
678 #'(lambda (point-with-properties)
679 (dolist (junk-key junk-keys
)
680 (remf point-with-properties junk-key
))
681 (destructuring-bind (&key x y z id
&allow-other-keys
) ;TODO: z probably bogus
682 point-with-properties
683 (json:as-array-member
(s)
684 (json:with-object
(s)
685 (json:encode-object-member
:type
:*feature s
)
686 (json:as-object-member
(:geometry s
)
687 (json:with-object
(s)
688 (json:encode-object-member
:type
:*point s
)
689 (json:as-object-member
(:coordinates s
)
690 (json:encode-json
(list x y z
) s
))))
691 (json:encode-object-member
:id id s
)
692 (json:as-object-member
(:properties s
)
693 (dolist (key '(:x
:y
:z
:id
))
694 (remf point-with-properties key
))
695 (json:encode-json-plist point-with-properties s
))))))
697 (json:encode-object-member
:phoros-version
(phoros-version) s
))))
700 "Return a WKT-compliant BOX3D string from string bbox."
701 (concatenate 'string
"BOX3D("
702 (substitute #\Space
#\
,
703 (substitute #\Space
#\
, bbox
:count
1)
704 :from-end t
:count
1)
707 (hunchentoot:define-easy-handler
(points :uri
"/phoros/lib/points.json") (bbox)
708 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
709 (when (hunchentoot:session-value
'authenticated-p
)
710 (setf (hunchentoot:content-type
*) "application/json")
712 (with-connection *postgresql-credentials
*
713 (let* ((presentation-project-id
714 (hunchentoot:session-value
'presentation-project-id
))
716 (common-table-names presentation-project-id
)))
717 (encode-geojson-to-string
724 for common-table-name in common-table-names
725 for aggregate-view-name
726 = (point-data-table-name common-table-name
)
727 ;; would have been nice, was too slow:
728 ;; = (aggregate-view-name common-table-name)
731 (:as
(:st_x
'coordinates
) x
)
732 (:as
(:st_y
'coordinates
) y
)
733 (:as
(:st_z
'coordinates
) z
)
734 (:as
'point-id
'id
) ;becomes fid on client
737 :from
',aggregate-view-name
738 :natural
:left-join
'sys-presentation
741 (:= 'presentation-project-id
742 ,presentation-project-id
)
745 (:st_setsrid
(:type
,(box3d bbox
) box3d
)
746 ,*standard-coordinates
*))))))
748 ,*number-of-features-per-layer
*))
750 :junk-keys
'(:random
))))
753 :error
"While fetching points from inside bbox ~S: ~A"
756 (hunchentoot:define-easy-handler
(aux-points :uri
"/phoros/lib/aux-points.json") (bbox)
757 "Send a bunch of GeoJSON-encoded points from inside bbox to client."
758 (when (hunchentoot:session-value
'authenticated-p
)
759 (setf (hunchentoot:content-type
*) "application/json")
761 (let ((limit *number-of-features-per-layer
*)
763 (aux-point-view-name (hunchentoot:session-value
764 'presentation-project-name
))))
765 (encode-geojson-to-string
766 (with-connection *postgresql-aux-credentials
*
772 (:as
(:st_x
'coordinates
) 'x
)
773 (:as
(:st_y
'coordinates
) 'y
)
774 (:as
(:st_z
'coordinates
) 'z
)
778 (:st_setsrid
(:type
,(box3d bbox
) box3d
)
779 ,*standard-coordinates
*)))
785 :error
"While fetching aux-points from inside bbox ~S: ~A"
788 (hunchentoot:define-easy-handler
789 (aux-local-data :uri
"/phoros/lib/aux-local-data"
790 :default-request-type
:post
)
792 "Receive coordinates, respond with the count nearest json objects
793 containing arrays aux-numeric, aux-text, and distance to the
794 coordinates received, wrapped in an array."
795 (when (hunchentoot:session-value
'authenticated-p
)
796 (setf (hunchentoot:content-type
*) "application/json")
797 (let* ((aux-view-name
798 (aux-point-view-name (hunchentoot:session-value
799 'presentation-project-name
)))
800 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
801 (longitude (cdr (assoc :longitude data
)))
802 (latitude (cdr (assoc :latitude data
)))
803 (count (cdr (assoc :count data
)))
805 (format nil
"POINT(~F ~F)" longitude latitude
))
806 (snap-distance 1e-3) ;about 100 m, TODO: make this a defparameter
808 (format nil
"~A,~A,~A,~A"
809 (- longitude snap-distance
)
810 (- latitude snap-distance
)
811 (+ longitude snap-distance
)
812 (+ latitude snap-distance
))))
813 (encode-geojson-to-string
815 (with-connection *postgresql-aux-credentials
*
823 (:as
(:st_x
'coordinates
) 'x
)
824 (:as
(:st_y
'coordinates
) 'y
)
825 (:as
(:st_z
'coordinates
) 'z
)
832 ,*spherical-mercator
*)
834 (:st_geomfromtext
,point-form
,*standard-coordinates
*)
835 ,*spherical-mercator
*))
837 :from
',aux-view-name
838 :where
(:&& 'coordinates
840 ,(box3d bounding-box
) box3d
)
841 ,*standard-coordinates
*)))
846 (hunchentoot:define-easy-handler
847 (aux-local-linestring :uri
"/phoros/lib/aux-local-linestring.json"
848 :default-request-type
:post
)
850 "Receive longitude, latitude, radius, and step-size; respond
851 with the a JSON object comprising the elements linestring (a WKT
852 linestring stitched together of the nearest auxiliary points from
853 within radius around coordinates), current-point (the point on
854 linestring closest to coordinates), and previous-point and next-point
855 \(points on linestring step-size before and after current-point
857 (when (hunchentoot:session-value
'authenticated-p
)
858 (setf (hunchentoot:content-type
*) "application/json")
859 (let* ((thread-aux-points-function-name
860 (thread-aux-points-function-name (hunchentoot:session-value
861 'presentation-project-name
)))
862 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
863 (longitude (cdr (assoc :longitude data
)))
864 (latitude (cdr (assoc :latitude data
)))
865 (radius (cdr (assoc :radius data
)))
866 (step-size (cdr (assoc :step-size data
)))
867 (azimuth (if (numberp (cdr (assoc :azimuth data
)))
868 (cdr (assoc :azimuth data
))
871 (format nil
"POINT(~F ~F)" longitude latitude
))
874 (with-connection *postgresql-aux-credentials
*
880 (,thread-aux-points-function-name
882 ,point-form
,*standard-coordinates
*)
884 ,*number-of-points-per-aux-linestring
*
887 ,(proj:degrees-to-radians
91))))
889 (with-output-to-string (s)
890 (json:with-object
(s)
891 (json:encode-object-member
892 :linestring
(getf sql-response
:threaded-points
) s
)
893 (json:encode-object-member
894 :current-point
(getf sql-response
:current-point
) s
)
895 (json:encode-object-member
896 :previous-point
(getf sql-response
:back-point
) s
)
897 (json:encode-object-member
898 :next-point
(getf sql-response
:forward-point
) s
)
899 (json:encode-object-member
900 :azimuth
(getf sql-response
:new-azimuth
) s
))))))
902 (defun get-user-points (user-point-table-name &key
903 (bounding-box "-180,-90,180,90")
905 (order-criterion 'id
))
906 "Return limit points from user-point-table-name in GeoJSON format,
907 and the number of points returned."
908 (let ((user-point-plist
914 (:as
(:st_x
'coordinates
) 'x
)
915 (:as
(:st_y
'coordinates
) 'y
)
916 (:as
(:st_z
'coordinates
) 'z
)
917 (:as
'user-point-id
'id
) ;becomes fid in OpenLayers
918 'stdx-global
'stdy-global
'stdz-global
920 'attribute
'description
'numeric-description
922 (:as
(:to-char
'creation-date
923 ,*user-point-creation-date-format
*)
925 'aux-numeric
'aux-text
926 :from
,user-point-table-name
:natural
:left-join
'sys-user
927 :where
(:&& 'coordinates
928 (:st_setsrid
(:type
,(box3d bounding-box
) box3d
)
929 ,*standard-coordinates
*)))
934 (encode-geojson-to-string (nsubst nil
:null user-point-plist
))
935 (length user-point-plist
))))
937 (hunchentoot:define-easy-handler
938 (user-points :uri
"/phoros/lib/user-points.json")
940 "Send *number-of-features-per-layer* randomly chosen GeoJSON-encoded
941 points from inside bbox to client. If there is no bbox parameter,
943 (when (hunchentoot:session-value
'authenticated-p
)
944 (setf (hunchentoot:content-type
*) "application/json")
946 (let ((bounding-box (or bbox
"-180,-90,180,90"))
947 (limit (if bbox
*number-of-features-per-layer
* :null
))
948 (order-criterion (if bbox
'(:random
) 'id
))
949 (user-point-table-name
950 (user-point-table-name (hunchentoot:session-value
951 'presentation-project-name
))))
952 (with-connection *postgresql-credentials
*
953 (nth-value 0 (get-user-points user-point-table-name
954 :bounding-box bounding-box
956 :order-criterion order-criterion
))))
959 :error
"While fetching user-points~@[ from inside bbox ~S~]: ~A"
962 (hunchentoot:define-easy-handler
963 (user-point-attributes :uri
"/phoros/lib/user-point-attributes.json")
965 "Send JSON object comprising arrays attributes and descriptions,
966 each containing unique values called attribute and description
967 respectively, and count being the frequency of value in the user point
969 (when (hunchentoot:session-value
'authenticated-p
)
970 (setf (hunchentoot:content-type
*) "application/json")
972 (let ((user-point-table-name
973 (user-point-table-name (hunchentoot:session-value
974 'presentation-project-name
))))
975 (with-connection *postgresql-credentials
*
976 (with-output-to-string (s)
977 (json:with-object
(s)
978 (json:as-object-member
(:descriptions s
)
980 (mapcar #'(lambda (x) (json:as-array-member
(s)
981 (json:encode-json-plist x s
)))
985 (:select
'description
986 (:count
'description
)
987 :from user-point-table-name
988 :group-by
'description
)
992 (json:as-object-member
(:attributes s
)
994 (mapcar #'(lambda (x) (json:as-array-member
(s)
995 (json:encode-json-plist x s
)))
996 (query (format nil
"~
997 (SELECT attribute, count(attribute) ~
998 FROM ((SELECT attribute FROM ~A) ~
1001 FROM (VALUES ('solitary'), ~
1004 AS defaults(attribute))) ~
1005 AS attributes_union(attribute) ~
1006 GROUP BY attribute) ~
1007 ORDER BY attribute LIMIT 100"
1008 ;; Counts of solitary,
1009 ;; polyline, polygon may be
1010 ;; to big by one if we
1011 ;; collect them like this.
1012 (s-sql:to-sql-name user-point-table-name
))
1016 :error
"While fetching user-point-attributes: ~A"
1019 (hunchentoot:define-easy-handler photo-handler
1020 ((bayer-pattern :init-form
"65280,16711680")
1021 (color-raiser :init-form
"1,1,1")
1022 (mounting-angle :init-form
"0"))
1023 "Serve an image from a .pictures file."
1024 (when (hunchentoot:session-value
'authenticated-p
)
1027 (push (bt:current-thread
)
1028 (hunchentoot:session-value
'recent-threads
))
1029 (let* ((s (cdr (cl-utilities:split-sequence
1031 (hunchentoot:script-name
*)
1032 :remove-empty-subseqs t
)))
1033 (directory (last (butlast s
2)))
1034 (file-name-and-type (cl-utilities:split-sequence
1035 #\.
(first (last s
2))))
1036 (byte-position (parse-integer (car (last s
)) :junk-allowed t
))
1041 :directory
(append (pathname-directory *common-root
*)
1042 directory
'(:wild-inferiors
))
1043 :name
(first file-name-and-type
)
1044 :type
(second file-name-and-type
)))))
1046 (setf (hunchentoot:header-out
'cache-control
)
1047 (format nil
"max-age=~D" (* 3600 24 7)))
1048 (setf (hunchentoot:content-type
*) "image/png")
1049 (setf stream
(hunchentoot:send-headers
))
1051 stream path-to-file byte-position
1053 (apply #'vector
(mapcar
1055 (cl-utilities:split-sequence
1056 #\
, bayer-pattern
)))
1058 (apply #'vector
(mapcar
1059 #'parse-number
:parse-positive-real-number
1060 (cl-utilities:split-sequence
#\
, color-raiser
)))
1061 :reversep
(= 180 (parse-integer mounting-angle
)))))
1062 (superseded () (terpri) nil
)
1065 :error
"While serving image ~S: ~A" (hunchentoot:request-uri
*) c
)))))
1067 (pushnew (hunchentoot:create-prefix-dispatcher
"/phoros/lib/photo"
1069 hunchentoot
:*dispatch-table
*)
1071 ;;; for debugging; this is the multi-file OpenLayers
1072 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1073 "/phoros/lib/openlayers/" "OpenLayers-2.10/")
1074 hunchentoot
:*dispatch-table
*)
1076 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
"/phoros/lib/ol/" "ol/")
1077 hunchentoot
:*dispatch-table
*)
1079 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1080 (format nil
"/phoros/lib/css-~A/" (phoros-version)) "css/") ;TODO: merge this style.css into public_html/style.css
1081 hunchentoot
:*dispatch-table
*)
1083 (pushnew (hunchentoot:create-folder-dispatcher-and-handler
1084 "/phoros/lib/public_html/" "public_html/")
1085 hunchentoot
:*dispatch-table
*)
1087 (pushnew (hunchentoot:create-static-file-dispatcher-and-handler
1088 "/favicon.ico" "public_html/favicon.ico")
1089 hunchentoot
:*dispatch-table
*)
1091 (hunchentoot:define-easy-handler
1092 (view :uri
(format nil
"/phoros/lib/view-~A" (phoros-version))
1093 :default-request-type
:post
)
1095 "Serve the client their main workspace."
1097 (hunchentoot:session-value
'authenticated-p
)
1098 (who:with-html-output-to-string
(s nil
:prologue t
:indent t
)
1104 "Phoros: " (hunchentoot:session-value
1105 'presentation-project-name
))))
1106 (if *use-multi-file-openlayers
*
1108 (:script
:src
"/phoros/lib/openlayers/lib/Firebug/firebug.js")
1109 (:script
:src
"/phoros/lib/openlayers/lib/OpenLayers.js"))
1110 (who:htm
(:script
:src
"/phoros/lib/ol/OpenLayers.js")))
1111 (:link
:rel
"stylesheet"
1112 :href
(format nil
"/phoros/lib/css-~A/style.css"
1115 (:script
:src
(format ;variability in script name is
1116 nil
; supposed to fight browser cache
1117 "/phoros/lib/phoros-~A-~A-~A.js"
1119 (hunchentoot:session-value
'user-name
)
1120 (hunchentoot:session-value
'presentation-project-name
)))
1121 (:script
:src
"http://maps.google.com/maps/api/js?sensor=false"))
1124 (:noscript
(:b
(:em
"You can't do much without JavaScript here.")))
1126 "Phoros: " (who:str
(hunchentoot:session-value
'user-full-name
))
1127 (who:fmt
" (~A)" (hunchentoot:session-value
'user-name
))
1128 "with " (:span
:id
"user-role"
1129 (who:str
(hunchentoot:session-value
'user-role
)))
1131 (:span
:id
"presentation-project-name"
1132 (who:str
(hunchentoot:session-value
1133 'presentation-project-name
)))
1134 (:span
:id
"presentation-project-emptiness")
1135 (:span
:id
"phoros-version" :class
"h1-right"
1136 (who:fmt
"v~A" (phoros-version))))
1137 (:div
:class
"controlled-streetmap"
1138 (:div
:id
"streetmap" :class
"streetmap" :style
"cursor:crosshair")
1139 (:div
:id
"streetmap-controls" :class
"streetmap-controls"
1140 (:div
:id
"streetmap-vertical-strut"
1141 :class
"streetmap-vertical-strut")
1142 (:div
:id
"streetmap-layer-switcher"
1143 :class
"streetmap-layer-switcher")
1144 (:div
:id
"streetmap-overview" :class
"streetmap-overview")
1145 (:div
:id
"streetmap-mouse-position"
1146 :class
"streetmap-mouse-position")
1147 (:div
:id
"streetmap-zoom" :class
"streetmap-zoom")))
1148 (:div
:class
"phoros-controls"
1149 (:div
:id
"real-phoros-controls"
1150 (:h2
(:span
:id
"h2-controls") (:span
:id
"creator"))
1151 (:div
:id
"point-attribute"
1153 (:select
:id
"point-attribute-select"
1154 :name
"point-attribute-select"
1155 :class
"combobox-select"
1158 (consolidate-combobox "point-attribute"))
1160 (:input
:id
"point-attribute-input"
1161 :name
"point-attribute-input"
1162 :class
"combobox-input"
1163 :onchange
(ps-inline
1164 (unselect-combobox-selection
1168 ;; (:select :id "point-attribute" :disabled t
1169 ;; :size 1 :name "point-attribute")
1170 (:input
:id
"point-numeric-description"
1171 :class
"vanilla-input"
1173 :type
"text" :name
"point-numeric-description")
1175 (:div
:id
"point-description"
1177 (:select
:id
"point-description-select"
1178 :name
"point-description-select"
1179 :class
"combobox-select"
1180 :onchange
(ps-inline
1181 (consolidate-combobox
1182 "point-description"))
1184 (:input
:id
"point-description-input"
1185 :name
"point-description-input"
1186 :class
"combobox-input"
1187 :onchange
(ps-inline
1188 (unselect-combobox-selection
1189 "point-description"))
1192 (:button
:id
"delete-point-button" :disabled t
1194 :onclick
(ps-inline (delete-point))
1196 (:button
:disabled t
:id
"finish-point-button"
1199 (:div
:id
"aux-point-distance-or-point-creation-date"
1200 (:code
:id
"point-creation-date")
1201 (:select
:id
"aux-point-distance" :disabled t
1202 :size
1 :name
"aux-point-distance"
1203 :onchange
(ps-inline
1204 (aux-point-distance-selected))
1206 (enable-aux-point-selection)))
1207 (:div
:id
"include-aux-data"
1209 (:input
:id
"include-aux-data-p"
1210 :class
"tight-input"
1211 :type
"checkbox" :checked t
1212 :name
"include-aux-data-p"
1213 :onchange
(ps-inline
1214 (flip-aux-data-inclusion)))
1216 (:div
:id
"aux-data"
1217 (:div
:id
"aux-numeric-list")
1218 (:div
:id
"aux-text-list")))
1219 (:div
:id
"multiple-points-phoros-controls"
1220 (:h2
"Multiple Points Selected")
1221 (:p
"You have selected multiple user points.")
1222 (:p
"Unselect all but one to edit or view its properties."))
1223 (:div
:class
"walk-mode-controls"
1224 (:div
:id
"walk-mode"
1226 (:input
:id
"walk-p"
1227 :class
"tight-input"
1228 :type
"checkbox" :checked nil
1229 :onchange
(ps-inline
1232 (:div
:id
"decrease-step-size"
1233 :onclick
(ps-inline (decrease-step-size)))
1234 (:div
:id
"step-size"
1235 :onclick
(ps-inline (increase-step-size))
1237 (:div
:id
"increase-step-size"
1238 :onclick
(ps-inline (increase-step-size))
1239 :ondblclick
(ps-inline (increase-step-size)
1240 (increase-step-size)))
1241 (:div
:id
"step-button" :disabled nil
1242 :onclick
(ps-inline (step))
1243 :ondblclick
(ps-inline (step t
))
1245 (:div
:class
"image-main-controls"
1246 (:div
:id
"auto-zoom"
1248 (:input
:id
"zoom-to-point-p"
1249 :class
"tight-input"
1250 :type
"checkbox" :checked t
)
1252 (:div
:id
"zoom-images-to-max-extent"
1253 :onclick
(ps-inline (zoom-images-to-max-extent)))
1254 (:div
:id
"no-footprints-p"
1256 (:div
:id
"remove-work-layers-button" :disabled t
1257 :onclick
(ps-inline (reset-layers-and-controls))
1259 (:div
:class
"help-div"
1260 (:button
:id
"download-user-points-button"
1262 :onclick
"self.location.href = \"/phoros/lib/user-points.json\""
1263 "download points") ;TODO: offer other formats and maybe projections
1264 (:button
:id
"blurb-button"
1269 (+ "/phoros/lib/blurb?openlayers-version="
1270 (@ *open-layers
*version_number
*))
1272 (:img
:src
"/phoros/lib/public_html/phoros-logo-plain.png"
1273 :alt
"Phoros" :style
"vertical-align:middle"
1275 (:button
:id
"logout-button"
1277 :onclick
(ps-inline (bye))
1279 (:h2
:id
"h2-help" "Help")
1280 (:div
:id
"help-display"))
1281 (:div
:id
"images" :style
"clear:both"
1283 for i from
0 below
*number-of-images
* do
1285 (:div
:class
"controlled-image"
1286 (:div
:id
(format nil
"image-~S-controls" i
)
1287 :class
"image-controls"
1288 (:div
:id
(format nil
"image-~S-zoom" i
)
1289 :class
"image-zoom")
1290 (:div
:id
(format nil
"image-~S-layer-switcher" i
)
1291 :class
"image-layer-switcher")
1292 (:div
:id
(format nil
"image-~S-usable" i
)
1293 :class
"image-usable"
1295 (:div
:id
(format nil
"image-~S-trigger-time" i
)
1296 :class
"image-trigger-time"))
1297 (:div
:id
(format nil
"image-~S" i
)
1298 :class
"image" :style
"cursor:crosshair"))))))))
1299 (hunchentoot:redirect
1300 (concatenate 'string
"/phoros/" (hunchentoot:session-value
1301 'presentation-project-name
))
1302 :add-session-id t
)))
1304 (hunchentoot:define-easy-handler
1305 (epipolar-line :uri
"/phoros/lib/epipolar-line")
1307 "Receive vector of two sets of picture parameters, respond with
1308 JSON encoded epipolar-lines."
1309 (when (hunchentoot:session-value
'authenticated-p
)
1310 (setf (hunchentoot:content-type
*) "application/json")
1311 (let* ((data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
1312 (json:encode-json-to-string
1313 (photogrammetry :epipolar-line
(first data
) (second data
))))))
1315 (hunchentoot:define-easy-handler
1316 (estimated-positions :uri
"/phoros/lib/estimated-positions")
1318 "Receive a two-part JSON vector comprising (1) a vector containing
1319 sets of picture-parameters with clicked (\"active\") points
1320 stored in :m, :n; and (2) a vector containing sets of
1321 picture-parameters; respond with a JSON encoded two-part vector
1322 comprising (1) a point in global coordinates; and (2) a vector of
1323 image coordinates (m, n) for the global point that correspond to the
1324 images from the received second vector. TODO: report error on bad
1325 data (ex: points too far apart)."
1326 ;; TODO: global-point-for-display should probably contain a proj string in order to make sense of the (cartesian) standard deviations.
1327 (when (hunchentoot:session-value
'authenticated-p
)
1328 (setf (hunchentoot:content-type
*) "application/json")
1330 (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1331 (active-point-photo-parameters
1333 (number-of-active-points
1334 (length active-point-photo-parameters
))
1335 (destination-photo-parameters
1338 (cdr (assoc :cartesian-system
1339 (first active-point-photo-parameters
))))
1340 (global-point-cartesian
1342 :multi-position-intersection active-point-photo-parameters
))
1343 (global-point-geographic-radians
1344 (proj:cs2cs
(list (cdr (assoc :x-global global-point-cartesian
))
1345 (cdr (assoc :y-global global-point-cartesian
))
1346 (cdr (assoc :z-global global-point-cartesian
)))
1347 :source-cs cartesian-system
))
1348 (global-point-for-display ;points geographic cs, degrees; std deviations in cartesian cs
1349 (pairlis '(:longitude
:latitude
:ellipsoid-height
1350 :stdx-global
:stdy-global
:stdz-global
1353 (proj:radians-to-degrees
1354 (first global-point-geographic-radians
))
1355 (proj:radians-to-degrees
1356 (second global-point-geographic-radians
))
1357 (third global-point-geographic-radians
)
1358 (cdr (assoc :stdx-global global-point-cartesian
))
1359 (cdr (assoc :stdy-global global-point-cartesian
))
1360 (cdr (assoc :stdz-global global-point-cartesian
))
1361 number-of-active-points
)))
1364 for i in destination-photo-parameters
1367 (photogrammetry :reprojection i global-point-cartesian
)))))
1368 (json:encode-json-to-string
1369 (list global-point-for-display image-coordinates
)))))
1371 (hunchentoot:define-easy-handler
1372 (user-point-positions :uri
"/phoros/lib/user-point-positions")
1374 "Receive a two-part JSON vector comprising
1375 - a vector of user-point-id's and
1376 - a vector containing sets of picture-parameters;
1377 respond with a JSON object comprising the elements
1378 - image-points, a vector whose elements
1379 - correspond to the elements of the picture-parameters vector
1381 - are GeoJSON feature collections containing one point (in picture
1382 coordinates) for each user-point-id received;
1383 - user-point-count, the number of user-points we tried to fetch
1385 (when (hunchentoot:session-value
'authenticated-p
)
1386 (setf (hunchentoot:content-type
*) "application/json")
1387 (let* ((user-point-table-name
1388 (user-point-table-name (hunchentoot:session-value
1389 'presentation-project-name
)))
1390 (data (json:decode-json-from-string
(hunchentoot:raw-post-data
)))
1391 (user-point-ids (first data
))
1392 (user-point-count (length user-point-ids
))
1393 (destination-photo-parameters (second data
))
1395 (cdr (assoc :cartesian-system
1396 (first destination-photo-parameters
)))) ;TODO: in rare cases, coordinate systems of the images shown may differ
1398 (with-connection *postgresql-credentials
*
1401 (:as
(:st_x
'coordinates
) 'longitude
)
1402 (:as
(:st_y
'coordinates
) 'latitude
)
1403 (:as
(:st_z
'coordinates
) 'ellipsoid-height
)
1404 (:as
'user-point-id
'id
) ;becomes fid on client
1407 'numeric-description
1409 (:as
(:to-char
'creation-date
"IYYY-MM-DD HH24:MI:SS TZ")
1413 :from user-point-table-name
:natural
:left-join
'sys-user
1414 :where
(:in
'user-point-id
(:set user-point-ids
)))
1416 (global-points-cartesian
1418 for global-point-geographic in user-points
1420 (ignore-errors ;in case no destination-photo-parameters have been sent
1421 (pairlis '(:x-global
:y-global
:z-global
)
1424 (proj:degrees-to-radians
1425 (getf global-point-geographic
:longitude
))
1426 (proj:degrees-to-radians
1427 (getf global-point-geographic
:latitude
))
1428 (getf global-point-geographic
:ellipsoid-height
))
1429 :destination-cs cartesian-system
)))))
1432 for photo-parameter-set in destination-photo-parameters
1434 (encode-geojson-to-string
1436 for global-point-cartesian in global-points-cartesian
1437 for user-point in user-points
1440 (let ((photo-coordinates
1441 (photogrammetry :reprojection
1443 global-point-cartesian
))
1446 (setf (getf photo-point
:x
)
1447 (cdr (assoc :m photo-coordinates
)))
1448 (setf (getf photo-point
:y
)
1449 (cdr (assoc :n photo-coordinates
)))
1451 :junk-keys
'(:longitude
:latitude
:ellipsoid-height
)))))
1452 (with-output-to-string (s)
1453 (json:with-object
(s)
1454 (json:encode-object-member
:user-point-count user-point-count s
)
1455 (json:as-object-member
(:image-points s
)
1456 (json:with-array
(s)
1457 (loop for i in image-coordinates do
1458 (json:as-array-member
(s) (princ i s
))))))))))
1460 (hunchentoot:define-easy-handler
1461 (multi-position-intersection :uri
"/phoros/lib/intersection")
1463 "Receive vector of sets of picture parameters, respond with stuff."
1464 (when (hunchentoot:session-value
'authenticated-p
)
1465 (setf (hunchentoot:content-type
*) "application/json")
1466 (let* ((data (json:decode-json-from-string
(hunchentoot:raw-post-data
))))
1467 (json:encode-json-to-string
1468 (photogrammetry :multi-position-intersection data
)))))