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 () (count byte-position in out
1201                            raw-bayer-pattern raw-color-raiser)
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 raw-bayer-pattern)
1210                            :color-raiser
1211                            (cli:canonicalize-color-raiser raw-color-raiser))
1212                  (send-nth-png count out-stream in
1213                                :bayer-pattern
1214                                (cli:canonicalize-bayer-pattern raw-bayer-pattern)
1215                                :color-raiser
1216                                (cli:canonicalize-color-raiser raw-color-raiser)))))
1217         (format *standard-output*
1218                 "~&~A~%" (timestring (utc-from-unix trigger-time)))))))
1219
1220 (defun cli:create-presentation-project-action ()
1221   "Make a presentation project."
1222   (cli:with-options (:database t :log t) (create-presentation-project)
1223     (let* ((presentation-project-name create-presentation-project)
1224            (fresh-project-p
1225             (create-presentation-project presentation-project-name)))
1226       (cl-log:log-message
1227        :db-dat
1228        "~:[Tried to recreate an existing~;Created a fresh~] ~
1229        presentation project by the name of ~A in database ~A at ~A:~D."
1230        fresh-project-p presentation-project-name database host port))))
1231
1232 (defun cli:delete-presentation-project-action ()
1233   "Delete a presentation project."
1234   (cli:with-options (:database t :log t) (delete-presentation-project)
1235     (let ((presentation-project-name delete-presentation-project))
1236       (assert-presentation-project presentation-project-name)
1237       (when (yes-or-no-p
1238              "You asked me to delete presentation-project ~A ~
1239              (including its tables of user-defined points and lines, ~
1240              ~A and ~A respectively) from database ~A at ~A:~D.  Proceed?"
1241              presentation-project-name
1242              (user-point-table-name presentation-project-name)
1243              (user-line-table-name presentation-project-name)
1244              database host port)
1245         (let ((project-did-exist-p
1246                (delete-presentation-project presentation-project-name)))
1247           (cl-log:log-message
1248            :db-dat
1249            "~:[Tried to delete nonexistent~;Deleted~] ~
1250            presentation project ~A from database ~A at ~A:~D."
1251            project-did-exist-p presentation-project-name
1252            database host port))))))
1253
1254 (defun cli:add-to-presentation-project-action ()
1255   "Add measurements to a presentation project."
1256   (cli:with-options (:database t :log t)
1257       (add-to-presentation-project)
1258     (cli:with-options (:tolerate-missing t)
1259         (measurement-id acquisition-project)
1260       (let ((presentation-project-name add-to-presentation-project))
1261         (assert-presentation-project presentation-project-name)
1262         (add-to-presentation-project presentation-project-name
1263                                      :measurement-ids measurement-id
1264                                      :acquisition-project acquisition-project)
1265         (cl-log:log-message
1266          :db-dat
1267          "Added ~@[measurement-ids ~{~D~#^, ~}~]~
1268        ~@[all measurements from acquisition project ~A~] ~
1269        to presentation project ~A in database ~A at ~A:~D."
1270          measurement-id acquisition-project
1271          presentation-project-name database host port)))))
1272
1273 (defun cli:remove-from-presentation-project-action ()
1274   "Add measurements to a presentation project."
1275   (cli:with-options (:database t :log t)
1276       (measurement-id acquisition-project remove-from-presentation-project)
1277     (let ((presentation-project-name remove-from-presentation-project))
1278       (assert-presentation-project presentation-project-name)
1279       (remove-from-presentation-project
1280          presentation-project-name
1281          :measurement-ids measurement-id
1282          :acquisition-project acquisition-project)
1283       (cl-log:log-message
1284        :db-dat
1285        "Removed ~@[measurement-ids ~{~D~#^, ~}~]~
1286        ~@[all measurements that belong to acquisition project ~A~] ~
1287        from presentation project ~A in database ~A at ~A:~D."
1288        measurement-id acquisition-project
1289        presentation-project-name database host port))))
1290
1291 (defun cli:create-image-attribute-action ()
1292   "Store a boolean SQL expression."
1293   (cli:with-options (:database t :log t)
1294       (tag sql-clause create-image-attribute)
1295     (let ((presentation-project-name create-image-attribute))
1296       (assert-presentation-project presentation-project-name)
1297       (multiple-value-bind (old-image-attribute
1298                             number-of-selected-images
1299                             total-number-of-images)
1300           (create-image-attribute presentation-project-name
1301                                   :tag tag :sql-clause sql-clause)
1302         (cl-log:log-message
1303          :db-dat
1304          "~:[Stored a fresh~;Updated an~] ~
1305          image attribute, tagged ~S, for presentation project ~A ~
1306          in database ~A at ~A:~D~
1307          ~0@*~@[, replacing the SQL clause previously stored there of ~S~].  ~
1308          ~6@*~@[The new SQL clause currently selects ~D out of ~D images.~]"
1309          old-image-attribute
1310          tag
1311          presentation-project-name
1312          database host port
1313          number-of-selected-images total-number-of-images)))))
1314
1315 (defun cli:delete-image-attribute-action ()
1316   "Remove SQL expression specified by presentation-project-name and tag."
1317   (cli:with-options (:database t :log t)
1318       (tag delete-image-attribute)
1319     (let ((presentation-project-name delete-image-attribute))
1320       (assert-presentation-project presentation-project-name)
1321       (let ((replaced-sql-clause
1322              (delete-image-attribute presentation-project-name :tag tag)))
1323         (cl-log:log-message
1324          :db-dat
1325          "~:[Tried to delete a nonexistent~;Deleted~] ~
1326        image attribute tagged ~S from ~
1327        presentation project ~A in database ~A at ~A:~D.  ~
1328        ~0@*~@[Its SQL clause, now deleted, was ~S~]"
1329          replaced-sql-clause tag presentation-project-name
1330          database host port)))))
1331
1332 (defun cli:list-image-attribute-action ()
1333   "List boolean SQL expressions."
1334   (cli:with-options (:database t) (tag list-image-attribute)
1335     (let* ((presentation-project-name (if (string= list-image-attribute "*")
1336                                           'presentation-project-name
1337                                           list-image-attribute))
1338            (restriction-id (or tag 'restriction-id))
1339            (content
1340             (query
1341              (:order-by
1342               (:select 'presentation-project-name
1343                        'sys-selectable-restriction.presentation-project-id
1344                        'restriction-id
1345                        'sql-clause
1346                        :from 'sys-selectable-restriction
1347                        :natural :left-join 'sys-presentation-project
1348                        :where (:and (:= presentation-project-name
1349                                         'presentation-project-name)
1350                                     (:= restriction-id
1351                                         'restriction-id)))
1352               'presentation-project-name 'restriction-id))))
1353       (cli:format-table *standard-output* content
1354                         '("Presentation Project" "ID" "Tag" "SQL-clause")
1355                         :column-widths '(nil nil nil 60)))))
1356
1357 (defun cli:redefine-trigger-function-action ()
1358   "Recreate an SQL trigger function that is fired on changes to the
1359 user point table, and fire it once."
1360   (cli:with-options (:database t :log t)
1361       (plpgsql-body redefine-trigger-function)
1362     (let ((presentation-project-name redefine-trigger-function)
1363           (body-text (make-array '(1) :adjustable t :fill-pointer 0
1364                                  :element-type 'character)))
1365       (if plpgsql-body
1366           (with-open-file (stream plpgsql-body)
1367             (loop
1368                for c = (read-char stream nil)
1369                while c
1370                do (vector-push-extend c body-text))
1371             (create-presentation-project-trigger-function
1372              presentation-project-name
1373              body-text
1374              (s-sql:to-sql-name (user-point-table-name
1375                                  presentation-project-name))
1376              (s-sql:to-sql-name (user-line-table-name
1377                                  presentation-project-name))))
1378           (create-presentation-project-trigger-function
1379            presentation-project-name))
1380       (fire-presentation-project-trigger-function presentation-project-name)
1381       (cl-log:log-message
1382        :db-dat
1383        "Defined (and fired once) ~
1384        a trigger function associatad with user point table of ~
1385        presentation project ~A in database ~A at ~A:~D to ~
1386        ~:[perform a minimal default action.~;perform the body given ~
1387           in file ~:*~A, whose content is is:~&~A~]"
1388        presentation-project-name database host port
1389        plpgsql-body body-text))))
1390
1391 (defun cli:create-aux-view-action ()
1392   "Connect presentation project to an auxiliary data table by means of
1393 a view."
1394   (cli:with-options (:database t :log t) (create-aux-view)
1395     (assert-presentation-project create-aux-view))
1396   (cli:with-options (:aux-database t :log t)
1397       (host port database user password use-ssl
1398             coordinates-column (numeric-column) (text-column) aux-table
1399             create-aux-view)
1400     (let* ((presentation-project-name create-aux-view)
1401            (numeric-columns
1402             (nsubstitute nil "" numeric-column :test #'string=))
1403            (text-columns
1404             (nsubstitute nil "" text-column :test #'string=))
1405            (aux-view-in-phoros-db-p
1406             (every #'equal
1407                    (list host port database user password use-ssl)
1408                    (list aux-host aux-port aux-database
1409                          aux-user aux-password aux-use-ssl)))
1410            (aux-view-exists-p
1411             (aux-view-exists-p presentation-project-name)))
1412       (when (or
1413              aux-view-in-phoros-db-p
1414              (yes-or-no-p
1415               "I'm going to ~:[create~;replace~] a view named ~A ~
1416               in database ~A at ~A:~D.  Proceed?"
1417               aux-view-exists-p
1418               (aux-point-view-name presentation-project-name)
1419               aux-database aux-host aux-port))
1420         (when aux-view-exists-p
1421           (delete-aux-view presentation-project-name))
1422         (create-aux-view presentation-project-name
1423                          :coordinates-column coordinates-column
1424                          :numeric-columns numeric-columns
1425                          :text-columns text-columns
1426                          :aux-table aux-table)
1427         (add-spherical-mercator-ref)
1428         (cl-log:log-message
1429          :db-dat
1430          "~:[Created~;Updated~] in database ~A at ~A:~D a view called ~A ~
1431          into table (of auxiliary data) ~A.  Coordinates column is ~A.  ~
1432          ~:[No numeric columns.~;Numeric column(s): ~:*~{~A~#^, ~}.~]  ~
1433          ~:[No text columns.~;Text column(s): ~:*~{~A~#^, ~}.~]  ~
1434          Also, ~0@*~:[created~;recreated~] in the same database a ~
1435          function called ~9@*~A."
1436          aux-view-exists-p
1437          aux-database aux-host aux-port
1438          (aux-point-view-name presentation-project-name)
1439          aux-table coordinates-column
1440          numeric-columns text-columns
1441          (thread-aux-points-function-name presentation-project-name))))))
1442
1443 (defun cli:store-user-points-action ()
1444   "Store user points from a GeoJSON file into database."
1445   (cli:with-options (:database t :log t) (json-file store-user-points)
1446     (let ((presentation-project store-user-points))
1447       (assert-presentation-project presentation-project)
1448       (multiple-value-bind
1449             (points-stored points-already-in-db points-tried zombie-users)
1450           (store-user-points presentation-project :json-file json-file)
1451         (cl-log:log-message
1452          :db-dat
1453          "Tried to store the ~D user point~:P I found in file ~A ~
1454          into presentation project ~A in database ~A at ~A:~D.  ~
1455          ~:[~:[~D~;None~*~]~;All~2*~] of them ~:[were~;was~] ~
1456          already present.  ~
1457          ~:[~:[~:[~D points have~;1 point has~*~]~;Nothing has~2*~]~
1458             ~;All points tried have~3*~] ~
1459          been added to the user point table.  ~
1460          ~15@*~@[I didn't know ~14@*~[~;a~:;any of the~] user~14@*~P ~
1461          called ~{~A~#^, ~}; treated them as zombie~14@*~P.~]"
1462          points-tried
1463          (truename json-file)
1464          presentation-project database host port
1465          (= points-already-in-db points-tried)
1466          (zerop points-already-in-db)
1467          points-already-in-db
1468          (<= points-already-in-db 1)
1469          (= points-stored points-tried)
1470          (zerop points-stored)
1471          (= 1 points-stored)
1472          points-stored
1473          (length zombie-users)          ;arg 14
1474          zombie-users)))))              ;arg 15
1475
1476 (defun cli:get-user-points-action ()
1477   "Save user points of presentation project into a GeoJSON file."
1478   (cli:with-options (:database t :log t) (json-file get-user-points)
1479     (let ((presentation-project get-user-points))
1480       (assert-presentation-project presentation-project)
1481       (multiple-value-bind (user-points user-point-count)
1482           (get-user-points (user-point-table-name presentation-project)
1483                            :indent t)
1484         (assert json-file ()
1485                 "Don't know where to store.  Try option --json-file")
1486         (unless (zerop user-point-count)
1487           (with-open-file (stream json-file
1488                                   :direction :output
1489                                   :if-exists :supersede)
1490             (princ user-points stream)))
1491         (cl-log:log-message
1492          :db-dat
1493          "~[There are no user points to get from presentation project ~A in ~
1494          database ~A at ~A:~D.  Didn't touch any file.~
1495          ~:;~:*Saved ~D user point~:P from presentation project ~A in ~
1496          database ~A at ~A:~D into file ~A.~]"
1497          user-point-count
1498          presentation-project database host port
1499          (ignore-errors (truename json-file)))))))
1500
1501 (defun cli:create-user-action ()
1502   "Define a new user."
1503   (cli:with-options (:database t :log t)
1504       ((presentation-project)
1505        user-full-name user-role user-password
1506        create-user)
1507     (let ((presentation-project-user create-user)
1508           fresh-user-p)
1509       (mapcar #'assert-presentation-project presentation-project)
1510       (setf fresh-user-p
1511             (create-user presentation-project-user
1512                          :presentation-projects presentation-project
1513                          :user-password user-password
1514                          :user-full-name user-full-name
1515                          :user-role user-role))
1516       (cl-log:log-message
1517        :db-dat ;TODO: We're listing nonexistent p-projects here as well.
1518        "~:[Updated~;Created~] user ~A (~A) who has ~A access ~
1519        to ~:[no ~;~]presentation project(s)~:*~{ ~A~#^,~} ~
1520        in database ~A at ~A:~D."
1521        fresh-user-p presentation-project-user
1522        user-full-name user-role
1523        presentation-project database host port))))
1524
1525 (defun cli:delete-user-action ()
1526   "Delete a presentation project user."
1527   (cli:with-options (:database t :log t) (delete-user)
1528     (let* ((presentation-project-user delete-user)
1529            (user-did-exist-p (delete-user presentation-project-user)))
1530       (cl-log:log-message
1531        :db-dat
1532        "~:[Tried to delete nonexistent~;Deleted~] ~
1533        presentation project user ~A from database ~A at ~A:~D."
1534        user-did-exist-p presentation-project-user database host port))))
1535
1536 (defun cli:list-user-action ()
1537   "List presentation project users together with their presentation
1538 projects."
1539   (cli:with-options (:database t) (list-user)
1540     (let* ((presentation-project-user (if (string= list-user "*")
1541                                           'user-name
1542                                           list-user))
1543            (content
1544             (query
1545              (:order-by
1546               (:select
1547                'user-name 'sys-user.user-id 'user-password
1548                'user-full-name 'presentation-project-name
1549                'sys-user-role.presentation-project-id 'user-role
1550                :from 'sys-user 'sys-user-role 'sys-presentation-project
1551                :where (:and (:= 'sys-user-role.presentation-project-id
1552                                 'sys-presentation-project.presentation-project-id)
1553                             (:= 'sys-user.user-id 'sys-user-role.user-id)
1554                             (:= 'user-name presentation-project-user)))
1555               'user-name))))
1556       (cli:format-table *standard-output* content
1557                         '("User" "ID" "Password" "Full Name"
1558                           "Presentation Project" "ID" "Role")))))
1559
1560 (defun cli:list-presentation-project-action ()
1561   "List content of presentation projects."
1562   (cli:with-options (:database t) (list-presentation-project)
1563     (let* ((presentation-project (if (string= list-presentation-project "*")
1564                                      'presentation-project-name
1565                                      list-presentation-project))
1566            (content
1567             (query
1568              (:order-by
1569               (:select
1570                'presentation-project-name
1571                'sys-presentation-project.presentation-project-id
1572                'sys-presentation.measurement-id
1573                'common-table-name
1574                'sys-measurement.acquisition-project-id
1575                :from
1576                'sys-presentation-project 'sys-presentation
1577                'sys-measurement 'sys-acquisition-project
1578                :where
1579                (:and (:= 'sys-presentation-project.presentation-project-id
1580                          'sys-presentation.presentation-project-id)
1581                      (:= 'sys-presentation.measurement-id
1582                          'sys-measurement.measurement-id)
1583                      (:= 'sys-measurement.acquisition-project-id
1584                          'sys-acquisition-project.acquisition-project-id)
1585                      (:= 'presentation-project-name
1586                          presentation-project)))
1587               'presentation-project-name
1588               'sys-presentation.measurement-id))))
1589       (cli:format-table *standard-output* content
1590                         '("Presentation Project" "ID" "Meas. ID"
1591                           "Acquisition Project" "ID")))))
1592
1593 (defun cli:format-table (destination content column-headers &key
1594                          (column-separator " | ")
1595                          (header-separator #\-)
1596                          (column-widths (mapcar (constantly nil)
1597                                                 column-headers)))
1598   "Print content (a list of lists) to destination."
1599   (let* ((rows (append (list column-headers)
1600                        (list (mapcar (constantly "") column-headers))
1601                        content))
1602          (number-of-rows (length column-headers))
1603          (widths
1604           (loop
1605              for column from 0 below number-of-rows
1606              collect (or (nth column column-widths)
1607                          (loop
1608                             for row in rows
1609                             maximize (length (format nil "~A" (nth column row))))))))
1610     (setf (second rows)
1611           (loop
1612              for width in widths collect
1613              (make-string width :initial-element header-separator)))
1614     (setf rows
1615           (loop
1616              for row in rows
1617              for i from 0
1618              nconc (cli:split-last-row (list row) widths)))
1619     (loop
1620        for row in rows do
1621        (format destination "~&~{~VA~1,#^~A~}~%"
1622                (loop
1623                   for width in widths and field in row
1624                   collect width collect field collect column-separator)))))
1625
1626 (defun cli:split-last-row (rows column-widths)
1627   "If necessary, split fields of the last element of rows whose width
1628 exceeds the respective column-width over multiple rows."
1629   (let ((last-row (mapcar #'(lambda (x) (format nil "~A" x))
1630                           (car (last rows)))))
1631     (if (notany #'(lambda (field width) (> (length field) width))
1632                 last-row
1633                 column-widths)
1634         rows
1635         (loop
1636            for field in last-row
1637            for column-width in column-widths
1638            collect (subseq field 0 (min column-width (length field)))
1639            into penultimate-row
1640            collect (subseq field (min column-width (length field)))
1641            into lowest-row
1642            finally (return (nconc (butlast rows)
1643                                   (list penultimate-row)
1644                                   (cli:split-last-row (list lowest-row)
1645                                                   column-widths)))))))
1646
1647 (defun cli:server-action ()
1648   "Start the HTTP server."
1649   (cli:with-options (:log t)
1650       (host port database user password use-ssl
1651             proxy-root http-port address common-root pid-file)
1652     (cli:with-options (:tolerate-missing t)
1653         (aux-host aux-port aux-database aux-user aux-password aux-use-ssl)
1654       (setf address (unless (string= address "*") address))
1655       (setf *postgresql-credentials*
1656             (list database user password host :port port
1657                   :use-ssl (s-sql:from-sql-name use-ssl)))
1658       (setf *postgresql-aux-credentials*
1659             (if (and aux-user aux-password aux-database)
1660                 (list aux-database aux-user aux-password aux-host
1661                       :port aux-port
1662                       :use-ssl (s-sql:from-sql-name aux-use-ssl))
1663                 *postgresql-credentials*))
1664       #+sbcl(unless (cli:verbosity-level :no-daemon)
1665               (assert
1666                (not (with-open-file (s pid-file :if-does-not-exist nil)
1667                       (when s
1668                         (probe-file (make-pathname
1669                                      :directory (list :absolute "proc"
1670                                                       (read-line s nil)))))))
1671                ()
1672                "~A contains the PID of a running process ~
1673                so I won't put my own there.  Giving up."
1674                (truename pid-file))
1675               (sb-daemon:daemonize :pidfile pid-file :exit-parent t))
1676       (insert-all-footprints *postgresql-credentials*)
1677       (delete-all-imageless-points *postgresql-credentials*)
1678       (setf hunchentoot:*log-lisp-backtraces-p*
1679             (cli:verbosity-level :log-error-backtraces))
1680       (setf hunchentoot:*show-lisp-errors-p*
1681             (cli:verbosity-level :show-server-errors))
1682       (setf *ps-print-pretty*
1683             (cli:verbosity-level :pretty-javascript))
1684       (start-server :proxy-root proxy-root
1685                     :http-port http-port
1686                     :address address
1687                     :common-root common-root)
1688       (cl-log:log-message
1689        :info
1690        "HTTP server listens on port ~D ~
1691        of ~:[all available addresses~;address ~:*~A~].  ~
1692        It expects to be called with a URL path root of /~A/.  ~
1693        Phoros database is ~A on ~A:~D.  Auxiliary database is ~A on ~A:~D.  ~
1694        Files are searched for in ~A."
1695        http-port address
1696        proxy-root
1697        database host port
1698        aux-database aux-host aux-port
1699        common-root)
1700       (loop (sleep 10)))))