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: arrays namespaces make io io.encodings io.encodings.string
5 io.encodings.utf8 io.encodings.iana io.encodings.binary
6 io.encodings.ascii io.timeouts io.sockets io.sockets.secure io.crlf
7 kernel logging sequences combinators splitting assocs strings
8 math.order math.parser random system calendar summary calendar.format
9 accessors sets hashtables base64 debugger classes prettyprint words ;
10 FROM: namespaces => set ;
16 "localhost" 25 <inet> smtp-server set-global
20 SYMBOL: smtp-read-timeout
21 1 minutes smtp-read-timeout set-global
25 TUPLE: plain-auth username password ;
26 C: <plain-auth> plain-auth
29 no-auth smtp-auth set-global
31 LOG: log-smtp-connection NOTICE
33 : with-smtp-connection ( quot -- )
35 dup log-smtp-connection
37 smtp-domain [ host-name or ] change
38 smtp-read-timeout get timeouts
40 ] with-client ; inline
48 { content-type string initial: "text/plain" }
49 { encoding word initial: utf8 }
52 : <email> ( -- email ) email new ; inline
56 : command ( string -- ) write crlf flush ;
58 \ command DEBUG add-input-logging
60 : helo ( -- ) "EHLO " host-name append command ;
62 : start-tls ( -- ) "STARTTLS" command ;
64 ERROR: bad-email-address email ;
66 : validate-address ( string -- string' )
67 #! Make sure we send funky stuff to the server by accident.
68 dup "\r\n>" intersects?
69 [ bad-email-address ] when ;
71 : mail-from ( fromaddr -- )
73 "MAIL FROM:<" ">" surround command ;
77 "RCPT TO:<" ">" surround command ;
82 ERROR: message-contains-dot message ;
84 M: message-contains-dot summary ( obj -- string )
85 drop "Message cannot contain . on a line by itself" ;
87 : validate-message ( msg -- msg' )
89 [ message-contains-dot ] when ;
91 : send-body ( email -- )
93 [ body>> ] [ encoding>> ] bi encode >base64-lines write
94 ascii encode-output crlf
100 LOG: smtp-response DEBUG
102 : multiline? ( response -- ? )
103 3 swap ?nth CHAR: - = ;
105 : (receive-response) ( -- )
109 [ multiline? [ (receive-response) ] when ]
112 TUPLE: response code messages ;
114 : <response> ( lines -- response )
115 [ first 3 head string>number ] keep response boa ;
117 : receive-response ( -- response )
118 [ (receive-response) ] { } make <response> ;
120 ERROR: smtp-error response ;
123 "SMTP error (" write dup class pprint ")" print
124 response>> messages>> [ print ] each ;
126 ERROR: smtp-server-busy < smtp-error ;
127 ERROR: smtp-syntax-error < smtp-error ;
128 ERROR: smtp-command-not-implemented < smtp-error ;
129 ERROR: smtp-bad-authentication < smtp-error ;
130 ERROR: smtp-mailbox-unavailable < smtp-error ;
131 ERROR: smtp-user-not-local < smtp-error ;
132 ERROR: smtp-exceeded-storage-allocation < smtp-error ;
133 ERROR: smtp-bad-mailbox-name < smtp-error ;
134 ERROR: smtp-transaction-failed < smtp-error ;
136 : check-response ( response -- )
138 { [ dup { 220 235 250 221 354 } member? ] [ 2drop ] }
139 { [ dup 400 499 between? ] [ drop smtp-server-busy ] }
140 { [ dup 500 = ] [ drop smtp-syntax-error ] }
141 { [ dup 501 = ] [ drop smtp-command-not-implemented ] }
142 { [ dup 500 509 between? ] [ drop smtp-syntax-error ] }
143 { [ dup 530 539 between? ] [ drop smtp-bad-authentication ] }
144 { [ dup 550 = ] [ drop smtp-mailbox-unavailable ] }
145 { [ dup 551 = ] [ drop smtp-user-not-local ] }
146 { [ dup 552 = ] [ drop smtp-exceeded-storage-allocation ] }
147 { [ dup 553 = ] [ drop smtp-bad-mailbox-name ] }
148 { [ dup 554 = ] [ drop smtp-transaction-failed ] }
152 : get-ok ( -- ) receive-response check-response ;
154 GENERIC: send-auth ( auth -- )
156 M: no-auth send-auth drop ;
158 : plain-auth-string ( username password -- string )
159 [ "\0" prepend ] bi@ append utf8 encode >base64 ;
161 M: plain-auth send-auth
162 [ username>> ] [ password>> ] bi plain-auth-string
163 "AUTH PLAIN " prepend command get-ok ;
165 : auth ( -- ) smtp-auth get send-auth ;
167 : encode-header ( string -- string' )
170 "=?utf-8?B?" "?=" surround
173 ERROR: invalid-header-string string ;
175 : validate-header ( string -- string' )
176 dup "\r\n" intersects?
177 [ invalid-header-string ] when ;
179 : write-header ( key value -- )
180 [ validate-header write ]
181 [ ": " write validate-header encode-header write ] bi* crlf ;
183 : write-headers ( assoc -- )
184 [ write-header ] assoc-each ;
186 : message-id ( -- string )
191 gmt timestamp>micros #
193 smtp-domain get [ host-name ] unless* %
197 : extract-email ( recepient -- email )
198 ! This could be much smarter.
199 " " split1-last swap or "<" ?head drop ">" ?tail drop ;
201 : email-content-type ( email -- content-type )
202 [ content-type>> ] [ encoding>> encoding>name ] bi "; charset=" glue ;
204 : email>headers ( email -- assoc )
206 now timestamp>rfc822 "Date" set
207 message-id "Message-Id" set
208 "1.0" "MIME-Version" set
209 "base64" "Content-Transfer-Encoding" set
211 [ from>> "From" set ]
212 [ to>> ", " join "To" set ]
213 [ cc>> ", " join [ "Cc" set ] unless-empty ]
214 [ subject>> "Subject" set ]
215 [ email-content-type "Content-Type" set ]
219 : (send-email) ( headers email -- )
223 smtp-tls? get [ start-tls get-ok send-secure-handshake ] when
225 dup from>> extract-email mail-from get-ok
226 dup to>> [ extract-email rcpt-to get-ok ] each
227 dup cc>> [ extract-email rcpt-to get-ok ] each
228 dup bcc>> [ extract-email rcpt-to get-ok ] each
234 ] with-smtp-connection ;
238 : send-email ( email -- )
239 [ email>headers ] keep (send-email) ;