extra/smtp/smtp.factor

   1 ! Copyright (C) 2007 Elie CHAFTARI
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 !
   4 ! cram-md5 auth code contributed by Dirk Vleugels <dvl@2scale.net>
   5
   6 USING: alien alien.c-types combinators crypto.common crypto.hmac base64
   7 kernel io io.sockets namespaces sequences splitting ;
   8
   9 IN: smtp
  10
  11 ! =========================================================
  12 ! smtp.factor implementation
  13 ! =========================================================
  14
  15 ! Connection default values
  16 : default-port  25                      ; inline
  17 : read-timeout  60000                   ; inline
  18 : esmtp         t                       ; inline ! t = ehlo
  19 : domain        "localhost.localdomain" ; inline
  20
  21 SYMBOL: sess
  22 SYMBOL: conn
  23 SYMBOL: challenge
  24
  25 TUPLE: session address port timeout domain esmtp ;
  26
  27 : <session> ( address -- session )
  28     default-port read-timeout domain esmtp
  29     session construct-boa ;
  30
  31 ! =========================================================
  32 ! Initialization routines
  33 ! =========================================================
  34
  35 : initialize ( address -- )
  36     <session> sess set ;
  37
  38 : set-port ( port -- )
  39     sess get set-session-port ;
  40
  41 : set-read-timeout ( timeout -- )
  42     sess get set-session-timeout ;
  43
  44 : set-esmtp ( esmtp -- )
  45     sess get set-session-esmtp ;
  46
  47 : set-domain ( -- )
  48     host-name sess get set-session-domain ;
  49
  50 : do-start ( -- )
  51     sess get [ session-address ] keep session-port <inet> <client>
  52     dup conn set [ sess get session-timeout swap set-timeout ]
  53     keep stream-readln print ;
  54
  55 ! =========================================================
  56 ! Command routines
  57 ! =========================================================
  58
  59 : check-response ( response -- )
  60     {
  61         { [ dup "220" head? ] [ print ] }
  62         { [ dup "235" swap subseq? ] [ print ] }
  63         { [ dup "250" head? ] [ print ] }
  64         { [ dup "221" head? ] [ print ] }
  65         { [ dup "bye" head? ] [ print ] }
  66         { [ dup "4" head? ] [ "server busy" throw ] }
  67         { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] }
  68         { [ dup "354" head? ] [ print ] }
  69         { [ dup "50" head? ] [ print "syntax error" throw ] }
  70         { [ dup "53" head? ] [ print "invalid authentication data" throw ] }
  71         { [ dup "55" head? ] [ print "fatal error" throw ] }
  72         { [ t ] [ "unknow error" throw ] }
  73     } cond ;
  74
  75 SYMBOL: multiline
  76
  77 : multiline? ( response -- boolean )
  78     CHAR: - swap index 3 = ;
  79
  80 : process-multiline ( -- response )
  81     conn get stream-readln dup
  82     multiline get " " append head? [
  83         print
  84     ] [
  85         check-response process-multiline
  86     ] if ;
  87
  88 : recv-response ( -- response )
  89     conn get stream-readln
  90     dup multiline? [
  91         dup 3 head multiline set process-multiline
  92     ] [ ] if ;
  93
  94 : get-ok ( command -- )
  95     >r conn get r> over stream-write stream-flush
  96     recv-response check-response ;
  97
  98 : helo ( -- )
  99     "HELO " sess get session-domain append "\r\n" append get-ok ;
 100
 101 : ehlo ( -- )
 102     "EHLO " sess get session-domain append "\r\n" append get-ok ;
 103
 104 : mailfrom ( fromaddr -- )
 105     "MAIL FROM:<" swap append ">\r\n" append get-ok ;
 106
 107 : rcptto ( to -- )
 108     "RCPT TO:<" swap append ">\r\n" append get-ok ;
 109
 110 : (cram-md5-auth) ( -- response )
 111     swap challenge get
 112     string>md5-hmac hex-string
 113     " " swap append append
 114     >base64 ;
 115
 116 : cram-md5-auth ( key login  -- )
 117     "AUTH CRAM-MD5\r\n" get-ok
 118     (cram-md5-auth) "\r\n" append get-ok ;
 119
 120 : data ( -- )
 121     "DATA\r\n" get-ok ;
 122
 123 : start ( -- )
 124     set-domain ! replaces localhost.localdomain with hostname
 125     do-start
 126     sess get session-esmtp [
 127         ehlo
 128     ] [
 129         helo
 130     ] if ;
 131
 132 : send-message ( msg -- )
 133     data
 134     "\r\n" join conn get swap "\r\n" append over stream-write
 135     stream-flush ".\r\n" get-ok ;
 136
 137 : quit ( -- )
 138     "QUIT\r\n" get-ok ;