From b1f60e8f8ef16ac9d9420abb89158a65e1622f24 Mon Sep 17 00:00:00 2001 From: ueno Date: Tue, 21 Nov 2000 20:15:29 +0000 Subject: [PATCH] Added experimental support for integrity encoder & decoder. I'm going to rewrite things again. * sasl.el (sasl-client-set-encoder): New function. (sasl-client-set-decoder): New function. (sasl-client-encoder): New function. (sasl-client-decoder): New function. * sasl-digest.el: Require 'cl' when compiling. (sasl-digest-md5-signing-encode-magic): New constant. (sasl-digest-md5-signing-decode-magic): New constant. (sasl-digest-md5-htonl-string): New function. (sasl-digest-md5-make-integrity-encoder): New function. (sasl-digest-md5-make-integrity-decoder): New function. (sasl-digest-md5-ha1): New function. (sasl-digest-md5-response-value): Accept the 1st argument `ha1'. (sasl-digest-md5-response): Use `sasl-digest-md5-ha1'. - Set integrity encoder and decoder of the client. * smtp.el: Require `luna'. (smtp-read-response): Accept `smtp-connection' object rather than process-object. (smtp-send-command): Likewise. (smtp-send-data): Likewise. --- ChangeLog | 24 +++++++ sasl-digest.el | 113 +++++++++++++++++++---------- sasl.el | 19 ++++- smtp.el | 216 +++++++++++++++++++++++++++----------------------------- 4 files changed, 223 insertions(+), 149 deletions(-) diff --git a/ChangeLog b/ChangeLog index 0456174..8b64201 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,27 @@ +2000-11-21 Daiki Ueno + + * sasl.el (sasl-client-set-encoder): New function. + (sasl-client-set-decoder): New function. + (sasl-client-encoder): New function. + (sasl-client-decoder): New function. + + * sasl-digest.el: Require 'cl' when compiling. + (sasl-digest-md5-signing-encode-magic): New constant. + (sasl-digest-md5-signing-decode-magic): New constant. + (sasl-digest-md5-htonl-string): New function. + (sasl-digest-md5-make-integrity-encoder): New function. + (sasl-digest-md5-make-integrity-decoder): New function. + (sasl-digest-md5-ha1): New function. + (sasl-digest-md5-response-value): Accept the 1st argument `ha1'. + (sasl-digest-md5-response): Use `sasl-digest-md5-ha1'. + - Set integrity encoder and decoder of the client. + + * smtp.el: Require `luna'. + (smtp-read-response): Accept `smtp-connection' object rather than + process-object. + (smtp-send-command): Likewise. + (smtp-send-data): Likewise. + 2000-11-12 Daiki Ueno * luna.el (luna-define-method): Clear method cache. diff --git a/sasl-digest.el b/sasl-digest.el index 7454a74..9d10dd1 100644 --- a/sasl-digest.el +++ b/sasl-digest.el @@ -35,6 +35,8 @@ (require 'sasl) (require 'hmac-md5) +(eval-when-compile (require 'cl)) + (defvar sasl-digest-md5-nonce-count 1) (defvar sasl-digest-md5-unique-id-function sasl-unique-id-function) @@ -77,58 +79,100 @@ charset algorithm cipher-opts auth-param)." (let ((sasl-unique-id-function sasl-digest-md5-unique-id-function)) (sasl-unique-id))) -(defun sasl-digest-md5-response-value (username - realm - nonce - cnonce - nonce-count - qop - digest-uri - authzid) +(defconst sasl-digest-md5-signing-encode-magic + "Digest session key to client-to-server signing key magic constant") + +(defconst sasl-digest-md5-signing-decode-magic + "Digest session key to server-to-client signing key magic constant") + +(defun sasl-digest-md5-htonl-string (n) + (car + (read-from-string + (format "\"\\x%02x\\x%02x\\x%02x\\x%02x\"" + (logand n 255) + (logand (lsh n -8) 255) + (logand (lsh n -16) 255) + (logand (lsh n -24) 255))))) + +(defun sasl-digest-md5-make-integrity-encoder (ha1) + (lexical-let ((key (md5-binary (concat ha1 sasl-digest-md5-signing-encode-magic))) + (seqnum 0)) + (lambda (string) + (let ((seqnum-string (sasl-digest-md5-htonl-string seqnum))) + (prog1 (concat (sasl-digest-md5-htonl-string (+ (length string) 16)) + string (hmac-md5 key (concat seqnum-string string)) + "\x0\x1\x0\x0" seqnum-string) + (setq seqnum (1+ seqnum))))))) + +(defun sasl-digest-md5-make-integrity-decoder (ha1) + (lexical-let ((key (md5-binary (concat ha1 sasl-digest-md5-signing-decode-magic))) + (seqnum 0)) + (lambda (string) + (let ((seqnum-string (sasl-digest-md5-htonl-string seqnum)) + (mac (substring string (- (length string) 16)))) + (setq string (substring string 4 (- (length string) 20))) + (or (string= (concat (hmac-md5 key (concat seqnum-string string)) + "\x0\x1\x0\x0" seqnum-string) + mac) + (sasl-error "MAC doesn't match")) + (setq seqnum (1+ seqnum)) + string)))) + +(defun sasl-digest-md5-ha1 (username realm nonce cnonce authzid) (let ((passphrase (sasl-read-passphrase (format "DIGEST-MD5 passphrase for %s: " username)))) (unwind-protect - (encode-hex-string - (md5-binary - (concat - (encode-hex-string - (md5-binary (concat (md5-binary - (concat username ":" realm ":" passphrase)) - ":" nonce ":" cnonce - (if authzid - (concat ":" authzid))))) - ":" nonce - ":" (format "%08x" nonce-count) ":" cnonce ":" qop ":" - (encode-hex-string - (md5-binary - (concat "AUTHENTICATE:" digest-uri - (if (member qop '("auth-int" "auth-conf")) - ":00000000000000000000000000000000"))))))) + (md5-binary + (concat (md5-binary + (concat username ":" realm ":" passphrase)) + ":" nonce ":" cnonce + (if authzid + (concat ":" authzid)))) (fillarray passphrase 0)))) +(defun sasl-digest-md5-response-value (ha1 nonce cnonce nonce-count qop digest-uri) + (encode-hex-string + (md5-binary + (concat + (encode-hex-string ha1) + ":" nonce + ":" (format "%08x" nonce-count) ":" cnonce ":" qop ":" + (encode-hex-string + (md5-binary + (concat "AUTHENTICATE:" digest-uri + (if (member qop '("auth-int" "auth-conf")) + ":00000000000000000000000000000000")))))))) + (defun sasl-digest-md5-response (client step) (let* ((plist (sasl-digest-md5-parse-string (sasl-step-data step))) (realm (or (sasl-client-property client 'realm) (plist-get plist 'realm))) ;need to check + (nonce (plist-get plist 'nonce)) + (cnonce + (or (sasl-client-property client 'cnonce) + (sasl-digest-md5-cnonce))) (nonce-count (or (sasl-client-property client 'nonce-count) sasl-digest-md5-nonce-count)) (qop (or (sasl-client-property client 'qop) - (setq qop "auth"))) + "auth")) (digest-uri (sasl-digest-md5-digest-uri (sasl-client-service client)(sasl-client-server client))) - (cnonce - (or (sasl-client-property client 'cnonce) - (sasl-digest-md5-cnonce)))) + (ha1 + (sasl-digest-md5-ha1 + (sasl-client-name client) realm nonce cnonce (plist-get plist 'authzid)))) (sasl-client-set-property client 'nonce-count (1+ nonce-count)) - (unless (string= qop "auth") - (sasl-error (format "Unsupported \"qop-value\": %s" qop))) + (when (member qop '("auth-int" "auth-conf")) + (sasl-client-set-encoder + client (sasl-digest-md5-make-integrity-encoder ha1)) + (sasl-client-set-decoder + client (sasl-digest-md5-make-integrity-decoder ha1))) (concat "username=\"" (sasl-client-name client) "\"," "realm=\"" realm "\"," @@ -139,14 +183,7 @@ charset algorithm cipher-opts auth-param)." "qop=" qop "," "response=" (sasl-digest-md5-response-value - (sasl-client-name client) - realm - (plist-get plist 'nonce) - cnonce - nonce-count - qop - digest-uri - (plist-get plist 'authzid))))) + ha1 nonce cnonce nonce-count qop digest-uri)))) (put 'sasl-digest 'sasl-mechanism (sasl-make-mechanism "DIGEST-MD5" sasl-digest-md5-steps)) diff --git a/sasl.el b/sasl.el index 8528898..64158ed 100644 --- a/sasl.el +++ b/sasl.el @@ -61,7 +61,8 @@ "Return a newly allocated SASL client. NAME is name of the authorization. SERVICE is name of the service desired. SERVER is the fully qualified host name of the server to authenticate to." - (vector mechanism name service server (make-symbol "sasl-client-properties"))) + (vector mechanism name service server (make-symbol "sasl-client-properties") + nil nil)) (defun sasl-client-mechanism (client) "Return the authentication mechanism driver of CLIENT." @@ -96,6 +97,22 @@ The second argument PLIST is the new property list." "Return the properties of CLIENT." (symbol-plist (aref client 4))) +(defun sasl-client-set-encoder (client encoder) + "Set integrity encoder of CLIENT." + (aset client 5 encoder)) + +(defun sasl-client-set-decoder (client decoder) + "Set integrity decoder of CLIENT." + (aset client 6 decoder)) + +(defun sasl-client-encoder (client) + "Return the integrity encoder of CLIENT." + (aref client 5)) + +(defun sasl-client-decoder (client) + "Retrun the integrity decoder of CLIENT." + (aref client 6)) + ;;; @ SASL mechanism ;;; diff --git a/smtp.el b/smtp.el index 2a979d4..c781252 100644 --- a/smtp.el +++ b/smtp.el @@ -35,6 +35,7 @@ (require 'pcustom) (require 'mail-utils) ; mail-strip-quoted-names (require 'sasl) +(require 'luna) (defgroup smtp nil "SMTP protocol for sending mail." @@ -120,36 +121,32 @@ don't define this value." (defvar smtp-submit-package-function #'smtp-submit-package) -;;; @ SMTP package structure +;;; @ SMTP package ;;; A package contains a mail message, an envelope sender address, ;;; and one or more envelope recipient addresses. In ESMTP model ;;; the current sending package should be guaranteed to be accessible ;;; anywhere from the hook methods (or SMTP commands). -(defmacro smtp-package-sender (package) - "Return the sender of PACKAGE, a string." - `(aref ,package 0)) - -(defmacro smtp-package-recipients (package) - "Return the recipients of PACKAGE, a list of strings." - `(aref ,package 1)) +(eval-and-compile + (luna-define-class smtp-package () + (sender + recipients + buffer)) -(defmacro smtp-package-buffer (package) - "Return the data of PACKAGE, a buffer." - `(aref ,package 2)) + (luna-define-internal-accessors 'smtp-package)) -(defmacro smtp-make-package (sender recipients buffer) +(defun smtp-make-package (sender recipients buffer) "Create a new package structure. A package is a unit of SMTP message SENDER specifies the package sender, a string. RECIPIENTS is a list of recipients. BUFFER may be a buffer or a buffer name which contains mail message." - `(vector ,sender ,recipients ,buffer)) + (luna-make-entity 'smtp-package :sender sender :recipients recipients :buffer buffer)) -(defun smtp-package-buffer-size (package) +(defun smtp-package-buffer-internal-size (package) "Return the size of PACKAGE, an integer." (save-excursion - (set-buffer (smtp-package-buffer package)) + (set-buffer (smtp-package-buffer-internal package)) (let ((size (+ (buffer-size) ;; Add one byte for each change-of-line @@ -165,49 +162,42 @@ BUFFER may be a buffer or a buffer name which contains mail message." (setq size (1+ size))) size))) -;;; @ SMTP connection structure +;;; @ SMTP connection ;;; We should consider the function `open-network-stream' is a emulation ;;; for another network stream. They are likely to be implemented with an ;;; external program and the function `process-contact' returns the ;;; process id instead of `(HOST SERVICE)' pair. -(defmacro smtp-connection-process (connection) - "Return the subprocess-object of CONNECTION." - `(aref ,connection 0)) - -(defmacro smtp-connection-server (connection) - "Return the server of CONNECTION, a string." - `(aref ,connection 1)) - -(defmacro smtp-connection-service (connection) - "Return the service of CONNECTION, a string or an integer." - `(aref ,connection 2)) - -(defmacro smtp-connection-extensions (connection) - "Return the SMTP extensions of CONNECTION, a list of strings." - `(aref ,connection 3)) +(eval-and-compile + (luna-define-class smtp-connection () + (process + server + service + extensions + encoder + decoder)) -(defmacro smtp-connection-set-extensions (connection extensions) - "Set the SMTP extensions of CONNECTION. -EXTENSIONS is a list of cons cells of the form \(EXTENSION . PARAMETERS). -Where EXTENSION is a symbol and PARAMETERS is a list of strings." - `(aset ,connection 3 ,extensions)) + (luna-define-internal-accessors 'smtp-connection)) -(defmacro smtp-make-connection (process server service) +(defun smtp-make-connection (process server service) "Create a new connection structure. PROCESS is an internal subprocess-object. SERVER is name of the host to connect to. SERVICE is name of the service desired." - `(vector ,process ,server ,service nil)) + (luna-make-entity 'smtp-connection :process process :server server :service service)) -(defun smtp-connection-opened (connection) - "Say whether the CONNECTION to server has been opened." - (let ((process (smtp-connection-process connection))) +(luna-define-generic smtp-connection-opened (connection) + "Say whether the CONNECTION to server has been opened.") + +(luna-define-generic smtp-close-connection (connection) + "Close the CONNECTION to server.") + +(luna-define-method smtp-connection-opened ((connection smtp-connection)) + (let ((process (smtp-connection-process-internal connection))) (if (memq (process-status process) '(open run)) t))) -(defun smtp-close-connection (connection) - "Close the CONNECTION to server." - (let ((process (smtp-connection-process connection))) +(luna-define-method smtp-close-connection ((connection smtp-connection)) + (let ((process (smtp-connection-process-internal connection))) (delete-process process))) (defun smtp-make-fqdn () @@ -318,22 +308,19 @@ of the host to connect to. SERVICE is name of the service desired." (let* ((connection (smtp-find-connection (current-buffer))) (response - (smtp-read-response - (smtp-connection-process connection)))) + (smtp-read-response connection))) (if (/= (car response) 220) (smtp-response-error response)))) (defun smtp-primitive-ehlo (package) (let* ((connection (smtp-find-connection (current-buffer))) - (process - (smtp-connection-process connection)) response) - (smtp-send-command process (format "EHLO %s" (smtp-make-fqdn))) - (setq response (smtp-read-response process)) + (smtp-send-command connection (format "EHLO %s" (smtp-make-fqdn))) + (setq response (smtp-read-response connection)) (if (/= (car response) 250) (smtp-response-error response)) - (smtp-connection-set-extensions + (smtp-connection-set-extensions-internal connection (mapcar (lambda (extension) (let ((extensions @@ -347,21 +334,17 @@ of the host to connect to. SERVICE is name of the service desired." (defun smtp-primitive-helo (package) (let* ((connection (smtp-find-connection (current-buffer))) - (process - (smtp-connection-process connection)) response) - (smtp-send-command process (format "HELO %s" (smtp-make-fqdn))) - (setq response (smtp-read-response process)) + (smtp-send-command connection (format "HELO %s" (smtp-make-fqdn))) + (setq response (smtp-read-response connection)) (if (/= (car response) 250) (smtp-response-error response)))) (defun smtp-primitive-auth (package) (let* ((connection (smtp-find-connection (current-buffer))) - (process - (smtp-connection-process connection)) (mechanisms - (cdr (assq 'auth (smtp-connection-extensions connection)))) + (cdr (assq 'auth (smtp-connection-extensions-internal connection)))) (sasl-mechanisms (or smtp-sasl-mechanisms sasl-mechanisms)) (mechanism @@ -373,20 +356,20 @@ of the host to connect to. SERVICE is name of the service desired." (unless mechanism (error "No authentication mechanism available")) (setq client (sasl-make-client mechanism smtp-sasl-user-name "smtp" - (smtp-connection-server connection))) + (smtp-connection-server-internal connection))) (if smtp-sasl-properties (sasl-client-set-properties client smtp-sasl-properties)) (setq name (sasl-mechanism-name mechanism) ;; Retrieve the initial response step (sasl-next-step client nil)) (smtp-send-command - process + connection (if (sasl-step-data step) (format "AUTH %s %s" name (base64-encode-string (sasl-step-data step) t)) (format "AUTH %s" name))) (catch 'done (while t - (setq response (smtp-read-response process)) + (setq response (smtp-read-response connection)) (when (= (car response) 235) ;; The authentication process is finished. (setq step (sasl-next-step client step)) @@ -398,97 +381,92 @@ of the host to connect to. SERVICE is name of the service desired." (sasl-step-set-data step (base64-decode-string (nth 1 response))) (setq step (sasl-next-step client step)) (smtp-send-command - process (if (sasl-step-data step) - (base64-encode-string (sasl-step-data step) t) - "")))))) + connection + (if (sasl-step-data step) + (base64-encode-string (sasl-step-data step) t) + "")))) + (smtp-connection-set-encoder-internal + connection (sasl-client-encoder client)) + (smtp-connection-set-decoder-internal + connection (sasl-client-decoder client)))) (defun smtp-primitive-starttls (package) (let* ((connection (smtp-find-connection (current-buffer))) - (process - (smtp-connection-process connection)) response) ;; STARTTLS --- begin a TLS negotiation (RFC 2595) - (smtp-send-command process "STARTTLS") - (setq response (smtp-read-response process)) + (smtp-send-command connection "STARTTLS") + (setq response (smtp-read-response connection)) (if (/= (car response) 220) (smtp-response-error response)) - (starttls-negotiate process))) + (starttls-negotiate (smtp-connection-process-internal connection)))) (defun smtp-primitive-mailfrom (package) (let* ((connection (smtp-find-connection (current-buffer))) - (process - (smtp-connection-process connection)) (extensions - (smtp-connection-extensions + (smtp-connection-extensions-internal connection)) (sender - (smtp-package-sender package)) + (smtp-package-sender-internal package)) extension response) ;; SIZE --- Message Size Declaration (RFC1870) (if (and smtp-use-size (assq 'size extensions)) - (setq extension (format "SIZE=%d" (smtp-package-buffer-size package)))) + (setq extension (format "SIZE=%d" (smtp-package-buffer-internal-size package)))) ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652) (if (and smtp-use-8bitmime (assq '8bitmime extensions)) (setq extension (concat extension " BODY=8BITMIME"))) (smtp-send-command - process + connection (if extension (format "MAIL FROM:<%s> %s" sender extension) (format "MAIL FROM:<%s>" sender))) - (setq response (smtp-read-response process)) + (setq response (smtp-read-response connection)) (if (/= (car response) 250) (smtp-response-error response)))) (defun smtp-primitive-rcptto (package) (let* ((connection (smtp-find-connection (current-buffer))) - (process - (smtp-connection-process connection)) (recipients - (smtp-package-recipients package)) + (smtp-package-recipients-internal package)) response) (while recipients (smtp-send-command - process (format "RCPT TO:<%s>" (pop recipients))) - (setq response (smtp-read-response process)) + connection (format "RCPT TO:<%s>" (pop recipients))) + (setq response (smtp-read-response connection)) (unless (memq (car response) '(250 251)) (smtp-response-error response))))) (defun smtp-primitive-data (package) (let* ((connection (smtp-find-connection (current-buffer))) - (process - (smtp-connection-process connection)) response) - (smtp-send-command process "DATA") - (setq response (smtp-read-response process)) + (smtp-send-command connection "DATA") + (setq response (smtp-read-response connection)) (if (/= (car response) 354) (smtp-response-error response)) (save-excursion - (set-buffer (smtp-package-buffer package)) + (set-buffer (smtp-package-buffer-internal package)) (goto-char (point-min)) (while (not (eobp)) (smtp-send-data - process (buffer-substring (point) (progn (end-of-line)(point)))) + connection (buffer-substring (point) (progn (end-of-line)(point)))) (beginning-of-line 2))) - (smtp-send-command process ".") - (setq response (smtp-read-response process)) + (smtp-send-command connection ".") + (setq response (smtp-read-response connection)) (if (/= (car response) 250) (smtp-response-error response)))) (defun smtp-primitive-quit (package) (let* ((connection (smtp-find-connection (current-buffer))) - (process - (smtp-connection-process connection)) response) - (smtp-send-command process "QUIT") - (setq response (smtp-read-response process)) + (smtp-send-command connection "QUIT") + (setq response (smtp-read-response connection)) (if (/= (car response) 221) (smtp-response-error response)))) @@ -509,14 +487,20 @@ of the host to connect to. SERVICE is name of the service desired." (defun smtp-response-error (response) (signal 'smtp-response-error response)) -(defun smtp-read-response (process) - (let ((response-continue t) +(defun smtp-read-response (connection) + (let ((decoder + (smtp-connection-decoder-internal connection)) + (response-continue t) response) (while response-continue (goto-char smtp-read-point) (while (not (search-forward "\r\n" nil t)) - (accept-process-output process) + (accept-process-output (smtp-connection-process-internal connection)) (goto-char smtp-read-point)) + (if decoder + (let ((string (buffer-substring smtp-read-point (- (point) 2)))) + (delete-region smtp-read-point (point)) + (insert (funcall decoder string) "\r\n"))) (setq response (nconc response (list (buffer-substring @@ -530,21 +514,33 @@ of the host to connect to. SERVICE is name of the service desired." response-continue nil))) response)) -(defun smtp-send-command (process command) +(defun smtp-send-command (connection command) (save-excursion - (set-buffer (process-buffer process)) - (goto-char (point-max)) - (insert command "\r\n") - (setq smtp-read-point (point)) - (process-send-string process command) - (process-send-string process "\r\n"))) - -(defun smtp-send-data (process data) - ;; Escape "." at start of a line. - (if (eq (string-to-char data) ?.) - (process-send-string process ".")) - (process-send-string process data) - (process-send-string process "\r\n")) + (let ((process + (smtp-connection-process-internal connection)) + (encoder + (smtp-connection-encoder-internal connection))) + (set-buffer (process-buffer process)) + (goto-char (point-max)) + (setq command (concat command "\r\n")) + (insert command) + (setq smtp-read-point (point)) + (if encoder + (setq command (funcall encoder command))) + (process-send-string process command)))) + +(defun smtp-send-data (connection data) + (let ((process + (smtp-connection-process-internal connection)) + (encoder + (smtp-connection-encoder-internal connection))) + ;; Escape "." at start of a line. + (if (eq (string-to-char data) ?.) + (setq data (concat "." data "\r\n")) + (setq data (concat data "\r\n"))) + (if encoder + (setq data (funcall encoder data))) + (process-send-string process data))) (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end) "Get address list suitable for smtp RCPT TO:
." -- 1.7.10.4