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