util.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2011, 2012, 2017 Bert Burgemeister
   3 ;;;
   4 ;;; This program is free software; you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation; either version 2 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License along
  15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
  16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17
  18
  19 (in-package :phoros)
  20
  21 (defun unqualified-symbol (symbol)
  22   (cond ((keywordp symbol) symbol)
  23         ((atom symbol) (intern (string symbol)))
  24         (t symbol)))
  25
  26 (defmacro defun* (name lambda-list &body body)
  27   "Like defun, define a function, but with an additional lambda list
  28 keyword &mandatory-key which goes after the &key section or in place
  29 of it.  &mandatory-key argument definitions are plain symbols (no
  30 lists).  An error is signalled on function calls where one of those
  31 keyargs is missing."
  32   (let ((mandatory-key-position (position '&mandatory-key lambda-list))
  33         (after-key-position (or (position '&allow-other-keys lambda-list)
  34                                 (position '&aux lambda-list))))
  35     (when mandatory-key-position
  36       (setf lambda-list
  37             (append (subseq lambda-list 0 mandatory-key-position)
  38                     (unless (position '&key lambda-list)
  39                       '(&key))
  40                     (mapcar
  41                      #'(lambda (k)
  42                          `(,k (error ,(format nil "~A: argument ~A undefined"
  43                                               name k))))
  44                      (subseq lambda-list
  45                              (1+ mandatory-key-position)
  46                              after-key-position))
  47                     (when after-key-position
  48                       (subseq lambda-list after-key-position))))))
  49   `(defun ,name ,(delete (unqualified-symbol '&mandatory-key) lambda-list)
  50      ,@body))
  51
  52 (defmacro logged-query (message-tag &rest args)
  53   "Act like postmodern:query; additionally log some debug information
  54 tagged by the short string message-tag."
  55   (cl-utilities:with-unique-names
  56       (executed-query query-milliseconds query-result)
  57     `(let* (,executed-query
  58             ,query-milliseconds
  59             ,query-result
  60             (cl-postgres:*query-callback*
  61              #'(lambda (query-string clock-ticks)
  62                  (setf ,query-milliseconds clock-ticks)
  63                  (setf ,executed-query query-string))))
  64        (prog1
  65            (setf ,query-result
  66                  (etypecase (car ',args)
  67                    (list
  68                     (typecase (caar ',args)
  69                       (keyword          ;s-sql form
  70                        (query (sql-compile ',(car args))
  71                               ,@(cdr args)))
  72                       (t       ;function (supposedly) returning string
  73                        (query ,@args))))
  74                    (string
  75                     (query ,@args))
  76                    (symbol
  77                     (query ,@args))))
  78          (cl-log:log-message
  79           :sql
  80           "[~A] Query ~S~& took ~F seconds and yielded~& ~A."
  81           ,message-tag
  82           ,executed-query
  83           (/ ,query-milliseconds 1000)
  84           ,query-result)))))
  85
  86 (defmacro with-restarting-connection (postgresql-credentials &body body)
  87   "Act like with-connection, but reconnect on database-reconnection-error"
  88   `(with-connection ,postgresql-credentials
  89      (handler-bind
  90          ((database-connection-error
  91            (lambda (err)
  92              (cl-log:log-message
  93               :warning "Need to reconnect database due to the following error:~&~A."
  94               (database-error-message err))
  95              (invoke-restart :reconnect))))
  96        ,@body)))
  97
  98
  99 (in-package :cli)
 100
 101 (defmacro with-options ((&key log database aux-database tolerate-missing)
 102                         (&rest options)
 103                         &body body
 104                         &aux postgresql-credentials)
 105   "Evaluate body with options bound to the values of the respective
 106 command line arguments.  Signal error if tolerate-missing is nil and a
 107 command line argument doesn't have a value.  Elements of options may
 108 be symbols named according to the :long-name argument of the option,
 109 or lists shaped like (symbol) which bind symbol to a list of values
 110 collected for multiple occurence of that option.  If log is t, start
 111 logging first.  If database or aux-database are t, evaluate body with
 112 the appropriate database connection(s) and bind the following
 113 additional variables to the values of the respective command line
 114 arguments: host, port, database, user, password, use-ssl; and/or
 115 aux-host, aux-port, aux-database, aux-user, aux-password,
 116 aux-use-ssl."
 117   (assert (not (and database aux-database)) ()
 118           "Can't handle connection to both database and aux-database ~
 119           at the same time.")
 120   (when database
 121     (setf options
 122           (append options '(host port database user password use-ssl)))
 123     (setf postgresql-credentials
 124           `(list ,(unqualified-symbol 'database)
 125                  ,(unqualified-symbol 'user)
 126                  ,(unqualified-symbol 'password)
 127                  ,(unqualified-symbol 'host)
 128                  :port ,(unqualified-symbol 'port)
 129                  :use-ssl (s-sql:from-sql-name
 130                            ,(unqualified-symbol 'use-ssl)))))
 131   (when aux-database
 132     (setf options
 133           (append options '(aux-host aux-port aux-database
 134                             aux-user aux-password aux-use-ssl)))
 135     (setf postgresql-credentials
 136           `(list ,(unqualified-symbol 'aux-database)
 137                  ,(unqualified-symbol 'aux-user)
 138                  ,(unqualified-symbol ' aux-password)
 139                  ,(unqualified-symbol 'aux-host)
 140                  :port ,(unqualified-symbol 'aux-port)
 141                  :use-ssl (s-sql:from-sql-name
 142                            ,(unqualified-symbol 'aux-use-ssl)))))
 143   (when log (setf options (append options '(log-dir))))
 144   (setf options (mapcar #'unqualified-symbol options))
 145   (let* ((db-connected-body
 146           (if (or database aux-database)
 147               `((with-connection ,postgresql-credentials
 148                   (muffle-postgresql-warnings)
 149                   (handler-bind
 150                       ((database-connection-error
 151                         (lambda (err)
 152                           (cl-log:log-message
 153                            :warning "Need to reconnect database due to the following error:~&~A."
 154                            (database-error-message err))
 155                           (invoke-restart :reconnect))))
 156                     ,@body)))
 157               body))
 158          (logged-body
 159           (if log
 160               `((launch-logger ,(unqualified-symbol 'log-dir))
 161                 ,@db-connected-body)
 162               db-connected-body)))
 163     `(with-context (make-context)
 164        (let (,@(loop
 165                   for option in (remove-duplicates options)
 166                   if (symbolp option) collect
 167                   (list option
 168                         (if tolerate-missing
 169                             `(getopt :long-name ,(string-downcase option))
 170                             `(getopt-mandatory ,(string-downcase option))))
 171                   else collect
 172                   `(,(car option)
 173                      (loop
 174                         for i = ,(if tolerate-missing
 175                                      `(getopt :long-name ,(string-downcase
 176                                                            (car option)))
 177                                      `(getopt-mandatory ,(string-downcase
 178                                                           (car option))))
 179                         then (getopt :long-name ,(string-downcase
 180                                                   (car option)))
 181                         while i collect i))))
 182          ,@logged-body))))