From: ueno <ueno>
Date: Thu, 2 Nov 2000 03:35:59 +0000 (+0000)
Subject: * FLIM-ELS (hmac-modules): New variable.
X-Git-Tag: deisui-1_14_0-1~22
X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=a83d0ed3057c460ca1c1d95f7ce430f0523b39b9;p=elisp%2Fflim.git

* FLIM-ELS (hmac-modules): New variable.
(flim-modules): Move HMAC modules to `hmac-modules'
- Add `sasl-digest'.

* smtp.el (smtp-sasl-principal-realm): New user option.

* sasl.el (sasl-plain-response): New function.
(sasl-mechanisms): Add `DIGEST-MD5' and `PLAIN'.
(sasl-unique-id-function): New variable.
(sasl-plain-continuations): New variable.
(sasl-unique-id): New function.
(sasl-unique-id-char): New variable.

* sasl-digest.el: New file.
---

diff --git a/ChangeLog b/ChangeLog
index 5658c9d..3611e9f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,20 @@
+2000-11-02   Daiki Ueno  <ueno@unixuser.org>
+
+	* FLIM-ELS (hmac-modules): New variable.
+	(flim-modules): Move HMAC modules to `hmac-modules'
+	- Add `sasl-digest'.
+
+	* smtp.el (smtp-sasl-principal-realm): New user option.
+
+	* sasl.el (sasl-plain-response): New function.
+	(sasl-mechanisms): Add `DIGEST-MD5' and `PLAIN'.
+	(sasl-unique-id-function): New variable.
+	(sasl-plain-continuations): New variable.
+	(sasl-unique-id): New function.
+	(sasl-unique-id-char): New variable.
+
+	* sasl-digest.el: New file.
+
 2000-11-01   Daiki Ueno  <ueno@unixuser.org>
 
 	* smtp.el: Bind `sasl-mechanisms'; add autoload settings for
diff --git a/FLIM-ELS b/FLIM-ELS
index 0095e6c..0fa8ca9 100644
--- a/FLIM-ELS
+++ b/FLIM-ELS
@@ -11,10 +11,17 @@
 		     mime mime-parse mmgeneric
 		     mmbuffer mmcooked mmdbuffer mmexternal
 		     mailcap
-		     md5 md5-el md5-dl hex-util hmac-def hmac-md5 
-		     sasl sasl-cram
+		     sasl sasl-cram sasl-digest
 		     smtp qmtp smtpmail))
 
+(setq hmac-modules '(hex-util
+		     hmac-def
+		     md5 md5-el md5-dl
+		     sha1 sha1-el sha1-dl
+		     hmac-md5 hmac-sha1))
+
+(setq flim-modules (nconc hmac-modules flim-modules))
+
 (if (and (fboundp 'base64-encode-string)
 	 (subrp (symbol-function 'base64-encode-string)))
     nil
diff --git a/sasl-digest.el b/sasl-digest.el
new file mode 100644
index 0000000..eee6f96
--- /dev/null
+++ b/sasl-digest.el
@@ -0,0 +1,175 @@
+;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework
+
+;; Copyright (C) 2000 Daiki Ueno
+
+;; Author: Kenichi OKADA <okada@opaopa.org>
+;;	Daiki Ueno <ueno@unixuser.org>
+;; Keywords: SASL, DIGEST-MD5
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;; This program is implemented from draft-leach-digest-sasl-05.txt.
+;;
+;; It is caller's responsibility to base64-decode challenges and
+;; base64-encode responses in IMAP4 AUTHENTICATE command.
+;;
+;; Passphrase should be longer than 16 bytes. (See RFC 2195)
+
+;;; Commentary:
+
+(require 'sasl)
+(require 'hmac-md5)
+
+(defvar sasl-digest-md5-authenticator nil)
+
+(defvar sasl-digest-md5-challenge nil)
+(defvar sasl-digest-md5-nonce-count 1)
+(defvar sasl-digest-md5-unique-id-function
+  sasl-unique-id-function)
+
+(defvar sasl-digest-md5-parse-digest-challenge-syntax-table
+  (let ((table (make-syntax-table)))
+    (modify-syntax-entry ?= "." table)
+    (modify-syntax-entry ?, "." table)
+    table)
+  "A syntax table for parsing digest-challenge attributes.")
+
+(defconst sasl-digest-md5-continuations
+  '(ignore				;no initial response
+    sasl-digest-md5-response
+    ignore))				;""
+
+(unless (get 'sasl-digest 'sasl-authenticator)
+  (put 'sasl-digest 'sasl-authenticator
+       (sasl-make-authenticator "DIGEST-MD5" sasl-digest-md5-continuations)))
+
+;;; @ low level functions
+;;;
+;;; Examples in `draft-leach-digest-sasl-05.txt'.
+;;;
+;;; (sasl-digest-md5-parse-digest-challenge 
+;;;   "realm=\"elwood.innosoft.com\",nonce=\"OA6MG9tEQGm2hh\",qop=\"auth\",algorithm=md5-sess,charset=utf-8")
+;;; => (realm "elwood.innosoft.com" nonce "OA6MG9tEQGm2hh" qop "auth" algorithm md5-sess charset utf-8)
+
+;;; (sasl-digest-md5-build-response-value
+;;;   "chris" "elwood.innosoft.com" "secret" "OA6MG9tEQGm2hh"
+;;;   "OA6MHXh6VqTrRk" 1 "imap/elwood.innosoft.com" "auth")
+;;; => "d388dad90d4bbd760a152321f2143af7"
+
+(defun sasl-digest-md5-parse-digest-challenge (digest-challenge)
+  "Return a property list parsed DIGEST-CHALLENGE.
+The value is a cons cell of the form \(realm nonce qop-options stale maxbuf
+charset algorithm cipher-opts auth-param)".
+  (with-temp-buffer
+    (set-syntax-table sasl-digest-md5-parse-digest-challenge-syntax-table)
+    (insert digest-challenge)
+    (goto-char (point-min))
+    (insert "(")
+    (while (progn (forward-sexp) (not (eobp)))
+      (delete-char 1)
+      (insert " "))
+    (insert ")")
+    (condition-case nil
+	(setplist 'sasl-digest-md5-challenge (read (point-min-marker)))
+      (end-of-file
+       (error "Parse error in digest-challenge.")))))
+
+(defun sasl-digest-md5-digest-uri (serv-type host &optional serv-name)
+  (concat serv-type "/" host
+	  (if (and serv-name
+		   (null (string= host serv-name)))
+	      (concat "/" serv-name))))
+
+(defun sasl-digest-md5-cnonce ()
+  (let ((sasl-unique-id-function sasl-digest-md5-unique-id-function))
+    (sasl-unique-id)))
+
+(defmacro sasl-digest-md5-challenge (prop)
+  (list 'get ''sasl-digest-md5-challenge prop))
+
+(defmacro sasl-digest-md5-build-response-value-1
+  (username realm passwd nonce cnonce nonce-count digest-uri qop)
+  `(encode-hex-string
+    (md5-binary
+     (concat
+      (encode-hex-string
+       (md5-binary (concat (md5-binary 
+			    (concat ,username 
+				    ":" ,realm
+				    ":" ,passwd))
+			   ":" ,nonce
+			   ":" ,cnonce
+			   (let ((authzid (sasl-digest-md5-challenge 'authzid)))
+			     (if authzid (concat ":" authzid) nil)))))
+      ":" ,nonce
+      ":" (format "%08x" ,nonce-count) ":" ,cnonce ":" ,qop ":"
+      (encode-hex-string
+       (md5-binary
+	(concat "AUTHENTICATE:" ,digest-uri
+		(if (string-equal "auth-int" ,qop)
+		    ":00000000000000000000000000000000"
+		  nil))))))))
+
+(defun sasl-digest-md5-build-response-value
+  (username realm passwd nonce cnonce nonce-count digest-uri
+	    &optional charset qop maxbuf cipher authzid)
+  (concat
+   "username=\"" username "\","
+   "realm=\"" realm "\","
+   "nonce=\"" nonce "\","
+   (format "nc=%08x," nonce-count)
+   "cnonce=\"" cnonce "\","
+   "digest-uri=\"" digest-uri "\","
+   "response=" 
+   (sasl-digest-md5-build-response-value
+    username realm passwd nonce cnonce nonce-count digest-uri
+    (or qop "auth"))
+   ","
+   (mapconcat 
+    #'identity
+    (delq nil 
+	  (mapcar (lambda (prop)
+		    (if (sasl-digest-md5-challenge prop)
+			(format "%s=%s"
+				prop (sasl-digest-md5-challenge prop))))
+		  '(charset qop maxbuf cipher authzid)))
+    ",")))
+
+(defun sasl-digest-md5-digest-response (principal challenge)
+  (sasl-digest-md5-parse-digest-challenge (nth 1 challenge))
+  (let ((passphrase
+	 (sasl-read-passphrase
+	  (format "DIGEST-MD5 passphrase for %s: "
+		  (sasl-principal-name-internal principal)))))
+    (unwind-protect
+	(sasl-digest-md5-build-response-value
+	 (sasl-principal-name-internal principal)
+	 (or (sasl-principal-realm-internal principal)
+	     (sasl-digest-md5-challenge 'realm))	;need to check
+	 passphrase
+	 (sasl-digest-md5-challenge 'nonce)
+	 (sasl-digest-md5-cnonce)
+	 sasl-digest-md5-nonce-count
+	 (sasl-digest-md5-digest-uri
+	  (sasl-principal-service-internal principal)
+	  (sasl-principal-server-internal principal)))
+      (fillarray passphrase 0))))
+
+(provide 'sasl-digest)
+
+;;; sasl-digest.el ends here
diff --git a/sasl.el b/sasl.el
index 94e133d..dc42358 100644
--- a/sasl.el
+++ b/sasl.el
@@ -27,7 +27,11 @@
 (require 'poe)
 
 (defvar sasl-mechanisms
-  '(("CRAM-MD5" sasl-cram)))
+  '(("CRAM-MD5" sasl-cram)
+    ("DIGEST-MD5" sasl-digest)
+    ("PLAIN" sasl-plain)))
+
+(defvar sasl-unique-id-function #'sasl-unique-id-function)
 
 (defmacro sasl-make-authenticator (mechanism continuations)
   `(vector ,mechanism ,continuations))
@@ -38,18 +42,21 @@
 (defmacro sasl-authenticator-continuations-internal (authenticator)
   `(aref ,authenticator 1))
 
-(defmacro sasl-make-principal (name service server)
-  `(vector ,name ,service ,server))
+(defmacro sasl-make-principal (name service server &optional realm)
+  `(vector ,name ,realm ,service ,server))
 
 (defmacro sasl-principal-name-internal (principal)
   `(aref ,principal 0))
 
-(defmacro sasl-principal-service-internal (principal)
+(defmacro sasl-principal-realm-internal (principal)
   `(aref ,principal 1))
 
-(defmacro sasl-principal-server-internal (principal)
+(defmacro sasl-principal-service-internal (principal)
   `(aref ,principal 2))
 
+(defmacro sasl-principal-server-internal (principal)
+  `(aref ,principal 3))
+
 (defun sasl-find-authenticator (mechanisms)
   "Retrieve an apropriate authenticator object from MECHANISMS hints."
   (let (mechanism)
@@ -86,6 +93,59 @@ The data type of the value and the CHALLENGE is nil or a cons cell of the form
 	  (setq sasl-read-passphrase 'ange-ftp-read-passwd))))
   (funcall sasl-read-passphrase prompt))
 
+(defun sasl-unique-id ()
+  "Compute a data string which must be different each time.
+It contain at least 64 bits of entropy."
+  (concat (funcall sasl-unique-id-function)(funcall sasl-unique-id-function)))
+
+(defvar sasl-unique-id-char nil)
+
+;; stolen (and renamed) from message.el
+(defun sasl-unique-id-function ()
+  ;; Don't use microseconds from (current-time), they may be unsupported.
+  ;; Instead we use this randomly inited counter.
+  (setq sasl-unique-id-char
+	(% (1+ (or sasl-unique-id-char (logand (random t) (1- (lsh 1 20)))))
+	   ;; (current-time) returns 16-bit ints,
+	   ;; and 2^16*25 just fits into 4 digits i base 36.
+	   (* 25 25)))
+  (let ((tm (current-time)))
+    (concat
+     (sasl-unique-id-number-base36
+      (+ (car   tm)
+	 (lsh (% sasl-unique-id-char 25) 16)) 4)
+     (sasl-unique-id-number-base36
+      (+ (nth 1 tm)
+	 (lsh (/ sasl-unique-id-char 25) 16)) 4))))
+
+(defun sasl-unique-id-number-base36 (num len)
+  (if (if (< len 0)
+	  (<= num 0)
+	(= len 0))
+      ""
+    (concat (sasl-unique-id-number-base36 (/ num 36) (1- len))
+	    (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
+				  (% num 36))))))
+
+;;; PLAIN SASL mechanism (RFC2595 Section 6)
+(defconst sasl-plain-continuations
+  '(sasl-plain-response))
+
+(unless (get 'sasl-plain 'sasl-authenticator)
+  (put 'sasl-plain 'sasl-authenticator
+       (sasl-make-authenticator "PLAIN" sasl-plain-continuations)))
+
+(defun sasl-plain-response (principal challenge)
+  (let ((passphrase
+	 (sasl-read-passphrase
+	  (format "PLAIN passphrase for %s: "
+		  (sasl-principal-name-internal principal)))))
+    (unwind-protect
+	(concat "\0" (sasl-principal-name-internal principal) "\0" passphrase)
+      (fillarray passphrase 0))))
+
+(provide 'sasl-plain)
+
 (provide 'sasl)
 
 ;;; sasl.el ends here
diff --git a/smtp.el b/smtp.el
index 0162538..c2fa2dd 100644
--- a/smtp.el
+++ b/smtp.el
@@ -94,6 +94,11 @@ don't define this value."
   :type 'string
   :group 'smtp-extensions)
 
+(defcustom smtp-sasl-principal-realm smtp-local-domain
+  "Realm name to be used for authorization."
+  :type 'string
+  :group 'smtp-extensions)
+
 (defcustom smtp-sasl-mechanisms nil
   "List of authentication mechanisms."
   :type '(repeat string)
@@ -327,8 +332,9 @@ or `smtp-local-domain' correctly."))))))
 	  (cdr (assq 'auth (smtp-connection-extensions-internal connection))))
 	 (principal
 	  (sasl-make-principal
-	   smtp-sasl-principal-name "smtp"
-	   (smtp-connection-server-internal connection)))
+	   smtp-sasl-principal-name
+	   "smtp" (smtp-connection-server-internal connection)
+	   smtp-sasl-principal-realm))
 	 (authenticator
 	  (sasl-find-authenticator mechanisms))
 	 (mechanism
@@ -336,12 +342,12 @@ or `smtp-local-domain' correctly."))))))
 	 ;; Retrieve the initial response
 	 (sasl-response
 	  (sasl-evaluate-challenge authenticator principal))
-	 sasl-challenge
 	 response)
     (smtp-send-command
      process
      (if (nth 1 sasl-response)
-	 (format "AUTH %s %s" mechanism (base64-encode-string (nth 1 sasl-response)))
+	 (format "AUTH %s %s" mechanism (base64-encode-string
+					 (nth 1 sasl-response) t))
        (format "AUTH %s" mechanism)))
     (catch 'done
       (while t
@@ -359,7 +365,8 @@ or `smtp-local-domain' correctly."))))))
 	(setq sasl-response
 	      (sasl-evaluate-challenge
 	       authenticator principal sasl-response))
-	(smtp-send-command process (base64-encode-string sasl-response))))))
+	(smtp-send-command process (base64-encode-string
+				    (nth 1 sasl-response) t))))))
 
 (defun smtp-primitive-starttls (package)
   (let* ((connection