1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: postgresql-socket.cl
6 ;;;; Purpose: Low-level PostgreSQL interface using sockets
7 ;;;; Programmers: Kevin M. Rosenberg based on
8 ;;;; Original code by Pierre R. Mai
10 ;;;; Date Started: Feb 2002
12 ;;;; $Id: postgresql-socket-api.cl,v 1.5 2002/03/25 23:48:46 kevin Exp $
14 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
15 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
17 ;;;; CLSQL users are granted the rights to distribute and use this software
18 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
19 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
20 ;;;; *************************************************************************
23 ;;;; Changes by Kevin Rosenberg
24 ;;;; - Added socket open functions for Allegro and Lispworks
25 ;;;; - Changed CMUCL FFI to UFFI
26 ;;;; - Added necessary (force-output) for socket streams on
27 ;;;; Allegro and Lispworks
28 ;;;; - Added initialization variable
29 ;;;; - Added field type processing
32 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
33 (in-package :postgresql-socket)
35 (uffi:def-enum pgsql-ftype
42 (defmethod database-type-library-loaded ((database-type
43 (eql :postgresql-socket)))
44 "T if foreign library was able to be loaded successfully. Always true for
51 (defmacro define-message-constants (description &rest clauses)
52 (assert (evenp (length clauses)))
53 (loop with seen-characters = nil
54 for (name char) on clauses by #'cddr
55 for char-code = (char-code char)
56 for doc-string = (format nil "~A (~:C): ~A" description char name)
57 if (member char seen-characters)
58 do (error "Duplicate message type ~@C for group ~A" char description)
61 `(defconstant ,name ,char-code ,doc-string)
63 and do (push char seen-characters)
65 (return `(progn ,@result-clauses))))
67 (eval-when (:compile-toplevel :load-toplevel :execute)
68 (define-message-constants "Backend Message Constants"
69 +ascii-row-message+ #\D
70 +authentication-message+ #\R
71 +backend-key-message+ #\K
72 +binary-row-message+ #\B
73 +completed-response-message+ #\C
74 +copy-in-response-message+ #\G
75 +copy-out-response-message+ #\H
76 +cursor-response-message+ #\P
77 +empty-query-response-message+ #\I
78 +error-response-message+ #\E
79 +function-response-message+ #\V
80 +notice-response-message+ #\N
81 +notification-response-message+ #\A
82 +ready-for-query-message+ #\Z
83 +row-description-message+ #\T))
85 (defgeneric send-socket-value (type socket value))
87 (defmethod send-socket-value ((type (eql 'int32)) socket (value integer))
88 (write-byte (ldb (byte 8 24) value) socket)
89 (write-byte (ldb (byte 8 16) value) socket)
90 (write-byte (ldb (byte 8 8) value) socket)
91 (write-byte (ldb (byte 8 0) value) socket))
93 (defmethod send-socket-value ((type (eql 'int16)) socket (value integer))
94 (write-byte (ldb (byte 8 8) value) socket)
95 (write-byte (ldb (byte 8 0) value) socket))
97 (defmethod send-socket-value ((type (eql 'int8)) socket (value integer))
98 (write-byte (ldb (byte 8 0) value) socket))
100 (defmethod send-socket-value ((type (eql 'string)) socket (value string))
101 (loop for char across value
102 for code = (char-code char)
103 do (write-byte code socket)
104 finally (write-byte 0 socket)))
106 (defmethod send-socket-value ((type (eql 'limstring)) socket (value string))
107 (loop for char across value
108 for code = (char-code char)
109 do (write-byte code socket)))
111 (defmethod send-socket-value ((type (eql 'byte)) socket (value integer))
112 (write-byte value socket))
114 (defmethod send-socket-value ((type (eql 'byte)) socket (value character))
115 (write-byte (char-code value) socket))
117 (defmethod send-socket-value ((type (eql 'byte)) socket value)
118 (write-sequence value socket))
120 (defgeneric read-socket-value (type socket))
122 (defmethod read-socket-value ((type (eql 'int32)) socket)
124 (setf (ldb (byte 8 24) result) (read-byte socket))
125 (setf (ldb (byte 8 16) result) (read-byte socket))
126 (setf (ldb (byte 8 8) result) (read-byte socket))
127 (setf (ldb (byte 8 0) result) (read-byte socket))
130 (defmethod read-socket-value ((type (eql 'int16)) socket)
132 (setf (ldb (byte 8 8) result) (read-byte socket))
133 (setf (ldb (byte 8 0) result) (read-byte socket))
136 (defmethod read-socket-value ((type (eql 'int8)) socket)
139 (defmethod read-socket-value ((type (eql 'string)) socket)
140 (with-output-to-string (out)
141 (loop for code = (read-byte socket)
143 do (write-char (code-char code) out))))
145 (defgeneric skip-socket-value (type socket))
147 (defmethod skip-socket-value ((type (eql 'int32)) socket)
148 (dotimes (i 4) (read-byte socket)))
150 (defmethod skip-socket-value ((type (eql 'int16)) socket)
151 (dotimes (i 2) (read-byte socket)))
153 (defmethod skip-socket-value ((type (eql 'int8)) socket)
156 (defmethod skip-socket-value ((type (eql 'string)) socket)
157 (loop until (zerop (read-byte socket))))
159 (defmacro define-message-sender (name (&rest args) &rest clauses)
160 (loop with socket-var = (gensym)
161 for (type value) in clauses
163 `(send-socket-value ',type ,socket-var ,value)
167 `(defun ,name (,socket-var ,@args)
170 (defun pad-limstring (string limit)
171 (let ((result (make-string limit :initial-element #\NULL)))
172 (loop for char across string
173 for index from 0 below limit
174 do (setf (char result index) char))
177 (define-message-sender send-startup-message
178 (database user &optional (command-line "") (backend-tty ""))
180 (int32 #x00020000) ; Version 2.0
181 (limstring (pad-limstring database 64))
182 (limstring (pad-limstring user 32))
183 (limstring (pad-limstring command-line 64))
184 (limstring (pad-limstring "" 64)) ; Unused
185 (limstring (pad-limstring backend-tty 64)))
187 (define-message-sender send-terminate-message ()
190 (define-message-sender send-unencrypted-password-message (password)
191 (int32 (+ 5 (length password)))
194 (define-message-sender send-query-message (query)
198 (define-message-sender send-encrypted-password-message (crypted-password)
199 (int32 (+ 5 (length crypted-password)))
200 (string crypted-password))
202 (define-message-sender send-cancel-request (pid key)
204 (int32 80877102) ; Magic
209 (defun read-socket-sequence (string stream)
210 "KMR -- Added to support reading from binary stream into a string"
211 (declare (optimize (speed 3) (safety 0)))
212 (dotimes (i (length string))
214 (setf (char string i) (code-char (read-byte stream))))
218 ;;; Support for encrypted password transmission
220 (defconstant +crypt-library+ "/usr/lib/libcrypt.so"
221 "Name of the shared library to load in order to access the crypt
222 function named by `*crypt-function-name*'.")
224 (defvar *crypt-library-loaded* nil)
226 (defun crypt-password (password salt)
227 "Encrypt a password for transmission to a PostgreSQL server."
228 (unless *crypt-library-loaded*
229 (uffi:load-foreign-library +crypt-library+ :supporting-libaries '("c"))
230 (eval (uffi:def-function "crypt"
233 :returning :cstring))
234 (setq *crypt-library-loaded* t))
235 (uffi:with-cstring (password-cstring password)
236 (uffi:with-cstring (salt-cstring salt)
237 (uffi:convert-from-cstring (crypt password-cstring salt-cstring)))))
238 ;;; Condition hierarchy
240 (define-condition postgresql-condition (condition)
241 ((connection :initarg :connection :reader postgresql-condition-connection)
242 (message :initarg :message :reader postgresql-condition-message))
245 (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>"
247 (postgresql-condition-connection c)
248 (postgresql-condition-message c)))))
250 (define-condition postgresql-error (error postgresql-condition)
253 (define-condition postgresql-fatal-error (postgresql-error)
256 (define-condition postgresql-login-error (postgresql-fatal-error)
259 (define-condition postgresql-warning (warning postgresql-condition)
262 (define-condition postgresql-notification (postgresql-condition)
266 (format stream "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
267 (postgresql-condition-connection c)
268 (postgresql-condition-message c)))))
272 (defstruct postgresql-connection
284 (defstruct postgresql-cursor
291 (defconstant +postgresql-server-default-port+ 5432
292 "Default port of PostgreSQL server.")
294 (defvar *postgresql-server-socket-timeout* 60
295 "Timeout in seconds for reads from the PostgreSQL server.")
299 (defun open-postgresql-socket (host port)
302 ;; Directory to unix-domain socket
303 (ext:connect-to-unix-socket
305 (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
308 (ext:connect-to-inet-socket host port))))
311 (defun open-postgresql-socket-stream (host port)
312 (system:make-fd-stream
313 (open-postgresql-socket host port)
314 :input t :output t :element-type '(unsigned-byte 8)
316 :timeout *postgresql-server-socket-timeout*))
319 (defun open-postgresql-socket-stream (host port)
322 (let ((path (namestring
323 (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
325 (socket:make-socket :type :stream :address-family :file
327 :remote-filename path :local-filename path)))
329 (socket:with-pending-connect
330 (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed"))
331 (socket:make-socket :type :stream :address-family :internet
332 :remote-port port :remote-host host
333 :connect :active :nodelay t))))
337 (defun open-postgresql-socket-stream (host port)
340 (error "File sockets not supported on Lispworks."))
342 (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8)
343 :read-timeout *postgresql-server-socket-timeout*))
346 ;;; Interface Functions
348 (defun open-postgresql-connection (&key (host (cmucl-compat:required-argument))
349 (port +postgresql-server-default-port+)
350 (database (cmucl-compat:required-argument))
351 (user (cmucl-compat:required-argument))
352 options tty password)
353 "Open a connection to a PostgreSQL server with the given parameters.
354 Note that host, database and user arguments must be supplied.
356 If host is a pathname, it is assumed to name a directory containing
357 the local unix-domain sockets of the server, with port selecting which
358 of those sockets to open. If host is a string, it is assumed to be
359 the name of the host running the PostgreSQL server. In that case a
360 TCP connection to the given port on that host is opened in order to
361 communicate with the server. In either case the port argument
362 defaults to `+postgresql-server-default-port+'.
364 Password is the clear-text password to be passed in the authentication
365 phase to the server. Depending on the server set-up, it is either
366 passed in the clear, or encrypted via crypt and a server-supplied
367 salt. In that case the alien function specified by `*crypt-library*'
368 and `*crypt-function-name*' is used for encryption.
370 Note that all the arguments (including the clear-text password
371 argument) are stored in the `postgresql-connection' structure, in
372 order to facilitate automatic reconnection in case of communication
374 (reopen-postgresql-connection
375 (make-postgresql-connection :host host :port port
376 :options (or options "") :tty (or tty "")
377 :database database :user user
378 :password (or password ""))))
380 (defun reopen-postgresql-connection (connection)
381 "Reopen the given PostgreSQL connection. Closes any existing
382 connection, if it is still open."
383 (when (postgresql-connection-open-p connection)
384 (close-postgresql-connection connection))
385 (let ((socket (open-postgresql-socket-stream
386 (postgresql-connection-host connection)
387 (postgresql-connection-port connection))))
390 (setf (postgresql-connection-socket connection) socket)
391 (send-startup-message socket
392 (postgresql-connection-database connection)
393 (postgresql-connection-user connection)
394 (postgresql-connection-options connection)
395 (postgresql-connection-tty connection))
396 (force-output socket)
398 (case (read-socket-value 'int8 socket)
399 (#.+authentication-message+
400 (case (read-socket-value 'int32 socket)
403 (error 'postgresql-login-error
404 :connection connection
406 "Postmaster expects unsupported Kerberos authentication."))
408 (send-unencrypted-password-message
410 (postgresql-connection-password connection)))
412 (let ((salt (make-string 2)))
413 (read-socket-sequence salt socket)
414 (send-encrypted-password-message
417 (postgresql-connection-password connection) salt))))
419 (error 'postgresql-login-error
420 :connection connection
422 "Postmaster expects unknown authentication method."))))
423 (#.+error-response-message+
424 (let ((message (read-socket-value 'string socket)))
425 (error 'postgresql-login-error
426 :connection connection :message message)))
428 (error 'postgresql-login-error
429 :connection connection
431 "Received garbled message from Postmaster"))))
432 ;; Start backend communication
433 (force-output socket)
435 (case (read-socket-value 'int8 socket)
436 (#.+backend-key-message+
437 (setf (postgresql-connection-pid connection)
438 (read-socket-value 'int32 socket)
439 (postgresql-connection-key connection)
440 (read-socket-value 'int32 socket)))
441 (#.+ready-for-query-message+
444 (#.+error-response-message+
445 (let ((message (read-socket-value 'string socket)))
446 (error 'postgresql-login-error
447 :connection connection
449 (#.+notice-response-message+
450 (let ((message (read-socket-value 'string socket)))
451 (warn 'postgresql-warning :connection connection
454 (error 'postgresql-login-error
455 :connection connection
457 "Received garbled message from Postmaster")))))
461 (defun close-postgresql-connection (connection &optional abort)
464 (send-terminate-message (postgresql-connection-socket connection))))
465 (close (postgresql-connection-socket connection)))
467 (defun postgresql-connection-open-p (connection)
468 (let ((socket (postgresql-connection-socket connection)))
469 (and socket (streamp socket) (open-stream-p socket))))
471 (defun ensure-open-postgresql-connection (connection)
472 (unless (postgresql-connection-open-p connection)
473 (reopen-postgresql-connection connection)))
475 (defun process-async-messages (connection)
476 (assert (postgresql-connection-open-p connection))
477 ;; Process any asnychronous messages
478 (loop with socket = (postgresql-connection-socket connection)
479 while (listen socket)
481 (case (read-socket-value 'int8 socket)
482 (#.+notice-response-message+
483 (let ((message (read-socket-value 'string socket)))
484 (warn 'postgresql-warning :connection connection
486 (#.+notification-response-message+
487 (let ((pid (read-socket-value 'int32 socket))
488 (message (read-socket-value 'string socket)))
489 (when (= pid (postgresql-connection-pid connection))
490 (signal 'postgresql-notification :connection connection
493 (close-postgresql-connection connection)
494 (error 'postgresql-fatal-error :connection connection
495 :message "Received garbled message from backend")))))
497 (defun start-query-execution (connection query)
498 (ensure-open-postgresql-connection connection)
499 (process-async-messages connection)
500 (send-query-message (postgresql-connection-socket connection) query)
501 (force-output (postgresql-connection-socket connection)))
503 (defun wait-for-query-results (connection)
504 (assert (postgresql-connection-open-p connection))
505 (let ((socket (postgresql-connection-socket connection))
509 (case (read-socket-value 'int8 socket)
510 (#.+completed-response-message+
511 (return (values :completed (read-socket-value 'string socket))))
512 (#.+cursor-response-message+
513 (setq cursor-name (read-socket-value 'string socket)))
514 (#.+row-description-message+
515 (let* ((count (read-socket-value 'int16 socket))
520 (read-socket-value 'string socket)
521 (read-socket-value 'int32 socket)
522 (read-socket-value 'int16 socket)
523 (read-socket-value 'int32 socket)))))
526 (make-postgresql-cursor :connection connection
529 (#.+copy-in-response-message+
531 (#.+copy-out-response-message+
533 (#.+ready-for-query-message+
537 (#.+error-response-message+
538 (let ((message (read-socket-value 'string socket)))
540 (make-condition 'postgresql-error
541 :connection connection :message message))))
542 (#.+notice-response-message+
543 (let ((message (read-socket-value 'string socket)))
544 (warn 'postgresql-warning
545 :connection connection :message message)))
546 (#.+notification-response-message+
547 (let ((pid (read-socket-value 'int32 socket))
548 (message (read-socket-value 'string socket)))
549 (when (= pid (postgresql-connection-pid connection))
550 (signal 'postgresql-notification :connection connection
553 (close-postgresql-connection connection)
554 (error 'postgresql-fatal-error :connection connection
555 :message "Received garbled message from backend"))))))
557 (defun read-null-bit-vector (socket count)
558 (let ((result (make-array count :element-type 'bit)))
559 (dotimes (offset (ceiling count 8))
560 (loop with byte = (read-byte socket)
561 for index from (* offset 8) below (min count (* (1+ offset) 8))
562 for weight downfrom 7
563 do (setf (aref result index) (ldb (byte 1 weight) byte))))
566 (defun read-field (socket type)
567 (let* ((length (read-socket-value 'int32 socket))
568 (result (make-string (- length 4))))
569 (read-socket-sequence result socket)
572 (parse-integer result))
574 (let ((*read-default-float-format* 'double-float))
575 (read-from-string result)))
579 (defun read-field2 (socket type)
580 (let* ((length (read-socket-value 'int32 socket)))
583 (read-integer-from-socket socket length))
585 (read-double-from-socket socket length))
587 (let ((result (make-string (- length 4))))
588 (read-socket-sequence result socket)
591 (defun read-integer-from-socket (socket length)
593 (first-char (read-byte socket))
595 (if (eql first-char (char-code #\-))
597 (setq val (- first-char (char-code #\0))))
598 (dotimes (i (1- length))
601 (- (read-byte socket) (char-code #\0)))))
608 (defun read-cursor-row (cursor types)
609 (let* ((connection (postgresql-cursor-connection cursor))
610 (socket (postgresql-connection-socket connection))
611 (fields (postgresql-cursor-fields cursor)))
612 (assert (postgresql-connection-open-p connection))
614 (let ((code (read-socket-value 'int8 socket)))
616 (#.+ascii-row-message+
618 (loop with count = (length fields)
619 with null-vector = (read-null-bit-vector socket count)
621 for null-bit across null-vector
623 for null-p = (zerop null-bit)
628 (read-field socket (nth i types)))))
629 (#.+binary-row-message+
631 (#.+completed-response-message+
632 (return (values nil (read-socket-value 'string socket))))
633 (#.+error-response-message+
634 (let ((message (read-socket-value 'string socket)))
635 (error 'postgresql-error
636 :connection connection :message message)))
637 (#.+notice-response-message+
638 (let ((message (read-socket-value 'string socket)))
639 (warn 'postgresql-warning
640 :connection connection :message message)))
641 (#.+notification-response-message+
642 (let ((pid (read-socket-value 'int32 socket))
643 (message (read-socket-value 'string socket)))
644 (when (= pid (postgresql-connection-pid connection))
645 (signal 'postgresql-notification :connection connection
648 (close-postgresql-connection connection)
649 (error 'postgresql-fatal-error :connection connection
650 :message "Received garbled message from backend")))))))
652 (defun map-into-indexed (result-seq func seq)
653 (dotimes (i (length seq))
655 (setf (elt result-seq i)
656 (funcall func (elt seq i) i)))
659 (defun copy-cursor-row (cursor sequence types)
660 (let* ((connection (postgresql-cursor-connection cursor))
661 (socket (postgresql-connection-socket connection))
662 (fields (postgresql-cursor-fields cursor)))
663 (assert (= (length fields) (length sequence)))
665 (let ((code (read-socket-value 'int8 socket)))
667 (#.+ascii-row-message+
670 (let* ((count (length sequence))
671 (null-vector (read-null-bit-vector socket count)))
674 (if (zerop (elt null-vector i))
675 (setf (elt sequence i) nil)
676 (let ((value (read-field socket (nth i types))))
677 (setf (elt sequence i) value)))))
680 #'(lambda (null-bit i)
683 (read-field socket (nth i types))))
684 (read-null-bit-vector socket (length sequence)))))
685 (#.+binary-row-message+
687 (#.+completed-response-message+
688 (return (values nil (read-socket-value 'string socket))))
689 (#.+error-response-message+
690 (let ((message (read-socket-value 'string socket)))
691 (error 'postgresql-error
692 :connection connection :message message)))
693 (#.+notice-response-message+
694 (let ((message (read-socket-value 'string socket)))
695 (warn 'postgresql-warning
696 :connection connection :message message)))
697 (#.+notification-response-message+
698 (let ((pid (read-socket-value 'int32 socket))
699 (message (read-socket-value 'string socket)))
700 (when (= pid (postgresql-connection-pid connection))
701 (signal 'postgresql-notification :connection connection
704 (close-postgresql-connection connection)
705 (error 'postgresql-fatal-error :connection connection
706 :message "Received garbled message from backend")))))))
708 (defun skip-cursor-row (cursor)
709 (let* ((connection (postgresql-cursor-connection cursor))
710 (socket (postgresql-connection-socket connection))
711 (fields (postgresql-cursor-fields cursor)))
713 (let ((code (read-socket-value 'int8 socket)))
715 (#.+ascii-row-message+
716 (loop for null-bit across
717 (read-null-bit-vector socket (length fields))
719 (unless (zerop null-bit)
720 (let* ((length (read-socket-value 'int32 socket)))
721 (loop repeat (- length 4) do (read-byte socket)))))
723 (#.+binary-row-message+
725 (#.+completed-response-message+
726 (return (values nil (read-socket-value 'string socket))))
727 (#.+error-response-message+
728 (let ((message (read-socket-value 'string socket)))
729 (error 'postgresql-error
730 :connection connection :message message)))
731 (#.+notice-response-message+
732 (let ((message (read-socket-value 'string socket)))
733 (warn 'postgresql-warning
734 :connection connection :message message)))
735 (#.+notification-response-message+
736 (let ((pid (read-socket-value 'int32 socket))
737 (message (read-socket-value 'string socket)))
738 (when (= pid (postgresql-connection-pid connection))
739 (signal 'postgresql-notification :connection connection
742 (close-postgresql-connection connection)
743 (error 'postgresql-fatal-error :connection connection
744 :message "Received garbled message from backend")))))))
746 (defun run-query (connection query &optional (types nil))
747 (start-query-execution connection query)
748 (multiple-value-bind (status cursor)
749 (wait-for-query-results connection)
750 (assert (eq status :cursor))
751 (loop for row = (read-cursor-row cursor types)
755 (wait-for-query-results connection))))