;;;; Authors: Kevin M. Rosenberg based on original code by Pierre R. Mai
;;;; Created: Feb 2002
;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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
(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)
(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)
(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))
(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))
: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
(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))))
projects / clsql.git / blobdiff