From emarsden at common-lisp.net  Thu Apr  1 18:35:19 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Thu, 01 Apr 2004 13:35:19 -0500
Subject: [pg-cvs] CVS update: pg/README pg/pg.asd pg/sysdep.lisp
	pg/v2-protocol.lisp pg/v3-protocol.lisp 
Message-ID: <E1B9727-0005Ef-00@common-lisp.net>

Update of /project/pg/cvsroot/pg
In directory common-lisp.net:/tmp/cvs-serv23682

Modified Files:
	README pg.asd sysdep.lisp v2-protocol.lisp v3-protocol.lisp 
Log Message:

  - add md5 authentication (thanks to Brian Mastenbrook). Uses Pierre Mai's
    portable md5.lisp library, that has been added to the project (with extra
    EVAL-WHENness to please OpenMCL and ACL).

    Tested with CMUCL, SBCL, OpenMCL, CLISP, ACL 6.1. ABCL does not compile
    md5.lisp, probably for more EVAL-WHEN reasons. Only tested with PostgreSQL
    version 7.4. 


Date: Thu Apr  1 13:35:19 2004
Author: emarsden

Index: pg/README
diff -u pg/README:1.2 pg/README:1.3
--- pg/README:1.2	Mon Mar  8 10:01:53 2004
+++ pg/README	Thu Apr  1 13:35:19 2004
@@ -1,8 +1,8 @@
 pg.lisp -- socket level interface to the PostgreSQL RDBMS for Common Lisp
 
  Author: Eric Marsden <emarsden at laas.fr>
- Time-stamp: <2004-03-08 emarsden>
- Version: 0.21
+ Time-stamp: <2004-04-01 emarsden>
+ Version: 0.22
 
      Copyright (C) 1999,2000,2001,2002,2003,2004  Eric Marsden
 
@@ -206,15 +206,19 @@
 
  pg.lisp is able to use the crypt authentication method to avoid
  sending the password in cleartext over the wire (this assumes access
- to the `crypt' function via the FFI). It does not support the
- Kerberos authentication method, nor OpenSSL connections (though this
- should not be difficult if your Common Lisp implementation is able to
- open SSL streams). However, it is possible to use the port forwarding
- capabilities of ssh to establish a connection to the backend over
- TCP/IP, which provides both a secure authentication mechanism and
- encryption (and optionally compression) of data passing through the
- tunnel. Here's how to do it (thanks to Gene Selkov, Jr.
- <selkovjr at mcs.anl.gov> for the description):
+ to the `crypt' function via the FFI -- see sysdep.lisp). It can also
+ use md5 passwords (which are used with the WITH ENCRYPTED PASSWORD
+ form of the CREATE USER command), thanks to Pierre Mai's portable md5
+ library. It does not support the Kerberos authentication method, nor
+ OpenSSL connections (though this should not be difficult if your
+ Common Lisp implementation is able to open SSL streams).
+
+ It is also possible to use the port forwarding capabilities of ssh to
+ establish a connection to the backend over TCP/IP, which provides
+ both a secure authentication mechanism and encryption (and optionally
+ compression) of data passing through the tunnel. Here's how to do it
+ (thanks to Gene Selkov, Jr. <selkovjr at mcs.anl.gov> for the
+ description):
 
  1. Establish a tunnel to the backend machine, like this:
 
@@ -244,8 +248,11 @@
 
    * CMUCL 18d and 18e on Solaris/SPARC and Linux/x86
    * CLISP 2.30 on LinuxPPC and SPARC
+   * OpenMCL 0.13.x and 0.14.x on LinuxPPC
+   * Armed Bear Common Lisp 
    * ACL 6.1 trial/x86
-   * PostgreSQL 6.5, 7.0, 7.1.2, 7.2, 7.3, 7.4
+   * Lispworks 4.3 on Linux and Windows
+   * PostgreSQL versions 6.5, 7.0, 7.1.2, 7.2, 7.3, 7.4
 
 
 You may be interested in using "pg-psql" by Harley Gorrell, which


Index: pg/pg.asd
diff -u pg/pg.asd:1.4 pg/pg.asd:1.5
--- pg/pg.asd:1.4	Mon Mar  8 10:01:53 2004
+++ pg/pg.asd	Thu Apr  1 13:35:19 2004
@@ -17,7 +17,8 @@
     :author "Eric Marsden"
     :version "0.21"
     :components ((:file "defpackage")
-                 (:pg-component "sysdep" :depends-on ("defpackage"))
+                 (:file "md5")
+                 (:pg-component "sysdep" :depends-on ("defpackage" "md5"))
                  (:file "meta-queries" :depends-on ("defpackage"))
                  (:file "parsers" :depends-on ("defpackage"))
                  (:file "utility" :depends-on ("defpackage"))


Index: pg/sysdep.lisp
diff -u pg/sysdep.lisp:1.4 pg/sysdep.lisp:1.5
--- pg/sysdep.lisp:1.4	Wed Mar 17 13:13:10 2004
+++ pg/sysdep.lisp	Thu Apr  1 13:35:19 2004
@@ -1,7 +1,7 @@
 ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
 ;;;
 ;;; Author: Eric Marsden <emarsden at laas.fr>
-;;; Time-stamp: <2004-03-17 emarsden>
+;;; Time-stamp: <2004-04-01 emarsden>
 ;;
 ;;
 
@@ -11,7 +11,7 @@
   #+allegro (require :socket)
   #+lispworks (require "comm")
   #+cormanlisp (require :sockets)
-  #+sbcl (progn (require :asdf) (require :sb-bsd-sockets))
+  #+sbcl (progn (require :asdf) (require :sb-bsd-sockets) (require :sb-md5))
   #+(and mcl (not openmcl)) (require "OPENTRANSPORT"))
 
 
@@ -33,6 +33,18 @@
 (defun crypt (key salt)
   (declare (ignore salt))
   key)
+
+
+(defun md5-digest (string &rest strings)
+  (declare (type simple-string string))
+  (let ((vec (md5:md5sum-sequence
+              (apply #'concatenate 'string string strings))))
+    (format nil "~(~{~2,'0X~}~)" (coerce vec 'list))))
+
+(defun md5-encode-password (user password salt)
+  (concatenate 'string "md5"
+               (md5-digest (md5-digest password user) salt)))
+
 
 
 ;; this is a little fiddly, because CLISP can be built without support


Index: pg/v2-protocol.lisp
diff -u pg/v2-protocol.lisp:1.3 pg/v2-protocol.lisp:1.4
--- pg/v2-protocol.lisp:1.3	Mon Mar  8 13:12:45 2004
+++ pg/v2-protocol.lisp	Thu Apr  1 13:35:19 2004
@@ -1,7 +1,6 @@
 ;;; v2-protocol.lisp -- frontend/backend protocol prior to PostgreSQL 7.4
 ;;;
 ;;; Author: Eric Marsden <emarsden at laas.fr>
-;;; Time-stamp: <2004-03-08 emarsden>
 
 
 (in-package :postgresql)
@@ -27,7 +26,6 @@
     (send-string connection dbname +SM_DATABASE+)
     (send-string connection user user-packet-length)
     (%flush connection)
-    #+cmu (ext:finalize connection (lambda () (pg-disconnect connection)))
     (loop
      (case (read-byte stream)
        ;; ErrorResponse
@@ -58,10 +56,21 @@
                   (crypted (crypt password salt)))
              #+debug
              (format *debug-io* "Got salt of ~s~%" salt)
-             (send-int connection (+ 5 (length crypted)) 4)
+             (send-int connection (+ 4 (length crypted) 1) 4)
              (send-string connection crypted)
              (send-int connection 0 1)
              (%flush connection)))
+          ((5)                          ; AuthMD5Password
+           #+debug
+           (format *debug-io* "MD5Auth: got salt of ~s~%" salt)
+           (force-output *debug-io*)
+           (let* ((salt (%read-chars stream 4))
+                  (ciphered (md5-encode-password user password salt)))
+             (send-int connection (+ 4 (length ciphered) 1) 4)
+             (send-string connection ciphered)
+             (send-int connection 0 1)
+             (%flush connection)))
+
           ((1)                          ; AuthKerberos4
            (error 'authentication-failure
                   :reason "Kerberos4 authentication not supported"))


Index: pg/v3-protocol.lisp
diff -u pg/v3-protocol.lisp:1.8 pg/v3-protocol.lisp:1.9
--- pg/v3-protocol.lisp:1.8	Sat Mar 20 16:48:41 2004
+++ pg/v3-protocol.lisp	Thu Apr  1 13:35:19 2004
@@ -248,8 +248,10 @@
    "Reads an array of LENGTH bytes from the packet")
   (:method ((packet pg-packet) (length (eql -1)))
     nil)
+  (:method ((packet pg-packet) (length (eql 0)))
+    nil)
   (:method ((packet pg-packet) (length integer))
-    (when (<= length 0)
+    (when (< length 0)
       (error "length cannot be negative. is: ~S"
              length))
     (let ((result (make-array length
@@ -383,22 +385,23 @@
              (error 'authentication-failure
                     :reason "Kerberos5 authentication not supported"))
             ((3)                          ; AuthUnencryptedPassword
-             (send-packet connection
-                          #\p
-                          `((:cstring ,password)))
+             (send-packet connection #\p `((:cstring ,password)))
              (%flush connection))
             ((4)                          ; AuthEncryptedPassword
              (let* ((salt (read-string-from-packet packet 2))
                     (crypted (crypt password salt)))
                #+debug
-               (format *debug-io* "Got salt of ~s~%" salt)
-               (send-packet connection
-                             #\p
-                             `((:cstring ,crypted)))
+               (format *debug-io* "CryptAuth: Got salt of ~s~%" salt)
+               (send-packet connection #\p `((:cstring ,crypted)))
                (%flush connection)))
             ((5)                          ; AuthMD5Password
-             (error 'authentication-failure
-                    :reason "MD5 authentication not supported"))
+             #+debug
+             (format *debug-io* "MD5Auth: got salt of ~s~%" salt)
+             (force-output *debug-io*)
+             (let* ((salt (read-string-from-packet packet 4))
+                    (ciphered (md5-encode-password user password salt)))
+               (send-packet connection #\p `((:cstring ,ciphered)))
+               (%flush connection)))
             ((6)                          ; AuthSCMPassword
              (error 'authentication-failure
                     :reason "SCM authentication not supported"))




From emarsden at common-lisp.net  Tue Apr 20 12:59:07 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Tue, 20 Apr 2004 08:59:07 -0400
Subject: [pg-cvs] CVS update: pg/md5.lisp 
Message-ID: <E1BFuqB-0002Al-00@common-lisp.net>

Update of /project/pg/cvsroot/pg
In directory common-lisp.net:/tmp/cvs-serv25733

Added Files:
	md5.lisp 
Log Message:
 
  - imported file, with some minor changes to Pierre Mai's original code
    to improve portability (mostly adding EVAL-WHEN clauses).


Date: Tue Apr 20 08:59:06 2004
Author: emarsden





From emarsden at common-lisp.net  Wed Apr 21 19:23:18 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Wed, 21 Apr 2004 15:23:18 -0400
Subject: [pg-cvs] CVS update: pg/parsers.lisp 
Message-ID: <E1BGNJW-0005ZI-00@common-lisp.net>

Update of /project/pg/cvsroot/pg
In directory common-lisp.net:/tmp/cvs-serv13664

Modified Files:
	parsers.lisp 
Log Message:
>From Sven Van Caekenberghe:

  - fix to PARSE-TIMESTAMP when no milliseconds are present
  
  - make use of :start and :end arguments to PARSE-INTEGER to reduce consing


Date: Wed Apr 21 15:23:18 2004
Author: emarsden

Index: pg/parsers.lisp
diff -u pg/parsers.lisp:1.2 pg/parsers.lisp:1.3
--- pg/parsers.lisp:1.2	Mon Mar  8 09:37:36 2004
+++ pg/parsers.lisp	Wed Apr 21 15:23:18 2004
@@ -1,7 +1,6 @@
 ;;; parsers.lisp -- type coercion support
 ;;;
 ;;; Author: Eric Marsden <emarsden at laas.fr>
-;;; Time-stamp: <2004-03-05 emarsden>
 ;;
 ;;
 ;; When returning data from a SELECT statement, PostgreSQL starts by
@@ -100,11 +99,15 @@
 ;; FIXME switch to a specialized float parser
 (defun float-parser (str)
   (declare (type simple-string str))
-
   (let ((*read-eval* nil))
     (read-from-string str)))
 
-;; FIXME this may need support for charset decoding
+;; here we are assuming that the value of *PG-CLIENT-ENCODING* is
+;; compatible with the encoding that the CL implementation uses for
+;; strings. The backend should convert all values belonging to one of
+;; the text data types from the table's internal representation to
+;; that requested by the client, so here we don't need to do any
+;; conversion.
 (defun text-parser (str) str)
 
 (defun bool-parser (str)
@@ -116,18 +119,20 @@
 
 (defun parse-timestamp (str)
   (declare (type simple-string str))
-  (let* ((year (parse-integer (subseq str 0 4)))
-         (month (parse-integer (subseq str 5 7)))
-         (day (parse-integer (subseq str 8 10)))
-         (hours (parse-integer (subseq str 11 13)))
-         (minutes (parse-integer (subseq str 14 16)))
-         (seconds (parse-integer (subseq str 17 19)))
-         (start-tz (if (eql #\+ (char str (- (length str) 3)))
-                       (- (length str) 3)))
+  (let* ((year (parse-integer str :start 0 :end 4))
+         (month (parse-integer str :start 5 :end 7))
+         (day (parse-integer str :start 8 :end 10))
+         (hours (parse-integer str :start 11 :end 13))
+         (minutes (parse-integer str :start 14 :end 16))
+         (seconds (parse-integer str :start 17 :end 19))
+         (length (length str))
+         (start-tz (if (eql #\+ (char str (- length 3)))
+                       (- length 3)))
          (tz (when start-tz
-               (parse-integer (subseq str start-tz))))
-         (milliseconds (if (eql (char str 19) #\.)
-                           (parse-integer (subseq str 20 start-tz)) 0)))
+               (parse-integer str :start start-tz)))
+         (milliseconds (if (and (< 19 length) (eql (char str 19) #\.))
+                           (parse-integer str :start 20 :end start-tz)
+                           0)))
     (values year month day hours minutes seconds milliseconds tz)))
 
 ;; format for abstime/timestamp etc with ISO output syntax is
@@ -151,10 +156,10 @@
 ;; An interval is what you get when you subtract two timestamps. We
 ;; convert to a number of seconds.
 (defun interval-parser (str)
-  (let* ((hours (parse-integer (subseq str 0 2)))
-         (minutes (parse-integer (subseq str 3 5)))
-         (seconds (parse-integer (subseq str 6 8)))
-         (milliseconds (parse-integer (subseq str 9))))
+  (let* ((hours (parse-integer str :start 0 :end 2))
+         (minutes (parse-integer str :start 3 :end 5))
+         (seconds (parse-integer str :start 6 :end 8))
+         (milliseconds (parse-integer str :start 9)))
     (+ (/ milliseconds (expt 10.0 (- (length str) 9)))
        seconds
        (* 60 minutes)
@@ -165,22 +170,22 @@
 ;;;    "1999-01-02 00:00:00+01"
 ;; which we convert to a CL universal time
 (defun isodate-parser (str)
-  (let ((year    (parse-integer (subseq str 0 4)))
-        (month   (parse-integer (subseq str 5 7)))
-        (day     (parse-integer (subseq str 8 10)))
-        (hours   (parse-integer (subseq str 11 13)))
-        (minutes (parse-integer (subseq str 14 16)))
-        (seconds (parse-integer (subseq str 17 19)))
-        (tz      (parse-integer (subseq str 19 22))))
+  (let ((year    (parse-integer str :start 0 :end 4))
+        (month   (parse-integer str :start 5 :end 7))
+        (day     (parse-integer str :start 8 :end 10))
+        (hours   (parse-integer str :start 11 :end 13))
+        (minutes (parse-integer str :start 14 :end 16))
+        (seconds (parse-integer str :start 17 :end 19))
+        (tz      (parse-integer str :start 19 :end 22)))
     (encode-universal-time seconds minutes hours day month year tz)))
 
 ;; format for date with ISO output syntax is
 ;;;    "1999-01-02"
 ;; which we convert to a CL universal time
 (defun date-parser (str)
-  (let ((year    (parse-integer (subseq str 0 4)))
-        (month   (parse-integer (subseq str 5 7)))
-        (day     (parse-integer (subseq str 8 10))))
+  (let ((year    (parse-integer str :start 0 :end 4))
+        (month   (parse-integer str :start 5 :end 7))
+        (day     (parse-integer str :start 8 :end 10)))
     (encode-universal-time 0 0 0 day month year)))
 
 (defun initialize-parsers (connection)
@@ -204,6 +209,8 @@
                    oid)))))
      tuples)))
 
+;; FIXME should perhaps resignal parse errors as a condition derived
+;; from POSTGRESQL-ERROR
 (defun parse (str oid)
   (declare (type simple-string str))
   (let ((parser (assoc oid *parsers* :test #'eql)))




From emarsden at common-lisp.net  Wed Apr 21 19:27:47 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Wed, 21 Apr 2004 15:27:47 -0400
Subject: [pg-cvs] CVS update: pg/v3-protocol.lisp 
Message-ID: <E1BGNNr-0006zB-00@common-lisp.net>

Update of /project/pg/cvsroot/pg
In directory common-lisp.net:/tmp/cvs-serv23077

Modified Files:
	v3-protocol.lisp 
Log Message:

A provisional fix for large object support: the test case (whose
large-object component only runs on CMUCL) was resetting the connection
during the IMPORT/EXPORT test, due to an unexpected #\V packet
(FunctionCallResponse) in DO-FOLLOWUP-QUERY. It's still not clear why a
FunctionCallResponse should be received anywhere other than in FN.
This test is currently failing due to CR -> "\012" corruption that I haven't
debugged. 



Date: Wed Apr 21 15:27:47 2004
Author: emarsden

Index: pg/v3-protocol.lisp
diff -u pg/v3-protocol.lisp:1.9 pg/v3-protocol.lisp:1.10
--- pg/v3-protocol.lisp:1.9	Thu Apr  1 13:35:19 2004
+++ pg/v3-protocol.lisp	Wed Apr 21 15:27:46 2004
@@ -579,8 +579,14 @@
            ;; PortalSuspend
            ;; we're done in any case:
            (return result))
-         ((#\2
-           ;; BindComplete
+          ((#\V)
+           ;; FunctionCallResponse -- not clear why we would get these here instead of in FN
+           (let* ((length (read-from-packet packet :int32))
+                  (response (unless (= length -1)
+                              (read-string-from-packet packet length))))
+             (setf (pgresult-status result) response)))
+          ((#\2
+            ;; BindComplete
            #\1
            ;; ParseComplete
            #\3
@@ -709,7 +715,7 @@
           :for packet = (read-packet connection)
           :do
           (case (pg-packet-type packet)
-            ((#\V)
+            ((#\V) ; FunctionCallResponse
              (let* ((length (read-from-packet packet :int32))
                     (data (unless (= length -1)
                             (if integer-result




From emarsden at common-lisp.net  Thu Apr 22 16:57:40 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Thu, 22 Apr 2004 12:57:40 -0400
Subject: [pg-cvs] CVS update: pg/defpackage.lisp 
Message-ID: <E1BGhW8-0001Nh-00@common-lisp.net>

Update of /project/pg/cvsroot/pg
In directory common-lisp.net:/tmp/cvs-serv5065

Modified Files:
	defpackage.lisp 
Log Message:

  - export the *PG-CLIENT-ENCODING* variable from the PG package
  

Date: Thu Apr 22 12:57:39 2004
Author: emarsden

Index: pg/defpackage.lisp
diff -u pg/defpackage.lisp:1.3 pg/defpackage.lisp:1.4
--- pg/defpackage.lisp:1.3	Tue Mar  9 11:27:20 2004
+++ pg/defpackage.lisp	Thu Apr 22 12:57:39 2004
@@ -8,6 +8,7 @@
   (:export #:pg-connect #:pg-exec #:pg-result #:pg-disconnect
 	   #:pgcon-sql-stream
            #:*pg-disable-type-coercion*
+           #:*pg-client-encoding*
            #:pg-databases #:pg-tables #:pg-columns
            #:pg-backend-version
            #:pg-date-style




From emarsden at common-lisp.net  Thu Apr 22 17:00:12 2004
From: emarsden at common-lisp.net (Eric Marsden)
Date: Thu, 22 Apr 2004 13:00:12 -0400
Subject: [pg-cvs] CVS update: pg/v3-protocol.lisp 
Message-ID: <E1BGhYa-000608-00@common-lisp.net>

Update of /project/pg/cvsroot/pg
In directory common-lisp.net:/tmp/cvs-serv6507

Modified Files:
	v3-protocol.lisp 
Log Message:

Comment-only patch: mark the places in the v3-protocol code where charset
encoding problems will have to be addressed. 

It's probably not worth going through the v2-protocol code to fix these
issues, since it has too many places where READ-CSTRING is confused with
READ-OCTET-ARRAY. 


Date: Thu Apr 22 13:00:12 2004
Author: emarsden

Index: pg/v3-protocol.lisp
diff -u pg/v3-protocol.lisp:1.10 pg/v3-protocol.lisp:1.11
--- pg/v3-protocol.lisp:1.10	Wed Apr 21 15:27:46 2004
+++ pg/v3-protocol.lisp	Thu Apr 22 13:00:12 2004
@@ -233,6 +233,7 @@
              (result (unless (= end position)
                        (make-array (- end position)
                                    :element-type 'base-char))))
+        ;; FIXME need to handle charset encoding issues here
         (when result
           (loop :for i :from position :below end
                 :for j :from 0
@@ -243,6 +244,9 @@
           (setf position (1+ end))
           result)))))
 
+;; FIXME need to check all callers of this function to distinguish
+;; between uses that expect charset encoding to be handled, and those
+;; that really want READ-OCTET-ARRAY-FROM-PACKET
 (defgeneric read-string-from-packet (packet length)
   (:documentation
    "Reads an array of LENGTH bytes from the packet")
@@ -316,6 +320,9 @@
              (setf (elt data (+ 2 position)) (ldb (byte 8 8) value))
              (setf (elt data (+ 3 position)) (ldb (byte 8 0) value))
              (incf position 4))
+            ;; FIXME need to deal with text encoding issues here:
+            ;; transform from the Lisp string representation to the
+            ;; encoding selected by *PG-CLIENT-ENCODING*. 
             ((:cstring)
              (check-type value string)