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