? bug-631314.data
? bug-631314.patch
? smtp-auth.patch
? smtp.tcl.mine
? test-tls.tcl
? test-tls2.tcl
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/mime/ChangeLog,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -r1.50 -r1.51
--- ChangeLog	16 Feb 2004 04:14:48 -0000	1.50
+++ ChangeLog	18 Mar 2004 10:47:53 -0000	1.51
@@ -1,3 +1,11 @@
+2004-03-18  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* smtp.tcl: Added support for RFC 2554 - SMTP Authentication. This
+	included support for the SASL mechanisms CRAM-MD5 and PLAIN and
+	the Microsoft LOGIN mechanism. This has been tested against
+	Microsoft Exchange servers and Sendmail 8.12.
+	Added support for RFC 1870, the SIZE extension.
+
 2004-02-15  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
 
 	*
Index: smtp.man
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/mime/smtp.man,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- smtp.man	30 Jan 2004 10:00:18 -0000	1.9
+++ smtp.man	18 Mar 2004 10:47:53 -0000	1.10
@@ -70,6 +70,17 @@
 Returning 'secure' will cause the socket to be closed and the next server
 in the [option -servers] list to be tried.
 
+[lst_item [option -username]]
+[lst_item [option -password]]
+
+If your SMTP server requires authentication before accepting mail you can
+use [option -username] and [option -password] to provide your authentication
+details to the server. Currently this package supports CRAM-MD5, LOGIN and
+PLAIN authentication methods. The most secure method will be tried first
+and each method tried in turn until we are either authorized or we run out of
+methods. Note that if the server permits a TLS connection, then the 
+authorization will occur after we begin using the secure channel.
+
 [list_end]
 [nl]
 
Index: smtp.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/mime/smtp.tcl,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- smtp.tcl	4 Feb 2004 22:50:28 -0000	1.32
+++ smtp.tcl	18 Mar 2004 10:47:53 -0000	1.33
@@ -95,6 +95,8 @@
 #                          some reason. Return 'insecure' to continue with
 #                          normal SMTP or 'secure' to close the connection and
 #                          try another server.
+#             -username    These are needed if your SMTP server requires
+#             -password    authentication.
 #
 # Results:
 #	Message is sent.  On success, return "".  On failure, throw an
@@ -120,6 +122,8 @@
     set ports [list 25]
     set tlsP 1
     set tlspolicy {}
+    set username {}
+    set password {}
 
     array set header ""
 
@@ -186,6 +190,9 @@
                 set ports $value
             }
 
+            -username { set username $value }
+            -password { set password $value }
+
             default {
                 error "unknown option $option"
             }
@@ -397,7 +404,8 @@
 		                -maxsecs $maxsecs -usetls $tlsP \
                                 -multiple $bccP -queue $queueP \
                                 -servers $servers -ports $ports \
-                                -tlspolicy $tlspolicy]
+                                -tlspolicy $tlspolicy \
+                                -username $username -password $password]
 
     if {![string match "::smtp::*" $token]} {
 	# An error occurred and $token contains the error info
@@ -512,7 +520,7 @@
 proc ::smtp::sendmessageaux {token part originator recipients aloP} {
     global errorCode errorInfo
 
-    winit $token $originator
+    winit $token $part $originator
 
     set goodP 0
     set badP 0
@@ -570,6 +578,8 @@
 #                          the request (one port per server-- defaults to 25).
 #             -usetls      A boolean to indicate we will use TLS if possible.
 #             -tlspolicy   Command called if TLS setup fails.
+#             -username    These provide the authentication information 
+#             -password    to be used if needed by the SMTP server.
 #
 # Results:
 #	On success, return an smtp token.  On failure, throw
@@ -588,7 +598,8 @@
     array set state [list afterID "" options "" readable 0]
     array set options [list -debug 0 -client localhost -multiple 1 \
                             -maxsecs 120 -queue 0 -servers localhost \
-                            -ports 25 -usetls 1 -tlspolicy {}]
+                            -ports 25 -usetls 1 -tlspolicy {} \
+                            -username {} -password {}]
     array set options $args
     set state(options) [array get options]
 
@@ -693,6 +704,8 @@
         # Successful response to HELO or EHLO command, so set up queuing
         # and whatnot and return the token.
         
+        set state(esmtp) $response(args)
+
         if {(!$options(-multiple)) \
                 && ([lsearch $response(args) ONEX] >= 0)} {
             catch {smtp::talk $token 300 ONEX}
@@ -744,6 +757,44 @@
                 }
             }
         }
+
+        if {![info exists state(auth)] \
+                && [set andx [lsearch -glob $response(args) "AUTH*"]] >= 0} {
+            
+            # May be AUTH mech or AUTH=mech
+            # We want to use the strongest mechanism that has been offered
+            # and that we support. If we cannot find a mechanism that 
+            # succeeds, we will go ahead and try to carry on unauthenticated.
+            # This may still work else we'll get an unauthorised error later.
+
+            set mechs [string range [lindex $response(args) $andx] 5 end]
+            foreach mech [list CRAM-MD5 LOGIN PLAIN] {
+                if {[lsearch -exact $mechs $mech] == -1} { continue }
+                if {[info command [namespace current]::auth_$mech] != {}} {
+                    if {[catch {
+                        auth_$mech $token
+                    } msg]} {
+                        if {$options(-debug)} {
+                            puts stderr "AUTH $mech failed: $msg "
+                            flush stderr
+                        }
+                    }
+                    if {[info exists state(auth)] && $state(auth)} {
+                        if {$state(auth) == 1} {
+                            break
+                        } else {
+                            # After successful AUTH we are supposed to redo
+                            # our connection for mechanisms that setup a new
+                            # security layer -- these should set state(auth) 
+                            # greater than 1
+                            fileevent $state(sd) readable \
+                                [list ::smtp::readable $token]
+                            return [initialize_ehlo $token]
+                        }
+                    }
+                }
+            }
+        }
         
         return $token
     } else {
@@ -754,6 +805,111 @@
     return {}
 }
 
+# ::smtp::auth_LOGIN --
+#
+#	Perform LOGIN authentication to the SMTP server.
+#
+# Results:
+#	Negiotiates user authentication. If successful returns the result
+#       otherwise an error is thrown
+
+proc ::smtp::auth_LOGIN {token} {
+    # FRINK: nocheck
+    variable $token
+    upvar 0 $token state
+    array set options $state(options)
+    
+    package require base64
+    set user [base64::encode $options(-username)]
+    set pass [base64::encode $options(-password)]
+
+    set state(auth) 0
+    set result [smtp::talk $token 300 "AUTH LOGIN"]
+    array set response $result
+
+    if {$response(code) == 334} {
+        set result [smtp::talk $token 300 $user]
+        array set response $result
+    }
+    if {$response(code) == 334} {
+        set result [smtp::talk $token 300 $pass]
+        array set response $result
+    }
+    if {$response(code) == 235} {
+        set state(auth) 1
+        return $result
+    } else {
+        return -code 7 $result
+    }
+}
+
+# ::smtp::auth_PLAIN
+#
+# 	Implement PLAIN SASL mechanism (RFC2595).
+#
+# Results:
+#	Negiotiates user authentication. If successful returns the result
+#       otherwise an error is thrown
+
+proc ::smtp::auth_PLAIN {token} {
+    # FRINK: nocheck
+    variable $token
+    upvar 0 $token state
+    array set options $state(options)
+    
+    package require base64
+    set id [base64::encode "\x00$options(-username)\x00$options(-password)"]
+
+    set state(auth) 0
+    set result [smtp::talk $token 300 "AUTH PLAIN $id"]
+    array set response $result
+    
+    if {$response(code) == 235} {
+        set state(auth) 1
+        return $result
+    } else {
+        return -code 7 $result
+    }
+}
+
+# ::smtp::auth_CRAM-MD5
+#
+# 	Implement CRAM-MD5 SASL mechanism (RFC2195).
+#
+# Results:
+#	Negiotiates user authentication. If successful returns the result
+#       otherwise an error is thrown
+
+proc ::smtp::auth_CRAM-MD5 {token} {
+    # FRINK: nocheck
+    variable $token
+    upvar 0 $token state
+    array set options $state(options)
+    
+    package require base64
+    package require md5 2
+
+    set state(auth) 0
+    set result [smtp::talk $token 300 "AUTH CRAM-MD5"]
+    array set response $result
+
+    if {$response(code) == 334} {
+        set challenge [base64::decode $response(diagnostic)]
+        set reply [md5::hmac -hex -key $options(-password) $challenge]
+        set reply [base64::encode \
+                       "$options(-username) [string tolower $reply]"]
+        set result [smtp::talk $token 300 $reply]
+        array set response $result
+    }
+
+    if {$response(code) == 235} {
+        set state(auth) 1
+        return $result
+    } else {
+        return -code 7 $result
+    }
+}
+
 # ::smtp::finalize --
 #
 #	Deletes an SMTP token by closing the connection to the SMTP server,
@@ -832,6 +988,8 @@
 #
 # Arguments:
 #       token       SMTP token that has an open connection to the SMTP server.
+#       part        MIME token for the message to be sent. May be used for
+#                   handling some SMTP extensions.
 #       originator  The e-mail address of the entity sending the message,
 #                   usually the From clause.
 #       mode        SMTP command specifying the mode of communication.  Default
@@ -841,7 +999,7 @@
 #	Originator info is sent and SMTP server's response is returned.  If an
 #       error occurs, throw an exception.
 
-proc ::smtp::winit {token originator {mode MAIL}} {
+proc ::smtp::winit {token part originator {mode MAIL}} {
     # FRINK: nocheck
     variable $token
     upvar 0 $token state
@@ -850,9 +1008,19 @@
         error "unknown origination mode $mode"
     }
 
-    array set response \
-          [set result [talk $token 600 \
-                                  "$mode FROM:<$originator>"]]
+    set from "$mode FROM:<$originator>"
+
+    # RFC 1870 -  SMTP Service Extension for Message Size Declaration
+    if {[info exists state(esmtp)] 
+        && [lsearch -glob $state(esmtp) "SIZE*"] != -1} {
+        catch {
+            set size [string length [mime::buildmessage $part]]
+            append from " SIZE=$size"
+        }
+    }
+
+    array set response [set result [talk $token 600 $from]]
+
     if {$response(code) == 250} {
         set state(addrs) 0
         return $result
