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