Permalink
Browse files

Unicode support

git-archimport-id: mange@freemail.hu--2005/cl-sasl--devo--0.1--patch-2
  • Loading branch information...
1 parent d602110 commit 9ccad427f4e6302240b067d723c534192211095a @legoscia committed Nov 6, 2005
Showing with 120 additions and 33 deletions.
  1. +3 −3 README
  2. +5 −5 client.lisp
  3. +30 −20 digest-md5.lisp
  4. +4 −4 plain.lisp
  5. +2 −1 sasl.asd
  6. +76 −0 util.lisp
View
@@ -4,8 +4,7 @@ This is an SASL client library for Common Lisp.
This library depends on cl-md5. Find it in Debian or on cliki.
* Supported mechanisms
-Currently PLAIN and DIGEST-MD5 are supported. Non-ASCII data will
-probably not work.
+Currently PLAIN and DIGEST-MD5 are supported.
* Usage
Create an instance of the mechanism you want to use. If you want to
@@ -29,7 +28,8 @@ call sasl:client-step with :SUCCESS, and proceed _only_ if it returns
* Compatibility
I have only tested this code on CLISP, but it should work on other
-implementations as well.
+implementations as well. The code assumes that CHAR-CODE returns the
+Unicode code point for every character in the given arguments.
* Contact
Feedback goes to henoch@dtek.chalmers.se.
View
@@ -33,16 +33,16 @@
(defgeneric client-step (client server-input)
(:documentation "Perform a step in the SASL authentication.
-SERVER-INPUT is a string containing the response from the server,
-or NIL if the client should start the exchange, or the
+SERVER-INPUT is a byte array containing the response from the
+server, or NIL if the client should start the exchange, or the
keyword :SUCCESS if the server reported successful
authentication.
-Returns a string to be sent in response to the server,
+Returns a byte array to be sent in response to the server,
or :SUCCESS if the client should consider authentication
successful, or :FAILURE if the client should consider
-authentication failed. Obeying this result is important, as
-some mechanisms provide mutual authentication."))
+authentication failed. Obeying this result is important, as some
+mechanisms provide mutual authentication."))
(defun get-password (password)
(etypecase password
View
@@ -20,8 +20,9 @@ as specified in RFC 2831."))
(:start
;; The server goes first, so wait if no input yet
(if (null server-input)
- ""
- (let ((challenge (parse-challenge server-input)))
+ #()
+ ;; XXX: we assume that the challenge is pure ASCII. correct?
+ (let ((challenge (parse-challenge (map 'string #'code-char server-input))))
;; If we know what realm we want, make sure we get it:
(if (realm c)
@@ -44,25 +45,27 @@ as specified in RFC 2831."))
(setf (state c) :sent)
;; XXX: obey charset directive
- (apply #'concatenate 'string
- "username=\"" (authc-id c) "\","
- "realm=\"" (realm c) "\","
- "nonce=\"" (nonce c) "\","
- "cnonce=\"" (cnonce c) "\","
- "nc=00000001,"
- "qop=auth,"
- "digest-uri=\"" (digest-uri-value c) "\","
- "charset=utf-8,"
- "response=" (response-value c t)
- (when (authz-id c)
- ",authzid=\"" (authz-id c) "\"")))))
+ (string-to-utf8
+ (apply #'concatenate 'string
+ "username=\"" (authc-id c) "\","
+ "realm=\"" (realm c) "\","
+ "nonce=\"" (nonce c) "\","
+ "cnonce=\"" (cnonce c) "\","
+ "nc=00000001,"
+ "qop=auth,"
+ "digest-uri=\"" (digest-uri-value c) "\","
+ "charset=utf-8,"
+ "response=" (response-value c t)
+ (when (authz-id c)
+ ",authzid=\"" (authz-id c) "\""))))))
(:sent
- (let ((challenge (parse-challenge server-input)))
+ ;; XXX: we assume that the challenge is pure ASCII. correct?
+ (let ((challenge (parse-challenge (map 'string #'code-char server-input))))
(if (string= (cdr (assoc "rspauth" challenge :test #'string=))
(response-value c nil))
(progn
(setf (state c) :success)
- "")
+ #())
:failure)))
(:success
(if (eql server-input :success)
@@ -77,16 +80,14 @@ as specified in RFC 2831."))
(labels ((c (&rest strings) (apply #'concatenate 'string strings))
(to-bytes (maybe-string)
(if (stringp maybe-string)
- (map '(simple-array
- (unsigned-byte 8))
- #'char-code maybe-string)
+ (string-to-latin1-or-utf8 maybe-string)
maybe-string))
(c-b (&rest maybe-strings) (apply #'concatenate
'(simple-array
(unsigned-byte 8))
(map 'list #'to-bytes
maybe-strings)))
- (h (string) (md5:md5sum-sequence string))
+ (h (string) (md5:md5sum-sequence (to-bytes string)))
(kd (k s) (h (c k ":" s)))
(hex (hash) (md5sum-to-hex hash)))
(let ((a1 (if authz-id
@@ -150,4 +151,13 @@ Start at index START."
(cons new-entry accumulated)
(parse-challenge challenge (1+ comma-position) (cons new-entry accumulated)))))))
+(defun string-to-latin1-or-utf8 (string)
+ "Convert STRING to ISO 8859-1 if possible, else to UTF-8.
+Return a byte array."
+ (if (every #'in-latin1-p string)
+ (map '(array (unsigned-byte 8))
+ #'char-code
+ string)
+ (string-to-utf8 string)))
+
;; arch-tag: bda651ac-39ec-11da-9ea5-000a95c2fcd0
View
@@ -13,10 +13,10 @@ as specified in RFC 2595, section 6."))
(ecase (state c)
(:start
(setf (state c) :sent)
- (concatenate 'string
- (authz-id c) (string (code-char 0))
- (authc-id c) (string (code-char 0))
- (get-password (password c))))
+ (concatenate '(vector (unsigned-byte 8))
+ (string-to-utf8 (authz-id c)) '(0)
+ (string-to-utf8 (authc-id c)) '(0)
+ (string-to-utf8 (get-password (password c)))))
(:sent
:success)))
View
@@ -14,7 +14,8 @@
:components
((:file "packages")
- (:file "client" :depends-on ("packages"))
+ (:file "util" :depends-on ("packages"))
+ (:file "client" :depends-on ("packages" "util"))
(:file "plain" :depends-on ("client"))
(:file "digest-md5" :depends-on ("client"))))
View
@@ -0,0 +1,76 @@
+(in-package :sasl)
+
+;;; These functions make assumptions about CHAR-CODE. See the README
+;;; file.
+
+(defun string-to-utf8 (string)
+ "Convert STRING to UTF-8. Return a vector of unsigned-bytes."
+ ;; Use built-in function on CLISP.
+ #+clisp (ext:convert-string-to-bytes string 'charset:utf-8)
+ #-clisp (string-to-utf8-lisp string))
+
+(defun string-to-utf8-lisp (string)
+ "Convert STRING to UTF-8. Return a vector of unsigned-bytes."
+ (let (result)
+ (loop for c across string
+ do
+ (let ((code (char-code c)))
+ (cond
+ ((<= code #x7f)
+ ;; 0xxxxxxx
+ (push code result))
+
+ ((<= code #x7ff)
+ ;; 110xxxxx 10xxxxxx
+ (push (logior #b11000000
+ (ash (logand #b11111000000 code)
+ -6))
+ result)
+ (push (logior #b10000000
+ (logand #b111111 code))
+ result))
+
+ ((<= code #xffff)
+ ;; 1110xxxx 10xxxxxx 10xxxxxx
+ (push (logior #b11100000
+ (ash (logand #b1111000000000000 code)
+ -12))
+ result)
+ (push (logior #b10000000
+ (ash (logand #b111111000000 code)
+ -6))
+ result)
+ (push (logior #b10000000
+ (logand #b111111 code))
+ result))
+
+ ((<= code #x10ffff)
+ ;; 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
+ (push (logior #b11110000
+ (ash (logand #b111000000000000000000 code)
+ -18))
+ result)
+ (push (logior #b10000000
+ (ash (logand #b111111000000000000 code)
+ -12))
+ result)
+ (push (logior #b10000000
+ (ash (logand #b111111000000 code)
+ -6))
+ result)
+ (push (logior #b10000000
+ (logand #b111111 code))
+ result))
+
+ (t
+ (error "Unknown code point: ~a" code)))))
+ (let ((length (length result)))
+ (make-array length
+ :element-type '(unsigned-byte 8)
+ :initial-contents (nreverse result)))))
+
+(defun in-latin1-p (char)
+ "Return non-nil if CHAR is in the ISO 8859-1 character set."
+ (<= (char-code char) #xff))
+
+;; arch-tag: 36cd3748-4939-11da-b980-000a95c2fcd0

0 comments on commit 9ccad42

Please sign in to comment.