;; Super-basic bell-and-whistle-free SMTP server. ;; ;; Intended for a single-user system (import tcp6 (chicken port) (chicken io) (chicken string) (chicken pathname) (chicken file) (chicken time) (chicken time posix) (chicken process) (chicken process-context) (chicken process-context posix) (chicken condition) (chicken sort) srfi-1 srfi-13 matchable base64) (define lambdamail-version "LambdaMail v1.1.0") (define-record config host port spool-dir user group) (define-record message to from text user password) (define (make-empty-message) (make-message "" "" "" "" "")) (define (time-stamp) (time->string (seconds->local-time) "%d %b %Y %T %z")) ;;; Server initialization ;; (define (drop-privs config) (let ((uid (config-user config)) (gid (config-group config))) (if (not (null? gid)) ; Group first, since only root can switch groups. (set! (current-group-id) gid)) (if (not (null? uid)) (set! (current-user-id) uid)))) (define (run-server config) (set-buffering-mode! (current-output-port) #:line) (let ((listener (tcp-listen (config-port config) 10 "::"))) (print lambdamail-version " listening on port " (config-port config) " ...") (print "(Host name: " (config-host config) ", Spool dir: " (config-spool-dir config) ")") (drop-privs config) (server-loop listener config '()))) ;;; Main server loop ;; (define (server-loop listener config undelivered-messages) (let* ((messages (append (receive-messages listener config) undelivered-messages))) (server-loop listener config (deliver-messages config messages)))) ;;; Receiving messages ;; (define (receive-messages listener config) (let ((messages '())) (print "*** Waiting for incoming mail") (let-values (((in-port out-port) (tcp-accept listener))) (let-values (((local-ip remote-ip) (tcp-addresses in-port))) (print "Accepted connection from " remote-ip " on " (time-stamp))) (condition-case (set! messages (process-smtp (make-smtp-session in-port out-port config) config)) (o (exn) (print-error-message o))) (print "Terminating connection.") (close-input-port in-port) (close-output-port out-port)) messages)) (define (make-smtp-session in-port out-port config) (let ((user "") (password "") (helo "")) (lambda command (match command (('get-line) (read-line in-port)) (('send strings ...) (write-line (conc (apply conc strings) "\r") out-port)) (('set-user! u) (set! user u)) (('set-password! p) (set! password p)) (('set-helo! h) (set! helo h)) (('user) user) (('password) password) (('helo) helo))))) (define (smtp-command? cmd-string input-string) (string-prefix? cmd-string (string-downcase input-string))) (define (smtp-command-args cmd-string input-string) (if (> (string-length input-string) (string-length cmd-string)) (string-trim (string-drop input-string (string-length cmd-string))) "")) (define (process-smtp smtp-session config) (smtp-session 'send "220 " (config-host config) " " lambdamail-version) (let loop ((msg (make-empty-message)) (received-messages '())) (let ((line (smtp-session 'get-line))) (print "got " line) (if (not (string? line)) '() ; Don't keep anything on unexpected termination. (cond ((smtp-command? "helo" line) (smtp-session 'set-helo! (smtp-command-args "helo" line)) (smtp-session 'send "250 ok") (loop msg received-messages)) ((smtp-command? "ehlo" line) (smtp-session 'set-helo! (smtp-command-args "helo" line)) (smtp-session 'send "250-" (config-host config) " Hello " (smtp-command-args "ehlo" line)) (smtp-session 'send "250 AUTH PLAIN") ;; (smtp-session 'send "250 STARTTLS") (loop msg received-messages)) ((smtp-command? "auth plain" line) (let* ((auth-string (smtp-command-args "auth plain" line)) (auth-decoded (base64-decode auth-string)) (auth-list (string-split auth-decoded "\x00")) (user (car auth-list)) (password (cadr auth-list))) (smtp-session 'set-user! user) (smtp-session 'set-password! password) (print "Attempted login, user: " user ", password: " password) (smtp-session 'send "235 authentication successful") (loop msg received-messages))) ((smtp-command? "mail from:" line) (message-from-set! msg (smtp-command-args "mail from:" line)) (smtp-session 'send "250 ok") (loop msg received-messages)) ((smtp-command? "rcpt to:" line) (message-to-set! msg (smtp-command-args "rcpt to:" line)) (smtp-session 'send "250 ok") (loop msg received-messages)) ((smtp-command? "data" line) (smtp-session 'send "354 intermediate") (let text-loop ((text (conc "Received: from " (smtp-session 'helo) "\n" "\tby " (config-host config) "\n" "\tfor " (message-to msg) ";\n" "\t" (time-stamp) "\n"))) (let ((text-line (smtp-session 'get-line))) (if (string=? "." text-line) (message-text-set! msg text) (text-loop (conc text text-line "\n"))))) (message-user-set! msg (smtp-session 'user)) (message-password-set! msg (smtp-session 'password)) (smtp-session 'send "250 ok") (loop (make-empty-message) (cons msg received-messages))) ((smtp-command? "quit" line) (smtp-session 'send "221 closing transmission channel") received-messages) ((string=? "" (string-trim line)) (loop msg received-messages)) (else (smtp-session 'send "502 command not implemented") (loop msg received-messages))))))) ;;; Sending/Delivering messages ;; (define (deliver-messages config messages) (print "*** Attempting delivery of " (length messages) " mail items.") (filter (lambda (msg) (not (deliver-message msg config))) messages)) (define (deliver-message msg config) (print "From: " (message-from msg)) (print "To: " (message-to msg)) (condition-case (let* ((local-addresses (get-local-addresses config)) (dest (assoc (message-to msg) local-addresses)) (orig (assoc (message-from msg) local-addresses))) (cond (dest (let ((dest-dir (cadr dest))) (deliver-message-local msg dest-dir))) (orig (let ((password (caddr orig))) (if (and (string=? (conc "<" (message-user msg) "@" (config-host config) ">") (message-from msg)) password (string=? (message-password msg) password)) (deliver-message-remote msg config) (begin (print "* REMOTE DELIVERY NOT ALLOWED (auth failure)") #t)))) (else (print "* REMOTE DELIVERY REJECTED (relay forbidden)") #t))) (o (exn) (print "* DELIVERY FAILED") (print-error-message o) #t))) ;; Local delivery (define (get-local-addresses config) (map (lambda (p) (cons (conc "<" (car p) "@" (config-host config) ">") (cdr p))) (map (lambda (file) (list (pathname-file file) file (let ((password-file (conc file ".auth"))) (if (file-exists? password-file) (with-input-from-file password-file read-line) #f)))) (filter directory-exists? (glob (conc (config-spool-dir config) "/*")))))) (define (deliver-message-local msg dest-dir) (with-output-to-file (conc dest-dir "/" (current-seconds)) (lambda () (print (message-text msg)))) (print "* MESSAGE DELIVERED (local)") #t) ;; Remote delivery (define (get-domain-from-email email-string) (car (string-split (cadr (string-split email-string "@")) ">"))) ;; This is a hack - there's no built-in interface to res_query() ;; in chicken, so we have to resort to a system call to dig... (define (get-mail-server-for-domain domain) (let* ((mx-lines (let-values (((in out id) (process (conc "dig " domain " mx +short")))) (with-input-from-port in read-lines))) (mx-entries (map (lambda (l) (let ((s (string-split l))) (list (string->number (car s)) (string-drop-right (cadr s) 1)))) ; remove trailing "." mx-lines)) (sorted-mx-entries (sort mx-entries (lambda (e f) (< (car e) (car f)))))) (if (null? sorted-mx-entries) domain ; fall-back to email address domain if no mx entries (cadar sorted-mx-entries)))) ; otherwise pick the highest priority server (define (deliver-message-remote msg config) (let* ((domain (get-domain-from-email (message-to msg))) (mail-server (get-mail-server-for-domain domain))) (print "Attempting delivery to " mail-server) (let-values (((tcp-in tcp-out) (tcp-connect mail-server 25))) (let ((smtp-session (make-outgoing-smtp-session tcp-in tcp-out))) (let ((result (and (smtp-session 'expect "220") (smtp-session 'send "helo " (config-host config)) (smtp-session 'expect "250") (smtp-session 'send "mail from:" (message-from msg)) (smtp-session 'expect "250") (smtp-session 'send "rcpt to:" (message-to msg)) (smtp-session 'expect "250") (smtp-session 'send "data") (smtp-session 'expect "354") (smtp-session 'send (message-text msg)) (smtp-session 'send ".") (smtp-session 'expect "250") (smtp-session 'send "quit")))) (close-input-port tcp-in) (close-output-port tcp-out) (print "Connection closed.") (if result (print "* MESSAGE DELIVERED (remote)") (print "* REMOTE DELIVERY FAILED (unexpected server response)")) result))))) (define ((make-outgoing-smtp-session tcp-in tcp-out) . command) (match command (('expect code) (let ((result (read-line tcp-in))) (print "Expecting " code " got " result) (string-prefix? code result))) (('send strings ...) (print "Sending " (if (> (string-length (car strings)) 30) (string-take (car strings) 30) (car strings))) (let ((processed-string (string-translate* (conc (apply conc strings) "\n") '(("\n" . "\r\n"))))) (write-string processed-string #f tcp-out))))) ;;; Command line argument parsing ;; (define (print-usage progname) (print "Usage:\n" progname " -h/--help\n" progname " -v/--version\n" progname " [-u/--user UID] [-g/--group GID] hostname [[port [spooldir]]\n" "\n" "The -u and -g options can be used to set the UID and GID of the process\n" "following the creation of the TCP port listener (which often requires root).")) (define (print-version) (print lambdamail-version)) (define (main) (let ((progname (pathname-file (car (argv)))) (config (make-config "" 25 "/var/spool/mail" '() '()))) (if (null? (cdr (argv))) (print-usage progname) (let loop ((args (cdr (argv)))) (let ((this-arg (car args)) (rest-args (cdr args))) (if (string-prefix? "-" this-arg) (cond ((or (equal? this-arg "-u") (equal? this-arg "--user")) (config-user-set! config (string->number (car rest-args))) (loop (cdr rest-args))) ((or (equal? this-arg "-g") (equal? this-arg "--group")) (config-group-set! config (string->number (car rest-args))) (loop (cdr rest-args))) ((or (equal? this-arg "-h") (equal? this-arg "--help")) (print-usage progname)) ((or (equal? this-arg "-v") (equal? this-arg "--version")) (print-version)) (else (print "Unknown option " this-arg "\n") (print-usage progname))) (begin (config-host-set! config this-arg) (unless (null? rest-args) (config-port-set! config (string->number (car rest-args))) (unless (null? (cdr rest-args)) (config-spool-dir-set! config (cadr rest-args)))) (run-server config)))))))) (main) ;; (define (test) ;; (run-server (make-config "localhost" 2525 "spool" '() '())))