From: okada Date: Sun, 19 Nov 2000 15:09:10 +0000 (+0000) Subject: rewrite for new SASL API X-Git-Tag: wl-2_6-root~196 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=d5b30dbc0d8ad66b629cf38de7df94bf92b09c11;p=elisp%2Fwanderlust.git rewrite for new SASL API --- diff --git a/elmo/elmo-imap4.el b/elmo/elmo-imap4.el index 450c68b..48c702c 100644 --- a/elmo/elmo-imap4.el +++ b/elmo/elmo-imap4.el @@ -59,9 +59,9 @@ (require 'starttls) (require 'sasl)) (error)) - (defun-maybe sasl-cram-md5 (username passphrase challenge)) - (defun-maybe sasl-digest-md5-digest-response - (digest-challenge username passwd serv-type host &optional realm)) +; (defun-maybe sasl-cram-md5 (username passphrase challenge)) +; (defun-maybe sasl-digest-md5-digest-response +; (digest-challenge username passwd serv-type host &optional realm)) (defun-maybe starttls-negotiate (a)) (defun-maybe elmo-generic-list-folder-unread (spec number-alist mark-alist unread-marks)) (defun-maybe elmo-generic-folder-diff (spec folder number-list)) @@ -1213,7 +1213,23 @@ If optional argument UNMARK is non-nil, unmark." (elmo-imap4-password (elmo-get-passwd (elmo-network-session-password-key session)))))) (signal 'elmo-authenticate-error '(login))))) - + +;;; dirty hack +(defconst sasl-imap4-login-steps + '(sasl-imap4-login-response)) + +(defun sasl-imap4-login-response (client step) + (concat + (sasl-client-name client) + " " + (sasl-read-passphrase + (format "LOGIN passphrase for %s: " (sasl-client-name client))))) + +(put 'sasl-imap4-login 'sasl-mechanism + (sasl-make-mechanism "IMAP4-LOGIN" sasl-imap4-login-steps)) + +(provide 'sasl-imap4-login) + (luna-define-method elmo-network-initialize-session-buffer :after ((session elmo-imap4-session) buffer) @@ -1259,34 +1275,108 @@ If optional argument UNMARK is non-nil, unmark." (luna-define-method elmo-network-authenticate-session ((session elmo-imap4-session)) - (with-current-buffer (process-buffer - (elmo-network-session-process-internal session)) - (unless (eq elmo-imap4-status 'auth) - (unless (or (not (elmo-network-session-auth-internal session)) - (eq (elmo-network-session-auth-internal session) 'plain) - (and (memq (intern - (format "auth=%s" - (elmo-network-session-auth-internal - session))) - (elmo-imap4-session-capability-internal session)) - (assq - (elmo-network-session-auth-internal session) - elmo-imap4-authenticator-alist))) - (if (or elmo-imap4-force-login - (y-or-n-p - (format - "There's no %s capability in server. continue?" - (elmo-network-session-auth-internal session)))) - (elmo-network-session-set-auth-internal session nil) - (signal 'elmo-open-error - '(elmo-network-initialize-session)))) - (let ((authenticator - (if (elmo-network-session-auth-internal session) - (nth 1 (assq - (elmo-network-session-auth-internal session) - elmo-imap4-authenticator-alist)) - 'elmo-imap4-login))) - (funcall authenticator session))))) + (with-current-buffer (process-buffer + (elmo-network-session-process-internal session)) + (let* ((auth (elmo-network-session-auth-internal session)) + (auth (mapcar '(lambda (a) + (if (eq a 'plain) + 'imap4-login + a)) + (if (listp auth) auth (list auth))))) + (unless (or (eq elmo-imap4-status 'auth) + (null auth)) + (let* ((elmo-imap4-debug-inhibit-logging t) + (sasl-mechanism-alist + (append + sasl-mechanism-alist + (list '("IMAP4-LOGIN" sasl-imap4-login)))) + (sasl-mechanisms + (append + (delq nil + (mapcar '(lambda (cap) + (if (string-match "^auth=\\(.*\\)$" + (symbol-name cap)) + (match-string 1 (upcase (symbol-name cap))))) + (elmo-imap4-session-capability-internal session))) + (list "IMAP4-LOGIN"))) + (mechanism + (if (eq auth 'any) + (sasl-find-mechanism sasl-mechanisms) + (sasl-find-mechanism + (delq nil + (mapcar '(lambda (cap) (upcase (symbol-name cap))) + (if (listp auth) + auth + (list auth))))))) + client name step response tag + sasl-read-passphrase) + (unless mechanism + (if (or elmo-imap4-force-login + (y-or-n-p + (format + "There's no %s capability in server. continue?" + (elmo-list-to-string + (elmo-network-session-auth-internal session))))) + (setq mechanism (sasl-find-mechanism + sasl-mechanisms)) + (signal 'elmo-authenticate-error '(elmo-imap4-auth-no-mechanisms)))) + (setq client + (sasl-make-client + mechanism + (elmo-network-session-user-internal session) + "imap" + (elmo-network-session-host-internal session))) +;;; (if elmo-imap4-auth-user-realm +;;; (sasl-client-set-property client 'realm elmo-imap4-auth-user-realm)) + (setq name (sasl-mechanism-name mechanism) + step (sasl-next-step client nil)) + (elmo-network-session-set-auth-internal session + (intern (downcase name))) + (setq sasl-read-passphrase + (function + (lambda (prompt) + (elmo-get-passwd + (elmo-network-session-password-key session))))) + (if (string= name "IMAP4-LOGIN") + (setq tag + (elmo-imap4-send-command + session + (concat "LOGIN " (sasl-step-data step)))) + (setq tag + (elmo-imap4-send-command + session + (concat "AUTHENTICATE " name + (and (sasl-step-data step) + (concat + " " + (elmo-base64-encode-string + (sasl-step-data step) + 'no-lin-break))))))) + (catch 'done + (while t + (setq response (elmo-imap4-read-untagged + (elmo-network-session-process-internal session))) + (if (and + (null (elmo-imap4-response-continue-req-p response)) + (elmo-imap4-response-ok-p response) + (or (sasl-next-step client step) + (throw 'done nil))) + (signal 'elmo-authenticate-error + (list (intern + (concat "elmo-imap4-auth-" + (downcase name)))))) + (sasl-step-set-data + step + (elmo-base64-decode-string + (elmo-imap4-response-value response 'continue-req))) + (setq step (sasl-next-step client step)) + (setq tag + (elmo-imap4-send-string + session + (if (sasl-step-data step) + (elmo-base64-encode-string (sasl-step-data step) + 'no-line-break) + "")))))))))) (luna-define-method elmo-network-setup-session ((session elmo-imap4-session)) diff --git a/elmo/elmo-pop3.el b/elmo/elmo-pop3.el index f39a37c..892862a 100644 --- a/elmo/elmo-pop3.el +++ b/elmo/elmo-pop3.el @@ -297,6 +297,45 @@ (signal 'elmo-open-error '(elmo-pop-auth-digest-md5))))) +;;; dirty hack +(defconst sasl-pop3-user-steps + '(sasl-pop3-user-response-1 + sasl-pop3-user-response-2)) + +(defun sasl-pop3-user-response-1 (client step) + (sasl-client-name client)) + +(defun sasl-pop3-user-response-2 (client step) + (format "PASS %s" + (sasl-read-passphrase + (format "LOGIN passphrase for %s: " + (sasl-client-name client))))) + +(put 'sasl-pop3-user 'sasl-mechanism + (sasl-make-mechanism "USER" sasl-pop3-user-steps)) + +(provide 'sasl-pop3-user) + +(defconst sasl-pop3-apop-steps + '(sasl-pop3-apop-response)) + +(defun sasl-pop3-apop-response (client step) + (require 'md5) + (format "%s %s" + (sasl-client-name client) + (md5 + (concat (match-string + 1 + (elmo-network-session-greeting-internal session)) + (sasl-read-passphrase + (format "LOGIN passphrase for %s: " + (sasl-client-name client))))))) + +(put 'sasl-pop3-apop 'sasl-mechanism + (sasl-make-mechanism "APOP" sasl-pop3-apop-steps)) + +(provide 'sasl-pop3-apop) + (luna-define-method elmo-network-initialize-session-buffer :after ((session elmo-pop3-session) buffer) (with-current-buffer buffer @@ -324,18 +363,97 @@ (signal 'elmo-open-error '(elmo-pop3-starttls-error))))))) +;(luna-define-method elmo-network-authenticate-session ((session +; elmo-pop3-session)) +; (let (authenticator) +; ;; defaults to 'user. +; (unless (elmo-network-session-auth-internal session) +; (elmo-network-session-set-auth-internal session 'user)) +; (setq authenticator +; (nth 1 (assq (elmo-network-session-auth-internal session) +; elmo-pop3-authenticator-alist))) +; (unless authenticator (error "There's no authenticator for %s" +; (elmo-network-session-auth-internal session))) +; (funcall authenticator session))) + (luna-define-method elmo-network-authenticate-session ((session elmo-pop3-session)) - (let (authenticator) - ;; defaults to 'user. - (unless (elmo-network-session-auth-internal session) - (elmo-network-session-set-auth-internal session 'user)) - (setq authenticator - (nth 1 (assq (elmo-network-session-auth-internal session) - elmo-pop3-authenticator-alist))) - (unless authenticator (error "There's no authenticator for %s" - (elmo-network-session-auth-internal session))) - (funcall authenticator session))) + (let* ((process (elmo-network-session-process-internal session)) + (auth (elmo-network-session-auth-internal session)) + (auth (mapcar '(lambda (mechanism) (upcase (symbol-name mechanism))) + (if (listp auth) auth (list auth)))) + (sasl-mechanism-alist + (append + sasl-mechanism-alist + (list '("USER" sasl-pop3-user) + '("APOP" sasl-pop3-apop)))) + (mechanism + (if (eq auth 'any) + (sasl-find-mechanism sasl-mechanisms) + (sasl-find-mechanism auth))) + client name step response + sasl-read-passphrase) + (unless mechanism + (if (or elmo-pop3-force-login + (y-or-n-p + (format + "There's no %s capability in server. continue?" + (elmo-list-to-string + (elmo-network-session-auth-internal session))))) + (setq mechanism (sasl-find-mechanism + sasl-mechanisms)) + (signal 'elmo-authenticate-error '(elmo-pop3-auth-no-mechanisms)))) + (setq client + (sasl-make-client + mechanism + (elmo-network-session-user-internal session) + "pop" + (elmo-network-session-host-internal session))) +;;; (if elmo-pop3-auth-user-realm +;;; (sasl-client-set-property client 'realm elmo-pop3-auth-user-realm)) + (setq name (sasl-mechanism-name mechanism) + step (sasl-next-step client nil)) + (elmo-network-session-set-auth-internal session + (intern (downcase name))) + (setq sasl-read-passphrase + (function + (lambda (prompt) + (elmo-get-passwd + (elmo-network-session-password-key session))))) + (if (or (string= name "USER") + (string= name "APOP")) + (elmo-pop3-send-command + process + (format "%s %s" name + (sasl-step-data step))) + (elmo-pop3-send-command + process + (concat "AUTH " name + (and (sasl-step-data step) + (concat + " " + (elmo-base64-encode-string + (sasl-step-data step) 'no-line-break)))))) + (catch 'done + (while t + (setq response (elmo-pop3-read-response process t)) + (if (string-match "^\+OK" response) + (if (sasl-next-step client step) + (signal 'elmo-authenticate-error + (list (intern + (concat "elmo-pop3-auth-" + (downcase name))))) + (throw 'done nil))) + (sasl-step-set-data + step + (elmo-base64-decode-string response)) + (setq step (sasl-next-step client step)) + (elmo-pop3-send-string + process + (if (sasl-step-data step) + (elmo-base64-encode-string (sasl-step-data step) + 'no-line-break) + "")))))) (luna-define-method elmo-network-setup-session ((session elmo-pop3-session)) diff --git a/elmo/elmo-util.el b/elmo/elmo-util.el index c493d00..713601a 100644 --- a/elmo/elmo-util.el +++ b/elmo/elmo-util.el @@ -899,6 +899,31 @@ Otherwise treat \\ in NEWTEXT string as special: (goto-char (point-min)) (read (current-buffer)))) +(defun elmo-list-to-string (list) + (let ((tlist list) + str) + (if (listp tlist) + (progn + (setq str "(") + (while (car tlist) + (setq str + (concat str + (if (symbolp (car tlist)) + (symbol-name (car tlist)) + (car tlist)))) + (if (cdr tlist) + (setq str + (concat str " "))) + (setq tlist (cdr tlist))) + (setq str + (concat str ")"))) + (setq str + (if (symbolp tlist) + (symbol-name tlist) + tlist))) + str)) + + (defun elmo-plug-on-by-servers (alist &optional servers) (let ((server-list (or servers elmo-plug-on-servers))) (catch 'plugged diff --git a/wl/wl-draft.el b/wl/wl-draft.el index 9edf607..41d0993 100644 --- a/wl/wl-draft.el +++ b/wl/wl-draft.el @@ -41,10 +41,9 @@ (defvar x-face-add-x-face-version-header) (defvar mail-reply-buffer) (defvar mail-from-style) -(defvar smtp-authenticate-type) -(defvar smtp-authenticate-user) -(defvar smtp-authenticate-passphrase) -(defvar smtp-connection-type) +;(defvar smtp-sasl-mechanisms) +;(defvar smtp-sasl-user-name) +;(defvar smtp-use-starttls) (eval-when-compile (require 'elmo-pop3) @@ -97,50 +96,77 @@ (make-variable-buffer-local 'wl-draft-reply-buffer) ;;; SMTP binding by Daiki Ueno -(defvar wl-smtp-features - '(((smtp-authenticate-type - (if wl-smtp-authenticate-type - (intern (downcase (format "%s" wl-smtp-authenticate-type))))) - ((smtp-authenticate-user wl-smtp-posting-user) - ((smtp-authenticate-passphrase - (elmo-get-passwd - (format "%s@%s" - smtp-authenticate-user - smtp-server)))))) - (smtp-connection-type)) - "Additional SMTP features.") - -(eval-when-compile - (defun wl-smtp-parse-extension (exts parents) - (let (bindings binding feature) - (dolist (ext exts) - (setq feature (if (listp (car ext)) (caar ext) (car ext)) - binding - (` ((, feature) - (or (, (if (listp (car ext)) - (cadar ext) - (let ((wl-feature - (intern - (concat "wl-" (symbol-name feature))))) - (if (boundp wl-feature) - wl-feature)))) - (and (boundp '(, feature)) (, feature)))))) - (when parents - (setcdr binding (list (append '(and) parents (cdr binding))))) - (setq bindings - (nconc bindings (list binding) - (wl-smtp-parse-extension - (cdr ext) (cons feature parents))))) - bindings))) +;;;(defvar wl-smtp-features +;;; '(((smtp-authenticate-type +;;; (if wl-smtp-authenticate-type +;;; (intern (downcase (format "%s" wl-smtp-authenticate-type))))) +;;; ((smtp-authenticate-user wl-smtp-posting-user) +;;; ((smtp-authenticate-passphrase +;;; (elmo-get-passwd +;;; (format "%s@%s" +;;; smtp-authenticate-user +;;; smtp-server)))))) +;;; (smtp-connection-type)) +;;; "Additional SMTP features.") + +;;;(eval-when-compile +;;; (defun wl-smtp-parse-extension (exts parents) +;;; (let (bindings binding feature) +;;; (dolist (ext exts) +;;; (setq feature (if (listp (car ext)) (caar ext) (car ext)) +;;; binding +;;; (` ((, feature) +;;; (or (, (if (listp (car ext)) +;;; (cadar ext) +;;; (let ((wl-feature +;;; (intern +;;; (concat "wl-" (symbol-name feature))))) +;;; (if (boundp wl-feature) +;;; wl-feature)))) +;;; (and (boundp '(, feature)) (, feature)))))) +;;; (when parents +;;; (setcdr binding (list (append '(and) parents (cdr binding))))) +;;; (setq bindings +;;; (nconc bindings (list binding) +;;; (wl-smtp-parse-extension +;;; (cdr ext) (cons feature parents))))) +;;; bindings))) + +;;;(defmacro wl-smtp-extension-bind (&rest body) +;;; "Return a `let' form that binds all variables of SMTP extension. +;;;After this is done, BODY will be executed in the scope +;;;of the `let' form. +;;; +;;;The variables bound and their default values are described by +;;;the `wl-smtp-features' variable." +;;; (` (let* (, (wl-smtp-parse-extension wl-smtp-features nil)) +;;; (,@ body)))) (defmacro wl-smtp-extension-bind (&rest body) - "Return a `let' form that binds all variables of SMTP extension. -After this is done, BODY will be executed in the scope -of the `let' form. - -The variables bound and their default values are described by -the `wl-smtp-features' variable." - (` (let* (, (wl-smtp-parse-extension wl-smtp-features nil)) + (` (let* ((smtp-sasl-mechanisms + (if wl-smtp-authenticate-type + (mapcar 'upcase + (if (listp wl-smtp-authenticate-type) + wl-smtp-authenticate-type + (list wl-smtp-authenticate-type))))) + (smtp-use-sasl (and smtp-sasl-mechanisms t)) + (smtp-use-starttls wl-smtp-connection-type) + smtp-sasl-user-name smtp-sasl-user-realm sasl-read-passphrase) + (if (and (string= (car smtp-sasl-mechanisms) "DIGEST-MD5") + ;; sendmail bug? + (string-match "^\\([^@]*\\)@\\([^@]*\\)" + wl-smtp-posting-user)) + (setq smtp-sasl-user-name (match-string 1 wl-smtp-posting-user) + smtp-sasl-user-realm (match-string 2 wl-smtp-posting-user)) + (setq smtp-sasl-user-name wl-smtp-posting-user + smtp-sasl-user-realm nil)) + (setq sasl-read-passphrase + (function + (lambda (prompt) + (elmo-get-passwd + (format "%s@%s" + smtp-sasl-user-name + smtp-server))))) (,@ body)))) (defun wl-draft-insert-date-field ()