cli.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011 Bert Burgemeister
   3 ;;;
   4 ;;; This program is free software; you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation; either version 2 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License along
  15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
  16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17
  18
  19 ;;;; The UNIX command line interface
  20
  21 ;; TODO: options that have a function as their :action seem to mask earlier options.  Fix or document.
  22
  23 (in-package :phoros)
  24
  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 bits set in this integer, emit various kinds of debugging output. ")
  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 #'check-db-action
  37      :documentation "Check connection to databases (including auxiliary if applicable) and exit.")
  38     ("check-dependencies" :action #'check-dependencies-action
  39      :documentation "Check presence of dependencies on local system and exit.")
  40     ("nuke-all-tables" :action #'nuke-all-tables-action
  41      :documentation "Ask for confirmation, then delete anything in database and exit.")
  42     ("create-sys-tables" :action #'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.")))
  44
  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]")))
  58
  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.  (defaul: 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)")))
  72
  73 (defparameter *cli-get-image-options*
  74   '(("get-image" :action #'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.")
  80     ("in" :type string
  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.")))
  88
  89 (defparameter *cli-camera-hardware-options*
  90   '(("store-camera-hardware" :action #'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.")))
 116
 117 (defparameter *cli-lens-options*
 118   '(("store-lens" :action #'store-lens-action
 119      :documentation "Put new lens data into the database; print lens-id to stdout.")
 120     ("c" :type string
 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.")))
 128
 129 (defparameter *cli-generic-device-options*
 130   '(("store-generic-device" :action #'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.")))
 136
 137 (defparameter *cli-device-stage-of-life-options*
 138   '(("store-device-stage-of-life" :action #'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\".")))
 156
 157 (defparameter *cli-device-stage-of-life-end-options*
 158   '(("store-device-stage-of-life-end" :action #'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\".")))
 164
 165 (defparameter *cli-camera-calibration-options*
 166   '(("store-camera-calibration" :action #'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.")
 170     ("date" :type string
 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     ("debug" :type string
 177      :documentation "If true: not for production use; may be altered or deleted at any time.")
 178     ("photogrammetry-version" :type string
 179      :documentation "Software version used to create this data.")
 180     ("mounting-angle" :type integer
 181      :documentation "Head up = 0; right ear up = 90; left ear up = -90; head down = 180.")
 182     ("inner-orientation-description" :type string
 183      :documentation "Comments regarding inner orientation calibration.")
 184     ("c" :type string :documentation "Inner orientation: focal length.")
 185     ("xh" :type string
 186      :documentation "Inner orientation: principal point displacement.")
 187     ("yh" :type string
 188      :documentation "Inner orientation: principal point displacement.")
 189     ("a1" :type string :documentation "Inner orientation: radial distortion.")
 190     ("a2" :type string :documentation "Inner orientation: radial distortion.")
 191     ("a3" :type string :documentation "Inner orientation: radial distortion.")
 192     ("b1" :type string
 193      :documentation "Inner orientation: asymmetric and tangential distortion.")
 194     ("b2" :type string
 195      :documentation "Inner orientation: asymmetric and tangential distortion.")
 196     ("c1" :type string
 197      :documentation "Inner orientation: affinity and shear distortion.")
 198     ("c2" :type string
 199      :documentation "Inner orientation: affinity and shear distortion.")
 200     ("r0" :type string :documentation "Inner orientation.")
 201     ("outer-orientation-description" :type string
 202      :documentation "Comments regarding outer orientation calibration.")
 203     ("dx" :type string :documentation "Outer orientation; in metres.")
 204     ("dy" :type string :documentation "Outer orientation; in metres.")
 205     ("dz" :type string :documentation "Outer orientation; in metres.")
 206     ("omega" :type string :documentation "Outer orientation.")
 207     ("phi" :type string :documentation "Outer orientation.")
 208     ("kappa" :type string :documentation "Outer orientation.")
 209     ("boresight-description" :type string
 210      :documentation "Comments regarding boresight alignment calibration.")
 211     ("b-dx" :type string :documentation "Boresight alignment.")
 212     ("b-dy" :type string :documentation "Boresight alignment.")
 213     ("b-dz" :type string :documentation "Boresight alignment.")
 214     ("b-ddx" :type string :documentation "Boresight alignment.")
 215     ("b-ddy" :type string :Documentation "Boresight alignment.")
 216     ("b-ddz" :type string :documentation "Boresight alignment.")
 217     ("b-rotx" :type string :documentation "Boresight alignment.")
 218     ("b-roty" :type string :documentation "Boresight alignment.")
 219     ("b-rotz" :type string :documentation "Boresight alignment.")
 220     ("b-drotx" :type string :documentation "Boresight alignment.")
 221     ("b-droty" :type string :documentation "Boresight alignment.")
 222     ("b-drotz" :type string :documentation "Boresight alignment.")
 223     ("nx" :type string
 224      :documentation "X component of unit vector of vehicle ground plane.")
 225     ("ny" :type string
 226      :documentation "Y component of unit vector of vehicle ground plane.")
 227     ("nz" :type string
 228      :documentation "Z component of unit vector of vehicle ground plane.")
 229     ("d" :type string :documentation "Distance of vehicle ground plane.")))
 230
 231 (defparameter *cli-acquisition-project-options*
 232   '(("create-acquisition-project"
 233      :type string :action #'create-acquisition-project-action
 234      :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.")
 235     ("delete-acquisition-project"
 236      :type string :action #'delete-acquisition-project-action
 237      :documentation "Ask for confirmation, then delete acquisition project and all its measurements.")
 238     ("delete-measurement"
 239      :type integer :action #'delete-measurement-action
 240      :documentation "Delete a measurement by its ID.")
 241     ("list-acquisition-project"
 242      :type string :optional t :action #'list-acquisition-project-action
 243      :documentation "List measurements of one acquisition project if its name is specified, or of all acquisition projects otherwise.")))
 244
 245 (defparameter *cli-store-images-and-points-options*
 246   '((("store-images-and-points" #\s) :type string :action #'store-images-and-points-action
 247      :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.")
 248     (("directory" #\d) :type string
 249      :documentation "Directory containing one set of measuring data.")
 250     (("common-root" #\r) :type string
 251      :documentation "The root part of directory that is equal for all pojects.  TODO: come up with some sensible default.")
 252     ("epsilon" :type string :initial-value ".001"
 253      :documentation "Difference in seconds below which two timestamps are considered equal.")
 254     ("aggregate-events" :type nil
 255      :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.")))
 256
 257 (defparameter *cli-start-server-options*
 258   '(("server" :action #'server-action
 259      :documentation "Start HTTP presentation server.  Entry URI is http://<host>:<port>/phoros/<presentation-project>")
 260     ("address" :type string
 261      :documentation "Address (of local machine) server is to listen to.  Default is listening to all available addresses.")
 262     ("http-port" :type integer :initial-value 8080
 263      :documentation "Port the presentation server listens on.")
 264     (("common-root" #\r) :type string :initial-value "/"
 265      :documentation "The root part of directory that is equal for all pojects.  TODO: come up with some sensible default.")
 266     ("images" :type integer :initial-value 4 :action *number-of-images*
 267      :documentation "Number of photos shown to the HTTP client.")))
 268
 269 (defparameter *cli-presentation-project-options*
 270   '(("create-presentation-project"
 271      :type string :action #'create-presentation-project-action
 272      :documentation "Create a fresh presentation project which is to expose a set of measurements to certain users.")
 273     ("delete-presentation-project"
 274      :type string :action #'delete-presentation-project-action
 275      :documentation "Ask for confirmation, then delete the presentation project including its table of user-generated points.")
 276     ("list-presentation-project"
 277      :type string :optional t :action #'list-presentation-project-action
 278      :documentation "List one presentation project if specified, or all presentation projects if not.")
 279     ("add-to-presentation-project"
 280      :type string :action #'add-to-presentation-project-action
 281      :documentation "Add to the presentation project given either certain measurements or all measurements currently in a certain acquisition project.")
 282     ("remove-from-presentation-project"
 283      :type string :action #'remove-from-presentation-project-action
 284      :documentation "Remove from the presentation project given either certain measurements or all measurements currently in a certain acquisition project.")
 285     ("measurement-id" :type integer :list t :optional t
 286      :documentation "One measurement-id to add or remove.  Repeat if necessary.")
 287     ("acquisition-project" :type string
 288      :documentation "The acquisition project whose measurements are to add or remove.")))
 289
 290 (defparameter *cli-aux-view-options*
 291   '(("create-aux-view"
 292      :type string :action #'create-aux-view-action
 293      :documentation "Connect table of auxiliary data with the specified presentation project by creating a view.")
 294     ("aux-table"
 295      :type string
 296      :documentation "Name of auxiliary table, which may be in any database.  It must have a geometry column.")
 297     ("coordinates-column"
 298      :type string :initial-value "the-geom"
 299      :documentation "Name of the geometry column in the auxiliary data table.")
 300     ("numeric-column"
 301      :type string :list t :optional t
 302      :documentation "Name of a numeric column in the auxiliary data table.  Repeat if necessary.")
 303     ("text-column"
 304      :type string :list t :optional t
 305      :documentation "Name of a text column in the auxiliary data table.  Repeat if necessary.")))
 306
 307 (defparameter *cli-user-options*
 308   '(("create-user"
 309      :type string :action #'create-user-action
 310      :documentation "Create or update user (specified by their ID) of certain presentation projects.")
 311     ("user-password" :type string :documentation "User's password.")
 312     ("user-full-name" :type string :documentation "User's real name.")
 313     ("user-role"
 314      :type string :initial-value "read"
 315      :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 same user; and \"admin\" is the same as \"write\" plus permission to delete points written by other users.")
 316     ("presentation-project" :type string :list t :optional t
 317      :documentation "Presentation project the user is allowed to see.  Repeat if necessary.")
 318     ("delete-user"
 319      :type string :action #'delete-user-action
 320      :documentation "Delete user.")
 321     ("list-user"
 322      :type string :optional t :action #'list-user-action
 323      :documentation "List the specified user with their presentation projects, or all users if no user is given.")))
 324
 325 (defparameter *cli-options*
 326   (append *cli-general-options*
 327           *cli-db-connection-options* *cli-aux-db-connection-options*
 328           *cli-get-image-options*
 329           *cli-camera-hardware-options* *cli-lens-options*
 330           *cli-generic-device-options* *cli-device-stage-of-life-options*
 331           *cli-device-stage-of-life-end-options*
 332           *cli-camera-calibration-options*
 333           *cli-acquisition-project-options*
 334           *cli-store-images-and-points-options*
 335           *cli-start-server-options*
 336           *cli-presentation-project-options*
 337           *cli-aux-view-options*
 338           *cli-user-options*))
 339
 340 (defun main ()
 341   "The UNIX command line entry point."
 342   (handler-bind
 343       ((serious-condition
 344         (lambda (c)
 345           (cl-log:log-message
 346            :error "~A ~:[~;[Backtrace follows]~&~A~]~&"
 347            c
 348            *log-lisp-backtraces-p*
 349            (trivial-backtrace:print-backtrace c :output nil))
 350           (format *error-output* "~A~&" c)
 351           #+sbcl (sb-ext:quit :unix-status 1)))
 352        (warning
 353         (lambda (c) (cl-log:log-message :warning "~A" c))))
 354     (cffi:use-foreign-library phoml)
 355     (compute-and-process-command-line-options *cli-options*)))
 356
 357 (defun ignore-warnings (c) (declare (ignore c)) (muffle-warning))
 358
 359 (defmacro with-cli-options ((&rest options) &body body)
 360   "Evaluate body with options bound to the values of the respective
 361 command line arguments.  Elements of options may be either symbols or
 362 lists shaped like (symbol default)."
 363   `(destructuring-bind (&key ,@options &allow-other-keys)
 364        (cli-remaining-options)
 365      ,@body))
 366
 367 (defun cli-remaining-options ()
 368   "Return current set of command line options as an alist, and a list
 369 of the non-option arguments.  In passing, set global variables
 370 according to the --verbose option given."
 371   (let ((options
 372          (multiple-value-list
 373           (process-command-line-options
 374            *cli-options* *command-line-arguments*))))
 375     (destructuring-bind (&key verbose &allow-other-keys)
 376         (car options)
 377       ;;(setf hunchentoot:*show-lisp-backtraces-p* (logbitp 12 verbose))  ;doesn't seem to exist
 378       ;; obeyed by both hunchentoot and Phoros' own logging:
 379       (setf hunchentoot:*log-lisp-backtraces-p* (logbitp 13 verbose))
 380       ;; necessary for (ps ... (debug-info ...)...):
 381       (setf *use-multi-file-openlayers* (logbitp 14 verbose))
 382       (setf *ps-print-pretty* (logbitp 15 verbose))
 383       (setf *show-lisp-errors-p* (logbitp 16 verbose)))
 384     (values-list options)))
 385
 386 (defun cli-help-action (&rest rest)
 387   "Print --help message."
 388   (declare (ignore rest))
 389   (flet ((show-help-section
 390              (options-specification
 391               &optional heading
 392               &rest introduction-paragraphs)
 393            "Show on *standard-output* help on options-specification
 394            preceded by header and introduction-paragraphs."
 395            (format *standard-output*
 396                    "~@[~2&_____~72,,,'_@<~A~>~]~
 397                     ~@[~{~&           ~{~@<~%        ~1,72:;~A~> ~}~}~]"
 398                    heading
 399                    (mapcar
 400                     #'(lambda (paragraph)
 401                         (cl-utilities:split-sequence-if
 402                          #'(lambda (x) (or (eql #\Space x)
 403                                            (eql #\Newline x)))
 404                          paragraph
 405                          :remove-empty-subseqs t))
 406                     introduction-paragraphs))
 407            (show-option-help options-specification)))
 408     (format
 409      *standard-output*
 410      "~&Usage: phoros [options] ...~&~A"
 411      (handler-bind ((warning #'ignore-warnings))
 412        (asdf:system-long-description (asdf:find-system :phoros))))
 413     (show-help-section
 414      *cli-general-options*
 415      "General Options")
 416     (show-help-section
 417      *cli-db-connection-options*
 418      "Database Connection (necessary for most operations)")
 419     (show-help-section
 420      *cli-aux-db-connection-options*
 421      "Auxiliary Database Connection"
 422      "Connection parameters to the database containing auxiliary data.
 423      Only needed for definition (--create-aux-view) and use (--server)
 424      of auxiliary data.")
 425     (show-help-section
 426      *cli-get-image-options*
 427      "Examine .pictures File"
 428      "Useful mostly for debugging purposes.")
 429     (show-help-section
 430      *cli-camera-hardware-options*
 431      "Camera Hardware Parameters (not including information on lens or
 432      mounting)")
 433     (show-help-section
 434      *cli-lens-options*
 435      "Lens Parameters"
 436      "Stored primarily for human consumption; not used in
 437      photogrammetric calculations.")
 438     (show-help-section
 439      *cli-generic-device-options*
 440      "Generic Device Definition"
 441      "Basically, this is a particular camera fitted with a particular
 442      lens.")
 443     (show-help-section
 444      *cli-device-stage-of-life-options*
 445      "Device Stage-Of-Life Definition"
 446      "A stage-of-life of a generic device is a possibly unfinished
 447      period of time during which the mounting constellation of the
 448      generic device remains unchanged.")
 449     (show-help-section
 450      *cli-device-stage-of-life-end-options*
 451      "Put An End To A Device's Stage-Of-Life"
 452      "This should be done after any event that renders any portion of
 453      the calibration data invalid. E.g.: accidental change of mounting
 454      constellation.")
 455     (show-help-section
 456      *cli-camera-calibration-options*
 457      "Camera Calibration Parameters")
 458     (show-help-section
 459      *cli-acquisition-project-options*
 460      "Manage Acquisition Projects"
 461      "An acquisition project is a set of measurements which share a
 462      set of data tables and views all of which have names beginning
 463      with dat-<acquisition-project-name>-.")
 464     (show-help-section
 465      *cli-store-images-and-points-options*
 466      "Store Measure Data")
 467     (show-help-section
 468      *cli-start-server-options*
 469      "Become A HTTP Presentation Server")
 470     (show-help-section
 471      *cli-presentation-project-options*
 472      "Manage Presentation Projects"
 473      "A presentation project is a set of measurements that can be
 474      visited under a dedicated URL
 475      \(http://<host>:<port>/phoros/<presentation-project>).
 476      Its extent may or may not be equal to the extent of an
 477      acquisition project.")
 478     (show-help-section
 479      *cli-aux-view-options*
 480      "Connect A Presentation Project To A Table Of Auxiliary Data"
 481      "Arbitrary data from tables not directly belonging to any Phoros
 482      project can be connected to a presentation project by means of a
 483      view which must be named
 484      usr-<presentation-project-name>-aux-point and which must contain
 485      the columns coordinates (geometry), aux-numeric (null or array of
 486      numeric), and aux-text (null or array of text).  The array
 487      elements of both aux-numeric and aux-text of auxiliary points can
 488      then be incorporated into neighbouring user points."
 489      "In simple cases (auxiliary data from one table which has a
 490      geometry column and some numeric and/or text columns), the
 491      following options can be used to create such view.")
 492     (show-help-section
 493      *cli-user-options*
 494      "Manage Presentation Project Users")))
 495
 496 (defun phoros-version (&key major minor revision)
 497   "Return version of this program, either one integer part as denoted by
 498 the key argument, or the whole dotted string."
 499   (let* ((version-string
 500           (handler-bind ((warning #'ignore-warnings))
 501             (asdf:component-version (asdf:find-system :phoros))))
 502          (version-components
 503           (mapcar #'parse-integer
 504                   (cl-utilities:split-sequence #\. version-string))))
 505     (cond (major (first version-components))
 506           (minor (second version-components))
 507           (revision (third version-components))
 508           (t version-string))))
 509
 510 (defun cli-version-action (&rest rest)
 511   "Print --version message. TODO: OpenLayers, Proj4js version."
 512   (declare (ignore rest))
 513   (with-cli-options (verbose)
 514     (case verbose
 515       (0
 516        (format
 517         *standard-output*
 518         "~&~A~&" (phoros-version)))
 519       (otherwise
 520        (format
 521         *standard-output*
 522         "~&~A version ~A~&  ~A version ~A~&  ~
 523          Proj4 library: ~A~&  PhoML version ~A~&"
 524         (handler-bind ((warning #'ignore-warnings))
 525           (asdf:system-description (asdf:find-system :phoros)))
 526         (handler-bind ((warning #'ignore-warnings))
 527           (asdf:component-version (asdf:find-system :phoros)))
 528         (lisp-implementation-type) (lisp-implementation-version)
 529         (proj:version)
 530         (phoml:get-version-number))))))
 531
 532 (defun cli-licence-action (&rest rest)
 533   "Print --licence boilerplate."
 534   (declare (ignore rest))
 535   (format
 536    *standard-output* "~&~A~&"
 537    (handler-bind ((warning #'ignore-warnings))
 538      (asdf:system-licence (asdf:find-system :phoros)))))
 539
 540 (defun check-db-action (&rest rest)
 541   "Say `OK´ if database is accessible."
 542   (declare (ignore rest))
 543   (with-cli-options (host (aux-host host) port (aux-port port)
 544                           database (aux-database database)
 545                           (user "") (aux-user user)
 546                           (password "") (aux-password password)
 547                           use-ssl (aux-use-ssl use-ssl))
 548     (when (and
 549            (check-db (list database user password host
 550                            :port port
 551                            :use-ssl (s-sql:from-sql-name use-ssl)))
 552            (check-db (list aux-database aux-user aux-password aux-host
 553                            :port aux-port
 554                            :use-ssl (s-sql:from-sql-name aux-use-ssl))))
 555       (format *error-output* "~&OK~%"))))
 556
 557 (defun check-dependencies-action (&rest rest)
 558   "Say `OK´ if the necessary external dependencies are available."
 559   (declare (ignore rest))
 560   (handler-case
 561       (progn
 562         (geographic-to-utm 33 13 52) ;check cs2cs
 563         (del-all)                    ;check photogrammetry
 564         (initialize-leap-seconds)    ;check source of leap second info
 565         (format *error-output* "~&OK~%"))
 566     (error (e) (format *error-output* "~A~&" e))))
 567
 568 (defun nuke-all-tables-action (&rest rest)
 569   "Drop the bomb.  Ask for confirmation first."
 570   (declare (ignore rest))
 571   (with-cli-options (host port database (user "") (password "") use-ssl
 572                           log-dir)
 573     (launch-logger log-dir)
 574     (when (yes-or-no-p
 575            "You asked me to delete anything in database ~A at ~A:~D.  ~
 576             Proceed?"
 577            database host port)
 578       (with-connection (list database user password host :port port
 579                              :use-ssl (s-sql:from-sql-name use-ssl)) ; string to keyword
 580         (nuke-all-tables))
 581       (cl-log:log-message
 582        :db-sys "Nuked database ~A at ~A:~D.  Back to square one!"
 583        database host port))))
 584
 585 (defun create-sys-tables-action (&rest rest)
 586   "Make a set of sys-* tables.  Ask for confirmation first."
 587   (declare (ignore rest))
 588   (with-cli-options (host port database (user "") (password "") use-ssl
 589                           log-dir)
 590     (launch-logger log-dir)
 591     (when (yes-or-no-p
 592            "You asked me to create a set of sys-* tables ~
 593             in database ~A at ~A:~D.  ~
 594             Make sure you know what you are doing.  Proceed?"
 595            database host port)
 596       (with-connection (list database user password host :port port
 597                              :use-ssl (s-sql:from-sql-name use-ssl))
 598         (create-sys-tables))
 599       (cl-log:log-message
 600        :db-sys "Created a fresh set of system tables in database ~A at ~A:~D."
 601        database host port))))
 602
 603 (defun create-acquisition-project-action (common-table-name)
 604   "Make a set of data tables."
 605   (with-cli-options (host port database (user "") (password "") use-ssl
 606                           log-dir)
 607     (launch-logger log-dir)
 608     (with-connection (list database user password host :port port
 609                            :use-ssl (s-sql:from-sql-name use-ssl))
 610       (create-acquisition-project common-table-name))
 611     (cl-log:log-message
 612      :db-dat
 613      "Created a fresh acquisition project by the name of ~A ~
 614       in database ~A at ~A:~D."
 615      common-table-name database host port)))
 616
 617 (defun delete-acquisition-project-action (common-table-name)
 618   "Delete an acquisition project."
 619   (with-cli-options (host port database (user "") (password "") use-ssl
 620                           log-dir)
 621     (launch-logger log-dir)
 622     (when (yes-or-no-p
 623            "You asked me to delete acquisition-project ~A ~
 624             (including all its measurements) ~
 625             from database ~A at ~A:~D.  Proceed?"
 626            common-table-name database host port)
 627       (with-connection (list database user password host :port port
 628                              :use-ssl (s-sql:from-sql-name use-ssl))
 629         (let ((project-did-exist-p
 630                (delete-acquisition-project common-table-name)))
 631           (cl-log:log-message
 632            :db-dat
 633            "~:[Tried to delete nonexistent~;Deleted~] ~
 634             acquisition project ~A from database ~A at ~A:~D."
 635            project-did-exist-p common-table-name database host port))))))
 636
 637 (defun delete-measurement-action (measurement-id)
 638   "Delete a measurement by its measurement-id."
 639   (with-cli-options (host port database (user "") (password "") use-ssl
 640                           log-dir)
 641     (launch-logger log-dir)
 642     (with-connection (list database user password host :port port
 643                            :use-ssl (s-sql:from-sql-name use-ssl))
 644       (let ((measurement-did-exist-p
 645              (delete-measurement measurement-id)))
 646         (cl-log:log-message
 647          :db-dat
 648          "~:[Tried to delete nonexistent~;Deleted~] ~
 649           measurement with ID ~A from database ~A at ~A:~D."
 650          measurement-did-exist-p measurement-id database host port)))))
 651
 652 (defun list-acquisition-project-action (&optional common-table-name)
 653   "List content of acquisition projects."
 654   (with-cli-options (host port database (user "") (password "") use-ssl)
 655     (with-connection (list database user password host :port port
 656                            :use-ssl (s-sql:from-sql-name use-ssl))
 657       (let ((content
 658              (if (stringp common-table-name)
 659                  (query
 660                   (:order-by
 661                    (:select
 662                     'common-table-name
 663                     'sys-acquisition-project.acquisition-project-id
 664                     'measurement-id
 665                     'directory
 666                     'cartesian-system
 667                     :from
 668                     'sys-acquisition-project :natural :left-join 'sys-measurement
 669                     :where (:= 'common-table-name common-table-name))
 670                    'measurement-id))
 671                  (query
 672                   (:order-by
 673                    (:select
 674                     'common-table-name
 675                     'sys-acquisition-project.acquisition-project-id
 676                     'measurement-id
 677                     'directory
 678                     'cartesian-system
 679                     :from
 680                     'sys-acquisition-project :natural :left-join 'sys-measurement)
 681                    'common-table-name 'measurement-id)))))
 682         (format-table
 683          *standard-output* " | " content
 684          "Acquisition Project" "ID" "Meas. ID" "Directory" "Cartesian CS")))))
 685
 686 (defun store-images-and-points-action (common-table-name)
 687   "Put data into the data tables."
 688   (with-cli-options (host port database (user "") (password "") use-ssl
 689                           log-dir
 690                           directory epsilon common-root aggregate-events)
 691     (launch-logger log-dir)
 692     (with-connection (list database user password host :port port
 693                            :use-ssl (s-sql:from-sql-name use-ssl))
 694       (cl-log:log-message
 695        :db-dat
 696        "Start: storing data from ~A into acquisition project ~A ~
 697         in database ~A at ~A:~D."
 698        directory common-table-name database host port)
 699       (store-images-and-points common-table-name directory
 700                                :epsilon (read-from-string epsilon nil)
 701                                :root-dir common-root
 702                                :aggregate-events aggregate-events))
 703     (cl-log:log-message
 704      :db-dat
 705      "Finish: storing data from ~A into acquisition project ~A ~
 706       in database ~A at ~A:~D."
 707      directory common-table-name database host port)))
 708
 709 ;;; We don't seem to have two-dimensional arrays in postmodern
 710 ;;(defun canonicalize-bayer-pattern (raw &optional sql-string-p)
 711 ;;  "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."
 712 ;;  (when raw
 713 ;;    (let* ((array
 714 ;;            (loop
 715 ;;               for row in raw
 716 ;;               collect
 717 ;;               (loop
 718 ;;                  for hex-color in (cl-utilities:split-sequence #\, row)
 719 ;;                  collect
 720 ;;                  (let ((*read-base* 16))
 721 ;;                    (assert (eql (elt hex-color 0) #\#) () "~A is not a valid color" hex-color)
 722 ;;                    (read-from-string
 723 ;;                     (concatenate 'string
 724 ;;                                  (subseq hex-color 5 7)
 725 ;;                                  (subseq hex-color 3 5)
 726 ;;                                  (subseq hex-color 1 3))
 727 ;;                     nil)))))
 728 ;;           (rows (length array))
 729 ;;           (columns (length (elt array 0))))
 730 ;;      (if sql-string-p
 731 ;;          (format nil "{~{{~{~A~#^,~}}~}}" array)
 732 ;;          (make-array (list rows columns) :initial-contents array)))))
 733
 734 (defun canonicalize-bayer-pattern (raw &optional sql-string-p)
 735   "Convert a string of comma-separated hex color strings (ex: #ff0000
 736 for red) into a vector of integers.  If sql-string-p is t, convert it
 737 into a string in SQL syntax."
 738   (when raw
 739     (let* ((vector
 740             (loop
 741                for hex-color in (cl-utilities:split-sequence #\, raw)
 742                collect
 743                  (let ((*read-base* 16))
 744                    (assert (eql (elt hex-color 0) #\#)
 745                            () "~A is not a valid color" hex-color)
 746                    (read-from-string
 747                     (concatenate 'string
 748                                  (subseq hex-color 5 7)
 749                                  (subseq hex-color 3 5)
 750                                  (subseq hex-color 1 3))
 751                     nil))))
 752            (columns (length vector)))
 753       (if sql-string-p
 754           (format nil "{~{~A~#^,~}}" vector)
 755           (make-array (list columns) :initial-contents vector)))))
 756
 757 (defun canonicalize-color-raiser (raw &optional sql-string-p)
 758   "Convert string of comma-separated numbers into a vector.  If
 759 sql-string-p is t, convert it into a string in SQL syntax."
 760   (when raw
 761     (let* ((vector
 762             (loop
 763                for multiplier in (cl-utilities:split-sequence #\, raw :count 3)
 764                collect
 765                  (read-from-string multiplier nil))))
 766       (if sql-string-p
 767           (format nil "{~{~A~#^,~}}" vector)
 768           (make-array '(3) :initial-contents vector)))))
 769
 770 (defun store-stuff (store-function)
 771   "Open database connection and call store-function on command line
 772 options.  Print return values to *standard-output*.  store-function
 773 should only take keyargs."
 774   (let ((command-line-options
 775          (cli-remaining-options)))
 776     (setf (getf command-line-options :bayer-pattern)
 777           (canonicalize-bayer-pattern
 778            (getf command-line-options :raw-bayer-pattern) t)
 779           (getf command-line-options :color-raiser)
 780           (canonicalize-color-raiser
 781            (getf command-line-options :raw-color-raiser) t))
 782     (destructuring-bind (&key host port database (user "") (password "") use-ssl
 783                               log-dir &allow-other-keys)
 784         command-line-options
 785       (launch-logger log-dir)
 786       (with-connection (list database user password host :port port
 787                              :use-ssl (s-sql:from-sql-name use-ssl))
 788         (format *standard-output* "~&~{~D~#^ ~}~%"
 789                 (multiple-value-list
 790                  (apply store-function :allow-other-keys t
 791                         command-line-options)))))))
 792
 793 (defun store-camera-hardware-action (&rest rest)
 794   (declare (ignore rest))
 795   (store-stuff #'store-camera-hardware))
 796
 797 (defun store-lens-action (&rest rest)
 798   (declare (ignore rest))
 799   (store-stuff #'store-lens))
 800
 801 (defun store-generic-device-action (&rest rest)
 802   (declare (ignore rest))
 803   (store-stuff #'store-generic-device))
 804
 805 (defun store-device-stage-of-life-action (&rest rest)
 806   (declare (ignore rest))
 807   (store-stuff #'store-device-stage-of-life))
 808
 809 (defun store-device-stage-of-life-end-action (&rest rest)
 810   (declare (ignore rest))
 811   (store-stuff #'store-device-stage-of-life-end))
 812
 813 (defun store-camera-calibration-action (&rest rest)
 814   (declare (ignore rest))
 815   (store-stuff #'store-camera-calibration))
 816
 817 (defun get-image-action (&rest rest)
 818   "Output a PNG file extracted from a .pictures file; print its
 819 trigger-time to stdout."
 820   (declare (ignore rest))
 821   (with-cli-options (count byte-position in out
 822                            raw-bayer-pattern raw-color-raiser)
 823     (with-open-file (out-stream out :direction :output
 824                                 :element-type 'unsigned-byte
 825                                 :if-exists :supersede)
 826       (let ((trigger-time
 827              (if byte-position
 828                  (send-png out-stream in byte-position
 829                            :bayer-pattern
 830                            (canonicalize-bayer-pattern raw-bayer-pattern)
 831                            :color-raiser
 832                            (canonicalize-color-raiser raw-color-raiser))
 833                  (send-nth-png count out-stream in
 834                                :bayer-pattern
 835                                (canonicalize-bayer-pattern raw-bayer-pattern)
 836                                :color-raiser
 837                                (canonicalize-color-raiser raw-color-raiser)))))
 838         (format *standard-output*
 839                 "~&~A~%" (timestring (utc-from-unix trigger-time)))))))
 840
 841 (defun create-presentation-project-action (presentation-project-name)
 842   "Make a presentation project."
 843   (with-cli-options (host port database (user "") (password "") use-ssl
 844                           log-dir)
 845     (launch-logger log-dir)
 846     (with-connection (list database user password host :port port
 847                            :use-ssl (s-sql:from-sql-name use-ssl))
 848       (let ((fresh-project-p
 849              (create-presentation-project presentation-project-name)))
 850         (cl-log:log-message
 851          :db-dat
 852          "~:[Tried to recreate an existing~;Created a fresh~] ~
 853           presentation project by the name of ~A in database ~A at ~A:~D."
 854          fresh-project-p presentation-project-name database host port)))))
 855
 856
 857 (defun delete-presentation-project-action (presentation-project-name)
 858   "Delete a presentation project."
 859   (with-cli-options (host port database (user "") (password "") use-ssl
 860                           log-dir)
 861     (launch-logger log-dir)
 862     (when (yes-or-no-p
 863            "You asked me to delete presentation-project ~A ~
 864             (including its table of user-defined points usr-~:*~A-point) ~
 865             from database ~A at ~A:~D.  Proceed?"
 866            presentation-project-name database host port)
 867       (with-connection (list database user password host :port port
 868                              :use-ssl (s-sql:from-sql-name use-ssl))
 869         (let ((project-did-exist-p
 870                (delete-presentation-project presentation-project-name)))
 871           (cl-log:log-message
 872            :db-dat
 873            "~:[Tried to delete nonexistent~;Deleted~] ~
 874             presentation project ~A from database ~A at ~A:~D."
 875            project-did-exist-p presentation-project-name
 876            database host port))))))
 877
 878 (defun add-to-presentation-project-action (presentation-project-name)
 879   "Add measurements to a presentation project."
 880   (with-cli-options (host port database (user "") (password "") use-ssl
 881                           log-dir
 882                           measurement-id acquisition-project)
 883     (launch-logger log-dir)
 884     (with-connection (list database user password host :port port
 885                            :use-ssl (s-sql:from-sql-name use-ssl))
 886       (add-to-presentation-project presentation-project-name
 887                                    :measurement-ids measurement-id
 888                                    :acquisition-project acquisition-project))
 889     (cl-log:log-message
 890      :db-dat
 891      "Added ~@[measurement-ids ~{~D~#^, ~}~]~
 892       ~@[all measurements from acquisition project ~A~] ~
 893       to presentation project ~A in database ~A at ~A:~D."
 894      measurement-id acquisition-project
 895      presentation-project-name database host port)))
 896
 897 (defun remove-from-presentation-project-action (presentation-project-name)
 898   "Add measurements to a presentation project."
 899   (with-cli-options (host port database (user "") (password "") use-ssl
 900                           log-dir
 901                           measurement-id acquisition-project)
 902     (launch-logger log-dir)
 903     (with-connection (list database user password host :port port
 904                            :use-ssl (s-sql:from-sql-name use-ssl))
 905       (remove-from-presentation-project presentation-project-name
 906                                         :measurement-ids measurement-id
 907                                         :acquisition-project acquisition-project))
 908     (cl-log:log-message
 909      :db-dat
 910      "Removed ~@[measurement-ids ~{~D~#^, ~}~]~
 911       ~@[all measurements that belong to acquisition project ~A~] ~
 912       from presentation project ~A in database ~A at ~A:~D."
 913      measurement-id acquisition-project
 914      presentation-project-name database host port)))
 915
 916 (defun create-aux-view-action (presentation-project-name)
 917   "Connect presentation project to an auxiliary data table by means of
 918 a view."
 919   (with-cli-options (host (aux-host host) port (aux-port port)
 920                           database (aux-database database)
 921                           (user "") (aux-user user)
 922                           (password "") (aux-password password)
 923                           use-ssl (aux-use-ssl use-ssl)
 924                           log-dir
 925                           aux-table coordinates-column
 926                           numeric-column text-column)
 927     (launch-logger log-dir)
 928     (with-connection (list aux-database aux-user aux-password aux-host
 929                            :port aux-port
 930                            :use-ssl (s-sql:from-sql-name aux-use-ssl))
 931       (let ((aux-view-in-phoros-db-p
 932              (every #'equal
 933                     (list host port database user password use-ssl)
 934                     (list aux-host aux-port aux-database
 935                           aux-user aux-password aux-use-ssl)))
 936             (aux-view-exists-p
 937              (aux-view-exists-p presentation-project-name)))
 938         (when (or
 939                aux-view-in-phoros-db-p
 940                (yes-or-no-p
 941                 "I'm going to ~:[create~;replace~] a view named ~A ~
 942                  in database ~A at ~A:~D.  Proceed?"
 943                 aux-view-exists-p
 944                 (aux-point-view-name presentation-project-name)
 945                 aux-database aux-host aux-port))
 946           (when aux-view-exists-p
 947             (delete-aux-view presentation-project-name))
 948           (handler-bind ((warning #'ignore-warnings)) ;TODO: muffle more postgresql warnings
 949             (create-aux-view
 950              presentation-project-name aux-table
 951              :coordinates-column (s-sql:to-sql-name coordinates-column)
 952              :numeric-columns numeric-column
 953              :text-columns text-column))
 954           (cl-log:log-message
 955            :db-dat
 956            "~:[Created~;Updated~] in database ~A at ~A:~D a view called ~A ~
 957             into table (of auxiliary data) ~A.  Coordinates column is ~A.  ~
 958             ~:[No numeric columns.~;Numeric column(s): ~:*~{~A~#^, ~}.~]  ~
 959             ~:[No text columns.~;Text column(s): ~:*~{~A~#^, ~}.~]"
 960            aux-view-exists-p
 961            aux-database aux-host aux-port
 962            (aux-point-view-name presentation-project-name)
 963            aux-table coordinates-column
 964            numeric-column text-column))))))
 965
 966 (defun create-user-action (presentation-project-user)
 967   "Define a new user."
 968   (let (fresh-user-p)
 969     (with-cli-options (host port database (user "") (password "") use-ssl
 970                             log-dir
 971                             user-password user-full-name
 972                             user-role presentation-project)
 973       (launch-logger log-dir)
 974       (with-connection (list database user password host :port port
 975                              :use-ssl (s-sql:from-sql-name use-ssl))
 976         (setf fresh-user-p
 977               (create-user presentation-project-user
 978                            :password user-password
 979                            :full-name user-full-name
 980                            :user-role user-role
 981                            :presentation-projects presentation-project)))
 982       (cl-log:log-message
 983        :db-dat ;TODO: We're listing nonexistent p-projects here as well.
 984        "~:[Updated~;Created~] user ~A (~A) who has ~A access ~
 985         to ~:[no ~;~]presentation project(s)~:*~{ ~A~#^,~} ~
 986         in database ~A at ~A:~D."
 987        fresh-user-p presentation-project-user
 988        user-full-name user-role
 989        presentation-project database host port))))
 990
 991 (defun delete-user-action (presentation-project-user)
 992   "Delete a presentation project user."
 993   (with-cli-options ( host port database (user "") (password "") use-ssl
 994                            log-dir)
 995     (launch-logger log-dir)
 996     (with-connection (list database user password host :port port
 997                            :use-ssl (s-sql:from-sql-name use-ssl))
 998       (let ((user-did-exist-p
 999              (delete-user presentation-project-user)))
1000         (cl-log:log-message
1001          :db-dat
1002          "~:[Tried to delete nonexistent~;Deleted~] ~
1003           presentation project user ~A from database ~A at ~A:~D."
1004          user-did-exist-p presentation-project-user database host port)))))
1005
1006 (defun list-user-action (&optional presentation-project-user)
1007   "List presentation project users together with their presentation
1008 projects."
1009   (with-cli-options (host port database (user "") (password "") use-ssl)
1010     (with-connection (list database user password host :port port
1011                            :use-ssl (s-sql:from-sql-name use-ssl))
1012       (let ((content
1013              (if (stringp presentation-project-user)
1014                  (query
1015                   (:order-by
1016                    (:select
1017                     'user-name 'sys-user.user-id 'user-password
1018                     'user-full-name 'presentation-project-name
1019                     'sys-user-role.presentation-project-id 'user-role
1020                     :from 'sys-user 'sys-user-role 'sys-presentation-project
1021                     :where (:and (:= 'sys-user-role.presentation-project-id
1022                                      'sys-presentation-project.presentation-project-id)
1023                                  (:= 'sys-user.user-id 'sys-user-role.user-id)
1024                                  (:= 'user-name presentation-project-user)))
1025                    'user-name))
1026                  (query
1027                   (:order-by
1028                    (:select
1029                     'user-name 'sys-user.user-id 'user-password
1030                     'user-full-name 'presentation-project-name
1031                     'sys-user-role.presentation-project-id 'user-role
1032                     :from 'sys-user 'sys-user-role 'sys-presentation-project
1033                     :where (:and (:= 'sys-user-role.presentation-project-id
1034                                      'sys-presentation-project.presentation-project-id)
1035                                  (:= 'sys-user.user-id 'sys-user-role.user-id)))
1036                    'user-name)))))
1037         (format-table
1038          *standard-output* " | " content
1039          "User" "ID" "Password" "Full Name" "Presentation Project" "ID" "Role")))))
1040
1041 (defun list-presentation-project-action (&optional presentation-project)
1042   "List content of presentation projects."
1043   (with-cli-options (host port database (user "") (password "") use-ssl)
1044     (with-connection (list database user password host :port port
1045                            :use-ssl (s-sql:from-sql-name use-ssl))
1046       (let ((content
1047              (if (stringp presentation-project)
1048                  (query
1049                   (:order-by
1050                    (:select
1051                     'presentation-project-name
1052                     'sys-presentation-project.presentation-project-id
1053                     'sys-presentation.measurement-id
1054                     'common-table-name
1055                     'sys-measurement.acquisition-project-id
1056                     :from
1057                     'sys-presentation-project 'sys-presentation
1058                     'sys-measurement 'sys-acquisition-project
1059                     :where (:and (:= 'sys-presentation-project.presentation-project-id
1060                                      'sys-presentation.presentation-project-id)
1061                                  (:= 'sys-presentation.measurement-id
1062                                      'sys-measurement.measurement-id)
1063                                  (:= 'sys-measurement.acquisition-project-id
1064                                      'sys-acquisition-project.acquisition-project-id)
1065                                  (:= 'presentation-project-name presentation-project)))
1066                    'presentation-project-name 'sys-presentation.measurement-id))
1067                  (query
1068                   (:order-by
1069                    (:select
1070                     'presentation-project-name
1071                     'sys-presentation-project.presentation-project-id
1072                     'sys-presentation.measurement-id
1073                     'common-table-name
1074                     'sys-measurement.acquisition-project-id
1075                     :from
1076                     'sys-presentation-project 'sys-presentation
1077                     'sys-measurement 'sys-acquisition-project
1078                     :where (:and (:= 'sys-presentation-project.presentation-project-id
1079                                      'sys-presentation.presentation-project-id)
1080                                  (:= 'sys-presentation.measurement-id
1081                                      'sys-measurement.measurement-id)
1082                                  (:= 'sys-measurement.acquisition-project-id
1083                                      'sys-acquisition-project.acquisition-project-id)))
1084                    'presentation-project-name 'sys-presentation.measurement-id)))))
1085         (format-table *standard-output* " | " content
1086                       "Presentation Project" "ID" "Meas. ID" "Acquisition Project" "ID")))))
1087
1088 (defun format-table (destination column-separator content &rest column-headers)
1089   "Print content (a list of lists) to destination."
1090   (let* ((rows
1091           (append (list column-headers) (list ()) content))
1092          (number-of-rows (length column-headers))
1093          (widths
1094           (loop
1095              for column from 0 below number-of-rows collect
1096                (loop
1097                   for row in rows
1098                   maximize (length (format nil "~A" (nth column row)))))))
1099     (setf (second rows)
1100           (loop
1101              for width in widths collect
1102                (make-string width :initial-element #\-)))
1103     (loop
1104        for row in rows do
1105          (format destination "~&~{~VA~1,#^~A~}~%"
1106                  (loop
1107                     for width in widths and field in row
1108                     collect width collect field collect column-separator)))))
1109
1110 (defun server-action (&rest rest)
1111   "Start the HTTP server."
1112   (declare (ignore rest))
1113   (with-cli-options  (host (aux-host host) port (aux-port port)
1114                            database (aux-database database)
1115                            (user "") (aux-user user)
1116                            (password "") (aux-password password)
1117                            use-ssl (aux-use-ssl use-ssl)
1118                            log-dir
1119                            http-port address common-root)
1120     (launch-logger log-dir)
1121     (setf *postgresql-credentials*
1122           (list database user password host :port port
1123                 :use-ssl (s-sql:from-sql-name use-ssl)))
1124     (setf *postgresql-aux-credentials*
1125           (list aux-database aux-user aux-password aux-host :port aux-port
1126                 :use-ssl (s-sql:from-sql-name aux-use-ssl)))
1127     (start-server :http-port http-port :address address
1128                   :common-root common-root)
1129     (cl-log:log-message
1130      :info
1131      "HTTP server listens on port ~D ~
1132       of ~:[all available addresses~;address ~:*~A~].  ~
1133       Phoros database is ~A on ~A:~D.  Auxiliary database is ~A on ~A:~D.  ~
1134       Files are searched for in ~A."
1135      http-port address
1136      database host port
1137      aux-database aux-host aux-port
1138      common-root)
1139     (loop (sleep 10))))