X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=db-postgresql-socket%2Fpostgresql-socket-api.lisp;h=40dc86a780d46d88c1a146b7ecbced867cc6eaee;hp=b12424cce74aa77c547d9a18725b5aee0ec40ffc;hb=f67c4e2a4e5b8371a1b7c1629828999ff909f538;hpb=d2d49ab13c98bc7a1819a0fd3968268a5567bdc3

diff --git a/db-postgresql-socket/postgresql-socket-api.lisp b/db-postgresql-socket/postgresql-socket-api.lisp
index b12424c..40dc86a 100644
--- a/db-postgresql-socket/postgresql-socket-api.lisp
+++ b/db-postgresql-socket/postgresql-socket-api.lisp
@@ -17,6 +17,15 @@
 
 (in-package #:postgresql-socket)
 
+;; KMR: 2011-06-12
+;; FIXME: The file has code specific to sb-unicode and CCL
+;; to assume UTF8 encoded strings.
+;; Best fix would be to use the user-specified encoding that is now
+;; stored in the database object and use the UFFI 2.x encoding functions
+;; to convert strings to/from octet vectors. This allows encoding
+;; other than UTF8 and also works on all CL implementations that
+;; support wide character strings
+
 (uffi:def-enum pgsql-ftype
     ((:bytea 17)
      (:int2 21)
@@ -105,13 +114,19 @@ socket interface"
 (defun send-socket-value-string (socket value)
   (declare (type stream socket)
            (type string value))
-  #-sb-unicode
+  #-(or sb-unicode ccl)
   (loop for char across value
-        for code = (char-code char)
-        do (write-byte code socket)
-        finally (write-byte 0 socket))
+     for code = (char-code char)
+     do (write-byte code socket)
+     finally (write-byte 0 socket))
+  #+ccl
+  (write-sequence (ccl:encode-string-to-octets
+                   value :external-format :utf-8) socket)
+  #+ccl
+  (write-byte 0 socket)
   #+sb-unicode
-  (write-sequence (sb-ext:string-to-octets value :null-terminate t) socket)
+  (write-sequence (sb-ext:string-to-octets value :null-terminate t)
+                  socket)
   nil)
 
 (defun send-socket-value-limstring (socket value limit)
@@ -150,24 +165,33 @@ socket interface"
   (declare (type stream socket))
   (read-byte socket))
 
+
 (defun read-socket-value-string (socket)
   (declare (type stream socket))
-  #-sb-unicode
+  #-(or sb-unicode ccl)
   (with-output-to-string (out)
     (loop for code = (read-byte socket)
-          until (zerop code)
-          do (write-char (code-char code) out)))
+       until (zerop code)
+       do (write-char (code-char code) out)))
+  #+ccl
+  (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))
+    (ccl:decode-string-from-octets bytes :external-format :utf-8))
   #+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)
+       until (zerop code)
           do (vector-push-extend code bytes))
     (sb-ext:octets-to-string bytes)))
 
-
 (defmacro define-message-sender (name (&rest args) &rest clauses)
   (let ((socket-var (gensym))
         (body nil))
@@ -210,15 +234,30 @@ socket interface"
   (int32 pid)
   (int32 key))
 
+(defun read-bytes (socket length)
+  "Read a byte array of the given length from a stream."
+  (declare (type stream socket)
+           (type fixnum length)
+           (optimize (speed 3) (safety 0)))
+  (let ((result (make-array length :element-type '(unsigned-byte 8))))
+    (read-sequence result socket)
+    result))
 
 (defun read-socket-sequence (stream length &optional (allow-wide t))
   (declare (stream stream)
            (optimize (speed 3) (safety 0)))
-  #-sb-unicode
+  #-(or sb-unicode ccl)
   (let ((result (make-string length)))
     (dotimes (i length result)
       (declare (fixnum i))
       (setf (char result i) (code-char (read-byte stream)))))
+  #+ccl
+  (let ((bytes (make-array length :element-type '(unsigned-byte 8))))
+    (declare (type (simple-array (unsigned-byte 8) (*)) bytes))
+    (read-sequence bytes stream)
+    (if allow-wide
+	(ccl:decode-string-from-octets bytes :external-format :utf-8)
+	(map 'string #'code-char bytes)))
   #+sb-unicode
   (let ((bytes (make-array length :element-type '(unsigned-byte 8))))
     (declare (type (simple-array (unsigned-byte 8) (*)) bytes))
@@ -456,10 +495,16 @@ troubles."
                                :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 byte-sequence-to-hex-string (sequence)
+  (string-downcase (format nil "~{~2,'0X~}" (coerce sequence 'list))))
+
+(defun encrypt-password-md5 (password user salt)
+  (let ((pass1 (byte-sequence-to-hex-string
+		(md5::md5sum-string (concatenate 'string password user)))))
+    (byte-sequence-to-hex-string
+     (md5:md5sum-sequence (concatenate '(vector (unsigned-byte 8))
+				   (map '(vector (unsigned-byte 8)) #'char-code pass1)
+				   salt)))))
 
 (defun reopen-postgresql-connection (connection)
   "Reopen the given PostgreSQL connection.  Closes any existing
@@ -501,10 +546,11 @@ connection, if it is still open."
                          (postgresql-connection-password connection) salt)))
                      (force-output socket))
                     (5
-                     (let ((salt (read-socket-sequence socket 4 nil)))
-                       (let* ((pwd2 (encrypt-md5 (postgresql-connection-password connection)
-                                                 (postgresql-connection-user connection)))
-                              (pwd (encrypt-md5 pwd2 salt)))
+                     (let ((salt (read-bytes socket 4)))
+                       (let ((pwd (encrypt-password-md5
+				   (postgresql-connection-password connection)
+				   (postgresql-connection-user connection)
+				   salt)))
                          (send-encrypted-password-message
                           socket
                           (concatenate 'string "md5" pwd))))