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:main ()
 628   "The UNIX command line entry point."
 629   (handler-bind
 630       ((sb-sys:interactive-interrupt
 631         (lambda (c)
 632           (declare (ignore c))
 633           (cl-log:log-message
 634            :error "Interactive interrupt.")
 635           #+sbcl(sb-ext:exit :code 2 :abort t)))
 636        (serious-condition
 637         (lambda (c)
 638           (cl-log:log-message
 639            :error "~A ~:[~;[Backtrace follows]~&~A~]~&"
 640            c
 641            (cli:verbosity-level :log-error-backtraces)
 642            (trivial-backtrace:print-backtrace c :output nil))
 643           (format *error-output* "~A~&" c)
 644           (sb-ext:exit :code 1 :abort t)))
 645        (warning
 646         (lambda (c) (cl-log:log-message :warning "~A" c))))
 647     (cffi:use-foreign-library phoml)
 648     (cli:set-.phoros-options)
 649     (cli:with-options (:tolerate-missing t)
 650         ((verbose) umask images (aux-numeric-label) (aux-text-label) (login-intro))
 651       (setf *verbosity* verbose)
 652       (setf *umask* umask)
 653       (setf *number-of-images* images)
 654       (setf *aux-numeric-labels* aux-numeric-label)
 655       (setf *aux-text-labels* aux-text-label)
 656       (setf *login-intro* login-intro))
 657     (cli:first-action-option help
 658                              licence
 659                              license
 660                              version
 661                              check-db
 662                              check-dependencies
 663                              nuke-all-tables
 664                              create-sys-tables
 665                              get-image
 666                              store-camera-hardware
 667                              store-lens
 668                              store-generic-device
 669                              store-device-stage-of-life
 670                              store-device-stage-of-life-end
 671                              store-camera-calibration
 672                              create-acquisition-project
 673                              delete-acquisition-project
 674                              delete-measurement
 675                              list-acquisition-project
 676                              store-images-and-points
 677                              insert-footprints
 678                              server
 679                              create-presentation-project
 680                              delete-presentation-project
 681                              list-presentation-project
 682                              add-to-presentation-project
 683                              remove-from-presentation-project
 684                              redefine-trigger-function
 685                              create-image-attribute
 686                              delete-image-attribute
 687                              list-image-attribute
 688                              create-aux-view
 689                              get-user-points
 690                              store-user-points
 691                              create-user
 692                              delete-user
 693                              list-user)
 694     (sb-ext:exit :code *unix-exit-code*)))
 695
 696 (defun cli:set-.phoros-options ()
 697   "Set previously non-existent environment variables, whose names must
 698 start with PHOROS_, according to the most relevant .phoros file."
 699   (let ((.phoros-path (or (probe-file
 700                            (make-pathname
 701                             :name ".phoros"
 702                             :defaults *default-pathname-defaults*))
 703                           (probe-file
 704                            (make-pathname
 705                             :name ".phoros"
 706                             :directory (directory-namestring
 707                                         (user-homedir-pathname)))))))
 708     (when .phoros-path
 709       #+sbcl
 710       (with-open-file (s .phoros-path)
 711         (loop
 712            for line = (read-line s nil nil)
 713            while line
 714            for option = (string-trim " " line)
 715            for (name value junk) = (cl-utilities:split-sequence #\= option)
 716            when (and (>= (length name) 7)
 717                      (string= (subseq name 0 7) "PHOROS_")
 718                      value
 719                      (not junk))
 720            do (sb-posix:setenv name value 0)))
 721       #-sbcl
 722       (warn "Ignoring settings from ~A" .phoros-path))))
 723
 724 (defun cli:verbosity-level (topic)
 725   "Return the number associated with verbose topic, or nil if the
 726 number is 0 or doesn't exist."
 727   (let* ((digested-verbosity
 728           (loop
 729              for entry in *verbosity*
 730              collect
 731                (destructuring-bind (topic &optional level)
 732                    (cl-utilities:split-sequence
 733                     #\: entry :count 2 :remove-empty-subseqs t)
 734                  (cons (intern (string-upcase topic) 'keyword)
 735                        (ignore-errors
 736                          (parse-integer level :junk-allowed t))))))
 737          (level (cdr (assoc topic digested-verbosity))))
 738     (unless (or (null level) (zerop level))
 739       level)))
 740
 741 (defun cli:set-umask ()
 742   "Set umask to the value from its octal representation stored in
 743 *umask*"
 744   (let ((umask (ignore-errors (parse-integer *umask* :radix 8))))
 745     (assert (typep umask '(integer #o000 #o777)) ()
 746             "~O is not a valid umask."
 747             *umask*)
 748     #+sbcl(sb-posix:umask umask)
 749     #-sbcl(warn "Ignoring umask.")))
 750
 751 (defun cli:getopt-mandatory (long-name)
 752   "Return value of command line option long-name if any. Otherwise
 753 signal error."
 754   (multiple-value-bind (value supplied-p) (cli:getopt :long-name long-name)
 755     (assert supplied-p () "Missing option --~A." long-name)
 756     value))
 757
 758 (defun cli:help-action ()
 759   (cli:with-options () (help)
 760     (ecase help
 761       (:long (cli:help :theme "etc/phoros.cth"))
 762       (:short (cli:help :theme "etc/short.cth")))))
 763
 764 (defun cli:version-action ()
 765   "Print --version message. TODO: OpenLayers, Proj4js version."
 766   (cli:with-options () (version)
 767     (ecase version
 768       (:all
 769        (format
 770         *standard-output*
 771         "~&~A version ~A~&  ~A version ~A~&  ~
 772         Proj4 library: ~A~&  PhoML version ~A~&"
 773         *phoros-description*
 774         (phoros-version)
 775         (lisp-implementation-type) (lisp-implementation-version)
 776         (proj:version)
 777         (phoml:get-version-number)))
 778       (:minimal
 779        (format *standard-output* "~&~A~&" (phoros-version))))))
 780
 781 (defun cli:licence-action ()
 782   "Print --licence boilerplate."
 783   (format *standard-output* "~&~A~&" *phoros-licence*))
 784
 785 (defun cli:license-action ()
 786   (cli:licence-action))
 787
 788 (defun cli:check-db-action ()
 789   "Tell us if databases are accessible."
 790   (cli:with-options ()
 791       (host port database user use-ssl
 792             aux-host aux-port
 793             aux-database aux-user aux-password password aux-use-ssl)
 794     (format *error-output*
 795             "Checking database ~A at ~A:~D and ~
 796             auxiliary database ~A at ~A:~D.~%"
 797             database host port
 798             aux-database aux-host aux-port)
 799     (if (and
 800          (check-db (list database user password host
 801                          :port port
 802                          :use-ssl (s-sql:from-sql-name use-ssl)))
 803          (check-db (list aux-database aux-user aux-password aux-host
 804                          :port aux-port
 805                          :use-ssl (s-sql:from-sql-name aux-use-ssl))))
 806         (progn
 807           (format *error-output*
 808                   "Both are accessible.~%")
 809           (setf *unix-exit-code* 0))
 810         (setf *unix-exit-code* 32))))
 811
 812 (defun cli:check-dependencies-action ()
 813   "Say OK if the necessary external dependencies are available."
 814   (check-dependencies))
 815
 816 (defun cli:nuke-all-tables-action ()
 817   "Drop the bomb.  Ask for confirmation first."
 818   (cli:with-options (:database t :log t) ()
 819     (when (yes-or-no-p
 820            "You asked me to delete anything in database ~A at ~A:~D.  ~
 821            Proceed?"
 822            database host port)
 823       (nuke-all-tables))
 824     (cl-log:log-message
 825      :db-sys "Nuked database ~A at ~A:~D.  Back to square one!"
 826      database host port)))
 827
 828 (defun cli:create-sys-tables-action ()
 829   "Make a set of sys-* tables.  Ask for confirmation first."
 830   (cli:with-options (:database t :log t) ()
 831     (when (yes-or-no-p
 832            "You asked me to create a set of sys-* tables ~
 833            in database ~A at ~A:~D.  ~
 834            Make sure you know what you are doing.  Proceed?"
 835            database host port)
 836       (create-sys-tables))
 837     (cl-log:log-message
 838      :db-sys "Created a fresh set of system tables in database ~A at ~A:~D."
 839      database host port)))
 840
 841 (defun cli:create-acquisition-project-action ()
 842   "Make a set of data tables."
 843   (cli:with-options (:database t :log t) (create-acquisition-project)
 844     (let ((common-table-name create-acquisition-project))
 845       (create-acquisition-project common-table-name)
 846       (cl-log:log-message
 847        :db-dat
 848        "Created a fresh acquisition project by the name of ~A ~
 849        in database ~A at ~A:~D."
 850        common-table-name database host port))))
 851
 852 (defun cli:delete-acquisition-project-action ()
 853   "Delete an acquisition project."
 854   (cli:with-options (:database t :log t) (delete-acquisition-project)
 855     (let ((common-table-name delete-acquisition-project))
 856       (assert-acquisition-project common-table-name)
 857       (when (yes-or-no-p
 858              "You asked me to delete acquisition-project ~A ~
 859              (including all its measurements) ~
 860              from database ~A at ~A:~D.  Proceed?"
 861              common-table-name database host port)
 862         (let ((project-did-exist-p
 863                  (delete-acquisition-project common-table-name)))
 864             (cl-log:log-message
 865              :db-dat
 866              "~:[Tried to delete nonexistent~;Deleted~] ~
 867              acquisition project ~A from database ~A at ~A:~D."
 868              project-did-exist-p common-table-name database host port))))))
 869
 870 (defun cli:delete-measurement-action ()
 871   "Delete a measurement by its measurement-id."
 872   (cli:with-options (:database t :log t) (delete-measurement)
 873     (let* ((measurement-id delete-measurement)
 874            (measurement-did-exist-p (delete-measurement measurement-id)))
 875       (cl-log:log-message
 876        :db-dat
 877        "~:[Tried to delete nonexistent~;Deleted~] ~
 878        measurement with ID ~A from database ~A at ~A:~D."
 879        measurement-did-exist-p measurement-id database host port))))
 880
 881 (defun cli:list-acquisition-project-action ()
 882   "List content of acquisition projects."
 883   (cli:with-options (:database t) (list-acquisition-project)
 884     (let* ((common-table-name  (if (string= list-acquisition-project "*")
 885                                    'common-table-name
 886                                    list-acquisition-project))
 887            (content
 888             (query
 889              (:order-by
 890               (:select
 891                'common-table-name
 892                'sys-acquisition-project.acquisition-project-id
 893                'measurement-id
 894                'directory
 895                'cartesian-system
 896                :from
 897                'sys-acquisition-project :natural :left-join 'sys-measurement
 898                :where (:= 'common-table-name common-table-name))
 899               'measurement-id))))
 900       (cli:format-table *standard-output* content
 901                         '("Acquisition Project" "ID" "Meas. ID"
 902                           "Directory" "Cartesian CS")))))
 903
 904 (defun cli:store-images-and-points-action ()
 905   "Put data into the data tables."
 906   (cli:with-options (:database t :log t)
 907       (directory epsilon common-root aggregate-events store-images-and-points)
 908     (let ((common-table-name store-images-and-points))
 909       (assert-acquisition-project common-table-name)
 910       (cl-log:log-message
 911        :db-dat
 912        "Start: storing data from ~A into acquisition project ~A ~
 913        in database ~A at ~A:~D."
 914        directory common-table-name database host port)
 915       (store-images-and-points common-table-name directory
 916                                :epsilon epsilon
 917                                :root-dir common-root
 918                                :aggregate-events aggregate-events)
 919       (cl-log:log-message
 920        :db-dat
 921        "Finish: storing data from ~A into acquisition project ~A ~
 922        in database ~A at ~A:~D."
 923        directory common-table-name database host port)
 924       (let ((points-deleted
 925              (delete-imageless-points common-table-name)))
 926         (cl-log:log-message
 927          :db-dat
 928          "Checked acquisition project ~A in database ~A at ~A:~D ~
 929          for imageless points~[; found none.~;. Found and deleted ~:*~D.~]"
 930          common-table-name database host port
 931          points-deleted)))))
 932
 933 (defun cli:insert-footprints-action ()
 934   "Update image footprints."
 935   (cli:with-options (:database t :log t) (host port database user password use-ssl
 936                           log-dir
 937                           insert-footprints)
 938     (let ((common-table-name insert-footprints))
 939       (assert-acquisition-project common-table-name)
 940       (cl-log:log-message
 941        :db-dat
 942        "Updating image footprints of acquisition project ~A ~
 943        in database ~A at ~A:~D."
 944        common-table-name database host port)
 945       (let ((number-of-updated-footprints
 946              (insert-footprints common-table-name)))
 947         (cl-log:log-message
 948          :db-dat
 949          "~:[All image footprints belonging to acquisition project ~*~A ~
 950          in database ~A at ~A:~D are up to date.~
 951              ~;Updated ~D image footprint~:P of acquisition project ~A ~
 952                in database ~A at ~A:~D.~]"
 953          (plusp number-of-updated-footprints) number-of-updated-footprints
 954          common-table-name database host port)))))
 955
 956 ;;; We don't seem to have two-dimensional arrays in postmodern
 957 ;;(defun cli:canonicalize-bayer-pattern (raw &optional sql-string-p)
 958 ;;  "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."
 959 ;;  (when raw
 960 ;;    (let* ((array
 961 ;;            (loop
 962 ;;               for row in raw
 963 ;;               collect
 964 ;;               (loop
 965 ;;                  for hex-color in (cl-utilities:split-sequence #\, row)
 966 ;;                  collect
 967 ;;                  (let ((*read-base* 16))
 968 ;;                    (assert (eql (elt hex-color 0) #\#) () "~A is not a valid color" hex-color)
 969 ;;                    (read-from-string
 970 ;;                     (concatenate 'string
 971 ;;                                  (subseq hex-color 5 7)
 972 ;;                                  (subseq hex-color 3 5)
 973 ;;                                  (subseq hex-color 1 3))
 974 ;;                     nil)))))
 975 ;;           (rows (length array))
 976 ;;           (columns (length (elt array 0))))
 977 ;;      (if sql-string-p
 978 ;;          (format nil "{~{{~{~A~#^,~}}~}}" array)
 979 ;;          (make-array (list rows columns) :initial-contents array)))))
 980
 981 (defun cli:canonicalize-bayer-pattern (raw &optional sql-string-p)
 982   "Convert a string of comma-separated hex color strings (ex: #ff0000
 983 for red) into a vector of integers.  If sql-string-p is t, convert it
 984 into a string in SQL syntax."
 985   (when raw
 986     (let* ((vector
 987             (loop
 988                for hex-color in (cl-utilities:split-sequence #\, raw)
 989                collect
 990                  (let ((*read-base* 16))
 991                    (assert (eql (elt hex-color 0) #\#)
 992                            () "~A is not a valid color" hex-color)
 993                    (read-from-string
 994                     (concatenate 'string
 995                                  (subseq hex-color 5 7)
 996                                  (subseq hex-color 3 5)
 997                                  (subseq hex-color 1 3))
 998                     nil))))
 999            (columns (length vector)))
1000       (if sql-string-p
1001           (format nil "{~{~A~#^,~}}" vector)
1002           (make-array (list columns) :initial-contents vector)))))
1003
1004 (defun cli:canonicalize-color-raiser (raw &optional sql-string-p)
1005   "Convert string of comma-separated numbers into a vector.  If
1006 sql-string-p is t, convert it into a string in SQL syntax."
1007   (when raw
1008     (let* ((vector
1009             (loop
1010                for multiplier in (cl-utilities:split-sequence #\, raw :count 3)
1011                collect
1012                  (read-from-string multiplier nil))))
1013       (if sql-string-p
1014           (format nil "{~{~A~#^,~}}" vector)
1015           (make-array '(3) :initial-contents vector)))))
1016
1017 (defun cli:store-camera-hardware-action ()
1018   (cli:with-options (:database t :log t)
1019       (try-overwrite
1020        sensor-width-pix
1021        sensor-height-pix
1022        pix-size
1023        channels
1024        pix-depth
1025        color-raiser
1026        bayer-pattern
1027        serial-number
1028        description)
1029     (format *standard-output* "~D~%"
1030             (store-camera-hardware
1031              :try-overwrite try-overwrite
1032              :sensor-width-pix sensor-width-pix
1033              :sensor-height-pix sensor-height-pix
1034              :pix-size pix-size
1035              :channels channels
1036              :pix-depth pix-depth
1037              :color-raiser (cli:canonicalize-color-raiser color-raiser)
1038              :bayer-pattern (cli:canonicalize-bayer-pattern bayer-pattern)
1039              :serial-number (string-trim " " serial-number)
1040              :description (string-trim " " description)))))
1041
1042 (defun cli:store-lens-action ()
1043   (cli:with-options (:database t :log t)
1044       (try-overwrite
1045        c
1046        serial-number
1047        description)
1048     (format *standard-output* "~D~%"
1049             (store-lens
1050              :try-overwrite try-overwrite
1051              :c c
1052              :serial-number (string-trim " " serial-number)
1053              :description (string-trim " " description)))))
1054
1055 (defun cli:store-generic-device-action ()
1056   (cli:with-options (:database t :log t)
1057       (camera-hardware-id
1058        lens-id
1059        scanner-id)
1060     (format *standard-output* "~D~%"
1061             (store-generic-device
1062              :camera-hardware-id camera-hardware-id
1063              :lens-id lens-id
1064              :scanner-id scanner-id))))
1065
1066 (defun cli:string-or-null (string)
1067   "If string is \":null\", return :null; otherwise return string."
1068   (if (string-equal string ":null") :null string))
1069
1070 (defun cli:store-device-stage-of-life-action ()
1071   (cli:with-options (:database t :log t)
1072       (unmounting-date
1073        try-overwrite
1074        recorded-device-id
1075        event-number
1076        generic-device-id
1077        vehicle-name
1078        casing-name
1079        computer-name
1080        computer-interface-name
1081        mounting-date)
1082     (format *standard-output* "~D~%"
1083             (store-device-stage-of-life
1084              :unmounting-date (cli:string-or-null unmounting-date)
1085              :try-overwrite try-overwrite
1086              :recorded-device-id recorded-device-id
1087              :event-number event-number
1088              :generic-device-id generic-device-id
1089              :vehicle-name (string-trim " " vehicle-name)
1090              :casing-name (string-trim " " casing-name)
1091              :computer-name (string-trim " " computer-name)
1092              :computer-interface-name computer-interface-name
1093              :mounting-date mounting-date))))
1094
1095 (defun cli:store-device-stage-of-life-end-action ()
1096   (cli:with-options (:database t :log t)
1097       (device-stage-of-life-id
1098        unmounting-date)
1099     (format *standard-output* "~D~%"
1100             (store-device-stage-of-life-end
1101              :device-stage-of-life-id device-stage-of-life-id
1102              :unmounting-date unmounting-date))))
1103
1104 (defun cli:store-camera-calibration-action ()
1105   (cli:with-options (:database t :log t)
1106       (usable
1107        device-stage-of-life-id
1108        date
1109        person
1110        main-description
1111        debug
1112        photogrammetry-version
1113        mounting-angle
1114        inner-orientation-description
1115        c
1116        xh
1117        yh
1118        a1
1119        a2
1120        a3
1121        b1
1122        b2
1123        c1
1124        c2
1125        r0
1126        outer-orientation-description
1127        dx
1128        dy
1129        dz
1130        omega
1131        phi
1132        kappa
1133        boresight-description
1134        b-dx
1135        b-dy
1136        b-dz
1137        b-ddx
1138        b-ddy
1139        b-ddz
1140        b-rotx
1141        b-roty
1142        b-rotz
1143        b-drotx
1144        b-droty
1145        b-drotz
1146        nx
1147        ny
1148        nz
1149        d)
1150     (format *standard-output* "~D~%"
1151             (store-camera-calibration
1152              :usable usable
1153              :device-stage-of-life-id device-stage-of-life-id
1154              :date date
1155              :person person
1156              :main-description main-description
1157              :debug debug
1158              :photogrammetry-version photogrammetry-version
1159              :mounting-angle mounting-angle
1160              :inner-orientation-description (string-trim " " inner-orientation-description)
1161              :c c
1162              :xh xh
1163              :yh yh
1164              :a1 a1
1165              :a2 a2
1166              :a3 a3
1167              :b1 b1
1168              :b2 b2
1169              :c1 c1
1170              :c2 c2
1171              :r0 r0
1172              :outer-orientation-description (string-trim " " outer-orientation-description)
1173              :dx dx
1174              :dy dy
1175              :dz dz
1176              :omega omega
1177              :phi phi
1178              :kappa kappa
1179              :boresight-description (string-trim " " boresight-description)
1180              :b-dx b-dx
1181              :b-dy b-dy
1182              :b-dz b-dz
1183              :b-ddx b-ddx
1184              :b-ddy b-ddy
1185              :b-ddz b-ddz
1186              :b-rotx b-rotx
1187              :b-roty b-roty
1188              :b-rotz b-rotz
1189              :b-drotx b-drotx
1190              :b-droty b-droty
1191              :b-drotz b-drotz
1192              :nx nx
1193              :ny ny
1194              :nz nz
1195              :d d))))
1196
1197 (defun cli:get-image-action ()
1198   "Output a PNG file extracted from a .pictures file; print its
1199 trigger-time to stdout."
1200   (cli:with-options () (in out bayer-pattern color-raiser)
1201     (cli:with-options (:tolerate-missing t) (count byte-position)
1202       (with-open-file (out-stream out :direction :output
1203                                   :element-type 'unsigned-byte
1204                                   :if-exists :supersede)
1205         (let ((trigger-time
1206                (if byte-position
1207                    (send-png out-stream in byte-position
1208                              :bayer-pattern
1209                              (cli:canonicalize-bayer-pattern bayer-pattern)
1210                              :color-raiser
1211                              (cli:canonicalize-color-raiser color-raiser))
1212                    (send-nth-png count out-stream in
1213                                  :bayer-pattern
1214                                  (cli:canonicalize-bayer-pattern
1215                                   bayer-pattern)
1216                                  :color-raiser
1217                                  (cli:canonicalize-color-raiser
1218                                   color-raiser)))))
1219           (format *standard-output*
1220                   "~&~A~%" (timestring (utc-from-unix trigger-time))))))))
1221
1222 (defun cli:create-presentation-project-action ()
1223   "Make a presentation project."
1224   (cli:with-options (:database t :log t) (create-presentation-project)
1225     (let* ((presentation-project-name create-presentation-project)
1226            (fresh-project-p
1227             (create-presentation-project presentation-project-name)))
1228       (cl-log:log-message
1229        :db-dat
1230        "~:[Tried to recreate an existing~;Created a fresh~] ~
1231        presentation project by the name of ~A in database ~A at ~A:~D."
1232        fresh-project-p presentation-project-name database host port))))
1233
1234 (defun cli:delete-presentation-project-action ()
1235   "Delete a presentation project."
1236   (cli:with-options (:database t :log t) (delete-presentation-project)
1237     (let ((presentation-project-name delete-presentation-project))
1238       (assert-presentation-project presentation-project-name)
1239       (when (yes-or-no-p
1240              "You asked me to delete presentation-project ~A ~
1241              (including its tables of user-defined points and lines, ~
1242              ~A and ~A respectively) from database ~A at ~A:~D.  Proceed?"
1243              presentation-project-name
1244              (user-point-table-name presentation-project-name)
1245              (user-line-table-name presentation-project-name)
1246              database host port)
1247         (let ((project-did-exist-p
1248                (delete-presentation-project presentation-project-name)))
1249           (cl-log:log-message
1250            :db-dat
1251            "~:[Tried to delete nonexistent~;Deleted~] ~
1252            presentation project ~A from database ~A at ~A:~D."
1253            project-did-exist-p presentation-project-name
1254            database host port))))))
1255
1256 (defun cli:add-to-presentation-project-action ()
1257   "Add measurements to a presentation project."
1258   (cli:with-options (:database t :log t)
1259       (add-to-presentation-project)
1260     (cli:with-options (:tolerate-missing t)
1261         (measurement-id acquisition-project)
1262       (let ((presentation-project-name add-to-presentation-project))
1263         (assert-presentation-project presentation-project-name)
1264         (add-to-presentation-project presentation-project-name
1265                                      :measurement-ids measurement-id
1266                                      :acquisition-project acquisition-project)
1267         (cl-log:log-message
1268          :db-dat
1269          "Added ~@[measurement-ids ~{~D~#^, ~}~]~
1270        ~@[all measurements from acquisition project ~A~] ~
1271        to presentation project ~A in database ~A at ~A:~D."
1272          measurement-id acquisition-project
1273          presentation-project-name database host port)))))
1274
1275 (defun cli:remove-from-presentation-project-action ()
1276   "Add measurements to a presentation project."
1277   (cli:with-options (:database t :log t)
1278       (measurement-id acquisition-project remove-from-presentation-project)
1279     (let ((presentation-project-name remove-from-presentation-project))
1280       (assert-presentation-project presentation-project-name)
1281       (remove-from-presentation-project
1282          presentation-project-name
1283          :measurement-ids measurement-id
1284          :acquisition-project acquisition-project)
1285       (cl-log:log-message
1286        :db-dat
1287        "Removed ~@[measurement-ids ~{~D~#^, ~}~]~
1288        ~@[all measurements that belong to acquisition project ~A~] ~
1289        from presentation project ~A in database ~A at ~A:~D."
1290        measurement-id acquisition-project
1291        presentation-project-name database host port))))
1292
1293 (defun cli:create-image-attribute-action ()
1294   "Store a boolean SQL expression."
1295   (cli:with-options (:database t :log t)
1296       (tag sql-clause create-image-attribute)
1297     (let ((presentation-project-name create-image-attribute))
1298       (assert-presentation-project presentation-project-name)
1299       (multiple-value-bind (old-image-attribute
1300                             number-of-selected-images
1301                             total-number-of-images)
1302           (create-image-attribute presentation-project-name
1303                                   :tag tag :sql-clause sql-clause)
1304         (cl-log:log-message
1305          :db-dat
1306          "~:[Stored a fresh~;Updated an~] ~
1307          image attribute, tagged ~S, for presentation project ~A ~
1308          in database ~A at ~A:~D~
1309          ~0@*~@[, replacing the SQL clause previously stored there of ~S~].  ~
1310          ~6@*~@[The new SQL clause currently selects ~D out of ~D images.~]"
1311          old-image-attribute
1312          tag
1313          presentation-project-name
1314          database host port
1315          number-of-selected-images total-number-of-images)))))
1316
1317 (defun cli:delete-image-attribute-action ()
1318   "Remove SQL expression specified by presentation-project-name and tag."
1319   (cli:with-options (:database t :log t)
1320       (tag delete-image-attribute)
1321     (let ((presentation-project-name delete-image-attribute))
1322       (assert-presentation-project presentation-project-name)
1323       (let ((replaced-sql-clause
1324              (delete-image-attribute presentation-project-name :tag tag)))
1325         (cl-log:log-message
1326          :db-dat
1327          "~:[Tried to delete a nonexistent~;Deleted~] ~
1328        image attribute tagged ~S from ~
1329        presentation project ~A in database ~A at ~A:~D.  ~
1330        ~0@*~@[Its SQL clause, now deleted, was ~S~]"
1331          replaced-sql-clause tag presentation-project-name
1332          database host port)))))
1333
1334 (defun cli:list-image-attribute-action ()
1335   "List boolean SQL expressions."
1336   (cli:with-options (:database t) (tag list-image-attribute)
1337     (let* ((presentation-project-name (if (string= list-image-attribute "*")
1338                                           'presentation-project-name
1339                                           list-image-attribute))
1340            (restriction-id (or tag 'restriction-id))
1341            (content
1342             (query
1343              (:order-by
1344               (:select 'presentation-project-name
1345                        'sys-selectable-restriction.presentation-project-id
1346                        'restriction-id
1347                        'sql-clause
1348                        :from 'sys-selectable-restriction
1349                        :natural :left-join 'sys-presentation-project
1350                        :where (:and (:= presentation-project-name
1351                                         'presentation-project-name)
1352                                     (:= restriction-id
1353                                         'restriction-id)))
1354               'presentation-project-name 'restriction-id))))
1355       (cli:format-table *standard-output* content
1356                         '("Presentation Project" "ID" "Tag" "SQL-clause")
1357                         :column-widths '(nil nil nil 60)))))
1358
1359 (defun cli:redefine-trigger-function-action ()
1360   "Recreate an SQL trigger function that is fired on changes to the
1361 user point table, and fire it once."
1362   (cli:with-options (:database t :log t)
1363       (plpgsql-body redefine-trigger-function)
1364     (let ((presentation-project-name redefine-trigger-function)
1365           (body-text (make-array '(1) :adjustable t :fill-pointer 0
1366                                  :element-type 'character)))
1367       (if plpgsql-body
1368           (with-open-file (stream plpgsql-body)
1369             (loop
1370                for c = (read-char stream nil)
1371                while c
1372                do (vector-push-extend c body-text))
1373             (create-presentation-project-trigger-function
1374              presentation-project-name
1375              body-text
1376              (s-sql:to-sql-name (user-point-table-name
1377                                  presentation-project-name))
1378              (s-sql:to-sql-name (user-line-table-name
1379                                  presentation-project-name))))
1380           (create-presentation-project-trigger-function
1381            presentation-project-name))
1382       (fire-presentation-project-trigger-function presentation-project-name)
1383       (cl-log:log-message
1384        :db-dat
1385        "Defined (and fired once) ~
1386        a trigger function associatad with user point table of ~
1387        presentation project ~A in database ~A at ~A:~D to ~
1388        ~:[perform a minimal default action.~;perform the body given ~
1389           in file ~:*~A, whose content is is:~&~A~]"
1390        presentation-project-name database host port
1391        plpgsql-body body-text))))
1392
1393 (defun cli:create-aux-view-action ()
1394   "Connect presentation project to an auxiliary data table by means of
1395 a view."
1396   (cli:with-options (:database t :log t) (create-aux-view)
1397     (assert-presentation-project create-aux-view))
1398   (cli:with-options (:aux-database t :log t)
1399       (host port database user password use-ssl
1400             coordinates-column (numeric-column) (text-column) aux-table
1401             create-aux-view)
1402     (let* ((presentation-project-name create-aux-view)
1403            (numeric-columns
1404             (nsubstitute nil "" numeric-column :test #'string=))
1405            (text-columns
1406             (nsubstitute nil "" text-column :test #'string=))
1407            (aux-view-in-phoros-db-p
1408             (every #'equal
1409                    (list host port database user password use-ssl)
1410                    (list aux-host aux-port aux-database
1411                          aux-user aux-password aux-use-ssl)))
1412            (aux-view-exists-p
1413             (aux-view-exists-p presentation-project-name)))
1414       (when (or
1415              aux-view-in-phoros-db-p
1416              (yes-or-no-p
1417               "I'm going to ~:[create~;replace~] a view named ~A ~
1418               in database ~A at ~A:~D.  Proceed?"
1419               aux-view-exists-p
1420               (aux-point-view-name presentation-project-name)
1421               aux-database aux-host aux-port))
1422         (when aux-view-exists-p
1423           (delete-aux-view presentation-project-name))
1424         (create-aux-view presentation-project-name
1425                          :coordinates-column coordinates-column
1426                          :numeric-columns numeric-columns
1427                          :text-columns text-columns
1428                          :aux-table aux-table)
1429         (add-spherical-mercator-ref)
1430         (cl-log:log-message
1431          :db-dat
1432          "~:[Created~;Updated~] in database ~A at ~A:~D a view called ~A ~
1433          into table (of auxiliary data) ~A.  Coordinates column is ~A.  ~
1434          ~:[No numeric columns.~;Numeric column(s): ~:*~{~A~#^, ~}.~]  ~
1435          ~:[No text columns.~;Text column(s): ~:*~{~A~#^, ~}.~]  ~
1436          Also, ~0@*~:[created~;recreated~] in the same database a ~
1437          function called ~9@*~A."
1438          aux-view-exists-p
1439          aux-database aux-host aux-port
1440          (aux-point-view-name presentation-project-name)
1441          aux-table coordinates-column
1442          numeric-columns text-columns
1443          (thread-aux-points-function-name presentation-project-name))))))
1444
1445 (defun cli:store-user-points-action ()
1446   "Store user points from a GeoJSON file into database."
1447   (cli:with-options (:database t :log t) (json-file store-user-points)
1448     (let ((presentation-project store-user-points))
1449       (assert-presentation-project presentation-project)
1450       (multiple-value-bind
1451             (points-stored points-already-in-db points-tried zombie-users)
1452           (store-user-points presentation-project :json-file json-file)
1453         (cl-log:log-message
1454          :db-dat
1455          "Tried to store the ~D user point~:P I found in file ~A ~
1456          into presentation project ~A in database ~A at ~A:~D.  ~
1457          ~:[~:[~D~;None~*~]~;All~2*~] of them ~:[were~;was~] ~
1458          already present.  ~
1459          ~:[~:[~:[~D points have~;1 point has~*~]~;Nothing has~2*~]~
1460             ~;All points tried have~3*~] ~
1461          been added to the user point table.  ~
1462          ~15@*~@[I didn't know ~14@*~[~;a~:;any of the~] user~14@*~P ~
1463          called ~{~A~#^, ~}; treated them as zombie~14@*~P.~]"
1464          points-tried
1465          (truename json-file)
1466          presentation-project database host port
1467          (= points-already-in-db points-tried)
1468          (zerop points-already-in-db)
1469          points-already-in-db
1470          (<= points-already-in-db 1)
1471          (= points-stored points-tried)
1472          (zerop points-stored)
1473          (= 1 points-stored)
1474          points-stored
1475          (length zombie-users)          ;arg 14
1476          zombie-users)))))              ;arg 15
1477
1478 (defun cli:get-user-points-action ()
1479   "Save user points of presentation project into a GeoJSON file."
1480   (cli:with-options (:database t :log t) (json-file get-user-points)
1481     (let ((presentation-project get-user-points))
1482       (assert-presentation-project presentation-project)
1483       (multiple-value-bind (user-points user-point-count)
1484           (get-user-points (user-point-table-name presentation-project)
1485                            :indent t)
1486         (assert json-file ()
1487                 "Don't know where to store.  Try option --json-file")
1488         (unless (zerop user-point-count)
1489           (with-open-file (stream json-file
1490                                   :direction :output
1491                                   :if-exists :supersede)
1492             (princ user-points stream)))
1493         (cl-log:log-message
1494          :db-dat
1495          "~[There are no user points to get from presentation project ~A in ~
1496          database ~A at ~A:~D.  Didn't touch any file.~
1497          ~:;~:*Saved ~D user point~:P from presentation project ~A in ~
1498          database ~A at ~A:~D into file ~A.~]"
1499          user-point-count
1500          presentation-project database host port
1501          (ignore-errors (truename json-file)))))))
1502
1503 (defun cli:create-user-action ()
1504   "Define a new user."
1505   (cli:with-options (:database t :log t)
1506       ((presentation-project)
1507        user-full-name user-role user-password
1508        create-user)
1509     (let ((presentation-project-user create-user)
1510           fresh-user-p)
1511       (mapcar #'assert-presentation-project presentation-project)
1512       (setf fresh-user-p
1513             (create-user presentation-project-user
1514                          :presentation-projects presentation-project
1515                          :user-password user-password
1516                          :user-full-name user-full-name
1517                          :user-role user-role))
1518       (cl-log:log-message
1519        :db-dat ;TODO: We're listing nonexistent p-projects here as well.
1520        "~:[Updated~;Created~] user ~A (~A) who has ~A access ~
1521        to ~:[no ~;~]presentation project(s)~:*~{ ~A~#^,~} ~
1522        in database ~A at ~A:~D."
1523        fresh-user-p presentation-project-user
1524        user-full-name user-role
1525        presentation-project database host port))))
1526
1527 (defun cli:delete-user-action ()
1528   "Delete a presentation project user."
1529   (cli:with-options (:database t :log t) (delete-user)
1530     (let* ((presentation-project-user delete-user)
1531            (user-did-exist-p (delete-user presentation-project-user)))
1532       (cl-log:log-message
1533        :db-dat
1534        "~:[Tried to delete nonexistent~;Deleted~] ~
1535        presentation project user ~A from database ~A at ~A:~D."
1536        user-did-exist-p presentation-project-user database host port))))
1537
1538 (defun cli:list-user-action ()
1539   "List presentation project users together with their presentation
1540 projects."
1541   (cli:with-options (:database t) (list-user)
1542     (let* ((presentation-project-user (if (string= list-user "*")
1543                                           'user-name
1544                                           list-user))
1545            (content
1546             (query
1547              (:order-by
1548               (:select
1549                'user-name 'sys-user.user-id 'user-password
1550                'user-full-name 'presentation-project-name
1551                'sys-user-role.presentation-project-id 'user-role
1552                :from 'sys-user 'sys-user-role 'sys-presentation-project
1553                :where (:and (:= 'sys-user-role.presentation-project-id
1554                                 'sys-presentation-project.presentation-project-id)
1555                             (:= 'sys-user.user-id 'sys-user-role.user-id)
1556                             (:= 'user-name presentation-project-user)))
1557               'user-name))))
1558       (cli:format-table *standard-output* content
1559                         '("User" "ID" "Password" "Full Name"
1560                           "Presentation Project" "ID" "Role")))))
1561
1562 (defun cli:list-presentation-project-action ()
1563   "List content of presentation projects."
1564   (cli:with-options (:database t) (list-presentation-project)
1565     (let* ((presentation-project (if (string= list-presentation-project "*")
1566                                      'presentation-project-name
1567                                      list-presentation-project))
1568            (content
1569             (query
1570              (:order-by
1571               (:select
1572                'presentation-project-name
1573                'sys-presentation-project.presentation-project-id
1574                'sys-presentation.measurement-id
1575                'common-table-name
1576                'sys-measurement.acquisition-project-id
1577                :from
1578                'sys-presentation-project 'sys-presentation
1579                'sys-measurement 'sys-acquisition-project
1580                :where
1581                (:and (:= 'sys-presentation-project.presentation-project-id
1582                          'sys-presentation.presentation-project-id)
1583                      (:= 'sys-presentation.measurement-id
1584                          'sys-measurement.measurement-id)
1585                      (:= 'sys-measurement.acquisition-project-id
1586                          'sys-acquisition-project.acquisition-project-id)
1587                      (:= 'presentation-project-name
1588                          presentation-project)))
1589               'presentation-project-name
1590               'sys-presentation.measurement-id))))
1591       (cli:format-table *standard-output* content
1592                         '("Presentation Project" "ID" "Meas. ID"
1593                           "Acquisition Project" "ID")))))
1594
1595 (defun cli:format-table (destination content column-headers &key
1596                          (column-separator " | ")
1597                          (header-separator #\-)
1598                          (column-widths (mapcar (constantly nil)
1599                                                 column-headers)))
1600   "Print content (a list of lists) to destination."
1601   (let* ((rows (append (list column-headers)
1602                        (list (mapcar (constantly "") column-headers))
1603                        content))
1604          (number-of-rows (length column-headers))
1605          (widths
1606           (loop
1607              for column from 0 below number-of-rows
1608              collect (or (nth column column-widths)
1609                          (loop
1610                             for row in rows
1611                             maximize (length (format nil "~A" (nth column row))))))))
1612     (setf (second rows)
1613           (loop
1614              for width in widths collect
1615              (make-string width :initial-element header-separator)))
1616     (setf rows
1617           (loop
1618              for row in rows
1619              for i from 0
1620              nconc (cli:split-last-row (list row) widths)))
1621     (loop
1622        for row in rows do
1623        (format destination "~&~{~VA~1,#^~A~}~%"
1624                (loop
1625                   for width in widths and field in row
1626                   collect width collect field collect column-separator)))))
1627
1628 (defun cli:split-last-row (rows column-widths)
1629   "If necessary, split fields of the last element of rows whose width
1630 exceeds the respective column-width over multiple rows."
1631   (let ((last-row (mapcar #'(lambda (x) (format nil "~A" x))
1632                           (car (last rows)))))
1633     (if (notany #'(lambda (field width) (> (length field) width))
1634                 last-row
1635                 column-widths)
1636         rows
1637         (loop
1638            for field in last-row
1639            for column-width in column-widths
1640            collect (subseq field 0 (min column-width (length field)))
1641            into penultimate-row
1642            collect (subseq field (min column-width (length field)))
1643            into lowest-row
1644            finally (return (nconc (butlast rows)
1645                                   (list penultimate-row)
1646                                   (cli:split-last-row (list lowest-row)
1647                                                   column-widths)))))))
1648
1649 (defun cli:server-action ()
1650   "Start the HTTP server."
1651   (cli:with-options (:log t)
1652       (host port database user password use-ssl
1653             proxy-root http-port address common-root pid-file)
1654     (cli:with-options (:tolerate-missing t)
1655         (aux-host aux-port aux-database aux-user aux-password aux-use-ssl)
1656       (setf address (unless (string= address "*") address))
1657       (setf *postgresql-credentials*
1658             (list database user password host :port port
1659                   :use-ssl (s-sql:from-sql-name use-ssl)))
1660       (setf *postgresql-aux-credentials*
1661             (if (and aux-user aux-password aux-database)
1662                 (list aux-database aux-user aux-password aux-host
1663                       :port aux-port
1664                       :use-ssl (s-sql:from-sql-name aux-use-ssl))
1665                 *postgresql-credentials*))
1666       #+sbcl(unless (cli:verbosity-level :no-daemon)
1667               (assert
1668                (not (with-open-file (s pid-file :if-does-not-exist nil)
1669                       (when s
1670                         (probe-file (make-pathname
1671                                      :directory (list :absolute "proc"
1672                                                       (read-line s nil)))))))
1673                ()
1674                "~A contains the PID of a running process ~
1675                so I won't put my own there.  Giving up."
1676                (truename pid-file))
1677               (sb-daemon:daemonize :pidfile pid-file :exit-parent t))
1678       (insert-all-footprints *postgresql-credentials*)
1679       (delete-all-imageless-points *postgresql-credentials*)
1680       (setf hunchentoot:*log-lisp-backtraces-p*
1681             (cli:verbosity-level :log-error-backtraces))
1682       (setf hunchentoot:*show-lisp-errors-p*
1683             (cli:verbosity-level :show-server-errors))
1684       (setf *ps-print-pretty*
1685             (cli:verbosity-level :pretty-javascript))
1686       (start-server :proxy-root proxy-root
1687                     :http-port http-port
1688                     :address address
1689                     :common-root common-root)
1690       (cl-log:log-message
1691        :info
1692        "HTTP server listens on port ~D ~
1693        of ~:[all available addresses~;address ~:*~A~].  ~
1694        It expects to be called with a URL path root of /~A/.  ~
1695        Phoros database is ~A on ~A:~D.  Auxiliary database is ~A on ~A:~D.  ~
1696        Files are searched for in ~A."
1697        http-port address
1698        proxy-root
1699        database host port
1700        aux-database aux-host aux-port
1701        common-root)
1702       (loop (sleep 10)))))