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 io io.timeouts kernel logging
5 io.sockets sequences combinators splitting assocs strings
6 math.parser random system calendar io.encodings.ascii summary
7 calendar.format accessors sets hashtables ;
11 SYMBOL: smtp-server "localhost" "smtp" <inet> smtp-server set-global
12 SYMBOL: smtp-read-timeout 1 minutes smtp-read-timeout set-global
13 SYMBOL: esmtp t esmtp set-global
15 LOG: log-smtp-connection NOTICE ( addrspec -- )
17 : with-smtp-connection ( quot -- )
19 dup log-smtp-connection
21 smtp-domain [ host-name or ] change
22 smtp-read-timeout get timeouts
24 ] with-client ; inline
34 : <email> ( -- email ) email new ;
37 : crlf ( -- ) "\r\n" write ;
39 : command ( string -- ) write crlf flush ;
42 esmtp get "EHLO " "HELO " ? host-name append command ;
44 ERROR: bad-email-address email ;
46 : validate-address ( string -- string' )
47 #! Make sure we send funky stuff to the server by accident.
48 dup "\r\n>" intersect empty?
49 [ bad-email-address ] unless ;
51 : mail-from ( fromaddr -- )
52 "MAIL FROM:<" swap validate-address ">" 3append command ;
55 "RCPT TO:<" swap validate-address ">" 3append command ;
60 ERROR: message-contains-dot message ;
62 M: message-contains-dot summary ( obj -- string )
64 "Message cannot contain . on a line by itself" ;
66 : validate-message ( msg -- msg' )
68 [ message-contains-dot ] when ;
70 : send-body ( body -- )
79 LOG: smtp-response DEBUG
81 ERROR: smtp-error message ;
82 ERROR: smtp-server-busy < smtp-error ;
83 ERROR: smtp-syntax-error < smtp-error ;
84 ERROR: smtp-command-not-implemented < smtp-error ;
85 ERROR: smtp-bad-authentication < smtp-error ;
86 ERROR: smtp-mailbox-unavailable < smtp-error ;
87 ERROR: smtp-user-not-local < smtp-error ;
88 ERROR: smtp-exceeded-storage-allocation < smtp-error ;
89 ERROR: smtp-bad-mailbox-name < smtp-error ;
90 ERROR: smtp-transaction-failed < smtp-error ;
92 : check-response ( response -- )
95 { [ dup "bye" head? ] [ drop ] }
96 { [ dup "220" head? ] [ drop ] }
97 { [ dup "235" swap subseq? ] [ drop ] }
98 { [ dup "250" head? ] [ drop ] }
99 { [ dup "221" head? ] [ drop ] }
100 { [ dup "354" head? ] [ drop ] }
101 { [ dup "4" head? ] [ smtp-server-busy ] }
102 { [ dup "500" head? ] [ smtp-syntax-error ] }
103 { [ dup "501" head? ] [ smtp-command-not-implemented ] }
104 { [ dup "50" head? ] [ smtp-syntax-error ] }
105 { [ dup "53" head? ] [ smtp-bad-authentication ] }
106 { [ dup "550" head? ] [ smtp-mailbox-unavailable ] }
107 { [ dup "551" head? ] [ smtp-user-not-local ] }
108 { [ dup "552" head? ] [ smtp-exceeded-storage-allocation ] }
109 { [ dup "553" head? ] [ smtp-bad-mailbox-name ] }
110 { [ dup "554" head? ] [ smtp-transaction-failed ] }
114 : multiline? ( response -- boolean )
115 3 swap ?nth CHAR: - = ;
117 : process-multiline ( multiline -- response )
118 >r readln r> 2dup " " append head? [
119 drop dup smtp-response
121 swap check-response process-multiline
124 : receive-response ( -- response )
126 dup multiline? [ 3 head process-multiline ] when ;
128 : get-ok ( -- ) receive-response check-response ;
130 ERROR: invalid-header-string string ;
132 : validate-header ( string -- string' )
133 dup "\r\n" intersect empty?
134 [ invalid-header-string ] unless ;
136 : write-header ( key value -- )
137 [ validate-header write ]
138 [ ": " write validate-header write ] bi* crlf ;
140 : write-headers ( assoc -- )
141 [ write-header ] assoc-each ;
143 : message-id ( -- string )
150 smtp-domain get [ host-name ] unless* %
154 : extract-email ( recepient -- email )
155 ! This could be much smarter.
156 " " last-split1 swap or "<" ?head drop ">" ?tail drop ;
158 : email>headers ( email -- hashtable )
161 [ from>> "From" set ]
162 [ to>> ", " join "To" set ]
163 [ cc>> ", " join [ "Cc" set ] unless-empty ]
164 [ subject>> "Subject" set ]
166 now timestamp>rfc822 "Date" set
167 message-id "Message-Id" set
170 : (send-email) ( headers email -- )
173 dup from>> extract-email mail-from get-ok
174 dup to>> [ extract-email rcpt-to get-ok ] each
175 dup cc>> [ extract-email rcpt-to get-ok ] each
176 dup bcc>> [ extract-email rcpt-to get-ok ] each
180 body>> send-body get-ok
182 ] with-smtp-connection ;
185 : send-email ( email -- )
186 [ email>headers ] keep (send-email) ;