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