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.1.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       (print "got " line)
 107       (if (not (string? line))
 108           '() ; Don't keep anything on unexpected termination.
 109           (cond
 110            ((smtp-command? "helo" line)
 111             (smtp-session 'set-helo! (smtp-command-args "helo" line))
 112             (smtp-session 'send "250 ok")
 113             (loop msg received-messages))
 114            ((smtp-command? "ehlo" line)
 115             (smtp-session 'set-helo! (smtp-command-args "helo" line))
 116             (smtp-session 'send
 117                           "250-" (config-host config)
 118                           " Hello " (smtp-command-args "ehlo" line))
 119             (smtp-session 'send "250 AUTH PLAIN")
 120             ;; (smtp-session 'send "250 STARTTLS")
 121             (loop msg received-messages))
 122            ((smtp-command? "auth plain" line)
 123             (let* ((auth-string (smtp-command-args "auth plain" line))
 124                    (auth-decoded (base64-decode auth-string))
 125                    (auth-list (string-split auth-decoded "\x00"))
 126                    (user (car auth-list))
 127                    (password (cadr auth-list)))
 128               (smtp-session 'set-user! user)
 129               (smtp-session 'set-password! password)
 130               (print "Attempted login, user: " user ", password: " password)
 131               (smtp-session 'send "235 authentication successful")
 132               (loop msg received-messages)))
 133            ((smtp-command? "mail from:" line)
 134             (message-from-set! msg (smtp-command-args "mail from:" line))
 135             (smtp-session 'send "250 ok")
 136             (loop msg received-messages))
 137            ((smtp-command? "rcpt to:" line)
 138             (message-to-set! msg (smtp-command-args "rcpt to:" line))
 139             (smtp-session 'send "250 ok")
 140             (loop msg received-messages))
 141            ((smtp-command? "data" line)
 142             (smtp-session 'send "354 intermediate")
 143             (let text-loop ((text (conc "Received: from " (smtp-session 'helo) "\n"
 144                                         "\tby " (config-host config) "\n"
 145                                         "\tfor " (message-to msg) ";\n"
 146                                         "\t" (time-stamp) "\n")))
 147               (let ((text-line (smtp-session 'get-line)))
 148                 (if (string=? "." text-line)
 149                     (message-text-set! msg text)
 150                     (text-loop (conc text text-line "\n")))))
 151             (message-user-set! msg (smtp-session 'user))
 152             (message-password-set! msg (smtp-session 'password))
 153             (smtp-session 'send "250 ok")
 154             (loop (make-empty-message) (cons msg received-messages)))
 155            ((smtp-command? "quit" line)
 156             (smtp-session 'send "221 closing transmission channel")
 157             received-messages)
 158            ((string=? "" (string-trim line))
 159             (loop msg received-messages))
 160            (else
 161             (smtp-session 'send "502 command not implemented")
 162             (loop msg received-messages)))))))
 163
 164
 165 ;;; Sending/Delivering messages
 166 ;;
 167
 168 (define (deliver-messages config messages)
 169   (print "*** Attempting delivery of " (length messages) " mail items.")
 170   (filter (lambda (msg) (not (deliver-message msg config)))
 171           messages))
 172
 173 (define (deliver-message msg config)
 174   (print "From: " (message-from msg))
 175   (print "To: " (message-to msg))
 176   (condition-case
 177       (let* ((local-addresses (get-local-addresses config))
 178              (dest (assoc (message-to msg) local-addresses))
 179              (orig (assoc (message-from msg) local-addresses)))
 180         (cond
 181          (dest
 182           (let ((dest-dir (cadr dest)))
 183             (deliver-message-local msg dest-dir)))
 184          (orig
 185           (let ((password (caddr orig)))
 186             (if (and (string=? (conc "<" (message-user msg) "@" (config-host config) ">")
 187                                (message-from msg))
 188                      password
 189                      (string=? (message-password msg) password))
 190                 (deliver-message-remote msg config)
 191                 (begin
 192                   (print "* REMOTE DELIVERY NOT ALLOWED (auth failure)")
 193                   #t))))
 194          (else
 195           (print "* REMOTE DELIVERY REJECTED (relay forbidden)")
 196           #t)))
 197     (o (exn)
 198        (print "* DELIVERY FAILED")
 199        (print-error-message o)
 200        #t)))
 201
 202
 203 ;; Local delivery
 204
 205 (define (get-local-addresses config)
 206   (map (lambda (p) (cons
 207                     (conc "<" (car p) "@" (config-host config) ">")
 208                     (cdr p)))
 209        (map (lambda (file)
 210               (list (pathname-file file) file
 211                     (let ((password-file (conc file ".auth")))
 212                       (if (file-exists? password-file)
 213                           (with-input-from-file password-file read-line)
 214                           #f))))
 215             (filter directory-exists?
 216                     (glob (conc (config-spool-dir config) "/*"))))))
 217
 218 (define (deliver-message-local msg dest-dir)
 219   (with-output-to-file (conc dest-dir "/" (current-seconds))
 220     (lambda ()
 221       (print (message-text msg))))
 222   (print "* MESSAGE DELIVERED (local)")
 223   #t)
 224
 225
 226 ;; Remote delivery
 227
 228 (define (get-domain-from-email email-string)
 229   (car (string-split (cadr (string-split email-string "@")) ">")))
 230
 231 ;; This is a hack - there's no built-in interface to res_query()
 232 ;; in chicken, so we have to resort to a system call to dig...
 233 (define (get-mail-server-for-domain domain)
 234   (let* ((mx-lines (let-values (((in out id) (process (conc "dig " domain " mx +short"))))
 235                      (with-input-from-port in read-lines)))
 236          (mx-entries (map (lambda (l)
 237                             (let ((s (string-split l)))
 238                               (list (string->number (car s))
 239                                     (string-drop-right (cadr s) 1)))) ; remove trailing "."
 240                           mx-lines))
 241          (sorted-mx-entries (sort mx-entries (lambda (e f) (< (car e) (car f))))))
 242     (if (null? sorted-mx-entries)
 243         domain ; fall-back to email address domain if no mx entries
 244         (cadar sorted-mx-entries)))) ; otherwise pick the highest priority server
 245
 246 (define (deliver-message-remote msg config)
 247   (let* ((domain (get-domain-from-email (message-to msg)))
 248          (mail-server (get-mail-server-for-domain domain)))
 249     (print "Attempting delivery to " mail-server)
 250     (let-values (((tcp-in tcp-out) (tcp-connect mail-server 25)))
 251       (let ((smtp-session (make-outgoing-smtp-session tcp-in tcp-out)))
 252         (let ((result (and
 253                        (smtp-session 'expect "220")
 254                        (smtp-session 'send "helo " (config-host config))
 255                        (smtp-session 'expect "250")
 256                        (smtp-session 'send "mail from:" (message-from msg))
 257                        (smtp-session 'expect "250")
 258                        (smtp-session 'send "rcpt to:" (message-to msg))
 259                        (smtp-session 'expect "250")
 260                        (smtp-session 'send "data")
 261                        (smtp-session 'expect "354")
 262                        (smtp-session 'send (message-text msg))
 263                        (smtp-session 'send ".")
 264                        (smtp-session 'expect "250")
 265                        (smtp-session 'send "quit"))))
 266           (close-input-port tcp-in)
 267           (close-output-port tcp-out)
 268           (print "Connection closed.")
 269           (if result
 270               (print "* MESSAGE DELIVERED (remote)")
 271               (print "* REMOTE DELIVERY FAILED (unexpected server response)"))
 272           result)))))
 273
 274 (define ((make-outgoing-smtp-session tcp-in tcp-out) . command)
 275   (match command
 276     (('expect code)
 277      (let ((result (read-line tcp-in)))
 278        (print "Expecting " code " got " result)
 279        (string-prefix? code result)))
 280     (('send strings ...)
 281      (print "Sending " (if (> (string-length (car strings)) 30)
 282                            (string-take (car strings) 30)
 283                            (car strings)))
 284      (let ((processed-string
 285             (string-translate* (conc (apply conc strings) "\n")
 286                                '(("\n" . "\r\n")))))
 287        (write-string processed-string #f tcp-out)))))
 288
 289
 290 ;;; Command line argument parsing
 291 ;;
 292
 293 (define (print-usage progname)
 294   (print "Usage:\n"
 295          progname " -h/--help\n"
 296          progname " [-u/--user UID] [-g/--group GID] hostname [[port [spooldir]]\n"
 297          "\n"
 298          "The -u and -g options can be used to set the UID and GID of the process\n"
 299          "following the creation of the TCP port listener (which often requires root)."))
 300
 301 (define (main)
 302   (let ((progname (pathname-file (car (argv))))
 303         (config (make-config "" 25 "/var/spool/mail" '() '())))
 304     (if (null? (cdr (argv)))
 305         (print-usage progname)
 306         (let loop ((args (cdr (argv))))
 307           (let ((this-arg (car args))
 308                 (rest-args (cdr args)))
 309             (if (string-prefix? "-" this-arg)
 310                 (cond
 311                  ((or (equal? this-arg "-u")
 312                       (equal? this-arg "--user"))
 313                   (config-user-set! config (string->number (car rest-args)))
 314                   (loop (cdr rest-args)))
 315                  ((or (equal? this-arg "-g")
 316                       (equal? this-arg "--group"))
 317                   (config-group-set! config (string->number (car rest-args)))
 318                   (loop (cdr rest-args)))
 319                  ((or (equal? this-arg "-h")
 320                       (equal? this-arg "--help"))
 321                   (print-usage progname))
 322                  (else
 323                   (print "Unknown option " this-arg "\n")
 324                   (print-usage progname)))
 325                 (begin
 326                   (config-host-set! config this-arg)
 327                   (unless (null? rest-args)
 328                     (config-port-set! config (string->number (car rest-args)))
 329                     (unless (null? (cdr rest-args))
 330                       (config-spool-dir-set! config (cadr rest-args))))
 331                   (run-server config))))))))
 332
 333 (main)
 334
 335 ;; (define (test)
 336 ;;   (run-server (make-config "localhost" 2525 "spool" '() '())))