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 "LambdaMail v0.0.1")
  20
  21 (define-record config host port spool-dir user group)
  22 (define-record message to from text user password)
  23 (define (make-empty-message) (make-message "" "" "" "" ""))
  24
  25 (define (time-stamp)
  26   (time->string (seconds->local-time) "%d %b %Y %T %z"))
  27
  28
  29 ;;; Server initialization
  30 ;;
  31
  32 (define (drop-privs config)
  33   (let ((uid (config-user config))
  34         (gid (config-group config)))
  35     (if (not (null? gid)) ; Group first, since only root can switch groups.
  36         (set! (current-group-id) gid))
  37     (if (not (null? uid))
  38         (set! (current-user-id) uid))))
  39
  40 (define (run-server config)
  41   (set-buffering-mode! (current-output-port) #:line)
  42   (let ((listener (tcp-listen (config-port config) 10 "::")))
  43     (print lambdamail-version
  44            " listening on port " (config-port config) " ...")
  45     (print "(Host name: " (config-host config)
  46            ", Spool dir: " (config-spool-dir config) ")")
  47     (drop-privs config)
  48     (server-loop listener config '())))
  49
  50
  51 ;;; Main server loop
  52 ;;
  53
  54 (define (server-loop listener config undelivered-messages)
  55   (let* ((messages (append (receive-messages listener config) undelivered-messages)))
  56     (server-loop listener config (deliver-messages config messages))))
  57
  58
  59 ;;; Receiving messages
  60 ;;
  61
  62 (define (receive-messages listener config)
  63   (let ((messages '()))
  64     (let-values (((in-port out-port) (tcp-accept listener)))
  65       (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
  66         (print "Accepted connection from " remote-ip " on " (time-stamp)))
  67       (condition-case
  68           (set! messages (process-smtp (make-smtp-session in-port out-port config) config))
  69         (o (exn)
  70            (print-error-message o)))
  71       (print "Terminating connection.")
  72       (close-input-port in-port)
  73       (close-output-port out-port))
  74     messages))
  75
  76 (define (make-smtp-session in-port out-port config)
  77   (let ((user "")
  78         (password "")
  79         (helo ""))
  80     (lambda command
  81       (match command
  82         (('get-line) (read-line in-port))
  83         (('send strings ...) (write-line (conc (apply conc strings) "\r") out-port))
  84         (('set-user! u) (set! user u))
  85         (('set-password! p) (set! password p))
  86         (('set-helo! h) (set! helo h))
  87         (('user) user)
  88         (('password) password)
  89         (('helo) helo)))))
  90
  91 (define (smtp-command? cmd-string input-string)
  92   (string-prefix? cmd-string (string-downcase input-string)))
  93
  94 (define (smtp-command-args cmd-string input-string)
  95   (if (> (string-length input-string) (string-length cmd-string))
  96       (string-trim (string-drop input-string (string-length cmd-string)))
  97       ""))
  98
  99 (define (process-smtp smtp-session config)
 100   (smtp-session 'send "220 " (config-host config) " " lambdamail-version)
 101   (let loop ((msg (make-empty-message))
 102              (received-messages '()))
 103     (let ((line (smtp-session 'get-line)))
 104       (when (string? line)
 105         (print "got " line)
 106         (cond
 107          ((smtp-command? "helo" line)
 108           (smtp-session 'set-helo! (smtp-command-args "helo" line))
 109           (smtp-session 'send "250 ok")
 110           (loop msg received-messages))
 111          ((smtp-command? "ehlo" line)
 112           (smtp-session 'set-helo! (smtp-command-args "helo" line))
 113           (smtp-session 'send
 114                         "250-" (config-host config)
 115                         " Hello " (smtp-command-args "ehlo" line))
 116           (smtp-session 'send "250 AUTH PLAIN")
 117           ;; (smtp-session 'send "250 STARTTLS")
 118           (loop msg received-messages))
 119          ((smtp-command? "auth plain" line)
 120           (let* ((auth-string (smtp-command-args "auth plain" line))
 121                  (auth-decoded (base64-decode auth-string))
 122                  (auth-list (string-split auth-decoded "\x00"))
 123                  (user (car auth-list))
 124                  (password (cadr auth-list)))
 125             (smtp-session 'set-user! user)
 126             (smtp-session 'set-password! password)
 127             (print "Attempted login, user: " user ", password: " password)
 128             (smtp-session 'send "235 authentication successful")
 129             (loop msg received-messages)))
 130          ((smtp-command? "mail from:" line)
 131           (message-from-set! msg (smtp-command-args "mail from:" line))
 132           (smtp-session 'send "250 ok")
 133           (loop msg received-messages))
 134          ((smtp-command? "rcpt to:" line)
 135           (message-to-set! msg (smtp-command-args "rcpt to:" line))
 136           (smtp-session 'send "250 ok")
 137           (loop msg received-messages))
 138          ((smtp-command? "data" line)
 139           (smtp-session 'send "354 intermediate")
 140           (let text-loop ((text (conc "Received: from " (smtp-session 'helo) "\n"
 141                                       "   by " (config-host config) "\n"
 142                                       "   for " (message-from msg)
 143                                       "; " (time-stamp) "\n")))
 144             (let ((text-line (smtp-session 'get-line)))
 145               (if (string=? "." text-line)
 146                   (message-text-set! msg text)
 147                   (text-loop (conc text text-line "\n")))))
 148           (message-user-set! msg (smtp-session 'user))
 149           (message-password-set! msg (smtp-session 'password))
 150           (smtp-session 'send "250 ok")
 151           (loop (make-empty-message) (cons msg received-messages)))
 152          ((smtp-command? "quit" line)
 153           (smtp-session 'send "221 closing transmission channel")
 154           received-messages)
 155          ((string=? "" (string-trim line))
 156           (loop msg received-messages))
 157          (else
 158           (smtp-session 'send "502 command not implemented")
 159           (loop msg received-messages)))))))
 160
 161
 162 ;;; Sending/Delivering messages
 163 ;;
 164
 165 (define (deliver-messages config messages)
 166   (print "\n"
 167          "**** Attempting delivery of " (length messages) " mail items.")
 168   (filter (lambda (msg) (not (deliver-message msg config)))
 169           messages))
 170
 171 (define (deliver-message msg config)
 172   (condition-case
 173       (begin
 174         (let* ((local-addresses (get-local-addresses config))
 175                (dest (assoc (message-to msg) local-addresses))
 176                (orig (assoc (message-from msg) local-addresses)))
 177           (cond
 178            (dest
 179             (let ((dest-dir (cadr dest)))
 180               (deliver-message-local msg dest-file))
 181             (print "Message DELIVERED (local):"))
 182            (orig
 183             (let ((password (caddr orig)))
 184               (if (and
 185                    (string=? (conc "<" (message-user msg) "@" (config-host config) ">")
 186                              (message-from msg))
 187                    password
 188                    (string=? (message-password msg) password))
 189                   (begin
 190                     (deliver-message-remote msg config)
 191                     (print "Message DELIVERED (remote):"))
 192                   (print "Message REMOTE DELIVERY REJECTED (auth failure):"))))
 193            (else
 194             (print "Message REMOTE DELIVERY REJECTED (relay forbidden):"))))
 195         (print " * From: " (message-from msg))
 196         (print " * To: " (message-to msg))
 197         #t)
 198     (o (exn)
 199        (print "Message delivery failed.")
 200        (print-error-message o))))
 201
 202 ;; Local delivery
 203
 204 (define (get-local-addresses config)
 205   (map (lambda (p) (cons
 206                     (conc "<" (car p) "@" (config-host config) ">")
 207                     (cdr p)))
 208        (map (lambda (file)
 209               (list (pathname-file file) file
 210                     (let ((password-file (conc file ".auth")))
 211                       (if (file-exists? password-file)
 212                           (with-input-from-file password-file read-line)
 213                           #f))))
 214             (filter directory-exists?
 215                     (glob (conc (config-spool-dir config) "/*"))))))
 216
 217 (define (deliver-message-local msg dest-dir)
 218   (with-output-to-file (conc dest-dir "/" (current-seconds))
 219     (lambda ()
 220       (print (message-text msg)))))
 221
 222
 223 ;; Remote delivery
 224
 225 (define (get-host-from-email email-string)
 226   (car (string-split (cadr (string-split email-string "@")) ">")))
 227
 228 (define (deliver-message-remote msg config)
 229   (let ((host (get-host-from-email (message-to msg))))
 230     (print "Attempting delivery to host " host)
 231     (let-values (((tcp-in tcp-out) (tcp-connect host 25)))
 232       (let ((smtp-session (make-outgoing-smtp-session tcp-in tcp-out)))
 233         (let ((result (and
 234                        (smtp-session 'expect "220")
 235                        (smtp-session 'send "helo " (config-host config))
 236                        (smtp-session 'expect "250")
 237                        (smtp-session 'send "mail from:" (message-from msg))
 238                        (smtp-session 'expect "250")
 239                        (smtp-session 'send "rcpt to:" (message-to msg))
 240                        (smtp-session 'expect "250")
 241                        (smtp-session 'send "data")
 242                        (smtp-session 'expect "354")
 243                        (smtp-session 'send (message-text msg))
 244                        (smtp-session 'send ".")
 245                        (smtp-session 'expect "250")
 246                        (smtp-session 'send "quit"))))
 247           (close-input-port tcp-in)
 248           (close-output-port tcp-out)
 249           result)))))
 250
 251 (define ((make-outgoing-smtp-session tcp-in tcp-out) . command)
 252   (match command
 253     (('expect code)
 254      (let ((result (read-line tcp-in)))
 255        (print "Expecting " code " got " result)
 256        (string-prefix? code result)))
 257     (('send strings ...)
 258      (print "Sending " (if (> (string-length (car strings)) 30)
 259                            (string-take (car strings) 30)
 260                            (car strings)))
 261      (let ((processed-string
 262             (string-translate* (conc (apply conc strings) "\n")
 263                                '(("\n" . "\r\n")))))
 264        (write-string processed-string #f tcp-out)))))
 265
 266 ;;; Command line argument parsing
 267 ;;
 268
 269 (define (print-usage progname)
 270   (print "Usage:\n"
 271          progname " -h/--help\n"
 272          progname " [-u/--user UID] [-g/--group GID] hostname [[port [spooldir]]\n"
 273          "\n"
 274          "The -u and -g options can be used to set the UID and GID of the process\n"
 275          "following the creation of the TCP port listener (which often requires root)."))
 276
 277 (define (main)
 278   (let ((progname (pathname-file (car (argv))))
 279         (config (make-config "" 25 "/var/spool/mail" '() '())))
 280     (if (null? (cdr (argv)))
 281         (print-usage progname)
 282         (let loop ((args (cdr (argv))))
 283           (let ((this-arg (car args))
 284                 (rest-args (cdr args)))
 285             (if (string-prefix? "-" this-arg)
 286                 (cond
 287                  ((or (equal? this-arg "-u")
 288                       (equal? this-arg "--user"))
 289                   (config-user-set! config (string->number (car rest-args)))
 290                   (loop (cdr rest-args)))
 291                  ((or (equal? this-arg "-g")
 292                       (equal? this-arg "--group"))
 293                   (config-group-set! config (string->number (car rest-args)))
 294                   (loop (cdr rest-args)))
 295                  ((or (equal? this-arg "-h")
 296                       (equal? this-arg "--help"))
 297                   (print-usage progname))
 298                  (else
 299                   (print "Unknown option " this-arg "\n")
 300                   (print-usage progname)))
 301                 (begin
 302                   (config-host-set! config this-arg)
 303                   (unless (null? rest-args)
 304                     (config-port-set! config (string->number (car rest-args)))
 305                     (unless (null? (cdr rest-args))
 306                       (config-spool-dir-set! config (cadr rest-args))))
 307                   (run-server config))))))))
 308
 309 (main)
 310
 311 ;; (define (test)
 312 ;;   (run-server (make-config "localhost" 2525 "spool" '() '())))