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