;;;; *************************************************************************
;;;; 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
+;;;; Name: postgresql-socket-api.lisp
+;;;; Purpose: Low-level PostgreSQL interface using sockets
+;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai
+;;;; Created: Feb 2002
;;;;
-;;;; $Id: postgresql-socket-api.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 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
;;;; (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
-;;;; - Added initialization variable
-;;;; - Added field type processing
-
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :postgresql-socket)
+(in-package #:postgresql-socket)
(uffi:def-enum pgsql-ftype
((:bytea 17)
(:float4 700)
(:float8 701)))
-(defmethod database-type-library-loaded ((database-type
+(defmethod clsql-sys:database-type-library-loaded ((database-type
(eql :postgresql-socket)))
"T if foreign library was able to be loaded successfully. Always true for
socket interface"
t)
-
+
+(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :postgresql-socket)))
+ t)
+
;;; Message I/O stuff
+ready-for-query-message+ #\Z
+row-description-message+ #\T))
-(defgeneric send-socket-value (type socket value))
+#+scl
+(declaim (inline read-byte write-byte))
-(defmethod send-socket-value ((type (eql 'int32)) socket (value integer))
+(defun send-socket-value-int32 (socket value)
+ (declare (type stream socket)
+ (type (unsigned-byte 32) value))
(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))
+ (write-byte (ldb (byte 8 0) value) socket)
+ nil)
-(defmethod send-socket-value ((type (eql 'int16)) socket (value integer))
+(defun send-socket-value-int16 (socket value)
+ (declare (type stream socket)
+ (type (unsigned-byte 16) value))
(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))
+ (write-byte (ldb (byte 8 0) value) socket)
+ nil)
+
+(defun send-socket-value-int8 (socket value)
+ (declare (type stream socket)
+ (type (unsigned-byte 8) value))
+ (write-byte (ldb (byte 8 0) value) socket)
+ nil)
+
+(defun send-socket-value-char-code (socket value)
+ (declare (type stream socket)
+ (type character value))
+ (write-byte (ldb (byte 8 0) (char-code value)) socket)
+ nil)
+
+(defun send-socket-value-string (socket value)
+ (declare (type stream socket)
+ (type string value))
+ #-sb-unicode
(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)
+ for code = (char-code char)
+ do (write-byte code socket)
+ finally (write-byte 0 socket))
+ #+sb-unicode
+ (write-sequence (sb-ext:string-to-octets value :null-terminate t) socket)
+ nil)
+
+(defun send-socket-value-limstring (socket value limit)
+ (declare (type stream socket)
+ (type string value)
+ (type fixnum limit))
+ (let ((length (length value)))
+ (dotimes (i (min length limit))
+ (let ((code (char-code (char value i))))
+ (write-byte code socket)))
+ (dotimes (i (- limit length))
+ (write-byte 0 socket)))
+ nil)
+
+
+(defun read-socket-value-int32 (socket)
+ (declare (type stream socket))
+ (declare (optimize (speed 3)))
(let ((result 0))
+ (declare (type (unsigned-byte 32) result))
(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)
+(defun read-socket-value-int16 (socket)
+ (declare (type stream socket))
(let ((result 0))
+ (declare (type (unsigned-byte 16) result))
(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)
+(defun read-socket-value-int8 (socket)
+ (declare (type stream socket))
(read-byte socket))
-(defmethod read-socket-value ((type (eql 'string)) socket)
+(defun read-socket-value-string (socket)
+ (declare (type stream socket))
+ #-sb-unicode
(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))
+ until (zerop code)
+ do (write-char (code-char code) out)))
+ #+sb-unicode
+ (let ((bytes (make-array 64
+ :element-type '(unsigned-byte 8)
+ :adjustable t
+ :fill-pointer 0)))
+ (loop for code = (read-byte socket)
+ until (zerop code)
+ do (vector-push-extend code bytes))
+ (sb-ext:octets-to-string bytes)))
-(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))
+ (let ((socket-var (gensym))
+ (body nil))
+ (dolist (clause clauses)
+ (let* ((type (first clause))
+ (fn (intern (concatenate 'string (symbol-name '#:send-socket-value-)
+ (symbol-name type)))))
+ (push `(,fn ,socket-var ,@(rest clause)) body)))
+ `(defun ,name (,socket-var ,@args)
+ ,@(nreverse body))))
(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)))
+ (limstring database 64)
+ (limstring user 32)
+ (limstring command-line 64)
+ (limstring "" 64) ; Unused
+ (limstring backend-tty 64))
(define-message-sender send-terminate-message ()
- (byte #\X))
+ (char-code #\X))
(define-message-sender send-unencrypted-password-message (password)
(int32 (+ 5 (length password)))
(string password))
(define-message-sender send-query-message (query)
- (byte #\Q)
+ (char-code #\Q)
(string query))
(define-message-sender send-encrypted-password-message (crypted-password)
(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))
- (string string))
- (dotimes (i (length string))
- (declare (fixnum i))
- (setf (char string i) (code-char (read-byte stream))))
- string)
+(defun read-socket-sequence (stream length)
+ "KMR -- Added to support reading from binary stream into a string"
+ (declare (stream stream)
+ (optimize (speed 3) (safety 0)))
+ #-sb-unicode
+ (let ((result (make-string length)))
+ (dotimes (i (length string) result)
+ (declare (fixnum i))
+ (setf (char string i) (code-char (read-byte stream)))))
+ #+sb-unicode
+ (let ((bytes (make-array length :element-type '(unsigned-byte 8))))
+ (declare (type (simple-array (unsigned-byte 8) (*)) bytes))
+ (read-sequence bytes stream)
+ (sb-ext:octets-to-string bytes)))
;;; Support for encrypted password transmission
-(defvar *crypt-library-loaded* nil)
+#-scl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (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
(uffi:find-foreign-library "libcrypt"
- '("/usr/lib/" "/usr/local/lib/" "/lib/"))
+ '(#+(or 64bit x86-64) "/usr/lib64/"
+ "/usr/lib/" "/usr/local/lib/" "/lib/"))
:supporting-libraries '("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
- (funcall (fdefinition 'crypt) password-cstring salt-cstring)))))
-;;; Condition hierarchy
+ (setq *crypt-library-loaded* t)))
+
+(in-package :postgresql-socket)
+
+(uffi:def-function ("crypt" crypt)
+ ((key :cstring)
+ (salt :cstring))
+ :returning :cstring)
+
+(defun crypt-password (password salt)
+ "Encrypt a password for transmission to a PostgreSQL server."
+ (uffi:with-cstring (password-cstring password)
+ (uffi:with-cstring (salt-cstring salt)
+ (uffi:convert-from-cstring
+ (crypt password-cstring salt-cstring)))))
+
+\f
+;;;; Condition hierarchy
(define-condition postgresql-condition (condition)
((connection :initarg :connection :reader postgresql-condition-connection)
(defvar *postgresql-server-socket-timeout* 60
"Timeout in seconds for reads from the PostgreSQL server.")
-
-#+cmu
+#+(or cmu scl)
(defun open-postgresql-socket (host port)
(etypecase host
(pathname
(string
(ext:connect-to-inet-socket host port))))
-#+cmu
+#+sbcl
+(defun open-postgresql-socket (host port)
+ (etypecase host
+ (pathname
+ ;; Directory to unix-domain socket
+ (sb-bsd-sockets:socket-connect
+ (namestring
+ (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
+ :defaults host))))
+ (string
+ (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (sb-bsd-sockets:socket-connect
+ sock
+ (sb-bsd-sockets:host-ent-address
+ (sb-bsd-sockets:get-host-by-name host))
+ port)
+ sock))))
+
+#+(or cmu scl)
(defun open-postgresql-socket-stream (host port)
(system:make-fd-stream
(open-postgresql-socket host port)
:buffering :none
:timeout *postgresql-server-socket-timeout*))
+
+#+sbcl
+(defun open-postgresql-socket-stream (host port)
+ (sb-bsd-sockets:socket-make-stream
+ (open-postgresql-socket host port) :input t :output t
+ :element-type '(unsigned-byte 8)))
+
+
#+allegro
(defun open-postgresql-socket-stream (host port)
(etypecase host
(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))))
- ))
+ :connect :active :nodelay t))))))
+
+#+openmcl
+(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))))
+ (ccl:make-socket :type :stream :address-family :file
+ :connect :active
+ :remote-filename path :local-filename path)))
+ (string
+ (ccl: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)
:database database :user user
:password (or password ""))))
+(defun encrypt-md5 (plaintext salt)
+ (string-downcase
+ (format nil "~{~2,'0X~}"
+ (coerce (md5sum-sequence (concatenate 'string plaintext salt)) 'list))))
+
(defun reopen-postgresql-connection (connection)
"Reopen the given PostgreSQL connection. Closes any existing
connection, if it is still open."
(postgresql-connection-tty connection))
(force-output socket)
(loop
- (case (read-socket-value 'int8 socket)
+ (case (read-socket-value-int8 socket)
(#.+authentication-message+
- (case (read-socket-value 'int32 socket)
+ (case (read-socket-value-int32 socket)
(0 (return))
((1 2)
(error 'postgresql-login-error
(3
(send-unencrypted-password-message
socket
- (postgresql-connection-password connection)))
+ (postgresql-connection-password connection))
+ (force-output socket))
(4
- (let ((salt (make-string 2)))
- (read-socket-sequence salt socket)
+ (let ((salt (read-socket-sequence socket 2)))
(send-encrypted-password-message
socket
(crypt-password
- (postgresql-connection-password connection) salt))))
+ (postgresql-connection-password connection) salt)))
+ (force-output socket))
+ (5
+ (let ((salt (read-socket-sequence socket 4)))
+ (let* ((pwd2 (encrypt-md5 (postgresql-connection-password connection)
+ (postgresql-connection-user connection)))
+ (pwd (encrypt-md5 pwd2 salt)))
+ (send-encrypted-password-message
+ socket
+ (concatenate 'string "md5" pwd))))
+ (force-output socket))
(t
(error 'postgresql-login-error
:connection connection
:message
"Postmaster expects unknown authentication method."))))
(#.+error-response-message+
- (let ((message (read-socket-value 'string socket)))
+ (let ((message (read-socket-value-string socket)))
(error 'postgresql-login-error
:connection connection :message message)))
(t
;; Start backend communication
(force-output socket)
(loop
- (case (read-socket-value 'int8 socket)
+ (case (read-socket-value-int8 socket)
(#.+backend-key-message+
(setf (postgresql-connection-pid connection)
- (read-socket-value 'int32 socket)
+ (read-socket-value-int32 socket)
(postgresql-connection-key connection)
- (read-socket-value 'int32 socket)))
+ (read-socket-value-int32 socket)))
(#.+ready-for-query-message+
(setq socket nil)
(return connection))
(#.+error-response-message+
- (let ((message (read-socket-value 'string socket)))
+ (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)))
+ (let ((message (read-socket-value-string socket)))
(warn 'postgresql-warning :connection connection
:message message)))
(t
(loop with socket = (postgresql-connection-socket connection)
while (listen socket)
do
- (case (read-socket-value 'int8 socket)
+ (case (read-socket-value-int8 socket)
+ (#.+ready-for-query-message+)
(#.+notice-response-message+
- (let ((message (read-socket-value 'string socket)))
+ (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)))
+ (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))))
(cursor-name nil)
(error nil))
(loop
- (case (read-socket-value 'int8 socket)
+ (case (read-socket-value-int8 socket)
(#.+completed-response-message+
- (return (values :completed (read-socket-value 'string socket))))
+ (return (values :completed (read-socket-value-string socket))))
(#.+cursor-response-message+
- (setq cursor-name (read-socket-value 'string socket)))
+ (setq cursor-name (read-socket-value-string socket)))
(#.+row-description-message+
- (let* ((count (read-socket-value 'int16 socket))
+ (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)))))
+ (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
(error error))
(return nil))
(#.+error-response-message+
- (let ((message (read-socket-value 'string socket)))
+ (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)))
+ (let ((message (read-socket-value-string socket)))
+ (unless (eq :ignore clsql-sys:*backend-warning-behavior*)
+ (warn 'postgresql-warning
+ :connection connection :message message))))
(#.+notification-response-message+
- (let ((pid (read-socket-value 'int32 socket))
- (message (read-socket-value 'string socket)))
+ (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))))
(defun read-field (socket type)
- (let ((length (- (read-socket-value 'int32 socket) 4)))
+ (let ((length (- (read-socket-value-int32 socket) 4)))
(case type
((:int32 :int64)
(read-integer-from-socket socket length))
(:double
(read-double-from-socket socket length))
(t
- (let ((result (make-string length)))
- (read-socket-sequence result socket)
- result)))))
+ (read-socket-sequence socket length)))))
(uffi:def-constant +char-code-zero+ (char-code #\0))
(uffi:def-constant +char-code-minus+ (char-code #\-))
(fields (postgresql-cursor-fields cursor)))
(assert (postgresql-connection-open-p connection))
(loop
- (let ((code (read-socket-value 'int8 socket)))
+ (let ((code (read-socket-value-int8 socket)))
(case code
(#.+ascii-row-message+
(return
(#.+binary-row-message+
(error "NYI"))
(#.+completed-response-message+
- (return (values nil (read-socket-value 'string socket))))
+ (return (values nil (read-socket-value-string socket))))
(#.+error-response-message+
- (let ((message (read-socket-value 'string socket)))
+ (let ((message (read-socket-value-string socket)))
(error 'postgresql-error
:connection connection :message message)))
(#.+notice-response-message+
- (let ((message (read-socket-value 'string socket)))
+ (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)))
+ (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))))
(fields (postgresql-cursor-fields cursor)))
(assert (= (length fields) (length sequence)))
(loop
- (let ((code (read-socket-value 'int8 socket)))
+ (let ((code (read-socket-value-int8 socket)))
(case code
(#.+ascii-row-message+
(return
(#.+binary-row-message+
(error "NYI"))
(#.+completed-response-message+
- (return (values nil (read-socket-value 'string socket))))
+ (return (values nil (read-socket-value-string socket))))
(#.+error-response-message+
- (let ((message (read-socket-value 'string socket)))
+ (let ((message (read-socket-value-string socket)))
(error 'postgresql-error
:connection connection :message message)))
(#.+notice-response-message+
- (let ((message (read-socket-value 'string socket)))
+ (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)))
+ (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))))
(socket (postgresql-connection-socket connection))
(fields (postgresql-cursor-fields cursor)))
(loop
- (let ((code (read-socket-value 'int8 socket)))
+ (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)))
+ (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))))
+ (return (values nil (read-socket-value-string socket))))
(#.+error-response-message+
- (let ((message (read-socket-value 'string socket)))
+ (let ((message (read-socket-value-string socket)))
(error 'postgresql-error
:connection connection :message message)))
(#.+notice-response-message+
- (let ((message (read-socket-value 'string socket)))
+ (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)))
+ (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))))
(error 'postgresql-fatal-error :connection connection
:message "Received garbled message from backend")))))))
-(defun run-query (connection query &optional (types nil))
+(defun run-query (connection query &optional (result-types nil))
(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 types)
+ (loop for row = (read-cursor-row cursor result-types)
while row
collect row
finally
(wait-for-query-results connection))))
+
+#+scl
+(declaim (ext:maybe-inline read-byte write-byte))