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