diff --git a/basis/smtp/server/server.factor b/basis/smtp/server/server.factor index 31b67b38a6..7de22e9af9 100644 --- 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 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 + [ + "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 + ] with-test-context ] in-thread ; diff --git a/basis/smtp/smtp-docs.factor b/basis/smtp/smtp-docs.factor index e8820b1be8..83b9287043 100644 --- 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 c2c95168f8..7bc7630a40 100644 --- 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" } check-response ] +[ smtp-error? ] must-fail-with -[ ] [ "220 success" check-response ] unit-test +[ ] [ { "220 success" } 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 smtp-server set + no-auth smtp-auth set + smtp-tls? on "Hi guys\nBye guys" >>body diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index c033ff2b2e..7f14945633 100644 --- 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 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 new ; +: ( -- email ) email new ; inline ( lines -- response ) + [ first 3 head string>number ] keep response boa ; + +: receive-response ( -- response ) + [ (receive-response) ] { } make ; + +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 ; -M: plain-auth send-auth - [ username>> ] [ password>> ] bi "\0" swap 3append utf8 encode >base64 - "AUTH PLAIN " prepend command ; +: plain-auth-string ( username password -- string ) + [ "\0" prepend ] bi@ append utf8 encode >base64 ; -: auth ( -- ) smtp-auth get send-auth get-ok ; +M: plain-auth send-auth + [ username>> ] [ password>> ] bi plain-auth-string + "AUTH PLAIN " prepend command 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