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