lambdamail.scm

   1 ;; Super-basic bell-and-whistle-free SMTP server.
   2 ;;
   3 ;; Intended for a single-user system
   4
   5 (import tcp6
   6         (chicken port)
   7         (chicken io)
   8         (chicken string)
   9         (chicken pathname)
  10         (chicken file)
  11         (chicken time posix)
  12         (chicken process-context)
  13         srfi-1 srfi-13 matchable)
  14
  15 (define lambdamail-version "0.0.1")
  16
  17 (define-record config port)
  18 (define-record message to from text helo)
  19 (define (make-empty-message) (make-message "" "" "" ""))
  20
  21 (define (run-server config)
  22   (set-buffering-mode! (current-output-port) #:line)
  23   (let ((listener (tcp-listen (config-port config) 10 "::")))
  24     (print "LambdaMail listening on port " (config-port config) " ...")
  25     (server-loop listener config)))
  26
  27 (define (server-loop listener config)
  28   (let-values (((in-port out-port) (tcp-accept listener)))
  29     (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
  30       (print "Accepted connection from " remote-ip " on " (seconds->string)))
  31     (smtp-greeting out-port)
  32     (process-smtp in-port out-port)
  33     (print "Connection terminated.")
  34     (close-input-port in-port)
  35     (close-output-port out-port))
  36   (server-loop listener config))
  37
  38 (define (smtp-reply reply out-port)
  39   (write-line (conc reply "\r") out-port))
  40
  41 (define (smtp-greeting out-port)
  42   (smtp-reply (conc "220 thelambdalab.xyz LambdaMail v" lambdamail-version) out-port))
  43
  44 (define (smtp-ok out-port)
  45   (smtp-reply "250 OK" out-port))
  46
  47 (define (smtp-intermediate out-port)
  48   (smtp-reply "354 Intermediate" out-port))
  49
  50 (define (smtp-close out-port)
  51   (smtp-reply "221 Closing transmission channel" out-port))
  52
  53 (define (smtp-no out-port)
  54   (smtp-reply "502 Command not implemented" out-port))
  55
  56 (define (process-smtp in-port out-port)
  57   (let loop ((msg (make-empty-message))
  58              (line-orig (read-line in-port)))
  59     (if (string? line-orig)
  60         (let ((line (string-downcase line-orig)))
  61           (cond
  62            ((string-prefix? "helo" line)
  63             (message-helo-set! msg (string-drop line (string-length "helo")))
  64             (print "got " line)
  65             (smtp-ok out-port)
  66             (loop msg (read-line in-port)))
  67            ((string-prefix? "mail from:" line)
  68             (print "got " line)
  69             (message-from-set! msg (string-drop line (string-length "mail from:")))
  70             (smtp-ok out-port)
  71             (loop msg (read-line in-port)))
  72            ((string-prefix? "rcpt to:" line)
  73             (print "got " line)
  74             (message-to-set! msg (string-drop line (string-length "rcpt to:")))
  75             (smtp-ok out-port)
  76             (loop msg (read-line in-port)))
  77            ((string-prefix? "data" line)
  78             (print "got " line)
  79             (smtp-intermediate out-port)
  80             (let text-loop ((text-line (read-line in-port))
  81                             (text ""))
  82               (print "Received '" text-line "'")
  83               (if (string=? "." text-line)
  84                   (message-text-set! msg text)
  85                   (text-loop (read-line in-port)
  86                              (conc text text-line))))
  87             (deliver-message msg)
  88             (smtp-ok out-port)
  89             (loop (make-empty-message)
  90                   (read-line in-port)))
  91            ((string-prefix? "quit" line)
  92             (smtp-close out-port)
  93             'done)
  94            ((string=? "" line)
  95             (loop msg (read-line in-port)))
  96            (else
  97             (smtp-no out-port)
  98             (print "got " line)
  99             (loop msg (read-line in-port)))))
 100         'done)))
 101
 102 (define (deliver-message msg)
 103   (print "Message delivered:")
 104   (print " * From: " (message-from msg))
 105   (print " * To: " (message-to msg))
 106   (print " * Text: " (message-text msg)))
 107
 108 (run-server (make-config 25))