cli.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011, 2012 Bert Burgemeister
   3 ;;;
   4 ;;; This program is free software; you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation; either version 2 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License along
  15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
  16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17
  18
  19 ;;;; The UNIX command line interface
  20
  21 (in-package :phoros)
  22
  23 (let (serial-number description try-overwrite device-stage-of-life-id
  24                     c common-root bayer-pattern unmounting-date)
  25   (cli:defsynopsis ()
  26     (text :contents *phoros-long-description*)
  27     (text
  28      :contents
  29      "Some options have a corresponding environment variable.  Phoros will set environment variables from definitions found in file <phoros-invocation-dir>/.phoros or, if that doesn't exist, in file ~/.phoros.")
  30     (text
  31      :contents
  32      "Options specified on the command line take precedence over any environment variables.  Pre-existing environment variables take precendence over definitions found in any .phoros files.")
  33     (text
  34      :contents
  35      "Config file syntax: one option per line; leading or trailing spaces are ignored; anything not beginning with PHOROS_ is ignored.")
  36     (enum :long-name "help" :short-name "h"
  37           :argument-name "FORMAT"
  38           :enum '(:long :short)
  39           :argument-type :optional
  40           :fallback-value :long
  41           :description "Print help in different formats [long|short] and exit.")
  42     (flag :long-name "licence"
  43           :description "Print licence boilerplate and exit.")
  44     (flag :long-name "license"
  45           :description "Same as --licence")
  46     (enum :long-name "version"
  47           :argument-name "FORMAT"
  48           :enum '(:all :minimal)
  49           :argument-type :optional
  50           :fallback-value :minimal
  51           :description "Print different amounts [minimal|all] of version information and exit.  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.")
  52     (group
  53      (:header "General Options:")
  54      (stropt :long-name "verbose"
  55              :description "Change behaviour, mainly for debugging, as specified in the form of <verbosity-topic>:<verbosity-level>.  Repeat if necessary.
  56   render-footprints:1 - display image footprints on http client;
  57   suppress-preemptive-caching:1 - don't stuff browser cache with lots of images around map cursor;
  58   log-sql:1 - log SQL activity;
  59   postgresql-warnings:1 - show PostgreSQL warnings;
  60   log-error-backtraces:1 - log http server error backtraces;
  61   use-multi-file-openlayers:1 - use multi-file version of OpenLayers;
  62   pretty-javascript:1 - send nicely formatted JavaScript;
  63   show-server-errors:1 - send HTTP server error messages to client;
  64   no-daemon:1 - run HTTP server in foreground.")
  65      ;; use-multi-file-openlayers:1 - Use OpenLayers uncompiled from
  66      ;; openlayers/*, which makes debugging easier and is necessary for
  67      ;; (ps; ... (debug-info ...)...) to work; doesn't work with
  68      ;; (OpenLayers 2.10 AND Firefox 4), though.  Otherwise use a
  69      ;; single-file shrunk ol/Openlayers.js.
  70      (stropt :long-name "umask"
  71              :env-var "PHOROS_UMASK"
  72              :argument-name "OCTAL_NUMBER"
  73              :default-value "002"
  74              :description "File permissions mask applied when Phoros creates files and directories.")
  75      (path :long-name "log-dir"
  76            :env-var "PHOROS_LOG_DIR"
  77            :type :directory
  78            :default-value #P"log.d/"
  79            :description "Where to put the log files.  Created if necessary; should end with a slash.")
  80      (flag :long-name "check-db"
  81            :description "Check connection to databases (including auxiliary if applicable) and exit.")
  82      (flag :long-name "check-dependencies"
  83            :description "Check presence of dependencies on local system and exit.")
  84      (flag :long-name "nuke-all-tables"
  85            :description "Ask for confirmation, then delete anything in database and exit.")
  86      (flag :long-name "create-sys-tables"
  87            :description "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."))
  88     (group
  89      (:header "Database Connection:")
  90      (text :contents "Necessary for most operations.")
  91      (stropt :long-name "host" :short-name "H"
  92              :env-var "PHOROS_HOST"
  93              :argument-name "NAME"
  94              :default-value "localhost"
  95              :description "Database server.")
  96      (lispobj :long-name "port" :short-name "P"
  97               :env-var "PHOROS_PORT"
  98               :typespec 'integer :argument-name "INT"
  99               :default-value 5432
 100               :description "Port on database server.")
 101      (stropt :long-name "database" :short-name "D"
 102              :env-var "PHOROS_DATABASE"
 103              :argument-name "NAME"
 104              :default-value "phoros"
 105              :description "Name of database.")
 106      (stropt :long-name "user" :short-name "U"
 107              :env-var "PHOROS_USER"
 108              :argument-name "NAME"
 109              :description "Database user.")
 110      (stropt :long-name "password" :short-name "W"
 111              :env-var "PHOROS_PASSWORD"
 112              :argument-name "PWD"
 113              :description "Database user's password.")
 114      (enum :long-name "use-ssl"
 115            :env-var "PHOROS_USE_SSL"
 116            :enum '(:yes :no :try)
 117            :argument-name "MODE"
 118            :default-value :no
 119            :description "Use SSL in database connection. [yes|no|try]"))
 120     (group
 121      (:header "Auxiliary Database Connection:")
 122      (text :contents "Connection parameters to the database containing auxiliary data.  Only needed for definition (--create-aux-view) and use (--server) of auxiliary data.")
 123      (stropt :long-name "aux-host"
 124              :env-var "PHOROS_AUX_HOST"
 125              :argument-name "NAME"
 126              :default-value "localhost"
 127              :description "Auxiliary database server.")
 128      (lispobj :long-name "aux-port"
 129               :env-var "PHOROS_AUX_PORT"
 130               :typespec 'integer :argument-name "INT"
 131               :default-value 5432
 132               :description "Port on auxiliary database server.")
 133      (stropt :long-name "aux-database"
 134              :env-var "PHOROS_AUX_DATABASE"
 135              :argument-name "NAME"
 136              :description "Name of auxiliary database.")
 137      (stropt :long-name "aux-user"
 138              :env-var "PHOROS_AUX_USER"
 139              :argument-name "NAME"
 140              :description "Auxiliary database user.")
 141      (stropt :long-name "aux-password"
 142              :env-var "PHOROS_AUX_PASSWORD"
 143              :argument-name "PWD"
 144              :description "Auxiliary database user's password.")
 145      (enum :long-name "aux-use-ssl"
 146            :env-var "PHOROS_AUX_USE_SSL"
 147            :argument-name "MODE"
 148            :enum '(:yes :no :try)
 149            :default-value :no
 150            :description "Use SSL in auxiliary database connection. [yes|no|try]"))
 151     (group
 152      (:header "Examine .pictures File:")
 153      (text :contents "Useful primarily for debugging purposes.")
 154      (flag :long-name "get-image"
 155            :description "Get a single image from a .pictures file, print its trigger-time to stdout, and exit.")
 156      (group ()
 157             (lispobj :long-name "count"
 158                      :typespec 'integer :argument-name "INT"
 159                      :default-value 0
 160                      :description "Image number in .pictures file.")
 161             (lispobj :long-name "byte-position"
 162                      :typespec 'integer :argument-name "INT"
 163                      :description "Byte position of image in .pictures file.")
 164             (path :long-name "in"
 165                   :type :file
 166                   :description "Path to .pictures file.")
 167             (path :long-name "out"
 168                   :type :file
 169                   :default-value #P"phoros-get-image.png"
 170                   :description "Path to output .png file.")
 171             ;; The way it should be had we two-dimensional arrays in postmodern:
 172             ;;("bayer-pattern" :type string :list t :optional t :action :raw-bayer-pattern :description "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.")
 173             (setf bayer-pattern
 174                   (cli:make-stropt
 175                    :long-name "bayer-pattern"
 176                    :default-value "#ff0000,#00ff00"
 177                    :description "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."))))
 178     (group
 179      (:header "Calibration Data:")
 180      (group
 181       (:header "Camera Hardware Parameters:")
 182       (text :contents "These do not include information on lenses or mounting.")
 183       (flag :long-name "store-camera-hardware"
 184             :description "Put new camera-hardware data into the database; print camera-hardware-id to stdout.")
 185       (group ()
 186              (lispobj :long-name "sensor-width-pix"
 187                       :typespec 'integer :argument-name "INT"
 188                       :description "Width of camera sensor.")
 189              (lispobj :long-name "sensor-height-pix"
 190                       :typespec 'integer :argument-name "INT"
 191                       :description "Height of camera sensor.")
 192              (lispobj :long-name "pix-size"
 193                       :typespec 'real :argument-name "NUM"
 194                       :description "Camera pixel size in millimetres (float).")
 195              (lispobj :long-name "channels"
 196                       :typespec 'integer :argument-name "INT"
 197                       :description "Number of color channels")
 198              (lispobj :long-name "pix-depth"
 199                       :typespec 'integer :argument-name "INT"
 200                       :default-value 255
 201                       :description "Greatest possible pixel value.")
 202              (stropt :long-name "color-raiser"
 203                      :default-value "1,1,1"
 204                      :description "Multipliers for the individual color components.  Example: 1.2,1,.8 multiplies red by 1.2 and blue by 0.8.")
 205              ;; The way it should be had we two-dimensional arrays in postmodern:
 206              ;;("bayer-pattern" :type string :list t :optional t :action :raw-bayer-pattern :description "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.")
 207              bayer-pattern
 208              (setf serial-number
 209                    (cli:make-stropt
 210                     :long-name "serial-number"
 211                     :default-value " "
 212                     :description "Serial number."))
 213              (setf description
 214                    (cli:make-stropt
 215                     :long-name "description"
 216                     :default-value " "
 217                     :description "Description of camera."))
 218              (setf try-overwrite
 219                    (cli:make-switch
 220                     :long-name "try-overwrite"
 221                     :default-value t
 222                     :argument-type :required
 223                     :description "Overwrite matching record if any."))))
 224      (group
 225       (:header "Lens Parameters:")
 226       (text :contents "Stored primarily for human consumption; not used in photogrammetric calculations.")
 227       (flag :long-name "store-lens"
 228             :description "Put new lens data into the database; print lens-id to stdout.")
 229       (group ()
 230              (setf c
 231                    (cli:make-lispobj
 232                     :long-name "c"
 233                     :typespec 'real :argument-name "NUM"
 234                     :description "Focal length."))
 235              serial-number
 236              description
 237              try-overwrite))
 238      (group
 239       (:header "Generic Device Definition:")
 240       (text :contents "Basically, this is a particular camera fitted with a particular lens.")
 241       (flag :long-name "store-generic-device"
 242             :description "Put a newly defined generic-device into the database; print generic-device-id to stdout.")
 243       (group ()
 244              (lispobj :long-name "camera-hardware-id"
 245                       :typespec 'integer :argument-name "ID"
 246                       :description "Numeric camera hardware ID in database.")
 247              (lispobj :long-name "lens-id"
 248                       :typespec 'integer :argument-name "ID"
 249                       :description "Numeric lens ID in database.")
 250              (lispobj :long-name "scanner-id" ;unimplemented
 251                       :typespec '(or integer (eql :null)) :argument-name "ID"
 252                       :default-value :null
 253                       :description "Numeric scanner ID in database."
 254                       :hidden t)))
 255      (group
 256       (:header "Device Stage-Of-Life Definition:")
 257       (text :contents "A stage-of-life of a generic device is a possibly unfinished period of time during which the mounting constellation of the generic device remains unchanged.")
 258       (flag :long-name "store-device-stage-of-life"
 259             :description "Put a newly defined device-stage-of-life into the database; print device-stage-of-life-id to stdout.")
 260       (group ()
 261              (stropt :long-name "recorded-device-id"
 262                      :description "Device id stored next to the measuring data.")
 263              (stropt :long-name "event-number"
 264                      :description "GPS event that triggers this generic device.")
 265              (lispobj :long-name "generic-device-id"
 266                       :typespec 'integer :argument-name "ID"
 267                       :description "Numeric generic-device id in database.")
 268              (stropt :long-name "vehicle-name"
 269                      :description "Descriptive name of vehicle.")
 270              (stropt :long-name "casing-name"
 271                      :default-value " "
 272                      ;;KLUDGE:  " " is enforced by clon's help; should be "".
 273                      ;; We string-trim this away further down the line.
 274                      :description "Descriptive name of device casing.")
 275              (stropt :long-name "computer-name"
 276                      :default-value " "
 277                      :description "Name of the recording device.")
 278              (stropt :long-name "computer-interface-name"
 279                      :default-value " "
 280                      :description "Interface at device.")
 281              (stropt :long-name "mounting-date"
 282                      :description "Time this device constellation became effective.  Format: \"2010-11-19T13:49+01\".")
 283              (setf unmounting-date
 284                    (cli:make-stropt
 285                     :long-name "unmounting-date"
 286                     :default-value ":null"
 287                     :description "Time this device constellation ceased to be effective.  Format: \"2010-11-19T17:02+01\"."))))
 288      (group
 289       (:header "Put An End To A Device's Stage-Of-Life:")
 290       (text :contents "This should be done after any event that renders any portion of the calibration data invalid. E.g.: accidental change of mounting constellation.")
 291       (flag :long-name "store-device-stage-of-life-end"
 292             :description "Put an end date to a device-stage-of-life in the database; print device-stage-of-life-id to stdout.")
 293       (group ()
 294              (setf device-stage-of-life-id
 295                    (cli:make-lispobj
 296                     :long-name "device-stage-of-life-id"
 297                     :typespec 'integer :argument-name "ID"
 298                     :description "ID of the device-stage-of-life."))
 299              unmounting-date))
 300      (group
 301       (:header "Camera Calibration Parameters:")
 302       (flag :long-name "store-camera-calibration"
 303             :description "Put new camera-calibration into the database; print generic-device-id and calibration date to stdout.")
 304       (group ()
 305              device-stage-of-life-id
 306              (stropt :long-name "date"
 307                      :description "Date of calibration.  Format: \"2010-11-19T13:49+01\".")
 308              (stropt :long-name "person"
 309                      :description "Person who did the calibration.")
 310              (stropt :long-name "main-description"
 311                      :description "Regarding this entire set of calibration data")
 312              (switch :long-name "usable"
 313                      :default-value t
 314                      :description "Set to no to just display images and inhibit photogrammetric calculations.")
 315              (switch :long-name "debug"
 316                      :default-value nil
 317                      :description "If yes: not for production use; may be altered or deleted at any time.")
 318              (stropt :long-name "photogrammetry-version"
 319                      :description "Software version used to create this data.")
 320              (lispobj :long-name "mounting-angle"
 321                       :typespec '(member 0 90 -90 180)
 322                       :description "Head up = 0; right ear up = 90; left ear up = -90; head down = 180.")
 323              (stropt :long-name "inner-orientation-description"
 324                      :default-value " "
 325                      :description "Comments regarding inner orientation calibration.")
 326              c
 327              (lispobj :long-name "xh"
 328                       :typespec 'real :argument-name "NUM"
 329                       :description "Inner orientation: principal point displacement.")
 330              (lispobj :long-name "yh"
 331                       :typespec 'real :argument-name "NUM"
 332                       :description "Inner orientation: principal point displacement.")
 333              (lispobj :long-name "a1"
 334                       :typespec 'real :argument-name "NUM"
 335                       :description "Inner orientation: radial distortion.")
 336              (lispobj :long-name "a2"
 337                       :typespec 'real :argument-name "NUM"
 338                       :description "Inner orientation: radial distortion.")
 339              (lispobj :long-name "a3"
 340                       :typespec 'real :argument-name "NUM"
 341                       :description "Inner orientation: radial distortion.")
 342              (lispobj :long-name "b1"
 343                       :typespec 'real :argument-name "NUM"
 344                       :description "Inner orientation: asymmetric and tangential distortion.")
 345              (lispobj :long-name "b2"
 346                       :typespec 'real :argument-name "NUM"
 347                       :description "Inner orientation: asymmetric and tangential distortion.")
 348              (lispobj :long-name "c1"
 349                       :typespec 'real :argument-name "NUM"
 350                       :description "Inner orientation: affinity and shear distortion.")
 351              (lispobj :long-name "c2"
 352                       :typespec 'real :argument-name "NUM"
 353                       :description "Inner orientation: affinity and shear distortion.")
 354              (lispobj :long-name "r0"
 355                       :typespec 'real :argument-name "NUM"
 356                       :description "Inner orientation.")
 357              (stropt :long-name "outer-orientation-description"
 358                      :default-value " "
 359                      :description "Comments regarding outer orientation calibration.")
 360              (lispobj :long-name "dx"
 361                       :typespec 'real :argument-name "NUM"
 362                       :description "Outer orientation; in metres.")
 363              (lispobj :long-name "dy"
 364                       :typespec 'real :argument-name "NUM"
 365                       :description "Outer orientation; in metres.")
 366              (lispobj :long-name "dz"
 367                       :typespec 'real :argument-name "NUM"
 368                       :description "Outer orientation; in metres.")
 369              (lispobj :long-name "omega"
 370                       :typespec 'real :argument-name "NUM"
 371                       :description "Outer orientation.")
 372              (lispobj :long-name "phi"
 373                       :typespec 'real :argument-name "NUM"
 374                       :description "Outer orientation.")
 375              (lispobj :long-name "kappa"
 376                       :typespec 'real :argument-name "NUM"
 377                       :description "Outer orientation.")
 378              (stropt :long-name "boresight-description"
 379                      :default-value " "
 380                      :description "Comments regarding boresight alignment calibration.")
 381              (lispobj :long-name "b-dx"
 382                       :typespec 'real :argument-name "NUM"
 383                       :description "Boresight alignment.")
 384              (lispobj :long-name "b-dy"
 385                       :typespec 'real :argument-name "NUM"
 386                       :description "Boresight alignment.")
 387              (lispobj :long-name "b-dz"
 388                       :typespec 'real :argument-name "NUM"
 389                       :description "Boresight alignment.")
 390              (lispobj :long-name "b-ddx"
 391                       :typespec 'real :argument-name "NUM"
 392                       :description "Boresight alignment.")
 393              (lispobj :long-name "b-ddy"
 394                       :typespec 'real :argument-name "NUM"
 395                       :description "Boresight alignment.")
 396              (lispobj :long-name "b-ddz"
 397                       :typespec 'real :argument-name "NUM"
 398                       :description "Boresight alignment.")
 399              (lispobj :long-name "b-rotx"
 400                       :typespec 'real :argument-name "NUM"
 401                       :description "Boresight alignment.")
 402              (lispobj :long-name "b-roty"
 403                       :typespec 'real :argument-name "NUM"
 404                       :description "Boresight alignment.")
 405              (lispobj :long-name "b-rotz"
 406                       :typespec 'real :argument-name "NUM"
 407                       :description "Boresight alignment.")
 408              (lispobj :long-name "b-drotx"
 409                       :typespec 'real :argument-name "NUM"
 410                       :description "Boresight alignment.")
 411              (lispobj :long-name "b-droty"
 412                       :typespec 'real :argument-name "NUM"
 413                       :description "Boresight alignment.")
 414              (lispobj :long-name "b-drotz"
 415                       :typespec 'real :argument-name "NUM"
 416                       :description "Boresight alignment.")
 417              (lispobj :long-name "nx"
 418                       :typespec 'real :argument-name "NUM"
 419                       :description "X component of unit vector of vehicle ground plane.")
 420              (lispobj :long-name "ny"
 421                       :typespec 'real :argument-name "NUM"
 422                       :description "Y component of unit vector of vehicle ground plane.")
 423              (lispobj :long-name "nz"
 424                       :typespec 'real :argument-name "NUM"
 425                       :description "Z component of unit vector of vehicle ground plane.")
 426              (lispobj :long-name "d"
 427                       :description "Distance of vehicle ground plane."))))
 428     (group
 429      (:header "Manage Acquisition Projects:")
 430      (text :contents "An acquisition project is a set of measurements which share a set of data tables and views named like dat-<acquisition-project-name>-point, dat-<acquisition-project-name>-image, dat-<acquisition-project-name>-aggregate.")
 431      (stropt :long-name "create-acquisition-project"
 432              :argument-name "NAME"
 433              :description "Create a fresh set of canonically named data tables.  NAME 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.")
 434      (stropt :long-name "delete-acquisition-project"
 435              :argument-name "NAME"
 436              :description "Ask for confirmation, then delete acquisition project NAME and all its measurements.")
 437      (lispobj :long-name "delete-measurement"
 438               :typespec 'integer :argument-name "INT"
 439               :description "Delete a measurement by its ID.")
 440      (stropt :long-name "list-acquisition-project"
 441              :argument-name "NAME"
 442              :argument-type :optional
 443              :fallback-value "*"
 444              :description "List measurements of one acquisition project if its name is specified, or of all acquisition projects otherwise."))
 445     (group
 446      (:header "Store Measure Data:")
 447      (stropt :long-name "store-images-and-points" :short-name "s"
 448              :argument-name "NAME"
 449              :description "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.")
 450      (group ()
 451             (path :long-name "directory" :short-name "d"
 452                   :type :directory
 453                   :description "Directory containing one set of measuring data.")
 454             (setf common-root
 455                   (cli:make-path
 456                    :long-name "common-root" :short-name "r"
 457                    :env-var "PHOROS_COMMON_ROOT"
 458                    :type :directory
 459                    :description "The root part of directory that is equal for all pojects.  TODO: come up with some sensible default."))
 460             (lispobj :long-name "epsilon"
 461                      :typespec 'real :argument-name "NUM"
 462                      :default-value .001
 463                      :description "Difference in seconds below which two timestamps are considered equal.")
 464             (switch :long-name "aggregate-events"
 465                     :default-value nil
 466                     :description "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."))
 467      (stropt :long-name "insert-footprints"
 468              :argument-name "NAME"
 469              :description "Update image footprints (the area on the ground that is most probably covered by the respective image) for acquisition project NAME."))
 470     (group
 471      (:header "Become An HTTP Presentation Server:")
 472      (text :contents "Phoros is a Web server in its own right, but you can also put it behind a proxy server to make it part of a larger Web site.  E.g., for Apache, load module proxy_http and use this configuration:
 473     ProxyPass /phoros http://127.0.0.1:8080/phoros
 474     ProxyPassReverse /phoros http://127.0.0.1:8080/phoros")
 475      (flag :long-name "server"
 476            :description "Start HTTP presentation server as a daemon.  Entry URIs are http://<host>:<port>/phoros/<presentation-project>.  Asynchronously update lacking image footprints (which should have been done already using --insert-footprints).")
 477      (group ()
 478             (stropt :long-name "proxy-root"
 479                     :default-value "phoros"
 480                     :description "First directory element of the server URL.  Must correspond to the proxy configuration if Phoros is hidden behind a proxy.")
 481             (stropt :long-name "address"
 482                     :default-value "*"
 483                     :description "Address (of local machine) server is to listen on.  Default is listening on all available addresses.")
 484             (lispobj :long-name "http-port"
 485                      :typespec 'integer :argument-name "INT"
 486                      :default-value 8080
 487                      :description "Port the presentation server listens on.")
 488             common-root
 489             (lispobj :long-name "images"
 490                      :typespec 'integer :argument-name "INT"
 491                      :default-value 4
 492                      :description "Number of photos displayed on HTTP client.")
 493             (stropt :long-name "aux-numeric-label"
 494                     :description "HTML label for an element of auxiliary numeric data.  Repeat if necessary.  The succession of labels should match the auxiliary data (defined by --numeric-column) of all presentation projects served by this server instance.")
 495             (stropt :long-name "aux-text-label"
 496                     :description "HTML label for an element of auxiliary text data.  Repeat if necessary.  The succession of labels should match the auxiliary data (defined by --text-column) of all presentation projects served by this server instance.")
 497             (stropt :long-name "login-intro"
 498                     :description "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>")
 499             (path :long-name "pid-file"
 500                   :env-var "PHOROS_PID_FILE"
 501                   :type :file
 502                   :default-value #P"phoros.pid"
 503                   :description "Where to put Phoros' PID when run as a daemon.")))
 504     (group
 505      (:header "Manage Presentation Projects:")
 506      (text :contents "A presentation project is a set of measurements that can be visited under a dedicated URL \(http://<host>:<port>/phoros/<presentation-project>).  Its extent may or may not be equal to the extent of an acquisition project.")
 507      (text :contents "Presentation projects have a table of user points and a table of user lines.  The former is associated with a trigger which may be defined to induce writing into the latter.")
 508      (stropt :long-name "create-presentation-project"
 509              :argument-name "NAME"
 510              :description "Create a fresh presentation project NAME which is to expose a set of measurements to certain users.")
 511      (stropt :long-name "delete-presentation-project"
 512              :argument-name "NAME"
 513              :description "Ask for confirmation, then delete the presentation project including its table of user-generated points.")
 514      (stropt :long-name "list-presentation-project"
 515              :argument-name "NAME"
 516              :argument-type :optional
 517              :fallback-value "*"
 518              :description "List one presentation project if specified, or all presentation projects if not.")
 519      (stropt :long-name "add-to-presentation-project"
 520              :argument-name "NAME"
 521              :description "Add to presentation project NAME either certain measurements or all measurements currently in a certain acquisition project.")
 522      (stropt :long-name "remove-from-presentation-project"
 523              :argument-name "NAME"
 524              :description "Remove from presentation project NAME either certain measurements or all measurements currently in a certain acquisition project.")
 525      (group ()
 526             (lispobj :long-name "measurement-id"
 527                      :typespec 'integer :argument-name "ID"
 528                      :description "One measurement-id to add or remove.  Repeat if necessary.")
 529             (stropt :long-name "acquisition-project"
 530                     :argument-name "NAME"
 531                     :description "The acquisition project whose measurements are to add or remove.")
 532             (stropt :long-name "redefine-trigger-function"
 533                     :argument-name "NAME"
 534                     :description "Change body of the trigger function that is fired on changes to the user point table connected to presentation project NAME.")
 535             (path :long-name "plpgsql-body"
 536                   :type :file
 537                   :description "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.")))
 538     (group
 539      (:header "Define Selectable Attributes For Images:")
 540      (text :contents "HTTP client users can select classes of images defined here.  Attributes are defined as PostgreSQL expressions and may use the following column names:")
 541      ;; ... which are obtainable like so:
 542      ;;   SELECT column_name
 543      ;;   FROM information_schema.columns
 544      ;;   WHERE table_name = 'dat_<acquisition-project>_aggregate';
 545      (text :contents "recorded_device_id, device_stage_of_life_id, generic_device_id, random, presentation_project_id, directory, measurement_id, filename, byte_position, point_id, footprint, footprint_device_stage_of_life_id, trigger_time, longitude, latitude, ellipsoid_height, cartesian_system, east_sd, north_sd, height_sd, roll, pitch, heading, roll_sd, pitch_sd, heading_sd, usable, sensor_width_pix, sensor_height_pix, pix_size, bayer_pattern, color_raiser, mounting_angle, dx, dy, dz, omega, phi, kappa, c, xh, yh, a1, a2, a3, b1, b2, c1, c2, r0, b_dx, b_dy, b_dz, b_rotx, b_roty, b_rotz, b_ddx, b_ddy, b_ddz, b_drotx, b_droty, b_drotz, nx, ny, nz, d.")
 546      (text :contents "Additionally, each of the column names can be prefixed by \"first_\" in order to refer to image data of the first image. (Example: \"measurement_id = first_measurement_id\" only displays images with equal measurement_id.)")
 547      (stropt :long-name "create-image-attribute"
 548              :argument-name "NAME"
 549              :description "Store, for presentation project NAME, a PostgreSQL expression an HTTP client user can use to select some subset of the images available.")
 550      (stropt :long-name "delete-image-attribute"
 551              :argument-name "NAME"
 552              :description "Delete presentation project NAME an image restriction identified by its tag.")
 553      (stropt :long-name "list-image-attribute"
 554              :argument-name "NAME"
 555              :argument-type :optional
 556              :fallback-value "*"
 557              :description "List restricting PostgreSQL expressions for presentation project NAME, or for all presentation projects.  If --tag is specified, list only matching expressions.")
 558      (group ()
 559             (stropt :long-name "tag"
 560                     :description "Identifying tag for the restriction.  Should be both short and descriptive as it is shown as a selectable item on HTTP client.")
 561             (stropt :long-name "sql-clause"
 562                     :description "Boolean PostgreSQL expression, to be used as an AND clause.  Should yield FALSE for images that are to be excluded.")))
 563     (group
 564      (:header "Connect A Presentation Project To A Table Of Auxiliary Data:")
 565      (text :contents "Arbitrary data from tables not directly belonging to any Phoros project can be connected to a presentation project by means of a view named phoros-<presentation-project-name>-aux-point with columns coordinates (geometry), aux-numeric (null or array of numeric), and aux-text (null or array of text).")
 566      (text :contents "The array elements of both aux-numeric and aux-text of auxiliary points can then be incorporated into neighbouring user points during user point creation.")
 567      (text :contents "To match the array elements to the labels shown on HTTP client (defined by --aux-numeric-label, --aux-text-label), NULL array elements can be used act as placeholders where appropriate.")
 568      (text :contents "Also, a walk mode along auxiliary points becomes available to the HTTP client.  PL/pgSQL function phoros-<presentation-project-name>-thread-aux-points is created to this end.")
 569      (text :contents "In order to be accessible by Phoros, auxiliary data must be structured rather simple (a single table which has a geometry column and some numeric and/or text columns).  You may want to create a simplifying view if your data looks more complicated.")
 570      (stropt :long-name "create-aux-view"
 571              :argument-name "NAME"
 572              :description "Connect table of auxiliary data with presentation project NAME by creating a view.")
 573      (group ()
 574             (stropt :long-name "aux-table"
 575                     :argument-name "NAME"
 576                     :description "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.")
 577             (stropt :long-name "coordinates-column"
 578                     :argument-name "NAME"
 579                     :default-value "the-geom"
 580                     :description "Name of the geometry column (which must contain geographic coordinates, SRID=4326; and which should have an index) in the auxiliary data table.")
 581             (stropt :long-name "numeric-column"
 582                     :argument-name "NAME"
 583                     :description "Name of a numeric column in the auxiliary data table.  An empty string defines an empty placeholder column.  Repeat if necessary.")
 584             (stropt :long-name "text-column"
 585                     :argument-name "NAME"
 586                     :description "Name of a text column in the auxiliary data table.  An empty string defines an empty placeholder column.  Repeat if necessary.")))
 587     (group
 588      (:header "Manage User Points:")
 589      (:text :contents "Backup/restore of user points; especially useful for getting them through database upgrades.")
 590      (stropt :long-name "get-user-points"
 591              :argument-name "NAME"
 592              :description "Save user points of presentation project NAME.")
 593      (stropt :long-name "store-user-points"
 594              :argument-name "NAME"
 595              :description "Store user points previously saved (using --get-user-points or download button in Web interface) into presentation project NAME.")
 596      (group ()
 597             (path :long-name "json-file"
 598                   :type :file
 599                   :description "Path to GeoJSON file.")))
 600     (group
 601      (:header "Manage Presentation Project Users:")
 602      (stropt :long-name "create-user"
 603              :argument-name "ID"
 604              :description "Create or update user (specified by their alphanummeric ID) of certain presentation projects, deleting any pre-existing permissions of that user.")
 605      (group ()
 606             (stropt :long-name "user-password"
 607                     :argument-name "PWD"
 608                     :description "User's password.")
 609             (stropt :long-name "user-full-name"
 610                     :description "User's real name.")
 611             (enum :long-name "user-role"
 612                   :enum '(:read :write :admin)
 613                   :default-value :read
 614                   :description "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.")
 615             (stropt :long-name "presentation-project"
 616                     :argument-name "NAME"
 617                     :description "Presentation project the user is allowed to see.  Repeat if necessary."))
 618      (stropt :long-name "delete-user"
 619              :argument-name "ID"
 620              :description "Delete user.")
 621      (stropt :long-name "list-user"
 622              :argument-name "ID"
 623              :argument-type :optional
 624              :fallback-value "*"
 625              :description "List the specified user with their presentation projects, or all users if no user is given."))))
 626
 627 (defun cli:first-action-option (&rest options)
 628   "Run action called <option>-action for the first non-nil option;
 629 return its value."
 630   (cli:with-context (cli:make-context)
 631      (loop
 632         for option in options
 633         when (cli:getopt :long-name (string-downcase option))
 634         return (funcall (symbol-function (intern (concatenate 'string
 635                                                               (string option)
 636                                                               "-ACTION")
 637                                                  :cli)))
 638         finally (cli:help :theme "etc/one-line.cth"))))
 639
 640 (defun cli:main ()
 641   "The UNIX command line entry point."
 642   (handler-bind
 643       ((sb-sys:interactive-interrupt
 644         (lambda (c)
 645           (declare (ignore c))
 646           (cl-log:log-message
 647            :error "Interactive interrupt.")
 648           #+sbcl(sb-ext:exit :code 2 :abort t)))
 649        (serious-condition
 650         (lambda (c)
 651           (cl-log:log-message
 652            :error "~A ~:[~;[Backtrace follows]~&~A~]~&"
 653            c
 654            (cli:verbosity-level :log-error-backtraces)
 655            (trivial-backtrace:print-backtrace c :output nil))
 656           (format *error-output* "~A~&" c)
 657           (sb-ext:exit :code 1 :abort t)))
 658        (warning
 659         (lambda (c) (cl-log:log-message :warning "~A" c))))
 660     (cffi:use-foreign-library phoml)
 661     (cli:set-.phoros-options)
 662     (cli:with-options (:tolerate-missing t)
 663         ((verbose) umask images (aux-numeric-label) (aux-text-label) (login-intro))
 664       (setf *verbosity* verbose)
 665       (setf *umask* umask)
 666       (setf *number-of-images* images)
 667       (setf *aux-numeric-labels* aux-numeric-label)
 668       (setf *aux-text-labels* aux-text-label)
 669       (setf *login-intro* login-intro))
 670     (cli:first-action-option 'help
 671                              'licence
 672                              'license
 673                              'version
 674                              'check-db
 675                              'check-dependencies
 676                              'nuke-all-tables
 677                              'create-sys-tables
 678                              'get-image
 679                              'store-camera-hardware
 680                              'store-lens
 681                              'store-generic-device
 682                              'store-device-stage-of-life
 683                              'store-device-stage-of-life-end
 684                              'store-camera-calibration
 685                              'create-acquisition-project
 686                              'delete-acquisition-project
 687                              'delete-measurement
 688                              'list-acquisition-project
 689                              'store-images-and-points
 690                              'insert-footprints
 691                              'server
 692                              'create-presentation-project
 693                              'delete-presentation-project
 694                              'list-presentation-project
 695                              'add-to-presentation-project
 696                              'remove-from-presentation-project
 697                              'redefine-trigger-function
 698                              'create-image-attribute
 699                              'delete-image-attribute
 700                              'list-image-attribute
 701                              'create-aux-view
 702                              'get-user-points
 703                              'store-user-points
 704                              'create-user
 705                              'delete-user
 706                              'list-user)
 707     (sb-ext:exit :code *unix-exit-code*)))
 708
 709 (defun cli:set-.phoros-options ()
 710   "Set previously non-existent environment variables, whose names must
 711 start with PHOROS_, according to the most relevant .phoros file."
 712   (let ((.phoros-path (or (probe-file
 713                            (make-pathname
 714                             :name ".phoros"
 715                             :defaults *default-pathname-defaults*))
 716                           (probe-file
 717                            (make-pathname
 718                             :name ".phoros"
 719                             :directory (directory-namestring
 720                                         (user-homedir-pathname)))))))
 721     (when .phoros-path
 722       #+sbcl
 723       (with-open-file (s .phoros-path)
 724         (loop
 725            for line = (read-line s nil nil)
 726            while line
 727            for option = (string-trim " " line)
 728            for (name value junk) = (cl-utilities:split-sequence #\= option)
 729            when (and (>= (length name) 7)
 730                      (string= (subseq name 0 7) "PHOROS_")
 731                      value
 732                      (not junk))
 733            do (sb-posix:setenv name value 0)))
 734       #-sbcl
 735       (warn "Ignoring settings from ~A" .phoros-path))))
 736
 737 (defun cli:verbosity-level (topic)
 738   "Return the number associated with verbose topic, or nil if the
 739 number is 0 or doesn't exist."
 740   (let* ((digested-verbosity
 741           (loop
 742              for entry in *verbosity*
 743              collect
 744                (destructuring-bind (topic &optional level)
 745                    (cl-utilities:split-sequence
 746                     #\: entry :count 2 :remove-empty-subseqs t)
 747                  (cons (intern (string-upcase topic) 'keyword)
 748                        (ignore-errors
 749                          (parse-integer level :junk-allowed t))))))
 750          (level (cdr (assoc topic digested-verbosity))))
 751     (unless (or (null level) (zerop level))
 752       level)))
 753
 754 (defun cli:set-umask ()
 755   "Set umask to the value from its octal representation stored in
 756 *umask*"
 757   (let ((umask (ignore-errors (parse-integer *umask* :radix 8))))
 758     (assert (typep umask '(integer #o000 #o777)) ()
 759             "~O is not a valid umask."
 760             *umask*)
 761     #+sbcl(sb-posix:umask umask)
 762     #-sbcl(warn "Ignoring umask.")))
 763
 764 (defun cli:getopt-mandatory (long-name)
 765   "Return value of command line option long-name if any. Otherwise
 766 signal error."
 767   (multiple-value-bind (value supplied-p) (cli:getopt :long-name long-name)
 768     (assert supplied-p () "Missing option --~A." long-name)
 769     value))
 770
 771 (defun cli:help-action ()
 772   (cli:with-options () (help)
 773     (ecase help
 774       (:long (cli:help :theme "etc/phoros.cth"))
 775       (:short (cli:help :theme "etc/short.cth")))))
 776
 777 (defun cli:version-action ()
 778   "Print --version message. TODO: OpenLayers, Proj4js version."
 779   (cli:with-options () (version)
 780     (ecase version
 781       (:all
 782        (format
 783         *standard-output*
 784         "~&~A version ~A~&  ~A version ~A~&  ~
 785         Proj4 library: ~A~&  PhoML version ~A~&"
 786         *phoros-description*
 787         (phoros-version)
 788         (lisp-implementation-type) (lisp-implementation-version)
 789         (proj:version)
 790         (phoml:get-version-number)))
 791       (:minimal
 792        (format *standard-output* "~&~A~&" (phoros-version))))))
 793
 794 (defun cli:licence-action ()
 795   "Print --licence boilerplate."
 796   (format *standard-output* "~&~A~&" *phoros-licence*))
 797
 798 (defun cli:license-action ()
 799   (cli:licence-action))
 800
 801 (defun cli:check-db-action ()
 802   "Tell us if databases are accessible."
 803   (cli:with-options ()
 804       (host port database user use-ssl
 805             aux-host aux-port
 806             aux-database aux-user aux-password password aux-use-ssl)
 807     (format *error-output*
 808             "Checking database ~A at ~A:~D and ~
 809             auxiliary database ~A at ~A:~D.~%"
 810             database host port
 811             aux-database aux-host aux-port)
 812     (if (and
 813          (check-db (list database user password host
 814                          :port port
 815                          :use-ssl (s-sql:from-sql-name use-ssl)))
 816          (check-db (list aux-database aux-user aux-password aux-host
 817                          :port aux-port
 818                          :use-ssl (s-sql:from-sql-name aux-use-ssl))))
 819         (progn
 820           (format *error-output*
 821                   "Both are accessible.~%")
 822           (setf *unix-exit-code* 0))
 823         (setf *unix-exit-code* 32))))
 824
 825 (defun cli:check-dependencies-action ()
 826   "Say OK if the necessary external dependencies are available."
 827   (check-dependencies))
 828
 829 (defun cli:nuke-all-tables-action ()
 830   "Drop the bomb.  Ask for confirmation first."
 831   (cli:with-options (:database t :log t) ()
 832     (when (yes-or-no-p
 833            "You asked me to delete anything in database ~A at ~A:~D.  ~
 834            Proceed?"
 835            database host port)
 836       (nuke-all-tables))
 837     (cl-log:log-message
 838      :db-sys "Nuked database ~A at ~A:~D.  Back to square one!"
 839      database host port)))
 840
 841 (defun cli:create-sys-tables-action ()
 842   "Make a set of sys-* tables.  Ask for confirmation first."
 843   (cli:with-options (:database t :log t) ()
 844     (when (yes-or-no-p
 845            "You asked me to create a set of sys-* tables ~
 846            in database ~A at ~A:~D.  ~
 847            Make sure you know what you are doing.  Proceed?"
 848            database host port)
 849       (create-sys-tables))
 850     (cl-log:log-message
 851      :db-sys "Created a fresh set of system tables in database ~A at ~A:~D."
 852      database host port)))
 853
 854 (defun cli:create-acquisition-project-action ()
 855   "Make a set of data tables."
 856   (cli:with-options (:database t :log t) (create-acquisition-project)
 857     (let ((common-table-name create-acquisition-project))
 858       (create-acquisition-project common-table-name)
 859       (cl-log:log-message
 860        :db-dat
 861        "Created a fresh acquisition project by the name of ~A ~
 862        in database ~A at ~A:~D."
 863        common-table-name database host port))))
 864
 865 (defun cli:delete-acquisition-project-action ()
 866   "Delete an acquisition project."
 867   (cli:with-options (:database t :log t) (delete-acquisition-project)
 868     (let ((common-table-name delete-acquisition-project))
 869       (assert-acquisition-project common-table-name)
 870       (when (yes-or-no-p
 871              "You asked me to delete acquisition-project ~A ~
 872              (including all its measurements) ~
 873              from database ~A at ~A:~D.  Proceed?"
 874              common-table-name database host port)
 875         (let ((project-did-exist-p
 876                  (delete-acquisition-project common-table-name)))
 877             (cl-log:log-message
 878              :db-dat
 879              "~:[Tried to delete nonexistent~;Deleted~] ~
 880              acquisition project ~A from database ~A at ~A:~D."
 881              project-did-exist-p common-table-name database host port))))))
 882
 883 (defun cli:delete-measurement-action ()
 884   "Delete a measurement by its measurement-id."
 885   (cli:with-options (:database t :log t) (delete-measurement)
 886     (let* ((measurement-id delete-measurement)
 887            (measurement-did-exist-p (delete-measurement measurement-id)))
 888       (cl-log:log-message
 889        :db-dat
 890        "~:[Tried to delete nonexistent~;Deleted~] ~
 891        measurement with ID ~A from database ~A at ~A:~D."
 892        measurement-did-exist-p measurement-id database host port))))
 893
 894 (defun cli:list-acquisition-project-action ()
 895   "List content of acquisition projects."
 896   (cli:with-options (:database t) (list-acquisition-project)
 897     (let* ((common-table-name  (if (string= list-acquisition-project "*")
 898                                    'common-table-name
 899                                    list-acquisition-project))
 900            (content
 901             (query
 902              (:order-by
 903               (:select
 904                'common-table-name
 905                'sys-acquisition-project.acquisition-project-id
 906                'measurement-id
 907                'directory
 908                'cartesian-system
 909                :from
 910                'sys-acquisition-project :natural :left-join 'sys-measurement
 911                :where (:= 'common-table-name common-table-name))
 912               'measurement-id))))
 913       (cli:format-table *standard-output* content
 914                         '("Acquisition Project" "ID" "Meas. ID"
 915                           "Directory" "Cartesian CS")))))
 916
 917 (defun cli:store-images-and-points-action ()
 918   "Put data into the data tables."
 919   (cli:with-options (:database t :log t)
 920       (directory epsilon common-root aggregate-events store-images-and-points)
 921     (let ((common-table-name store-images-and-points))
 922       (assert-acquisition-project common-table-name)
 923       (cl-log:log-message
 924        :db-dat
 925        "Start: storing data from ~A into acquisition project ~A ~
 926        in database ~A at ~A:~D."
 927        directory common-table-name database host port)
 928       (store-images-and-points common-table-name directory
 929                                :epsilon epsilon
 930                                :root-dir common-root
 931                                :aggregate-events aggregate-events)
 932       (cl-log:log-message
 933        :db-dat
 934        "Finish: storing data from ~A into acquisition project ~A ~
 935        in database ~A at ~A:~D."
 936        directory common-table-name database host port)
 937       (let ((points-deleted
 938              (delete-imageless-points common-table-name)))
 939         (cl-log:log-message
 940          :db-dat
 941          "Checked acquisition project ~A in database ~A at ~A:~D ~
 942          for imageless points~[; found none.~;. Found and deleted ~:*~D.~]"
 943          common-table-name database host port
 944          points-deleted)))))
 945
 946 (defun cli:insert-footprints-action ()
 947   "Update image footprints."
 948   (cli:with-options (:database t :log t) (host port database user password use-ssl
 949                           log-dir
 950                           insert-footprints)
 951     (let ((common-table-name insert-footprints))
 952       (assert-acquisition-project common-table-name)
 953       (cl-log:log-message
 954        :db-dat
 955        "Updating image footprints of acquisition project ~A ~
 956        in database ~A at ~A:~D."
 957        common-table-name database host port)
 958       (let ((number-of-updated-footprints
 959              (insert-footprints common-table-name)))
 960         (cl-log:log-message
 961          :db-dat
 962          "~:[All image footprints belonging to acquisition project ~*~A ~
 963          in database ~A at ~A:~D are up to date.~
 964              ~;Updated ~D image footprint~:P of acquisition project ~A ~
 965                in database ~A at ~A:~D.~]"
 966          (plusp number-of-updated-footprints) number-of-updated-footprints
 967          common-table-name database host port)))))
 968
 969 ;;; We don't seem to have two-dimensional arrays in postmodern
 970 ;;(defun cli:canonicalize-bayer-pattern (raw &optional sql-string-p)
 971 ;;  "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."
 972 ;;  (when raw
 973 ;;    (let* ((array
 974 ;;            (loop
 975 ;;               for row in raw
 976 ;;               collect
 977 ;;               (loop
 978 ;;                  for hex-color in (cl-utilities:split-sequence #\, row)
 979 ;;                  collect
 980 ;;                  (let ((*read-base* 16))
 981 ;;                    (assert (eql (elt hex-color 0) #\#) () "~A is not a valid color" hex-color)
 982 ;;                    (read-from-string
 983 ;;                     (concatenate 'string
 984 ;;                                  (subseq hex-color 5 7)
 985 ;;                                  (subseq hex-color 3 5)
 986 ;;                                  (subseq hex-color 1 3))
 987 ;;                     nil)))))
 988 ;;           (rows (length array))
 989 ;;           (columns (length (elt array 0))))
 990 ;;      (if sql-string-p
 991 ;;          (format nil "{~{{~{~A~#^,~}}~}}" array)
 992 ;;          (make-array (list rows columns) :initial-contents array)))))
 993
 994 (defun cli:canonicalize-bayer-pattern (raw &optional sql-string-p)
 995   "Convert a string of comma-separated hex color strings (ex: #ff0000
 996 for red) into a vector of integers.  If sql-string-p is t, convert it
 997 into a string in SQL syntax."
 998   (when raw
 999     (let* ((vector
1000             (loop
1001                for hex-color in (cl-utilities:split-sequence #\, raw)
1002                collect
1003                  (let ((*read-base* 16))
1004                    (assert (eql (elt hex-color 0) #\#)
1005                            () "~A is not a valid color" hex-color)
1006                    (read-from-string
1007                     (concatenate 'string
1008                                  (subseq hex-color 5 7)
1009                                  (subseq hex-color 3 5)
1010                                  (subseq hex-color 1 3))
1011                     nil))))
1012            (columns (length vector)))
1013       (if sql-string-p
1014           (format nil "{~{~A~#^,~}}" vector)
1015           (make-array (list columns) :initial-contents vector)))))
1016
1017 (defun cli:canonicalize-color-raiser (raw &optional sql-string-p)
1018   "Convert string of comma-separated numbers into a vector.  If
1019 sql-string-p is t, convert it into a string in SQL syntax."
1020   (when raw
1021     (let* ((vector
1022             (loop
1023                for multiplier in (cl-utilities:split-sequence #\, raw :count 3)
1024                collect
1025                  (read-from-string multiplier nil))))
1026       (if sql-string-p
1027           (format nil "{~{~A~#^,~}}" vector)
1028           (make-array '(3) :initial-contents vector)))))
1029
1030 (defun cli:store-camera-hardware-action ()
1031   (cli:with-options (:database t :log t)
1032       (try-overwrite
1033        sensor-width-pix
1034        sensor-height-pix
1035        pix-size
1036        channels
1037        pix-depth
1038        color-raiser
1039        bayer-pattern
1040        serial-number
1041        description)
1042     (format *standard-output* "~D~%"
1043             (store-camera-hardware
1044              :try-overwrite try-overwrite
1045              :sensor-width-pix sensor-width-pix
1046              :sensor-height-pix sensor-height-pix
1047              :pix-size pix-size
1048              :channels channels
1049              :pix-depth pix-depth
1050              :color-raiser (cli:canonicalize-color-raiser color-raiser)
1051              :bayer-pattern (cli:canonicalize-bayer-pattern bayer-pattern)
1052              :serial-number (string-trim " " serial-number)
1053              :description (string-trim " " description)))))
1054
1055 (defun cli:store-lens-action ()
1056   (cli:with-options (:database t :log t)
1057       (try-overwrite
1058        c
1059        serial-number
1060        description)
1061     (format *standard-output* "~D~%"
1062             (store-lens
1063              :try-overwrite try-overwrite
1064              :c c
1065              :serial-number (string-trim " " serial-number)
1066              :description (string-trim " " description)))))
1067
1068 (defun cli:store-generic-device-action ()
1069   (cli:with-options (:database t :log t)
1070       (camera-hardware-id
1071        lens-id
1072        scanner-id)
1073     (format *standard-output* "~D~%"
1074             (store-generic-device
1075              :camera-hardware-id camera-hardware-id
1076              :lens-id lens-id
1077              :scanner-id scanner-id))))
1078
1079 (defun cli:string-or-null (string)
1080   "If string is \":null\", return :null; otherwise return string."
1081   (if (string-equal string ":null") :null string))
1082
1083 (defun cli:store-device-stage-of-life-action ()
1084   (cli:with-options (:database t :log t)
1085       (unmounting-date
1086        try-overwrite
1087        recorded-device-id
1088        event-number
1089        generic-device-id
1090        vehicle-name
1091        casing-name
1092        computer-name
1093        computer-interface-name
1094        mounting-date)
1095     (format *standard-output* "~D~%"
1096             (store-device-stage-of-life
1097              :unmounting-date (cli:string-or-null unmounting-date)
1098              :try-overwrite try-overwrite
1099              :recorded-device-id recorded-device-id
1100              :event-number event-number
1101              :generic-device-id generic-device-id
1102              :vehicle-name (string-trim " " vehicle-name)
1103              :casing-name (string-trim " " casing-name)
1104              :computer-name (string-trim " " computer-name)
1105              :computer-interface-name computer-interface-name
1106              :mounting-date mounting-date))))
1107
1108 (defun cli:store-device-stage-of-life-end-action ()
1109   (cli:with-options (:database t :log t)
1110       (device-stage-of-life-id
1111        unmounting-date)
1112     (format *standard-output* "~D~%"
1113             (store-device-stage-of-life-end
1114              :device-stage-of-life-id device-stage-of-life-id
1115              :unmounting-date unmounting-date))))
1116
1117 (defun cli:store-camera-calibration-action ()
1118   (cli:with-options (:database t :log t)
1119       (usable
1120        device-stage-of-life-id
1121        date
1122        person
1123        main-description
1124        debug
1125        photogrammetry-version
1126        mounting-angle
1127        inner-orientation-description
1128        c
1129        xh
1130        yh
1131        a1
1132        a2
1133        a3
1134        b1
1135        b2
1136        c1
1137        c2
1138        r0
1139        outer-orientation-description
1140        dx
1141        dy
1142        dz
1143        omega
1144        phi
1145        kappa
1146        boresight-description
1147        b-dx
1148        b-dy
1149        b-dz
1150        b-ddx
1151        b-ddy
1152        b-ddz
1153        b-rotx
1154        b-roty
1155        b-rotz
1156        b-drotx
1157        b-droty
1158        b-drotz
1159        nx
1160        ny
1161        nz
1162        d)
1163     (format *standard-output* "~D~%"
1164             (store-camera-calibration
1165              :usable usable
1166              :device-stage-of-life-id device-stage-of-life-id
1167              :date date
1168              :person person
1169              :main-description main-description
1170              :debug debug
1171              :photogrammetry-version photogrammetry-version
1172              :mounting-angle mounting-angle
1173              :inner-orientation-description (string-trim " " inner-orientation-description)
1174              :c c
1175              :xh xh
1176              :yh yh
1177              :a1 a1
1178              :a2 a2
1179              :a3 a3
1180              :b1 b1
1181              :b2 b2
1182              :c1 c1
1183              :c2 c2
1184              :r0 r0
1185              :outer-orientation-description (string-trim " " outer-orientation-description)
1186              :dx dx
1187              :dy dy
1188              :dz dz
1189              :omega omega
1190              :phi phi
1191              :kappa kappa
1192              :boresight-description (string-trim " " boresight-description)
1193              :b-dx b-dx
1194              :b-dy b-dy
1195              :b-dz b-dz
1196              :b-ddx b-ddx
1197              :b-ddy b-ddy
1198              :b-ddz b-ddz
1199              :b-rotx b-rotx
1200              :b-roty b-roty
1201              :b-rotz b-rotz
1202              :b-drotx b-drotx
1203              :b-droty b-droty
1204              :b-drotz b-drotz
1205              :nx nx
1206              :ny ny
1207              :nz nz
1208              :d d))))
1209
1210 (defun cli:get-image-action ()
1211   "Output a PNG file extracted from a .pictures file; print its
1212 trigger-time to stdout."
1213   (cli:with-options () (in out bayer-pattern color-raiser)
1214     (cli:with-options (:tolerate-missing t) (count byte-position)
1215       (with-open-file (out-stream out :direction :output
1216                                   :element-type 'unsigned-byte
1217                                   :if-exists :supersede)
1218         (let ((trigger-time
1219                (if byte-position
1220                    (send-png out-stream in byte-position
1221                              :bayer-pattern
1222                              (cli:canonicalize-bayer-pattern bayer-pattern)
1223                              :color-raiser
1224                              (cli:canonicalize-color-raiser color-raiser))
1225                    (send-nth-png count out-stream in
1226                                  :bayer-pattern
1227                                  (cli:canonicalize-bayer-pattern
1228                                   bayer-pattern)
1229                                  :color-raiser
1230                                  (cli:canonicalize-color-raiser
1231                                   color-raiser)))))
1232           (format *standard-output*
1233                   "~&~A~%" (timestring (utc-from-unix trigger-time))))))))
1234
1235 (defun cli:create-presentation-project-action ()
1236   "Make a presentation project."
1237   (cli:with-options (:database t :log t) (create-presentation-project)
1238     (let* ((presentation-project-name create-presentation-project)
1239            (fresh-project-p
1240             (create-presentation-project presentation-project-name)))
1241       (cl-log:log-message
1242        :db-dat
1243        "~:[Tried to recreate an existing~;Created a fresh~] ~
1244        presentation project by the name of ~A in database ~A at ~A:~D."
1245        fresh-project-p presentation-project-name database host port))))
1246
1247 (defun cli:delete-presentation-project-action ()
1248   "Delete a presentation project."
1249   (cli:with-options (:database t :log t) (delete-presentation-project)
1250     (let ((presentation-project-name delete-presentation-project))
1251       (assert-presentation-project presentation-project-name)
1252       (when (yes-or-no-p
1253              "You asked me to delete presentation-project ~A ~
1254              (including its tables of user-defined points and lines, ~
1255              ~A and ~A respectively) from database ~A at ~A:~D.  Proceed?"
1256              presentation-project-name
1257              (user-point-table-name presentation-project-name)
1258              (user-line-table-name presentation-project-name)
1259              database host port)
1260         (let ((project-did-exist-p
1261                (delete-presentation-project presentation-project-name)))
1262           (cl-log:log-message
1263            :db-dat
1264            "~:[Tried to delete nonexistent~;Deleted~] ~
1265            presentation project ~A from database ~A at ~A:~D."
1266            project-did-exist-p presentation-project-name
1267            database host port))))))
1268
1269 (defun cli:add-to-presentation-project-action ()
1270   "Add measurements to a presentation project."
1271   (cli:with-options (:database t :log t)
1272       (add-to-presentation-project)
1273     (cli:with-options (:tolerate-missing t)
1274         (measurement-id acquisition-project)
1275       (let ((presentation-project-name add-to-presentation-project))
1276         (assert-presentation-project presentation-project-name)
1277         (add-to-presentation-project presentation-project-name
1278                                      :measurement-ids measurement-id
1279                                      :acquisition-project acquisition-project)
1280         (cl-log:log-message
1281          :db-dat
1282          "Added ~@[measurement-ids ~{~D~#^, ~}~]~
1283        ~@[all measurements from acquisition project ~A~] ~
1284        to presentation project ~A in database ~A at ~A:~D."
1285          measurement-id acquisition-project
1286          presentation-project-name database host port)))))
1287
1288 (defun cli:remove-from-presentation-project-action ()
1289   "Add measurements to a presentation project."
1290   (cli:with-options (:database t :log t)
1291       (measurement-id acquisition-project remove-from-presentation-project)
1292     (let ((presentation-project-name remove-from-presentation-project))
1293       (assert-presentation-project presentation-project-name)
1294       (remove-from-presentation-project
1295          presentation-project-name
1296          :measurement-ids measurement-id
1297          :acquisition-project acquisition-project)
1298       (cl-log:log-message
1299        :db-dat
1300        "Removed ~@[measurement-ids ~{~D~#^, ~}~]~
1301        ~@[all measurements that belong to acquisition project ~A~] ~
1302        from presentation project ~A in database ~A at ~A:~D."
1303        measurement-id acquisition-project
1304        presentation-project-name database host port))))
1305
1306 (defun cli:create-image-attribute-action ()
1307   "Store a boolean SQL expression."
1308   (cli:with-options (:database t :log t)
1309       (tag sql-clause create-image-attribute)
1310     (let ((presentation-project-name create-image-attribute))
1311       (assert-presentation-project presentation-project-name)
1312       (multiple-value-bind (old-image-attribute
1313                             number-of-selected-images
1314                             total-number-of-images)
1315           (create-image-attribute presentation-project-name
1316                                   :tag tag :sql-clause sql-clause)
1317         (cl-log:log-message
1318          :db-dat
1319          "~:[Stored a fresh~;Updated an~] ~
1320          image attribute, tagged ~S, for presentation project ~A ~
1321          in database ~A at ~A:~D~
1322          ~0@*~@[, replacing the SQL clause previously stored there of ~S~].  ~
1323          ~6@*~@[The new SQL clause currently selects ~D out of ~D images.~]"
1324          old-image-attribute
1325          tag
1326          presentation-project-name
1327          database host port
1328          number-of-selected-images total-number-of-images)))))
1329
1330 (defun cli:delete-image-attribute-action ()
1331   "Remove SQL expression specified by presentation-project-name and tag."
1332   (cli:with-options (:database t :log t)
1333       (tag delete-image-attribute)
1334     (let ((presentation-project-name delete-image-attribute))
1335       (assert-presentation-project presentation-project-name)
1336       (let ((replaced-sql-clause
1337              (delete-image-attribute presentation-project-name :tag tag)))
1338         (cl-log:log-message
1339          :db-dat
1340          "~:[Tried to delete a nonexistent~;Deleted~] ~
1341        image attribute tagged ~S from ~
1342        presentation project ~A in database ~A at ~A:~D.  ~
1343        ~0@*~@[Its SQL clause, now deleted, was ~S~]"
1344          replaced-sql-clause tag presentation-project-name
1345          database host port)))))
1346
1347 (defun cli:list-image-attribute-action ()
1348   "List boolean SQL expressions."
1349   (cli:with-options (:database t) (tag list-image-attribute)
1350     (let* ((presentation-project-name (if (string= list-image-attribute "*")
1351                                           'presentation-project-name
1352                                           list-image-attribute))
1353            (restriction-id (or tag 'restriction-id))
1354            (content
1355             (query
1356              (:order-by
1357               (:select 'presentation-project-name
1358                        'sys-selectable-restriction.presentation-project-id
1359                        'restriction-id
1360                        'sql-clause
1361                        :from 'sys-selectable-restriction
1362                        :natural :left-join 'sys-presentation-project
1363                        :where (:and (:= presentation-project-name
1364                                         'presentation-project-name)
1365                                     (:= restriction-id
1366                                         'restriction-id)))
1367               'presentation-project-name 'restriction-id))))
1368       (cli:format-table *standard-output* content
1369                         '("Presentation Project" "ID" "Tag" "SQL-clause")
1370                         :column-widths '(nil nil nil 60)))))
1371
1372 (defun cli:redefine-trigger-function-action ()
1373   "Recreate an SQL trigger function that is fired on changes to the
1374 user point table, and fire it once."
1375   (cli:with-options (:database t :log t)
1376       (plpgsql-body redefine-trigger-function)
1377     (let ((presentation-project-name redefine-trigger-function)
1378           (body-text (make-array '(1) :adjustable t :fill-pointer 0
1379                                  :element-type 'character)))
1380       (if plpgsql-body
1381           (with-open-file (stream plpgsql-body)
1382             (loop
1383                for c = (read-char stream nil)
1384                while c
1385                do (vector-push-extend c body-text))
1386             (create-presentation-project-trigger-function
1387              presentation-project-name
1388              body-text
1389              (s-sql:to-sql-name (user-point-table-name
1390                                  presentation-project-name))
1391              (s-sql:to-sql-name (user-line-table-name
1392                                  presentation-project-name))))
1393           (create-presentation-project-trigger-function
1394            presentation-project-name))
1395       (fire-presentation-project-trigger-function presentation-project-name)
1396       (cl-log:log-message
1397        :db-dat
1398        "Defined (and fired once) ~
1399        a trigger function associatad with user point table of ~
1400        presentation project ~A in database ~A at ~A:~D to ~
1401        ~:[perform a minimal default action.~;perform the body given ~
1402           in file ~:*~A, whose content is is:~&~A~]"
1403        presentation-project-name database host port
1404        plpgsql-body body-text))))
1405
1406 (defun cli:create-aux-view-action ()
1407   "Connect presentation project to an auxiliary data table by means of
1408 a view."
1409   (cli:with-options (:database t :log t) (create-aux-view)
1410     (assert-presentation-project create-aux-view))
1411   (cli:with-options (:aux-database t :log t)
1412       (host port database user password use-ssl
1413             coordinates-column (numeric-column) (text-column) aux-table
1414             create-aux-view)
1415     (let* ((presentation-project-name create-aux-view)
1416            (numeric-columns
1417             (nsubstitute nil "" numeric-column :test #'string=))
1418            (text-columns
1419             (nsubstitute nil "" text-column :test #'string=))
1420            (aux-view-in-phoros-db-p
1421             (every #'equal
1422                    (list host port database user password use-ssl)
1423                    (list aux-host aux-port aux-database
1424                          aux-user aux-password aux-use-ssl)))
1425            (aux-view-exists-p
1426             (aux-view-exists-p presentation-project-name)))
1427       (when (or
1428              aux-view-in-phoros-db-p
1429              (yes-or-no-p
1430               "I'm going to ~:[create~;replace~] a view named ~A ~
1431               in database ~A at ~A:~D.  Proceed?"
1432               aux-view-exists-p
1433               (aux-point-view-name presentation-project-name)
1434               aux-database aux-host aux-port))
1435         (when aux-view-exists-p
1436           (delete-aux-view presentation-project-name))
1437         (create-aux-view presentation-project-name
1438                          :coordinates-column coordinates-column
1439                          :numeric-columns numeric-columns
1440                          :text-columns text-columns
1441                          :aux-table aux-table)
1442         (add-spherical-mercator-ref)
1443         (cl-log:log-message
1444          :db-dat
1445          "~:[Created~;Updated~] in database ~A at ~A:~D a view called ~A ~
1446          into table (of auxiliary data) ~A.  Coordinates column is ~A.  ~
1447          ~:[No numeric columns.~;Numeric column(s): ~:*~{~A~#^, ~}.~]  ~
1448          ~:[No text columns.~;Text column(s): ~:*~{~A~#^, ~}.~]  ~
1449          Also, ~0@*~:[created~;recreated~] in the same database a ~
1450          function called ~9@*~A."
1451          aux-view-exists-p
1452          aux-database aux-host aux-port
1453          (aux-point-view-name presentation-project-name)
1454          aux-table coordinates-column
1455          numeric-columns text-columns
1456          (thread-aux-points-function-name presentation-project-name))))))
1457
1458 (defun cli:store-user-points-action ()
1459   "Store user points from a GeoJSON file into database."
1460   (cli:with-options (:database t :log t) (json-file store-user-points)
1461     (let ((presentation-project store-user-points))
1462       (assert-presentation-project presentation-project)
1463       (multiple-value-bind
1464             (points-stored points-already-in-db points-tried zombie-users)
1465           (store-user-points presentation-project :json-file json-file)
1466         (cl-log:log-message
1467          :db-dat
1468          "Tried to store the ~D user point~:P I found in file ~A ~
1469          into presentation project ~A in database ~A at ~A:~D.  ~
1470          ~:[~:[~D~;None~*~]~;All~2*~] of them ~:[were~;was~] ~
1471          already present.  ~
1472          ~:[~:[~:[~D points have~;1 point has~*~]~;Nothing has~2*~]~
1473             ~;All points tried have~3*~] ~
1474          been added to the user point table.  ~
1475          ~15@*~@[I didn't know ~14@*~[~;a~:;any of the~] user~14@*~P ~
1476          called ~{~A~#^, ~}; treated them as zombie~14@*~P.~]"
1477          points-tried
1478          (truename json-file)
1479          presentation-project database host port
1480          (= points-already-in-db points-tried)
1481          (zerop points-already-in-db)
1482          points-already-in-db
1483          (<= points-already-in-db 1)
1484          (= points-stored points-tried)
1485          (zerop points-stored)
1486          (= 1 points-stored)
1487          points-stored
1488          (length zombie-users)          ;arg 14
1489          zombie-users)))))              ;arg 15
1490
1491 (defun cli:get-user-points-action ()
1492   "Save user points of presentation project into a GeoJSON file."
1493   (cli:with-options (:database t :log t) (json-file get-user-points)
1494     (let ((presentation-project get-user-points))
1495       (assert-presentation-project presentation-project)
1496       (multiple-value-bind (user-points user-point-count)
1497           (get-user-points (user-point-table-name presentation-project)
1498                            :indent t)
1499         (assert json-file ()
1500                 "Don't know where to store.  Try option --json-file")
1501         (unless (zerop user-point-count)
1502           (with-open-file (stream json-file
1503                                   :direction :output
1504                                   :if-exists :supersede)
1505             (princ user-points stream)))
1506         (cl-log:log-message
1507          :db-dat
1508          "~[There are no user points to get from presentation project ~A in ~
1509          database ~A at ~A:~D.  Didn't touch any file.~
1510          ~:;~:*Saved ~D user point~:P from presentation project ~A in ~
1511          database ~A at ~A:~D into file ~A.~]"
1512          user-point-count
1513          presentation-project database host port
1514          (ignore-errors (truename json-file)))))))
1515
1516 (defun cli:create-user-action ()
1517   "Define a new user."
1518   (cli:with-options (:database t :log t)
1519       ((presentation-project)
1520        user-full-name user-role user-password
1521        create-user)
1522     (let ((presentation-project-user create-user)
1523           fresh-user-p)
1524       (mapcar #'assert-presentation-project presentation-project)
1525       (setf fresh-user-p
1526             (create-user presentation-project-user
1527                          :presentation-projects presentation-project
1528                          :user-password user-password
1529                          :user-full-name user-full-name
1530                          :user-role user-role))
1531       (cl-log:log-message
1532        :db-dat ;TODO: We're listing nonexistent p-projects here as well.
1533        "~:[Updated~;Created~] user ~A (~A) who has ~A access ~
1534        to ~:[no ~;~]presentation project(s)~:*~{ ~A~#^,~} ~
1535        in database ~A at ~A:~D."
1536        fresh-user-p presentation-project-user
1537        user-full-name user-role
1538        presentation-project database host port))))
1539
1540 (defun cli:delete-user-action ()
1541   "Delete a presentation project user."
1542   (cli:with-options (:database t :log t) (delete-user)
1543     (let* ((presentation-project-user delete-user)
1544            (user-did-exist-p (delete-user presentation-project-user)))
1545       (cl-log:log-message
1546        :db-dat
1547        "~:[Tried to delete nonexistent~;Deleted~] ~
1548        presentation project user ~A from database ~A at ~A:~D."
1549        user-did-exist-p presentation-project-user database host port))))
1550
1551 (defun cli:list-user-action ()
1552   "List presentation project users together with their presentation
1553 projects."
1554   (cli:with-options (:database t) (list-user)
1555     (let* ((presentation-project-user (if (string= list-user "*")
1556                                           'user-name
1557                                           list-user))
1558            (content
1559             (query
1560              (:order-by
1561               (:select
1562                'user-name 'sys-user.user-id 'user-password
1563                'user-full-name 'presentation-project-name
1564                'sys-user-role.presentation-project-id 'user-role
1565                :from 'sys-user 'sys-user-role 'sys-presentation-project
1566                :where (:and (:= 'sys-user-role.presentation-project-id
1567                                 'sys-presentation-project.presentation-project-id)
1568                             (:= 'sys-user.user-id 'sys-user-role.user-id)
1569                             (:= 'user-name presentation-project-user)))
1570               'user-name))))
1571       (cli:format-table *standard-output* content
1572                         '("User" "ID" "Password" "Full Name"
1573                           "Presentation Project" "ID" "Role")))))
1574
1575 (defun cli:list-presentation-project-action ()
1576   "List content of presentation projects."
1577   (cli:with-options (:database t) (list-presentation-project)
1578     (let* ((presentation-project (if (string= list-presentation-project "*")
1579                                      'presentation-project-name
1580                                      list-presentation-project))
1581            (content
1582             (query
1583              (:order-by
1584               (:select
1585                'presentation-project-name
1586                'sys-presentation-project.presentation-project-id
1587                'sys-presentation.measurement-id
1588                'common-table-name
1589                'sys-measurement.acquisition-project-id
1590                :from
1591                'sys-presentation-project 'sys-presentation
1592                'sys-measurement 'sys-acquisition-project
1593                :where
1594                (:and (:= 'sys-presentation-project.presentation-project-id
1595                          'sys-presentation.presentation-project-id)
1596                      (:= 'sys-presentation.measurement-id
1597                          'sys-measurement.measurement-id)
1598                      (:= 'sys-measurement.acquisition-project-id
1599                          'sys-acquisition-project.acquisition-project-id)
1600                      (:= 'presentation-project-name
1601                          presentation-project)))
1602               'presentation-project-name
1603               'sys-presentation.measurement-id))))
1604       (cli:format-table *standard-output* content
1605                         '("Presentation Project" "ID" "Meas. ID"
1606                           "Acquisition Project" "ID")))))
1607
1608 (defun cli:format-table (destination content column-headers &key
1609                          (column-separator " | ")
1610                          (header-separator #\-)
1611                          (column-widths (mapcar (constantly nil)
1612                                                 column-headers)))
1613   "Print content (a list of lists) to destination."
1614   (let* ((rows (append (list column-headers)
1615                        (list (mapcar (constantly "") column-headers))
1616                        content))
1617          (number-of-rows (length column-headers))
1618          (widths
1619           (loop
1620              for column from 0 below number-of-rows
1621              collect (or (nth column column-widths)
1622                          (loop
1623                             for row in rows
1624                             maximize (length (format nil "~A" (nth column row))))))))
1625     (setf (second rows)
1626           (loop
1627              for width in widths collect
1628              (make-string width :initial-element header-separator)))
1629     (setf rows
1630           (loop
1631              for row in rows
1632              for i from 0
1633              nconc (cli:split-last-row (list row) widths)))
1634     (loop
1635        for row in rows do
1636        (format destination "~&~{~VA~1,#^~A~}~%"
1637                (loop
1638                   for width in widths and field in row
1639                   collect width collect field collect column-separator)))))
1640
1641 (defun cli:split-last-row (rows column-widths)
1642   "If necessary, split fields of the last element of rows whose width
1643 exceeds the respective column-width over multiple rows."
1644   (let ((last-row (mapcar #'(lambda (x) (format nil "~A" x))
1645                           (car (last rows)))))
1646     (if (notany #'(lambda (field width) (> (length field) width))
1647                 last-row
1648                 column-widths)
1649         rows
1650         (loop
1651            for field in last-row
1652            for column-width in column-widths
1653            collect (subseq field 0 (min column-width (length field)))
1654            into penultimate-row
1655            collect (subseq field (min column-width (length field)))
1656            into lowest-row
1657            finally (return (nconc (butlast rows)
1658                                   (list penultimate-row)
1659                                   (cli:split-last-row (list lowest-row)
1660                                                   column-widths)))))))
1661
1662 (defun cli:server-action ()
1663   "Start the HTTP server."
1664   (cli:with-options (:log t)
1665       (host port database user password use-ssl
1666             proxy-root http-port address common-root pid-file)
1667     (cli:with-options (:tolerate-missing t)
1668         (aux-host aux-port aux-database aux-user aux-password aux-use-ssl)
1669       (setf address (unless (string= address "*") address))
1670       (setf *postgresql-credentials*
1671             (list database user password host :port port
1672                   :use-ssl (s-sql:from-sql-name use-ssl)))
1673       (setf *postgresql-aux-credentials*
1674             (if (and aux-user aux-password aux-database)
1675                 (list aux-database aux-user aux-password aux-host
1676                       :port aux-port
1677                       :use-ssl (s-sql:from-sql-name aux-use-ssl))
1678                 *postgresql-credentials*))
1679       #+sbcl(unless (cli:verbosity-level :no-daemon)
1680               (assert
1681                (not (with-open-file (s pid-file :if-does-not-exist nil)
1682                       (when s
1683                         (probe-file (make-pathname
1684                                      :directory (list :absolute "proc"
1685                                                       (read-line s nil)))))))
1686                ()
1687                "~A contains the PID of a running process ~
1688                so I won't put my own there.  Giving up."
1689                (truename pid-file))
1690               (sb-daemon:daemonize :pidfile pid-file :exit-parent t))
1691       (insert-all-footprints *postgresql-credentials*)
1692       (delete-all-imageless-points *postgresql-credentials*)
1693       (setf hunchentoot:*log-lisp-backtraces-p*
1694             (cli:verbosity-level :log-error-backtraces))
1695       (setf hunchentoot:*show-lisp-errors-p*
1696             (cli:verbosity-level :show-server-errors))
1697       (setf *ps-print-pretty*
1698             (cli:verbosity-level :pretty-javascript))
1699       (start-server :proxy-root proxy-root
1700                     :http-port http-port
1701                     :address address
1702                     :common-root common-root)
1703       (cl-log:log-message
1704        :info
1705        "HTTP server listens on port ~D ~
1706        of ~:[all available addresses~;address ~:*~A~].  ~
1707        It expects to be called with a URL path root of /~A/.  ~
1708        Phoros database is ~A on ~A:~D.  Auxiliary database is ~A on ~A:~D.  ~
1709        Files are searched for in ~A."
1710        http-port address
1711        proxy-root
1712        database host port
1713        aux-database aux-host aux-port
1714        common-root)
1715       (loop (sleep 10)))))