Fix AUTH PLAIN support,and add STARTTLS support; clean up response handling code...

diff --git a/basis/smtp/server/server.factor b/basis/smtp/server/server.factor
index 31b67b38a68c0d3770ab7c4b19f17c4bd83b5ca3..7de22e9af9a3ccbd8ded2a29099c0bc30d3a2d46 100644 (file)
--- a/basis/smtp/server/server.factor
+++ b/basis/smtp/server/server.factor
@@ -1,9 +1,10 @@
 ! Copyright (C) 2007 Elie CHAFTARI
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel prettyprint io io.timeouts
-sequences namespaces io.sockets continuations calendar
-io.encodings.ascii io.streams.duplex destructors
-locals concurrency.promises threads accessors ;
+USING: combinators kernel prettyprint io io.timeouts sequences
+namespaces io.sockets io.sockets.secure continuations calendar
+io.encodings.ascii io.streams.duplex destructors locals
+concurrency.promises threads accessors smtp.private
+io.unix.sockets.secure.debug ;
 IN: smtp.server
 
 ! Mock SMTP server for testing purposes.
@@ -34,44 +35,52 @@ IN: smtp.server
 SYMBOL: data-mode
 
 : process ( -- )
-    readln {
-        { [ [ dup "HELO" head? ] keep "EHLO" head? or ] [ 
-            "220 and..?\r\n" write flush t
-          ] }
-        { [ dup "QUIT" = ] [ 
-            "bye\r\n" write flush f
-          ] }
-        { [ dup "MAIL FROM:" head? ] [ 
-            "220 OK\r\n" write flush t
-          ] }
-        { [ dup "RCPT TO:" head? ] [ 
-            "220 OK\r\n" write flush t
-          ] }
-        { [ dup "DATA" = ] [
-            data-mode on 
-            "354 Enter message, ending with \".\" on a line by itself\r\n"
-            write flush t
-          ] }
-        { [ dup "." = data-mode get and ] [
-            data-mode off
-            "220 OK\r\n" write flush t
-          ] }
+    read-crlf {
+        {
+            [ dup [ "HELO" head? ] [ "EHLO" head? ] bi or ]
+            [ "220 and..?\r\n" write flush t ]
+        }
+        {
+            [ dup "STARTTLS" = ]
+            [
+                "220 2.0.0 Ready to start TLS\r\n" write flush
+                accept-secure-handshake t
+            ]
+        }
+        { [ dup "QUIT" = ] [ "220 bye\r\n" write flush f ] }
+        { [ dup "MAIL FROM:" head? ] [ "220 OK\r\n" write flush t ] }
+        { [ dup "RCPT TO:" head? ] [ "220 OK\r\n" write flush t ] }
+        {
+            [ dup "DATA" = ]
+            [
+                data-mode on 
+                "354 Enter message, ending with \".\" on a line by itself\r\n"
+                write flush t
+            ]
+        }
+        {
+            [ dup "." = data-mode get and ]
+            [
+                data-mode off
+                "220 OK\r\n" write flush t
+            ]
+        }
         { [ data-mode get ] [ dup global [ print ] bind t ] }
-        [ 
-            "500 ERROR\r\n" write flush t
-        ]
+        [ "500 ERROR\r\n" write flush t ]
     } cond nip [ process ] when ;
 
 :: mock-smtp-server ( promise -- )
     #! Store the port we are running on in the promise.
     [
-        "127.0.0.1" 0 <inet4> ascii <server> [
-        dup addr>> port>> promise fulfill
-            accept drop [
-                1 minutes timeouts
-                "220 hello\r\n" write flush
-                process
-                global [ flush ] bind
-            ] with-stream
-        ] with-disposal
+        [
+            "127.0.0.1" 0 <inet4> ascii <server> [
+            dup addr>> port>> promise fulfill
+                accept drop [
+                    1 minutes timeouts
+                    "220 hello\r\n" write flush
+                    process
+                    global [ flush ] bind
+                ] with-stream
+            ] with-disposal
+        ] with-test-context
     ] in-thread ;

diff --git a/basis/smtp/smtp-docs.factor b/basis/smtp/smtp-docs.factor
index e8820b1be8d9b55e0f2e37b2e2a57fc953f333fb..83b9287043fbf9882aba604f173037af74b9254c 100644 (file)
--- a/basis/smtp/smtp-docs.factor
+++ b/basis/smtp/smtp-docs.factor
@@ -10,6 +10,9 @@ HELP: smtp-domain
 HELP: smtp-server
 { $var-description "Holds an " { $link inet } " object with the address of an SMTP server." } ;
 
+HELP: smtp-tls?
+{ $var-description "If set to true, secure socket communication will be established after connecting to the SMTP server. The server must support the " { $snippet "STARTTLS" } " command. Off by default." } ;
+
 HELP: smtp-read-timeout
 { $var-description "Holds a " { $link duration } " object that specifies how long to wait for a response from the SMTP server." } ;
 
@@ -75,6 +78,7 @@ ARTICLE: "smtp" "SMTP client library"
 $nl
 "This library is configured by a set of dynamically-scoped variables:"
 { $subsection smtp-server }
+{ $subsection smtp-tls? }
 { $subsection smtp-read-timeout }
 { $subsection smtp-domain }
 { $subsection smtp-auth }

diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor
index c2c95168f86909bd617b92abdd39ca645da9fe2f..7bc7630a4028ef9786f32456c2c1ce6d631be43b 100644 (file)
--- a/basis/smtp/smtp-tests.factor
+++ b/basis/smtp/smtp-tests.factor
@@ -18,15 +18,22 @@ IN: smtp.tests
     "hello\nworld" [ send-body ] with-string-writer
 ] unit-test
 
-[ "500 syntax error" check-response ] must-fail
+[ { "500 syntax error" } <response> check-response ]
+[ smtp-error? ] must-fail-with
 
-[ ] [ "220 success" check-response ] unit-test
+[ ] [ { "220 success" } <response> check-response ] unit-test
 
-[ "220 success" ] [
+[ T{ response f 220 { "220 success" } } ] [
     "220 success" [ receive-response ] with-string-reader
 ] unit-test
 
-[ "220 the end" ] [
+[
+    T{ response f 220 {
+        "220-a multiline response"
+        "250-another line"
+        "220 the end"
+    } }
+] [
     "220-a multiline response\r\n250-another line\r\n220 the end"
     [ receive-response ] with-string-reader
 ] unit-test
@@ -72,6 +79,8 @@ IN: smtp.tests
 [ ] [
     [
         "localhost" "p" get ?promise <inet> smtp-server set
+        no-auth smtp-auth set
+        smtp-tls? on
 
         <email>
             "Hi guys\nBye guys" >>body

diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor
index c033ff2b2e973d840c21511797dd8f0513d00029..7f14945633b82f2b2201959ede17856d2086b209 100644 (file)
--- a/basis/smtp/smtp.factor
+++ b/basis/smtp/smtp.factor
@@ -2,10 +2,11 @@
 ! Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays namespaces make io io.encodings.string
-io.encodings.utf8 io.timeouts kernel logging io.sockets
-sequences combinators splitting assocs strings math.parser
-random system calendar io.encodings.ascii summary
-calendar.format accessors sets hashtables base64 ;
+io.encodings.utf8 io.timeouts io.sockets io.sockets.secure
+io.encodings.ascii kernel logging sequences combinators
+splitting assocs strings math.order math.parser random system
+calendar summary calendar.format accessors sets hashtables
+base64 debugger classes prettyprint ;
 IN: smtp
 
 SYMBOL: smtp-domain
@@ -13,6 +14,8 @@ SYMBOL: smtp-domain
 SYMBOL: smtp-server
 "localhost" 25 <inet> smtp-server set-global
 
+SYMBOL: smtp-tls?
+
 SYMBOL: smtp-read-timeout
 1 minutes smtp-read-timeout set-global
 
@@ -43,16 +46,24 @@ TUPLE: email
     { subject string }
     { body string } ;
 
-: <email> ( -- email ) email new ;
+: <email> ( -- email ) email new ; inline
 
 <PRIVATE
 
 : crlf ( -- ) "\r\n" write ;
 
+: read-crlf ( -- bytes )
+    "\r" read-until
+    [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
+
 : command ( string -- ) write crlf flush ;
 
+\ command DEBUG add-input-logging
+
 : helo ( -- ) "EHLO " host-name append command ;
 
+: start-tls ( -- ) "STARTTLS" command ;
+
 ERROR: bad-email-address email ;
 
 : validate-address ( string -- string' )
@@ -89,7 +100,30 @@ M: message-contains-dot summary ( obj -- string )
 
 LOG: smtp-response DEBUG
 
-ERROR: smtp-error message ;
+: multiline? ( response -- boolean )
+    3 swap ?nth CHAR: - = ;
+
+: (receive-response) ( -- )
+    read-crlf
+    [ , ]
+    [ smtp-response ]
+    [ multiline? [ (receive-response) ] when ]
+    tri ;
+
+TUPLE: response code messages ;
+
+: <response> ( lines -- response )
+    [ first 3 head string>number ] keep response boa ;
+
+: receive-response ( -- response )
+    [ (receive-response) ] { } make <response> ;
+
+ERROR: smtp-error response ;
+
+M: smtp-error error.
+    "SMTP error (" write dup class pprint ")" print
+    response>> messages>> [ print ] each ;
+
 ERROR: smtp-server-busy < smtp-error ;
 ERROR: smtp-syntax-error < smtp-error ;
 ERROR: smtp-command-not-implemented < smtp-error ;
@@ -101,52 +135,35 @@ ERROR: smtp-bad-mailbox-name < smtp-error ;
 ERROR: smtp-transaction-failed < smtp-error ;
 
 : check-response ( response -- )
-    dup smtp-response
-    {
-        { [ dup "bye" head? ] [ drop ] }
-        { [ dup "220" head? ] [ drop ] }
-        { [ dup "235" swap subseq? ] [ drop ] }
-        { [ dup "250" head? ] [ drop ] }
-        { [ dup "221" head? ] [ drop ] }
-        { [ dup "354" head? ] [ drop ] }
-        { [ dup "4" head? ] [ smtp-server-busy ] }
-        { [ dup "500" head? ] [ smtp-syntax-error ] }
-        { [ dup "501" head? ] [ smtp-command-not-implemented ] }
-        { [ dup "50" head? ] [ smtp-syntax-error ] }
-        { [ dup "53" head? ] [ smtp-bad-authentication ] }
-        { [ dup "550" head? ] [ smtp-mailbox-unavailable ] }
-        { [ dup "551" head? ] [ smtp-user-not-local ] }
-        { [ dup "552" head? ] [ smtp-exceeded-storage-allocation ] }
-        { [ dup "553" head? ] [ smtp-bad-mailbox-name ] }
-        { [ dup "554" head? ] [ smtp-transaction-failed ] }
-        [ smtp-error ]
+    dup code>> {
+        { [ dup { 220 235 250 221 354 } member? ] [ 2drop ] }
+        { [ dup 400 499 between? ] [ drop smtp-server-busy ] }
+        { [ dup 500 = ] [ drop smtp-syntax-error ] }
+        { [ dup 501 = ] [ drop smtp-command-not-implemented ] }
+        { [ dup 500 509 between? ] [ drop smtp-syntax-error ] }
+        { [ dup 530 539 between? ] [ drop smtp-bad-authentication ] }
+        { [ dup 550 = ] [ drop smtp-mailbox-unavailable ] }
+        { [ dup 551 = ] [ drop smtp-user-not-local ] }
+        { [ dup 552 = ] [ drop smtp-exceeded-storage-allocation ] }
+        { [ dup 553 = ] [ drop smtp-bad-mailbox-name ] }
+        { [ dup 554 = ] [ drop smtp-transaction-failed ] }
+        [ drop smtp-error ]
     } cond ;
 
-: multiline? ( response -- boolean )
-    3 swap ?nth CHAR: - = ;
-
-: process-multiline ( multiline -- response )
-    [ readln ] dip 2dup " " append head? [
-        drop dup smtp-response
-    ] [
-        swap check-response process-multiline
-    ] if ;
-
-: receive-response ( -- response )
-    readln
-    dup multiline? [ 3 head process-multiline ] when ;
-
 : get-ok ( -- ) receive-response check-response ;
 
 GENERIC: send-auth ( auth -- )
 
 M: no-auth send-auth drop ;
 
+: plain-auth-string ( username password -- string )
+    [ "\0" prepend ] bi@ append utf8 encode >base64 ;
+
 M: plain-auth send-auth
-    [ username>> ] [ password>> ] bi "\0" swap 3append utf8 encode >base64
-    "AUTH PLAIN " prepend command ;
+    [ username>> ] [ password>> ] bi plain-auth-string
+    "AUTH PLAIN " prepend command get-ok ;
 
-: auth ( -- ) smtp-auth get send-auth get-ok ;
+: auth ( -- ) smtp-auth get send-auth ;
 
 ERROR: invalid-header-string string ;
 
@@ -190,7 +207,9 @@ ERROR: invalid-header-string string ;
 
 : (send-email) ( headers email -- )
     [
+        get-ok
         helo get-ok
+        smtp-tls? get [ start-tls get-ok send-secure-handshake ] when
         auth
         dup from>> extract-email mail-from get-ok
         dup to>> [ extract-email rcpt-to get-ok ] each