From a83d0ed3057c460ca1c1d95f7ce430f0523b39b9 Mon Sep 17 00:00:00 2001 From: ueno Date: Thu, 2 Nov 2000 03:35:59 +0000 Subject: [PATCH] * 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. --- ChangeLog | 17 ++++++ FLIM-ELS | 11 +++- sasl-digest.el | 175 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ sasl.el | 70 +++++++++++++++++++++-- smtp.el | 17 ++++-- 5 files changed, 278 insertions(+), 12 deletions(-) create mode 100644 sasl-digest.el diff --git a/ChangeLog b/ChangeLog index 5658c9d..3611e9f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,20 @@ +2000-11-02 Daiki Ueno + + * 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 * 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 +;; Daiki Ueno +;; 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 -- 1.7.10.4