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

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