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