smtp: Use a config object. Fix docs. Fix unit tests.

diff --git a/basis/smtp/smtp-docs.factor b/basis/smtp/smtp-docs.factor
index b00ee6a856e29c188377951d794f437269b4c37e..62c0f770c9f33ce0875deea22f540c7791fa4a0b 100644 (file)
--- a/basis/smtp/smtp-docs.factor
+++ b/basis/smtp/smtp-docs.factor
@@ -4,34 +4,41 @@ USING: accessors kernel quotations help.syntax help.markup
 io.sockets strings calendar io.encodings.utf8 ;
 IN: smtp
 
-HELP: smtp-domain
-{ $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
-{ $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-config
+{ $class-description "An SMTP configuration object, with the following slots:"
+    { $table
+        { { $slot "domain" } { "Name of the machine sending the email, or " { $link host-name } " if empty." } }
+        { { $slot "server" } { "An " { $link <inet> } " of the SMTP server." } }
+        { { $slot "tls?" } { "Secure socket after connecting to server, server must support " { $snippet "STARTTLS" } } }
+        { { $slot "read-timeout" } { "Length of time after which we give up waiting for a response." } }
+        { { $slot "auth" } { "Either " { $link no-auth } " or an instance of " { $link plain-auth } } }
+    }
+} ;
 
-HELP: smtp-read-timeout
-{ $var-description "Holds a " { $link duration } " object that specifies how long to wait for a response from the SMTP server." } ;
+HELP: default-smtp-config
+{ $values { "smtp-config" smtp-config } }
+{ $description "Creates a new " { $link smtp-config } " with defaults of a one minute " { $snippet "read-timeout" } ", " { $link no-auth } " for authentication, and " { $snippet "localhost" } " port " { $snippet "25" } " as the server." } ;
 
-HELP: smtp-auth
-{ $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." } ;
+{ smtp-config default-smtp-config } related-words
 
 HELP: no-auth
-{ $class-description "If the " { $link smtp-auth } " variable is set to this value, no authentication will be performed." } ;
+{ $class-description "If the " { $snippet "auth" } " slot 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." } ;
+{ $class-description "If the " { $snippet "auth" } " slot 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>
 { $values { "username" string } { "password" string } { "plain-auth" plain-auth } }
 { $description "Creates a new " { $link plain-auth } " instance." } ;
 
+HELP: with-smtp-config
+{ $values { "quot" quotation } }
+{ $description "Connects to an SMTP server using credentials and settings stored in " { $link smtp-config } " and calls the " { $link with-smtp-connection } " combinator." }
+{ $notes "This word is used to implement " { $link send-email } " and there is probably no reason to call it directly." } ;
+
 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 using credentials and settings stored in " { $link smtp-config } " 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
@@ -76,31 +83,29 @@ HELP: send-email
 } ;
 
 ARTICLE: "smtp-gmail" "Setting up SMTP with gmail"
-"If you plan to send all email from the same address, then setting variables in the global namespace is the best option. The code example below does this approach and is meant to go in your " { $link ".factor-boot-rc" } "." $nl
-"Several variables need to be set for sending outgoing mail through gmail. First, we set the login and password to a " { $link <plain-auth> } " tuple with our login. Next, we set the gmail server address with an " { $link <inet> } " object. Finally, we tell the SMTP library to use a secure connection."
+"If you plan to send all email from the same address, then setting the config variable in the global namespace is the best option. The code example below does this approach and is meant to go in your " { $link ".factor-boot-rc" } "." $nl
+"First, we set the login and password to a " { $link <plain-auth> } " tuple with our login. Next, we set the gmail server address with an " { $link <inet> } " object. Finally, we tell the SMTP library to use a secure connection."
+{ $notes "Gmail requires the use of application-specific passwords when accessed from anywhere but their website. Visit " { $url "https://support.google.com/accounts/answer/185833?hl=en" } " to create a password for use with Factor." }
 { $code
     "USING: smtp namespaces io.sockets ;"
     ""
-    "\"my.gmail.address@gmail.com\" \"secret-password\" <plain-auth> smtp-auth set-global"
-    ""
-    "\"smtp.gmail.com\" 587 <inet> smtp-server set-global"
-    ""
-    "t smtp-tls? set-global"
+    """default-smtp-config
+    "smtp.gmail.com" 587 <inet> >>server
+    t >>tls?
+    "my.gmail.address@gmail.com" "qwertyuiasdfghjk" <plain-auth> >>auth
+    \\ smtp-config set-global"""
 } ;
 
 
 ARTICLE: "smtp" "SMTP client library"
 "The " { $vocab-link "smtp" } " vocabulary sends e-mail via an SMTP server."
 $nl
-"This library is configured by a set of dynamically-scoped variables:"
+"This library is configured by a globally scoped config tuple:"
 { $subsections
-    smtp-server
-    smtp-tls?
-    smtp-read-timeout
-    smtp-domain
-    smtp-auth
+    smtp-config
+    default-smtp-config
 }
-"The latter is set to an instance of one of the following:"
+"The auth slot is set to an instance of one of the following:"
 { $subsections
     no-auth
     plain-auth

diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor
index ca0629a1fd09d443229b1ba2ee834fe0a25fca86..f4cb3e572af1e66686fdd6fa55f2209231940c2e 100644 (file)
--- a/basis/smtp/smtp-tests.factor
+++ b/basis/smtp/smtp-tests.factor
@@ -4,6 +4,18 @@ namespaces logging accessors assocs sorting smtp.private
 concurrency.promises system ;
 IN: smtp.tests
 
+: with-test-smtp-config ( quot -- )
+    [
+        <promise> "p" set
+        "p" get mock-smtp-server
+
+        default-smtp-config
+            "localhost" "p" get ?promise <inet> >>server
+            no-auth >>auth
+            os unix? [ t >>tls? ] when
+        \ smtp-config
+    ] dip with-variable ; inline
+
 { 0 0 } [ [ ] with-smtp-connection ] must-infer-as
 
 [ "hello\nworld" validate-address ] must-fail
@@ -56,40 +68,36 @@ IN: smtp.tests
     { "slava@factorcode.org" "dharmatech@factorcode.org" }
     "erg@factorcode.org"
 ] [
-    <email>
-        "Factor rules" >>subject
-        {
-            "Slava <slava@factorcode.org>"
-            "Ed <dharmatech@factorcode.org>"
-        } >>to
-        "Doug <erg@factorcode.org>" >>from
     [
-        email>headers sort-keys [
-            drop { "Date" "Message-Id" } member? not
-        ] assoc-filter
-    ]
-    [ to>> [ extract-email ] map ]
-    [ from>> extract-email ] tri
-] unit-test
-
-<promise> "p" set
-
-[ ] [ "p" get mock-smtp-server ] unit-test
-
-[ ] [
-    <secure-config> f >>verify [
-        "localhost" "p" get ?promise <inet> smtp-server set
-        no-auth smtp-auth set
-        os unix? [ smtp-tls? on ] when
-
         <email>
-            "Hi guys\nBye guys" >>body
             "Factor rules" >>subject
             {
                 "Slava <slava@factorcode.org>"
                 "Ed <dharmatech@factorcode.org>"
             } >>to
             "Doug <erg@factorcode.org>" >>from
-        send-email
+        [
+            email>headers sort-keys [
+                drop { "Date" "Message-Id" } member? not
+            ] assoc-filter
+        ]
+        [ to>> [ extract-email ] map ]
+        [ from>> extract-email ] tri
+    ] with-test-smtp-config
+] unit-test
+
+[ ] [
+    <secure-config> f >>verify [
+        [
+            <email>
+                "Hi guys\nBye guys" >>body
+                "Factor rules" >>subject
+                {
+                    "Slava <slava@factorcode.org>"
+                    "Ed <dharmatech@factorcode.org>"
+                } >>to
+                "Doug <erg@factorcode.org>" >>from
+            send-email
+        ] with-test-smtp-config
     ] with-secure-context
 ] unit-test

diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor
index 78c0fad40f06e442fa088390f95ebefbe544e44b..48ea2c181443c315d3bf9dfe82794f1581a7bef6 100644 (file)
--- a/basis/smtp/smtp.factor
+++ b/basis/smtp/smtp.factor
@@ -1,43 +1,47 @@
 ! Copyright (C) 2007, 2009 Elie CHAFTARI, Dirk Vleugels,
 ! Slava Pestov, Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays namespaces make io io.encodings io.encodings.string
-io.encodings.utf8 io.encodings.iana io.encodings.binary
-io.encodings.ascii io.timeouts io.sockets io.sockets.secure io.crlf
-kernel logging sequences combinators splitting assocs strings
-math.order math.parser random system calendar summary calendar.format
-accessors sets hashtables base64 debugger classes prettyprint words ;
+USING: accessors arrays assocs base64 calendar calendar.format
+classes combinators debugger fry io io.crlf io.encodings
+io.encodings.ascii io.encodings.binary io.encodings.iana
+io.encodings.string io.encodings.utf8 io.sockets
+io.sockets.secure io.timeouts kernel logging make math.order
+math.parser namespaces prettyprint random sequences sets
+splitting strings words ;
 IN: smtp
 
-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
+TUPLE: smtp-config domain server tls? { read-timeout duration } auth ;
 
 SINGLETON: no-auth
 
 TUPLE: plain-auth username password ;
 C: <plain-auth> plain-auth
 
-SYMBOL: smtp-auth
-no-auth smtp-auth set-global
+: <smtp-config> ( -- smtp-config )
+    smtp-config new ; inline
+
+: default-smtp-config ( -- smtp-config )
+    <smtp-config>
+        "localhost" 25 <inet> >>server
+        1 minutes >>read-timeout
+        no-auth >>auth ; inline
 
 LOG: log-smtp-connection NOTICE
 
 : with-smtp-connection ( quot -- )
-    smtp-server get
+    smtp-config get server>>
     dup log-smtp-connection
     ascii [
-        smtp-domain [ host-name or ] change
-        smtp-read-timeout get timeouts
+        smtp-config get
+        [ [ host-name or ] change-domain drop ]
+        [ read-timeout>> timeouts ] bi
         call
     ] with-client ; inline
 
+: with-smtp-config ( quot -- )
+    [ \ smtp-config get-global clone \ smtp-config ] dip
+    '[ _ with-smtp-connection ] with-variable ; inline
+
 TUPLE: email
     { from string }
     { to array }
@@ -152,7 +156,7 @@ M: plain-auth send-auth
     [ username>> ] [ password>> ] bi plain-auth-string
     "AUTH PLAIN " prepend command get-ok ;
 
-: auth ( -- ) smtp-auth get send-auth ;
+: auth ( -- ) smtp-config get auth>> send-auth ;
 
 : encode-header ( string -- string' )
     dup aux>> [
@@ -180,7 +184,7 @@ ERROR: invalid-header-string string ;
         "-" %
         gmt timestamp>micros #
         "@" %
-        smtp-domain get [ host-name ] unless* %
+        smtp-config get domain>> [ host-name ] unless* %
         ">" %
     ] "" make ;
 
@@ -210,7 +214,7 @@ ERROR: invalid-header-string string ;
     [
         get-ok
         helo get-ok
-        smtp-tls? get [ start-tls get-ok send-secure-handshake ] when
+        smtp-config get tls?>> [ 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