extra/smtp/smtp.factor

   1 ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
   2 ! Slava Pestov.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: namespaces io io.timeouts kernel logging io.sockets
   5 sequences combinators sequences.lib splitting assocs strings
   6 math.parser random system calendar io.encodings.ascii
   7 calendar.format accessors sets ;
   8 IN: smtp
   9
  10 SYMBOL: smtp-domain
  11 SYMBOL: smtp-server     "localhost" "smtp" <inet> smtp-server set-global
  12 SYMBOL: read-timeout    1 minutes 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         read-timeout get timeouts
  23         call
  24     ] with-client ; inline
  25
  26 : crlf ( -- ) "\r\n" write ;
  27
  28 : command ( string -- ) write crlf flush ;
  29
  30 : helo ( -- )
  31     esmtp get "EHLO " "HELO " ? host-name append command ;
  32
  33 : validate-address ( string -- string' )
  34     #! Make sure we send funky stuff to the server by accident.
  35     dup "\r\n>" intersect empty?
  36     [ "Bad e-mail address: " prepend throw ] unless ;
  37
  38 : mail-from ( fromaddr -- )
  39     "MAIL FROM:<" swap validate-address ">" 3append command ;
  40
  41 : rcpt-to ( to -- )
  42     "RCPT TO:<" swap validate-address ">" 3append command ;
  43
  44 : data ( -- )
  45     "DATA" command ;
  46
  47 : validate-message ( msg -- msg' )
  48     "." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
  49
  50 : send-body ( body -- )
  51     string-lines
  52     validate-message
  53     [ write crlf ] each
  54     "." command ;
  55
  56 : quit ( -- )
  57     "QUIT" command ;
  58
  59 LOG: smtp-response DEBUG
  60
  61 : check-response ( response -- )
  62     {
  63         { [ dup "220" head? ] [ smtp-response ] }
  64         { [ dup "235" swap subseq? ] [ smtp-response ] }
  65         { [ dup "250" head? ] [ smtp-response ] }
  66         { [ dup "221" head? ] [ smtp-response ] }
  67         { [ dup "bye" head? ] [ smtp-response ] }
  68         { [ dup "4" head? ] [ "server busy" throw ] }
  69         { [ dup "354" head? ] [ smtp-response ] }
  70         { [ dup "50" head? ] [ smtp-response "syntax error" throw ] }
  71         { [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] }
  72         { [ dup "55" head? ] [ smtp-response "fatal error" throw ] }
  73         [ "unknown error" throw ]
  74     } cond ;
  75
  76 : multiline? ( response -- boolean )
  77     ?fourth CHAR: - = ;
  78
  79 : process-multiline ( multiline -- response )
  80     >r readln r> 2dup " " append head? [
  81         drop dup smtp-response
  82     ] [
  83         swap check-response process-multiline
  84     ] if ;
  85
  86 : receive-response ( -- response )
  87     readln
  88     dup multiline? [ 3 head process-multiline ] when ;
  89
  90 : get-ok ( -- ) receive-response check-response ;
  91
  92 : validate-header ( string -- string' )
  93     dup "\r\n" intersect empty?
  94     [ "Invalid header string: " prepend throw ] unless ;
  95
  96 : write-header ( key value -- )
  97     swap
  98     validate-header write
  99     ": " write
 100     validate-header write
 101     crlf ;
 102
 103 : write-headers ( assoc -- )
 104     [ write-header ] assoc-each ;
 105
 106 TUPLE: email from to subject headers body ;
 107
 108 M: email clone
 109     call-next-method [ clone ] change-headers ;
 110
 111 : (send) ( email -- )
 112     [
 113         helo get-ok
 114         dup from>> mail-from get-ok
 115         dup to>> [ rcpt-to get-ok ] each
 116         data get-ok
 117         dup headers>> write-headers
 118         crlf
 119         body>> send-body get-ok
 120         quit get-ok
 121     ] with-smtp-connection ;
 122
 123 : extract-email ( recepient -- email )
 124     #! This could be much smarter.
 125     " " last-split1 swap or "<" ?head drop ">" ?tail drop ;
 126
 127 : message-id ( -- string )
 128     [
 129         "<" %
 130         64 random-bits #
 131         "-" %
 132         millis #
 133         "@" %
 134         smtp-domain get [ host-name ] unless* %
 135         ">" %
 136     ] "" make ;
 137
 138 : set-header ( email value key -- email )
 139     pick headers>> set-at ;
 140
 141 : prepare ( email -- email )
 142     clone
 143     dup from>> "From" set-header
 144     [ extract-email ] change-from
 145     dup to>> ", " join "To" set-header
 146     [ [ extract-email ] map ] change-to
 147     dup subject>> "Subject" set-header
 148     now timestamp>rfc822 "Date" set-header
 149     message-id "Message-Id" set-header ;
 150
 151 : <email> ( -- email )
 152     email new
 153     H{ } clone >>headers ;
 154
 155 : send-email ( email -- )
 156     prepare (send) ;
 157
 158 ! Dirk's old AUTH CRAM-MD5 code. I don't know anything about
 159 ! CRAM MD5, and the old code didn't work properly either, so here
 160 ! it is in case anyone wants to fix it later.
 161 !
 162 ! check-response used to have this clause:
 163 ! { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] }
 164 !
 165 ! and the rest of the code was as follows:
 166 ! : (cram-md5-auth) ( -- response )
 167 !     swap challenge get
 168 !     string>md5-hmac hex-string
 169 !     " " prepend append
 170 !     >base64 ;
 171 !
 172 ! : cram-md5-auth ( key login  -- )
 173 !     "AUTH CRAM-MD5\r\n" get-ok
 174 !     (cram-md5-auth) "\r\n" append get-ok ;
 175
 176 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!