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         (chicken condition)
  14         srfi-1 srfi-13 matchable)
  15
  16 (define lambdamail-version "0.0.1")
  17
  18
  19 (define-record config
  20   host port spool-dir)
  21 (define-record message to from text helo)
  22 (define (make-empty-message) (make-message "" "" "" ""))
  23
  24
  25 ;;; SMTP transactions
  26 ;;
  27
  28 (define ((make-smtp in-port out-port config) type)
  29   (if (eq? type 'get-line)
  30       (read-line in-port)
  31       (write-line (conc
  32                    (case type
  33                      ((greeting) (conc "220 " (config-host config)
  34                                        " LambdaMail v" lambdamail-version))
  35                      ((ok) "250 ok")
  36                      ((intermediate) "354 intermediate")
  37                      ((close) "221 closing transmission channel")
  38                      ((not-implemented) "502 command not implemented"))
  39                    "\r") out-port)))
  40
  41
  42 ;;; Server initialization
  43 ;;
  44
  45 (define (run-server config)
  46   (set-buffering-mode! (current-output-port) #:line)
  47   (let ((listener (tcp-listen (config-port config) 10 "::")))
  48     (print "LambdaMail v" lambdamail-version
  49            " listening on port " (config-port config) " ...")
  50     (print "(Host name: " (config-host config)
  51            ", Spool dir: " (config-spool-dir config) ")")
  52     (server-loop listener config)))
  53
  54
  55 ;;; Main server loop
  56 ;;
  57
  58 (define (server-loop listener config)
  59   (let-values (((in-port out-port) (tcp-accept listener)))
  60     (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
  61       (print "Accepted connection from " remote-ip " on " (seconds->string)))
  62     (condition-case
  63         (let ((smtp (make-smtp in-port out-port config)))
  64           (smtp 'greeting)
  65           (process-smtp smtp config))
  66       (o (exn)
  67          (print-error-message o)))
  68     (print "Terminating connection.")
  69     (close-input-port in-port)
  70     (close-output-port out-port)
  71     (server-loop listener config)))
  72
  73 ;;; SMTP processing loop
  74 ;;
  75
  76 (define (process-smtp smtp config)
  77   (let loop ((msg (make-empty-message))
  78              (line-orig (smtp 'get-line)))
  79     (if (string? line-orig)
  80         (let ((line (string-downcase line-orig)))
  81           (cond
  82            ((string-prefix? "helo" line)
  83             (message-helo-set! msg (string-drop line (string-length "helo")))
  84             (print "got " line)
  85             (smtp 'ok)
  86             (loop msg (smtp 'get-line)))
  87            ((string-prefix? "mail from:" line)
  88             (print "got " line)
  89             (message-from-set! msg (string-drop line (string-length "mail from:")))
  90             (smtp 'ok)
  91             (loop msg (smtp 'get-line)))
  92            ((string-prefix? "rcpt to:" line)
  93             (print "got " line)
  94             (message-to-set! msg (string-drop line (string-length "rcpt to:")))
  95             (smtp 'ok)
  96             (loop msg (smtp 'get-line)))
  97            ((string-prefix? "data" line)
  98             (print "got " line)
  99             (smtp 'intermediate)
 100             (let text-loop ((text-line (smtp 'get-line))
 101                             (text ""))
 102               (print "Received '" text-line "'")
 103               (if (string=? "." text-line)
 104                   (message-text-set! msg text)
 105                   (text-loop (smtp 'get-line)
 106                              (conc text "\n" text-line))))
 107             (deliver-message msg config)
 108             (smtp 'ok)
 109             (loop (make-empty-message)
 110                   (smtp 'get-line)))
 111            ((string-prefix? "quit" line)
 112             (smtp 'close)
 113             'done)
 114            ((string=? "" line)
 115             (loop msg (smtp 'get-line)))
 116            (else
 117             (smtp 'not-implemented)
 118             (print "got " line)
 119             (loop msg (smtp 'get-line)))))
 120         'done)))
 121
 122
 123 ;;; Message delivery
 124 ;;
 125
 126 (define (deliver-message msg config)
 127   (print "Message delivered:")
 128   (print " * From: " (message-from msg))
 129   (print " * To: " (message-to msg))
 130   (print " * Text: " (message-text msg)))
 131
 132
 133 ;;; Command line argument parsing
 134 ;;
 135
 136 (define (print-usage progname)
 137   (print "Usage: " progname " hostname [port [spooldir]]"))
 138
 139 (define (main)
 140   (let ((progname (pathname-file (car (argv))))
 141         (args (cdr (argv)))
 142         (config (make-config "" 25 "/var/spool/mail")))
 143     (if (null? args)
 144         (print-usage progname)
 145         (begin
 146           (config-host-set! config (car args))
 147           (unless (null? (cdr args))
 148             (config-port-set! config (string->number (cadr args)))
 149             (unless (null? (cddr args))
 150               (config-spool-dir-set! (caddr args))))
 151           (run-server config)))))
 152
 153 (main)
 154
 155 ;; (run-server (make-config "thelambdalab.xyz" 2525 "/var/spool/mail"))