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 #+(or cmu scl)
 314 (defun open-postgresql-socket (host port)
 315   (etypecase host
 316     (pathname
 317      ;; Directory to unix-domain socket
 318      (ext:connect-to-unix-socket
 319       (namestring
 320        (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 321                       :defaults host))))
 322     (string
 323      (ext:connect-to-inet-socket host port))))
 324
 325 #+sbcl
 326 (defun open-postgresql-socket (host port)
 327   (etypecase host
 328     (pathname
 329      ;; Directory to unix-domain socket
 330      (sb-bsd-sockets:socket-connect
 331       (namestring
 332        (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 333                       :defaults host))))
 334     (string
 335      (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
 336                                 :type :stream
 337                                 :protocol :tcp)))
 338        (sb-bsd-sockets:socket-connect
 339         sock
 340         (sb-bsd-sockets:host-ent-address
 341          (sb-bsd-sockets:get-host-by-name host))
 342         port)
 343        sock))))
 344
 345 #+(or cmu scl)
 346 (defun open-postgresql-socket-stream (host port)
 347   (system:make-fd-stream
 348    (open-postgresql-socket host port)
 349    :input t :output t :element-type '(unsigned-byte 8)
 350    :buffering :none
 351    :timeout *postgresql-server-socket-timeout*))
 352
 353
 354 #+sbcl
 355 (defun open-postgresql-socket-stream (host port)
 356   (sb-bsd-sockets:socket-make-stream
 357    (open-postgresql-socket host port) :input t :output t
 358    :element-type '(unsigned-byte 8)))
 359
 360
 361 #+allegro
 362 (defun open-postgresql-socket-stream (host port)
 363   (etypecase host
 364     (pathname
 365      (let ((path (namestring
 366                   (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
 367                                  :defaults host))))
 368        (socket:make-socket :type :stream :address-family :file
 369                            :connect :active
 370                            :remote-filename path :local-filename path)))
 371     (string
 372      (socket:with-pending-connect
 373          (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed"))
 374            (socket:make-socket :type :stream :address-family :internet
 375                                :remote-port port :remote-host host
 376                                :connect :active :nodelay t))))))
 377
 378 #+openmcl
 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        (ccl: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            (ccl:make-socket :type :stream :address-family :internet
 392                             :remote-port port :remote-host host
 393                             :connect :active :nodelay t))))))
 394
 395 #+lispworks
 396 (defun open-postgresql-socket-stream (host port)
 397   (etypecase host
 398     (pathname
 399      (error "File sockets not supported on Lispworks."))
 400     (string
 401      (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8)
 402                            :read-timeout *postgresql-server-socket-timeout*))
 403     ))
 404
 405 ;;; Interface Functions
 406
 407 (defun open-postgresql-connection (&key (host (cmucl-compat:required-argument))
 408                                         (port +postgresql-server-default-port+)
 409                                         (database (cmucl-compat:required-argument))
 410                                         (user (cmucl-compat:required-argument))
 411                                         options tty password)
 412   "Open a connection to a PostgreSQL server with the given parameters.
 413 Note that host, database and user arguments must be supplied.
 414
 415 If host is a pathname, it is assumed to name a directory containing
 416 the local unix-domain sockets of the server, with port selecting which
 417 of those sockets to open.  If host is a string, it is assumed to be
 418 the name of the host running the PostgreSQL server.  In that case a
 419 TCP connection to the given port on that host is opened in order to
 420 communicate with the server.  In either case the port argument
 421 defaults to `+postgresql-server-default-port+'.
 422
 423 Password is the clear-text password to be passed in the authentication
 424 phase to the server.  Depending on the server set-up, it is either
 425 passed in the clear, or encrypted via crypt and a server-supplied
 426 salt.  In that case the alien function specified by `*crypt-library*'
 427 and `*crypt-function-name*' is used for encryption.
 428
 429 Note that all the arguments (including the clear-text password
 430 argument) are stored in the `postgresql-connection' structure, in
 431 order to facilitate automatic reconnection in case of communication
 432 troubles."
 433   (reopen-postgresql-connection
 434    (make-postgresql-connection :host host :port port
 435                                :options (or options "") :tty (or tty "")
 436                                :database database :user user
 437                                :password (or password ""))))
 438
 439 (defun encrypt-md5 (plaintext salt)
 440   (string-downcase
 441    (format nil "~{~2,'0X~}"
 442            (coerce (md5:md5sum-sequence (concatenate 'string plaintext salt)) 'list))))
 443
 444 (defun reopen-postgresql-connection (connection)
 445   "Reopen the given PostgreSQL connection.  Closes any existing
 446 connection, if it is still open."
 447   (when (postgresql-connection-open-p connection)
 448     (close-postgresql-connection connection))
 449   (let ((socket (open-postgresql-socket-stream
 450                   (postgresql-connection-host connection)
 451                   (postgresql-connection-port connection))))
 452     (unwind-protect
 453          (progn
 454            (setf (postgresql-connection-socket connection) socket)
 455            (send-startup-message socket
 456                                  (postgresql-connection-database connection)
 457                                  (postgresql-connection-user connection)
 458                                  (postgresql-connection-options connection)
 459                                  (postgresql-connection-tty connection))
 460            (force-output socket)
 461            (loop
 462                (case (read-socket-value-int8 socket)
 463                  (#.+authentication-message+
 464                   (case (read-socket-value-int32 socket)
 465                     (0 (return))
 466                     ((1 2)
 467                      (error 'postgresql-login-error
 468                             :connection connection
 469                             :message
 470                             "Postmaster expects unsupported Kerberos authentication."))
 471                     (3
 472                      (send-unencrypted-password-message
 473                       socket
 474                       (postgresql-connection-password connection)))
 475                     (4
 476                      (let ((salt (make-string 2)))
 477                        (read-socket-sequence salt socket)
 478                        (send-encrypted-password-message
 479                         socket
 480                         (crypt-password
 481                          (postgresql-connection-password connection) salt))))
 482                     (5
 483                      (let ((salt (make-string 4)))
 484                        (read-socket-sequence salt socket)
 485                        (let* ((pwd2 (encrypt-md5 (postgresql-connection-password connection)
 486                                                  (postgresql-connection-user connection)))
 487                               (pwd (encrypt-md5 pwd2 salt)))
 488                          (send-encrypted-password-message
 489                           socket
 490                           (concatenate 'string "md5" pwd)))))
 491                     (t
 492                      (error 'postgresql-login-error
 493                             :connection connection
 494                             :message
 495                             "Postmaster expects unknown authentication method."))))
 496                  (#.+error-response-message+
 497                   (let ((message (read-socket-value-string socket)))
 498                     (error 'postgresql-login-error
 499                            :connection connection :message message)))
 500                  (t
 501                   (error 'postgresql-login-error
 502                          :connection connection
 503                          :message
 504                          "Received garbled message from Postmaster"))))
 505            ;; Start backend communication
 506            (force-output socket)
 507            (loop
 508                (case (read-socket-value-int8 socket)
 509                  (#.+backend-key-message+
 510                   (setf (postgresql-connection-pid connection)
 511                         (read-socket-value-int32 socket)
 512                         (postgresql-connection-key connection)
 513                         (read-socket-value-int32 socket)))
 514                  (#.+ready-for-query-message+
 515                   (setq socket nil)
 516                   (return connection))
 517                  (#.+error-response-message+
 518                   (let ((message (read-socket-value-string socket)))
 519                     (error 'postgresql-login-error
 520                            :connection connection
 521                            :message message)))
 522                  (#.+notice-response-message+
 523                   (let ((message (read-socket-value-string socket)))
 524                     (warn 'postgresql-warning :connection connection
 525                           :message message)))
 526                  (t
 527                   (error 'postgresql-login-error
 528                          :connection connection
 529                          :message
 530                          "Received garbled message from Postmaster")))))
 531       (when socket
 532         (close socket)))))
 533
 534 (defun close-postgresql-connection (connection &optional abort)
 535   (unless abort
 536     (ignore-errors
 537       (send-terminate-message (postgresql-connection-socket connection))))
 538   (close (postgresql-connection-socket connection)))
 539
 540 (defun postgresql-connection-open-p (connection)
 541   (let ((socket (postgresql-connection-socket connection)))
 542     (and socket (streamp socket) (open-stream-p socket))))
 543
 544 (defun ensure-open-postgresql-connection (connection)
 545   (unless (postgresql-connection-open-p connection)
 546     (reopen-postgresql-connection connection)))
 547
 548 (defun process-async-messages (connection)
 549   (assert (postgresql-connection-open-p connection))
 550   ;; Process any asnychronous messages
 551   (loop with socket = (postgresql-connection-socket connection)
 552         while (listen socket)
 553         do
 554         (case (read-socket-value-int8 socket)
 555           (#.+notice-response-message+
 556            (let ((message (read-socket-value-string socket)))
 557              (warn 'postgresql-warning :connection connection
 558                    :message message)))
 559           (#.+notification-response-message+
 560            (let ((pid (read-socket-value-int32 socket))
 561                  (message (read-socket-value-string socket)))
 562              (when (= pid (postgresql-connection-pid connection))
 563                (signal 'postgresql-notification :connection connection
 564                        :message message))))
 565           (t
 566            (close-postgresql-connection connection)
 567            (error 'postgresql-fatal-error :connection connection
 568                   :message "Received garbled message from backend")))))
 569
 570 (defun start-query-execution (connection query)
 571   (ensure-open-postgresql-connection connection)
 572   (process-async-messages connection)
 573   (send-query-message (postgresql-connection-socket connection) query)
 574   (force-output (postgresql-connection-socket connection)))
 575
 576 (defun wait-for-query-results (connection)
 577   (assert (postgresql-connection-open-p connection))
 578   (let ((socket (postgresql-connection-socket connection))
 579         (cursor-name nil)
 580         (error nil))
 581     (loop
 582         (case (read-socket-value-int8 socket)
 583           (#.+completed-response-message+
 584            (return (values :completed (read-socket-value-string socket))))
 585           (#.+cursor-response-message+
 586            (setq cursor-name (read-socket-value-string socket)))
 587           (#.+row-description-message+
 588            (let* ((count (read-socket-value-int16 socket))
 589                   (fields
 590                    (loop repeat count
 591                      collect
 592                      (list
 593                       (read-socket-value-string socket)
 594                       (read-socket-value-int32 socket)
 595                       (read-socket-value-int16 socket)
 596                       (read-socket-value-int32 socket)))))
 597              (return
 598                (values :cursor
 599                        (make-postgresql-cursor :connection connection
 600                                                :name cursor-name
 601                                                :fields fields)))))
 602           (#.+copy-in-response-message+
 603            (return :copy-in))
 604           (#.+copy-out-response-message+
 605            (return :copy-out))
 606           (#.+ready-for-query-message+
 607            (when error
 608              (error error))
 609            (return nil))
 610           (#.+error-response-message+
 611            (let ((message (read-socket-value-string socket)))
 612              (setq error
 613                    (make-condition 'postgresql-error
 614                                    :connection connection :message message))))
 615           (#.+notice-response-message+
 616            (let ((message (read-socket-value-string socket)))
 617              (warn 'postgresql-warning
 618                    :connection connection :message message)))
 619           (#.+notification-response-message+
 620            (let ((pid (read-socket-value-int32 socket))
 621                  (message (read-socket-value-string socket)))
 622              (when (= pid (postgresql-connection-pid connection))
 623                (signal 'postgresql-notification :connection connection
 624                        :message message))))
 625           (t
 626            (close-postgresql-connection connection)
 627            (error 'postgresql-fatal-error :connection connection
 628                   :message "Received garbled message from backend"))))))
 629
 630 (defun read-null-bit-vector (socket count)
 631   (let ((result (make-array count :element-type 'bit)))
 632     (dotimes (offset (ceiling count 8))
 633       (loop with byte = (read-byte socket)
 634             for index from (* offset 8) below (min count (* (1+ offset) 8))
 635             for weight downfrom 7
 636             do (setf (aref result index) (ldb (byte 1 weight) byte))))
 637     result))
 638
 639
 640 (defun read-field (socket type)
 641   (let ((length (- (read-socket-value-int32 socket) 4)))
 642     (case type
 643       ((:int32 :int64)
 644        (read-integer-from-socket socket length))
 645       (:double
 646        (read-double-from-socket socket length))
 647       (t
 648        (let ((result (make-string length)))
 649          (read-socket-sequence result socket)
 650          result)))))
 651
 652 (uffi:def-constant +char-code-zero+ (char-code #\0))
 653 (uffi:def-constant +char-code-minus+ (char-code #\-))
 654 (uffi:def-constant +char-code-plus+ (char-code #\+))
 655 (uffi:def-constant +char-code-period+ (char-code #\.))
 656 (uffi:def-constant +char-code-lower-e+ (char-code #\e))
 657 (uffi:def-constant +char-code-upper-e+ (char-code #\E))
 658
 659 (defun read-integer-from-socket (socket length)
 660   (declare (fixnum length))
 661   (if (zerop length)
 662       nil
 663     (let ((val 0)
 664           (first-char (read-byte socket))
 665           (minusp nil))
 666       (declare (fixnum first-char))
 667       (decf length) ;; read first char
 668       (cond
 669        ((= first-char +char-code-minus+)
 670         (setq minusp t))
 671        ((= first-char +char-code-plus+)
 672         )               ;; nothing to do
 673        (t
 674         (setq val (- first-char +char-code-zero+))))
 675
 676       (dotimes (i length)
 677         (declare (fixnum i))
 678         (setq val (+
 679                    (* 10 val)
 680                    (- (read-byte socket) +char-code-zero+))))
 681       (if minusp
 682           (- val)
 683         val))))
 684
 685 (defmacro ascii-digit (int)
 686   (let ((offset (gensym)))
 687     `(let ((,offset (- ,int +char-code-zero+)))
 688       (declare (fixnum ,int ,offset))
 689       (if (and (>= ,offset 0)
 690                (< ,offset 10))
 691           ,offset
 692           nil))))
 693
 694 (defun read-double-from-socket (socket length)
 695   (declare (fixnum length))
 696   (let ((before-decimal 0)
 697         (after-decimal 0)
 698         (decimal-count 0)
 699         (exponent 0)
 700         (decimalp nil)
 701         (minusp nil)
 702         (result nil)
 703         (char (read-byte socket)))
 704     (declare (fixnum char exponent decimal-count))
 705     (decf length) ;; already read first character
 706     (cond
 707       ((= char +char-code-minus+)
 708        (setq minusp t))
 709       ((= char +char-code-plus+)
 710        )
 711       ((= char +char-code-period+)
 712        (setq decimalp t))
 713       (t
 714        (setq before-decimal (ascii-digit char))
 715        (unless before-decimal
 716          (error "Unexpected value"))))
 717
 718     (block loop
 719       (dotimes (i length)
 720         (setq char (read-byte socket))
 721         ;;      (format t "~&len:~D, i:~D, char:~D, minusp:~A, decimalp:~A" length i char minusp decimalp)
 722         (let ((weight (ascii-digit char)))
 723           (cond
 724            ((and weight (not decimalp)) ;; before decimal point
 725             (setq before-decimal (+ weight (* 10 before-decimal))))
 726            ((and weight decimalp) ;; after decimal point
 727             (setq after-decimal (+ weight (* 10 after-decimal)))
 728             (incf decimal-count))
 729            ((and (= char +char-code-period+))
 730             (setq decimalp t))
 731            ((or (= char +char-code-lower-e+)          ;; E is for exponent
 732                 (= char +char-code-upper-e+))
 733             (setq exponent (read-integer-from-socket socket (- length i 1)))
 734             (setq exponent (or exponent 0))
 735             (return-from loop))
 736           (t
 737            (break "Unexpected value"))
 738           )
 739         )))
 740     (setq result (* (+ (coerce before-decimal 'double-float)
 741                        (* after-decimal
 742                           (expt 10 (- decimal-count))))
 743                     (expt 10 exponent)))
 744     (if minusp
 745         (- result)
 746         result)))
 747
 748
 749 #+ignore
 750 (defun read-double-from-socket (socket length)
 751   (let ((result (make-string length)))
 752     (read-socket-sequence result socket)
 753     (let ((*read-default-float-format* 'double-float))
 754       (read-from-string result))))
 755
 756 (defun read-cursor-row (cursor types)
 757   (let* ((connection (postgresql-cursor-connection cursor))
 758          (socket (postgresql-connection-socket connection))
 759          (fields (postgresql-cursor-fields cursor)))
 760     (assert (postgresql-connection-open-p connection))
 761     (loop
 762         (let ((code (read-socket-value-int8 socket)))
 763           (case code
 764             (#.+ascii-row-message+
 765              (return
 766                (loop with count = (length fields)
 767                      with null-vector = (read-null-bit-vector socket count)
 768                      repeat count
 769                      for null-bit across null-vector
 770                      for i from 0
 771                      for null-p = (zerop null-bit)
 772                      if null-p
 773                      collect nil
 774                      else
 775                      collect
 776                      (read-field socket (nth i types)))))
 777             (#.+binary-row-message+
 778              (error "NYI"))
 779             (#.+completed-response-message+
 780              (return (values nil (read-socket-value-string socket))))
 781             (#.+error-response-message+
 782              (let ((message (read-socket-value-string socket)))
 783                (error 'postgresql-error
 784                       :connection connection :message message)))
 785             (#.+notice-response-message+
 786              (let ((message (read-socket-value-string socket)))
 787                (warn 'postgresql-warning
 788                      :connection connection :message message)))
 789             (#.+notification-response-message+
 790              (let ((pid (read-socket-value-int32 socket))
 791                    (message (read-socket-value-string socket)))
 792                (when (= pid (postgresql-connection-pid connection))
 793                  (signal 'postgresql-notification :connection connection
 794                          :message message))))
 795             (t
 796              (close-postgresql-connection connection)
 797              (error 'postgresql-fatal-error :connection connection
 798                     :message "Received garbled message from backend")))))))
 799
 800 (defun map-into-indexed (result-seq func seq)
 801   (dotimes (i (length seq))
 802     (declare (fixnum i))
 803     (setf (elt result-seq i)
 804           (funcall func (elt seq i) i)))
 805   result-seq)
 806
 807 (defun copy-cursor-row (cursor sequence types)
 808   (let* ((connection (postgresql-cursor-connection cursor))
 809          (socket (postgresql-connection-socket connection))
 810          (fields (postgresql-cursor-fields cursor)))
 811     (assert (= (length fields) (length sequence)))
 812     (loop
 813         (let ((code (read-socket-value-int8 socket)))
 814           (case code
 815             (#.+ascii-row-message+
 816              (return
 817                #+ignore
 818                (let* ((count (length sequence))
 819                       (null-vector (read-null-bit-vector socket count)))
 820                  (dotimes (i count)
 821                    (declare (fixnum i))
 822                    (if (zerop (elt null-vector i))
 823                        (setf (elt sequence i) nil)
 824                        (let ((value (read-field socket (nth i types))))
 825                          (setf (elt sequence i) value)))))
 826                (map-into-indexed
 827                 sequence
 828                 #'(lambda (null-bit i)
 829                     (if (zerop null-bit)
 830                         nil
 831                         (read-field socket (nth i types))))
 832                 (read-null-bit-vector socket (length sequence)))))
 833             (#.+binary-row-message+
 834              (error "NYI"))
 835             (#.+completed-response-message+
 836              (return (values nil (read-socket-value-string socket))))
 837             (#.+error-response-message+
 838              (let ((message (read-socket-value-string socket)))
 839                (error 'postgresql-error
 840                       :connection connection :message message)))
 841             (#.+notice-response-message+
 842              (let ((message (read-socket-value-string socket)))
 843                (warn 'postgresql-warning
 844                      :connection connection :message message)))
 845             (#.+notification-response-message+
 846              (let ((pid (read-socket-value-int32 socket))
 847                    (message (read-socket-value-string socket)))
 848                (when (= pid (postgresql-connection-pid connection))
 849                  (signal 'postgresql-notification :connection connection
 850                          :message message))))
 851             (t
 852              (close-postgresql-connection connection)
 853              (error 'postgresql-fatal-error :connection connection
 854                     :message "Received garbled message from backend")))))))
 855
 856 (defun skip-cursor-row (cursor)
 857   (let* ((connection (postgresql-cursor-connection cursor))
 858          (socket (postgresql-connection-socket connection))
 859          (fields (postgresql-cursor-fields cursor)))
 860     (loop
 861         (let ((code (read-socket-value-int8 socket)))
 862           (case code
 863             (#.+ascii-row-message+
 864              (loop for null-bit across
 865                    (read-null-bit-vector socket (length fields))
 866                    do
 867                    (unless (zerop null-bit)
 868                      (let* ((length (read-socket-value-int32 socket)))
 869                        (loop repeat (- length 4) do (read-byte socket)))))
 870              (return t))
 871             (#.+binary-row-message+
 872              (error "NYI"))
 873             (#.+completed-response-message+
 874              (return (values nil (read-socket-value-string socket))))
 875             (#.+error-response-message+
 876              (let ((message (read-socket-value-string socket)))
 877                (error 'postgresql-error
 878                       :connection connection :message message)))
 879             (#.+notice-response-message+
 880              (let ((message (read-socket-value-string socket)))
 881                (warn 'postgresql-warning
 882                      :connection connection :message message)))
 883             (#.+notification-response-message+
 884              (let ((pid (read-socket-value-int32 socket))
 885                    (message (read-socket-value-string socket)))
 886                (when (= pid (postgresql-connection-pid connection))
 887                  (signal 'postgresql-notification :connection connection
 888                          :message message))))
 889             (t
 890              (close-postgresql-connection connection)
 891              (error 'postgresql-fatal-error :connection connection
 892                     :message "Received garbled message from backend")))))))
 893
 894 (defun run-query (connection query &optional (result-types nil))
 895   (start-query-execution connection query)
 896   (multiple-value-bind (status cursor)
 897       (wait-for-query-results connection)
 898     (assert (eq status :cursor))
 899     (loop for row = (read-cursor-row cursor result-types)
 900           while row
 901           collect row
 902           finally
 903           (wait-for-query-results connection))))
 904
 905 #+scl
 906 (declaim (ext:maybe-inline read-byte write-byte))