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