basis/smtp/server/server.factor

   1 ! Copyright (C) 2007 Elie CHAFTARI
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: combinators kernel prettyprint io io.timeouts
   4 sequences namespaces io.sockets continuations calendar
   5 io.encodings.ascii io.streams.duplex destructors ;
   6 IN: smtp.server
   7
   8 ! Mock SMTP server for testing purposes.
   9
  10 ! Usage: 4321 mock-smtp-server
  11 ! $ telnet 127.0.0.1 4321
  12 ! Trying 127.0.0.1...
  13 ! Connected to localhost.
  14 ! Escape character is '^]'.
  15 ! 220 hello
  16 ! EHLO
  17 ! 220 and..?
  18 ! MAIL FROM: <here@mail.com>
  19 ! 220 OK
  20 ! RCPT TO: <there@mail.com>
  21 ! 220 OK
  22 ! Hi
  23 ! 500 ERROR
  24 ! DATA
  25 ! 354 Enter message, ending with "." on a line by itself
  26 ! Hello I am still waiting for your call
  27 ! Thanks
  28 ! .
  29 ! 220 OK
  30 ! QUIT
  31 ! bye
  32 ! Connection closed by foreign host.
  33
  34 SYMBOL: data-mode
  35
  36 : process ( -- )
  37     readln {
  38         { [ [ dup "HELO" head? ] keep "EHLO" head? or ] [
  39             "220 and..?\r\n" write flush t
  40           ] }
  41         { [ dup "QUIT" = ] [
  42             "bye\r\n" write flush f
  43           ] }
  44         { [ dup "MAIL FROM:" head? ] [
  45             "220 OK\r\n" write flush t
  46           ] }
  47         { [ dup "RCPT TO:" head? ] [
  48             "220 OK\r\n" write flush t
  49           ] }
  50         { [ dup "DATA" = ] [
  51             data-mode on
  52             "354 Enter message, ending with \".\" on a line by itself\r\n"
  53             write flush t
  54           ] }
  55         { [ dup "." = data-mode get and ] [
  56             data-mode off
  57             "220 OK\r\n" write flush t
  58           ] }
  59         { [ data-mode get ] [ dup global [ print ] bind t ] }
  60         [
  61             "500 ERROR\r\n" write flush t
  62         ]
  63     } cond nip [ process ] when ;
  64
  65 : mock-smtp-server ( port -- )
  66     "Starting SMTP server on port " write dup . flush
  67     "127.0.0.1" swap <inet4> ascii <server> [
  68         accept drop [
  69             1 minutes timeouts
  70             "220 hello\r\n" write flush
  71             process
  72             global [ flush ] bind
  73         ] with-stream
  74     ] with-disposal ;