Add support for AUTH PLAIN to smtp library

Update documentation
The smtp.server used for testing now starts on a random port instead of hard-coding 4321

basis/smtp/server/server.factor

@@ -2,12 +2,12 @@
 ! 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 ;
+io.encodings.ascii io.streams.duplex destructors
+locals concurrency.promises threads accessors ;
 IN: smtp.server
 
 ! Mock SMTP server for testing purposes.
 
-! Usage: 4321 mock-smtp-server
 ! $ telnet 127.0.0.1 4321
 ! Trying 127.0.0.1...
 ! Connected to localhost.
@@ -62,13 +62,16 @@ SYMBOL: data-mode
         ]
     } cond nip [ process ] when ;
 
-: mock-smtp-server ( port -- )
+:: mock-smtp-server ( promise -- )
-    "Starting SMTP server on port " write dup . flush
+    #! Store the port we are running on in the promise.
-    "127.0.0.1" swap <inet4> ascii <server> [
+    [
-        accept drop [
+        "127.0.0.1" 0 <inet4> ascii <server> [
-            1 minutes timeouts
+        dup addr>> port>> promise fulfill
-            "220 hello\r\n" write flush
+            accept drop [
-            process
+                1 minutes timeouts
-            global [ flush ] bind
+                "220 hello\r\n" write flush
-        ] with-stream
+                process
-    ] with-disposal ;
+                global [ flush ] bind
+            ] with-stream
+        ] with-disposal
+    ] in-thread ;

basis/smtp/smtp-docs.factor

@@ -5,20 +5,49 @@ io.sockets strings calendar ;
 IN: smtp
 
 HELP: smtp-domain
-{ $description "The name of the machine that is sending the email.  This variable will be filled in by the " { $link host-name } " word if not set by the user." } ;
+{ $var-description "The name of the machine that is sending the email.  This variable will be filled in by the " { $link host-name } " word if not set by the user." } ;
 
 HELP: smtp-server
-{ $description "Holds an " { $link inet } " object with the address of an SMTP server." } ;
+{ $var-description "Holds an " { $link inet } " object with the address of an SMTP server." } ;
 
 HELP: smtp-read-timeout
-{ $description "Holds an " { $link duration } " object that specifies how long to wait for a response from the SMTP server." } ;
+{ $var-description "Holds a " { $link duration } " object that specifies how long to wait for a response from the SMTP server." } ;
 
-HELP: esmtp?
+HELP: smtp-auth
-{ $description "Set true by default, determines whether the SMTP client is using the Extended SMTP protocol." } ;
+{ $var-description "Holds either " { $link no-auth } " or an instance of " { $link plain-auth } ", specifying how to authenticate with the SMTP server. Set to " { $link no-auth } " by default." } ;
+
+HELP: no-auth
+{ $class-description "If the " { $link smtp-auth } " variable is set to this value, no authentication will be performed." } ;
+
+HELP: plain-auth
+{ $class-description "If the " { $link smtp-auth } " variable is set to this value, plain authentication will be performed, with the username and password stored in the " { $slot "username" } " and " { $slot "password" } " slots of the tuple sent to the server as plain-text." } ;
+
+HELP: <plain-auth> ( username password -- plain-auth )
+{ $values { "username" string } { "password" string } { "plain-auth" plain-auth } }
+{ $description "Creates a new " { $link plain-auth } " instance." } ;
 
 HELP: with-smtp-connection
 { $values { "quot" quotation } }
-{ $description "Connects to an SMTP server stored in " { $link smtp-server } " and calls the quotation." } ;
+{ $description "Connects to an SMTP server stored in " { $link smtp-server } " and calls the quotation." }
+{ $notes "This word is used to implement " { $link send-email } " and there is probably no reason to call it directly." } ;
+
+HELP: email
+{ $class-description "An e-mail. E-mails have the following slots:"
+    { $table
+        { { $slot "from" } "The sender of the e-mail. An e-mail address." }
+        { { $slot "to" } "The recipients of the e-mail. A sequence of e-mail addresses." }
+        { { $slot "cc" } "Carbon-copy. A sequence of e-mail addresses." }
+        { { $slot "bcc" } "Blind carbon-copy. A sequence of e-mail addresses." }
+        { { $slot "subject" } " The subject of the e-mail. A string." }
+        { { $slot "body" } " The body of the e-mail. A string." }
+    }
+"The " { $slot "from" } " and " { $slot "to" } " slots are required; the rest are optional."
+$nl
+"An e-mail address is a string in one of the following two formats:"
+{ $list
+    { $snippet "joe@groff.com" }
+    { $snippet "Joe Groff <joe@groff.com>" }
+} } ;
 
 HELP: <email>
 { $values { "email" email } }
@@ -26,9 +55,9 @@ HELP: <email>
 
 HELP: send-email
 { $values { "email" email } }
-{ $description "Sends an " { $link email } " object to an STMP server stored in the " { $link smtp-server } " variable.  The required slots are " { $slot "from" } " and " { $slot "to" } "." }
+{ $description "Sends an e-mail." }
 { $examples
-    { $unchecked-example "USING: accessors smtp ;"
+    { $code "USING: accessors smtp ;"
     "<email>"
     "    \"groucho@marx.bros\" >>from"
     "    { \"chico@marx.bros\" \"harpo@marx.bros\" } >>to"
@@ -42,10 +71,20 @@ HELP: send-email
 } ;
 
 ARTICLE: "smtp" "SMTP client library"
-"Configuring SMTP:"
+"The " { $vocab-link "smtp" } " vocabulary sends e-mail via an SMTP server."
+$nl
+"This library is configured by a set of dynamically-scoped variables:"
 { $subsection smtp-server }
 { $subsection smtp-read-timeout }
 { $subsection smtp-domain }
-{ $subsection esmtp? }
+{ $subsection smtp-auth }
+"The latter is set to an instance of one of the following:"
+{ $subsection no-auth }
+{ $subsection plain-auth }
+"Constructing an e-mail:"
+{ $subsection email }
+{ $subsection <email> }
 "Sending an email:"
 { $subsection send-email } ;
+
+ABOUT: "smtp"

basis/smtp/smtp-tests.factor

@@ -1,8 +1,10 @@
 USING: smtp tools.test io.streams.string io.sockets threads
 smtp.server kernel sequences namespaces logging accessors
-assocs sorting smtp.private ;
+assocs sorting smtp.private concurrency.promises ;
 IN: smtp.tests
 
+\ send-email must-infer
+
 { 0 0 } [ [ ] with-smtp-connection ] must-infer-as
 
 [ "hello\nworld" validate-address ] must-fail
@@ -63,13 +65,13 @@ IN: smtp.tests
     [ from>> extract-email ] tri
 ] unit-test
 
-[ ] [ [ 4321 mock-smtp-server ] "SMTP server" spawn drop ] unit-test
+<promise> "p" set
 
-[ ] [ yield ] unit-test
+[ ] [ "p" get mock-smtp-server ] unit-test
 
 [ ] [
     [
-        "localhost" 4321 <inet> smtp-server set
+        "localhost" "p" get ?promise <inet> smtp-server set
 
         <email>
             "Hi guys\nBye guys" >>body
@@ -82,5 +84,3 @@ IN: smtp.tests
         send-email
     ] with-scope
 ] unit-test
-
-[ ] [ yield ] unit-test

basis/smtp/smtp.factor

@@ -1,16 +1,28 @@
 ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
 ! Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays namespaces make io io.timeouts kernel logging
+USING: arrays namespaces make io io.encodings.string
-io.sockets sequences combinators splitting assocs strings
+io.encodings.utf8 io.timeouts kernel logging io.sockets
-math.parser random system calendar io.encodings.ascii summary
+sequences combinators splitting assocs strings math.parser
-calendar.format accessors sets hashtables ;
+random system calendar io.encodings.ascii summary
+calendar.format accessors sets hashtables base64 ;
 IN: smtp
 
 SYMBOL: smtp-domain
-SYMBOL: smtp-server     "localhost" 25 <inet> smtp-server set-global
+
-SYMBOL: smtp-read-timeout    1 minutes smtp-read-timeout set-global
+SYMBOL: smtp-server
-SYMBOL: esmtp?           t esmtp? set-global
+"localhost" 25 <inet> smtp-server set-global
+
+SYMBOL: smtp-read-timeout
+1 minutes smtp-read-timeout set-global
+
+SINGLETON: no-auth
+
+TUPLE: plain-auth username password ;
+C: <plain-auth> plain-auth
+
+SYMBOL: smtp-auth
+no-auth smtp-auth set-global
 
 LOG: log-smtp-connection NOTICE ( addrspec -- )
 
@@ -34,12 +46,12 @@ TUPLE: email
 : <email> ( -- email ) email new ;
 
 <PRIVATE
+
 : crlf ( -- ) "\r\n" write ;
 
 : command ( string -- ) write crlf flush ;
 
-: helo ( -- )
+: helo ( -- ) "EHLO " host-name append command ;
-    esmtp? get "EHLO " "HELO " ? host-name append command ;
 
 ERROR: bad-email-address email ;
 
@@ -60,8 +72,7 @@ ERROR: bad-email-address email ;
 ERROR: message-contains-dot message ;
 
 M: message-contains-dot summary ( obj -- string )
-    drop
+    drop "Message cannot contain . on a line by itself" ;
-    "Message cannot contain . on a line by itself" ;
 
 : validate-message ( msg -- msg' )
     "." over member?
@@ -115,7 +126,7 @@ ERROR: smtp-transaction-failed < smtp-error ;
     3 swap ?nth CHAR: - = ;
 
 : process-multiline ( multiline -- response )
-    >r readln r> 2dup " " append head? [
+    [ readln ] dip 2dup " " append head? [
         drop dup smtp-response
     ] [
         swap check-response process-multiline
@@ -127,6 +138,16 @@ ERROR: smtp-transaction-failed < smtp-error ;
 
 : get-ok ( -- ) receive-response check-response ;
 
+GENERIC: send-auth ( auth -- )
+
+M: no-auth send-auth drop ;
+
+M: plain-auth send-auth
+    [ username>> ] [ password>> ] bi "\0" swap 3append utf8 encode >base64
+    "AUTH PLAIN " prepend command ;
+
+: auth ( -- ) smtp-auth get send-auth get-ok ;
+
 ERROR: invalid-header-string string ;
 
 : validate-header ( string -- string' )
@@ -170,6 +191,7 @@ ERROR: invalid-header-string string ;
 : (send-email) ( headers email -- )
     [
         helo get-ok
+        auth
         dup from>> extract-email mail-from get-ok
         dup to>> [ extract-email rcpt-to get-ok ] each
         dup cc>> [ extract-email rcpt-to get-ok ] each
@@ -180,6 +202,7 @@ ERROR: invalid-header-string string ;
         body>> send-body get-ok
         quit get-ok
     ] with-smtp-connection ;
+
 PRIVATE>
 
 : send-email ( email -- )