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