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