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.1 2002/03/23 14:04:54 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 ;;; Support for encrypted password transmission
 193
 194 (defconstant +crypt-library+ "/usr/lib/libcrypt.so"
 195   "Name of the shared library to load in order to access the crypt
 196 function named by `*crypt-function-name*'.")
 197
 198 (defvar *crypt-library-loaded* nil)
 199
 200 (defun crypt-password (password salt)
 201   "Encrypt a password for transmission to a PostgreSQL server."
 202   (unless *crypt-library-loaded*
 203     (uffi:load-foreign-library +crypt-library+ :supporting-libaries '("c"))
 204     (eval (uffi:def-function "crypt"
 205               ((key :cstring)
 206                (salt :cstring))
 207             :returning :cstring))
 208     (setq *crypt-library-loaded* t))
 209    (uffi:with-cstring (password-cstring password)
 210      (uffi:with-cstring (salt-cstring salt)
 211        (uffi:convert-from-cstring (crypt password-cstring salt-cstring)))))
 212 ;;; Condition hierarchy
 213
 214 (define-condition postgresql-condition (condition)
 215   ((connection :initarg :connection :reader postgresql-condition-connection)
 216    (message :initarg :message :reader postgresql-condition-message))
 217   (:report
 218    (lambda (c stream)
 219      (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>"
 220              (type-of c)
 221              (postgresql-condition-connection c)
 222              (postgresql-condition-message c)))))
 223
 224 (define-condition postgresql-error (error postgresql-condition)
 225   ())
 226
 227 (define-condition postgresql-fatal-error (postgresql-error)
 228   ())
 229
 230 (define-condition postgresql-login-error (postgresql-fatal-error)
 231   ())
 232
 233 (define-condition postgresql-warning (warning postgresql-condition)
 234   ())
 235
 236 (define-condition postgresql-notification (postgresql-condition)
 237   ()
 238   (:report
 239    (lambda (c stream)
 240      (format stream "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
 241              (postgresql-condition-connection c)
 242              (postgresql-condition-message c)))))
 243
 244 ;;; Structures
 245
 246 (defstruct postgresql-connection
 247   host
 248   port
 249   database
 250   user
 251   password
 252   options
 253   tty
 254   socket
 255   pid
 256   key)
 257
 258 (defstruct postgresql-cursor
 259   connection
 260   name
 261   fields)
 262
 263 ;;; Socket stuff
 264
 265 (defconstant +postgresql-server-default-port+ 5432
 266   "Default port of PostgreSQL server.")
 267
 268 (defvar *postgresql-server-socket-timeout* 60
 269   "Timeout in seconds for reads from the PostgreSQL server.")
 270
 271
 272 #+cmu
 273 (defun open-postgresql-socket (host port)
 274   (etypecase host
 275     (pathname
 276      ;; Directory to unix-domain socket
 277      (ext:connect-to-unix-socket
 278       (namestring
 279        (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 280                       :defaults host))))
 281     (string
 282      (ext:connect-to-inet-socket host port))))
 283
 284 #+cmu
 285 (defun open-postgresql-socket-stream (host port)
 286   (system:make-fd-stream
 287    (open-postgresql-socket host port)
 288    :input t :output t :element-type '(unsigned-byte 8)
 289    :buffering :none
 290    :timeout *postgresql-server-socket-timeout*))
 291
 292 #+allegro
 293 (defun open-postgresql-socket-stream (host port)
 294   (etypecase host
 295     (pathname
 296      (let ((path (namestring
 297                   (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 298                                  :defaults host))))
 299        (socket:make-socket :type :stream :address-family :file
 300                            :connect :active
 301                            :remote-filename path :local-filename path)))
 302     (string
 303      (socket:with-pending-connect
 304          (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed"))
 305            (socket:make-socket :type :stream :address-family :internet
 306                                :remote-port port :remote-host host
 307                                :connect :active :nodelay t))))
 308     ))
 309
 310 #+lispworks
 311 (defun open-postgresql-socket-stream (host port)
 312   (etypecase host
 313     (pathname
 314      (error "File sockets not supported on Lispworks."))
 315     (string
 316      (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8)
 317                            :read-timeout *postgresql-server-socket-timeout*))
 318     ))
 319
 320 ;;; Interface Functions
 321
 322 (defun open-postgresql-connection (&key (host (cmucl-compat:required-argument))
 323                                         (port +postgresql-server-default-port+)
 324                                         (database (cmucl-compat:required-argument))
 325                                         (user (cmucl-compat:required-argument))
 326                                         options tty password)
 327   "Open a connection to a PostgreSQL server with the given parameters.
 328 Note that host, database and user arguments must be supplied.
 329
 330 If host is a pathname, it is assumed to name a directory containing
 331 the local unix-domain sockets of the server, with port selecting which
 332 of those sockets to open.  If host is a string, it is assumed to be
 333 the name of the host running the PostgreSQL server.  In that case a
 334 TCP connection to the given port on that host is opened in order to
 335 communicate with the server.  In either case the port argument
 336 defaults to `+postgresql-server-default-port+'.
 337
 338 Password is the clear-text password to be passed in the authentication
 339 phase to the server.  Depending on the server set-up, it is either
 340 passed in the clear, or encrypted via crypt and a server-supplied
 341 salt.  In that case the alien function specified by `*crypt-library*'
 342 and `*crypt-function-name*' is used for encryption.
 343
 344 Note that all the arguments (including the clear-text password
 345 argument) are stored in the `postgresql-connection' structure, in
 346 order to facilitate automatic reconnection in case of communication
 347 troubles."
 348   (reopen-postgresql-connection
 349    (make-postgresql-connection :host host :port port
 350                                :options (or options "") :tty (or tty "")
 351                                :database database :user user
 352                                :password (or password ""))))
 353
 354 (defun reopen-postgresql-connection (connection)
 355   "Reopen the given PostgreSQL connection.  Closes any existing
 356 connection, if it is still open."
 357   (when (postgresql-connection-open-p connection)
 358     (close-postgresql-connection connection))
 359   (let ((socket (open-postgresql-socket-stream
 360                   (postgresql-connection-host connection)
 361                   (postgresql-connection-port connection))))
 362     (unwind-protect
 363          (progn
 364            (setf (postgresql-connection-socket connection) socket)
 365            (send-startup-message socket
 366                                  (postgresql-connection-database connection)
 367                                  (postgresql-connection-user connection)
 368                                  (postgresql-connection-options connection)
 369                                  (postgresql-connection-tty connection))
 370            (force-output socket)
 371            (loop
 372                (case (read-socket-value 'int8 socket)
 373                  (#.+authentication-message+
 374                   (case (read-socket-value 'int32 socket)
 375                     (0 (return))
 376                     ((1 2)
 377                      (error 'postgresql-login-error
 378                             :connection connection
 379                             :message
 380                             "Postmaster expects unsupported Kerberos authentication."))
 381                     (3
 382                      (send-unencrypted-password-message
 383                       socket
 384                       (postgresql-connection-password connection)))
 385                     (4
 386                      (let ((salt (make-string 2)))
 387                        (read-sequence salt socket)
 388                        (send-encrypted-password-message
 389                         socket
 390                         (crypt-password
 391                          (postgresql-connection-password connection) salt))))
 392                     (t
 393                      (error 'postgresql-login-error
 394                             :connection connection
 395                             :message
 396                             "Postmaster expects unknown authentication method."))))
 397                  (#.+error-response-message+
 398                   (let ((message (read-socket-value 'string socket)))
 399                     (error 'postgresql-login-error
 400                            :connection connection :message message)))
 401                  (t
 402                   (error 'postgresql-login-error
 403                          :connection connection
 404                          :message
 405                          "Received garbled message from Postmaster"))))
 406            ;; Start backend communication
 407            (force-output socket)
 408            (loop
 409                (case (read-socket-value 'int8 socket)
 410                  (#.+backend-key-message+
 411                   (setf (postgresql-connection-pid connection)
 412                         (read-socket-value 'int32 socket)
 413                         (postgresql-connection-key connection)
 414                         (read-socket-value 'int32 socket)))
 415                  (#.+ready-for-query-message+
 416                   (setq socket nil)
 417                   (return connection))
 418                  (#.+error-response-message+
 419                   (let ((message (read-socket-value 'string socket)))
 420                     (error 'postgresql-login-error
 421                            :connection connection
 422                            :message message)))
 423                  (#.+notice-response-message+
 424                   (let ((message (read-socket-value 'string socket)))
 425                     (warn 'postgresql-warning :connection connection
 426                           :message message)))
 427                  (t
 428                   (error 'postgresql-login-error
 429                          :connection connection
 430                          :message
 431                          "Received garbled message from Postmaster")))))
 432       (when socket
 433         (close socket)))))
 434
 435 (defun close-postgresql-connection (connection &optional abort)
 436   (unless abort
 437     (ignore-errors
 438       (send-terminate-message (postgresql-connection-socket connection))))
 439   (close (postgresql-connection-socket connection)))
 440
 441 (defun postgresql-connection-open-p (connection)
 442   (let ((socket (postgresql-connection-socket connection)))
 443     (and socket (streamp socket) (open-stream-p socket))))
 444
 445 (defun ensure-open-postgresql-connection (connection)
 446   (unless (postgresql-connection-open-p connection)
 447     (reopen-postgresql-connection connection)))
 448
 449 (defun process-async-messages (connection)
 450   (assert (postgresql-connection-open-p connection))
 451   ;; Process any asnychronous messages
 452   (loop with socket = (postgresql-connection-socket connection)
 453         while (listen socket)
 454         do
 455         (case (read-socket-value 'int8 socket)
 456           (#.+notice-response-message+
 457            (let ((message (read-socket-value 'string socket)))
 458              (warn 'postgresql-warning :connection connection
 459                    :message message)))
 460           (#.+notification-response-message+
 461            (let ((pid (read-socket-value 'int32 socket))
 462                  (message (read-socket-value 'string socket)))
 463              (when (= pid (postgresql-connection-pid connection))
 464                (signal 'postgresql-notification :connection connection
 465                        :message message))))
 466           (t
 467            (close-postgresql-connection connection)
 468            (error 'postgresql-fatal-error :connection connection
 469                   :message "Received garbled message from backend")))))
 470
 471 (defun start-query-execution (connection query)
 472   (ensure-open-postgresql-connection connection)
 473   (process-async-messages connection)
 474   (send-query-message (postgresql-connection-socket connection) query)
 475   (force-output (postgresql-connection-socket connection)))
 476
 477 (defun wait-for-query-results (connection)
 478   (assert (postgresql-connection-open-p connection))
 479   (let ((socket (postgresql-connection-socket connection))
 480         (cursor-name nil)
 481         (error nil))
 482     (loop
 483         (case (read-socket-value 'int8 socket)
 484           (#.+completed-response-message+
 485            (return (values :completed (read-socket-value 'string socket))))
 486           (#.+cursor-response-message+
 487            (setq cursor-name (read-socket-value 'string socket)))
 488           (#.+row-description-message+
 489            (let* ((count (read-socket-value 'int16 socket))
 490                   (fields
 491                    (loop repeat count
 492                      collect
 493                      (list
 494                       (read-socket-value 'string socket)
 495                       (read-socket-value 'int32 socket)
 496                       (read-socket-value 'int16 socket)
 497                       (read-socket-value 'int32 socket)))))
 498              (return
 499                (values :cursor
 500                        (make-postgresql-cursor :connection connection
 501                                                :name cursor-name
 502                                                :fields fields)))))
 503           (#.+copy-in-response-message+
 504            (return :copy-in))
 505           (#.+copy-out-response-message+
 506            (return :copy-out))
 507           (#.+ready-for-query-message+
 508            (when error
 509              (error error))
 510            (return nil))
 511           (#.+error-response-message+
 512            (let ((message (read-socket-value 'string socket)))
 513              (setq error
 514                    (make-condition 'postgresql-error
 515                                    :connection connection :message message))))
 516           (#.+notice-response-message+
 517            (let ((message (read-socket-value 'string socket)))
 518              (warn 'postgresql-warning
 519                    :connection connection :message message)))
 520           (#.+notification-response-message+
 521            (let ((pid (read-socket-value 'int32 socket))
 522                  (message (read-socket-value 'string socket)))
 523              (when (= pid (postgresql-connection-pid connection))
 524                (signal 'postgresql-notification :connection connection
 525                        :message message))))
 526           (t
 527            (close-postgresql-connection connection)
 528            (error 'postgresql-fatal-error :connection connection
 529                   :message "Received garbled message from backend"))))))
 530
 531 (defun read-null-bit-vector (socket count)
 532   (let ((result (make-array count :element-type 'bit)))
 533     (dotimes (offset (ceiling count 8))
 534       (loop with byte = (read-byte socket)
 535             for index from (* offset 8) below (min count (* (1+ offset) 8))
 536             for weight downfrom 7
 537             do (setf (aref result index) (ldb (byte 1 weight) byte))))
 538     result))
 539
 540 (defun read-cursor-row (cursor)
 541   (let* ((connection (postgresql-cursor-connection cursor))
 542          (socket (postgresql-connection-socket connection))
 543          (fields (postgresql-cursor-fields cursor)))
 544     (assert (postgresql-connection-open-p connection))
 545     (loop
 546         (let ((code (read-socket-value 'int8 socket)))
 547           (case code
 548             (#.+ascii-row-message+
 549              (return
 550                (loop with count = (length fields)
 551                      with null-vector = (read-null-bit-vector socket count)
 552                      repeat count
 553                      for null-bit across null-vector
 554                      for null-p = (zerop null-bit)
 555                      if null-p
 556                      collect nil
 557                      else
 558                      collect
 559                      (let* ((length (read-socket-value 'int32 socket))
 560                             (result (make-string (- length 4))))
 561                        (read-sequence result socket)
 562                        result))))
 563             (#.+binary-row-message+
 564              (error "NYI"))
 565             (#.+completed-response-message+
 566              (return (values nil (read-socket-value 'string socket))))
 567             (#.+error-response-message+
 568              (let ((message (read-socket-value 'string socket)))
 569                (error 'postgresql-error
 570                       :connection connection :message message)))
 571             (#.+notice-response-message+
 572              (let ((message (read-socket-value 'string socket)))
 573                (warn 'postgresql-warning
 574                      :connection connection :message message)))
 575             (#.+notification-response-message+
 576              (let ((pid (read-socket-value 'int32 socket))
 577                    (message (read-socket-value 'string socket)))
 578                (when (= pid (postgresql-connection-pid connection))
 579                  (signal 'postgresql-notification :connection connection
 580                          :message message))))
 581             (t
 582              (close-postgresql-connection connection)
 583              (error 'postgresql-fatal-error :connection connection
 584                     :message "Received garbled message from backend")))))))
 585
 586 (defun copy-cursor-row (cursor sequence)
 587   (let* ((connection (postgresql-cursor-connection cursor))
 588          (socket (postgresql-connection-socket connection))
 589          (fields (postgresql-cursor-fields cursor)))
 590     (assert (= (length fields) (length sequence)))
 591     (loop
 592         (let ((code (read-socket-value 'int8 socket)))
 593           (case code
 594             (#.+ascii-row-message+
 595              (return
 596                (map-into
 597                 sequence
 598                 #'(lambda (null-bit)
 599                     (if (zerop null-bit)
 600                         nil
 601                         (let* ((length (read-socket-value 'int32 socket))
 602                                (result (make-string (- length 4))))
 603                           (read-sequence result socket)
 604                           result)))
 605                 (read-null-bit-vector socket (length sequence)))))
 606             (#.+binary-row-message+
 607              (error "NYI"))
 608             (#.+completed-response-message+
 609              (return (values nil (read-socket-value 'string socket))))
 610             (#.+error-response-message+
 611              (let ((message (read-socket-value 'string socket)))
 612                (error 'postgresql-error
 613                       :connection connection :message message)))
 614             (#.+notice-response-message+
 615              (let ((message (read-socket-value 'string socket)))
 616                (warn 'postgresql-warning
 617                      :connection connection :message message)))
 618             (#.+notification-response-message+
 619              (let ((pid (read-socket-value 'int32 socket))
 620                    (message (read-socket-value 'string socket)))
 621                (when (= pid (postgresql-connection-pid connection))
 622                  (signal 'postgresql-notification :connection connection
 623                          :message message))))
 624             (t
 625              (close-postgresql-connection connection)
 626              (error 'postgresql-fatal-error :connection connection
 627                     :message "Received garbled message from backend")))))))
 628
 629 (defun skip-cursor-row (cursor)
 630   (let* ((connection (postgresql-cursor-connection cursor))
 631          (socket (postgresql-connection-socket connection))
 632          (fields (postgresql-cursor-fields cursor)))
 633     (loop
 634         (let ((code (read-socket-value 'int8 socket)))
 635           (case code
 636             (#.+ascii-row-message+
 637              (loop for null-bit across
 638                    (read-null-bit-vector socket (length fields))
 639                    do
 640                    (unless (zerop null-bit)
 641                      (let* ((length (read-socket-value 'int32 socket)))
 642                        (loop repeat (- length 4) do (read-byte socket)))))
 643              (return t))
 644             (#.+binary-row-message+
 645              (error "NYI"))
 646             (#.+completed-response-message+
 647              (return (values nil (read-socket-value 'string socket))))
 648             (#.+error-response-message+
 649              (let ((message (read-socket-value 'string socket)))
 650                (error 'postgresql-error
 651                       :connection connection :message message)))
 652             (#.+notice-response-message+
 653              (let ((message (read-socket-value 'string socket)))
 654                (warn 'postgresql-warning
 655                      :connection connection :message message)))
 656             (#.+notification-response-message+
 657              (let ((pid (read-socket-value 'int32 socket))
 658                    (message (read-socket-value 'string socket)))
 659                (when (= pid (postgresql-connection-pid connection))
 660                  (signal 'postgresql-notification :connection connection
 661                          :message message))))
 662             (t
 663              (close-postgresql-connection connection)
 664              (error 'postgresql-fatal-error :connection connection
 665                     :message "Received garbled message from backend")))))))
 666
 667 (defun run-query (connection query)
 668   (start-query-execution connection query)
 669   (multiple-value-bind (status cursor)
 670       (wait-for-query-results connection)
 671     (assert (eq status :cursor))
 672     (loop for row = (read-cursor-row cursor)
 673           while row
 674           collect row
 675           finally
 676           (wait-for-query-results connection))))