;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: postgresql-socket.cl
+;;;; Name: postgresql-socket-api.lisp
;;;; 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.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $
+;;;; $Id: postgresql-socket-api.lisp,v 1.2 2002/10/21 07:45:50 kevin Exp $
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
+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))
(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)
+ finally (write-byte 0 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))
(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))
+ (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)
(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))
+ "KMR -- Added to support reading from binary stream into a string"
+ (declare (string string)
+ (stream stream)
+ (optimize (speed 3) (safety 0)))
(dotimes (i (length string))
(declare (fixnum i))
(setf (char string i) (code-char (read-byte stream))))
;;; Support for encrypted password transmission
-(defvar *crypt-library-loaded* nil)
+#-scl
+(eval-when (compile eval load)
+ (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/"))
: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"
+ ((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)
"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
+#+(or cmu scl)
(defun open-postgresql-socket-stream (host port)
(system:make-fd-stream
(open-postgresql-socket host port)
(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
: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)
(#.+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)))
+ (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))))
(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))
(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))))
collect row
finally
(wait-for-query-results connection))))
+
+#+scl
+(declaim (ext:maybe-inline read-byte write-byte))
;;;; Programmers: Kevin M. Rosenberg, Marc Battyani
;;;; Date Started: Apr 2002
;;;;
-;;;; $Id: pool.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $
+;;;; $Id: pool.lisp,v 1.2 2002/10/21 07:45:50 kevin Exp $
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
(in-package :clsql-sys)
+#-scl
+(defun make-lock (name) (declare (ignore name)) nil)
+
+#-scl
+(defmacro with-lock-held ((lock desc) &body body)
+ (declare (ignore lock desc))
+ `(progn
+ ,@body))
+
(defvar *db-pool* (make-hash-table :test #'equal))
+(defvar *db-pool-lock* (make-lock "DB Pool lock"))
(defclass conn-pool ()
((connection-spec :accessor connection-spec :initarg :connection-spec)
(free-connections :accessor free-connections
:initform (make-array 5 :fill-pointer 0 :adjustable t))
(all-connections :accessor all-connections
- :initform (make-array 5 :fill-pointer 0 :adjustable t))))
+ :initform (make-array 5 :fill-pointer 0 :adjustable t))
+ (lock :accessor conn-pool-lock
+ :initform (make-lock "Connection pool"))))
(defun acquire-from-conn-pool (pool)
- (if (zerop (length (free-connections pool)))
- (let ((conn (connect (connection-spec pool)
- :database-type (database-type pool) :if-exists :new)))
- (vector-push-extend conn (all-connections pool))
- (setf (conn-pool conn) pool)
- conn)
- (vector-pop (free-connections pool))))
+ (or (with-lock-held ((conn-pool-lock pool) "Acquire from pool")
+ (and (plusp (length (free-connections pool)))
+ (vector-pop (free-connections pool))))
+ (let ((conn (connect (connection-spec pool)
+ :database-type (database-type pool)
+ :if-exists :new)))
+ (with-lock-held ((conn-pool-lock pool) "Acquire from pool")
+ (vector-push-extend conn (all-connections pool))
+ (setf (conn-pool conn) pool))
+ conn)))
(defun release-to-conn-pool (conn)
- (vector-push-extend conn (free-connections (conn-pool conn))))
+ (let ((pool (conn-pool conn)))
+ (with-lock-held ((conn-pool-lock pool) "Release to pool")
+ (vector-push-extend conn (free-connections pool)))))
(defun clear-conn-pool (pool)
- (loop for conn across (all-connections pool)
- do (setf (conn-pool conn) nil)
- (disconnect :database conn))
- (setf (fill-pointer (free-connections pool)) 0)
- (setf (fill-pointer (all-connections pool)) 0))
+ (with-lock-held ((conn-pool-lock pool) "Clear pool")
+ (loop for conn across (all-connections pool)
+ do (setf (conn-pool conn) nil)
+ (disconnect :database conn))
+ (setf (fill-pointer (free-connections pool)) 0)
+ (setf (fill-pointer (all-connections pool)) 0))
+ nil)
(defun find-or-create-connection-pool (connection-spec database-type)
"Find connection pool in hash table, creates a new connection pool if not found"
- (let* ((key (list connection-spec database-type))
- (conn-pool (gethash key *db-pool*)))
- (unless conn-pool
- (setq conn-pool (make-instance 'conn-pool
- :connection-spec connection-spec
- :database-type database-type))
- (setf (gethash key *db-pool*) conn-pool))
- conn-pool))
+ (with-lock-held (*db-pool-lock* "Find connection")
+ (let* ((key (list connection-spec database-type))
+ (conn-pool (gethash key *db-pool*)))
+ (unless conn-pool
+ (setq conn-pool (make-instance 'conn-pool
+ :connection-spec connection-spec
+ :database-type database-type))
+ (setf (gethash key *db-pool*) conn-pool))
+ conn-pool)))
(defun acquire-from-pool (connection-spec database-type &optional pool)
(unless (typep pool 'conn-pool)
(defun disconnect-pooled (&optional clear)
"Disconnects all connections in the pool"
- (maphash
- #'(lambda (key conn-pool)
- (declare (ignore key))
- (clear-conn-pool conn-pool))
- *db-pool*)
- (when clear (clrhash *db-pool*))
+ (with-lock-held (*db-pool-lock* "Find connection")
+ (maphash
+ #'(lambda (key conn-pool)
+ (declare (ignore key))
+ (clear-conn-pool conn-pool))
+ *db-pool*)
+ (when clear (clrhash *db-pool*)))
t)