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