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