From: Taylor R. Campbell Date: Sun, 10 Feb 2008 10:44:13 +0000 (+0000) Subject: Implement SMTP AUTH LOGIN and AUTH PLAIN extensions for authentication X-Git-Tag: 20090517-FFI~339 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=874427983adcd0a63e06e5a385e1958a3b18adc6;p=mit-scheme.git Implement SMTP AUTH LOGIN and AUTH PLAIN extensions for authentication when sending mail by SMTP. New Edwin variable MAIL-AUTHENTICATION controls whether to authenticate; set it to #T to enable authentication by default. New Edwin variable SMTP-USER-NAME can be set to specify a user name. Still to do: CRAM-MD5 (shouldn't be hard, but I don't need it now), and automatic detection of necessity of authentication. Is there an SMTP reply code to tell us that we must authenticate? --- diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index dcb31d066..99a5ad4f0 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.305 2008/02/10 10:06:51 riastradh Exp $ +$Id: edwin.pkg,v 1.306 2008/02/10 10:44:13 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -1525,6 +1525,7 @@ USA. edwin-variable$file-type-to-mime-type edwin-variable$mail-abbreviate-mime edwin-variable$mail-archive-file-name + edwin-variable$mail-authentication edwin-variable$mail-default-reply-to edwin-variable$mail-from-style edwin-variable$mail-full-name @@ -1544,8 +1545,10 @@ USA. edwin-variable$mime-attachments-mode-hook edwin-variable$send-mail-procedure edwin-variable$sendmail-program + edwin-variable$smtp-greeting-hostname edwin-variable$smtp-require-valid-recipients edwin-variable$smtp-trace + edwin-variable$smtp-user-name edwin-variable$user-mail-address enable-buffer-mime-processing! finish-preparing-mail-buffer diff --git a/v7/src/edwin/sendmail.scm b/v7/src/edwin/sendmail.scm index 6d4aeebf0..ecef264d7 100644 --- a/v7/src/edwin/sendmail.scm +++ b/v7/src/edwin/sendmail.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: sendmail.scm,v 1.93 2008/01/30 20:02:05 cph Exp $ +$Id: sendmail.scm,v 1.94 2008/02/10 10:44:13 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -109,6 +109,24 @@ This is used only of `mail-relay-host' is set." (exact-positive-integer? service) (string? service)))) +(define-variable mail-authentication + "SMTP authentication method (SASL mechanism) as a string. +Set this to #F to disable authentication and to #T to use whatever + method is accepted by server, or no authentication if the server + accepts none. +Currently only \"LOGIN\" and \"PLAIN\" are supported, so use this form + of authentication only over a secure channel." + #f + (lambda (method) + (member method '(#f #t "LOGIN" "PLAIN")))) + +(define-variable smtp-user-name + "User name to use for simple SMTP authentication. +#F means prompt for the name each time." + #f + (lambda (object) + (or (not object) (string? object)))) + (define-variable smtp-trace "If true, direct SMTP transmissions are traced in a buffer." #f @@ -120,6 +138,15 @@ Otherwise, only one valid recipient is required." #t boolean?) +(define-variable smtp-greeting-hostname + "Hostname for HELO (or EHLO) messages when sending mail by SMTP. +This may be a string or a procedure. +Default is whatever the OS reports." + os/hostname + (lambda (object) + (or (string? object) + (procedure? object)))) + (define-variable sendmail-program "Filename of sendmail program." #f @@ -918,46 +945,24 @@ the user from the mailer." (define (send-mail-using-smtp message-pathname recipients lookup-context) (message "Sending...") - (let ((from - (rfc822:canonicalize-address-string - (mail-from-string lookup-context))) - (trace-buffer + (if (null? recipients) + (editor-error "No recipients specified for mail.")) + (let ((trace-buffer (and (ref-variable smtp-trace lookup-context) - (temporary-buffer "*SMTP-trace*"))) - (require-valid? - (ref-variable smtp-require-valid-recipients lookup-context)) - (valid-response? - (lambda (response) (= 250 (smtp-response-number response))))) - (if (null? recipients) - (editor-error "No recipients specified for mail.")) + (temporary-buffer "*SMTP-trace*")))) (let ((responses - (call-with-smtp-socket (ref-variable mail-relay-host lookup-context) - (ref-variable mail-relay-service - lookup-context) - trace-buffer - (lambda (port banner) - banner - (smtp-command/helo port) - (smtp-command/mail port from) - (let ((responses - (map (lambda (recipient) - (smtp-command/rcpt port recipient)) - recipients))) - (if (if require-valid? - (for-all? responses valid-response?) - (there-exists? responses valid-response?)) - (smtp-command/data port message-pathname) - (smtp-command/rset port)) - (smtp-command/quit port) - responses))))) - (cond ((not (for-all? responses valid-response?)) + (transct-smtp recipients + message-pathname + trace-buffer + lookup-context))) + (cond ((not (for-all? responses smtp-response-valid?)) (pop-up-temporary-buffer "*SMTP-invalid*" '(READ-ONLY FLUSH-ON-SPACE) (lambda (buffer window) window (let ((m (mark-left-inserting-copy (buffer-start buffer)))) (for-each (lambda (recipient response) - (if (not (valid-response? response)) + (if (not (smtp-response-valid? response)) (begin (insert-string recipient m) (insert-char #\tab m) @@ -970,11 +975,38 @@ the user from the mailer." (buffer-not-modified! trace-buffer) (pop-up-buffer trace-buffer #f))) (message "Sending..." - (if (if require-valid? - (for-all? responses valid-response?) - (there-exists? responses valid-response?)) + (if (smtp-responses-ok? responses lookup-context) "done" "aborted"))))) + +(define (transct-smtp recipients message-pathname trace-buffer lookup-context) + (call-with-smtp-socket (ref-variable mail-relay-host lookup-context) + (ref-variable mail-relay-service lookup-context) + trace-buffer + (lambda (port banner) + banner ;ignore + (let ((capabilities + (smtp-command/ehlo port (smtp-greeting-hostname lookup-context)))) + (smtp-authenticate port capabilities lookup-context) + (smtp-command/mail port (rfc822:canonicalize-address-string + (mail-from-string lookup-context))) + (let ((responses + (map (lambda (recipient) + (smtp-command/rcpt port recipient)) + recipients))) + (if (smtp-responses-ok? responses lookup-context) + (smtp-command/data port message-pathname) + (smtp-command/rset port)) + (smtp-command/quit port) + responses))))) + +(define (smtp-response-valid? response) + (= 250 (smtp-response-number response))) + +(define (smtp-responses-ok? responses lookup-context) + (if (ref-variable smtp-require-valid-recipients lookup-context) + (for-all? responses smtp-response-valid?) + (there-exists? responses smtp-response-valid?))) (define (call-with-smtp-socket host-name service trace-buffer receiver) (let ((port #f)) @@ -982,7 +1014,7 @@ the user from the mailer." (lambda () (set! port (make-smtp-port (open-tcp-stream-socket host-name - (or service "smtp")) + (or service "smtp")) trace-buffer)) unspecific) (lambda () @@ -1025,8 +1057,15 @@ the user from the mailer." (if trace-buffer (insert-newline (buffer-end trace-buffer))))) -(define (smtp-command/helo port) - (smtp-write-line port "HELO " (os/hostname)) +(define (smtp-command/ehlo port hostname) + ;++ This should probably fall back on HELO if the server answers + ;++ non-250, but honestly, how many non-ESMTP servers are there out + ;++ there? + (smtp-write-line port "EHLO " hostname) + (smtp-read-response port 250)) + +(define (smtp-command/helo port hostname) + (smtp-write-line port "HELO " hostname) (smtp-read-response port 250)) (define (smtp-command/mail port from) @@ -1062,6 +1101,12 @@ the user from the mailer." (smtp-write-line port "QUIT") (smtp-read-response port 221)) +(define (smtp-greeting-hostname lookup-context) + (let ((hostname (ref-variable smtp-greeting-hostname lookup-context))) + (if (procedure? hostname) + (hostname) + hostname))) + (define (smtp-read-response port . numbers) (smtp-drain-output port) (let ((response (smtp-read-line port))) @@ -1097,7 +1142,121 @@ the user from the mailer." responses))) (cons (car lines) (append-map (lambda (line) (list "\n" line)) - lines)))))) + (cdr lines))))))) + +;;;;; SMTP Authentication + +(define (smtp-authenticate port capabilities lookup-context) + (define (authenticate method) + (smtp-authenticate-with-method port method lookup-context)) + (let ((method (ref-variable mail-authentication lookup-context))) + (if method + (let ((accepted-methods + (smtp-accepted-authentication-methods capabilities))) + (if (not (pair? accepted-methods)) + (editor-failure "No accepted authentication methods.") + (cond ((and (eq? method #t) + (or (member "LOGIN" accepted-methods) + (member "PLAIN" accepted-methods))) + => (lambda (tail) + (authenticate (car tail)))) + ((member method accepted-methods) + (authenticate method)) + (else + (editor-failure "Authentication method not accepted:" + method)))))))) + +(define rexp:sasl-mechanism ;RFC 2222, Section 3, par. 2 + (let ((char-set + (char-set-union char-set:upper-case + char-set:numeric + (char-set #\- #\_)))) + ;; The regexp compiler loses on this, unfortunately. Fortunately, + ;; it doesn't matter, because if there were an excessively long + ;; name, it would have already caused any harm it could by the + ;; time we try to examine it here. + ;; (rexp-n*m 1 20 char-set) + (rexp+ char-set))) + +(define regexp:sasl-mechanism (rexp->regexp rexp:sasl-mechanism)) + +(define rexp:smtp-auth-keywords + (rexp-sequence (rexp-line-start) + "AUTH" + (rexp-group (rexp* " " rexp:sasl-mechanism)))) + +(define regexp:smtp-auth-keywords (rexp->regexp rexp:smtp-auth-keywords)) + +(define (smtp-accepted-authentication-methods capabilities) + (let ((match + (re-string-search-forward regexp:smtp-auth-keywords capabilities))) + (if match + (cdr (burst-string (re-match-extract capabilities match 1) #\space #f)) + '()))) + +(define (smtp-authenticate-with-method port method lookup-context) + (smtp-write-line port "AUTH " method) + (smtp-read-response port 334) + (let* ((user-name + (or (ref-variable smtp-user-name lookup-context) + (prompt-for-string "User name" #f))) + (pass-phrase-key + (smtp-server-pass-phrase-key user-name lookup-context))) + (cond ((string=? method "LOGIN") + (smtp-auth:login port user-name pass-phrase-key)) + ((string=? method "PLAIN") + (smtp-auth:plain port user-name pass-phrase-key)) + (else (error "Unknown SMTP authentication method:" method))) + (bind-condition-handler + (list condition-type:editor-error) + (lambda (condition) + condition ;ignore + (delete-stored-pass-phrase pass-phrase-key)) + (lambda () + (smtp-read-response port 235))))) + +(define (smtp-auth:login port user-name pass-phrase-key) + (define (base64 string) + (string-trim + (call-with-output-string + (lambda (port) + (let ((context (encode-base64:initialize port #f))) + (encode-base64:update context string 0 (string-length string)) + (encode-base64:finalize context)))))) + (smtp-write-line port (base64 user-name)) + (smtp-read-response port 334) + (smtp-write-line port (call-with-stored-pass-phrase pass-phrase-key base64))) + +(define (smtp-auth:plain port user-name pass-phrase-key) + ((lambda (string) + (smtp-write-line port (string-trim string))) + (call-with-output-string + (lambda (port) + (let ((context (encode-base64:initialize port))) + (encode-base64:update context "\000" 0 1) + (encode-base64:update context user-name 0 (string-length user-name)) + (encode-base64:update context "\000" 0 1) + (call-with-stored-pass-phrase pass-phrase-key + (lambda (pass) + (encode-base64:update context pass 0 (string-length pass)))) + (encode-base64:finalize context)))))) + +(define (smtp-server-pass-phrase-key user-name lookup-context) + ;++ Should this include `SMTP' anywhere? Generating + ;++ `smtp://@:' is disgusting, but it would + ;++ do the trick... + (string-append user-name + "@" + (ref-variable mail-relay-host lookup-context) + (let ((service + (ref-variable mail-relay-service lookup-context))) + (if (or (eqv? service 25) + (equal? service "smtp")) + "" + (string-append ":" + (if (string? service) + service + (number->string service #d10))))))) ;;;; MIME