basis/smtp/smtp.factor

   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 ;
  10 IN: smtp
  11
  12 SYMBOL: smtp-domain
  13
  14 SYMBOL: smtp-server
  15 "localhost" 25 <inet> smtp-server set-global
  16
  17 SYMBOL: smtp-tls?
  18
  19 SYMBOL: smtp-read-timeout
  20 1 minutes smtp-read-timeout set-global
  21
  22 SINGLETON: no-auth
  23
  24 TUPLE: plain-auth username password ;
  25 C: <plain-auth> plain-auth
  26
  27 SYMBOL: smtp-auth
  28 no-auth smtp-auth set-global
  29
  30 LOG: log-smtp-connection NOTICE ( addrspec -- )
  31
  32 : with-smtp-connection ( quot -- )
  33     smtp-server get
  34     dup log-smtp-connection
  35     ascii [
  36         smtp-domain [ host-name or ] change
  37         smtp-read-timeout get timeouts
  38         call
  39     ] with-client ; inline
  40
  41 TUPLE: email
  42     { from string }
  43     { to array }
  44     { cc array }
  45     { bcc array }
  46     { subject string }
  47     { body string } ;
  48
  49 : <email> ( -- email ) email new ; inline
  50
  51 <PRIVATE
  52
  53 : crlf ( -- ) "\r\n" write ;
  54
  55 : read-crlf ( -- bytes )
  56     "\r" read-until
  57     [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
  58
  59 : command ( string -- ) write crlf flush ;
  60
  61 \ command DEBUG add-input-logging
  62
  63 : helo ( -- ) "EHLO " host-name append command ;
  64
  65 : start-tls ( -- ) "STARTTLS" command ;
  66
  67 ERROR: bad-email-address email ;
  68
  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 ;
  73
  74 : mail-from ( fromaddr -- )
  75     validate-address
  76     "MAIL FROM:<" ">" surround command ;
  77
  78 : rcpt-to ( to -- )
  79     validate-address
  80     "RCPT TO:<" ">" surround command ;
  81
  82 : data ( -- )
  83     "DATA" command ;
  84
  85 ERROR: message-contains-dot message ;
  86
  87 M: message-contains-dot summary ( obj -- string )
  88     drop "Message cannot contain . on a line by itself" ;
  89
  90 : validate-message ( msg -- msg' )
  91     "." over member?
  92     [ message-contains-dot ] when ;
  93
  94 : send-body ( body -- )
  95     utf8 encode
  96     >base64-lines write crlf
  97     "." command ;
  98
  99 : quit ( -- )
 100     "QUIT" command ;
 101
 102 LOG: smtp-response DEBUG
 103
 104 : multiline? ( response -- ? )
 105     3 swap ?nth CHAR: - = ;
 106
 107 : (receive-response) ( -- )
 108     read-crlf
 109     [ , ]
 110     [ smtp-response ]
 111     [ multiline? [ (receive-response) ] when ]
 112     tri ;
 113
 114 TUPLE: response code messages ;
 115
 116 : <response> ( lines -- response )
 117     [ first 3 head string>number ] keep response boa ;
 118
 119 : receive-response ( -- response )
 120     [ (receive-response) ] { } make <response> ;
 121
 122 ERROR: smtp-error response ;
 123
 124 M: smtp-error error.
 125     "SMTP error (" write dup class pprint ")" print
 126     response>> messages>> [ print ] each ;
 127
 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 ;
 137
 138 : check-response ( response -- )
 139     dup code>> {
 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 ] }
 151         [ drop smtp-error ]
 152     } cond ;
 153
 154 : get-ok ( -- ) receive-response check-response ;
 155
 156 GENERIC: send-auth ( auth -- )
 157
 158 M: no-auth send-auth drop ;
 159
 160 : plain-auth-string ( username password -- string )
 161     [ "\0" prepend ] bi@ append utf8 encode >base64 ;
 162
 163 M: plain-auth send-auth
 164     [ username>> ] [ password>> ] bi plain-auth-string
 165     "AUTH PLAIN " prepend command get-ok ;
 166
 167 : auth ( -- ) smtp-auth get send-auth ;
 168
 169 : encode-header ( string -- string' )
 170     dup aux>> [
 171         "=?utf-8?B?"
 172         swap utf8 encode >base64
 173         "?=" 3append
 174     ] when ;
 175
 176 ERROR: invalid-header-string string ;
 177
 178 : validate-header ( string -- string' )
 179     dup "\r\n" intersects?
 180     [ invalid-header-string ] when ;
 181
 182 : write-header ( key value -- )
 183     [ validate-header write ]
 184     [ ": " write validate-header encode-header write ] bi* crlf ;
 185
 186 : write-headers ( assoc -- )
 187     [ write-header ] assoc-each ;
 188
 189 : message-id ( -- string )
 190     [
 191         "<" %
 192         64 random-bits #
 193         "-" %
 194         micros #
 195         "@" %
 196         smtp-domain get [ host-name ] unless* %
 197         ">" %
 198     ] "" make ;
 199
 200 : extract-email ( recepient -- email )
 201     ! This could be much smarter.
 202     " " split1-last swap or "<" ?head drop ">" ?tail drop ;
 203
 204 : utf8-mime-header ( -- alist )
 205     {
 206         { "MIME-Version" "1.0" }
 207         { "Content-Transfer-Encoding" "base64" }
 208         { "Content-Type" "Text/plain; charset=utf-8" }
 209     } ;
 210
 211 : email>headers ( email -- hashtable )
 212     [
 213         {
 214             [ from>> "From" set ]
 215             [ to>> ", " join "To" set ]
 216             [ cc>> ", " join [ "Cc" set ] unless-empty ]
 217             [ subject>> "Subject" set ]
 218         } cleave
 219         now timestamp>rfc822 "Date" set
 220         message-id "Message-Id" set
 221     ] { } make-assoc utf8-mime-header append ;
 222
 223 : (send-email) ( headers email -- )
 224     [
 225         get-ok
 226         helo get-ok
 227         smtp-tls? get [ start-tls get-ok send-secure-handshake ] when
 228         auth
 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
 233         data get-ok
 234         swap write-headers
 235         crlf
 236         body>> send-body get-ok
 237         quit get-ok
 238     ] with-smtp-connection ;
 239
 240 PRIVATE>
 241
 242 : send-email ( email -- )
 243     [ email>headers ] keep (send-email) ;