cli.lisp

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