interfaces/postgresql-socket/postgresql-socket-uffi.cl

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          postgresql-socket.cl
   6 ;;;; Purpose:       Low-level PostgreSQL interface using sockets
   7 ;;;; Programmers:   Kevin M. Rosenberg based on
   8 ;;;;                Original code by Pierre R. Mai
   9 ;;;;
  10 ;;;; Date Started:  Feb 2002
  11 ;;;;
  12 ;;;; $Id: postgresql-socket-uffi.cl,v 1.2 2002/03/23 16:42:06 kevin Exp $
  13 ;;;;
  14 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
  15 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
  16 ;;;;
  17 ;;;; CLSQL users are granted the rights to distribute and use this software
  18 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  19 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  20 ;;;; *************************************************************************
  21
  22
  23 ;;;; Changes by Kevin Rosenberg
  24 ;;;;  - Added socket open functions for Allegro and Lispworks
  25 ;;;;  - Changed CMUCL FFI to UFFI
  26 ;;;;  - Added necessary (force-output) for socket streams on
  27 ;;;;     Allegro and Lispworks
  28
  29 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  30 (in-package :postgresql-socket)
  31
  32
  33 ;;; Message I/O stuff
  34
  35 (defmacro define-message-constants (description &rest clauses)
  36   (assert (evenp (length clauses)))
  37   (loop with seen-characters = nil
  38         for (name char) on clauses by #'cddr
  39         for char-code = (char-code char)
  40         for doc-string = (format nil "~A (~:C): ~A" description char name)
  41         if (member char seen-characters)
  42         do (error "Duplicate message type ~@C for group ~A" char description)
  43         else
  44         collect
  45         `(defconstant ,name ,char-code ,doc-string)
  46         into result-clauses
  47         and do (push char seen-characters)
  48       finally
  49         (return `(progn ,@result-clauses))))
  50
  51 (eval-when (:compile-toplevel :load-toplevel :execute)
  52 (define-message-constants "Backend Message Constants"
  53   +ascii-row-message+ #\D
  54   +authentication-message+ #\R
  55   +backend-key-message+ #\K
  56   +binary-row-message+ #\B
  57   +completed-response-message+ #\C
  58   +copy-in-response-message+ #\G
  59   +copy-out-response-message+ #\H
  60   +cursor-response-message+ #\P
  61   +empty-query-response-message+ #\I
  62   +error-response-message+ #\E
  63   +function-response-message+ #\V
  64   +notice-response-message+ #\N
  65   +notification-response-message+ #\A
  66   +ready-for-query-message+ #\Z
  67   +row-description-message+ #\T))
  68
  69 (defgeneric send-socket-value (type socket value))
  70
  71 (defmethod send-socket-value ((type (eql 'int32)) socket (value integer))
  72   (write-byte (ldb (byte 8 24) value) socket)
  73   (write-byte (ldb (byte 8 16) value) socket)
  74   (write-byte (ldb (byte 8 8) value) socket)
  75   (write-byte (ldb (byte 8 0) value) socket))
  76
  77 (defmethod send-socket-value ((type (eql 'int16)) socket (value integer))
  78   (write-byte (ldb (byte 8 8) value) socket)
  79   (write-byte (ldb (byte 8 0) value) socket))
  80
  81 (defmethod send-socket-value ((type (eql 'int8)) socket (value integer))
  82   (write-byte (ldb (byte 8 0) value) socket))
  83
  84 (defmethod send-socket-value ((type (eql 'string)) socket (value string))
  85   (loop for char across value
  86         for code = (char-code char)
  87         do (write-byte code socket)
  88         finally (write-byte 0 socket)))
  89
  90 (defmethod send-socket-value ((type (eql 'limstring)) socket (value string))
  91   (loop for char across value
  92         for code = (char-code char)
  93         do (write-byte code socket)))
  94
  95 (defmethod send-socket-value ((type (eql 'byte)) socket (value integer))
  96   (write-byte value socket))
  97
  98 (defmethod send-socket-value ((type (eql 'byte)) socket (value character))
  99   (write-byte (char-code value) socket))
 100
 101 (defmethod send-socket-value ((type (eql 'byte)) socket value)
 102   (write-sequence value socket))
 103
 104 (defgeneric read-socket-value (type socket))
 105
 106 (defmethod read-socket-value ((type (eql 'int32)) socket)
 107   (let ((result 0))
 108     (setf (ldb (byte 8 24) result) (read-byte socket))
 109     (setf (ldb (byte 8 16) result) (read-byte socket))
 110     (setf (ldb (byte 8 8) result) (read-byte socket))
 111     (setf (ldb (byte 8 0) result) (read-byte socket))
 112     result))
 113
 114 (defmethod read-socket-value ((type (eql 'int16)) socket)
 115   (let ((result 0))
 116     (setf (ldb (byte 8 8) result) (read-byte socket))
 117     (setf (ldb (byte 8 0) result) (read-byte socket))
 118     result))
 119
 120 (defmethod read-socket-value ((type (eql 'int8)) socket)
 121   (read-byte socket))
 122
 123 (defmethod read-socket-value ((type (eql 'string)) socket)
 124   (with-output-to-string (out)
 125     (loop for code = (read-byte socket)
 126           until (zerop code)
 127           do (write-char (code-char code) out))))
 128
 129 (defgeneric skip-socket-value (type socket))
 130
 131 (defmethod skip-socket-value ((type (eql 'int32)) socket)
 132   (dotimes (i 4) (read-byte socket)))
 133
 134 (defmethod skip-socket-value ((type (eql 'int16)) socket)
 135   (dotimes (i 2) (read-byte socket)))
 136
 137 (defmethod skip-socket-value ((type (eql 'int8)) socket)
 138   (read-byte socket))
 139
 140 (defmethod skip-socket-value ((type (eql 'string)) socket)
 141   (loop until (zerop (read-byte socket))))
 142
 143 (defmacro define-message-sender (name (&rest args) &rest clauses)
 144   (loop with socket-var = (gensym)
 145         for (type value) in clauses
 146         collect
 147         `(send-socket-value ',type ,socket-var ,value)
 148         into body
 149       finally
 150         (return
 151           `(defun ,name (,socket-var ,@args)
 152              ,@body))))
 153
 154 (defun pad-limstring (string limit)
 155   (let ((result (make-string limit :initial-element #\NULL)))
 156     (loop for char across string
 157           for index from 0 below limit
 158           do (setf (char result index) char))
 159     result))
 160
 161 (define-message-sender send-startup-message
 162     (database user &optional (command-line "") (backend-tty ""))
 163   (int32 296)                           ; Length
 164   (int32 #x00020000)                    ; Version 2.0
 165   (limstring (pad-limstring database 64))
 166   (limstring (pad-limstring user 32))
 167   (limstring (pad-limstring command-line 64))
 168   (limstring (pad-limstring "" 64))     ; Unused
 169   (limstring (pad-limstring backend-tty 64)))
 170
 171 (define-message-sender send-terminate-message ()
 172   (byte #\X))
 173
 174 (define-message-sender send-unencrypted-password-message (password)
 175   (int32 (+ 5 (length password)))
 176   (string password))
 177
 178 (define-message-sender send-query-message (query)
 179   (byte #\Q)
 180   (string query))
 181
 182 (define-message-sender send-encrypted-password-message (crypted-password)
 183   (int32 (+ 5 (length crypted-password)))
 184   (string crypted-password))
 185
 186 (define-message-sender send-cancel-request (pid key)
 187   (int32 16)                            ; Length
 188   (int32 80877102)                      ; Magic
 189   (int32 pid)
 190   (int32 key))
 191
 192
 193 (defun read-socket-sequence (string stream)
 194 "KMR -- Added to support reading from binary stream into a string"
 195   (declare (optimize (speed 3) (safety 0)))
 196   (dotimes (i (length string))
 197     (declare (fixnum i))
 198     (setf (char string i) (code-char (read-byte stream))))
 199   string)
 200
 201
 202 ;;; Support for encrypted password transmission
 203
 204 (defconstant +crypt-library+ "/usr/lib/libcrypt.so"
 205   "Name of the shared library to load in order to access the crypt
 206 function named by `*crypt-function-name*'.")
 207
 208 (defvar *crypt-library-loaded* nil)
 209
 210 (defun crypt-password (password salt)
 211   "Encrypt a password for transmission to a PostgreSQL server."
 212   (unless *crypt-library-loaded*
 213     (uffi:load-foreign-library +crypt-library+ :supporting-libaries '("c"))
 214     (eval (uffi:def-function "crypt"
 215               ((key :cstring)
 216                (salt :cstring))
 217             :returning :cstring))
 218     (setq *crypt-library-loaded* t))
 219    (uffi:with-cstring (password-cstring password)
 220      (uffi:with-cstring (salt-cstring salt)
 221        (uffi:convert-from-cstring (crypt password-cstring salt-cstring)))))
 222 ;;; Condition hierarchy
 223
 224 (define-condition postgresql-condition (condition)
 225   ((connection :initarg :connection :reader postgresql-condition-connection)
 226    (message :initarg :message :reader postgresql-condition-message))
 227   (:report
 228    (lambda (c stream)
 229      (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>"
 230              (type-of c)
 231              (postgresql-condition-connection c)
 232              (postgresql-condition-message c)))))
 233
 234 (define-condition postgresql-error (error postgresql-condition)
 235   ())
 236
 237 (define-condition postgresql-fatal-error (postgresql-error)
 238   ())
 239
 240 (define-condition postgresql-login-error (postgresql-fatal-error)
 241   ())
 242
 243 (define-condition postgresql-warning (warning postgresql-condition)
 244   ())
 245
 246 (define-condition postgresql-notification (postgresql-condition)
 247   ()
 248   (:report
 249    (lambda (c stream)
 250      (format stream "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
 251              (postgresql-condition-connection c)
 252              (postgresql-condition-message c)))))
 253
 254 ;;; Structures
 255
 256 (defstruct postgresql-connection
 257   host
 258   port
 259   database
 260   user
 261   password
 262   options
 263   tty
 264   socket
 265   pid
 266   key)
 267
 268 (defstruct postgresql-cursor
 269   connection
 270   name
 271   fields)
 272
 273 ;;; Socket stuff
 274
 275 (defconstant +postgresql-server-default-port+ 5432
 276   "Default port of PostgreSQL server.")
 277
 278 (defvar *postgresql-server-socket-timeout* 60
 279   "Timeout in seconds for reads from the PostgreSQL server.")
 280
 281
 282 #+cmu
 283 (defun open-postgresql-socket (host port)
 284   (etypecase host
 285     (pathname
 286      ;; Directory to unix-domain socket
 287      (ext:connect-to-unix-socket
 288       (namestring
 289        (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 290                       :defaults host))))
 291     (string
 292      (ext:connect-to-inet-socket host port))))
 293
 294 #+cmu
 295 (defun open-postgresql-socket-stream (host port)
 296   (system:make-fd-stream
 297    (open-postgresql-socket host port)
 298    :input t :output t :element-type '(unsigned-byte 8)
 299    :buffering :none
 300    :timeout *postgresql-server-socket-timeout*))
 301
 302 #+allegro
 303 (defun open-postgresql-socket-stream (host port)
 304   (etypecase host
 305     (pathname
 306      (let ((path (namestring
 307                   (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 308                                  :defaults host))))
 309        (socket:make-socket :type :stream :address-family :file
 310                            :connect :active
 311                            :remote-filename path :local-filename path)))
 312     (string
 313      (socket:with-pending-connect
 314          (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed"))
 315            (socket:make-socket :type :stream :address-family :internet
 316                                :remote-port port :remote-host host
 317                                :connect :active :nodelay t))))
 318     ))
 319
 320 #+lispworks
 321 (defun open-postgresql-socket-stream (host port)
 322   (etypecase host
 323     (pathname
 324      (error "File sockets not supported on Lispworks."))
 325     (string
 326      (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8)
 327                            :read-timeout *postgresql-server-socket-timeout*))
 328     ))
 329
 330 ;;; Interface Functions
 331
 332 (defun open-postgresql-connection (&key (host (cmucl-compat:required-argument))
 333                                         (port +postgresql-server-default-port+)
 334                                         (database (cmucl-compat:required-argument))
 335                                         (user (cmucl-compat:required-argument))
 336                                         options tty password)
 337   "Open a connection to a PostgreSQL server with the given parameters.
 338 Note that host, database and user arguments must be supplied.
 339
 340 If host is a pathname, it is assumed to name a directory containing
 341 the local unix-domain sockets of the server, with port selecting which
 342 of those sockets to open.  If host is a string, it is assumed to be
 343 the name of the host running the PostgreSQL server.  In that case a
 344 TCP connection to the given port on that host is opened in order to
 345 communicate with the server.  In either case the port argument
 346 defaults to `+postgresql-server-default-port+'.
 347
 348 Password is the clear-text password to be passed in the authentication
 349 phase to the server.  Depending on the server set-up, it is either
 350 passed in the clear, or encrypted via crypt and a server-supplied
 351 salt.  In that case the alien function specified by `*crypt-library*'
 352 and `*crypt-function-name*' is used for encryption.
 353
 354 Note that all the arguments (including the clear-text password
 355 argument) are stored in the `postgresql-connection' structure, in
 356 order to facilitate automatic reconnection in case of communication
 357 troubles."
 358   (reopen-postgresql-connection
 359    (make-postgresql-connection :host host :port port
 360                                :options (or options "") :tty (or tty "")
 361                                :database database :user user
 362                                :password (or password ""))))
 363
 364 (defun reopen-postgresql-connection (connection)
 365   "Reopen the given PostgreSQL connection.  Closes any existing
 366 connection, if it is still open."
 367   (when (postgresql-connection-open-p connection)
 368     (close-postgresql-connection connection))
 369   (let ((socket (open-postgresql-socket-stream
 370                   (postgresql-connection-host connection)
 371                   (postgresql-connection-port connection))))
 372     (unwind-protect
 373          (progn
 374            (setf (postgresql-connection-socket connection) socket)
 375            (send-startup-message socket
 376                                  (postgresql-connection-database connection)
 377                                  (postgresql-connection-user connection)
 378                                  (postgresql-connection-options connection)
 379                                  (postgresql-connection-tty connection))
 380            (force-output socket)
 381            (loop
 382                (case (read-socket-value 'int8 socket)
 383                  (#.+authentication-message+
 384                   (case (read-socket-value 'int32 socket)
 385                     (0 (return))
 386                     ((1 2)
 387                      (error 'postgresql-login-error
 388                             :connection connection
 389                             :message
 390                             "Postmaster expects unsupported Kerberos authentication."))
 391                     (3
 392                      (send-unencrypted-password-message
 393                       socket
 394                       (postgresql-connection-password connection)))
 395                     (4
 396                      (let ((salt (make-string 2)))
 397                        (read-socket-sequence salt socket)
 398                        (send-encrypted-password-message
 399                         socket
 400                         (crypt-password
 401                          (postgresql-connection-password connection) salt))))
 402                     (t
 403                      (error 'postgresql-login-error
 404                             :connection connection
 405                             :message
 406                             "Postmaster expects unknown authentication method."))))
 407                  (#.+error-response-message+
 408                   (let ((message (read-socket-value 'string socket)))
 409                     (error 'postgresql-login-error
 410                            :connection connection :message message)))
 411                  (t
 412                   (error 'postgresql-login-error
 413                          :connection connection
 414                          :message
 415                          "Received garbled message from Postmaster"))))
 416            ;; Start backend communication
 417            (force-output socket)
 418            (loop
 419                (case (read-socket-value 'int8 socket)
 420                  (#.+backend-key-message+
 421                   (setf (postgresql-connection-pid connection)
 422                         (read-socket-value 'int32 socket)
 423                         (postgresql-connection-key connection)
 424                         (read-socket-value 'int32 socket)))
 425                  (#.+ready-for-query-message+
 426                   (setq socket nil)
 427                   (return connection))
 428                  (#.+error-response-message+
 429                   (let ((message (read-socket-value 'string socket)))
 430                     (error 'postgresql-login-error
 431                            :connection connection
 432                            :message message)))
 433                  (#.+notice-response-message+
 434                   (let ((message (read-socket-value 'string socket)))
 435                     (warn 'postgresql-warning :connection connection
 436                           :message message)))
 437                  (t
 438                   (error 'postgresql-login-error
 439                          :connection connection
 440                          :message
 441                          "Received garbled message from Postmaster")))))
 442       (when socket
 443         (close socket)))))
 444
 445 (defun close-postgresql-connection (connection &optional abort)
 446   (unless abort
 447     (ignore-errors
 448       (send-terminate-message (postgresql-connection-socket connection))))
 449   (close (postgresql-connection-socket connection)))
 450
 451 (defun postgresql-connection-open-p (connection)
 452   (let ((socket (postgresql-connection-socket connection)))
 453     (and socket (streamp socket) (open-stream-p socket))))
 454
 455 (defun ensure-open-postgresql-connection (connection)
 456   (unless (postgresql-connection-open-p connection)
 457     (reopen-postgresql-connection connection)))
 458
 459 (defun process-async-messages (connection)
 460   (assert (postgresql-connection-open-p connection))
 461   ;; Process any asnychronous messages
 462   (loop with socket = (postgresql-connection-socket connection)
 463         while (listen socket)
 464         do
 465         (case (read-socket-value 'int8 socket)
 466           (#.+notice-response-message+
 467            (let ((message (read-socket-value 'string socket)))
 468              (warn 'postgresql-warning :connection connection
 469                    :message message)))
 470           (#.+notification-response-message+
 471            (let ((pid (read-socket-value 'int32 socket))
 472                  (message (read-socket-value 'string socket)))
 473              (when (= pid (postgresql-connection-pid connection))
 474                (signal 'postgresql-notification :connection connection
 475                        :message message))))
 476           (t
 477            (close-postgresql-connection connection)
 478            (error 'postgresql-fatal-error :connection connection
 479                   :message "Received garbled message from backend")))))
 480
 481 (defun start-query-execution (connection query)
 482   (ensure-open-postgresql-connection connection)
 483   (process-async-messages connection)
 484   (send-query-message (postgresql-connection-socket connection) query)
 485   (force-output (postgresql-connection-socket connection)))
 486
 487 (defun wait-for-query-results (connection)
 488   (assert (postgresql-connection-open-p connection))
 489   (let ((socket (postgresql-connection-socket connection))
 490         (cursor-name nil)
 491         (error nil))
 492     (loop
 493         (case (read-socket-value 'int8 socket)
 494           (#.+completed-response-message+
 495            (return (values :completed (read-socket-value 'string socket))))
 496           (#.+cursor-response-message+
 497            (setq cursor-name (read-socket-value 'string socket)))
 498           (#.+row-description-message+
 499            (let* ((count (read-socket-value 'int16 socket))
 500                   (fields
 501                    (loop repeat count
 502                      collect
 503                      (list
 504                       (read-socket-value 'string socket)
 505                       (read-socket-value 'int32 socket)
 506                       (read-socket-value 'int16 socket)
 507                       (read-socket-value 'int32 socket)))))
 508              (return
 509                (values :cursor
 510                        (make-postgresql-cursor :connection connection
 511                                                :name cursor-name
 512                                                :fields fields)))))
 513           (#.+copy-in-response-message+
 514            (return :copy-in))
 515           (#.+copy-out-response-message+
 516            (return :copy-out))
 517           (#.+ready-for-query-message+
 518            (when error
 519              (error error))
 520            (return nil))
 521           (#.+error-response-message+
 522            (let ((message (read-socket-value 'string socket)))
 523              (setq error
 524                    (make-condition 'postgresql-error
 525                                    :connection connection :message message))))
 526           (#.+notice-response-message+
 527            (let ((message (read-socket-value 'string socket)))
 528              (warn 'postgresql-warning
 529                    :connection connection :message message)))
 530           (#.+notification-response-message+
 531            (let ((pid (read-socket-value 'int32 socket))
 532                  (message (read-socket-value 'string socket)))
 533              (when (= pid (postgresql-connection-pid connection))
 534                (signal 'postgresql-notification :connection connection
 535                        :message message))))
 536           (t
 537            (close-postgresql-connection connection)
 538            (error 'postgresql-fatal-error :connection connection
 539                   :message "Received garbled message from backend"))))))
 540
 541 (defun read-null-bit-vector (socket count)
 542   (let ((result (make-array count :element-type 'bit)))
 543     (dotimes (offset (ceiling count 8))
 544       (loop with byte = (read-byte socket)
 545             for index from (* offset 8) below (min count (* (1+ offset) 8))
 546             for weight downfrom 7
 547             do (setf (aref result index) (ldb (byte 1 weight) byte))))
 548     result))
 549
 550 (defun read-cursor-row (cursor)
 551   (let* ((connection (postgresql-cursor-connection cursor))
 552          (socket (postgresql-connection-socket connection))
 553          (fields (postgresql-cursor-fields cursor)))
 554     (assert (postgresql-connection-open-p connection))
 555     (loop
 556         (let ((code (read-socket-value 'int8 socket)))
 557           (case code
 558             (#.+ascii-row-message+
 559              (return
 560                (loop with count = (length fields)
 561                      with null-vector = (read-null-bit-vector socket count)
 562                      repeat count
 563                      for null-bit across null-vector
 564                      for null-p = (zerop null-bit)
 565                      if null-p
 566                      collect nil
 567                      else
 568                      collect
 569                      (let* ((length (read-socket-value 'int32 socket))
 570                             (result (make-string (- length 4))))
 571                        (read-socket-sequence result socket)
 572                        result))))
 573             (#.+binary-row-message+
 574              (error "NYI"))
 575             (#.+completed-response-message+
 576              (return (values nil (read-socket-value 'string socket))))
 577             (#.+error-response-message+
 578              (let ((message (read-socket-value 'string socket)))
 579                (error 'postgresql-error
 580                       :connection connection :message message)))
 581             (#.+notice-response-message+
 582              (let ((message (read-socket-value 'string socket)))
 583                (warn 'postgresql-warning
 584                      :connection connection :message message)))
 585             (#.+notification-response-message+
 586              (let ((pid (read-socket-value 'int32 socket))
 587                    (message (read-socket-value 'string socket)))
 588                (when (= pid (postgresql-connection-pid connection))
 589                  (signal 'postgresql-notification :connection connection
 590                          :message message))))
 591             (t
 592              (close-postgresql-connection connection)
 593              (error 'postgresql-fatal-error :connection connection
 594                     :message "Received garbled message from backend")))))))
 595
 596 (defun copy-cursor-row (cursor sequence)
 597   (let* ((connection (postgresql-cursor-connection cursor))
 598          (socket (postgresql-connection-socket connection))
 599          (fields (postgresql-cursor-fields cursor)))
 600     (assert (= (length fields) (length sequence)))
 601     (loop
 602         (let ((code (read-socket-value 'int8 socket)))
 603           (case code
 604             (#.+ascii-row-message+
 605              (return
 606                (map-into
 607                 sequence
 608                 #'(lambda (null-bit)
 609                     (if (zerop null-bit)
 610                         nil
 611                         (let* ((length (read-socket-value 'int32 socket))
 612                                (result (make-string (- length 4))))
 613                           (read-socket-sequence result socket)
 614                           result)))
 615                 (read-null-bit-vector socket (length sequence)))))
 616             (#.+binary-row-message+
 617              (error "NYI"))
 618             (#.+completed-response-message+
 619              (return (values nil (read-socket-value 'string socket))))
 620             (#.+error-response-message+
 621              (let ((message (read-socket-value 'string socket)))
 622                (error 'postgresql-error
 623                       :connection connection :message message)))
 624             (#.+notice-response-message+
 625              (let ((message (read-socket-value 'string socket)))
 626                (warn 'postgresql-warning
 627                      :connection connection :message message)))
 628             (#.+notification-response-message+
 629              (let ((pid (read-socket-value 'int32 socket))
 630                    (message (read-socket-value 'string socket)))
 631                (when (= pid (postgresql-connection-pid connection))
 632                  (signal 'postgresql-notification :connection connection
 633                          :message message))))
 634             (t
 635              (close-postgresql-connection connection)
 636              (error 'postgresql-fatal-error :connection connection
 637                     :message "Received garbled message from backend")))))))
 638
 639 (defun skip-cursor-row (cursor)
 640   (let* ((connection (postgresql-cursor-connection cursor))
 641          (socket (postgresql-connection-socket connection))
 642          (fields (postgresql-cursor-fields cursor)))
 643     (loop
 644         (let ((code (read-socket-value 'int8 socket)))
 645           (case code
 646             (#.+ascii-row-message+
 647              (loop for null-bit across
 648                    (read-null-bit-vector socket (length fields))
 649                    do
 650                    (unless (zerop null-bit)
 651                      (let* ((length (read-socket-value 'int32 socket)))
 652                        (loop repeat (- length 4) do (read-byte socket)))))
 653              (return t))
 654             (#.+binary-row-message+
 655              (error "NYI"))
 656             (#.+completed-response-message+
 657              (return (values nil (read-socket-value 'string socket))))
 658             (#.+error-response-message+
 659              (let ((message (read-socket-value 'string socket)))
 660                (error 'postgresql-error
 661                       :connection connection :message message)))
 662             (#.+notice-response-message+
 663              (let ((message (read-socket-value 'string socket)))
 664                (warn 'postgresql-warning
 665                      :connection connection :message message)))
 666             (#.+notification-response-message+
 667              (let ((pid (read-socket-value 'int32 socket))
 668                    (message (read-socket-value 'string socket)))
 669                (when (= pid (postgresql-connection-pid connection))
 670                  (signal 'postgresql-notification :connection connection
 671                          :message message))))
 672             (t
 673              (close-postgresql-connection connection)
 674              (error 'postgresql-fatal-error :connection connection
 675                     :message "Received garbled message from backend")))))))
 676
 677 (defun run-query (connection query)
 678   (start-query-execution connection query)
 679   (multiple-value-bind (status cursor)
 680       (wait-for-query-results connection)
 681     (assert (eq status :cursor))
 682     (loop for row = (read-cursor-row cursor)
 683           while row
 684           collect row
 685           finally
 686           (wait-for-query-results connection))))