1 ;;; PHOROS -- Photogrammetric Road Survey
2 ;;; Copyright (C) 2010, 2011, 2012 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.
19 ;;;; The UNIX command line interface
21 ;; TODO: options that have a function as their :action seem to mask earlier options. Fix and remove (*) stuff.
25 (defparameter cli
:*general-options
*
26 '((("help" #\h
) :action
#'cli
:help-action
27 :documentation
"(*) Print this help and exit.")
28 (("licence" "license") :action
#'cli
:licence-action
29 :documentation
"(*) Print licence boilerplate and exit.")
30 ("version" :action
#'cli
:version-action
31 :documentation
"(*) Print version information and exit. Use --verbose=1 to see more. In a version string A.B.C, changes in A denote incompatible changes in data; changes in B mean user-visible changes in feature set.")
32 ("verbose" :type integer
:initial-value
0
33 :documentation
"Dependent on zero-indexed bits set in this integer, emit various kinds of debugging output. Bit 9: log SQL activity; bit 10: display image footprints on http client; bit 11: show PostgreSQL warnings; bit 13: log http server error backtraces; bit 14: use multi-file version of OpenLayers; bit 15: send nicely formatted JavaScript; bit 16: send http server error messages to client.")
34 ("log-dir" :type string
:initial-value
""
35 :documentation
"Where to put the log files. Created if necessary; should end with a slash.")
36 ("check-db" :action
#'cli
:check-db-action
37 :documentation
"(*) Check connection to databases (including auxiliary if applicable) and exit.")
38 ("check-dependencies" :action
#'cli
:check-dependencies-action
39 :documentation
"(*) Check presence of dependencies on local system and exit.")
40 ("nuke-all-tables" :action
#'cli
:nuke-all-tables-action
41 :documentation
"(*) Ask for confirmation, then delete anything in database and exit.")
42 ("create-sys-tables" :action
#'cli
:create-sys-tables-action
43 :documentation
"(*) Ask for confirmation, then create in database a set of sys-* tables (tables shared between all projects). The database should probably be empty before you try this.")))
45 (defparameter cli
:*db-connection-options
*
46 '((("host" #\H
) :type string
:initial-value
"localhost"
47 :documentation
"Database server.")
48 (("port" #\P
) :type integer
:initial-value
5432
49 :documentation
"Port on database server.")
50 (("database" #\D
) :type string
:initial-value
"phoros"
51 :documentation
"Name of database.")
52 (("user" #\U
) :type string
53 :documentation
"Database user.")
54 (("password" #\W
) :type string
55 :documentation
"Database user's password.")
56 ("use-ssl" :type string
:initial-value
"no"
57 :documentation
"Use SSL in database connection. [yes|no|try]")))
59 (defparameter cli
:*aux-db-connection-options
*
60 '(("aux-host" :type string
61 :documentation
"Auxiliary database server. (default: same as --host)")
62 ("aux-port" :type integer
63 :documentation
"Port on auxiliary database server. (default: same as --port)")
64 ("aux-database" :type string
65 :documentation
"Name of auxiliary database. (default: same as --database)")
66 ("aux-user" :type string
67 :documentation
"Auxiliary database user. (default: same as --user)")
68 ("aux-password" :type string
69 :documentation
"Auxiliary database user's password. (default: same as --password)")
70 ("aux-use-ssl" :type string
71 :documentation
"Use SSL in auxiliary database connection. [yes|no|try] (default: same as --use-ssl)")))
73 (defparameter cli
:*get-image-options
*
74 '(("get-image" :action
#'cli
:get-image-action
75 :documentation
"(*) Get a single image from a .pictures file, print its trigger-time to stdout, and exit.")
76 ("count" :type integer
:initial-value
0
77 :documentation
"Image number in .pictures file.")
78 ("byte-position" :type integer
79 :documentation
"Byte position of image in .pictures file.")
81 :documentation
"Path to .pictures file.")
82 ("out" :type string
:initial-value
"phoros-get-image.png"
83 :documentation
"Path to to output .png file.")
84 ;; The way it should be had we two-dimensional arrays in postmodern:
85 ;;("bayer-pattern" :type string :list t :optional t :action :raw-bayer-pattern :documentation "The first pixels of the first row. Repeat this option to describe following row(s). Each pixel is to be interpreted as RGB hex string. Example: use #ff0000,#00ff00 if the first pixels in topmost row are red, green.")
86 ("bayer-pattern" :type string
:initial-value
"#ff0000,#00ff00" :action
:raw-bayer-pattern
87 :documentation
"The first pixels of the first row. Each pixel is to be interpreted as RGB hex string. Example: use #ff0000,#00ff00 if the first pixels in topmost row are red, green.")))
89 (defparameter cli
:*camera-hardware-options
*
90 '(("store-camera-hardware" :action
#'cli
:store-camera-hardware-action
91 :documentation
"(*) Put new camera-hardware data into the database; print camera-hardware-id to stdout.")
92 ("sensor-width-pix" :type integer
93 :documentation
"Width of camera sensor.")
94 ("sensor-height-pix" :type integer
95 :documentation
"Height of camera sensor.")
96 ("pix-size" :type string
97 :documentation
"Camera pixel size in millimetres (float).")
98 ("channels" :type integer
99 :documentation
"Number of color channels")
100 ("pix-depth" :type integer
:initial-value
255
101 :documentation
"Greatest possible pixel value.")
102 ("color-raiser" :type string
:initial-value
"1,1,1"
103 :action
:raw-color-raiser
104 :documentation
"Multipliers for the individual color components. Example: 1.2,1,.8 multiplies red by 1.2 and blue by 0.8.")
105 ;; The way it should be had we two-dimensional arrays in postmodern:
106 ;;("bayer-pattern" :type string :list t :optional t :action :raw-bayer-pattern :documentation "The first pixels of the first row. Repeat this option to describe following row(s). Each pixel is to be interpreted as RGB hex string. Example: use #ff0000,#00ff00 if the first pixels in topmost row are red, green.")
107 ("bayer-pattern" :type string
:optional t
108 :action
:raw-bayer-pattern
109 :documentation
"The first pixels of the first row. Each pixel is to be interpreted as RGB hex string. Example: use #ff0000,#00ff00 if the first pixels in topmost row are red, green.")
110 ("serial-number" :type string
111 :documentation
"Serial number.")
112 ("description" :type string
113 :documentation
"Description of camera.")
114 ("try-overwrite" :type boolean
:initial-value
"yes"
115 :documentation
"Overwrite matching camera-hardware record if any.")))
117 (defparameter cli
:*lens-options
*
118 '(("store-lens" :action
#'cli
:store-lens-action
119 :documentation
"(*) Put new lens data into the database; print lens-id to stdout.")
121 :documentation
"Nominal focal length in millimetres.")
122 ("serial-number" :type string
123 :documentation
"Serial number.")
124 ("description" :type string
125 :documentation
"Lens desription.")
126 ("try-overwrite" :type boolean
:initial-value
"yes"
127 :documentation
"Overwrite matching lens record if any.")))
129 (defparameter cli
:*generic-device-options
*
130 '(("store-generic-device" :action
#'cli
:store-generic-device-action
131 :documentation
"(*) Put a newly defined generic-device into the database; print generic-device-id to stdout.")
132 ("camera-hardware-id" :type integer
133 :documentation
"Numeric camera hardware id in database.")
134 ("lens-id" :type integer
135 :documentation
"Numeric lens id in database.")))
137 (defparameter cli
:*device-stage-of-life-options
*
138 '(("store-device-stage-of-life" :action
#'cli
:store-device-stage-of-life-action
139 :documentation
"(*) Put a newly defined device-stage-of-life into the database; print device-stage-of-life-id to stdout.")
140 ("recorded-device-id" :type string
141 :documentation
"Device id stored next to the measuring data.")
142 ("event-number" :type string
143 :documentation
"GPS event that triggers this generic device.")
144 ("generic-device-id" :type integer
145 :documentation
"Numeric generic-device id in database.")
146 ("vehicle-name" :type string
147 :documentation
"Descriptive name of vehicle.")
148 ("casing-name" :type string
149 :documentation
"Descriptive name of device casing.")
150 ("computer-name" :type string
151 :documentation
"Name of the recording device.")
152 ("computer-interface-name" :type string
153 :documentation
"Interface at device.")
154 ("mounting-date" :type string
155 :documentation
"Time this device constellation became effective. Format: \"2010-11-19T13:49+01\".")))
157 (defparameter cli
:*device-stage-of-life-end-options
*
158 '(("store-device-stage-of-life-end" :action
#'cli
:store-device-stage-of-life-end-action
159 :documentation
"(*) Put an end date to a device-stage-of-life in the database; print device-stage-of-life-id to stdout.")
160 ("device-stage-of-life-id" :type string
161 :documentation
"Id of the device-stage-of-life to put to an end.")
162 ("unmounting-date" :type string
163 :documentation
"Time this device constellation ceased to be effective. Format: \"2010-11-19T17:02+01\".")))
165 (defparameter cli
:*camera-calibration-options
*
166 '(("store-camera-calibration" :action
#'cli
:store-camera-calibration-action
167 :documentation
"(*) Put new camera-calibration into the database; print generic-device-id and calibration date to stdout.")
168 ("device-stage-of-life-id" :type string
169 :documentation
"This tells us what hardware this calibration is for.")
171 :documentation
"Date of calibration. Format: \"2010-11-19T13:49+01\".")
172 ("person" :type string
173 :documentation
"Person who did the calibration.")
174 ("main-description" :type string
175 :documentation
"Regarding this entire set of calibration data")
176 ("usable" :type string
:initial-value
"yes"
177 :documentation
"Set to no to just display images and inhibit photogrammetric calculations.")
178 ("debug" :type string
179 :documentation
"If true: not for production use; may be altered or deleted at any time.")
180 ("photogrammetry-version" :type string
181 :documentation
"Software version used to create this data.")
182 ("mounting-angle" :type integer
183 :documentation
"Head up = 0; right ear up = 90; left ear up = -90; head down = 180.")
184 ("inner-orientation-description" :type string
185 :documentation
"Comments regarding inner orientation calibration.")
186 ("c" :type string
:documentation
"Inner orientation: focal length.")
188 :documentation
"Inner orientation: principal point displacement.")
190 :documentation
"Inner orientation: principal point displacement.")
191 ("a1" :type string
:documentation
"Inner orientation: radial distortion.")
192 ("a2" :type string
:documentation
"Inner orientation: radial distortion.")
193 ("a3" :type string
:documentation
"Inner orientation: radial distortion.")
195 :documentation
"Inner orientation: asymmetric and tangential distortion.")
197 :documentation
"Inner orientation: asymmetric and tangential distortion.")
199 :documentation
"Inner orientation: affinity and shear distortion.")
201 :documentation
"Inner orientation: affinity and shear distortion.")
202 ("r0" :type string
:documentation
"Inner orientation.")
203 ("outer-orientation-description" :type string
204 :documentation
"Comments regarding outer orientation calibration.")
205 ("dx" :type string
:documentation
"Outer orientation; in metres.")
206 ("dy" :type string
:documentation
"Outer orientation; in metres.")
207 ("dz" :type string
:documentation
"Outer orientation; in metres.")
208 ("omega" :type string
:documentation
"Outer orientation.")
209 ("phi" :type string
:documentation
"Outer orientation.")
210 ("kappa" :type string
:documentation
"Outer orientation.")
211 ("boresight-description" :type string
212 :documentation
"Comments regarding boresight alignment calibration.")
213 ("b-dx" :type string
:documentation
"Boresight alignment.")
214 ("b-dy" :type string
:documentation
"Boresight alignment.")
215 ("b-dz" :type string
:documentation
"Boresight alignment.")
216 ("b-ddx" :type string
:documentation
"Boresight alignment.")
217 ("b-ddy" :type string
:Documentation
"Boresight alignment.")
218 ("b-ddz" :type string
:documentation
"Boresight alignment.")
219 ("b-rotx" :type string
:documentation
"Boresight alignment.")
220 ("b-roty" :type string
:documentation
"Boresight alignment.")
221 ("b-rotz" :type string
:documentation
"Boresight alignment.")
222 ("b-drotx" :type string
:documentation
"Boresight alignment.")
223 ("b-droty" :type string
:documentation
"Boresight alignment.")
224 ("b-drotz" :type string
:documentation
"Boresight alignment.")
226 :documentation
"X component of unit vector of vehicle ground plane.")
228 :documentation
"Y component of unit vector of vehicle ground plane.")
230 :documentation
"Z component of unit vector of vehicle ground plane.")
231 ("d" :type string
:documentation
"Distance of vehicle ground plane.")))
233 (defparameter cli
:*acquisition-project-options
*
234 '(("create-acquisition-project"
235 :type string
:action
#'cli
:create-acquisition-project-action
236 :documentation
"(*) Create a fresh set of canonically named data tables. The string argument is the acquisition project name. It will be stored in table sys-acquisition-project, field common-table-name, and used as a common part of the data table names.")
237 ("delete-acquisition-project"
238 :type string
:action
#'cli
:delete-acquisition-project-action
239 :documentation
"(*) Ask for confirmation, then delete acquisition project and all its measurements.")
240 ("delete-measurement"
241 :type integer
:action
#'cli
:delete-measurement-action
242 :documentation
"(*) Delete a measurement by its ID.")
243 ("list-acquisition-project"
244 :type string
:optional t
:action
#'cli
:list-acquisition-project-action
245 :documentation
"(*) List measurements of one acquisition project if its name is specified, or of all acquisition projects otherwise.")))
247 (defparameter cli
:*store-images-and-points-options
*
248 '((("store-images-and-points" #\s
) :type string
:action
#'cli
:store-images-and-points-action
249 :documentation
"(*) Link images to GPS points; store both into their respective DB tables. Images become linked to GPS points when their respective times differ by less than epsilon seconds, and when the respective events match. The string argument is the acquisition project name.")
250 (("directory" #\d
) :type string
251 :documentation
"Directory containing one set of measuring data.")
252 (("common-root" #\r) :type string
253 :documentation
"The root part of directory that is equal for all pojects. TODO: come up with some sensible default.")
254 ("epsilon" :type string
:initial-value
".001"
255 :documentation
"Difference in seconds below which two timestamps are considered equal.")
256 ("aggregate-events" :type nil
257 :documentation
"Put all GPS points in one bucket, disregarding any event numbers. Use this if you have morons setting up your generic-device. Hundreds of orphaned images may indicate this is the case.")
258 ("insert-footprints" :type string
:action
#'cli
:insert-footprints-action
259 :documentation
"(*) Update image footprints (the area on the ground that is most probably covered by the respective image). The string argument is the acquisition project name.")))
261 (defparameter cli
:*start-server-options
*
262 '(("server" :action
#'cli
:server-action
263 :documentation
"(*) Start HTTP presentation server. Entry URI is http://<host>:<port>/phoros/<presentation-project>. Asynchronously update lacking image footprints (which should have been done already using --insert-footprints).")
264 ("proxy-root" :type string
:initial-value
"phoros"
265 :documentation
"First directory element of the server URL. Must correspond to the proxy configuration if Phoros is hidden behind a proxy.")
266 ("address" :type string
267 :documentation
"Address (of local machine) server is to listen to. Default is listening to all available addresses.")
268 ("http-port" :type integer
:initial-value
8080
269 :documentation
"Port the presentation server listens on.")
270 (("common-root" #\r) :type string
:initial-value
"/"
271 :documentation
"The root part of directory that is equal for all pojects. TODO: come up with some sensible default.")
272 ("images" :type integer
:initial-value
4 :action
*number-of-images
*
273 :documentation
"Number of photos shown to the HTTP client.")
275 :type string
:list t
:optional t
:action
*aux-numeric-labels
*
276 :documentation
"Label for an element of auxiliary numeric data. Repeat if necessary.")
278 :type string
:list t
:optional t
:action
*aux-text-labels
*
279 :documentation
"Label for an element of auxiliary text data. Repeat if necessary.")
280 ("login-intro" :type string
:list t
:optional t
:action
*login-intro
*
281 :documentation
"Text to be shown below the login form. Use repeatedly to divide text into paragraphs. You can use HTML markup as long as it is legal inside <p>...</p>")))
283 (defparameter cli
:*presentation-project-options
*
284 '(("create-presentation-project"
285 :type string
:action
#'cli
:create-presentation-project-action
286 :documentation
"(*) Create a fresh presentation project which is to expose a set of measurements to certain users.")
287 ("delete-presentation-project"
288 :type string
:action
#'cli
:delete-presentation-project-action
289 :documentation
"(*) Ask for confirmation, then delete the presentation project including its table of user-generated points.")
290 ("list-presentation-project"
291 :type string
:optional t
:action
#'cli
:list-presentation-project-action
292 :documentation
"(*) List one presentation project if specified, or all presentation projects if not.")
293 ("add-to-presentation-project"
294 :type string
:action
#'cli
:add-to-presentation-project-action
295 :documentation
"(*) Add to the presentation project given either certain measurements or all measurements currently in a certain acquisition project.")
296 ("remove-from-presentation-project"
297 :type string
:action
#'cli
:remove-from-presentation-project-action
298 :documentation
"(*) Remove from the presentation project given either certain measurements or all measurements currently in a certain acquisition project.")
299 ("measurement-id" :type integer
:list t
:optional t
300 :documentation
"One measurement-id to add or remove. Repeat if necessary.")
301 ("acquisition-project"
303 :documentation
"The acquisition project whose measurements are to add or remove.")
304 ("redefine-trigger-function"
305 :type string
:action
#'cli
:redefine-trigger-function-action
306 :documentation
"(*) Change body of the trigger function that is fired on changes to the user point table connected to the specified presentation project.")
309 :documentation
"Path to a file containing the body of a PL/pgSQL trigger function. Any ocurrence of the strings ~0@*~A and ~1@*~A will be replaced by the name of the user point table/of the user line table respectively. Omit this option to reset that function to just emit a notice.")))
311 (defparameter cli
:*aux-view-options
*
313 :type string
:action
#'cli
:create-aux-view-action
314 :documentation
"(*) Connect table of auxiliary data with the specified presentation project by creating a view.")
317 :documentation
"Name of auxiliary table. It may reside either in Phoros' native database or in an auxiliary database (which is common to all projects). It must have a geometry column.")
318 ("coordinates-column"
319 :type string
:initial-value
"the-geom"
320 :documentation
"Name of the geometry column (which should have an index) in the auxiliary data table.")
322 :type string
:list t
:optional t
323 :documentation
"Name of a numeric column in the auxiliary data table. Repeat if necessary.")
325 :type string
:list t
:optional t
326 :documentation
"Name of a text column in the auxiliary data table. Repeat if necessary.")))
328 (defparameter cli
:*user-points-options
*
330 :type string
:action
#'cli
:get-user-points-action
331 :documentation
"(*) Save user points of presentation project.")
333 :type string
:action
#'cli
:store-user-points-action
334 :documentation
"(*) Store user points previously saved (using --get-user-points or download button in Web interface) into the presentation project named by the string argument.")
337 :documentation
"Path to GeoJSON file.")))
339 (defparameter cli
:*user-options
*
341 :type string
:action
#'cli
:create-user-action
342 :documentation
"(*) Create or update user (specified by their alphanummeric ID) of certain presentation projects, deleting any pre-existing permissions of that user.")
343 ("user-password" :type string
:documentation
"User's password.")
344 ("user-full-name" :type string
:documentation
"User's real name.")
346 :type string
:initial-value
"read"
347 :documentation
"User's permission on their projects. One of \"read\", \"write\", or \"admin\" where \"write\" is the same as \"read\" plus permission to add user points and delete them if written by themselves (or by unknown user); and \"admin\" is the same as \"write\" plus permission to delete points written by other users.")
348 ("presentation-project" :type string
:list t
:optional t
349 :documentation
"Presentation project the user is allowed to see. Repeat if necessary.")
351 :type string
:action
#'cli
:delete-user-action
352 :documentation
"(*) Delete user.")
354 :type string
:optional t
:action
#'cli
:list-user-action
355 :documentation
"(*) List the specified user with their presentation projects, or all users if no user is given.")))
357 (defparameter cli
:*options
*
358 (append cli
:*general-options
*
359 cli
:*db-connection-options
* cli
:*aux-db-connection-options
*
360 cli
:*get-image-options
*
361 cli
:*camera-hardware-options
* cli
:*lens-options
*
362 cli
:*generic-device-options
* cli
:*device-stage-of-life-options
*
363 cli
:*device-stage-of-life-end-options
*
364 cli
:*camera-calibration-options
*
365 cli
:*acquisition-project-options
*
366 cli
:*store-images-and-points-options
*
367 cli
:*start-server-options
*
368 cli
:*presentation-project-options
*
369 cli
:*aux-view-options
*
370 cli
:*user-points-options
*
374 "The UNIX command line entry point."
379 :error
"~A ~:[~;[Backtrace follows]~&~A~]~&"
381 hunchentoot
:*log-lisp-backtraces-p
*
382 (trivial-backtrace:print-backtrace c
:output nil
))
383 (format *error-output
* "~A~&" c
)
384 #+sbcl
(sb-ext:quit
:unix-status
1)))
386 (lambda (c) (cl-log:log-message
:warning
"~A" c
))))
387 (cffi:use-foreign-library phoml
)
388 (cli:compute-and-process-command-line-options cli
:*options
*)))
390 (defmacro cli
:with-options
((&rest options
) &body body
)
391 "Evaluate body with options bound to the values of the respective
392 command line arguments. Elements of options may be either symbols or
393 lists shaped like (symbol default)."
394 `(destructuring-bind (&key
,@options
&allow-other-keys
)
395 (cli:remaining-options
)
398 (defun cli:.phoros-options
()
399 "Return nil or a list of options from the most relevant .phoros file."
400 (let ((.phoros-path
(or (probe-file
403 :defaults
*default-pathname-defaults
*))
407 :directory
(directory-namestring
408 (user-homedir-pathname)))))))
410 (with-open-file (s .phoros-path
)
412 for line
= (read-line s nil nil
)
413 for option
= (string-trim " " line
)
415 when
(and (>= (length option
) 2)
416 (string= (subseq option
0 2) "--"))
419 (defun cli:remaining-options
()
420 "Return current set of options (from both .phoros config file and
421 command line) as an alist, and a list of the non-option arguments. In
422 passing, set global variables according to the --verbose option
424 (setf cli
:*command-line-arguments
*
425 (append (cli:.phoros-options
) cli
:*command-line-arguments
*))
428 (cli:process-command-line-options
429 cli
:*options
* cli
:*command-line-arguments
*))))
430 (destructuring-bind (&key verbose
&allow-other-keys
)
432 (setf *log-sql-p
* (logbitp 9 verbose
))
433 (setf *render-footprints-p
* (logbitp 10 verbose
))
434 (setf *postgresql-warnings
* (logbitp 11 verbose
))
435 ;;(setf hunchentoot:*show-lisp-backtraces-p* (logbitp 12 verbose)) ;doesn't seem to exist
436 ;; obeyed by both hunchentoot and Phoros' own logging:
437 (setf hunchentoot
:*log-lisp-backtraces-p
* (logbitp 13 verbose
))
438 ;; necessary for (ps ... (debug-info ...)...); doesn't work with
439 ;; (OpenLayers 2.10 AND Firefox 4), though:
440 (setf *use-multi-file-openlayers
* (logbitp 14 verbose
))
441 (setf *ps-print-pretty
* (logbitp 15 verbose
))
442 (setf hunchentoot
:*show-lisp-errors-p
* (logbitp 16 verbose
)))
443 (values-list options
)))
445 (defun cli:help-action
(&rest rest
)
446 "Print --help message."
447 (declare (ignore rest
))
448 (flet ((show-help-section
449 (options-specification
451 &rest introduction-paragraphs
)
452 "Show on *standard-output* help on options-specification
453 preceded by header and introduction-paragraphs."
454 (format *standard-output
*
455 "~@[~2&_____~72,,,'_@<~A~>~]~
456 ~@[~{~& ~{~@<~% ~1,72:;~A~> ~}~}~]"
459 #'(lambda (paragraph)
460 (cl-utilities:split-sequence-if
461 #'(lambda (x) (or (eql #\Space x
)
464 :remove-empty-subseqs t
))
465 introduction-paragraphs
))
466 (cli:show-option-help options-specification
)))
467 (format *standard-output
*
468 "~&Usage: phoros option[=value] ...~&~A~2&"
469 *phoros-long-description
*)
472 "Options marked (*) are mutually exclusive and must come before
474 "Options are also read from file <phoros-invocation-dir>/.phoros
475 or, if that doesn't exist, from file ~/.phoros. Config file
476 syntax: one option per line; leading or trailing spaces are
477 ignored; anything not beginning with -- is ignored."
478 "Command line options take precedence over config file options.")
480 cli
:*general-options
*
483 cli
:*db-connection-options
*
484 "Database Connection"
485 "Necessary for most operations.")
487 cli
:*aux-db-connection-options
*
488 "Auxiliary Database Connection"
489 "Connection parameters to the database containing auxiliary data.
490 Only needed for definition (--create-aux-view) and use (--server)
493 cli
:*get-image-options
*
494 "Examine .pictures File"
495 "Useful mostly for debugging purposes.")
497 cli
:*camera-hardware-options
*
498 "Camera Hardware Parameters"
499 "These do not include information on lenses or
504 "Stored primarily for human consumption; not used in
505 photogrammetric calculations.")
507 cli
:*generic-device-options
*
508 "Generic Device Definition"
509 "Basically, this is a particular camera fitted with a particular
512 cli
:*device-stage-of-life-options
*
513 "Device Stage-Of-Life Definition"
514 "A stage-of-life of a generic device is a possibly unfinished
515 period of time during which the mounting constellation of the
516 generic device remains unchanged.")
518 cli
:*device-stage-of-life-end-options
*
519 "Put An End To A Device's Stage-Of-Life"
520 "This should be done after any event that renders any portion of
521 the calibration data invalid. E.g.: accidental change of mounting
524 cli
:*camera-calibration-options
*
525 "Camera Calibration Parameters")
527 cli
:*acquisition-project-options
*
528 "Manage Acquisition Projects"
530 "An acquisition project is a set of measurements which
531 share a set of data tables and views named like ~(~A, ~A, ~A~)."
532 (point-data-table-name '<acquisition-project-name
>)
533 (image-data-table-name '<acquisition-project-name
>)
534 (aggregate-view-name '<acquisition-project-name
>)))
536 cli
:*store-images-and-points-options
*
537 "Store Measure Data")
539 cli
:*start-server-options
*
540 "Become A HTTP Presentation Server"
541 "Phoros is a Web server in its own right, but you can also put it
542 behind a proxy server to make it part of a larger Web site.
543 E.g., for Apache, load module proxy_http and use this
545 "ProxyPass /phoros http://127.0.0.1:8080/phoros"
546 "ProxyPassReverse /phoros http://127.0.0.1:8080/phoros")
548 cli
:*presentation-project-options
*
549 "Manage Presentation Projects"
550 "A presentation project is a set of measurements that can be
551 visited under a dedicated URL
552 \(http://<host>:<port>/phoros/<presentation-project>).
553 Its extent may or may not be equal to the extent of an
554 acquisition project."
555 "Presentation projects have a table of user points and a table of
556 user lines. The former is associated with a trigger which may be
557 defined to induce writing into the latter.")
559 cli
:*aux-view-options
*
560 "Connect A Presentation Project To A Table Of Auxiliary Data"
562 "Arbitrary data from tables not directly belonging to any
563 Phoros project can be connected to a presentation project by
564 means of a view named ~(~A~) with
565 columns coordinates (geometry), aux-numeric (null or array
566 of numeric), and aux-text (null or array of text)."
567 (aux-point-view-name '<presentation-project-name
>))
568 "The array elements of both aux-numeric and aux-text of auxiliary
569 points can then be incorporated into neighbouring user points
570 during user point creation."
572 "Also, a walk mode along auxiliary points becomes
573 available to the HTTP client. PL/pgSQL function ~(~A~) is
574 created to this end."
575 (thread-aux-points-function-name '<presentation-project-name
>))
576 "In order to be accessible by Phoros, auxiliary data must be
577 structured rather simple (a single table which has a geometry
578 column and some numeric and/or text columns). You may want to
579 create a simplifying view if your data looks more complicated.")
581 cli
:*user-points-options
*
583 "Backup/restore of user points; especially useful for getting
584 them through database upgrades.")
587 "Manage Presentation Project Users")))
589 (defun cli:version-action
(&rest rest
)
590 "Print --version message. TODO: OpenLayers, Proj4js version."
591 (declare (ignore rest
))
592 (cli:with-options
(verbose)
595 (format *standard-output
* "~&~A~&" (phoros-version)))
599 "~&~A version ~A~& ~A version ~A~& ~
600 Proj4 library: ~A~& PhoML version ~A~&"
603 (lisp-implementation-type) (lisp-implementation-version)
605 (phoml:get-version-number
))))))
607 (defun cli:licence-action
(&rest rest
)
608 "Print --licence boilerplate."
609 (declare (ignore rest
))
610 (format *standard-output
* "~&~A~&" *phoros-licence
*))
612 (defun cli:check-db-action
(&rest rest
)
613 "Tell us if databases are accessible."
614 (declare (ignore rest
))
615 (cli:with-options
(host (aux-host host
) port
(aux-port port
)
616 database
(aux-database database
)
617 (user "") (aux-user user
)
618 (password "") (aux-password password
)
619 use-ssl
(aux-use-ssl use-ssl
))
620 (format *error-output
*
621 "Checking database ~A at ~A:~D and ~
622 auxiliary database ~A at ~A:~D.~%"
624 aux-database aux-host aux-port
)
626 (check-db (list database user password host
628 :use-ssl
(s-sql:from-sql-name use-ssl
)))
629 (check-db (list aux-database aux-user aux-password aux-host
631 :use-ssl
(s-sql:from-sql-name aux-use-ssl
))))
632 (format *error-output
*
633 "Both are accessible.~%"))))
635 (defun cli:check-dependencies-action
(&rest rest
)
636 "Say OK if the necessary external dependencies are available."
637 (declare (ignore rest
))
638 (check-dependencies))
640 (defun cli:nuke-all-tables-action
(&rest rest
)
641 "Drop the bomb. Ask for confirmation first."
642 (declare (ignore rest
))
643 (cli:with-options
(host port database
(user "") (password "") use-ssl
645 (launch-logger log-dir
)
647 "You asked me to delete anything in database ~A at ~A:~D. ~
650 (with-connection (list database user password host
:port port
651 :use-ssl
(s-sql:from-sql-name use-ssl
))
652 (muffle-postgresql-warnings)
655 :db-sys
"Nuked database ~A at ~A:~D. Back to square one!"
656 database host port
))))
658 (defun cli:create-sys-tables-action
(&rest rest
)
659 "Make a set of sys-* tables. Ask for confirmation first."
660 (declare (ignore rest
))
661 (cli:with-options
(host port database
(user "") (password "") use-ssl
663 (launch-logger log-dir
)
665 "You asked me to create a set of sys-* tables ~
666 in database ~A at ~A:~D. ~
667 Make sure you know what you are doing. Proceed?"
669 (with-connection (list database user password host
:port port
670 :use-ssl
(s-sql:from-sql-name use-ssl
))
671 (muffle-postgresql-warnings)
674 :db-sys
"Created a fresh set of system tables in database ~A at ~A:~D."
675 database host port
))))
677 (defun cli:create-acquisition-project-action
(common-table-name)
678 "Make a set of data tables."
679 (cli:with-options
(host port database
(user "") (password "") use-ssl
681 (launch-logger log-dir
)
682 (with-connection (list database user password host
:port port
683 :use-ssl
(s-sql:from-sql-name use-ssl
))
684 (muffle-postgresql-warnings)
685 (create-acquisition-project common-table-name
))
688 "Created a fresh acquisition project by the name of ~A ~
689 in database ~A at ~A:~D."
690 common-table-name database host port
)))
692 (defun cli:delete-acquisition-project-action
(common-table-name)
693 "Delete an acquisition project."
694 (cli:with-options
(host port database
(user "") (password "") use-ssl
696 (launch-logger log-dir
)
698 "You asked me to delete acquisition-project ~A ~
699 (including all its measurements) ~
700 from database ~A at ~A:~D. Proceed?"
701 common-table-name database host port
)
702 (with-connection (list database user password host
:port port
703 :use-ssl
(s-sql:from-sql-name use-ssl
))
704 (muffle-postgresql-warnings)
705 (let ((project-did-exist-p
706 (delete-acquisition-project common-table-name
)))
709 "~:[Tried to delete nonexistent~;Deleted~] ~
710 acquisition project ~A from database ~A at ~A:~D."
711 project-did-exist-p common-table-name database host port
))))))
713 (defun cli:delete-measurement-action
(measurement-id)
714 "Delete a measurement by its measurement-id."
715 (cli:with-options
(host port database
(user "") (password "") use-ssl
717 (launch-logger log-dir
)
718 (with-connection (list database user password host
:port port
719 :use-ssl
(s-sql:from-sql-name use-ssl
))
720 (let ((measurement-did-exist-p
721 (delete-measurement measurement-id
)))
724 "~:[Tried to delete nonexistent~;Deleted~] ~
725 measurement with ID ~A from database ~A at ~A:~D."
726 measurement-did-exist-p measurement-id database host port
)))))
728 (defun cli:list-acquisition-project-action
(&optional common-table-name
)
729 "List content of acquisition projects."
730 (cli:with-options
(host port database
(user "") (password "") use-ssl
)
731 (with-connection (list database user password host
:port port
732 :use-ssl
(s-sql:from-sql-name use-ssl
))
734 (if (stringp common-table-name
)
739 'sys-acquisition-project.acquisition-project-id
744 'sys-acquisition-project
:natural
:left-join
'sys-measurement
745 :where
(:= 'common-table-name common-table-name
))
751 'sys-acquisition-project.acquisition-project-id
756 'sys-acquisition-project
:natural
:left-join
'sys-measurement
)
757 'common-table-name
'measurement-id
)))))
759 *standard-output
* " | " content
760 "Acquisition Project" "ID" "Meas. ID" "Directory" "Cartesian CS")))))
762 (defun cli:store-images-and-points-action
(common-table-name)
763 "Put data into the data tables."
764 (cli:with-options
(host port database
(user "") (password "") use-ssl
766 directory epsilon common-root aggregate-events
)
767 (launch-logger log-dir
)
768 (with-connection (list database user password host
:port port
769 :use-ssl
(s-sql:from-sql-name use-ssl
))
772 "Start: storing data from ~A into acquisition project ~A ~
773 in database ~A at ~A:~D."
774 directory common-table-name database host port
)
775 (store-images-and-points common-table-name directory
776 :epsilon
(read-from-string epsilon nil
)
777 :root-dir common-root
778 :aggregate-events aggregate-events
)
781 "Finish: storing data from ~A into acquisition project ~A ~
782 in database ~A at ~A:~D."
783 directory common-table-name database host port
)
784 (let ((points-deleted
785 (delete-imageless-points common-table-name
)))
788 "Checked acquisition project ~A in database ~A at ~A:~D ~
789 for imageless points~[; found none.~;. Found and deleted ~:*~D.~]"
790 common-table-name database host port
793 (defun cli:insert-footprints-action
(common-table-name)
794 "Update image footprints."
795 (cli:with-options
(host port database
(user "") (password "") use-ssl
797 (launch-logger log-dir
)
798 (with-connection (list database user password host
:port port
799 :use-ssl
(s-sql:from-sql-name use-ssl
))
802 "Updating image footprints of acquisition project ~A ~
803 in database ~A at ~A:~D."
804 common-table-name database host port
)
805 (let ((number-of-updated-footprints
806 (insert-footprints common-table-name
)))
809 "~:[All image footprints belonging to acquisition project ~*~A ~
810 in database ~A at ~A:~D are up to date.~
811 ~;Updated ~D image footprint~:P of acquisition project ~A ~
812 in database ~A at ~A:~D.~]"
813 (plusp number-of-updated-footprints
) number-of-updated-footprints
814 common-table-name database host port
)))))
816 ;;; We don't seem to have two-dimensional arrays in postmodern
817 ;;(defun cli:canonicalize-bayer-pattern (raw &optional sql-string-p)
818 ;; "Convert list of strings of comma-separated hex color strings (ex: #ff0000 for red) into an array of integers. If sql-string-p is t, convert it into a string in SQL syntax."
825 ;; for hex-color in (cl-utilities:split-sequence #\, row)
827 ;; (let ((*read-base* 16))
828 ;; (assert (eql (elt hex-color 0) #\#) () "~A is not a valid color" hex-color)
830 ;; (concatenate 'string
831 ;; (subseq hex-color 5 7)
832 ;; (subseq hex-color 3 5)
833 ;; (subseq hex-color 1 3))
835 ;; (rows (length array))
836 ;; (columns (length (elt array 0))))
838 ;; (format nil "{~{{~{~A~#^,~}}~}}" array)
839 ;; (make-array (list rows columns) :initial-contents array)))))
841 (defun cli:canonicalize-bayer-pattern
(raw &optional sql-string-p
)
842 "Convert a string of comma-separated hex color strings (ex: #ff0000
843 for red) into a vector of integers. If sql-string-p is t, convert it
844 into a string in SQL syntax."
848 for hex-color in
(cl-utilities:split-sequence
#\
, raw
)
850 (let ((*read-base
* 16))
851 (assert (eql (elt hex-color
0) #\
#)
852 () "~A is not a valid color" hex-color
)
855 (subseq hex-color
5 7)
856 (subseq hex-color
3 5)
857 (subseq hex-color
1 3))
859 (columns (length vector
)))
861 (format nil
"{~{~A~#^,~}}" vector
)
862 (make-array (list columns
) :initial-contents vector
)))))
864 (defun cli:canonicalize-color-raiser
(raw &optional sql-string-p
)
865 "Convert string of comma-separated numbers into a vector. If
866 sql-string-p is t, convert it into a string in SQL syntax."
870 for multiplier in
(cl-utilities:split-sequence
#\
, raw
:count
3)
872 (read-from-string multiplier nil
))))
874 (format nil
"{~{~A~#^,~}}" vector
)
875 (make-array '(3) :initial-contents vector
)))))
877 (defun cli:store-stuff
(store-function)
878 "Open database connection and call store-function on command line
879 options. Print return values to *standard-output*. store-function
880 should only take keyargs."
881 (let ((command-line-options
882 (cli:remaining-options
)))
883 (setf (getf command-line-options
:bayer-pattern
)
884 (cli:canonicalize-bayer-pattern
885 (getf command-line-options
:raw-bayer-pattern
) t
)
886 (getf command-line-options
:color-raiser
)
887 (cli:canonicalize-color-raiser
888 (getf command-line-options
:raw-color-raiser
) t
))
889 (destructuring-bind (&key host port database
(user "") (password "") use-ssl
890 log-dir
&allow-other-keys
)
892 (launch-logger log-dir
)
893 (with-connection (list database user password host
:port port
894 :use-ssl
(s-sql:from-sql-name use-ssl
))
895 (format *standard-output
* "~&~{~D~#^ ~}~%"
897 (apply store-function
:allow-other-keys t
898 command-line-options
)))))))
900 (defun cli:store-camera-hardware-action
(&rest rest
)
901 (declare (ignore rest
))
902 (cli:store-stuff
#'store-camera-hardware
))
904 (defun cli:store-lens-action
(&rest rest
)
905 (declare (ignore rest
))
906 (cli:store-stuff
#'store-lens
))
908 (defun cli:store-generic-device-action
(&rest rest
)
909 (declare (ignore rest
))
910 (cli:store-stuff
#'store-generic-device
))
912 (defun cli:store-device-stage-of-life-action
(&rest rest
)
913 (declare (ignore rest
))
914 (cli:store-stuff
#'store-device-stage-of-life
))
916 (defun cli:store-device-stage-of-life-end-action
(&rest rest
)
917 (declare (ignore rest
))
918 (cli:store-stuff
#'store-device-stage-of-life-end
))
920 (defun cli:store-camera-calibration-action
(&rest rest
)
921 (declare (ignore rest
))
922 (cli:store-stuff
#'store-camera-calibration
))
924 (defun cli:get-image-action
(&rest rest
)
925 "Output a PNG file extracted from a .pictures file; print its
926 trigger-time to stdout."
927 (declare (ignore rest
))
928 (cli:with-options
(count byte-position in out
929 raw-bayer-pattern raw-color-raiser
)
930 (with-open-file (out-stream out
:direction
:output
931 :element-type
'unsigned-byte
932 :if-exists
:supersede
)
935 (send-png out-stream in byte-position
937 (cli:canonicalize-bayer-pattern raw-bayer-pattern
)
939 (cli:canonicalize-color-raiser raw-color-raiser
))
940 (send-nth-png count out-stream in
942 (cli:canonicalize-bayer-pattern raw-bayer-pattern
)
944 (cli:canonicalize-color-raiser raw-color-raiser
)))))
945 (format *standard-output
*
946 "~&~A~%" (timestring (utc-from-unix trigger-time
)))))))
948 (defun cli:create-presentation-project-action
(presentation-project-name)
949 "Make a presentation project."
950 (cli:with-options
(host port database
(user "") (password "") use-ssl
952 (launch-logger log-dir
)
953 (with-connection (list database user password host
:port port
954 :use-ssl
(s-sql:from-sql-name use-ssl
))
955 (muffle-postgresql-warnings)
956 (let ((fresh-project-p
957 (create-presentation-project presentation-project-name
)))
960 "~:[Tried to recreate an existing~;Created a fresh~] ~
961 presentation project by the name of ~A in database ~A at ~A:~D."
962 fresh-project-p presentation-project-name database host port
)))))
964 (defun cli:delete-presentation-project-action
(presentation-project-name)
965 "Delete a presentation project."
966 (cli:with-options
(host port database
(user "") (password "") use-ssl
968 (launch-logger log-dir
)
970 "You asked me to delete presentation-project ~A ~
971 (including its tables of user-defined points and lines, ~
972 ~A and ~A respectively) from database ~A at ~A:~D. Proceed?"
973 presentation-project-name
974 (user-point-table-name presentation-project-name
)
975 (user-line-table-name presentation-project-name
)
977 (with-connection (list database user password host
:port port
978 :use-ssl
(s-sql:from-sql-name use-ssl
))
979 (muffle-postgresql-warnings)
980 (let ((project-did-exist-p
981 (delete-presentation-project presentation-project-name
)))
984 "~:[Tried to delete nonexistent~;Deleted~] ~
985 presentation project ~A from database ~A at ~A:~D."
986 project-did-exist-p presentation-project-name
987 database host port
))))))
989 (defun cli:add-to-presentation-project-action
(presentation-project-name)
990 "Add measurements to a presentation project."
991 (cli:with-options
(host port database
(user "") (password "") use-ssl
993 measurement-id acquisition-project
)
994 (launch-logger log-dir
)
995 (with-connection (list database user password host
:port port
996 :use-ssl
(s-sql:from-sql-name use-ssl
))
997 (add-to-presentation-project presentation-project-name
998 :measurement-ids measurement-id
999 :acquisition-project acquisition-project
))
1002 "Added ~@[measurement-ids ~{~D~#^, ~}~]~
1003 ~@[all measurements from acquisition project ~A~] ~
1004 to presentation project ~A in database ~A at ~A:~D."
1005 measurement-id acquisition-project
1006 presentation-project-name database host port
)))
1008 (defun cli:remove-from-presentation-project-action
(presentation-project-name)
1009 "Add measurements to a presentation project."
1010 (cli:with-options
(host port database
(user "") (password "") use-ssl
1012 measurement-id acquisition-project
)
1013 (launch-logger log-dir
)
1014 (with-connection (list database user password host
:port port
1015 :use-ssl
(s-sql:from-sql-name use-ssl
))
1016 (remove-from-presentation-project
1017 presentation-project-name
1018 :measurement-ids measurement-id
1019 :acquisition-project acquisition-project
))
1022 "Removed ~@[measurement-ids ~{~D~#^, ~}~]~
1023 ~@[all measurements that belong to acquisition project ~A~] ~
1024 from presentation project ~A in database ~A at ~A:~D."
1025 measurement-id acquisition-project
1026 presentation-project-name database host port
)))
1028 (defun cli:redefine-trigger-function-action
(presentation-project-name)
1029 "Recreate an SQL trigger function that is fired on changes to the
1030 user point table, and fire it once."
1031 (cli:with-options
(host port database
(user "") (password "") use-ssl
1034 (launch-logger log-dir
)
1035 (with-connection (list database user password host
:port port
1036 :use-ssl
(s-sql:from-sql-name use-ssl
))
1037 (muffle-postgresql-warnings)
1039 (make-array '(1) :adjustable t
:fill-pointer
0
1040 :element-type
'character
)))
1042 (with-open-file (stream plpgsql-body
)
1044 for c
= (read-char stream nil
)
1046 do
(vector-push-extend c body-text
))
1047 (create-presentation-project-trigger-function
1048 presentation-project-name
1050 (s-sql:to-sql-name
(user-point-table-name
1051 presentation-project-name
))
1052 (s-sql:to-sql-name
(user-line-table-name
1053 presentation-project-name
))))
1054 (create-presentation-project-trigger-function
1055 presentation-project-name
))
1056 (fire-presentation-project-trigger-function presentation-project-name
)
1059 "Defined (and fired once) ~
1060 a trigger function associatad with user point table of ~
1061 presentation project ~A in database ~A at ~A:~D to ~
1062 ~:[perform a minimal default action.~;perform the body given ~
1063 in file ~:*~A, whose content is is:~&~A~]"
1064 presentation-project-name database host port
1065 plpgsql-body body-text
)))))
1067 (defun cli:create-aux-view-action
(presentation-project-name)
1068 "Connect presentation project to an auxiliary data table by means of
1070 (cli:with-options
(host (aux-host host
) port
(aux-port port
)
1071 database
(aux-database database
)
1072 (user "") (aux-user user
)
1073 (password "") (aux-password password
)
1074 use-ssl
(aux-use-ssl use-ssl
)
1076 coordinates-column numeric-column text-column
1078 (launch-logger log-dir
)
1079 (with-connection (list aux-database aux-user aux-password aux-host
1081 :use-ssl
(s-sql:from-sql-name aux-use-ssl
))
1082 (let ((aux-view-in-phoros-db-p
1084 (list host port database user password use-ssl
)
1085 (list aux-host aux-port aux-database
1086 aux-user aux-password aux-use-ssl
)))
1088 (aux-view-exists-p presentation-project-name
)))
1090 aux-view-in-phoros-db-p
1092 "I'm going to ~:[create~;replace~] a view named ~A ~
1093 in database ~A at ~A:~D. Proceed?"
1095 (aux-point-view-name presentation-project-name
)
1096 aux-database aux-host aux-port
))
1097 (muffle-postgresql-warnings)
1098 (when aux-view-exists-p
1099 (delete-aux-view presentation-project-name
))
1100 (apply #'create-aux-view
1101 presentation-project-name
1102 :coordinates-column
(s-sql:to-sql-name coordinates-column
)
1103 :numeric-columns numeric-column
1104 :text-columns text-column
1106 (cli:remaining-options
))
1107 (add-spherical-mercator-ref)
1110 "~:[Created~;Updated~] in database ~A at ~A:~D a view called ~A ~
1111 into table (of auxiliary data) ~A. Coordinates column is ~A. ~
1112 ~:[No numeric columns.~;Numeric column(s): ~:*~{~A~#^, ~}.~] ~
1113 ~:[No text columns.~;Text column(s): ~:*~{~A~#^, ~}.~] ~
1114 Also, ~0@*~:[created~;recreated~] in the same database a ~
1115 function called ~9@*~A."
1117 aux-database aux-host aux-port
1118 (aux-point-view-name presentation-project-name
)
1119 aux-table coordinates-column
1120 numeric-column text-column
1121 (thread-aux-points-function-name presentation-project-name
)))))))
1123 (defun cli:store-user-points-action
(presentation-project)
1124 "Store user points from a GeoJSON file into database."
1125 (cli:with-options
(host port database
(user "") (password "") use-ssl
1128 (launch-logger log-dir
)
1129 (with-connection (list database user password host
:port port
1130 :use-ssl
(s-sql:from-sql-name use-ssl
))
1131 (muffle-postgresql-warnings)
1132 (multiple-value-bind
1133 (points-stored points-already-in-db points-tried zombie-users
)
1134 (apply #'store-user-points presentation-project
1136 (cli:remaining-options
))
1139 "Tried to store the ~D user point~:P I found in file ~A ~
1140 into presentation project ~A in database ~A at ~A:~D. ~
1141 ~:[~:[~D~;None~*~]~;All~2*~] of them ~:[were~;was~] ~
1143 ~:[~:[~:[~D points have~;1 point has~*~]~;Nothing has~2*~]~
1144 ~;All points tried have~3*~] ~
1145 been added to the user point table. ~
1146 ~15@*~@[I didn't know ~14@*~[~;a~:;any of the~] user~14@*~P ~
1147 called ~{~A~#^, ~}; treated them as zombie~14@*~P.~]"
1149 (truename json-file
)
1150 presentation-project database host port
1151 (= points-already-in-db points-tried
)
1152 (zerop points-already-in-db
)
1153 points-already-in-db
1154 (<= points-already-in-db
1)
1155 (= points-stored points-tried
)
1156 (zerop points-stored
)
1159 (length zombie-users
) ;arg 14
1160 zombie-users
))))) ;arg 15
1162 (defun cli:get-user-points-action
(presentation-project)
1163 "Save user points of presentation project into a GeoJSON file."
1164 (cli:with-options
(host port database
(user "") (password "") use-ssl
1167 (launch-logger log-dir
)
1168 (with-connection (list database user password host
:port port
1169 :use-ssl
(s-sql:from-sql-name use-ssl
))
1170 (multiple-value-bind (user-points user-point-count
)
1171 (get-user-points (user-point-table-name presentation-project
))
1172 (assert json-file
()
1173 "Don't know where to store. Try option --json-file")
1174 (unless (zerop user-point-count
)
1175 (with-open-file (stream json-file
1177 :if-exists
:supersede
)
1178 (princ user-points stream
)))
1181 "~[There are no user points to get from presentation project ~A in ~
1182 database ~A at ~A:~D. Didn't touch any file.~
1183 ~:;~:*Saved ~D user point~:P from presentation project ~A in ~
1184 database ~A at ~A:~D into file ~A.~]"
1186 presentation-project database host port
1187 (ignore-errors (truename json-file
)))))))
1189 (defun cli:create-user-action
(presentation-project-user)
1190 "Define a new user."
1192 (cli:with-options
(host port database
(user "") (password "") use-ssl
1194 presentation-project
1195 user-full-name user-role
)
1196 (launch-logger log-dir
)
1197 (with-connection (list database user password host
:port port
1198 :use-ssl
(s-sql:from-sql-name use-ssl
))
1200 (apply #'create-user
1201 presentation-project-user
1203 :presentation-projects presentation-project
1204 (cli:remaining-options
))))
1206 :db-dat
;TODO: We're listing nonexistent p-projects here as well.
1207 "~:[Updated~;Created~] user ~A (~A) who has ~A access ~
1208 to ~:[no ~;~]presentation project(s)~:*~{ ~A~#^,~} ~
1209 in database ~A at ~A:~D."
1210 fresh-user-p presentation-project-user
1211 user-full-name user-role
1212 presentation-project database host port
))))
1214 (defun cli:delete-user-action
(presentation-project-user)
1215 "Delete a presentation project user."
1216 (cli:with-options
(host port database
(user "") (password "") use-ssl
1218 (launch-logger log-dir
)
1219 (with-connection (list database user password host
:port port
1220 :use-ssl
(s-sql:from-sql-name use-ssl
))
1221 (let ((user-did-exist-p
1222 (delete-user presentation-project-user
)))
1225 "~:[Tried to delete nonexistent~;Deleted~] ~
1226 presentation project user ~A from database ~A at ~A:~D."
1227 user-did-exist-p presentation-project-user database host port
)))))
1229 (defun cli:list-user-action
(&optional presentation-project-user
)
1230 "List presentation project users together with their presentation
1232 (cli:with-options
(host port database
(user "") (password "") use-ssl
)
1233 (with-connection (list database user password host
:port port
1234 :use-ssl
(s-sql:from-sql-name use-ssl
))
1236 (if (stringp presentation-project-user
)
1240 'user-name
'sys-user.user-id
'user-password
1241 'user-full-name
'presentation-project-name
1242 'sys-user-role.presentation-project-id
'user-role
1243 :from
'sys-user
'sys-user-role
'sys-presentation-project
1244 :where
(:and
(:= 'sys-user-role.presentation-project-id
1245 'sys-presentation-project.presentation-project-id
)
1246 (:= 'sys-user.user-id
'sys-user-role.user-id
)
1247 (:= 'user-name presentation-project-user
)))
1252 'user-name
'sys-user.user-id
'user-password
1253 'user-full-name
'presentation-project-name
1254 'sys-user-role.presentation-project-id
'user-role
1255 :from
'sys-user
'sys-user-role
'sys-presentation-project
1256 :where
(:and
(:= 'sys-user-role.presentation-project-id
1257 'sys-presentation-project.presentation-project-id
)
1258 (:= 'sys-user.user-id
'sys-user-role.user-id
)))
1261 *standard-output
* " | " content
1262 "User" "ID" "Password" "Full Name" "Presentation Project" "ID" "Role")))))
1264 (defun cli:list-presentation-project-action
(&optional presentation-project
)
1265 "List content of presentation projects."
1266 (cli:with-options
(host port database
(user "") (password "") use-ssl
)
1267 (with-connection (list database user password host
:port port
1268 :use-ssl
(s-sql:from-sql-name use-ssl
))
1270 (if (stringp presentation-project
)
1274 'presentation-project-name
1275 'sys-presentation-project.presentation-project-id
1276 'sys-presentation.measurement-id
1278 'sys-measurement.acquisition-project-id
1280 'sys-presentation-project
'sys-presentation
1281 'sys-measurement
'sys-acquisition-project
1283 (:and
(:= 'sys-presentation-project.presentation-project-id
1284 'sys-presentation.presentation-project-id
)
1285 (:= 'sys-presentation.measurement-id
1286 'sys-measurement.measurement-id
)
1287 (:= 'sys-measurement.acquisition-project-id
1288 'sys-acquisition-project.acquisition-project-id
)
1289 (:= 'presentation-project-name
1290 presentation-project
)))
1291 'presentation-project-name
1292 'sys-presentation.measurement-id
))
1296 'presentation-project-name
1297 'sys-presentation-project.presentation-project-id
1298 'sys-presentation.measurement-id
1300 'sys-measurement.acquisition-project-id
1302 'sys-presentation-project
'sys-presentation
1303 'sys-measurement
'sys-acquisition-project
1305 (:and
(:= 'sys-presentation-project.presentation-project-id
1306 'sys-presentation.presentation-project-id
)
1307 (:= 'sys-presentation.measurement-id
1308 'sys-measurement.measurement-id
)
1309 (:= 'sys-measurement.acquisition-project-id
1310 'sys-acquisition-project.acquisition-project-id
)))
1311 'presentation-project-name
1312 'sys-presentation.measurement-id
)))))
1314 *standard-output
* " | " content
1315 "Presentation Project" "ID" "Meas. ID" "Acquisition Project" "ID")))))
1317 (defun cli:format-table
(destination column-separator content
1318 &rest column-headers
)
1319 "Print content (a list of lists) to destination."
1321 (append (list column-headers
) (list ()) content
))
1322 (number-of-rows (length column-headers
))
1325 for column from
0 below number-of-rows collect
1328 maximize
(length (format nil
"~A" (nth column row
)))))))
1331 for width in widths collect
1332 (make-string width
:initial-element
#\-
)))
1335 (format destination
"~&~{~VA~1,#^~A~}~%"
1337 for width in widths and field in row
1338 collect width collect field collect column-separator
)))))
1340 (defun cli:server-action
(&rest rest
)
1341 "Start the HTTP server."
1342 (declare (ignore rest
))
1343 (cli:with-options
(host (aux-host host
) port
(aux-port port
)
1344 database
(aux-database database
)
1345 (user "") (aux-user user
)
1346 (password "") (aux-password password
)
1347 use-ssl
(aux-use-ssl use-ssl
)
1349 proxy-root http-port address common-root
)
1350 (launch-logger log-dir
)
1351 (setf *postgresql-credentials
*
1352 (list database user password host
:port port
1353 :use-ssl
(s-sql:from-sql-name use-ssl
)))
1354 (setf *postgresql-aux-credentials
*
1355 (list aux-database aux-user aux-password aux-host
:port aux-port
1356 :use-ssl
(s-sql:from-sql-name aux-use-ssl
)))
1357 (insert-all-footprints *postgresql-credentials
*)
1358 (delete-all-imageless-points *postgresql-credentials
*)
1359 (start-server :proxy-root proxy-root
1360 :http-port http-port
:address address
1361 :common-root common-root
)
1364 "HTTP server listens on port ~D ~
1365 of ~:[all available addresses~;address ~:*~A~]. ~
1366 It expects to be called with a URL path root of /~A/. ~
1367 Phoros database is ~A on ~A:~D. Auxiliary database is ~A on ~A:~D. ~
1368 Files are searched for in ~A."
1372 aux-database aux-host aux-port