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