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)
  14         (chicken process-context)
  15         (chicken process-context posix)
  16         (chicken condition)
  17         srfi-1 srfi-13 matchable)
  18
  19 (define lambdamail-version "0.0.1")
  20
  21
  22 (define-record config
  23   host port spool-dir user group)
  24 (define-record message to from text helo)
  25 (define (make-empty-message) (make-message "" "" "" ""))
  26
  27
  28 ;;; SMTP transactions
  29 ;;
  30
  31 (define ((make-smtp in-port out-port config) . msg)
  32   (if (equal? msg '(get-line))
  33       (read-line in-port)
  34       (write-line (conc
  35                    (match msg
  36                      (('greeting) (conc "220 " (config-host config)
  37                                        " LambdaMail v" lambdamail-version))
  38                      (('ok) "250 ok")
  39                      (('ehlo host) (conc "250-" (config-host config) " Hello " host "\r\n"
  40                                     "250 AUTH PLAIN"))
  41                      (('intermediate) "354 intermediate")
  42                      (('close) "221 closing transmission channel")
  43                      (('not-implemented) "502 command not implemented"))
  44                    "\r") out-port)))
  45
  46
  47 ;;; Server initialization
  48 ;;
  49
  50 (define (drop-privs config)
  51   (let ((uid (config-user config))
  52         (gid (config-group config)))
  53     (if (not (null? gid)) ; Group first, since only root can switch groups.
  54         (set! (current-group-id) gid))
  55     (if (not (null? uid))
  56         (set! (current-user-id) uid))))
  57
  58 (define (run-server config)
  59   (set-buffering-mode! (current-output-port) #:line)
  60   (let ((listener (tcp-listen (config-port config) 10 "::")))
  61     (print "LambdaMail v" lambdamail-version
  62            " listening on port " (config-port config) " ...")
  63     (print "(Host name: " (config-host config)
  64            ", Spool dir: " (config-spool-dir config) ")")
  65     (drop-privs config)
  66     (server-loop listener config)))
  67
  68
  69 ;;; Main server loop
  70 ;;
  71
  72 (define (server-loop listener config)
  73   (let-values (((in-port out-port) (tcp-accept listener)))
  74     (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
  75       (print "Accepted connection from " remote-ip " on " (seconds->string)))
  76     (condition-case
  77         (let ((smtp (make-smtp in-port out-port config)))
  78           (smtp 'greeting)
  79           (process-smtp smtp config))
  80       (o (exn)
  81          (print-error-message o)))
  82     (print "Terminating connection.")
  83     (close-input-port in-port)
  84     (close-output-port out-port)
  85     (server-loop listener config)))
  86
  87 ;;; SMTP processing loop
  88 ;;
  89
  90 (define (process-smtp smtp config)
  91   (let loop ((msg (make-empty-message))
  92              (line-orig (smtp 'get-line)))
  93     (if (string? line-orig)
  94         (let ((line (string-downcase line-orig)))
  95           (print "got " line-orig)
  96           (cond
  97            ((string-prefix? "helo" line)
  98             (message-helo-set! msg (string-drop line (string-length "helo")))
  99             (smtp 'ok)
 100             (loop msg (smtp 'get-line)))
 101            ((string-prefix? "ehlo" line)
 102             (smtp 'ehlo (string-drop line (+ 1 (string-length "ehlo"))))
 103             (loop msg (smtp 'get-line)))
 104            ((string-prefix? "mail from:" line)
 105             (message-from-set! msg (string-drop line (string-length "mail from:")))
 106             (smtp 'ok)
 107             (loop msg (smtp 'get-line)))
 108            ((string-prefix? "rcpt to:" line)
 109             (message-to-set! msg (string-drop line (string-length "rcpt to:")))
 110             (smtp 'ok)
 111             (loop msg (smtp 'get-line)))
 112            ((string-prefix? "data" line)
 113             (smtp 'intermediate)
 114             (let text-loop ((text-line (smtp 'get-line))
 115                             (text ""))
 116               (if (string=? "." text-line)
 117                   (message-text-set! msg text)
 118                   (text-loop (smtp 'get-line)
 119                              (conc text text-line "\n"))))
 120             (process-message msg config)
 121             (smtp 'ok)
 122             (loop (make-empty-message)
 123                   (smtp 'get-line)))
 124            ((string-prefix? "quit" line)
 125             (smtp 'close)
 126             'done)
 127            ((string=? "" line)
 128             (loop msg (smtp 'get-line)))
 129            (else
 130             (smtp 'not-implemented)
 131             (loop msg (smtp 'get-line)))))
 132         'done)))
 133
 134
 135 ;;; Message delivery
 136 ;;
 137
 138 (define (get-to-addresses config)
 139   (map (lambda (p) (cons
 140                     (conc "<" (car p) "@" (config-host config) ">")
 141                     (cdr p)))
 142        (map (lambda (file) (cons (pathname-file file) file))
 143             (glob (conc (config-spool-dir config) "/*")))))
 144
 145 (define (remove-angle-brackets addr)
 146   (let ((left-idx (substring-index "<" addr))
 147         (right-idx (substring-index ">" addr)))
 148     (substring addr (+ left-idx 1) right-idx)))
 149
 150 (define (deliver-message-maildir msg dest-dir)
 151   (print "Delivering to maildir " dest-dir)
 152   (with-output-to-file (conc dest-dir "/" (current-seconds))
 153     (lambda ()
 154       (print (message-text msg)))))
 155
 156 (define (process-message msg config)
 157   (let ((dest (assoc (message-to msg) (get-to-addresses config))))
 158     (if dest
 159         (let ((dest-file (cdr dest)))
 160           (if (directory-exists? dest-file)
 161               (deliver-message-maildir msg dest-file)
 162               (deliver-message-mbox msg dest-file))
 163           (print "Message DELIVERED:"))
 164         (print "Message REJECTED:"))
 165     (print " * From: " (message-from msg))
 166     (print " * To: " (message-to msg))))
 167
 168
 169 ;;; Command line argument parsing
 170 ;;
 171
 172 (define (print-usage progname)
 173   (print "Usage:\n"
 174          progname " -h/--help\n"
 175          progname " [-u/--user UID] [-g/--group GID] hostname [[port [spooldir]]\n"
 176          "\n"
 177          "The -u and -g options can be used to set the UID and GID of the process\n"
 178          "following the creation of the TCP port listener (which often requires root)."))
 179
 180 (define (main)
 181   (let ((progname (pathname-file (car (argv))))
 182         (config (make-config "" 25 "/var/spool/mail" '() '())))
 183     (if (null? (cdr (argv)))
 184         (print-usage progname)
 185         (let loop ((args (cdr (argv))))
 186           (let ((this-arg (car args))
 187                 (rest-args (cdr args)))
 188             (if (string-prefix? "-" this-arg)
 189                 (cond
 190                  ((or (equal? this-arg "-u")
 191                       (equal? this-arg "--user"))
 192                   (config-user-set! config (string->number (car rest-args)))
 193                   (loop (cdr rest-args)))
 194                  ((or (equal? this-arg "-g")
 195                       (equal? this-arg "--group"))
 196                   (config-group-set! config (string->number (car rest-args)))
 197                   (loop (cdr rest-args)))
 198                  ((or (equal? this-arg "-h")
 199                       (equal? this-arg "--help"))
 200                   (print-usage progname))
 201                  (else
 202                   (print "Unknown option " this-arg "\n")
 203                   (print-usage progname)))
 204                 (begin
 205                   (config-host-set! config this-arg)
 206                   (unless (null? rest-args)
 207                     (config-port-set! config (string->number (car rest-args)))
 208                     (unless (null? (cdr rest-args))
 209                       (config-spool-dir-set! config (cadr rest-args))))
 210                   (run-server config))))))))
 211
 212 (main)
 213
 214 ;; (run-server (make-config "thelambdalab.xyz" 2525 "/var/spool/mail"))