cli.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011 Bert Burgemeister
   3 ;;;
   4 ;;; This program is free software; you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation; either version 2 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License along
  15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
  16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17
  18
  19 ;;;; The UNIX command line interface
  20
  21 (in-package :phoros)
  22
  23 (defparameter *cli-main-options*
  24   '((("help" #\h) :action #'cli-help-action
  25      :documentation "Print this help and exit.")
  26     ("version" :action #'cli-version-action
  27      :documentation "Output version information and exit.  Use --verbose=1 to see more.")
  28     ("verbose" :type integer :initial-value 0 :action *verbose*
  29      :documentation "Dependent on bits set in this integer, emit various kinds of debugging output. ")
  30     ("log-dir" :type string :initial-value ""
  31      :documentation "Where to put the log files.  Created if necessary; should end with a slash.")
  32     ("check-db" :action #'check-db-action
  33      :documentation "Check database connection and exit.")
  34     ("check-dependencies" :action #'check-dependencies-action
  35      :documentation "Check presence of dependencies on local system and exit.")
  36     ("nuke-all-tables" :action #'nuke-all-tables-action
  37      :documentation "Ask for confirmation, then delete anything in database and exit.")
  38     ("create-sys-tables" :action #'create-sys-tables-action
  39      :documentation "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.")
  40     ("create-acquisition-project" :type string :action #'create-acquisition-project-action
  41      :documentation "Create a fresh set of canonically named data tables.  The string argument 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.")))
  42
  43 (defparameter *cli-db-connection-options*
  44   '((("host" #\H) :type string :initial-value "localhost" :documentation "Database server.")
  45     (("port" #\P) :type integer :initial-value 5432
  46      :documentation "Port on database server.")
  47     (("database" #\D) :type string :initial-value "phoros"
  48      :documentation "Name of database.")
  49     (("user" #\U) :type string
  50      :documentation "Database user.")
  51     (("password" #\W) :type string
  52      :documentation "Database user's password.")
  53     ("use-ssl" :type string :initial-value "no"
  54      :documentation "Use SSL in database connection. [yes|no|try]")))
  55
  56 (defparameter *cli-get-image-options*
  57   '(("get-image" :action #'get-image-action
  58      :documentation "Get a single image from a .pictures file, print its trigger-time to stdout, and exit.")
  59     ("count" :type integer :initial-value 0
  60      :documentation "Image number in .pictures file.")
  61     ("byte-position" :type integer
  62      :documentation "Byte position of image in .pictures file.")
  63     ("in" :type string
  64      :documentation "Path to .pictures file.")
  65     ("out" :type string :initial-value "phoros-get-image.png"
  66      :documentation "Path to to output .png file.")
  67     ;; The way it should be had we two-dimensional arrays in postmodern:
  68     ;;("bayer-pattern" :type string :list t :optional t :action :raw-bayer-pattern :documentation "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.")
  69     ("bayer-pattern" :type string :initial-value "#ff0000,#00ff00" :action :raw-bayer-pattern
  70      :documentation "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.")))
  71
  72 (defparameter *cli-camera-hardware-options*
  73   '(("store-camera-hardware" :action #'store-camera-hardware-action
  74      :documentation "Put new camera-hardware data into the database; print camera-hardware-id to stdout.")
  75     ("sensor-width-pix" :type integer
  76      :documentation "Width of camera sensor.")
  77     ("sensor-height-pix" :type integer
  78      :documentation "Height of camera sensor.")
  79     ("pix-size" :type string
  80      :documentation "Camera pixel size in millimetres (float).")
  81     ("channels" :type integer
  82      :documentation "Number of color channels")
  83     ("pix-depth" :type integer :initial-value 255
  84      :documentation "Greatest possible pixel value.")
  85     ("color-raiser" :type string :initial-value "1,1,1"
  86      :action :raw-color-raiser
  87      :documentation "Multipliers for the individual color components.  Example: 1.2,1,.8 multiplies red by 1.2 and blue by 0.8.")
  88     ;; The way it should be had we two-dimensional arrays in postmodern:
  89     ;;("bayer-pattern" :type string :list t :optional t :action :raw-bayer-pattern :documentation "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.")
  90     ("bayer-pattern" :type string :optional t
  91      :action :raw-bayer-pattern
  92      :documentation "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.")
  93     ("serial-number" :type string
  94      :documentation "Serial number.")
  95     ("description" :type string
  96      :documentation "Description of camera.")
  97     ("try-overwrite" :type boolean :initial-value "yes"
  98      :documentation "Overwrite matching camera-hardware record if any.")))
  99
 100 (defparameter *cli-lens-options*
 101   '(("store-lens" :action #'store-lens-action
 102      :documentation "Put new lens data into the database; print lens-id to stdout.")
 103     ("c" :type string
 104      :documentation "Nominal focal length in millimetres.")
 105     ("serial-number" :type string
 106      :documentation "Serial number.")
 107     ("description" :type string
 108      :documentation "Lens desription.")
 109     ("try-overwrite" :type boolean :initial-value "yes"
 110      :documentation "Overwrite matching lens record if any.")))
 111
 112 (defparameter *cli-generic-device-options*
 113   '(("store-generic-device" :action #'store-generic-device-action
 114      :documentation "Put a newly defined generic-device into the database; print generic-device-id to stdout.")
 115     ("camera-hardware-id" :type integer
 116      :documentation "Numeric camera hardware id in database.")
 117     ("lens-id" :type integer
 118      :documentation "Numeric lens id in database.")))
 119
 120 (defparameter *cli-device-stage-of-life-options*
 121   '(("store-device-stage-of-life" :action #'store-device-stage-of-life-action
 122      :documentation "Put a newly defined device-stage-of-life into the database; print device-stage-of-life-id to stdout.")
 123     ("recorded-device-id" :type string
 124      :documentation "Device id stored next to the measuring data.")
 125     ("event-number" :type string
 126      :documentation "GPS event that triggers this generic device.")
 127     ("generic-device-id" :type integer
 128      :documentation "Numeric generic-device id in database.")
 129     ("vehicle-name" :type string
 130      :documentation "Descriptive name of vehicle.")
 131     ("casing-name" :type string
 132      :documentation "Descriptive name of device casing.")
 133     ("computer-name" :type string
 134      :documentation "Name of the recording device.")
 135     ("computer-interface-name" :type string
 136      :documentation "Interface at device.")
 137     ("mounting-date" :type string
 138      :documentation "Time this device constellation became effective.  Format: `2010-11-19T13:49+01´.")))
 139
 140 (defparameter *cli-device-stage-of-life-end-options*
 141   '(("store-device-stage-of-life-end" :action #'store-device-stage-of-life-end-action
 142      :documentation "Put an end date to a device-stage-of-life in the database; print device-stage-of-life-id to stdout.")
 143     ("device-stage-of-life-id" :type string
 144      :documentation "Id of the device-stage-of-life to put to an end.")
 145     ("unmounting-date" :type string
 146      :documentation "Time this device constellation ceased to be effective.  Format: `2010-11-19T17:02+01´.")))
 147
 148 (defparameter *cli-camera-calibration-options*
 149   '(("store-camera-calibration" :action #'store-camera-calibration-action
 150      :documentation "Put new camera-calibration into the database; print generic-device-id and calibration date to stdout.")
 151     ("device-stage-of-life-id" :type string
 152      :documentation "This tells us what hardware this calibration is for.")
 153     ("date" :type string
 154      :documentation "Date of calibration.  Format: `2010-11-19T13:49+01´.")
 155     ("person" :type string
 156      :documentation "Person who did the calibration.")
 157     ("main-description" :type string
 158      :documentation "Regarding this entire set of calibration data")
 159     ("debug" :type string
 160      :documentation "If true: not for production use; may be altered or deleted at any time.")
 161     ("photogrammetry-version" :type string
 162      :documentation "Software version used to create this data.")
 163     ("mounting-angle" :type integer
 164      :documentation "Head up = 0; right ear up = 90; left ear up = -90; head down = 180.")
 165     ("inner-orientation-description" :type string
 166      :documentation "Comments regarding inner orientation calibration.")
 167     ("c" :type string :documentation "Inner orientation: focal length.")
 168     ("xh" :type string
 169      :documentation "Inner orientation: principal point displacement.")
 170     ("yh" :type string
 171      :documentation "Inner orientation: principal point displacement.")
 172     ("a1" :type string :documentation "Inner orientation: radial distortion.")
 173     ("a2" :type string :documentation "Inner orientation: radial distortion.")
 174     ("a3" :type string :documentation "Inner orientation: radial distortion.")
 175     ("b1" :type string
 176      :documentation "Inner orientation: asymmetric and tangential distortion.")
 177     ("b2" :type string
 178      :documentation "Inner orientation: asymmetric and tangential distortion.")
 179     ("c1" :type string
 180      :documentation "Inner orientation: affinity and shear distortion.")
 181     ("c2" :type string
 182      :documentation "Inner orientation: affinity and shear distortion.")
 183     ("r0" :type string :documentation "Inner orientation.")
 184     ("outer-orientation-description" :type string
 185      :documentation "Comments regarding outer orientation calibration.")
 186     ("dx" :type string :documentation "Outer orientation; in metres.")
 187     ("dy" :type string :documentation "Outer orientation; in metres.")
 188     ("dz" :type string :documentation "Outer orientation; in metres.")
 189     ("omega" :type string :documentation "Outer orientation.")
 190     ("phi" :type string :documentation "Outer orientation.")
 191     ("kappa" :type string :documentation "Outer orientation.")
 192     ("boresight-description" :type string
 193      :documentation "Comments regarding boresight alignment calibration.")
 194     ("b-dx" :type string :documentation "Boresight alignment.")
 195     ("b-dy" :type string :documentation "Boresight alignment.")
 196     ("b-dz" :type string :documentation "Boresight alignment.")
 197     ("b-ddx" :type string :documentation "Boresight alignment.")
 198     ("b-ddy" :type string :Documentation "Boresight alignment.")
 199     ("b-ddz" :type string :documentation "Boresight alignment.")
 200     ("b-rotx" :type string :documentation "Boresight alignment.")
 201     ("b-roty" :type string :documentation "Boresight alignment.")
 202     ("b-rotz" :type string :documentation "Boresight alignment.")
 203     ("b-drotx" :type string :documentation "Boresight alignment.")
 204     ("b-droty" :type string :documentation "Boresight alignment.")
 205     ("b-drotz" :type string :documentation "Boresight alignment.")
 206     ("nx" :type string
 207      :documentation "X component of unit vector of vehicle ground plane.")
 208     ("ny" :type string
 209      :documentation "Y component of unit vector of vehicle ground plane.")
 210     ("nz" :type string
 211      :documentation "Z component of unit vector of vehicle ground plane.")
 212     ("d" :type string :documentation "Distance of vehicle ground plane.")))
 213
 214 (defparameter *cli-store-images-and-points-options*
 215   '((("store-images-points" #\s) :type string :action #'store-images-and-points-action
 216      :documentation "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.")
 217     (("directory" #\d) :type string
 218      :documentation "Directory containing one set of measuring data.")
 219     (("common-root" #\r) :type string
 220      :documentation "The root part of directory that is equal for all pojects.  TODO: come up with some sensible default.")
 221     ("epsilon" :type string :initial-value ".001"
 222      :documentation "Difference in seconds below which two timestamps are considered equal.")
 223     ("aggregate-events" :type nil
 224      :documentation "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.")))
 225
 226 (defparameter *cli-start-server-options*
 227   '(("server" :action #'server-action :documentation "Start HTTP presentation server.  Entry URI is http://<host>:<port>/phoros/<project>")
 228     ("server-port" :type integer :initial-value 8080 :documentation "Port the presentation server listens on.")
 229     (("common-root" #\r) :type string :initial-value "/"
 230      :documentation "The root part of directory that is equal for all pojects.  TODO: come up with some sensible default.")))
 231
 232 (defparameter *cli-presentation-project-options*
 233   '(("create-presentation-project"
 234      :type string :action #'create-presentation-project-action
 235      :documentation "Create a fresh presentation project which is to expose a set of meassurements to certain users.")
 236     ("delete-presentation-project"
 237      :type string :action #'delete-presentation-project-action
 238      :documentation "Delete a presentation project.")
 239     ("list-presentation-project"
 240      :type string :optional t :action #'list-presentation-project-action
 241      :documentation "List one presentation project if specified, or all presentation projects if not.")
 242     ("add-to-presentation-project"
 243      :type string :action #'add-to-presentation-project-action
 244      :documentation "Add to the presentation project given either certain measurements or all measurements currently in a certain acquisition project.")
 245     ("remove-from-presentation-project"
 246      :type string :action #'remove-from-presentation-project-action
 247      :documentation "Remove from the presentation project given either certain measurements or all measurements currently in a certain acquisition project.")
 248     ("measurement-id" :type integer :list t :optional t
 249      :documentation "One measurement-id to add or remove.  Repeat if necessary.")
 250     ("acquisition-project" :type string
 251      :documentation "The acquisition project whose measurements are to add or remove.")))
 252
 253 (defparameter *cli-user-options*
 254   '(("create-user"
 255      :type string :action #'create-user-action
 256      :documentation "Create or update a user of certain presentation projects.")
 257     ("user-password" :type string :documentation "User's password.")
 258     ("user-full-name" :type string :documentation "User's real name.")
 259     ("presentation-project" :type string :list t :optional t
 260      :documentation "Presentation project the user is allowed to see.  Repeat if necessary.")
 261     ("delete-user"
 262      :type string :action #'delete-user-action :documentation "Delete user.")
 263     ("list-user"
 264      :type string :optional t :action #'list-user-action
 265      :documentation "List the specified user with their presentation projects, or all users if no user is given.")))
 266
 267 (defparameter *cli-options*
 268   (append *cli-main-options* *cli-db-connection-options* *cli-get-image-options*
 269           *cli-camera-hardware-options* *cli-lens-options*
 270           *cli-generic-device-options* *cli-device-stage-of-life-options*
 271           *cli-device-stage-of-life-end-options*
 272           *cli-camera-calibration-options* *cli-store-images-and-points-options*
 273           *cli-start-server-options*
 274           *cli-presentation-project-options* *cli-user-options*))
 275
 276 (defun main ()
 277   "The UNIX command line entry point."
 278 ;;  (handler-bind ((serious-condition (lambda (c)
 279 ;;                                      (declare (ignore c))
 280 ;;                                      (sb-debug:backtrace))))
 281   #+sbcl (sb-ext:disable-debugger)
 282   (handler-case
 283       (progn
 284         (cffi:use-foreign-library photogrammetrie)
 285         (compute-and-process-command-line-options *cli-options*))
 286     (serious-condition (c)
 287       (cl-log:log-message :warning "Fatal: ~A" c)
 288       (format *error-output* "~A~&" c))))
 289
 290 (defun cli-help-action (&rest rest)
 291   "Print --help message."
 292   (declare (ignore rest))
 293   (flet ((show-help-headline (content)
 294            (format *standard-output* "~&~95,,,'#@<~A ~>" content)))
 295     (format *standard-output*
 296             "~&Usage: phoros [options] ...~&~A"
 297             (asdf:system-long-description (asdf:find-system :phoros)))
 298     (show-help-headline "Main Options")
 299     (show-option-help *cli-main-options*)
 300     (show-help-headline "Database Connection")
 301     (show-option-help *cli-db-connection-options*)
 302     (show-help-headline "Examine .pictures File")
 303     (show-option-help *cli-get-image-options*)
 304     (show-help-headline "Camera Hardware Parameters")
 305     (show-option-help *cli-camera-hardware-options*)
 306     (show-help-headline "Lens Parameters")
 307     (show-option-help *cli-lens-options*)
 308     (show-help-headline "Generic Device Definition")
 309     (show-option-help *cli-generic-device-options*)
 310     (show-help-headline "Device Stage-Of-Life Definition")
 311     (show-option-help *cli-device-stage-of-life-options*)
 312     (show-help-headline "Put An End To A Device's Stage-Of-Life")
 313     (show-option-help *cli-device-stage-of-life-end-options*)
 314     (show-help-headline "Camera Calibration Parameters")
 315     (show-option-help *cli-camera-calibration-options*)
 316     (show-help-headline "Store Measure Data")
 317     (show-option-help *cli-store-images-and-points-options*)
 318     (show-help-headline "Become A HTTP Presentation Server")
 319     (show-option-help *cli-start-server-options*)
 320     (show-help-headline "Manage Presentation Projects")
 321     (show-option-help *cli-presentation-project-options*)
 322     (show-help-headline "Manage Presentation Project Users")
 323     (show-option-help *cli-user-options*)))
 324
 325 (defun cli-version-action (&rest rest)
 326   "Print --version message."
 327   (declare (ignore rest))
 328   (process-command-line-options*)
 329   (case *verbose*
 330     (0
 331      (format
 332       *standard-output*
 333       "~&~A~&" (asdf:component-version (asdf:find-system :phoros))))
 334     (otherwise
 335      (format
 336       *standard-output*
 337       "~&~A version ~A~&  ~A version ~A~&  Proj4 library: ~A~&  Photogrammetry version ~A~&"
 338       (asdf:system-description (asdf:find-system :phoros))
 339       (asdf:component-version (asdf:find-system :phoros))
 340       (lisp-implementation-type) (lisp-implementation-version)
 341       (proj:version)
 342       (photogrammetrie:get-version-number)))))
 343
 344 (defun check-db-action (&rest rest)
 345   "Say `OK´ if database is accessible."
 346   (declare (ignore rest))
 347   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 348                             &allow-other-keys)
 349       (process-command-line-options *cli-options* *command-line-arguments*)
 350     (when (check-db (list database user password host :port port
 351                           :use-ssl (s-sql:from-sql-name use-ssl)))
 352       (format *error-output* "~&OK~%"))))
 353
 354 (defun check-dependencies-action (&rest rest)
 355   "Say `OK´ if the necessary external dependencies are available."
 356   (declare (ignore rest))
 357   (handler-case
 358       (progn
 359         (geographic-to-utm 33 13 52) ;check cs2cs
 360         (del-all)                    ;check photogrammetry
 361         (initialize-leap-seconds)    ;check source of leap second info
 362         (format *error-output* "~&OK~%"))
 363     (error (e) (format *error-output* "~A~&" e))))
 364
 365 (defun nuke-all-tables-action (&rest rest)
 366   "Drop the bomb.  Ask for confirmation first."
 367   (declare (ignore rest))
 368   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 369                             log-dir &allow-other-keys)
 370       (process-command-line-options *cli-options* *command-line-arguments*)
 371     (launch-logger log-dir)
 372     (when (yes-or-no-p
 373            "You asked me to delete anything in database ~A at ~A:~D.  Proceed?"
 374            database host port)
 375       (with-connection (list database user password host :port port
 376                              :use-ssl (s-sql:from-sql-name use-ssl)) ; string to keyword
 377         (nuke-all-tables))
 378       (cl-log:log-message :db "Nuked database ~A at ~A:~D.  Back to square one!" database host port))))
 379
 380 (defun create-sys-tables-action (&rest rest)
 381   "Make a set of sys-* tables.  Ask for confirmation first."
 382   (declare (ignore rest))
 383   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 384                             log-dir &allow-other-keys)
 385       (process-command-line-options *cli-options* *command-line-arguments*)
 386     (launch-logger log-dir)
 387     (when (yes-or-no-p
 388            "You asked me to create a set of sys-* tables in database ~A at ~A:~D.  Make sure you know what you are doing.  Proceed?"
 389            database host port)
 390       (with-connection (list database user password host :port port
 391                              :use-ssl (s-sql:from-sql-name use-ssl))
 392         (create-sys-tables))
 393       (cl-log:log-message
 394        :db-sys "Created a fresh set of system tables in database ~A at ~A:~D."
 395        database host port))))
 396
 397 (defun create-acquisition-project-action (common-table-name)
 398   "Make a set of data tables."
 399   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 400                             log-dir &allow-other-keys)
 401       (process-command-line-options *cli-options* *command-line-arguments*)
 402     (launch-logger log-dir)
 403     (with-connection (list database user password host :port port
 404                            :use-ssl (s-sql:from-sql-name use-ssl))
 405       (create-acquisition-project common-table-name))
 406     (cl-log:log-message
 407      :db-dat
 408      "Created a fresh acquisition project by the name of ~A in database ~A at ~A:~D."
 409      common-table-name database host port)))
 410
 411 (defun store-images-and-points-action (common-table-name)
 412   "Put data into the data tables."
 413   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 414                             log-dir
 415                             directory epsilon common-root aggregate-events
 416                             &allow-other-keys)
 417       (process-command-line-options *cli-options* *command-line-arguments*)
 418     (launch-logger log-dir)
 419     (with-connection (list database user password host :port port
 420                            :use-ssl (s-sql:from-sql-name use-ssl))
 421       (cl-log:log-message
 422        :db-dat
 423        "Start: storing data from ~A into acquisition project ~A in database ~A at ~A:~D."
 424        directory common-table-name database host port)
 425       (store-images-and-points common-table-name directory
 426                                :epsilon (read-from-string epsilon nil)
 427                                :root-dir common-root
 428                                :aggregate-events aggregate-events))
 429     (cl-log:log-message
 430      :db-dat
 431      "Finish: storing data from ~A into acquisition project ~A in database ~A at ~A:~D."
 432      directory common-table-name database host port)))
 433
 434 ;;; We don't seem to have two-dimensional arrays in postmodern
 435 ;;(defun canonicalize-bayer-pattern (raw &optional sql-string-p)
 436 ;;  "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."
 437 ;;  (when raw
 438 ;;    (let* ((array
 439 ;;            (loop
 440 ;;               for row in raw
 441 ;;               collect
 442 ;;               (loop
 443 ;;                  for hex-color in (cl-utilities:split-sequence #\, row)
 444 ;;                  collect
 445 ;;                  (let ((*read-base* 16))
 446 ;;                    (assert (eql (elt hex-color 0) #\#) () "~A is not a valid color" hex-color)
 447 ;;                    (read-from-string
 448 ;;                     (concatenate 'string
 449 ;;                                  (subseq hex-color 5 7)
 450 ;;                                  (subseq hex-color 3 5)
 451 ;;                                  (subseq hex-color 1 3))
 452 ;;                     nil)))))
 453 ;;           (rows (length array))
 454 ;;           (columns (length (elt array 0))))
 455 ;;      (if sql-string-p
 456 ;;          (format nil "{~{{~{~A~#^,~}}~}}" array)
 457 ;;          (make-array (list rows columns) :initial-contents array)))))
 458
 459 (defun canonicalize-bayer-pattern (raw &optional sql-string-p)
 460   "Convert a string of comma-separated hex color strings (ex: #ff0000
 461 for red) into a vector integers.  If sql-string-p is t, convert it
 462 into a string in SQL syntax."
 463   (when raw
 464     (let* ((vector
 465             (loop
 466                for hex-color in (cl-utilities:split-sequence #\, raw)
 467                collect
 468                  (let ((*read-base* 16))
 469                    (assert (eql (elt hex-color 0) #\#)
 470                            () "~A is not a valid color" hex-color)
 471                    (read-from-string
 472                     (concatenate 'string
 473                                  (subseq hex-color 5 7)
 474                                  (subseq hex-color 3 5)
 475                                  (subseq hex-color 1 3))
 476                     nil))))
 477            (columns (length vector)))
 478       (if sql-string-p
 479           (format nil "{~{~A~#^,~}}" vector)
 480           (make-array (list columns) :initial-contents vector)))))
 481
 482 (defun canonicalize-color-raiser (raw &optional sql-string-p)
 483   "Convert string of comma-separated numbers into a vector.  If
 484 sql-string-p is t, convert it into a string in SQL syntax."
 485   (when raw
 486     (let* ((vector
 487             (loop
 488                for multiplier in (cl-utilities:split-sequence #\, raw :count 3)
 489                collect
 490                (read-from-string multiplier nil))))
 491       (if sql-string-p
 492           (format nil "{~{~A~#^,~}}" vector)
 493           (make-array '(3) :initial-contents vector)))))
 494
 495 (defun store-stuff (store-function)
 496   "Open database connection and call store-function on command line
 497 options.  Print return values to *standard-output*.  store-function
 498 should only take keyargs."
 499   (let ((command-line-options
 500          (process-command-line-options *cli-options* *command-line-arguments*)))
 501     (setf (getf command-line-options :bayer-pattern)
 502           (canonicalize-bayer-pattern
 503            (getf command-line-options :raw-bayer-pattern) t)
 504           (getf command-line-options :color-raiser)
 505           (canonicalize-color-raiser
 506            (getf command-line-options :raw-color-raiser) t))
 507     (destructuring-bind (&key host port database (user "") (password "") use-ssl
 508                               log-dir &allow-other-keys)
 509         command-line-options
 510       (launch-logger log-dir)
 511       (with-connection (list database user password host :port port
 512                              :use-ssl (s-sql:from-sql-name use-ssl))
 513         (format *standard-output* "~&~{~D~#^ ~}~%"
 514                 (multiple-value-list
 515                  (apply store-function :allow-other-keys t
 516                         command-line-options)))))))
 517
 518 (defun store-camera-hardware-action (&rest rest)
 519   (declare (ignore rest))
 520   (store-stuff #'store-camera-hardware))
 521
 522 (defun store-lens-action (&rest rest)
 523   (declare (ignore rest))
 524   (store-stuff #'store-lens))
 525
 526 (defun store-generic-device-action (&rest rest)
 527   (declare (ignore rest))
 528   (store-stuff #'store-generic-device))
 529
 530 (defun store-device-stage-of-life-action (&rest rest)
 531   (declare (ignore rest))
 532   (store-stuff #'store-device-stage-of-life))
 533
 534 (defun store-device-stage-of-life-end-action (&rest rest)
 535   (declare (ignore rest))
 536   (store-stuff #'store-device-stage-of-life-end))
 537
 538 (defun store-camera-calibration-action (&rest rest)
 539   (declare (ignore rest))
 540   (store-stuff #'store-camera-calibration))
 541
 542 (defun get-image-action (&rest rest)
 543   "Output a PNG file extracted from a .pictures file; print its
 544 trigger-time to stdout."
 545   (declare (ignore rest))
 546   (destructuring-bind (&key count byte-position in out
 547                             raw-bayer-pattern raw-color-raiser
 548                             &allow-other-keys)
 549       (process-command-line-options *cli-options* *command-line-arguments*)
 550     (with-open-file (out-stream out :direction :output
 551                                 :element-type 'unsigned-byte
 552                                 :if-exists :supersede)
 553       (let ((trigger-time
 554              (if byte-position
 555                  (send-png out-stream in byte-position
 556                            :bayer-pattern
 557                            (canonicalize-bayer-pattern raw-bayer-pattern)
 558                            :color-raiser
 559                            (canonicalize-color-raiser raw-color-raiser))
 560                  (send-nth-png count out-stream in
 561                                :bayer-pattern
 562                                (canonicalize-bayer-pattern raw-bayer-pattern)
 563                                :color-raiser
 564                                (canonicalize-color-raiser raw-color-raiser)))))
 565         (format *standard-output*
 566                 "~&~A~%" (timestring (utc-from-unix trigger-time)))))))
 567
 568 (defun create-presentation-project-action (presentation-project-name)
 569   "Make a presentation project."
 570   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 571                             log-dir
 572                             &allow-other-keys)
 573       (process-command-line-options *cli-options* *command-line-arguments*)
 574     (launch-logger log-dir)
 575     (with-connection (list database user password host :port port
 576                            :use-ssl (s-sql:from-sql-name use-ssl))
 577       (let ((fresh-project-p
 578              (create-presentation-project presentation-project-name)))
 579         (cl-log:log-message
 580          :db-dat
 581          "~:[Tried to recreate an existing~;Created a fresh~] presentation project by the name of ~A in database ~A at ~A:~D."
 582          fresh-project-p presentation-project-name database host port)))))
 583
 584 (defun delete-presentation-project-action (presentation-project-name)
 585   "Delete a presentation project."
 586   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 587                             log-dir
 588                             &allow-other-keys)
 589       (process-command-line-options *cli-options* *command-line-arguments*)
 590     (launch-logger log-dir)
 591     (with-connection (list database user password host :port port
 592                            :use-ssl (s-sql:from-sql-name use-ssl))
 593       (let ((project-did-exist-p
 594              (delete-presentation-project presentation-project-name)))
 595         (cl-log:log-message
 596          :db-dat
 597          "~:[Tried to delete nonexistent~;Deleted~] presentation project ~A from database ~A at ~A:~D."
 598          project-did-exist-p presentation-project-name database host port)))))
 599
 600 (defun add-to-presentation-project-action (presentation-project-name)
 601   "Add measurements to a presentation project."
 602     (destructuring-bind (&key host port database (user "") (password "") use-ssl
 603                               log-dir
 604                               measurement-id acquisition-project
 605                               &allow-other-keys)
 606         (process-command-line-options *cli-options* *command-line-arguments*)
 607       (launch-logger log-dir)
 608       (with-connection (list database user password host :port port
 609                              :use-ssl (s-sql:from-sql-name use-ssl))
 610         (add-to-presentation-project presentation-project-name
 611                                      :measurement-ids measurement-id
 612                                      :acquisition-project acquisition-project))
 613       (cl-log:log-message
 614        :db-dat
 615        "Added ~@[measurement-ids ~{~D~#^, ~}~]~@[all measurements from acquisition project ~A~] to presentation project ~A in database ~A at ~A:~D."
 616        measurement-id acquisition-project
 617        presentation-project-name database host port)))
 618
 619 (defun remove-from-presentation-project-action (presentation-project-name)
 620   "Add measurements to a presentation project."
 621   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 622                             log-dir
 623                             measurement-id acquisition-project
 624                             &allow-other-keys)
 625       (process-command-line-options *cli-options* *command-line-arguments*)
 626     (launch-logger log-dir)
 627     (with-connection (list database user password host :port port
 628                            :use-ssl (s-sql:from-sql-name use-ssl))
 629       (remove-from-presentation-project presentation-project-name
 630                                    :measurement-ids measurement-id
 631                                    :acquisition-project acquisition-project))
 632     (cl-log:log-message
 633      :db-dat
 634      "Removed ~@[measurement-ids ~{~D~#^, ~}~]~@[all measurements that belong to acquisition project ~A~] from presentation project ~A in database ~A at ~A:~D."
 635      measurement-id acquisition-project
 636      presentation-project-name database host port)))
 637
 638 (defun create-user-action (presentation-project-user)
 639   "Define a new user."
 640   (let (fresh-user-p)
 641     (destructuring-bind (&key host port database (user "") (password "") use-ssl
 642                               log-dir
 643                               user-password user-full-name presentation-project
 644                               &allow-other-keys)
 645         (process-command-line-options *cli-options* *command-line-arguments*)
 646       (launch-logger log-dir)
 647       (with-connection (list database user password host :port port
 648                              :use-ssl (s-sql:from-sql-name use-ssl))
 649         (setf fresh-user-p (create-user presentation-project-user :password user-password :full-name user-full-name :presentation-projects presentation-project)))
 650       (cl-log:log-message
 651        :db-dat ;TODO: We're listing nonexistent p-projects here as well.
 652        "~:[Updated~;Created~] user ~A (~A) who has access to ~:[no ~;~]presentation project(s)~:*~{ ~A~#^,~} in database ~A at ~A:~D."
 653        fresh-user-p presentation-project-user user-full-name presentation-project database host port))))
 654
 655 (defun delete-user-action (presentation-project-user)
 656   "Delete a presentation project user."
 657   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 658                             log-dir
 659                             &allow-other-keys)
 660       (process-command-line-options *cli-options* *command-line-arguments*)
 661     (launch-logger log-dir)
 662     (with-connection (list database user password host :port port
 663                            :use-ssl (s-sql:from-sql-name use-ssl))
 664       (let ((user-did-exist-p
 665              (delete-user presentation-project-user)))
 666         (cl-log:log-message
 667          :db-dat
 668          "~:[Tried to delete nonexistent~;Deleted~] presentation project user ~A from database ~A at ~A:~D."
 669          user-did-exist-p presentation-project-user database host port)))))
 670
 671 (defun list-user-action (&optional presentation-project-user)
 672   "List presentation project users together with their presentation
 673 projects."
 674   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 675                             &allow-other-keys)
 676       (process-command-line-options *cli-options* *command-line-arguments*)
 677     (with-connection (list database user password host :port port
 678                            :use-ssl (s-sql:from-sql-name use-ssl))
 679       (let ((content
 680              (if (stringp presentation-project-user)
 681                  (query
 682                   (:order-by
 683                    (:select
 684                     'user-name 'sys-user.user-id 'user-password
 685                     'user-full-name 'presentation-project-name
 686                     'sys-user-role.presentation-project-id
 687                     :from 'sys-user 'sys-user-role 'sys-presentation-project
 688                     :where (:and (:= 'sys-user-role.presentation-project-id
 689                                      'sys-presentation-project.presentation-project-id)
 690                                  (:= 'sys-user.user-id 'sys-user-role.user-id)
 691                                  (:= 'user-name presentation-project-user)))
 692                    'user-name))
 693                  (query
 694                   (:order-by
 695                    (:select
 696                     'user-name 'sys-user.user-id 'user-password
 697                     'user-full-name 'presentation-project-name
 698                     'sys-user-role.presentation-project-id
 699                     :from 'sys-user 'sys-user-role 'sys-presentation-project
 700                     :where (:and (:= 'sys-user-role.presentation-project-id
 701                                      'sys-presentation-project.presentation-project-id)
 702                                  (:= 'sys-user.user-id 'sys-user-role.user-id)))
 703                    'user-name)))))
 704         (format-table *standard-output* " | " content
 705                       "User" "ID" "Password" "Full Name" "Presentation Project" "ID")))))
 706
 707 (defun list-presentation-project-action (&optional presentation-project)
 708   "List content of presentation projects."
 709   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 710                             &allow-other-keys)
 711       (process-command-line-options *cli-options* *command-line-arguments*)
 712     (with-connection (list database user password host :port port
 713                            :use-ssl (s-sql:from-sql-name use-ssl))
 714       (let ((content
 715              (if (stringp presentation-project)
 716                  (query
 717                   (:order-by
 718                    (:select
 719                     'presentation-project-name
 720                     'sys-presentation-project.presentation-project-id
 721                     'sys-presentation.measurement-id
 722                     'common-table-name
 723                     'sys-measurement.acquisition-project-id
 724                     :from
 725                     'sys-presentation-project 'sys-presentation
 726                     'sys-measurement 'sys-acquisition-project
 727                     :where (:and (:= 'sys-presentation-project.presentation-project-id
 728                                      'sys-presentation.presentation-project-id)
 729                                  (:= 'sys-presentation.measurement-id
 730                                      'sys-measurement.measurement-id)
 731                                  (:= 'sys-measurement.acquisition-project-id
 732                                      'sys-acquisition-project.acquisition-project-id)
 733                                  (:= 'presentation-project-name presentation-project)))
 734                    'presentation-project-name 'sys-presentation.measurement-id))
 735                  (query
 736                   (:order-by
 737                    (:select
 738                     'presentation-project-name
 739                     'sys-presentation-project.presentation-project-id
 740                     'sys-presentation.measurement-id
 741                     'common-table-name
 742                     'sys-measurement.acquisition-project-id
 743                     :from
 744                     'sys-presentation-project 'sys-presentation
 745                     'sys-measurement 'sys-acquisition-project
 746                     :where (:and (:= 'sys-presentation-project.presentation-project-id
 747                                      'sys-presentation.presentation-project-id)
 748                                  (:= 'sys-presentation.measurement-id
 749                                      'sys-measurement.measurement-id)
 750                                  (:= 'sys-measurement.acquisition-project-id
 751                                      'sys-acquisition-project.acquisition-project-id)))
 752                    'presentation-project-name 'sys-presentation.measurement-id)))))
 753         (format-table *standard-output* " | " content
 754                       "Presentation Project" "ID" "Meas. ID" "Acquisition Project" "ID")))))
 755
 756 (defun format-table (destination column-separator content &rest column-headers)
 757   "Print content (a list of lists) to destination."
 758   (let* ((rows
 759           (append (list column-headers) content))
 760          (number-of-rows (length column-headers))
 761          (widths
 762           (loop
 763              for column from 0 below number-of-rows collect
 764                (loop
 765                   for row in rows
 766                   maximize (length (format nil "~A" (nth column row)))))))
 767     (loop
 768        for row in rows do
 769          (format destination "~&~{~VA~1,#^~A~}~%"
 770                  (loop
 771                     for width in widths and field in row
 772                     collect width collect field collect column-separator)))))
 773
 774 (defun server-action (&rest rest)
 775   "Start the HTTP server."
 776   (declare (ignore rest))
 777   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 778                             log-dir
 779                             server-port common-root
 780                             &allow-other-keys)
 781       (process-command-line-options *cli-options* *command-line-arguments*)
 782     (launch-logger log-dir)
 783     (setf *postgresql-credentials*
 784           (list database user password host :port port
 785                 :use-ssl (s-sql:from-sql-name use-ssl)))
 786     (start-server :server-port server-port :common-root common-root)
 787     (cl-log:log-message
 788      :server
 789      "HTTP server listens on port ~D.  Database is ~A on ~A:~D.  Files are searched for in ~A."
 790      server-port database host port common-root)
 791     (loop (sleep 10))))