1 ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
2 ! Slava Pestov, Doug Coleman.
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: arrays namespaces make io io.encodings.string
5 io.encodings.utf8 io.timeouts io.sockets io.sockets.secure
6 io.encodings.ascii kernel logging sequences combinators
7 splitting assocs strings math.order math.parser random system
8 calendar summary calendar.format accessors sets hashtables
9 base64 debugger classes prettyprint ;
15 "localhost" 25 <inet> smtp-server set-global
19 SYMBOL: smtp-read-timeout
20 1 minutes smtp-read-timeout set-global
24 TUPLE: plain-auth username password ;
25 C: <plain-auth> plain-auth
28 no-auth smtp-auth set-global
30 LOG: log-smtp-connection NOTICE ( addrspec -- )
32 : with-smtp-connection ( quot -- )
34 dup log-smtp-connection
36 smtp-domain [ host-name or ] change
37 smtp-read-timeout get timeouts
39 ] with-client ; inline
49 : <email> ( -- email ) email new ; inline
53 : crlf ( -- ) "\r\n" write ;
55 : read-crlf ( -- bytes )
57 [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
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 ERROR: message-contains-dot message ;
87 M: message-contains-dot summary ( obj -- string )
88 drop "Message cannot contain . on a line by itself" ;
90 : validate-message ( msg -- msg' )
92 [ message-contains-dot ] when ;
94 : send-body ( body -- )
96 >base64-lines write crlf
102 LOG: smtp-response DEBUG
104 : multiline? ( response -- ? )
105 3 swap ?nth CHAR: - = ;
107 : (receive-response) ( -- )
111 [ multiline? [ (receive-response) ] when ]
114 TUPLE: response code messages ;
116 : <response> ( lines -- response )
117 [ first 3 head string>number ] keep response boa ;
119 : receive-response ( -- response )
120 [ (receive-response) ] { } make <response> ;
122 ERROR: smtp-error response ;
125 "SMTP error (" write dup class pprint ")" print
126 response>> messages>> [ print ] each ;
128 ERROR: smtp-server-busy < smtp-error ;
129 ERROR: smtp-syntax-error < smtp-error ;
130 ERROR: smtp-command-not-implemented < smtp-error ;
131 ERROR: smtp-bad-authentication < smtp-error ;
132 ERROR: smtp-mailbox-unavailable < smtp-error ;
133 ERROR: smtp-user-not-local < smtp-error ;
134 ERROR: smtp-exceeded-storage-allocation < smtp-error ;
135 ERROR: smtp-bad-mailbox-name < smtp-error ;
136 ERROR: smtp-transaction-failed < smtp-error ;
138 : check-response ( response -- )
140 { [ dup { 220 235 250 221 354 } member? ] [ 2drop ] }
141 { [ dup 400 499 between? ] [ drop smtp-server-busy ] }
142 { [ dup 500 = ] [ drop smtp-syntax-error ] }
143 { [ dup 501 = ] [ drop smtp-command-not-implemented ] }
144 { [ dup 500 509 between? ] [ drop smtp-syntax-error ] }
145 { [ dup 530 539 between? ] [ drop smtp-bad-authentication ] }
146 { [ dup 550 = ] [ drop smtp-mailbox-unavailable ] }
147 { [ dup 551 = ] [ drop smtp-user-not-local ] }
148 { [ dup 552 = ] [ drop smtp-exceeded-storage-allocation ] }
149 { [ dup 553 = ] [ drop smtp-bad-mailbox-name ] }
150 { [ dup 554 = ] [ drop smtp-transaction-failed ] }
154 : get-ok ( -- ) receive-response check-response ;
156 GENERIC: send-auth ( auth -- )
158 M: no-auth send-auth drop ;
160 : plain-auth-string ( username password -- string )
161 [ "\0" prepend ] bi@ append utf8 encode >base64 ;
163 M: plain-auth send-auth
164 [ username>> ] [ password>> ] bi plain-auth-string
165 "AUTH PLAIN " prepend command get-ok ;
167 : auth ( -- ) smtp-auth get send-auth ;
169 : encode-header ( string -- string' )
172 swap utf8 encode >base64
176 ERROR: invalid-header-string string ;
178 : validate-header ( string -- string' )
179 dup "\r\n" intersects?
180 [ invalid-header-string ] when ;
182 : write-header ( key value -- )
183 [ validate-header write ]
184 [ ": " write validate-header encode-header write ] bi* crlf ;
186 : write-headers ( assoc -- )
187 [ write-header ] assoc-each ;
189 : message-id ( -- string )
196 smtp-domain get [ host-name ] unless* %
200 : extract-email ( recepient -- email )
201 ! This could be much smarter.
202 " " split1-last swap or "<" ?head drop ">" ?tail drop ;
204 : utf8-mime-header ( -- alist )
206 { "MIME-Version" "1.0" }
207 { "Content-Transfer-Encoding" "base64" }
208 { "Content-Type" "Text/plain; charset=utf-8" }
211 : email>headers ( email -- hashtable )
214 [ from>> "From" set ]
215 [ to>> ", " join "To" set ]
216 [ cc>> ", " join [ "Cc" set ] unless-empty ]
217 [ subject>> "Subject" set ]
219 now timestamp>rfc822 "Date" set
220 message-id "Message-Id" set
221 ] { } make-assoc utf8-mime-header append ;
223 : (send-email) ( headers email -- )
227 smtp-tls? get [ start-tls get-ok send-secure-handshake ] when
229 dup from>> extract-email mail-from get-ok
230 dup to>> [ extract-email rcpt-to get-ok ] each
231 dup cc>> [ extract-email rcpt-to get-ok ] each
232 dup bcc>> [ extract-email rcpt-to get-ok ] each
236 body>> send-body get-ok
238 ] with-smtp-connection ;
242 : send-email ( email -- )
243 [ email>headers ] keep (send-email) ;