cli.lisp

   1 ;;;; UNIX command line interface
   2
   3 (in-package :phoros)
   4
   5 (defparameter *cli-main-options*
   6   '((("help" #\h) :action #'cli-help-action  :documentation "Print this help and exit.")
   7     ("version" :action #'cli-version-action :documentation "Output version information and exit.")
   8     ("verbose" :type integer :initial-value 0 :documentation "Emit increasing amounts of debugging output.")
   9     ("log-dir" :type string :initial-value "" :documentation "Where to put the log files.")
  10     ("check-db" :action #'check-db-action :documentation "Check database connection and exit.")
  11     ("nuke-all-tables" :action #'nuke-all-tables-action :documentation "Ask for confirmation, then delete anything in database and exit.")
  12     ("create-sys-tables" :action #'create-sys-tables-action :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.")
  13     ("create-acquisition-project" :type string :action #'create-acquisition-project-action :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.")))
  14
  15 (defparameter *cli-db-connection-options*
  16   '((("host" #\H) :type string :initial-value "localhost" :documentation "Database server.")
  17     (("port" #\P) :type integer :initial-value 5432 :documentation "Port on database server.")
  18     (("database" #\D) :type string :initial-value "phoros" :documentation "Name of database.")
  19     (("user" #\U) :type string :documentation "Database user.")
  20     (("password" #\W) :type string :documentation "Database user's password.")
  21     ("use-ssl" :type string :initial-value "no" :documentation "Use SSL in database connection. [yes|no|try]")))
  22
  23 (defparameter *cli-get-image-options*
  24   '(("get-image" :action #'get-image-action :documentation "Get a single image from a .pictures file, print its trigger-time to stdout, and exit.")
  25     ("count" :type integer :initial-value 0 :documentation "Image number in .pictures file.")
  26     ("byte-position" :type integer :documentation "Byte position of image in .pictures file.")
  27     ("in" :type string :documentation "Path to .pictures file.")
  28     ("out" :type string :initial-value "phoros-get-image.png" :documentation "Path to to output .png file.")
  29     ;; The way it should be had we two-dimensional arrays in postmodern:
  30     ;;("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.")
  31     ("bayer-pattern" :type string :optional t :action :raw-bayer-pattern :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.")))
  32
  33 (defparameter *cli-camera-hardware-options*
  34   '(("store-camera-hardware" :action #'store-camera-hardware-action :documentation "Put new camera-hardware data into the database; print camera-hardware-id to stdout.")
  35     ("sensor-width-pix" :type integer :documentation "Width of camera sensor.")
  36     ("sensor-height-pix" :type integer :documentation "Height of camera sensor.")
  37     ("pix-size" :type string :documentation "Camera pixel size in millimetres (float).")
  38     ("channels" :type integer :documentation "Number of color channels")
  39     ("pix-depth" :type integer :initial-value 255 :documentation "Greatest possible pixel value.")
  40     ("color-raiser" :type string :initial-value "1,1,1" :action :raw-color-raiser :documentation "Multipliers for the individual color components.  Example: 1.2,1,.8 multiplies red by 1.2 and blue by 0.8.")
  41     ;; The way it should be had we two-dimensional arrays in postmodern:
  42     ;;("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.")
  43     ("bayer-pattern" :type string :optional t :action :raw-bayer-pattern :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.")
  44     ("serial-number" :type string :documentation "Serial number.")
  45     ("description" :type string :documentation "Description of camera.")
  46     ("try-overwrite" :type boolean :initial-value "yes" :documentation "Overwrite matching camera-hardware record if any.")))
  47
  48 (defparameter *cli-lens-options*
  49   '(("store-lens" :action #'store-lens-action :documentation "Put new lens data into the database; print lens-id to stdout.")
  50     ("c" :type string :documentation "Nominal focal length in millimetres.")
  51     ("serial-number" :type string :documentation "Serial number.")
  52     ("description" :type string :documentation "Lens desription.")
  53     ("try-overwrite" :type boolean :initial-value "yes" :documentation "Overwrite matching lens record if any.")))
  54
  55 (defparameter *cli-generic-device-options*
  56   '(("store-generic-device" :action #'store-generic-device-action :documentation "Put a newly defined generic-device into the database; print generic-device-id to stdout.")
  57     ("camera-hardware-id" :type integer :documentation "Numeric camera hardware id in database.")
  58     ("lens-id" :type integer :documentation "Numeric lens id in database.")))
  59
  60 (defparameter *cli-device-stage-of-life-options*
  61   '(("store-device-stage-of-life" :action #'store-device-stage-of-life-action :documentation "Put a newly defined device-stage-of-life into the database; print device-stage-of-life-id to stdout.")
  62     ("recorded-device-id" :type string :documentation "Device id stored next to the measuring data.")
  63     ("event-number" :type string :documentation "GPS event that triggers this generic device.")
  64     ("generic-device-id" :type integer :documentation "Numeric generic-device id in database.")
  65     ("vehicle-name" :type string :documentation "Descriptive name of vehicle.")
  66     ("casing-name" :type string :documentation "Descriptive name of device casing.")
  67     ("computer-name" :type string :documentation "Name of the recording device.")
  68     ("computer-interface-name" :type string :documentation "Interface at device.")
  69     ("mounting-date" :type string :documentation "Time this device constellation became effective.  Format: `2010-11-19T13:49+01´.")))
  70
  71 (defparameter *cli-device-stage-of-life-end-options*
  72   '(("store-device-stage-of-life-end" :action #'store-device-stage-of-life-end-action :documentation "Put an end date to a device-stage-of-life in the database; print device-stage-of-life-id to stdout.")
  73     ("device-stage-of-life-id" :type string :documentation "Id of the device-stage-of-life to put to an end.")
  74     ("unmounting-date" :type string :documentation "Time this device constellation ceased to be effective.  Format: `2010-11-19T17:02+01´.")))
  75
  76 (defparameter *cli-camera-calibration-options*
  77   '(("store-camera-calibration" :action #'store-camera-calibration-action :documentation "Put new camera-calibration into the database; print generic-device-id and calibration date to stdout.")
  78     ("device-stage-of-life-id" :type string :documentation "This tells us what hardware this calibration is for.")
  79     ("date" :type string :documentation "Date of calibration.  Format: `2010-11-19T13:49+01´.")
  80     ("person" :type string :documentation "Person who did the calibration.")
  81     ("main-description" :type string :documentation "Regarding this entire set of calibration data")
  82     ("debug" :type string :documentation "If true: not for production use; may be altered or deleted at any time.")
  83     ("photogrammetry-version" :type string :documentation "Software version used to create this data.")
  84     ("mounting-angle" :type integer :documentation "Head up = 0; right ear up = 90; left ear up = -90; head down = 180.")
  85     ("inner-orientation-description" :type string :documentation "Comments regarding inner orientation calibration.")
  86     ("c" :type string :documentation "Inner orientation: focal length.")
  87     ("xh" :type string :documentation "Inner orientation: principal point displacement.")
  88     ("yh" :type string :documentation "Inner orientation: principal point displacement.")
  89     ("a1" :type string :documentation "Inner orientation: radial distortion.")
  90     ("a2" :type string :documentation "Inner orientation: radial distortion.")
  91     ("a3" :type string :documentation "Inner orientation: radial distortion.")
  92     ("b1" :type string :documentation "Inner orientation: asymmetric and tangential distortion.")
  93     ("b2" :type string :documentation "Inner orientation: asymmetric and tangential distortion.")
  94     ("c1" :type string :documentation "Inner orientation: affinity and shear distortion.")
  95     ("c2" :type string :documentation "Inner orientation: affinity and shear distortion.")
  96     ("r0" :type string :documentation "Inner orientation.")
  97     ("outer-orientation-description" :type string :documentation "Comments regarding outer orientation calibration.")
  98     ("dx" :type string :documentation "Outer orientation; in metres.")
  99     ("dy" :type string :documentation "Outer orientation; in metres.")
 100     ("dz" :type string :documentation "Outer orientation; in metres.")
 101     ("omega" :type string :documentation "Outer orientation.")
 102     ("phi" :type string :documentation "Outer orientation.")
 103     ("kappa" :type string :documentation "Outer orientation.")
 104     ("boresight-description" :type string :documentation "Comments regarding boresight alignment calibration.")
 105     ("b-dx" :type string :documentation "Boresight alignment.")
 106     ("b-dy" :type string :documentation "Boresight alignment.")
 107     ("b-dz" :type string :documentation "Boresight alignment.")
 108     ("b-ddx" :type string :documentation "Boresight alignment.")
 109     ("b-ddy" :type string :Documentation "Boresight alignment.")
 110     ("b-ddz" :type string :documentation "Boresight alignment.")
 111     ("b-rotx" :type string :documentation "Boresight alignment.")
 112     ("b-roty" :type string :documentation "Boresight alignment.")
 113     ("b-rotz" :type string :documentation "Boresight alignment.")
 114     ("b-drotx" :type string :documentation "Boresight alignment.")
 115     ("b-droty" :type string :documentation "Boresight alignment.")
 116     ("b-drotz" :type string :documentation "Boresight alignment.")
 117     ("nx" :type string :documentation "X component of unit vector of vehicle ground plane.")
 118     ("ny" :type string :documentation "Y component of unit vector of vehicle ground plane.")
 119     ("nz" :type string :documentation "Z component of unit vector of vehicle ground plane.")
 120     ("d" :type string :documentation "Distance of vehicle ground plane.")))
 121
 122 (defparameter *cli-store-images-and-points-options*
 123   '((("store-images-and-points" #\s) :type string :action #'store-images-and-points-action :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.")
 124     (("directory" #\d) :type string :documentation "Directory containing one set of measuring data.")
 125     (("common-root" #\r) :type string :documentation "The root part of directory that is equal for all pojects.  TODO: come up with some sensible default.")
 126     ("epsilon" :type string :initial-value ".001" :documentation "Difference in seconds below which two timestamps are considered equal.")))
 127
 128 (defparameter *cli-options* (append *cli-main-options* *cli-db-connection-options* *cli-get-image-options* *cli-camera-hardware-options* *cli-lens-options* *cli-generic-device-options* *cli-device-stage-of-life-options* *cli-device-stage-of-life-end-options* *cli-camera-calibration-options* *cli-store-images-and-points-options*))
 129
 130 (defun main ()
 131   "The UNIX command line entry point."
 132 ;;  (handler-bind ((serious-condition (lambda (c)
 133 ;;                                      (declare (ignore c))
 134 ;;                                      (sb-debug:backtrace))))
 135   (handler-case
 136       (command-line-arguments:compute-and-process-command-line-options *cli-options*)
 137     (serious-condition (c)
 138       (cl-log:log-message :warning "Cancelled: ~A" c)
 139       (format *error-output* "~A~&" c))))
 140
 141 (defun cli-help-action (&rest rest)
 142   "Print --help message."
 143   (declare (ignore rest))
 144   (let ((format-headline (formatter "~&~95,,,'#@<~A ~>")))
 145     (format *standard-output*
 146             "~&Usage: phoros [options] ...~&~A"
 147             (asdf:system-long-description (asdf:find-system :phoros)))
 148     (format *standard-output* format-headline "Main Options")
 149     (command-line-arguments:show-option-help *cli-main-options*)
 150     (format *standard-output* format-headline "Database Connection")
 151     (command-line-arguments:show-option-help *cli-db-connection-options*)
 152     (format *standard-output* format-headline "Examine .pictures File")
 153     (command-line-arguments:show-option-help *cli-get-image-options*)
 154     (format *standard-output* format-headline "Camera Hardware Parameters")
 155     (command-line-arguments:show-option-help *cli-camera-hardware-options*)
 156     (format *standard-output* format-headline "Lens Parameters")
 157     (command-line-arguments:show-option-help *cli-lens-options*)
 158     (format *standard-output* format-headline "Generic Device Definition")
 159     (command-line-arguments:show-option-help *cli-generic-device-options*)
 160     (format *standard-output* format-headline "Device Stage-Of-Life Definition")
 161     (command-line-arguments:show-option-help *cli-device-stage-of-life-options*)
 162     (format *standard-output* format-headline "Put An End To A Device's Stage-Of-Life")
 163     (command-line-arguments:show-option-help *cli-device-stage-of-life-end-options*)
 164     (format *standard-output* format-headline "Camera Calibration Parameters")
 165     (command-line-arguments:show-option-help *cli-camera-calibration-options*)
 166     (format *standard-output* format-headline "Store Measure Data")
 167     (command-line-arguments:show-option-help *cli-store-images-and-points-options*)))
 168
 169 (defun cli-version-action (&rest rest)
 170   "Print --version message."
 171   (declare (ignore rest))
 172   (format *standard-output* "~&~A ~A~%"
 173           (asdf:system-description (asdf:find-system :phoros))
 174           (asdf:component-version (asdf:find-system :phoros))))
 175
 176 (defun check-db-action (&rest rest)
 177   "Say `OK´ if database is accessible."
 178   (declare (ignore rest))
 179   (destructuring-bind (&key host port database (user "") (password "") use-ssl &allow-other-keys)
 180       (command-line-arguments:process-command-line-options *cli-options* command-line-arguments:*command-line-arguments*)
 181     (let (connection)
 182       (handler-case
 183           (setf
 184            connection
 185            (connect database user password host :port port
 186                     :use-ssl (s-sql:from-sql-name use-ssl))) ; string to keyword
 187         (error (e) (format *error-output* "~A~&" e)))
 188       (when connection
 189         (disconnect connection)
 190         (format *error-output* "~&OK~%")))))
 191
 192 (defun nuke-all-tables-action (&rest rest)
 193   "Drop the bomb.  Ask for confirmation first."
 194   (declare (ignore rest))
 195   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 196                             log-dir &allow-other-keys)
 197       (command-line-arguments:process-command-line-options *cli-options* command-line-arguments:*command-line-arguments*)
 198     (launch-logger log-dir)
 199     (when (yes-or-no-p "You asked me to delete anything in database ~A at ~A:~D.  Proceed?"
 200                        database host port)
 201       (with-connection (list database user password host :port port
 202                              :use-ssl (s-sql:from-sql-name use-ssl)) ; string to keyword
 203         (nuke-all-tables))
 204       (cl-log:log-message :db "Nuked database ~A at ~A:~D.  Back to square one!" database host port))))
 205
 206 (defun create-sys-tables-action (&rest rest)
 207   "Make a set of sys-* tables.  Ask for confirmation first."
 208   (declare (ignore rest))
 209   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 210                             log-dir &allow-other-keys)
 211       (command-line-arguments:process-command-line-options *cli-options* command-line-arguments:*command-line-arguments*)
 212     (launch-logger log-dir)
 213     (when (yes-or-no-p "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?"
 214                        database host port)
 215       (with-connection (list database user password host :port port
 216                              :use-ssl (s-sql:from-sql-name use-ssl)) ; string to keyword
 217         (create-sys-tables))
 218       (cl-log:log-message :db-sys "Created a fresh set of system tables in database ~A at ~A:~D." database host port))))
 219
 220 (defun create-acquisition-project-action (common-table-name)
 221   "Make a set of data tables."
 222   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 223                             log-dir &allow-other-keys)
 224       (command-line-arguments:process-command-line-options *cli-options* command-line-arguments:*command-line-arguments*)
 225     (launch-logger log-dir)
 226     (with-connection (list database user password host :port port
 227                            :use-ssl (s-sql:from-sql-name use-ssl))
 228       (create-acquisition-project common-table-name))
 229     (cl-log:log-message :db-dat "Created a fresh acquisition project by the name of ~A in database ~A at ~A:~D." common-table-name database host port)))
 230
 231 (defun store-images-and-points-action (common-table-name)
 232   "Put data into the data tables."
 233   (destructuring-bind (&key host port database (user "") (password "") use-ssl
 234                             log-dir
 235                             directory epsilon common-root &allow-other-keys)
 236       (command-line-arguments:process-command-line-options *cli-options* command-line-arguments:*command-line-arguments*)
 237     (launch-logger log-dir)
 238     (with-connection (list database user password host :port port
 239                            :use-ssl (s-sql:from-sql-name use-ssl))
 240       (cl-log:log-message :db-dat "Start: storing data from ~A into acquisition project ~A in database ~A at ~A:~D." directory common-table-name database host port)
 241       (store-images-and-points common-table-name directory
 242                                :epsilon (read-from-string epsilon nil)
 243                                :root-dir common-root))
 244     (cl-log:log-message :db-dat "Finish: storing data from ~A into acquisition project ~A in database ~A at ~A:~D." directory common-table-name database host port)))
 245
 246 ;;; We don't seem to have two-dimensional arrays in postmodern
 247 ;;(defun canonicalize-bayer-pattern (raw &optional sql-string-p)
 248 ;;  "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."
 249 ;;  (when raw
 250 ;;    (let* ((array
 251 ;;            (loop
 252 ;;               for row in raw
 253 ;;               collect
 254 ;;               (loop
 255 ;;                  for hex-color in (cl-utilities:split-sequence #\, row)
 256 ;;                  collect
 257 ;;                  (let ((*read-base* 16))
 258 ;;                    (assert (eql (elt hex-color 0) #\#) () "~A is not a valid color" hex-color)
 259 ;;                    (read-from-string
 260 ;;                     (concatenate 'string
 261 ;;                                  (subseq hex-color 5 7)
 262 ;;                                  (subseq hex-color 3 5)
 263 ;;                                  (subseq hex-color 1 3))
 264 ;;                     nil)))))
 265 ;;           (rows (length array))
 266 ;;           (columns (length (elt array 0))))
 267 ;;      (if sql-string-p
 268 ;;          (format nil "{~{{~{~A~#^,~}}~}}" array)
 269 ;;          (make-array (list rows columns) :initial-contents array)))))
 270
 271 (defun canonicalize-bayer-pattern (raw &optional sql-string-p)
 272   "Convert a string of comma-separated hex color strings (ex: #ff0000 for red) into a vector integers.  If sql-string-p is t, convert it into a string in SQL syntax."
 273   (when raw
 274     (let* ((vector
 275             (loop
 276                for hex-color in (cl-utilities:split-sequence #\, raw)
 277                collect
 278                  (let ((*read-base* 16))
 279                    (assert (eql (elt hex-color 0) #\#) () "~A is not a valid color" hex-color)
 280                    (read-from-string
 281                     (concatenate 'string
 282                                  (subseq hex-color 5 7)
 283                                  (subseq hex-color 3 5)
 284                                  (subseq hex-color 1 3))
 285                     nil))))
 286            (columns (length vector)))
 287       (if sql-string-p
 288           (format nil "{~{~A~#^,~}}" vector)
 289           (make-array (list columns) :initial-contents vector)))))
 290
 291 (defun canonicalize-color-raiser (raw &optional sql-string-p)
 292   "Convert string of comma-separated numbers into a vector.  If sql-string-p is t, convert it into a string in SQL syntax."
 293   (when raw
 294     (let* ((vector
 295             (loop
 296                for multiplier in (cl-utilities:split-sequence #\, raw :count 3)
 297                collect
 298                (read-from-string multiplier nil))))
 299       (if sql-string-p
 300           (format nil "{~{~A~#^,~}}" vector)
 301           (make-array '(3) :initial-contents vector)))))
 302
 303 (defun store-stuff (store-function)
 304   "Open database connection and call store-function on command line options.  Print return values to *standard-output*.  store-function should only take keyargs."
 305   (let ((command-line-options
 306          (command-line-arguments:process-command-line-options *cli-options* command-line-arguments:*command-line-arguments*)))
 307     (setf (getf command-line-options :bayer-pattern)
 308           (canonicalize-bayer-pattern (getf command-line-options :raw-bayer-pattern) t)
 309           (getf command-line-options :color-raiser)
 310           (canonicalize-color-raiser (getf command-line-options :raw-color-raiser) t))
 311     (destructuring-bind (&key host port database (user "") (password "") use-ssl
 312                               log-dir &allow-other-keys)
 313         command-line-options
 314       (launch-logger log-dir)
 315       (with-connection (list database user password host :port port
 316                              :use-ssl (s-sql:from-sql-name use-ssl))
 317         (format *standard-output* "~&~{~D~#^ ~}~%"
 318                 (multiple-value-list (apply store-function :allow-other-keys t command-line-options)))))))
 319
 320 (defun store-camera-hardware-action (&rest rest)
 321   (declare (ignore rest))
 322   (store-stuff #'store-camera-hardware))
 323
 324 (defun store-lens-action (&rest rest)
 325   (declare (ignore rest))
 326   (store-stuff #'store-lens))
 327
 328 (defun store-generic-device-action (&rest rest)
 329   (declare (ignore rest))
 330   (store-stuff #'store-generic-device))
 331
 332 (defun store-device-stage-of-life-action (&rest rest)
 333   (declare (ignore rest))
 334   (store-stuff #'store-device-stage-of-life))
 335
 336 (defun store-device-stage-of-life-end-action (&rest rest)
 337   (declare (ignore rest))
 338   (store-stuff #'store-device-stage-of-life-end))
 339
 340 (defun store-camera-calibration-action (&rest rest)
 341   (declare (ignore rest))
 342   (store-stuff #'store-camera-calibration))
 343
 344 (defun get-image-action (&rest rest)
 345   "Output a PNG file extracted from a .pictures file; print its trigger-time to stdout."
 346   (declare (ignore rest))
 347   (destructuring-bind (&key count byte-position in out raw-bayer-pattern raw-color-raiser &allow-other-keys)
 348       (command-line-arguments:process-command-line-options *cli-options* command-line-arguments:*command-line-arguments*)
 349     (with-open-file (out-stream out :direction :output :element-type 'unsigned-byte
 350                                 :if-exists :supersede)
 351       (let ((trigger-time
 352              (if byte-position
 353                  (send-png out-stream in byte-position :bayer-pattern (canonicalize-bayer-pattern raw-bayer-pattern) :color-raiser (canonicalize-color-raiser raw-color-raiser))
 354                  (send-nth-png count out-stream in :bayer-pattern (canonicalize-bayer-pattern raw-bayer-pattern) :color-raiser (canonicalize-color-raiser raw-color-raiser)))))
 355         (format *standard-output* "~&~A~%" (timestring (utc-from-unix trigger-time)))))))