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