factor/basis/smtp/smtp.factor

240 lines
6.4 KiB
Factor

! 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 ;
FROM: namespaces => set ;
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
SINGLETON: no-auth
TUPLE: plain-auth username password ;
C: <plain-auth> plain-auth
SYMBOL: smtp-auth
no-auth smtp-auth set-global
LOG: log-smtp-connection NOTICE ( addrspec -- )
: with-smtp-connection ( quot -- )
smtp-server get
dup log-smtp-connection
ascii [
smtp-domain [ host-name or ] change
smtp-read-timeout get timeouts
call
] with-client ; 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
: command ( string -- ) write crlf flush ;
\ command DEBUG add-input-logging
: helo ( -- ) "EHLO " host-name append command ;
: start-tls ( -- ) "STARTTLS" command ;
ERROR: bad-email-address email ;
: validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident.
dup "\r\n>" intersects?
[ bad-email-address ] when ;
: mail-from ( fromaddr -- )
validate-address
"MAIL FROM:<" ">" surround command ;
: rcpt-to ( to -- )
validate-address
"RCPT TO:<" ">" surround command ;
: 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 -- )
binary encode-output
[ body>> ] [ encoding>> ] bi encode >base64-lines write
ascii encode-output crlf
"." command ;
: quit ( -- )
"QUIT" command ;
LOG: smtp-response DEBUG
: multiline? ( response -- ? )
3 swap ?nth CHAR: - = ;
: (receive-response) ( -- )
read-crlf
[ , ]
[ smtp-response ]
[ multiline? [ (receive-response) ] when ]
tri ;
TUPLE: response code messages ;
: <response> ( lines -- response )
[ first 3 head string>number ] keep response boa ;
: receive-response ( -- response )
[ (receive-response) ] { } make <response> ;
ERROR: smtp-error response ;
M: smtp-error error.
"SMTP error (" write dup class pprint ")" print
response>> messages>> [ print ] each ;
ERROR: smtp-server-busy < smtp-error ;
ERROR: smtp-syntax-error < smtp-error ;
ERROR: smtp-command-not-implemented < smtp-error ;
ERROR: smtp-bad-authentication < smtp-error ;
ERROR: smtp-mailbox-unavailable < smtp-error ;
ERROR: smtp-user-not-local < smtp-error ;
ERROR: smtp-exceeded-storage-allocation < smtp-error ;
ERROR: smtp-bad-mailbox-name < smtp-error ;
ERROR: smtp-transaction-failed < smtp-error ;
: check-response ( response -- )
dup code>> {
{ [ dup { 220 235 250 221 354 } member? ] [ 2drop ] }
{ [ dup 400 499 between? ] [ drop smtp-server-busy ] }
{ [ dup 500 = ] [ drop smtp-syntax-error ] }
{ [ dup 501 = ] [ drop smtp-command-not-implemented ] }
{ [ dup 500 509 between? ] [ drop smtp-syntax-error ] }
{ [ dup 530 539 between? ] [ drop smtp-bad-authentication ] }
{ [ dup 550 = ] [ drop smtp-mailbox-unavailable ] }
{ [ dup 551 = ] [ drop smtp-user-not-local ] }
{ [ dup 552 = ] [ drop smtp-exceeded-storage-allocation ] }
{ [ dup 553 = ] [ drop smtp-bad-mailbox-name ] }
{ [ dup 554 = ] [ drop smtp-transaction-failed ] }
[ drop smtp-error ]
} cond ;
: get-ok ( -- ) receive-response check-response ;
GENERIC: send-auth ( auth -- )
M: no-auth send-auth drop ;
: plain-auth-string ( username password -- string )
[ "\0" prepend ] bi@ append utf8 encode >base64 ;
M: plain-auth send-auth
[ username>> ] [ password>> ] bi plain-auth-string
"AUTH PLAIN " prepend command get-ok ;
: auth ( -- ) smtp-auth get 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" intersects?
[ invalid-header-string ] when ;
: write-header ( key value -- )
[ validate-header write ]
[ ": " write validate-header encode-header write ] bi* crlf ;
: write-headers ( assoc -- )
[ write-header ] assoc-each ;
: message-id ( -- string )
[
"<" %
64 random-bits #
"-" %
system-micros #
"@" %
smtp-domain get [ host-name ] unless* %
">" %
] "" make ;
: extract-email ( recepient -- email )
! This could be much smarter.
" " split1-last swap or "<" ?head drop ">" ?tail drop ;
: email-content-type ( email -- content-type )
[ content-type>> ] [ encoding>> encoding>name ] bi "; charset=" glue ;
: email>headers ( email -- assoc )
[
now timestamp>rfc822 "Date" set
message-id "Message-Id" set
"1.0" "MIME-Version" set
"base64" "Content-Transfer-Encoding" set
{
[ from>> "From" set ]
[ to>> ", " join "To" set ]
[ cc>> ", " join [ "Cc" set ] unless-empty ]
[ subject>> "Subject" set ]
[ email-content-type "Content-Type" set ]
} cleave
] { } make-assoc ;
: (send-email) ( headers email -- )
[
get-ok
helo get-ok
smtp-tls? get [ start-tls get-ok send-secure-handshake ] when
auth
dup from>> extract-email mail-from get-ok
dup to>> [ extract-email rcpt-to get-ok ] each
dup cc>> [ extract-email rcpt-to get-ok ] each
dup bcc>> [ extract-email rcpt-to get-ok ] each
data get-ok
swap write-headers
crlf
send-body get-ok
quit get-ok
] with-smtp-connection ;
PRIVATE>
: send-email ( email -- )
[ email>headers ] keep (send-email) ;