cli.lisp

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