! 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 io.encodings.string
-io.encodings.utf8 io.encodings.iana io.encodings.binary
-io.encodings.ascii io.timeouts io.sockets io.sockets.secure io.crlf
-kernel logging sequences combinators splitting assocs strings
-math.order math.parser random system calendar summary calendar.format
-accessors sets hashtables base64 debugger classes prettyprint 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
+
+: <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 ;
: 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 >string ;
+ [ "\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>> [
"<" %
64 random-bits #
"-" %
- gmt timestamp>micros #
+ now timestamp>micros #
"@" %
- smtp-domain get [ host-name ] unless* %
+ smtp-config get domain>> [ host-name ] unless* %
">" %
] "" make ;
[
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