1 ;;; PHOROS -- Photogrammetric Road Survey
2 ;;; Copyright (C) 2011, 2012, 2017 Bert Burgemeister
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.
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.
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.
21 (defun unqualified-symbol (symbol)
22 (cond ((keywordp symbol
) symbol
)
23 ((atom symbol
) (intern (string symbol
)))
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
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
37 (append (subseq lambda-list
0 mandatory-key-position
)
38 (unless (position '&key lambda-list
)
42 `(,k
(error ,(format nil
"~A: argument ~A undefined"
45 (1+ mandatory-key-position
)
47 (when after-key-position
48 (subseq lambda-list after-key-position
))))))
49 `(defun ,name
,(delete (unqualified-symbol '&mandatory-key
) lambda-list
)
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
60 (cl-postgres:*query-callback
*
61 #'(lambda (query-string clock-ticks
)
62 (setf ,query-milliseconds clock-ticks
)
63 (setf ,executed-query query-string
))))
66 (etypecase (car ',args
)
68 (typecase (caar ',args
)
70 (query (sql-compile ',(car args
))
72 (t ;function (supposedly) returning string
80 "[~A] Query ~S~& took ~F seconds and yielded~& ~A."
83 (/ ,query-milliseconds
1000)
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
90 ((database-connection-error
93 :warning
"Need to reconnect database due to the following error:~&~A."
94 (database-error-message err
))
95 (invoke-restart :reconnect
))))
101 (defmacro with-options
((&key log database aux-database tolerate-missing
)
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,
117 (assert (not (and database aux-database
)) ()
118 "Can't handle connection to both database and aux-database ~
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
)))))
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)
150 ((database-connection-error
153 :warning
"Need to reconnect database due to the following error:~&~A."
154 (database-error-message err
))
155 (invoke-restart :reconnect
))))
160 `((launch-logger ,(unqualified-symbol 'log-dir
))
163 `(with-context (make-context)
165 for option in
(remove-duplicates options
)
166 if
(symbolp option
) collect
169 `(getopt :long-name
,(string-downcase option
))
170 `(getopt-mandatory ,(string-downcase option
))))
174 for i
= ,(if tolerate-missing
175 `(getopt :long-name
,(string-downcase
177 `(getopt-mandatory ,(string-downcase
179 then
(getopt :long-name
,(string-downcase
181 while i collect i
))))