From dce74a69158b5b22188499bdd086f5b902ba0eab Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Nov 2008 10:12:08 -0600 Subject: [PATCH] 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 | 27 ++++++++------- basis/smtp/smtp-docs.factor | 59 +++++++++++++++++++++++++++------ basis/smtp/smtp-tests.factor | 12 +++---- basis/smtp/smtp.factor | 47 +++++++++++++++++++------- 4 files changed, 105 insertions(+), 40 deletions(-) diff --git a/basis/smtp/server/server.factor b/basis/smtp/server/server.factor index a6a8bb2cca..31b67b38a6 100644 --- a/basis/smtp/server/server.factor +++ b/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 -- ) - "Starting SMTP server on port " write dup . flush - "127.0.0.1" swap ascii [ - accept drop [ - 1 minutes timeouts - "220 hello\r\n" write flush - process - global [ flush ] bind - ] with-stream - ] with-disposal ; +:: mock-smtp-server ( promise -- ) + #! Store the port we are running on in the promise. + [ + "127.0.0.1" 0 ascii [ + dup addr>> port>> promise fulfill + accept drop [ + 1 minutes timeouts + "220 hello\r\n" write flush + process + global [ flush ] bind + ] with-stream + ] with-disposal + ] in-thread ; diff --git a/basis/smtp/smtp-docs.factor b/basis/smtp/smtp-docs.factor index c1c2d1c1f8..e8820b1be8 100644 --- a/basis/smtp/smtp-docs.factor +++ b/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? -{ $description "Set true by default, determines whether the SMTP client is using the Extended SMTP protocol." } ; +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." } ; + +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: ( 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 " } +} } ; HELP: { $values { "email" email } } @@ -26,9 +55,9 @@ HELP: 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 ;" "" " \"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 } "Sending an email:" { $subsection send-email } ; + +ABOUT: "smtp" diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor index f8b321fdac..c2c95168f8 100644 --- a/basis/smtp/smtp-tests.factor +++ b/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 + "p" set -[ ] [ yield ] unit-test +[ ] [ "p" get mock-smtp-server ] unit-test [ ] [ [ - "localhost" 4321 smtp-server set + "localhost" "p" get ?promise smtp-server set "Hi guys\nBye guys" >>body @@ -82,5 +84,3 @@ IN: smtp.tests send-email ] with-scope ] unit-test - -[ ] [ yield ] unit-test diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 9dc03dfac2..c033ff2b2e 100644 --- a/basis/smtp/smtp.factor +++ b/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 -io.sockets sequences combinators splitting assocs strings -math.parser random system calendar io.encodings.ascii summary -calendar.format accessors sets hashtables ; +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 ; IN: smtp SYMBOL: smtp-domain -SYMBOL: smtp-server "localhost" 25 smtp-server set-global -SYMBOL: smtp-read-timeout 1 minutes smtp-read-timeout set-global -SYMBOL: esmtp? t esmtp? set-global + +SYMBOL: smtp-server +"localhost" 25 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 + +SYMBOL: smtp-auth +no-auth smtp-auth set-global LOG: log-smtp-connection NOTICE ( addrspec -- ) @@ -34,12 +46,12 @@ TUPLE: email : ( -- email ) email new ; 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 -- )