1 ! Copyright (C) 2007, 2009 Elie CHAFTARI, Dirk Vleugels,
2 ! Slava Pestov, Doug Coleman, Daniel Ehrenberg.
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors arrays assocs base64 calendar calendar.format
5 classes combinators debugger fry io io.crlf io.encodings
6 io.encodings.ascii io.encodings.binary io.encodings.iana
7 io.encodings.string io.encodings.utf8 io.sockets
8 io.sockets.secure io.timeouts kernel logging make math.order
9 math.parser namespaces prettyprint random sequences sets
10 splitting strings words ;
13 TUPLE: smtp-config domain server tls? { read-timeout duration } auth ;
17 TUPLE: plain-auth username password ;
18 C: <plain-auth> plain-auth
20 : <smtp-config> ( -- smtp-config )
21 smtp-config new ; inline
23 : default-smtp-config ( -- smtp-config )
25 "localhost" 25 <inet> >>server
26 1 minutes >>read-timeout
27 no-auth >>auth ; inline
29 LOG: log-smtp-connection NOTICE
31 : with-smtp-connection ( quot -- )
32 smtp-config get server>>
33 dup log-smtp-connection
36 [ [ host-name or ] change-domain drop ]
37 [ read-timeout>> timeouts ] bi
39 ] with-client ; inline
41 : with-smtp-config ( quot -- )
42 [ \ smtp-config get-global clone \ smtp-config ] dip
43 '[ _ with-smtp-connection ] with-variable ; inline
51 { content-type string initial: "text/plain" }
52 { encoding word initial: utf8 }
55 : <email> ( -- email ) email new ; inline
59 : command ( string -- ) write crlf flush ;
61 \ command DEBUG add-input-logging
63 : helo ( -- ) "EHLO " host-name append command ;
65 : start-tls ( -- ) "STARTTLS" command ;
67 ERROR: bad-email-address email ;
69 : validate-address ( string -- string' )
70 ! Make sure we send funky stuff to the server by accident.
71 dup "\r\n>" intersects?
72 [ bad-email-address ] when ;
74 : mail-from ( fromaddr -- )
76 "MAIL FROM:<" ">" surround command ;
80 "RCPT TO:<" ">" surround command ;
85 : send-body ( email -- )
87 [ body>> ] [ encoding>> ] bi encode >base64-lines write
88 ascii encode-output crlf
94 LOG: smtp-response DEBUG
96 : multiline? ( response -- ? )
97 3 swap ?nth CHAR: - = ;
99 : (receive-response) ( -- )
103 [ multiline? [ (receive-response) ] when ]
106 TUPLE: response code messages ;
108 : <response> ( lines -- response )
109 [ first 3 head string>number ] keep response boa ;
111 : receive-response ( -- response )
112 [ (receive-response) ] { } make <response> ;
114 ERROR: smtp-error response ;
117 "SMTP error (" write dup class-of pprint ")" print
118 response>> messages>> [ print ] each ;
120 ERROR: smtp-server-busy < smtp-error ;
121 ERROR: smtp-syntax-error < smtp-error ;
122 ERROR: smtp-command-not-implemented < smtp-error ;
123 ERROR: smtp-bad-authentication < smtp-error ;
124 ERROR: smtp-mailbox-unavailable < smtp-error ;
125 ERROR: smtp-user-not-local < smtp-error ;
126 ERROR: smtp-exceeded-storage-allocation < smtp-error ;
127 ERROR: smtp-bad-mailbox-name < smtp-error ;
128 ERROR: smtp-transaction-failed < smtp-error ;
130 : check-response ( response -- )
132 { [ dup { 220 235 250 221 354 } member? ] [ 2drop ] }
133 { [ dup 400 499 between? ] [ drop smtp-server-busy ] }
134 { [ dup 500 = ] [ drop smtp-syntax-error ] }
135 { [ dup 501 = ] [ drop smtp-command-not-implemented ] }
136 { [ dup 500 509 between? ] [ drop smtp-syntax-error ] }
137 { [ dup 530 539 between? ] [ drop smtp-bad-authentication ] }
138 { [ dup 550 = ] [ drop smtp-mailbox-unavailable ] }
139 { [ dup 551 = ] [ drop smtp-user-not-local ] }
140 { [ dup 552 = ] [ drop smtp-exceeded-storage-allocation ] }
141 { [ dup 553 = ] [ drop smtp-bad-mailbox-name ] }
142 { [ dup 554 = ] [ drop smtp-transaction-failed ] }
146 : get-ok ( -- ) receive-response check-response ;
148 GENERIC: send-auth ( auth -- )
150 M: no-auth send-auth drop ;
152 : plain-auth-string ( username password -- string )
153 [ "\0" prepend ] bi@ append utf8 encode >base64 >string ;
155 M: plain-auth send-auth
156 [ username>> ] [ password>> ] bi plain-auth-string
157 "AUTH PLAIN " prepend command get-ok ;
159 : auth ( -- ) smtp-config get auth>> send-auth ;
161 : encode-header ( string -- string' )
164 "=?utf-8?B?" "?=" surround
167 ERROR: invalid-header-string string ;
169 : validate-header ( string -- string' )
170 dup "\r\n" intersects?
171 [ invalid-header-string ] when ;
173 : write-header ( key value -- )
174 [ validate-header write ]
175 [ ": " write validate-header encode-header write ] bi* crlf ;
177 : write-headers ( assoc -- )
178 [ write-header ] assoc-each ;
180 : message-id ( -- string )
185 gmt timestamp>micros #
187 smtp-config get domain>> [ host-name ] unless* %
191 : extract-email ( recepient -- email )
192 ! This could be much smarter.
193 " " split1-last swap or "<" ?head drop ">" ?tail drop ;
195 : email-content-type ( email -- content-type )
196 [ content-type>> ] [ encoding>> encoding>name ] bi "; charset=" glue ;
198 : email>headers ( email -- assoc )
200 now timestamp>rfc822 "Date" ,,
201 message-id "Message-Id" ,,
202 "1.0" "MIME-Version" ,,
203 "base64" "Content-Transfer-Encoding" ,,
206 [ to>> ", " join "To" ,, ]
207 [ cc>> ", " join [ "Cc" ,, ] unless-empty ]
208 [ subject>> "Subject" ,, ]
209 [ email-content-type "Content-Type" ,, ]
213 : (send-email) ( headers email -- )
217 smtp-config get tls?>> [ start-tls get-ok send-secure-handshake ] when
219 dup from>> extract-email mail-from get-ok
220 dup to>> [ extract-email rcpt-to get-ok ] each
221 dup cc>> [ extract-email rcpt-to get-ok ] each
222 dup bcc>> [ extract-email rcpt-to get-ok ] each
228 ] with-smtp-connection ;
232 : send-email ( email -- )
233 [ email>headers ] keep (send-email) ;