basis/smtp/smtp.factor

   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 ;
  11 IN: smtp
  12
  13 SYMBOL: smtp-domain
  14
  15 SYMBOL: smtp-server
  16 "localhost" 25 <inet> smtp-server set-global
  17
  18 SYMBOL: smtp-tls?
  19
  20 SYMBOL: smtp-read-timeout
  21 1 minutes smtp-read-timeout set-global
  22
  23 SINGLETON: no-auth
  24
  25 TUPLE: plain-auth username password ;
  26 C: <plain-auth> plain-auth
  27
  28 SYMBOL: smtp-auth
  29 no-auth smtp-auth set-global
  30
  31 LOG: log-smtp-connection NOTICE
  32
  33 : with-smtp-connection ( quot -- )
  34     smtp-server get
  35     dup log-smtp-connection
  36     ascii [
  37         smtp-domain [ host-name or ] change
  38         smtp-read-timeout get timeouts
  39         call
  40     ] with-client ; inline
  41
  42 TUPLE: email
  43     { from string }
  44     { to array }
  45     { cc array }
  46     { bcc array }
  47     { subject string }
  48     { content-type string initial: "text/plain" }
  49     { encoding word initial: utf8 }
  50     { body string } ;
  51
  52 : <email> ( -- email ) email new ; inline
  53
  54 <PRIVATE
  55
  56 : command ( string -- ) write crlf flush ;
  57
  58 \ command DEBUG add-input-logging
  59
  60 : helo ( -- ) "EHLO " host-name append command ;
  61
  62 : start-tls ( -- ) "STARTTLS" command ;
  63
  64 ERROR: bad-email-address email ;
  65
  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 ;
  70
  71 : mail-from ( fromaddr -- )
  72     validate-address
  73     "MAIL FROM:<" ">" surround command ;
  74
  75 : rcpt-to ( to -- )
  76     validate-address
  77     "RCPT TO:<" ">" surround command ;
  78
  79 : data ( -- )
  80     "DATA" command ;
  81
  82 : send-body ( email -- )
  83     binary encode-output
  84     [ body>> ] [ encoding>> ] bi encode >base64-lines write
  85     ascii encode-output crlf
  86     "." command ;
  87
  88 : quit ( -- )
  89     "QUIT" command ;
  90
  91 LOG: smtp-response DEBUG
  92
  93 : multiline? ( response -- ? )
  94     3 swap ?nth CHAR: - = ;
  95
  96 : (receive-response) ( -- )
  97     read-crlf
  98     [ , ]
  99     [ smtp-response ]
 100     [ multiline? [ (receive-response) ] when ]
 101     tri ;
 102
 103 TUPLE: response code messages ;
 104
 105 : <response> ( lines -- response )
 106     [ first 3 head string>number ] keep response boa ;
 107
 108 : receive-response ( -- response )
 109     [ (receive-response) ] { } make <response> ;
 110
 111 ERROR: smtp-error response ;
 112
 113 M: smtp-error error.
 114     "SMTP error (" write dup class-of pprint ")" print
 115     response>> messages>> [ print ] each ;
 116
 117 ERROR: smtp-server-busy < smtp-error ;
 118 ERROR: smtp-syntax-error < smtp-error ;
 119 ERROR: smtp-command-not-implemented < smtp-error ;
 120 ERROR: smtp-bad-authentication < smtp-error ;
 121 ERROR: smtp-mailbox-unavailable < smtp-error ;
 122 ERROR: smtp-user-not-local < smtp-error ;
 123 ERROR: smtp-exceeded-storage-allocation < smtp-error ;
 124 ERROR: smtp-bad-mailbox-name < smtp-error ;
 125 ERROR: smtp-transaction-failed < smtp-error ;
 126
 127 : check-response ( response -- )
 128     dup code>> {
 129         { [ dup { 220 235 250 221 354 } member? ] [ 2drop ] }
 130         { [ dup 400 499 between? ] [ drop smtp-server-busy ] }
 131         { [ dup 500 = ] [ drop smtp-syntax-error ] }
 132         { [ dup 501 = ] [ drop smtp-command-not-implemented ] }
 133         { [ dup 500 509 between? ] [ drop smtp-syntax-error ] }
 134         { [ dup 530 539 between? ] [ drop smtp-bad-authentication ] }
 135         { [ dup 550 = ] [ drop smtp-mailbox-unavailable ] }
 136         { [ dup 551 = ] [ drop smtp-user-not-local ] }
 137         { [ dup 552 = ] [ drop smtp-exceeded-storage-allocation ] }
 138         { [ dup 553 = ] [ drop smtp-bad-mailbox-name ] }
 139         { [ dup 554 = ] [ drop smtp-transaction-failed ] }
 140         [ drop smtp-error ]
 141     } cond ;
 142
 143 : get-ok ( -- ) receive-response check-response ;
 144
 145 GENERIC: send-auth ( auth -- )
 146
 147 M: no-auth send-auth drop ;
 148
 149 : plain-auth-string ( username password -- string )
 150     [ "\0" prepend ] bi@ append utf8 encode >base64 ;
 151
 152 M: plain-auth send-auth
 153     [ username>> ] [ password>> ] bi plain-auth-string
 154     "AUTH PLAIN " prepend command get-ok ;
 155
 156 : auth ( -- ) smtp-auth get send-auth ;
 157
 158 : encode-header ( string -- string' )
 159     dup aux>> [
 160         utf8 encode >base64
 161         "=?utf-8?B?" "?=" surround
 162     ] when ;
 163
 164 ERROR: invalid-header-string string ;
 165
 166 : validate-header ( string -- string' )
 167     dup "\r\n" intersects?
 168     [ invalid-header-string ] when ;
 169
 170 : write-header ( key value -- )
 171     [ validate-header write ]
 172     [ ": " write validate-header encode-header write ] bi* crlf ;
 173
 174 : write-headers ( assoc -- )
 175     [ write-header ] assoc-each ;
 176
 177 : message-id ( -- string )
 178     [
 179         "<" %
 180         64 random-bits #
 181         "-" %
 182         gmt timestamp>micros #
 183         "@" %
 184         smtp-domain get [ host-name ] unless* %
 185         ">" %
 186     ] "" make ;
 187
 188 : extract-email ( recepient -- email )
 189     ! This could be much smarter.
 190     " " split1-last swap or "<" ?head drop ">" ?tail drop ;
 191
 192 : email-content-type ( email -- content-type )
 193     [ content-type>> ] [ encoding>> encoding>name ] bi "; charset=" glue ;
 194
 195 : email>headers ( email -- assoc )
 196     [
 197         now timestamp>rfc822 "Date" set
 198         message-id "Message-Id" set
 199         "1.0" "MIME-Version" set
 200         "base64" "Content-Transfer-Encoding" set
 201         {
 202             [ from>> "From" set ]
 203             [ to>> ", " join "To" set ]
 204             [ cc>> ", " join [ "Cc" set ] unless-empty ]
 205             [ subject>> "Subject" set ]
 206             [ email-content-type "Content-Type" set ]
 207         } cleave
 208     ] { } make-assoc ;
 209
 210 : (send-email) ( headers email -- )
 211     [
 212         get-ok
 213         helo get-ok
 214         smtp-tls? get [ start-tls get-ok send-secure-handshake ] when
 215         auth
 216         dup from>> extract-email mail-from get-ok
 217         dup to>> [ extract-email rcpt-to get-ok ] each
 218         dup cc>> [ extract-email rcpt-to get-ok ] each
 219         dup bcc>> [ extract-email rcpt-to get-ok ] each
 220         data get-ok
 221         swap write-headers
 222         crlf
 223         send-body get-ok
 224         quit get-ok
 225     ] with-smtp-connection ;
 226
 227 PRIVATE>
 228
 229 : send-email ( email -- )
 230     [ email>headers ] keep (send-email) ;