--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: postgresql-socket.cl
+;;;; Purpose: Low-level PostgreSQL interface using sockets
+;;;; Programmers: Kevin M. Rosenberg based on
+;;;; Original code by Pierre R. Mai
+;;;;
+;;;; Date Started: Feb 2002
+;;;;
+;;;; $Id: postgresql-socket-api.cl,v 1.1 2002/03/23 17:10:48 kevin Exp $
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+
+;;;; Changes by Kevin Rosenberg
+;;;; - Added socket open functions for Allegro and Lispworks
+;;;; - Changed CMUCL FFI to UFFI
+;;;; - Added necessary (force-output) for socket streams on
+;;;; Allegro and Lispworks
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :postgresql-socket)
+
+
+;;; Message I/O stuff
+
+(defmacro define-message-constants (description &rest clauses)
+ (assert (evenp (length clauses)))
+ (loop with seen-characters = nil
+ for (name char) on clauses by #'cddr
+ for char-code = (char-code char)
+ for doc-string = (format nil "~A (~:C): ~A" description char name)
+ if (member char seen-characters)
+ do (error "Duplicate message type ~@C for group ~A" char description)
+ else
+ collect
+ `(defconstant ,name ,char-code ,doc-string)
+ into result-clauses
+ and do (push char seen-characters)
+ finally
+ (return `(progn ,@result-clauses))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(define-message-constants "Backend Message Constants"
+ +ascii-row-message+ #\D
+ +authentication-message+ #\R
+ +backend-key-message+ #\K
+ +binary-row-message+ #\B
+ +completed-response-message+ #\C
+ +copy-in-response-message+ #\G
+ +copy-out-response-message+ #\H
+ +cursor-response-message+ #\P
+ +empty-query-response-message+ #\I
+ +error-response-message+ #\E
+ +function-response-message+ #\V
+ +notice-response-message+ #\N
+ +notification-response-message+ #\A
+ +ready-for-query-message+ #\Z
+ +row-description-message+ #\T))
+
+(defgeneric send-socket-value (type socket value))
+
+(defmethod send-socket-value ((type (eql 'int32)) socket (value integer))
+ (write-byte (ldb (byte 8 24) value) socket)
+ (write-byte (ldb (byte 8 16) value) socket)
+ (write-byte (ldb (byte 8 8) value) socket)
+ (write-byte (ldb (byte 8 0) value) socket))
+
+(defmethod send-socket-value ((type (eql 'int16)) socket (value integer))
+ (write-byte (ldb (byte 8 8) value) socket)
+ (write-byte (ldb (byte 8 0) value) socket))
+
+(defmethod send-socket-value ((type (eql 'int8)) socket (value integer))
+ (write-byte (ldb (byte 8 0) value) socket))
+
+(defmethod send-socket-value ((type (eql 'string)) socket (value string))
+ (loop for char across value
+ for code = (char-code char)
+ do (write-byte code socket)
+ finally (write-byte 0 socket)))
+
+(defmethod send-socket-value ((type (eql 'limstring)) socket (value string))
+ (loop for char across value
+ for code = (char-code char)
+ do (write-byte code socket)))
+
+(defmethod send-socket-value ((type (eql 'byte)) socket (value integer))
+ (write-byte value socket))
+
+(defmethod send-socket-value ((type (eql 'byte)) socket (value character))
+ (write-byte (char-code value) socket))
+
+(defmethod send-socket-value ((type (eql 'byte)) socket value)
+ (write-sequence value socket))
+
+(defgeneric read-socket-value (type socket))
+
+(defmethod read-socket-value ((type (eql 'int32)) socket)
+ (let ((result 0))
+ (setf (ldb (byte 8 24) result) (read-byte socket))
+ (setf (ldb (byte 8 16) result) (read-byte socket))
+ (setf (ldb (byte 8 8) result) (read-byte socket))
+ (setf (ldb (byte 8 0) result) (read-byte socket))
+ result))
+
+(defmethod read-socket-value ((type (eql 'int16)) socket)
+ (let ((result 0))
+ (setf (ldb (byte 8 8) result) (read-byte socket))
+ (setf (ldb (byte 8 0) result) (read-byte socket))
+ result))
+
+(defmethod read-socket-value ((type (eql 'int8)) socket)
+ (read-byte socket))
+
+(defmethod read-socket-value ((type (eql 'string)) socket)
+ (with-output-to-string (out)
+ (loop for code = (read-byte socket)
+ until (zerop code)
+ do (write-char (code-char code) out))))
+
+(defgeneric skip-socket-value (type socket))
+
+(defmethod skip-socket-value ((type (eql 'int32)) socket)
+ (dotimes (i 4) (read-byte socket)))
+
+(defmethod skip-socket-value ((type (eql 'int16)) socket)
+ (dotimes (i 2) (read-byte socket)))
+
+(defmethod skip-socket-value ((type (eql 'int8)) socket)
+ (read-byte socket))
+
+(defmethod skip-socket-value ((type (eql 'string)) socket)
+ (loop until (zerop (read-byte socket))))
+
+(defmacro define-message-sender (name (&rest args) &rest clauses)
+ (loop with socket-var = (gensym)
+ for (type value) in clauses
+ collect
+ `(send-socket-value ',type ,socket-var ,value)
+ into body
+ finally
+ (return
+ `(defun ,name (,socket-var ,@args)
+ ,@body))))
+
+(defun pad-limstring (string limit)
+ (let ((result (make-string limit :initial-element #\NULL)))
+ (loop for char across string
+ for index from 0 below limit
+ do (setf (char result index) char))
+ result))
+
+(define-message-sender send-startup-message
+ (database user &optional (command-line "") (backend-tty ""))
+ (int32 296) ; Length
+ (int32 #x00020000) ; Version 2.0
+ (limstring (pad-limstring database 64))
+ (limstring (pad-limstring user 32))
+ (limstring (pad-limstring command-line 64))
+ (limstring (pad-limstring "" 64)) ; Unused
+ (limstring (pad-limstring backend-tty 64)))
+
+(define-message-sender send-terminate-message ()
+ (byte #\X))
+
+(define-message-sender send-unencrypted-password-message (password)
+ (int32 (+ 5 (length password)))
+ (string password))
+
+(define-message-sender send-query-message (query)
+ (byte #\Q)
+ (string query))
+
+(define-message-sender send-encrypted-password-message (crypted-password)
+ (int32 (+ 5 (length crypted-password)))
+ (string crypted-password))
+
+(define-message-sender send-cancel-request (pid key)
+ (int32 16) ; Length
+ (int32 80877102) ; Magic
+ (int32 pid)
+ (int32 key))
+
+
+(defun read-socket-sequence (string stream)
+"KMR -- Added to support reading from binary stream into a string"
+ (declare (optimize (speed 3) (safety 0)))
+ (dotimes (i (length string))
+ (declare (fixnum i))
+ (setf (char string i) (code-char (read-byte stream))))
+ string)
+
+
+;;; Support for encrypted password transmission
+
+(defconstant +crypt-library+ "/usr/lib/libcrypt.so"
+ "Name of the shared library to load in order to access the crypt
+function named by `*crypt-function-name*'.")
+
+(defvar *crypt-library-loaded* nil)
+
+(defun crypt-password (password salt)
+ "Encrypt a password for transmission to a PostgreSQL server."
+ (unless *crypt-library-loaded*
+ (uffi:load-foreign-library +crypt-library+ :supporting-libaries '("c"))
+ (eval (uffi:def-function "crypt"
+ ((key :cstring)
+ (salt :cstring))
+ :returning :cstring))
+ (setq *crypt-library-loaded* t))
+ (uffi:with-cstring (password-cstring password)
+ (uffi:with-cstring (salt-cstring salt)
+ (uffi:convert-from-cstring (crypt password-cstring salt-cstring)))))
+;;; Condition hierarchy
+
+(define-condition postgresql-condition (condition)
+ ((connection :initarg :connection :reader postgresql-condition-connection)
+ (message :initarg :message :reader postgresql-condition-message))
+ (:report
+ (lambda (c stream)
+ (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>"
+ (type-of c)
+ (postgresql-condition-connection c)
+ (postgresql-condition-message c)))))
+
+(define-condition postgresql-error (error postgresql-condition)
+ ())
+
+(define-condition postgresql-fatal-error (postgresql-error)
+ ())
+
+(define-condition postgresql-login-error (postgresql-fatal-error)
+ ())
+
+(define-condition postgresql-warning (warning postgresql-condition)
+ ())
+
+(define-condition postgresql-notification (postgresql-condition)
+ ()
+ (:report
+ (lambda (c stream)
+ (format stream "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
+ (postgresql-condition-connection c)
+ (postgresql-condition-message c)))))
+
+;;; Structures
+
+(defstruct postgresql-connection
+ host
+ port
+ database
+ user
+ password
+ options
+ tty
+ socket
+ pid
+ key)
+
+(defstruct postgresql-cursor
+ connection
+ name
+ fields)
+
+;;; Socket stuff
+
+(defconstant +postgresql-server-default-port+ 5432
+ "Default port of PostgreSQL server.")
+
+(defvar *postgresql-server-socket-timeout* 60
+ "Timeout in seconds for reads from the PostgreSQL server.")
+
+
+#+cmu
+(defun open-postgresql-socket (host port)
+ (etypecase host
+ (pathname
+ ;; Directory to unix-domain socket
+ (ext:connect-to-unix-socket
+ (namestring
+ (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
+ :defaults host))))
+ (string
+ (ext:connect-to-inet-socket host port))))
+
+#+cmu
+(defun open-postgresql-socket-stream (host port)
+ (system:make-fd-stream
+ (open-postgresql-socket host port)
+ :input t :output t :element-type '(unsigned-byte 8)
+ :buffering :none
+ :timeout *postgresql-server-socket-timeout*))
+
+#+allegro
+(defun open-postgresql-socket-stream (host port)
+ (etypecase host
+ (pathname
+ (let ((path (namestring
+ (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
+ :defaults host))))
+ (socket:make-socket :type :stream :address-family :file
+ :connect :active
+ :remote-filename path :local-filename path)))
+ (string
+ (socket:with-pending-connect
+ (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed"))
+ (socket:make-socket :type :stream :address-family :internet
+ :remote-port port :remote-host host
+ :connect :active :nodelay t))))
+ ))
+
+#+lispworks
+(defun open-postgresql-socket-stream (host port)
+ (etypecase host
+ (pathname
+ (error "File sockets not supported on Lispworks."))
+ (string
+ (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8)
+ :read-timeout *postgresql-server-socket-timeout*))
+ ))
+
+;;; Interface Functions
+
+(defun open-postgresql-connection (&key (host (cmucl-compat:required-argument))
+ (port +postgresql-server-default-port+)
+ (database (cmucl-compat:required-argument))
+ (user (cmucl-compat:required-argument))
+ options tty password)
+ "Open a connection to a PostgreSQL server with the given parameters.
+Note that host, database and user arguments must be supplied.
+
+If host is a pathname, it is assumed to name a directory containing
+the local unix-domain sockets of the server, with port selecting which
+of those sockets to open. If host is a string, it is assumed to be
+the name of the host running the PostgreSQL server. In that case a
+TCP connection to the given port on that host is opened in order to
+communicate with the server. In either case the port argument
+defaults to `+postgresql-server-default-port+'.
+
+Password is the clear-text password to be passed in the authentication
+phase to the server. Depending on the server set-up, it is either
+passed in the clear, or encrypted via crypt and a server-supplied
+salt. In that case the alien function specified by `*crypt-library*'
+and `*crypt-function-name*' is used for encryption.
+
+Note that all the arguments (including the clear-text password
+argument) are stored in the `postgresql-connection' structure, in
+order to facilitate automatic reconnection in case of communication
+troubles."
+ (reopen-postgresql-connection
+ (make-postgresql-connection :host host :port port
+ :options (or options "") :tty (or tty "")
+ :database database :user user
+ :password (or password ""))))
+
+(defun reopen-postgresql-connection (connection)
+ "Reopen the given PostgreSQL connection. Closes any existing
+connection, if it is still open."
+ (when (postgresql-connection-open-p connection)
+ (close-postgresql-connection connection))
+ (let ((socket (open-postgresql-socket-stream
+ (postgresql-connection-host connection)
+ (postgresql-connection-port connection))))
+ (unwind-protect
+ (progn
+ (setf (postgresql-connection-socket connection) socket)
+ (send-startup-message socket
+ (postgresql-connection-database connection)
+ (postgresql-connection-user connection)
+ (postgresql-connection-options connection)
+ (postgresql-connection-tty connection))
+ (force-output socket)
+ (loop
+ (case (read-socket-value 'int8 socket)
+ (#.+authentication-message+
+ (case (read-socket-value 'int32 socket)
+ (0 (return))
+ ((1 2)
+ (error 'postgresql-login-error
+ :connection connection
+ :message
+ "Postmaster expects unsupported Kerberos authentication."))
+ (3
+ (send-unencrypted-password-message
+ socket
+ (postgresql-connection-password connection)))
+ (4
+ (let ((salt (make-string 2)))
+ (read-socket-sequence salt socket)
+ (send-encrypted-password-message
+ socket
+ (crypt-password
+ (postgresql-connection-password connection) salt))))
+ (t
+ (error 'postgresql-login-error
+ :connection connection
+ :message
+ "Postmaster expects unknown authentication method."))))
+ (#.+error-response-message+
+ (let ((message (read-socket-value 'string socket)))
+ (error 'postgresql-login-error
+ :connection connection :message message)))
+ (t
+ (error 'postgresql-login-error
+ :connection connection
+ :message
+ "Received garbled message from Postmaster"))))
+ ;; Start backend communication
+ (force-output socket)
+ (loop
+ (case (read-socket-value 'int8 socket)
+ (#.+backend-key-message+
+ (setf (postgresql-connection-pid connection)
+ (read-socket-value 'int32 socket)
+ (postgresql-connection-key connection)
+ (read-socket-value 'int32 socket)))
+ (#.+ready-for-query-message+
+ (setq socket nil)
+ (return connection))
+ (#.+error-response-message+
+ (let ((message (read-socket-value 'string socket)))
+ (error 'postgresql-login-error
+ :connection connection
+ :message message)))
+ (#.+notice-response-message+
+ (let ((message (read-socket-value 'string socket)))
+ (warn 'postgresql-warning :connection connection
+ :message message)))
+ (t
+ (error 'postgresql-login-error
+ :connection connection
+ :message
+ "Received garbled message from Postmaster")))))
+ (when socket
+ (close socket)))))
+
+(defun close-postgresql-connection (connection &optional abort)
+ (unless abort
+ (ignore-errors
+ (send-terminate-message (postgresql-connection-socket connection))))
+ (close (postgresql-connection-socket connection)))
+
+(defun postgresql-connection-open-p (connection)
+ (let ((socket (postgresql-connection-socket connection)))
+ (and socket (streamp socket) (open-stream-p socket))))
+
+(defun ensure-open-postgresql-connection (connection)
+ (unless (postgresql-connection-open-p connection)
+ (reopen-postgresql-connection connection)))
+
+(defun process-async-messages (connection)
+ (assert (postgresql-connection-open-p connection))
+ ;; Process any asnychronous messages
+ (loop with socket = (postgresql-connection-socket connection)
+ while (listen socket)
+ do
+ (case (read-socket-value 'int8 socket)
+ (#.+notice-response-message+
+ (let ((message (read-socket-value 'string socket)))
+ (warn 'postgresql-warning :connection connection
+ :message message)))
+ (#.+notification-response-message+
+ (let ((pid (read-socket-value 'int32 socket))
+ (message (read-socket-value 'string socket)))
+ (when (= pid (postgresql-connection-pid connection))
+ (signal 'postgresql-notification :connection connection
+ :message message))))
+ (t
+ (close-postgresql-connection connection)
+ (error 'postgresql-fatal-error :connection connection
+ :message "Received garbled message from backend")))))
+
+(defun start-query-execution (connection query)
+ (ensure-open-postgresql-connection connection)
+ (process-async-messages connection)
+ (send-query-message (postgresql-connection-socket connection) query)
+ (force-output (postgresql-connection-socket connection)))
+
+(defun wait-for-query-results (connection)
+ (assert (postgresql-connection-open-p connection))
+ (let ((socket (postgresql-connection-socket connection))
+ (cursor-name nil)
+ (error nil))
+ (loop
+ (case (read-socket-value 'int8 socket)
+ (#.+completed-response-message+
+ (return (values :completed (read-socket-value 'string socket))))
+ (#.+cursor-response-message+
+ (setq cursor-name (read-socket-value 'string socket)))
+ (#.+row-description-message+
+ (let* ((count (read-socket-value 'int16 socket))
+ (fields
+ (loop repeat count
+ collect
+ (list
+ (read-socket-value 'string socket)
+ (read-socket-value 'int32 socket)
+ (read-socket-value 'int16 socket)
+ (read-socket-value 'int32 socket)))))
+ (return
+ (values :cursor
+ (make-postgresql-cursor :connection connection
+ :name cursor-name
+ :fields fields)))))
+ (#.+copy-in-response-message+
+ (return :copy-in))
+ (#.+copy-out-response-message+
+ (return :copy-out))
+ (#.+ready-for-query-message+
+ (when error
+ (error error))
+ (return nil))
+ (#.+error-response-message+
+ (let ((message (read-socket-value 'string socket)))
+ (setq error
+ (make-condition 'postgresql-error
+ :connection connection :message message))))
+ (#.+notice-response-message+
+ (let ((message (read-socket-value 'string socket)))
+ (warn 'postgresql-warning
+ :connection connection :message message)))
+ (#.+notification-response-message+
+ (let ((pid (read-socket-value 'int32 socket))
+ (message (read-socket-value 'string socket)))
+ (when (= pid (postgresql-connection-pid connection))
+ (signal 'postgresql-notification :connection connection
+ :message message))))
+ (t
+ (close-postgresql-connection connection)
+ (error 'postgresql-fatal-error :connection connection
+ :message "Received garbled message from backend"))))))
+
+(defun read-null-bit-vector (socket count)
+ (let ((result (make-array count :element-type 'bit)))
+ (dotimes (offset (ceiling count 8))
+ (loop with byte = (read-byte socket)
+ for index from (* offset 8) below (min count (* (1+ offset) 8))
+ for weight downfrom 7
+ do (setf (aref result index) (ldb (byte 1 weight) byte))))
+ result))
+
+(defun read-cursor-row (cursor)
+ (let* ((connection (postgresql-cursor-connection cursor))
+ (socket (postgresql-connection-socket connection))
+ (fields (postgresql-cursor-fields cursor)))
+ (assert (postgresql-connection-open-p connection))
+ (loop
+ (let ((code (read-socket-value 'int8 socket)))
+ (case code
+ (#.+ascii-row-message+
+ (return
+ (loop with count = (length fields)
+ with null-vector = (read-null-bit-vector socket count)
+ repeat count
+ for null-bit across null-vector
+ for null-p = (zerop null-bit)
+ if null-p
+ collect nil
+ else
+ collect
+ (let* ((length (read-socket-value 'int32 socket))
+ (result (make-string (- length 4))))
+ (read-socket-sequence result socket)
+ result))))
+ (#.+binary-row-message+
+ (error "NYI"))
+ (#.+completed-response-message+
+ (return (values nil (read-socket-value 'string socket))))
+ (#.+error-response-message+
+ (let ((message (read-socket-value 'string socket)))
+ (error 'postgresql-error
+ :connection connection :message message)))
+ (#.+notice-response-message+
+ (let ((message (read-socket-value 'string socket)))
+ (warn 'postgresql-warning
+ :connection connection :message message)))
+ (#.+notification-response-message+
+ (let ((pid (read-socket-value 'int32 socket))
+ (message (read-socket-value 'string socket)))
+ (when (= pid (postgresql-connection-pid connection))
+ (signal 'postgresql-notification :connection connection
+ :message message))))
+ (t
+ (close-postgresql-connection connection)
+ (error 'postgresql-fatal-error :connection connection
+ :message "Received garbled message from backend")))))))
+
+(defun copy-cursor-row (cursor sequence)
+ (let* ((connection (postgresql-cursor-connection cursor))
+ (socket (postgresql-connection-socket connection))
+ (fields (postgresql-cursor-fields cursor)))
+ (assert (= (length fields) (length sequence)))
+ (loop
+ (let ((code (read-socket-value 'int8 socket)))
+ (case code
+ (#.+ascii-row-message+
+ (return
+ (map-into
+ sequence
+ #'(lambda (null-bit)
+ (if (zerop null-bit)
+ nil
+ (let* ((length (read-socket-value 'int32 socket))
+ (result (make-string (- length 4))))
+ (read-socket-sequence result socket)
+ result)))
+ (read-null-bit-vector socket (length sequence)))))
+ (#.+binary-row-message+
+ (error "NYI"))
+ (#.+completed-response-message+
+ (return (values nil (read-socket-value 'string socket))))
+ (#.+error-response-message+
+ (let ((message (read-socket-value 'string socket)))
+ (error 'postgresql-error
+ :connection connection :message message)))
+ (#.+notice-response-message+
+ (let ((message (read-socket-value 'string socket)))
+ (warn 'postgresql-warning
+ :connection connection :message message)))
+ (#.+notification-response-message+
+ (let ((pid (read-socket-value 'int32 socket))
+ (message (read-socket-value 'string socket)))
+ (when (= pid (postgresql-connection-pid connection))
+ (signal 'postgresql-notification :connection connection
+ :message message))))
+ (t
+ (close-postgresql-connection connection)
+ (error 'postgresql-fatal-error :connection connection
+ :message "Received garbled message from backend")))))))
+
+(defun skip-cursor-row (cursor)
+ (let* ((connection (postgresql-cursor-connection cursor))
+ (socket (postgresql-connection-socket connection))
+ (fields (postgresql-cursor-fields cursor)))
+ (loop
+ (let ((code (read-socket-value 'int8 socket)))
+ (case code
+ (#.+ascii-row-message+
+ (loop for null-bit across
+ (read-null-bit-vector socket (length fields))
+ do
+ (unless (zerop null-bit)
+ (let* ((length (read-socket-value 'int32 socket)))
+ (loop repeat (- length 4) do (read-byte socket)))))
+ (return t))
+ (#.+binary-row-message+
+ (error "NYI"))
+ (#.+completed-response-message+
+ (return (values nil (read-socket-value 'string socket))))
+ (#.+error-response-message+
+ (let ((message (read-socket-value 'string socket)))
+ (error 'postgresql-error
+ :connection connection :message message)))
+ (#.+notice-response-message+
+ (let ((message (read-socket-value 'string socket)))
+ (warn 'postgresql-warning
+ :connection connection :message message)))
+ (#.+notification-response-message+
+ (let ((pid (read-socket-value 'int32 socket))
+ (message (read-socket-value 'string socket)))
+ (when (= pid (postgresql-connection-pid connection))
+ (signal 'postgresql-notification :connection connection
+ :message message))))
+ (t
+ (close-postgresql-connection connection)
+ (error 'postgresql-fatal-error :connection connection
+ :message "Received garbled message from backend")))))))
+
+(defun run-query (connection query)
+ (start-query-execution connection query)
+ (multiple-value-bind (status cursor)
+ (wait-for-query-results connection)
+ (assert (eq status :cursor))
+ (loop for row = (read-cursor-row cursor)
+ while row
+ collect row
+ finally
+ (wait-for-query-results connection))))
projects / clsql.git / blobdiff