-! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
+! 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.string io.encodings.utf8
-io.encodings.iana 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 io.crlf words ;
+! See https://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs base64 calendar calendar.format
+classes combinators debugger 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
+TUPLE: login-auth username password ;
+C: <login-auth> login-auth
-LOG: log-smtp-connection NOTICE ( addrspec -- )
+: <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 }
ERROR: bad-email-address email ;
: validate-address ( string -- string' )
- #! Make sure we send funky stuff to the server by accident.
+ ! Make sure we send funky stuff to the server by accident.
dup "\r\n>" intersects?
[ bad-email-address ] when ;
: data ( -- )
"DATA" command ;
-ERROR: message-contains-dot message ;
-
-M: message-contains-dot summary ( obj -- string )
- drop "Message cannot contain . on a line by itself" ;
-
-: validate-message ( msg -- msg' )
- "." over member?
- [ message-contains-dot ] when ;
-
: send-body ( email -- )
- [ body>> ] [ encoding>> ] bi encode
- >base64-lines write crlf
+ binary encode-output
+ [ body>> ] [ encoding>> ] bi encode >base64-lines write
+ ascii encode-output crlf
"." command ;
: quit ( -- )
ERROR: smtp-error response ;
M: smtp-error error.
- "SMTP error (" write dup class pprint ")" print
+ "SMTP error (" write dup class-of pprint ")" print
response>> messages>> [ print ] each ;
ERROR: smtp-server-busy < smtp-error ;
: check-response ( response -- )
dup code>> {
- { [ dup { 220 235 250 221 354 } member? ] [ 2drop ] }
+ { [ dup { 220 235 250 221 334 354 } member? ] [ 2drop ] }
{ [ dup 400 499 between? ] [ drop smtp-server-busy ] }
{ [ dup 500 = ] [ drop smtp-syntax-error ] }
{ [ dup 501 = ] [ drop smtp-command-not-implemented ] }
M: no-auth send-auth drop ;
+: >smtp-base64 ( str -- str' )
+ utf8 encode >base64 >string ;
+
: plain-auth-string ( username password -- string )
- [ "\0" prepend ] bi@ append utf8 encode >base64 ;
+ [ "\0" prepend ] bi@ append >smtp-base64 ;
M: plain-auth send-auth
[ username>> ] [ password>> ] bi plain-auth-string
"AUTH PLAIN " prepend command get-ok ;
-: auth ( -- ) smtp-auth get send-auth ;
+M: login-auth send-auth
+ "AUTH LOGIN" command get-ok
+ [ username>> >smtp-base64 command get-ok ]
+ [ password>> >smtp-base64 command get-ok ] bi ;
+
+: auth ( -- ) smtp-config get auth>> send-auth ;
: encode-header ( string -- string' )
dup aux>> [
- "=?utf-8?B?"
- swap utf8 encode >base64
- "?=" 3append
+ utf8 encode >base64
+ "=?utf-8?B?" "?=" surround
] when ;
ERROR: invalid-header-string string ;
"<" %
64 random-bits #
"-" %
- micros #
+ now timestamp>micros #
"@" %
- smtp-domain get [ host-name ] unless* %
+ smtp-config get domain>> [ host-name ] unless* %
">" %
] "" make ;
: email>headers ( email -- assoc )
[
- now timestamp>rfc822 "Date" set
- message-id "Message-Id" set
- "1.0" "MIME-Version" set
- "base64" "Content-Transfer-Encoding" set
+ now timestamp>rfc822 "Date" ,,
+ message-id "Message-Id" ,,
+ "1.0" "MIME-Version" ,,
+ "base64" "Content-Transfer-Encoding" ,,
{
- [ from>> "From" set ]
- [ to>> ", " join "To" set ]
- [ cc>> ", " join [ "Cc" set ] unless-empty ]
- [ subject>> "Subject" set ]
- [ email-content-type "Content-Type" set ]
+ [ from>> "From" ,, ]
+ [ to>> ", " join "To" ,, ]
+ [ cc>> ", " join [ "Cc" ,, ] unless-empty ]
+ [ subject>> "Subject" ,, ]
+ [ email-content-type "Content-Type" ,, ]
} cleave
- ] { } make-assoc ;
+ ] H{ } make ;
: (send-email) ( headers email -- )
[
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
+ helo get-ok
+ ] when
auth
dup from>> extract-email mail-from get-ok
dup to>> [ extract-email rcpt-to get-ok ] each
projects / factor.git / blobdiff