util.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 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 (in-package :phoros)
  20
  21 (defmacro defun* (name lambda-list &body body)
  22   "Like defun, define a function, but with an additional lambda list
  23 keyword &mandatory-key which goes after the &key section or in place
  24 of it.  &mandatory-key argument definitions are plain symbols (no
  25 lists).  An error is signalled on function calls where one of those
  26 keyargs is missing."
  27   (let ((mandatory-key-position (position '&mandatory-key lambda-list))
  28         (after-key-position (or (position '&allow-other-keys lambda-list)
  29                                 (position '&aux lambda-list))))
  30     (when mandatory-key-position
  31       (setf lambda-list
  32             (append (subseq lambda-list 0 mandatory-key-position)
  33                     (unless (position '&key lambda-list)
  34                       '(&key))
  35                     (mapcar
  36                      #'(lambda (k)
  37                          `(,k (error ,(format nil "~A: argument ~A undefined"
  38                                               name k))))
  39                      (subseq lambda-list
  40                              (1+ mandatory-key-position)
  41                              after-key-position))
  42                     (when after-key-position
  43                       (subseq lambda-list after-key-position))))))
  44   `(defun ,name ,(delete (intern (string '&mandatory-key)) lambda-list)
  45      ,@body))
  46
  47 (defmacro logged-query (message-tag &rest args)
  48   "Act like postmodern:query; additionally log some debug information
  49 tagged by the short string message-tag."
  50   (cl-utilities:with-unique-names
  51       (executed-query query-milliseconds query-result)
  52     `(let* (,executed-query
  53             ,query-milliseconds
  54             ,query-result
  55             (cl-postgres:*query-callback*
  56              #'(lambda (query-string clock-ticks)
  57                  (setf ,query-milliseconds clock-ticks)
  58                  (setf ,executed-query query-string))))
  59        (prog1
  60            (setf ,query-result
  61                  (etypecase (car ',args)
  62                    (list
  63                     (typecase (caar ',args)
  64                       (keyword          ;s-sql form
  65                        (query (sql-compile ',(car args))
  66                               ,@(cdr args)))
  67                       (t       ;function (supposedly) returning string
  68                        (query ,@args))))
  69                    (string
  70                     (query ,@args))
  71                    (symbol
  72                     (query ,@args))))
  73          (cl-log:log-message
  74           :sql
  75           "[~A] Query ~S~& took ~F seconds and yielded~& ~A."
  76           ,message-tag
  77           ,executed-query
  78           (/ ,query-milliseconds 1000)
  79           ,query-result)))))
  80
  81 (defmacro cli:with-options ((&key log database aux-database tolerate-missing)
  82                             (&rest options)
  83                             &body body
  84                             &aux postgresql-credentials)
  85   "Evaluate body with options bound to the values of the respective
  86 command line arguments.  Signal error if tolerate-missing is nil and a
  87 command line argument doesn't have a value.  Elements of options may
  88 be symbols named according to the :long-name argument of the option,
  89 or lists shaped like (symbol) which bind symbol to a list of values
  90 collected for multiple occurence of that option.  If log is t, start
  91 logging first.  If database or aux-database are t, evaluate body with
  92 the appropriate database connection(s) and bind the following
  93 additional variables to the values of the respective command line
  94 arguments: host, port, database, user, password, use-ssl; and/or
  95 aux-host, aux-port, aux-database, aux-user, aux-password,
  96 aux-use-ssl."
  97   (assert (not (and database aux-database)) ()
  98           "Can't handle connection to both database and aux-database ~
  99           at the same time.")
 100   (when database
 101     (setf options
 102           (append options '(host port database user password use-ssl)))
 103     (setf postgresql-credentials
 104           '(list database user password host :port port
 105             :use-ssl (s-sql:from-sql-name use-ssl))))
 106   (when aux-database
 107     (setf options
 108           (append options '(aux-host aux-port aux-database
 109                             aux-user aux-password aux-use-ssl)))
 110     (setf postgresql-credentials
 111           '(list aux-database aux-user aux-password aux-host :port aux-port
 112             :use-ssl (s-sql:from-sql-name aux-use-ssl))))
 113   (when log (setf options (append options '(log-dir))))
 114   (let* ((db-connected-body
 115           (if (or database aux-database)
 116               `((with-connection ,postgresql-credentials
 117                   (muffle-postgresql-warnings)
 118                   ,@body))
 119               body))
 120          (logged-body
 121           (if log
 122               `((launch-logger log-dir)
 123                 ,@db-connected-body)
 124               db-connected-body)))
 125     `(cli:with-context (cli:make-context)
 126        (let (,@(loop
 127                   for option in (remove-duplicates options)
 128                   if (symbolp option) collect
 129                     (list option
 130                           (if tolerate-missing
 131                               `(cli:getopt :long-name ,(string-downcase option))
 132                               `(cli:getopt-mandatory ,(string-downcase option))))
 133                   else collect
 134                   `(,(car option)
 135                      (loop
 136                         for i = ,(if tolerate-missing
 137                                      `(cli:getopt :long-name ,(string-downcase
 138                                                                (car option)))
 139                                      `(cli:getopt-mandatory ,(string-downcase
 140                                                             (car option))))
 141                         then (cli:getopt :long-name ,(string-downcase
 142                                                       (car option)))
 143                         while i collect i))))
 144          ,@logged-body))))