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

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