cl-postgres/public.lisp

   1 ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES; -*-
   2 (in-package :cl-postgres)
   3
   4 (defgeneric connection-port (cl)
   5   (:method ((cl t)) nil))
   6
   7 (defgeneric connection-db (cl)
   8   (:method ((cl t)) nil))
   9
  10 (defgeneric connection-parameters (obj)
  11   (:documentation "This method returns a mapping (string to string) containing
  12 all the configuration parameters for the connection."))
  13
  14 (defclass database-connection ()
  15   ((host :initarg :host :reader connection-host)
  16    (port :initarg :port :reader connection-port)
  17    (database :initarg :db :reader connection-db)
  18    (user :initarg :user :reader connection-user)
  19    (password :initarg :password :reader connection-password)
  20    (use-ssl :initarg :ssl :reader connection-use-ssl)
  21    (use-binary :initarg :binary :accessor connection-use-binary :initform nil)
  22    (service :initarg :service :accessor connection-service)
  23    (application-name :initarg :application-name :accessor connection-application-name)
  24    (socket :initarg :socket :accessor connection-socket)
  25    (meta :initform nil)
  26    (available :initform t :accessor connection-available)
  27    (parameters :accessor connection-parameters)
  28    (timestamp-format :accessor connection-timestamp-format))
  29   (:default-initargs :application-name "postmodern-default")
  30   (:documentation "Representation of a database connection. Contains
  31 login information in order to be able to automatically re-establish a
  32 connection when it is somehow closed."))
  33
  34 (defun get-postgresql-version (connection)
  35   "Retrieves the version number of the connected postgresql database as a
  36 string. Some installations of Postgresql add additional information after the base
  37 version number, so hopefully this gets rid of the unwanted info."
  38   (first
  39    (split-sequence:split-sequence #\space
  40                                   (gethash "server_version"
  41                                            (connection-parameters connection)))))
  42
  43 (defun postgresql-version-at-least (desired-version connection)
  44   "Takes a postgresql version number which should be a string with the major and
  45 minor versions separated by a period e.g. '12.2' or '9.6.17'. Checks against the
  46 connection understanding of the running postgresql version and returns t if the
  47 running version is the requested version or newer."
  48   (when (numberp desired-version)
  49     (setf desired-version (write-to-string desired-version)))
  50   (flet ((validate-input (str)
  51            (unless (or (not (stringp desired-version))
  52                        (= 0 (length str)))
  53              (every (lambda (char)
  54                       (or (digit-char-p char)
  55                           (eq char #\.)))
  56                     str)))
  57          (string-version-to-integer-list (string-version)
  58            (mapcar #'parse-integer
  59                    (split-sequence:split-sequence #\.
  60                                                   string-version
  61                                                   :remove-empty-subseqs t)))
  62          (convert-to-integer (split-versions)
  63            (apply #'+
  64                   (loop for x in split-versions counting x into y collect
  65                                                                   (/ (* x 10000)
  66                                                                      (expt 100 y))))))
  67     (when (validate-input desired-version)
  68       (let ((current-version (string-version-to-integer-list
  69                               (get-postgresql-version connection))))
  70         (setf desired-version (string-version-to-integer-list desired-version))
  71         (when (>= (convert-to-integer current-version)
  72                   (convert-to-integer desired-version))
  73           t)))))
  74
  75 (defun connection-meta (connection)
  76   "This method provides access to a hash table that is associated with the
  77 current database connection, and is used to store information about the
  78 prepared statements that have been parsed for this connection."
  79   (or (slot-value connection 'meta)
  80       (let ((meta-data (make-hash-table :test 'equal)))
  81         (setf (slot-value connection 'meta) meta-data)
  82         meta-data)))
  83
  84 (defun connection-pid (connection)
  85   "Retrieves a list consisting of the pid and the secret-key from the
  86 connection, not from the database itself. These are needed for cancelling
  87 connections and error processing with respect to prepared statements."
  88   (list (gethash "pid" (slot-value connection 'parameters))
  89         (gethash "secret-key" (slot-value connection 'parameters))))
  90
  91 (defun use-binary-parameters (db-connection param)
  92   "Accepts a database connection and nil or t. The default for cl-postgres/Postmodern
  93 is pass parameters to Postgresql as text (not in binary format). This is how it has
  94 been since the beginning of Postmodern and the default is set this way in order to
  95 avoid breaking existing user code. You can set Postmodern to pass integer, float
  96 or boolean parameters to Postgresql in binary format on a connection basis when
  97 the connection is created or you can use this function to change the existing connection
  98 to use or not use binary parameter passing."
  99   (setf (connection-use-binary db-connection) param))
 100
 101 (defun database-open-p (connection)
 102   "Returns a boolean indicating whether the given connection is currently
 103 connected."
 104   (and (connection-socket connection)
 105        (open-stream-p (connection-socket connection))))
 106
 107 (defun open-database (database user password host
 108                       &optional (port 5432) (use-ssl :no)
 109                         (service "postgres") (application-name "postmodern-default")
 110                         (use-binary nil))
 111   "Create and open a connection for the specified server, database, and user.
 112 use-ssl may be :no, :try, :yes, or :full; where :try means 'if the server
 113 supports it'. :require uses provided ssl certificate with no verification.
 114 :yes only verifies that the server cert is issued by a trusted CA,
 115 but does not verify the server hostname. :full 'means expect a CA-signed cert
 116 for the supplied host name' and verify the server hostname. When it is anything
 117 but :no, you must have the CL+SSL package loaded to initiate the connection.
 118
 119 On SBCL and Clozure CL, the value :unix may be passed for host, in order to
 120 connect using a Unix domain socket instead of a TCP socket."
 121   (check-type database string)
 122   (check-type user string)
 123   (check-type password (or null string))
 124   (check-type host (or string (eql :unix)) "a string or :unix")
 125   (check-type port (integer 1 65535) "an integer from 1 to 65535")
 126   (check-type use-ssl (member :no :try :require :yes :full) ":no, :try, :require, :yes or :full")
 127   (let ((conn (make-instance 'database-connection :host host :port port
 128                                                   :user user :password password
 129                                                   :socket nil :db database
 130                                                   :ssl use-ssl
 131                                                   :binary use-binary
 132                                                   :service service
 133                                                   :application-name application-name))
 134         (connection-attempts 0))
 135     (initiate-connection conn connection-attempts)
 136     conn))
 137
 138 #+(and (or cl-postgres.features:sbcl-available ccl allegro) unix)
 139 (progn
 140   (defparameter *unix-socket-dir*
 141     #-(or freebsd darwin) "/var/run/postgresql/"
 142     #+(or darwin freebsd) "/tmp/"
 143     "Directory where the Unix domain socket for PostgreSQL be found.")
 144
 145   (defun unix-socket-path (base-dir port)
 146     (unless (char= #\/ (aref base-dir (1- (length base-dir))))
 147       (setf base-dir (concatenate 'string base-dir "/")))
 148     (format nil "~a.s.PGSQL.~a" base-dir port))
 149
 150   #+cl-postgres.features:sbcl-available
 151   (defun unix-socket-connect (path)
 152     (let ((sock (make-instance 'sb-bsd-sockets:local-socket :type :stream)))
 153       (sb-bsd-sockets:socket-connect sock path)
 154       (sb-bsd-sockets:socket-make-stream
 155        sock :input t :output t :element-type '(unsigned-byte 8))))
 156
 157   #+ccl (setf ccl:*default-socket-character-encoding* :utf-8)
 158   #+ccl
 159   (defun unix-socket-connect (path)
 160     (ccl:make-socket :type :stream
 161                      :address-family :file
 162                      :format :binary
 163                      :remote-filename path))
 164
 165   #+allegro
 166   (defun unix-socket-connect (path)
 167     (socket:make-socket :type :stream
 168                         :address-family :file
 169                         :format :binary
 170                         :remote-filename path)))
 171
 172 #+cl-postgres.features:sbcl-available
 173 (defun get-host-address (host)
 174   "Returns valid IPv4 or IPv6 address for the host."
 175   ;; get all IPv4 and IPv6 addresses as a list
 176   (let* ((host-ents (multiple-value-list (sb-bsd-sockets:get-host-by-name host)))
 177          ;; remove protocols for which we don't have an address
 178          (addresses (remove-if-not #'sb-bsd-sockets:host-ent-address host-ents)))
 179     ;; Return the first one or nil,
 180     ;; but actually, it shouln't return nil, because
 181     ;; get-host-by-name should signal NAME-SERVICE-ERROR condition
 182     ;; if there isn't any address for the host.
 183     (first addresses)))
 184
 185
 186 #+cl-postgres.features:sbcl-available
 187 (defun inet-socket-connect (host port)
 188   (let* ((host-ent (get-host-address host))
 189          (sock (make-instance
 190                 #+cl-postgres.features:sbcl-ipv6-available
 191                 (ecase (sb-bsd-sockets:host-ent-address-type host-ent)
 192                   (2  'sb-bsd-sockets:inet-socket)
 193                   (10 'sb-bsd-sockets:inet6-socket))
 194
 195                 #-cl-postgres.features:sbcl-ipv6-available
 196                 'sb-bsd-sockets:inet-socket
 197
 198                 :type :stream :protocol :tcp))
 199          (address (sb-bsd-sockets:host-ent-address host-ent)))
 200     (sb-bsd-sockets:socket-connect sock address port)
 201     (sb-bsd-sockets:socket-make-stream
 202      sock :input t :output t :buffering :full :element-type '(unsigned-byte 8))))
 203
 204 #+ccl
 205 (defun inet-socket-connect (host port)
 206   (when (and (stringp host)
 207              (string= host "localhost"))
 208     (setf host "127.0.0.1")) ;this corrects a strange ccl error we are seeing in certain scram authentication situations
 209   (ccl:make-socket :format :binary
 210                    :remote-host host
 211                    :remote-port port))
 212
 213 #+allegro
 214 (defun inet-socket-connect (host port)
 215   (socket:make-socket :remote-host host
 216                       :remote-port port
 217                       :format :binary
 218                       :type :stream))
 219
 220 (defun initiate-connection (conn &optional (connection-attempts 0))
 221   "Check whether a connection object is connected, try to connect it
 222 if it isn't."
 223   (flet ((add-restart (err)
 224            (restart-case (error (wrap-socket-error err))
 225              (:reconnect () :report "Try again."
 226                (progn (incf connection-attempts)
 227                       (initiate-connection conn connection-attempts)))))
 228          (assert-unix ()
 229            #+unix t
 230            #-unix (error "Unix sockets only available on Unix (really)")))
 231     (handler-case
 232         (let ((socket #-(or allegro cl-postgres.features:sbcl-available ccl)
 233                       (usocket:socket-stream
 234                        (usocket:socket-connect (connection-host conn)
 235                                                (connection-port conn)
 236                                                :element-type '(unsigned-byte 8)))
 237                       #+(or allegro cl-postgres.features:sbcl-available ccl)
 238                       (cond
 239                         ((equal (connection-host conn) :unix)
 240                          (assert-unix)
 241                          (unix-socket-connect (unix-socket-path *unix-socket-dir*
 242                                                                 (connection-port conn))))
 243                         ((and (stringp (connection-host conn))
 244                               (char= #\/ (aref (connection-host conn) 0)))
 245                          (assert-unix)
 246                          (unix-socket-connect (unix-socket-path (connection-host conn)
 247                                                                 (connection-port conn))))
 248                         ((and (pathnamep (connection-host conn))
 249                               (eql :absolute (pathname-directory (connection-host conn))))
 250                          (assert-unix)
 251                          (unix-socket-connect (unix-socket-path (namestring (connection-host conn))
 252                                                                 (connection-port conn))))
 253                         (t
 254                          (inet-socket-connect (connection-host conn)
 255                                               (connection-port conn)))))
 256               (finished nil)
 257               (*connection-params* (make-hash-table :test 'equal)))
 258           (setf (connection-parameters conn) *connection-params*)
 259           (unwind-protect
 260                (setf socket (handler-case
 261                                 (authenticate socket conn)
 262                               (cl-postgres-error:protocol-violation (err)
 263                                 (setf finished t)
 264                                 (ensure-socket-is-closed socket)
 265                                 ;; If we settled on a single logging library, I
 266                                 ;; would suggest logging this kind of situation
 267                                 ;; with at least the following data
 268                                 ;; (database-error-message err)
 269                                 ;; (database-error-detail err)
 270                                 (incf connection-attempts)
 271                                 (when (< connection-attempts
 272                                          *retry-connect-times*)
 273                                   (initiate-connection conn
 274                                                        connection-attempts))))
 275                      (connection-timestamp-format conn)
 276                      (if (string= (gethash "integer_datetimes"
 277                                            (connection-parameters conn)) "on")
 278                          :integer :float)
 279                      (connection-socket conn) socket
 280                      finished t)
 281             (unless finished
 282               (ensure-socket-is-closed socket)))
 283           (maphash (lambda (id query-param-list)
 284                      (prepare-query conn id
 285                                     (first query-param-list)
 286                                     (second query-param-list)))
 287                    (connection-meta conn)))
 288       #-(or allegro cl-postgres.features:sbcl-available ccl)
 289       (usocket:socket-error (e) (add-restart e))
 290       #+ccl (ccl:socket-error (e) (add-restart e))
 291       #+allegro(excl:socket-error (e) (add-restart e))
 292       #+cl-postgres.features:sbcl-available(sb-bsd-sockets:socket-error (e) (add-restart e))
 293       #+cl-postgres.features:sbcl-available(sb-bsd-sockets:name-service-error (e) (add-restart e))
 294       (stream-error (e) (add-restart e))))
 295   (values))
 296
 297 (defun reopen-database (conn &optional (connection-attempts 0))
 298   "Re-establish a database connection for a previously closed connection object.
 299 (Calling this on a connection that is still open is harmless.)"
 300   (loop :while (not (database-open-p conn))
 301         :repeat *retry-connect-times*
 302         :do
 303            (initiate-connection conn connection-attempts)))
 304
 305 (defun ensure-connection (conn &optional (connection-attempts 0))
 306   "Used to make sure a connection object is connected before doing anything
 307 with it."
 308   (unless conn
 309     (error "No database connection selected."))
 310   (unless (database-open-p conn)
 311     (restart-case (error 'database-connection-lost
 312                          :message "Connection to database server lost.")
 313       (:reconnect () :report "Try to reconnect."
 314         (loop :while (not (database-open-p conn))
 315               :repeat *retry-connect-times*
 316               :do
 317                  (initiate-connection conn connection-attempts))))))
 318
 319 (defun close-database (connection)
 320   "Close a database connection. It is advisable to call this on connections when
 321 you are done with them. Otherwise the open socket will stick around until it is
 322 garbage collected, and no one will tell the database server that we are done
 323 with it."
 324   (when (database-open-p connection)
 325     (terminate-connection (connection-socket connection)))
 326   (values))
 327
 328 (defmacro using-connection (connection &body body)
 329   "This is used to prevent a row-reader from recursively calling some
 330 query function. Because the connection is still returning results from
 331 the previous query when a row-reading is being executed, starting
 332 another query will not work as expected \(or at all, in general). This
 333 might also raise an error when you are using a single database
 334 connection from multiple threads, but you should not do that at all.
 335 Also binds *timestamp-format* and *connection-params*, which might be
 336 needed by the code interpreting the query results."
 337   (let ((connection-name (gensym)))
 338     `(let* ((,connection-name ,connection)
 339             (*timestamp-format* (connection-timestamp-format ,connection-name))
 340             (*connection-params* (connection-parameters ,connection-name)))
 341        (when (not (connection-available ,connection-name))
 342          (error 'database-error
 343                 :message "This connection is still processing another query."))
 344        (setf (connection-available ,connection-name) nil)
 345        (unwind-protect (progn ,@body)
 346          (setf (connection-available ,connection-name) t)))))
 347
 348 (defmacro with-reconnect-restart (connection &body body)
 349   "When, inside the body, an error occurs that breaks the connection
 350 socket, a condition of type database-connection-error is raised,
 351 offering a :reconnect restart."
 352   (let ((connection-name (gensym))
 353         (body-name (gensym))
 354         (retry-name (gensym)))
 355     `(let ((,connection-name ,connection))
 356        (ensure-connection ,connection-name)
 357        (labels ((,body-name ()
 358                   (handler-case (progn ,@body)
 359                     (stream-error (e)
 360                       (cond ((eq (connection-socket ,connection-name)
 361                                  (stream-error-stream e))
 362                              (ensure-socket-is-closed (connection-socket
 363                                                        ,connection-name)
 364                                                       :abort t)
 365                              (,retry-name (wrap-socket-error e)))
 366                             (t (error e))))
 367                     (cl-postgres-error:server-shutdown (e)
 368                       (ensure-socket-is-closed (connection-socket
 369                                                 ,connection-name)
 370                                                :abort t)
 371                       (,retry-name e))))
 372                 (,retry-name (err)
 373                   (restart-case (error err)
 374                     (:reconnect () :report "Try to reconnect"
 375                       (reopen-database ,connection-name)
 376                       (,body-name)))))
 377          (,body-name)))))
 378
 379 (defun wait-for-notification (connection)
 380   "This function blocks until asynchronous notification is received on the
 381 connection. Return the channel string, the payload and notifying pid as
 382 multiple values. The PostgreSQL LISTEN command must be used to enable listening
 383 for notifications."
 384   (block nil
 385     (with-reconnect-restart connection
 386       (handler-bind ((postgresql-notification
 387                        (lambda (c)
 388                          (return (values (postgresql-notification-channel c)
 389                                          (postgresql-notification-payload c)
 390                                          (postgresql-notification-pid c))))))
 391         (message-case (connection-socket connection))))))
 392
 393 (defun exec-query (connection query &optional (row-reader 'ignore-row-reader))
 394   "Sends the given query to the given connection, and interprets the results
 395  (if there are any) with the given row-reader. If the database returns
 396 information about the amount of rows affected, this is returned as a second
 397 value."
 398   (check-type query string)
 399   (with-reconnect-restart connection
 400     (using-connection connection
 401       (send-query (connection-socket connection) query row-reader))))
 402
 403 (defun prepare-query (connection name query &optional parameters)
 404   "Parse and plan the given query, and store it with Postgresql under the given name.
 405 Note that prepared statements are per-connection, so they can only be executed
 406 through the same connection that prepared them. Also note that while the Postmodern package
 407 will also stored the prepared query in the connection-meta slot of the connection, but
 408 cl-postgres prepare-query does not. If the name is an empty string, Postgresql will not
 409 store it as a reusable query. To make this useful in cl-postgres while
 410 (connection-use-binary connection) is true, you need to pass a list of parameters with
 411 the same type as you will be using when you call (exec-prepared).
 412
 413 For example:
 414
 415     (prepare-query connection \"test6\" \"select $1, $2\" '(1 T))
 416     (exec-prepared connection \"test6\" '(42 nil) 'list-row-reader)"
 417
 418   (check-type query string)
 419   (check-type name string)
 420   (with-reconnect-restart connection
 421     (using-connection connection
 422                       (send-parse (connection-socket connection) name query parameters
 423                                   (connection-use-binary connection))
 424       (values))))
 425
 426 (defun unprepare-query (connection name)
 427   "Close the prepared query given by name by closing the session connection.
 428 Does not remove the query from the meta slot in connection. This is not the same as
 429 keeping the connection open and sending Postgresql query to deallocate the named
 430 prepared query."
 431   (check-type name string)
 432   (with-reconnect-restart connection
 433     (using-connection connection
 434                       (send-close (connection-socket connection) name)
 435                       (values))))
 436
 437 (defun find-postgresql-prepared-query (connection name)
 438   "Returns a list of (name, query, parameters) for a named prepared query.
 439 Note the somewhat similar Postmodern version (find-postgresql-prepared-statement name) only
 440 returns the query, not the parameters or name."
 441   (let* ((prepared-queries
 442           (exec-query connection
 443                       "select name, statement, parameter_types from pg_prepared_statements"
 444                       'list-row-reader))
 445          (query (find name prepared-queries :key 'first :test 'equal))
 446          (len (if (and (stringp (third query)))
 447                   (length (third query))
 448                   0)))
 449     (when query (setf (third query) (subseq (third query) 1 (decf len))))
 450     query))
 451
 452 (defun exec-prepared (connection name parameters
 453                       &optional (row-reader 'ignore-row-reader))
 454   "Execute the prepared statement by the given name. Parameters should be given
 455 as a list. Each value in this list should be of a type that to-sql-string has
 456 been specialised on. (Byte arrays will be passed in their binary form, without
 457 being put through to-sql-string.) The result of the executing the statement, if
 458 any, is interpreted by the given row reader, and returned. Again, the number or
 459 affected rows is optionally returned as a second value.
 460 row-reader to the result."
 461   (check-type name string)
 462   (check-type parameters list)
 463   (with-reconnect-restart connection
 464     (using-connection connection
 465       (handler-case
 466           (send-execute (connection-socket connection)
 467                         name parameters row-reader (connection-use-binary connection))
 468         (cl-postgres-error::invalid-byte-sequence (error)
 469           (error "~A ~%Did you specify the types of parameters to be passed when
 470 you created the prepared statement? This error typically happens in this context
 471 when you are passing parameters to a prepared statement in a binary format but
 472 Postgresql is expecting the parameters to be in text format." error))))))
 473
 474 ;; A row-reader that returns a list of (field-name . field-value)
 475 ;; alist for the returned rows.
 476 (def-row-reader alist-row-reader (fields)
 477   (loop :while (next-row)
 478         :collect (loop :for field :across fields
 479                        :collect (cons (field-name field)
 480                                       (next-field field)))))
 481
 482 ;; Row-reader that returns a list of lists.
 483 (def-row-reader list-row-reader (fields)
 484   (loop :while (next-row)
 485         :collect (loop :for field :across fields
 486                        :collect (next-field field))))
 487
 488 ;; Row-reader that returns a vector of vectors.
 489 (def-row-reader vector-row-reader (fields)
 490   (let ((rows (make-array 1 :adjustable t :fill-pointer 0)))
 491     (loop :for row = (make-array (length fields))
 492           :while (next-row)
 493           :do (progn
 494                 (loop :for field :across fields
 495                       :for idx :upfrom 0
 496                       :do (setf (aref row idx) (next-field field)))
 497                 (vector-push-extend row rows)))
 498     rows))
 499
 500 ;; Row-reader that discards the query results.
 501 (def-row-reader ignore-row-reader (fields)
 502   (loop :while (next-row)
 503         :do (loop :for field :across fields
 504                   :do
 505                      (next-field field)))
 506   (values))