db-postgresql-socket/postgresql-socket-api.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:     postgresql-socket-api.lisp
   6 ;;;; Purpose:  Low-level PostgreSQL interface using sockets
   7 ;;;; Authors:  Kevin M. Rosenberg based on original code by Pierre R. Mai
   8 ;;;; Created:  Feb 2002
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
  13 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
  14 ;;;;
  15 ;;;; CLSQL users are granted the rights to distribute and use this software
  16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  18 ;;;; *************************************************************************
  19
  20 (in-package #:postgresql-socket)
  21
  22 (uffi:def-enum pgsql-ftype
  23     ((:bytea 17)
  24      (:int2 21)
  25      (:int4 23)
  26      (:int8 20)
  27      (:float4 700)
  28      (:float8 701)))
  29
  30 (defmethod clsql-sys:database-type-library-loaded ((database-type
  31                                           (eql :postgresql-socket)))
  32   "T if foreign library was able to be loaded successfully. Always true for
  33 socket interface"
  34   t)
  35
  36 (defmethod clsql-sys:database-type-load-foreign ((database-type (eql :postgresql-socket)))
  37   t)
  38
  39
  40 ;;; Message I/O stuff
  41
  42 (defmacro define-message-constants (description &rest clauses)
  43   (assert (evenp (length clauses)))
  44   (loop with seen-characters = nil
  45         for (name char) on clauses by #'cddr
  46         for char-code = (char-code char)
  47         for doc-string = (format nil "~A (~:C): ~A" description char name)
  48         if (member char seen-characters)
  49         do (error "Duplicate message type ~@C for group ~A" char description)
  50         else
  51         collect
  52         `(defconstant ,name ,char-code ,doc-string)
  53         into result-clauses
  54         and do (push char seen-characters)
  55       finally
  56         (return `(progn ,@result-clauses))))
  57
  58 (eval-when (:compile-toplevel :load-toplevel :execute)
  59 (define-message-constants "Backend Message Constants"
  60   +ascii-row-message+ #\D
  61   +authentication-message+ #\R
  62   +backend-key-message+ #\K
  63   +binary-row-message+ #\B
  64   +completed-response-message+ #\C
  65   +copy-in-response-message+ #\G
  66   +copy-out-response-message+ #\H
  67   +cursor-response-message+ #\P
  68   +empty-query-response-message+ #\I
  69   +error-response-message+ #\E
  70   +function-response-message+ #\V
  71   +notice-response-message+ #\N
  72   +notification-response-message+ #\A
  73   +ready-for-query-message+ #\Z
  74   +row-description-message+ #\T))
  75
  76 #+scl
  77 (declaim (inline read-byte write-byte))
  78
  79 (defun send-socket-value-int32 (socket value)
  80   (declare (type stream socket)
  81            (type (unsigned-byte 32) value))
  82   (write-byte (ldb (byte 8 24) value) socket)
  83   (write-byte (ldb (byte 8 16) value) socket)
  84   (write-byte (ldb (byte 8 8) value) socket)
  85   (write-byte (ldb (byte 8 0) value) socket)
  86   nil)
  87
  88 (defun send-socket-value-int16 (socket value)
  89   (declare (type stream socket)
  90            (type (unsigned-byte 16) value))
  91   (write-byte (ldb (byte 8 8) value) socket)
  92   (write-byte (ldb (byte 8 0) value) socket)
  93   nil)
  94
  95 (defun send-socket-value-int8 (socket value)
  96   (declare (type stream socket)
  97            (type (unsigned-byte 8) value))
  98   (write-byte (ldb (byte 8 0) value) socket)
  99   nil)
 100
 101 (defun send-socket-value-char-code (socket value)
 102   (declare (type stream socket)
 103            (type character value))
 104   (write-byte (ldb (byte 8 0) (char-code value)) socket)
 105   nil)
 106
 107 (defun send-socket-value-string (socket value)
 108   (declare (type stream socket)
 109            (type string value))
 110   #-sb-unicode
 111   (loop for char across value
 112         for code = (char-code char)
 113         do (write-byte code socket)
 114         finally (write-byte 0 socket))
 115   #+sb-unicode
 116   (write-sequence (sb-ext:string-to-octets value :null-terminate t) socket)
 117   nil)
 118
 119 (defun send-socket-value-limstring (socket value limit)
 120   (declare (type stream socket)
 121            (type string value)
 122            (type fixnum limit))
 123   (let ((length (length value)))
 124     (dotimes (i (min length limit))
 125       (let ((code (char-code (char value i))))
 126         (write-byte code socket)))
 127     (dotimes (i (- limit length))
 128       (write-byte 0 socket)))
 129   nil)
 130
 131
 132 (defun read-socket-value-int32 (socket)
 133   (declare (type stream socket))
 134   (declare (optimize (speed 3)))
 135   (let ((result 0))
 136     (declare (type (unsigned-byte 32) result))
 137     (setf (ldb (byte 8 24) result) (read-byte socket))
 138     (setf (ldb (byte 8 16) result) (read-byte socket))
 139     (setf (ldb (byte 8 8) result) (read-byte socket))
 140     (setf (ldb (byte 8 0) result) (read-byte socket))
 141     result))
 142
 143 (defun read-socket-value-int16 (socket)
 144   (declare (type stream socket))
 145   (let ((result 0))
 146     (declare (type (unsigned-byte 16) result))
 147     (setf (ldb (byte 8 8) result) (read-byte socket))
 148     (setf (ldb (byte 8 0) result) (read-byte socket))
 149     result))
 150
 151 (defun read-socket-value-int8 (socket)
 152   (declare (type stream socket))
 153   (read-byte socket))
 154
 155 (defun read-socket-value-string (socket)
 156   (declare (type stream socket))
 157   #-sb-unicode
 158   (with-output-to-string (out)
 159     (loop for code = (read-byte socket)
 160           until (zerop code)
 161           do (write-char (code-char code) out)))
 162   #+sb-unicode
 163   (let ((bytes (make-array 64
 164                            :element-type '(unsigned-byte 8)
 165                            :adjustable t
 166                            :fill-pointer 0)))
 167     (loop for code = (read-byte socket)
 168           until (zerop code)
 169           do (vector-push-extend code bytes))
 170     (sb-ext:octets-to-string bytes)))
 171
 172
 173 (defmacro define-message-sender (name (&rest args) &rest clauses)
 174   (let ((socket-var (gensym))
 175         (body nil))
 176     (dolist (clause clauses)
 177       (let* ((type (first clause))
 178              (fn (intern (concatenate 'string (symbol-name '#:send-socket-value-)
 179                                       (symbol-name type)))))
 180         (push `(,fn ,socket-var ,@(rest clause)) body)))
 181     `(defun ,name (,socket-var ,@args)
 182        ,@(nreverse body))))
 183
 184 (define-message-sender send-startup-message
 185     (database user &optional (command-line "") (backend-tty ""))
 186   (int32 296)                           ; Length
 187   (int32 #x00020000)                    ; Version 2.0
 188   (limstring database 64)
 189   (limstring user 32)
 190   (limstring command-line 64)
 191   (limstring "" 64)     ; Unused
 192   (limstring backend-tty 64))
 193
 194 (define-message-sender send-terminate-message ()
 195   (char-code #\X))
 196
 197 (define-message-sender send-unencrypted-password-message (password)
 198   (int32 (+ 5 (length password)))
 199   (string password))
 200
 201 (define-message-sender send-query-message (query)
 202   (char-code #\Q)
 203   (string query))
 204
 205 (define-message-sender send-encrypted-password-message (crypted-password)
 206   (int32 (+ 5 (length crypted-password)))
 207   (string crypted-password))
 208
 209 (define-message-sender send-cancel-request (pid key)
 210   (int32 16)                            ; Length
 211   (int32 80877102)                      ; Magic
 212   (int32 pid)
 213   (int32 key))
 214
 215
 216 (defun read-socket-sequence (stream length &optional (allow-wide t))
 217   (declare (stream stream)
 218            (optimize (speed 3) (safety 0)))
 219   #-sb-unicode
 220   (let ((result (make-string length)))
 221     (dotimes (i length result)
 222       (declare (fixnum i))
 223       (setf (char result i) (code-char (read-byte stream)))))
 224   #+sb-unicode
 225   (let ((bytes (make-array length :element-type '(unsigned-byte 8))))
 226     (declare (type (simple-array (unsigned-byte 8) (*)) bytes))
 227     (read-sequence bytes stream)
 228     (if allow-wide
 229         (sb-ext:octets-to-string bytes)
 230         (map 'string #'code-char bytes))))
 231
 232 ;;; Support for encrypted password transmission
 233
 234 #-scl
 235 (eval-when (:compile-toplevel :load-toplevel :execute)
 236   (defvar *crypt-library-loaded* nil)
 237
 238   (unless *crypt-library-loaded*
 239     (uffi:load-foreign-library
 240      (uffi:find-foreign-library "libcrypt"
 241                            '(#+(or 64bit x86-64) "/usr/lib64/"
 242                              "/usr/lib/" "/usr/local/lib/" "/lib/"))
 243      :supporting-libraries '("c"))
 244     (setq *crypt-library-loaded* t)))
 245
 246 (in-package :postgresql-socket)
 247
 248 (uffi:def-function ("crypt" crypt)
 249     ((key :cstring)
 250      (salt :cstring))
 251   :returning :cstring)
 252
 253 (defun crypt-password (password salt)
 254   "Encrypt a password for transmission to a PostgreSQL server."
 255   (uffi:with-cstring (password-cstring password)
 256     (uffi:with-cstring (salt-cstring salt)
 257       (uffi:convert-from-cstring
 258        (crypt password-cstring salt-cstring)))))
 259
 260 \f
 261 ;;;; Condition hierarchy
 262
 263 (define-condition postgresql-condition (condition)
 264   ((connection :initarg :connection :reader postgresql-condition-connection)
 265    (message :initarg :message :reader postgresql-condition-message))
 266   (:report
 267    (lambda (c stream)
 268      (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>"
 269              (type-of c)
 270              (postgresql-condition-connection c)
 271              (postgresql-condition-message c)))))
 272
 273 (define-condition postgresql-error (error postgresql-condition)
 274   ())
 275
 276 (define-condition postgresql-fatal-error (postgresql-error)
 277   ())
 278
 279 (define-condition postgresql-login-error (postgresql-fatal-error)
 280   ())
 281
 282 (define-condition postgresql-warning (warning postgresql-condition)
 283   ())
 284
 285 (define-condition postgresql-notification (postgresql-condition)
 286   ()
 287   (:report
 288    (lambda (c stream)
 289      (format stream "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
 290              (postgresql-condition-connection c)
 291              (postgresql-condition-message c)))))
 292
 293 ;;; Structures
 294
 295 (defstruct postgresql-connection
 296   host
 297   port
 298   database
 299   user
 300   password
 301   options
 302   tty
 303   socket
 304   pid
 305   key)
 306
 307 (defstruct postgresql-cursor
 308   connection
 309   name
 310   fields)
 311
 312 ;;; Socket stuff
 313
 314 (defconstant +postgresql-server-default-port+ 5432
 315   "Default port of PostgreSQL server.")
 316
 317 (defvar *postgresql-server-socket-timeout* 60
 318   "Timeout in seconds for reads from the PostgreSQL server.")
 319
 320 #+(or cmu scl)
 321 (defun open-postgresql-socket (host port)
 322   (etypecase host
 323     (pathname
 324      ;; Directory to unix-domain socket
 325      (ext:connect-to-unix-socket
 326       (namestring
 327        (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 328                       :defaults host))))
 329     (string
 330      (ext:connect-to-inet-socket host port))))
 331
 332 #+sbcl
 333 (defun open-postgresql-socket (host port)
 334   (etypecase host
 335     (pathname
 336      ;; Directory to unix-domain socket
 337      (let ((sock (make-instance 'sb-bsd-sockets:local-socket
 338                                 :type :stream)))
 339        (sb-bsd-sockets:socket-connect
 340         sock
 341         (namestring
 342          (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 343                         :defaults host)))
 344        sock))
 345     (string
 346      (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
 347                                 :type :stream
 348                                 :protocol :tcp)))
 349        (sb-bsd-sockets:socket-connect
 350         sock
 351         (sb-bsd-sockets:host-ent-address
 352          (sb-bsd-sockets:get-host-by-name host))
 353         port)
 354        sock))))
 355
 356 #+(or cmu scl)
 357 (defun open-postgresql-socket-stream (host port)
 358   (system:make-fd-stream
 359    (open-postgresql-socket host port)
 360    :input t :output t :element-type '(unsigned-byte 8)
 361    :buffering :none
 362    :timeout *postgresql-server-socket-timeout*))
 363
 364
 365 #+sbcl
 366 (defun open-postgresql-socket-stream (host port)
 367   (sb-bsd-sockets:socket-make-stream
 368    (open-postgresql-socket host port) :input t :output t
 369    :element-type '(unsigned-byte 8)))
 370
 371
 372 #+allegro
 373 (defun open-postgresql-socket-stream (host port)
 374   (etypecase host
 375     (pathname
 376      (let ((path (namestring
 377                   (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 378                                  :defaults host))))
 379        (socket:make-socket :type :stream :address-family :file
 380                            :connect :active
 381                            :remote-filename path :local-filename path)))
 382     (string
 383      (socket:with-pending-connect
 384          (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed"))
 385            (socket:make-socket :type :stream :address-family :internet
 386                                :remote-port port :remote-host host
 387                                :connect :active :nodelay t))))))
 388
 389 #+openmcl
 390 (defun open-postgresql-socket-stream (host port)
 391   (etypecase host
 392     (pathname
 393      (let ((path (namestring
 394                   (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 395                                  :defaults host))))
 396        (ccl:make-socket :type :stream :address-family :file
 397                         :connect :active
 398                         :remote-filename path :local-filename path)))
 399     (string
 400      (ccl:make-socket :type :stream :address-family :internet
 401                       :remote-port port :remote-host host
 402                       :connect :active :nodelay t))))
 403
 404 #+lispworks
 405 (defun open-postgresql-socket-stream (host port)
 406   (etypecase host
 407     (pathname
 408      (error "File sockets not supported on Lispworks."))
 409     (string
 410      (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8)
 411                            :read-timeout *postgresql-server-socket-timeout*))
 412     ))
 413
 414
 415 #+clisp
 416 (defun open-postgresql-socket-stream (host port)
 417   (etypecase host
 418     (pathname
 419      (error "Not supported"))
 420     (string
 421      (socket:socket-connect
 422       port host
 423       :element-type '(unsigned-byte 8)
 424       :timeout *postgresql-server-socket-timeout*))))
 425
 426
 427 ;;; Interface Functions
 428
 429 (defun open-postgresql-connection (&key (host (cmucl-compat:required-argument))
 430                                         (port +postgresql-server-default-port+)
 431                                         (database (cmucl-compat:required-argument))
 432                                         (user (cmucl-compat:required-argument))
 433                                         options tty password)
 434   "Open a connection to a PostgreSQL server with the given parameters.
 435 Note that host, database and user arguments must be supplied.
 436
 437 If host is a pathname, it is assumed to name a directory containing
 438 the local unix-domain sockets of the server, with port selecting which
 439 of those sockets to open.  If host is a string, it is assumed to be
 440 the name of the host running the PostgreSQL server.  In that case a
 441 TCP connection to the given port on that host is opened in order to
 442 communicate with the server.  In either case the port argument
 443 defaults to `+postgresql-server-default-port+'.
 444
 445 Password is the clear-text password to be passed in the authentication
 446 phase to the server.  Depending on the server set-up, it is either
 447 passed in the clear, or encrypted via crypt and a server-supplied
 448 salt.  In that case the alien function specified by `*crypt-library*'
 449 and `*crypt-function-name*' is used for encryption.
 450
 451 Note that all the arguments (including the clear-text password
 452 argument) are stored in the `postgresql-connection' structure, in
 453 order to facilitate automatic reconnection in case of communication
 454 troubles."
 455   (reopen-postgresql-connection
 456    (make-postgresql-connection :host host :port port
 457                                :options (or options "") :tty (or tty "")
 458                                :database database :user user
 459                                :password (or password ""))))
 460
 461 (defun encrypt-md5 (plaintext salt)
 462   (string-downcase
 463    (format nil "~{~2,'0X~}"
 464            (coerce (md5sum-sequence (concatenate 'string plaintext salt)) 'list))))
 465
 466 (defun reopen-postgresql-connection (connection)
 467   "Reopen the given PostgreSQL connection.  Closes any existing
 468 connection, if it is still open."
 469   (when (postgresql-connection-open-p connection)
 470     (close-postgresql-connection connection))
 471   (let ((socket (open-postgresql-socket-stream
 472                   (postgresql-connection-host connection)
 473                   (postgresql-connection-port connection))))
 474     (unwind-protect
 475          (progn
 476            (setf (postgresql-connection-socket connection) socket)
 477            (send-startup-message socket
 478                                  (postgresql-connection-database connection)
 479                                  (postgresql-connection-user connection)
 480                                  (postgresql-connection-options connection)
 481                                  (postgresql-connection-tty connection))
 482            (force-output socket)
 483            (loop
 484                (case (read-socket-value-int8 socket)
 485                  (#.+authentication-message+
 486                   (case (read-socket-value-int32 socket)
 487                     (0 (return))
 488                     ((1 2)
 489                      (error 'postgresql-login-error
 490                             :connection connection
 491                             :message
 492                             "Postmaster expects unsupported Kerberos authentication."))
 493                     (3
 494                      (send-unencrypted-password-message
 495                       socket
 496                       (postgresql-connection-password connection))
 497                       (force-output socket))
 498                     (4
 499                      (let ((salt (read-socket-sequence socket 2 nil)))
 500                        (send-encrypted-password-message
 501                         socket
 502                         (crypt-password
 503                          (postgresql-connection-password connection) salt)))
 504                      (force-output socket))
 505                     (5
 506                      (let ((salt (read-socket-sequence socket 4 nil)))
 507                        (let* ((pwd2 (encrypt-md5 (postgresql-connection-password connection)
 508                                                  (postgresql-connection-user connection)))
 509                               (pwd (encrypt-md5 pwd2 salt)))
 510                          (send-encrypted-password-message
 511                           socket
 512                           (concatenate 'string "md5" pwd))))
 513                      (force-output socket))
 514                     (t
 515                      (error 'postgresql-login-error
 516                             :connection connection
 517                             :message
 518                             "Postmaster expects unknown authentication method."))))
 519                  (#.+error-response-message+
 520                   (let ((message (read-socket-value-string socket)))
 521                     (error 'postgresql-login-error
 522                            :connection connection :message message)))
 523                  (t
 524                   (error 'postgresql-login-error
 525                          :connection connection
 526                          :message
 527                          "Received garbled message from Postmaster"))))
 528            ;; Start backend communication
 529            (force-output socket)
 530            (loop
 531                (case (read-socket-value-int8 socket)
 532                  (#.+backend-key-message+
 533                   (setf (postgresql-connection-pid connection)
 534                         (read-socket-value-int32 socket)
 535                         (postgresql-connection-key connection)
 536                         (read-socket-value-int32 socket)))
 537                  (#.+ready-for-query-message+
 538                   (setq socket nil)
 539                   (return connection))
 540                  (#.+error-response-message+
 541                   (let ((message (read-socket-value-string socket)))
 542                     (error 'postgresql-login-error
 543                            :connection connection
 544                            :message message)))
 545                  (#.+notice-response-message+
 546                   (let ((message (read-socket-value-string socket)))
 547                     (warn 'postgresql-warning :connection connection
 548                           :message message)))
 549                  (t
 550                   (error 'postgresql-login-error
 551                          :connection connection
 552                          :message
 553                          "Received garbled message from Postmaster")))))
 554       (when socket
 555         (close socket)))))
 556
 557 (defun close-postgresql-connection (connection &optional abort)
 558   (unless abort
 559     (ignore-errors
 560       (send-terminate-message (postgresql-connection-socket connection))))
 561   (close (postgresql-connection-socket connection)))
 562
 563 (defun postgresql-connection-open-p (connection)
 564   (let ((socket (postgresql-connection-socket connection)))
 565     (and socket (streamp socket) (open-stream-p socket))))
 566
 567 (defun ensure-open-postgresql-connection (connection)
 568   (unless (postgresql-connection-open-p connection)
 569     (reopen-postgresql-connection connection)))
 570
 571 (defun process-async-messages (connection)
 572   (assert (postgresql-connection-open-p connection))
 573   ;; Process any asnychronous messages
 574   (loop with socket = (postgresql-connection-socket connection)
 575         while (listen socket)
 576         do
 577         (case (read-socket-value-int8 socket)
 578           (#.+ready-for-query-message+)
 579           (#.+notice-response-message+
 580            (let ((message (read-socket-value-string socket)))
 581              (warn 'postgresql-warning :connection connection
 582                    :message message)))
 583           (#.+notification-response-message+
 584            (let ((pid (read-socket-value-int32 socket))
 585                  (message (read-socket-value-string socket)))
 586              (when (= pid (postgresql-connection-pid connection))
 587                (signal 'postgresql-notification :connection connection
 588                        :message message))))
 589           (t
 590            (close-postgresql-connection connection)
 591            (error 'postgresql-fatal-error :connection connection
 592                   :message "Received garbled message from backend")))))
 593
 594 (defun start-query-execution (connection query)
 595   (ensure-open-postgresql-connection connection)
 596   (process-async-messages connection)
 597   (send-query-message (postgresql-connection-socket connection) query)
 598   (force-output (postgresql-connection-socket connection)))
 599
 600 (defun wait-for-query-results (connection)
 601   (assert (postgresql-connection-open-p connection))
 602   (let ((socket (postgresql-connection-socket connection))
 603         (cursor-name nil)
 604         (error nil))
 605     (loop
 606         (case (read-socket-value-int8 socket)
 607           (#.+completed-response-message+
 608            (return (values :completed (read-socket-value-string socket))))
 609           (#.+cursor-response-message+
 610            (setq cursor-name (read-socket-value-string socket)))
 611           (#.+row-description-message+
 612            (let* ((count (read-socket-value-int16 socket))
 613                   (fields
 614                    (loop repeat count
 615                      collect
 616                      (list
 617                       (read-socket-value-string socket)
 618                       (read-socket-value-int32 socket)
 619                       (read-socket-value-int16 socket)
 620                       (read-socket-value-int32 socket)))))
 621              (return
 622                (values :cursor
 623                        (make-postgresql-cursor :connection connection
 624                                                :name cursor-name
 625                                                :fields fields)))))
 626           (#.+copy-in-response-message+
 627            (return :copy-in))
 628           (#.+copy-out-response-message+
 629            (return :copy-out))
 630           (#.+ready-for-query-message+
 631            (when error
 632              (error error))
 633            (return nil))
 634           (#.+error-response-message+
 635            (let ((message (read-socket-value-string socket)))
 636              (setq error
 637                    (make-condition 'postgresql-error
 638                                    :connection connection :message message))))
 639           (#.+notice-response-message+
 640            (let ((message (read-socket-value-string socket)))
 641              (unless (eq :ignore clsql-sys:*backend-warning-behavior*)
 642                (warn 'postgresql-warning
 643                      :connection connection :message message))))
 644           (#.+notification-response-message+
 645            (let ((pid (read-socket-value-int32 socket))
 646                  (message (read-socket-value-string socket)))
 647              (when (= pid (postgresql-connection-pid connection))
 648                (signal 'postgresql-notification :connection connection
 649                        :message message))))
 650           (t
 651            (close-postgresql-connection connection)
 652            (error 'postgresql-fatal-error :connection connection
 653                   :message "Received garbled message from backend"))))))
 654
 655 (defun read-null-bit-vector (socket count)
 656   (let ((result (make-array count :element-type 'bit)))
 657     (dotimes (offset (ceiling count 8))
 658       (loop with byte = (read-byte socket)
 659             for index from (* offset 8) below (min count (* (1+ offset) 8))
 660             for weight downfrom 7
 661             do (setf (aref result index) (ldb (byte 1 weight) byte))))
 662     result))
 663
 664
 665 (defun read-field (socket type)
 666   (let ((length (- (read-socket-value-int32 socket) 4)))
 667     (case type
 668       ((:int32 :int64)
 669        (read-integer-from-socket socket length))
 670       (:double
 671        (read-double-from-socket socket length))
 672       (t
 673        (read-socket-sequence socket length)))))
 674
 675 (uffi:def-constant +char-code-zero+ (char-code #\0))
 676 (uffi:def-constant +char-code-minus+ (char-code #\-))
 677 (uffi:def-constant +char-code-plus+ (char-code #\+))
 678 (uffi:def-constant +char-code-period+ (char-code #\.))
 679 (uffi:def-constant +char-code-lower-e+ (char-code #\e))
 680 (uffi:def-constant +char-code-upper-e+ (char-code #\E))
 681
 682 (defun read-integer-from-socket (socket length)
 683   (declare (fixnum length))
 684   (if (zerop length)
 685       nil
 686     (let ((val 0)
 687           (first-char (read-byte socket))
 688           (minusp nil))
 689       (declare (fixnum first-char))
 690       (decf length) ;; read first char
 691       (cond
 692        ((= first-char +char-code-minus+)
 693         (setq minusp t))
 694        ((= first-char +char-code-plus+)
 695         )               ;; nothing to do
 696        (t
 697         (setq val (- first-char +char-code-zero+))))
 698
 699       (dotimes (i length)
 700         (declare (fixnum i))
 701         (setq val (+
 702                    (* 10 val)
 703                    (- (read-byte socket) +char-code-zero+))))
 704       (if minusp
 705           (- val)
 706         val))))
 707
 708 (defmacro ascii-digit (int)
 709   (let ((offset (gensym)))
 710     `(let ((,offset (- ,int +char-code-zero+)))
 711       (declare (fixnum ,int ,offset))
 712       (if (and (>= ,offset 0)
 713                (< ,offset 10))
 714           ,offset
 715           nil))))
 716
 717 (defun read-double-from-socket (socket length)
 718   (declare (fixnum length))
 719   (let ((before-decimal 0)
 720         (after-decimal 0)
 721         (decimal-count 0)
 722         (exponent 0)
 723         (decimalp nil)
 724         (minusp nil)
 725         (result nil)
 726         (char (read-byte socket)))
 727     (declare (fixnum char exponent decimal-count))
 728     (decf length) ;; already read first character
 729     (cond
 730       ((= char +char-code-minus+)
 731        (setq minusp t))
 732       ((= char +char-code-plus+)
 733        )
 734       ((= char +char-code-period+)
 735        (setq decimalp t))
 736       (t
 737        (setq before-decimal (ascii-digit char))
 738        (unless before-decimal
 739          (error "Unexpected value"))))
 740
 741     (block loop
 742       (dotimes (i length)
 743         (setq char (read-byte socket))
 744         ;;      (format t "~&len:~D, i:~D, char:~D, minusp:~A, decimalp:~A" length i char minusp decimalp)
 745         (let ((weight (ascii-digit char)))
 746           (cond
 747            ((and weight (not decimalp)) ;; before decimal point
 748             (setq before-decimal (+ weight (* 10 before-decimal))))
 749            ((and weight decimalp) ;; after decimal point
 750             (setq after-decimal (+ weight (* 10 after-decimal)))
 751             (incf decimal-count))
 752            ((and (= char +char-code-period+))
 753             (setq decimalp t))
 754            ((or (= char +char-code-lower-e+)          ;; E is for exponent
 755                 (= char +char-code-upper-e+))
 756             (setq exponent (read-integer-from-socket socket (- length i 1)))
 757             (setq exponent (or exponent 0))
 758             (return-from loop))
 759           (t
 760            (break "Unexpected value"))
 761           )
 762         )))
 763     (setq result (* (+ (coerce before-decimal 'double-float)
 764                        (* after-decimal
 765                           (expt 10 (- decimal-count))))
 766                     (expt 10 exponent)))
 767     (if minusp
 768         (- result)
 769         result)))
 770
 771
 772 #+ignore
 773 (defun read-double-from-socket (socket length)
 774   (let ((result (make-string length)))
 775     (read-socket-sequence result socket)
 776     (let ((*read-default-float-format* 'double-float))
 777       (read-from-string result))))
 778
 779 (defun read-cursor-row (cursor types)
 780   (let* ((connection (postgresql-cursor-connection cursor))
 781          (socket (postgresql-connection-socket connection))
 782          (fields (postgresql-cursor-fields cursor)))
 783     (assert (postgresql-connection-open-p connection))
 784     (loop
 785         (let ((code (read-socket-value-int8 socket)))
 786           (case code
 787             (#.+ascii-row-message+
 788              (return
 789                (loop with count = (length fields)
 790                      with null-vector = (read-null-bit-vector socket count)
 791                      repeat count
 792                      for null-bit across null-vector
 793                      for i from 0
 794                      for null-p = (zerop null-bit)
 795                      if null-p
 796                      collect nil
 797                      else
 798                      collect
 799                      (read-field socket (nth i types)))))
 800             (#.+binary-row-message+
 801              (error "NYI"))
 802             (#.+completed-response-message+
 803              (return (values nil (read-socket-value-string socket))))
 804             (#.+error-response-message+
 805              (let ((message (read-socket-value-string socket)))
 806                (error 'postgresql-error
 807                       :connection connection :message message)))
 808             (#.+notice-response-message+
 809              (let ((message (read-socket-value-string socket)))
 810                (warn 'postgresql-warning
 811                      :connection connection :message message)))
 812             (#.+notification-response-message+
 813              (let ((pid (read-socket-value-int32 socket))
 814                    (message (read-socket-value-string socket)))
 815                (when (= pid (postgresql-connection-pid connection))
 816                  (signal 'postgresql-notification :connection connection
 817                          :message message))))
 818             (t
 819              (close-postgresql-connection connection)
 820              (error 'postgresql-fatal-error :connection connection
 821                     :message "Received garbled message from backend")))))))
 822
 823 (defun map-into-indexed (result-seq func seq)
 824   (dotimes (i (length seq))
 825     (declare (fixnum i))
 826     (setf (elt result-seq i)
 827           (funcall func (elt seq i) i)))
 828   result-seq)
 829
 830 (defun copy-cursor-row (cursor sequence types)
 831   (let* ((connection (postgresql-cursor-connection cursor))
 832          (socket (postgresql-connection-socket connection))
 833          (fields (postgresql-cursor-fields cursor)))
 834     (assert (= (length fields) (length sequence)))
 835     (loop
 836         (let ((code (read-socket-value-int8 socket)))
 837           (case code
 838             (#.+ascii-row-message+
 839              (return
 840                #+ignore
 841                (let* ((count (length sequence))
 842                       (null-vector (read-null-bit-vector socket count)))
 843                  (dotimes (i count)
 844                    (declare (fixnum i))
 845                    (if (zerop (elt null-vector i))
 846                        (setf (elt sequence i) nil)
 847                        (let ((value (read-field socket (nth i types))))
 848                          (setf (elt sequence i) value)))))
 849                (map-into-indexed
 850                 sequence
 851                 #'(lambda (null-bit i)
 852                     (if (zerop null-bit)
 853                         nil
 854                         (read-field socket (nth i types))))
 855                 (read-null-bit-vector socket (length sequence)))))
 856             (#.+binary-row-message+
 857              (error "NYI"))
 858             (#.+completed-response-message+
 859              (return (values nil (read-socket-value-string socket))))
 860             (#.+error-response-message+
 861              (let ((message (read-socket-value-string socket)))
 862                (error 'postgresql-error
 863                       :connection connection :message message)))
 864             (#.+notice-response-message+
 865              (let ((message (read-socket-value-string socket)))
 866                (warn 'postgresql-warning
 867                      :connection connection :message message)))
 868             (#.+notification-response-message+
 869              (let ((pid (read-socket-value-int32 socket))
 870                    (message (read-socket-value-string socket)))
 871                (when (= pid (postgresql-connection-pid connection))
 872                  (signal 'postgresql-notification :connection connection
 873                          :message message))))
 874             (t
 875              (close-postgresql-connection connection)
 876              (error 'postgresql-fatal-error :connection connection
 877                     :message "Received garbled message from backend")))))))
 878
 879 (defun skip-cursor-row (cursor)
 880   (let* ((connection (postgresql-cursor-connection cursor))
 881          (socket (postgresql-connection-socket connection))
 882          (fields (postgresql-cursor-fields cursor)))
 883     (loop
 884         (let ((code (read-socket-value-int8 socket)))
 885           (case code
 886             (#.+ascii-row-message+
 887              (loop for null-bit across
 888                    (read-null-bit-vector socket (length fields))
 889                    do
 890                    (unless (zerop null-bit)
 891                      (let* ((length (read-socket-value-int32 socket)))
 892                        (loop repeat (- length 4) do (read-byte socket)))))
 893              (return t))
 894             (#.+binary-row-message+
 895              (error "NYI"))
 896             (#.+completed-response-message+
 897              (return (values nil (read-socket-value-string socket))))
 898             (#.+error-response-message+
 899              (let ((message (read-socket-value-string socket)))
 900                (error 'postgresql-error
 901                       :connection connection :message message)))
 902             (#.+notice-response-message+
 903              (let ((message (read-socket-value-string socket)))
 904                (warn 'postgresql-warning
 905                      :connection connection :message message)))
 906             (#.+notification-response-message+
 907              (let ((pid (read-socket-value-int32 socket))
 908                    (message (read-socket-value-string socket)))
 909                (when (= pid (postgresql-connection-pid connection))
 910                  (signal 'postgresql-notification :connection connection
 911                          :message message))))
 912             (t
 913              (close-postgresql-connection connection)
 914              (error 'postgresql-fatal-error :connection connection
 915                     :message "Received garbled message from backend")))))))
 916
 917 (defun run-query (connection query &optional (result-types nil))
 918   (start-query-execution connection query)
 919   (multiple-value-bind (status cursor)
 920       (wait-for-query-results connection)
 921     (assert (eq status :cursor))
 922     (loop for row = (read-cursor-row cursor result-types)
 923           while row
 924           collect row
 925           finally
 926           (wait-for-query-results connection))))
 927
 928 #+scl
 929 (declaim (ext:maybe-inline read-byte write-byte))