From a06c536123a2b8a1c7785caa591a9bdf1e742cbc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:03:27 -0600 Subject: [PATCH] Cleaned up SMTP implementation and added some features --- extra/smtp/authors.txt | 2 + extra/smtp/server/server.factor | 72 ++++++++++ extra/smtp/smtp-tests.factor | 130 ++++++++++++++---- extra/smtp/smtp.factor | 237 ++++++++++++++++++-------------- 4 files changed, 310 insertions(+), 131 deletions(-) create mode 100644 extra/smtp/server/server.factor diff --git a/extra/smtp/authors.txt b/extra/smtp/authors.txt index 7c29e7c401..159b1e91e9 100644 --- a/extra/smtp/authors.txt +++ b/extra/smtp/authors.txt @@ -1 +1,3 @@ Elie Chaftari +Dirk Vleugels +Slava Pestov diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor new file mode 100644 index 0000000000..2cfc1e65e4 --- /dev/null +++ b/extra/smtp/server/server.factor @@ -0,0 +1,72 @@ +! Copyright (C) 2007 Elie CHAFTARI +! See http://factorcode.org/license.txt for BSD license. + +! Mock SMTP server for testing purposes. + +! Usage: 4321 smtp-server +! $ telnet 127.0.0.1 4321 +! Trying 127.0.0.1... +! Connected to localhost. +! Escape character is '^]'. +! 220 hello +! EHLO +! 220 and..? +! MAIL FROM: +! 220 OK +! RCPT TO: +! 220 OK +! Hi +! 500 ERROR +! DATA +! 354 Enter message, ending with "." on a line by itself +! Hello I am still waiting for your call +! Thanks +! . +! 220 OK +! QUIT +! bye +! Connection closed by foreign host. + +USING: combinators kernel prettyprint io io.server sequences +namespaces io.sockets continuations ; + +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 + ] } + { [ data-mode get ] [ t ] } + { [ t ] [ + "500 ERROR\r\n" write flush t + ] } + } cond nip [ process ] when ; + +: smtp-server ( port -- ) + "Starting SMTP server on port " write dup . flush + "127.0.0.1" swap [ + accept [ + 60000 stdio get set-timeout + "220 hello\r\n" write flush + process + ] with-stream + ] with-disposal ; diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 8ab1fd0899..9a357fdc7d 100644 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,41 +1,111 @@ -! Tested with Apache JAMES version 2.3.1 on localhost -! cram-md5 authentication tested against Exim 4 -! Replace "localhost" with your smtp server -! e.g. "your.smtp.server" initialize +USING: smtp tools.test io.streams.string io.logging threads +smtp.server kernel sequences namespaces ; +IN: temporary -USING: smtp tools.test ; +{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as -"localhost" initialize ! replace localhost with your smtp server +[ "hello\nworld" validate-address ] must-fail -! 8889 set-port ! default port = 25, change for testing purposes +[ "slava@factorcode.org" ] +[ "slava@factorcode.org" validate-address ] unit-test -! 30000 set-read-timeout ! default = 60000 -! f set-esmtp ! when esmtp (extended smtp) is not supported +[ { "hello" "." "world" } validate-message ] must-fail -start +[ "hello\r\nworld\r\n.\r\n" ] [ + { "hello" "world" } [ send-body ] string-out +] unit-test -! "md5 password here" "login" cram-md5-auth +[ + [ + "500 syntax error" check-response + ] with-log-stdio +] must-fail -"root@localhost" mailfrom ! your@mail.address +[ ] [ + [ + "220 success" check-response + ] with-log-stdio +] unit-test -"root@localhost" rcptto ! someone@example.com +[ "220 success" ] [ + "220 success" [ receive-response ] string-in +] unit-test -! { "From: Your Name " -! "To: Destination Address " -! "Subject: test message" -! "Date: Thu, 17 May 2007 18:46:45 +0200" -! "Message-Id: " -! " " -! "This is a test message." -! } send-message +[ "220 the end" ] [ + [ + "220-a multiline response\r\n250-another line\r\n220 the end" + [ receive-response ] string-in + ] with-log-stdio +] unit-test -{ "From: Your Name " - "To: Destination Address " - "Subject: test message" - "Date: Thu, 17 May 2007 18:46:45 +0200" - "Message-Id: " - " " - "This is a test message." -} send-message +[ ] [ + [ + "220-a multiline response\r\n250-another line\r\n220 the end" + [ get-ok ] string-in + ] with-log-stdio +] unit-test -quit \ No newline at end of file +[ + "Subject:\r\nsecurity hole" validate-header +] must-fail + +[ + V{ + { "To" "Slava , Ed " } + { "From" "Doug " } + { "Subject" "Factor rules" } + } + { "slava@factorcode.org" "dharmatech@factorcode.org" } + "erg@factorcode.org" +] [ + "Factor rules" + { + "Slava " + "Ed " + } + "Doug " + simple-headers >r >r 2 head* r> r> +] unit-test + +[ + { + "To: Slava , Ed " + "From: Doug " + "Subject: Factor rules" + f + f + " " + "Hi guys" + "Bye guys" + } + { "slava@factorcode.org" "dharmatech@factorcode.org" } + "erg@factorcode.org" +] [ + "Hi guys\nBye guys" + "Factor rules" + { + "Slava " + "Ed " + } + "Doug " + prepare-simple-message + >r >r f 3 pick set-nth f 4 pick set-nth r> r> +] unit-test + +[ ] [ [ 4321 smtp-server ] in-thread ] unit-test + +[ ] [ + [ + 4321 smtp-port set + + "Hi guys\nBye guys" + "Factor rules" + { + "Slava " + "Ed " + } + "Doug " + + send-simple-message + ] with-scope +] unit-test \ No newline at end of file diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 9116d094de..77bfb6cd82 100644 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -1,138 +1,173 @@ -! Copyright (C) 2007 Elie CHAFTARI +! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -! -! cram-md5 auth code contributed by Dirk Vleugels - -USING: alien alien.c-types combinators crypto.common crypto.hmac base64 -kernel io io.sockets namespaces sequences splitting ; +USING: namespaces io kernel io.logging io.sockets sequences +combinators sequences.lib splitting assocs strings math.parser +random system calendar ; IN: smtp -! ========================================================= -! smtp.factor implementation -! ========================================================= +SYMBOL: smtp-domain +SYMBOL: smtp-host "localhost" smtp-host set-global +SYMBOL: smtp-port 25 smtp-port set-global +SYMBOL: read-timeout 60000 read-timeout set-global +SYMBOL: esmtp t esmtp set-global -! Connection default values -: default-port 25 ; inline -: read-timeout 60000 ; inline -: esmtp t ; inline ! t = ehlo -: domain "localhost.localdomain" ; inline +: log-smtp-connection ( host port -- ) + [ + "Establishing SMTP connection to " % swap % ":" % # + ] "" make log-message ; -SYMBOL: sess -SYMBOL: conn -SYMBOL: challenge +: with-smtp-connection ( quot -- ) + [ + smtp-host get smtp-port get + 2dup log-smtp-connection + [ + smtp-domain [ host-name or ] change + read-timeout get stdio get set-timeout + call + ] with-stream + ] with-log-stdio ; inline -TUPLE: session address port timeout domain esmtp ; +: crlf "\r\n" write ; -: ( address -- session ) - default-port read-timeout domain esmtp - session construct-boa ; +: helo ( -- ) + esmtp get "EHLO " "HELO " ? write host-name write crlf ; -! ========================================================= -! Initialization routines -! ========================================================= +: validate-address ( string -- string' ) + #! Make sure we send funky stuff to the server by accident. + dup [ "\r\n>" member? ] contains? + [ "Bad e-mail address: " swap append throw ] when ; -: initialize ( address -- ) - sess set ; +: mail-from ( fromaddr -- ) + "MAIL FROM:<" write validate-address write ">" write crlf ; -: set-port ( port -- ) - sess get set-session-port ; +: rcpt-to ( to -- ) + "RCPT TO:<" write validate-address write ">" write crlf ; -: set-read-timeout ( timeout -- ) - sess get set-session-timeout ; +: data ( -- ) + "DATA" write crlf ; -: set-esmtp ( esmtp -- ) - sess get set-session-esmtp ; +: validate-message ( msg -- msg' ) + "." over member? [ "Message cannot contain . on a line by itself" throw ] when ; -: set-domain ( -- ) - host-name sess get set-session-domain ; +: send-body ( body -- ) + validate-message + [ write crlf ] each + "." write crlf ; -: do-start ( -- ) - sess get [ session-address ] keep session-port - dup conn set [ sess get session-timeout swap set-timeout ] - keep stream-readln print ; +: quit ( -- ) + "QUIT" write crlf ; -! ========================================================= -! Command routines -! ========================================================= +: log-response ( string -- ) "SMTP: " swap append log-message ; : check-response ( response -- ) { - { [ dup "220" head? ] [ print ] } - { [ dup "235" swap subseq? ] [ print ] } - { [ dup "250" head? ] [ print ] } - { [ dup "221" head? ] [ print ] } - { [ dup "bye" head? ] [ print ] } + { [ dup "220" head? ] [ log-response ] } + { [ dup "235" swap subseq? ] [ log-response ] } + { [ dup "250" head? ] [ log-response ] } + { [ dup "221" head? ] [ log-response ] } + { [ dup "bye" head? ] [ log-response ] } { [ dup "4" head? ] [ "server busy" throw ] } - { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] } - { [ dup "354" head? ] [ print ] } - { [ dup "50" head? ] [ print "syntax error" throw ] } - { [ dup "53" head? ] [ print "invalid authentication data" throw ] } - { [ dup "55" head? ] [ print "fatal error" throw ] } - { [ t ] [ "unknow error" throw ] } + { [ dup "354" head? ] [ log-response ] } + { [ dup "50" head? ] [ log-response "syntax error" throw ] } + { [ dup "53" head? ] [ log-response "invalid authentication data" throw ] } + { [ dup "55" head? ] [ log-response "fatal error" throw ] } + { [ t ] [ "unknown error" throw ] } } cond ; -SYMBOL: multiline - : multiline? ( response -- boolean ) - CHAR: - swap index 3 = ; + ?fourth CHAR: - = ; -: process-multiline ( -- response ) - conn get stream-readln dup - multiline get " " append head? [ - print +: process-multiline ( multiline -- response ) + >r readln r> 2dup " " append head? [ + drop dup log-response ] [ - check-response process-multiline + swap check-response process-multiline ] if ; -: recv-response ( -- response ) - conn get stream-readln - dup multiline? [ - dup 3 head multiline set process-multiline - ] [ ] if ; +: receive-response ( -- response ) + readln + dup multiline? [ 3 head process-multiline ] when ; -: get-ok ( command -- ) - >r conn get r> over stream-write stream-flush - recv-response check-response ; +: get-ok ( -- ) flush receive-response check-response ; -: helo ( -- ) - "HELO " sess get session-domain append "\r\n" append get-ok ; +: send-raw-message ( body to from -- ) + [ + helo get-ok + mail-from get-ok + [ rcpt-to get-ok ] each + data get-ok + send-body get-ok + quit get-ok + ] with-smtp-connection ; -: ehlo ( -- ) - "EHLO " sess get session-domain append "\r\n" append get-ok ; +: validate-header ( string -- string' ) + dup [ "\r\n" member? ] contains? + [ "Invalid header string: " swap append throw ] when ; -: mailfrom ( fromaddr -- ) - "MAIL FROM:<" swap append ">\r\n" append get-ok ; +: prepare-header ( key value -- ) + swap + validate-header % + ": " % + validate-header % ; -: rcptto ( to -- ) - "RCPT TO:<" swap append ">\r\n" append get-ok ; +: prepare-headers ( assoc -- ) + [ [ prepare-header ] "" make , ] assoc-each ; -: (cram-md5-auth) ( -- response ) - swap challenge get - string>md5-hmac hex-string - " " swap append append - >base64 ; +: extract-email ( recepient -- email ) + #! This could be much smarter. + " " last-split1 [ ] [ ] ?if "<" ?head drop ">" ?tail drop ; -: cram-md5-auth ( key login -- ) - "AUTH CRAM-MD5\r\n" get-ok - (cram-md5-auth) "\r\n" append get-ok ; - -: data ( -- ) - "DATA\r\n" get-ok ; +: message-id ( -- string ) + [ + "<" % + 2 big-random # + "-" % + millis # + "@" % + smtp-domain get % + ">" % + ] "" make ; -: start ( -- ) - set-domain ! replaces localhost.localdomain with hostname - do-start - sess get session-esmtp [ - ehlo - ] [ - helo - ] if ; +: simple-headers ( subject to from -- headers to from ) + [ + >r dup ", " join "To" set [ extract-email ] map r> + dup "From" set extract-email + rot "Subject" set + now timestamp>rfc822-string "Date" set + message-id "Message-Id" set + ] { } make-assoc -rot ; -: send-message ( msg -- ) - data - "\r\n" join conn get swap "\r\n" append over stream-write - stream-flush ".\r\n" get-ok ; +: prepare-message ( body headers -- body' ) + [ + prepare-headers + " " , + dup string? [ string-lines ] when % + ] { } make ; -: quit ( -- ) - "QUIT\r\n" get-ok ; +: prepare-simple-message ( body subject to from -- body' to from ) + simple-headers >r >r prepare-message r> r> ; + +: send-message ( body headers to from -- ) + >r >r prepare-message r> r> send-raw-message ; + +: send-simple-message ( body subject to from -- ) + prepare-simple-message send-raw-message ; + +! Dirk's old AUTH CRAM-MD5 code. I don't know anything about +! CRAM MD5, and the old code didn't work properly either, so here +! it is in case anyone wants to fix it later. +! +! check-response used to have this clause: +! { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] } +! +! and the rest of the code was as follows: +! : (cram-md5-auth) ( -- response ) +! swap challenge get +! string>md5-hmac hex-string +! " " swap append append +! >base64 ; +! +! : cram-md5-auth ( key login -- ) +! "AUTH CRAM-MD5\r\n" get-ok +! (cram-md5-auth) "\r\n" append get-ok ;