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