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.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 ;
   8 IN: smtp
   9
  10 SYMBOL: smtp-domain
  11 SYMBOL: smtp-server     "localhost" 25 <inet> smtp-server set-global
  12 SYMBOL: smtp-read-timeout    1 minutes smtp-read-timeout set-global
  13 SYMBOL: esmtp?           t esmtp? set-global
  14
  15 LOG: log-smtp-connection NOTICE ( addrspec -- )
  16
  17 : with-smtp-connection ( quot -- )
  18     smtp-server get
  19     dup log-smtp-connection
  20     ascii [
  21         smtp-domain [ host-name or ] change
  22         smtp-read-timeout get timeouts
  23         call
  24     ] with-client ; inline
  25
  26 TUPLE: email
  27     { from string }
  28     { to array }
  29     { cc array }
  30     { bcc array }
  31     { subject string }
  32     { body string } ;
  33
  34 : <email> ( -- email ) email new ;
  35
  36 <PRIVATE
  37 : crlf ( -- ) "\r\n" write ;
  38
  39 : command ( string -- ) write crlf flush ;
  40
  41 : helo ( -- )
  42     esmtp? get "EHLO " "HELO " ? host-name append command ;
  43
  44 ERROR: bad-email-address email ;
  45
  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 ;
  50
  51 : mail-from ( fromaddr -- )
  52     "MAIL FROM:<" swap validate-address ">" 3append command ;
  53
  54 : rcpt-to ( to -- )
  55     "RCPT TO:<" swap validate-address ">" 3append command ;
  56
  57 : data ( -- )
  58     "DATA" command ;
  59
  60 ERROR: message-contains-dot message ;
  61
  62 M: message-contains-dot summary ( obj -- string )
  63     drop
  64     "Message cannot contain . on a line by itself" ;
  65
  66 : validate-message ( msg -- msg' )
  67     "." over member?
  68     [ message-contains-dot ] when ;
  69
  70 : send-body ( body -- )
  71     string-lines
  72     validate-message
  73     [ write crlf ] each
  74     "." command ;
  75
  76 : quit ( -- )
  77     "QUIT" command ;
  78
  79 LOG: smtp-response DEBUG
  80
  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 ;
  91
  92 : check-response ( response -- )
  93     dup smtp-response
  94     {
  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 ] }
 111         [ smtp-error ]
 112     } cond ;
 113
 114 : multiline? ( response -- boolean )
 115     3 swap ?nth CHAR: - = ;
 116
 117 : process-multiline ( multiline -- response )
 118     >r readln r> 2dup " " append head? [
 119         drop dup smtp-response
 120     ] [
 121         swap check-response process-multiline
 122     ] if ;
 123
 124 : receive-response ( -- response )
 125     readln
 126     dup multiline? [ 3 head process-multiline ] when ;
 127
 128 : get-ok ( -- ) receive-response check-response ;
 129
 130 ERROR: invalid-header-string string ;
 131
 132 : validate-header ( string -- string' )
 133     dup "\r\n" intersect empty?
 134     [ invalid-header-string ] unless ;
 135
 136 : write-header ( key value -- )
 137     [ validate-header write ]
 138     [ ": " write validate-header write ] bi* crlf ;
 139
 140 : write-headers ( assoc -- )
 141     [ write-header ] assoc-each ;
 142
 143 : message-id ( -- string )
 144     [
 145         "<" %
 146         64 random-bits #
 147         "-" %
 148         millis #
 149         "@" %
 150         smtp-domain get [ host-name ] unless* %
 151         ">" %
 152     ] "" make ;
 153
 154 : extract-email ( recepient -- email )
 155     ! This could be much smarter.
 156     " " last-split1 swap or "<" ?head drop ">" ?tail drop ;
 157
 158 : email>headers ( email -- hashtable )
 159     [
 160         {
 161             [ from>> "From" set ]
 162             [ to>> ", " join "To" set ]
 163             [ cc>> ", " join [ "Cc" set ] unless-empty ]
 164             [ subject>> "Subject" set ]
 165         } cleave
 166         now timestamp>rfc822 "Date" set
 167         message-id "Message-Id" set
 168     ] { } make-assoc ;
 169
 170 : (send-email) ( headers email -- )
 171     [
 172         helo get-ok
 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
 177         data get-ok
 178         swap write-headers
 179         crlf
 180         body>> send-body get-ok
 181         quit get-ok
 182     ] with-smtp-connection ;
 183 PRIVATE>
 184
 185 : send-email ( email -- )
 186     [ email>headers ] keep (send-email) ;