From 047a6c27a1f825a5a882f0305a07d728ecf161bb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 01:55:38 -0600 Subject: [PATCH] smtp now uses new-slots --- extra/smtp/smtp-tests.factor | 72 +++++++++++----------------- extra/smtp/smtp.factor | 92 +++++++++++++++++------------------- 2 files changed, 70 insertions(+), 94 deletions(-) diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 32b2f3be14..76ceaceea4 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,5 +1,6 @@ USING: smtp tools.test io.streams.string threads -smtp.server kernel sequences namespaces logging ; +smtp.server kernel sequences namespaces logging accessors +assocs sorting ; IN: smtp.tests { 0 0 } [ [ ] with-smtp-connection ] must-infer-as @@ -12,7 +13,7 @@ IN: smtp.tests [ { "hello" "." "world" } validate-message ] must-fail [ "hello\r\nworld\r\n.\r\n" ] [ - { "hello" "world" } [ send-body ] with-string-writer + "hello\nworld" [ send-body ] with-string-writer ] unit-test [ "500 syntax error" check-response ] must-fail @@ -38,46 +39,27 @@ IN: smtp.tests ] must-fail [ - V{ - { "To" "Slava , Ed " } + { { "From" "Doug " } { "Subject" "Factor rules" } + { "To" "Slava , Ed " } } { "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> + + "Factor rules" >>subject + { + "Slava " + "Ed " + } >>to + "Doug " >>from + prepare + dup headers>> >alist sort-keys [ + drop { "Date" "Message-Id" } member? not + ] assoc-subset + over to>> + rot from>> ] unit-test [ ] [ [ 4321 smtp-server ] in-thread ] unit-test @@ -87,14 +69,14 @@ IN: smtp.tests "localhost" smtp-host set 4321 smtp-port set - "Hi guys\nBye guys" - "Factor rules" - { - "Slava " - "Ed " - } - "Doug " - - send-simple-message + + "Hi guys\nBye guys" >>body + "Factor rules" >>subject + { + "Slava " + "Ed " + } >>to + "Doug " >>from + send ] with-scope ] unit-test diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index bbec129ef6..b23d5e3798 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -3,8 +3,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces io io.timeouts kernel logging io.sockets sequences combinators sequences.lib splitting assocs strings -math.parser random system calendar io.encodings.ascii calendar.format ; - +math.parser random system calendar io.encodings.ascii +calendar.format new-slots accessors ; IN: smtp SYMBOL: smtp-domain @@ -49,6 +49,7 @@ SYMBOL: esmtp t esmtp set-global "." over member? [ "Message cannot contain . on a line by itself" throw ] when ; : send-body ( body -- ) + string-lines validate-message [ write crlf ] each "." write crlf ; @@ -89,28 +90,36 @@ LOG: smtp-response DEBUG : get-ok ( -- ) flush receive-response check-response ; -: 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 ; - : validate-header ( string -- string' ) dup [ "\r\n" member? ] contains? [ "Invalid header string: " swap append throw ] when ; -: prepare-header ( key value -- ) +: write-header ( key value -- ) swap - validate-header % - ": " % - validate-header % ; + validate-header write + ": " write + validate-header write + crlf ; -: prepare-headers ( assoc -- ) - [ [ prepare-header ] "" make , ] assoc-each ; +: write-headers ( assoc -- ) + [ write-header ] assoc-each ; + +TUPLE: email from to subject headers body ; + +M: email clone + (clone) [ clone ] change-headers ; + +: (send) ( email -- ) + [ + helo get-ok + dup from>> mail-from get-ok + dup to>> [ rcpt-to get-ok ] each + data get-ok + dup headers>> write-headers + crlf + body>> send-body get-ok + quit get-ok + ] with-smtp-connection ; : extract-email ( recepient -- email ) #! This could be much smarter. @@ -127,30 +136,25 @@ LOG: smtp-response DEBUG ">" % ] "" make ; -: 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 ; +: set-header ( email value key -- email ) + pick headers>> set-at ; -: prepare-message ( body headers -- body' ) - [ - prepare-headers - "" , - dup string? [ string-lines ] when % - ] { } make ; +: prepare ( email -- email ) + clone + dup from>> "From" set-header + [ extract-email ] change-from + dup to>> ", " join "To" set-header + [ [ extract-email ] map ] change-to + dup subject>> "Subject" set-header + now timestamp>rfc822-string "Date" set-header + message-id "Message-Id" set-header ; -: prepare-simple-message ( body subject to from -- body' to from ) - simple-headers >r >r prepare-message r> r> ; +: ( -- email ) + email construct-empty + H{ } clone >>headers ; -: 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 ; +: send ( email -- ) + prepare (send) ; ! 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 @@ -171,13 +175,3 @@ LOG: smtp-response DEBUG ! (cram-md5-auth) "\r\n" append get-ok ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USE: new-slots - -TUPLE: email from to subject body ; - -: ( -- email ) email construct-empty ; - -: send ( email -- ) - { email-body email-subject email-to email-from } get-slots - send-simple-message ;