-! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
-! 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 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 ;
+! Copyright (C) 2007, 2009 Elie CHAFTARI, Dirk Vleugels,
+! Slava Pestov, Doug Coleman, Daniel Ehrenberg.
+! 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
-LOG: log-smtp-connection NOTICE ( addrspec -- )
+: 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 }
{ cc array }
{ bcc array }
{ subject string }
+ { content-type string initial: "text/plain" }
+ { encoding word initial: utf8 }
{ body string } ;
: <email> ( -- email ) email new ; inline
<PRIVATE
-: crlf ( -- ) "\r\n" write ;
-
-: read-crlf ( -- bytes )
- "\r" read-until
- [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
-
: command ( string -- ) write crlf flush ;
\ command DEBUG add-input-logging
ERROR: bad-email-address email ;
: validate-address ( string -- string' )
- #! Make sure we send funky stuff to the server by accident.
- dup "\r\n>" intersect empty?
- [ bad-email-address ] unless ;
+ ! Make sure we send funky stuff to the server by accident.
+ dup "\r\n>" intersects?
+ [ bad-email-address ] when ;
: mail-from ( fromaddr -- )
validate-address
: 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 ( body -- )
- string-lines
- validate-message
- [ write crlf ] each
+: send-body ( email -- )
+ 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>> [
+ utf8 encode >base64
+ "=?utf-8?B?" "?=" surround
+ ] when ;
ERROR: invalid-header-string string ;
: validate-header ( string -- string' )
- dup "\r\n" intersect empty?
- [ invalid-header-string ] unless ;
+ dup "\r\n" intersects?
+ [ invalid-header-string ] when ;
: write-header ( key value -- )
[ validate-header write ]
- [ ": " write validate-header write ] bi* crlf ;
+ [ ": " write validate-header encode-header write ] bi* crlf ;
: write-headers ( assoc -- )
[ write-header ] assoc-each ;
"<" %
64 random-bits #
"-" %
- micros #
+ now timestamp>micros #
"@" %
- smtp-domain get [ host-name ] unless* %
+ smtp-config get domain>> [ host-name ] unless* %
">" %
] "" make ;
! This could be much smarter.
" " split1-last swap or "<" ?head drop ">" ?tail drop ;
-: email>headers ( email -- hashtable )
+: email-content-type ( email -- content-type )
+ [ content-type>> ] [ encoding>> encoding>name ] bi "; charset=" glue ;
+
+: email>headers ( email -- assoc )
[
+ 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 ]
+ [ from>> "From" ,, ]
+ [ to>> ", " join "To" ,, ]
+ [ cc>> ", " join [ "Cc" ,, ] unless-empty ]
+ [ subject>> "Subject" ,, ]
+ [ email-content-type "Content-Type" ,, ]
} cleave
- now timestamp>rfc822 "Date" set
- message-id "Message-Id" set
- ] { } 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
data get-ok
swap write-headers
crlf
- body>> send-body get-ok
+ send-body get-ok
quit get-ok
] with-smtp-connection ;
projects / factor.git / blobdiff