X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=lambdamail.scm;h=1cfe6a07014599108e7c57c75331d240fad452a8;hb=928dfdbfd14f5aaca67b5b9ca166f1c62aeac6fb;hp=e4956d8bd5d0d00e8bf183fa71841766752b4aed;hpb=5c769132c51dbe2812d70db4566e5880f80a82e7;p=lambdamail.git diff --git a/lambdamail.scm b/lambdamail.scm index e4956d8..1cfe6a0 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -10,99 +10,161 @@ (chicken file) (chicken time posix) (chicken process-context) + (chicken condition) srfi-1 srfi-13 matchable) (define lambdamail-version "0.0.1") -(define-record config port) + +(define-record config + host port spool-dir) (define-record message to from text helo) (define (make-empty-message) (make-message "" "" "" "")) + +;;; SMTP transactions +;; + +(define ((make-smtp in-port out-port config) type) + (if (eq? type 'get-line) + (read-line in-port) + (write-line (conc + (case type + ((greeting) (conc "220 " (config-host config) + " LambdaMail v" lambdamail-version)) + ((ok) "250 ok") + ((intermediate) "354 intermediate") + ((close) "221 closing transmission channel") + ((not-implemented) "502 command not implemented")) + "\r") out-port))) + + +;;; Server initialization +;; + (define (run-server config) (set-buffering-mode! (current-output-port) #:line) (let ((listener (tcp-listen (config-port config) 10 "::"))) - (print "LambdaMail listening on port " (config-port config) " ...") + (print "LambdaMail v" lambdamail-version + " listening on port " (config-port config) " ...") + (print "(Host name: " (config-host config) + ", Spool dir: " (config-spool-dir config) ")") (server-loop listener config))) + +;;; Main server loop +;; + (define (server-loop listener config) (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 " (seconds->string))) - (smtp-greeting out-port) - (process-smtp in-port out-port) - (print "Connection terminated.") + (condition-case + (let ((smtp (make-smtp in-port out-port config))) + (smtp 'greeting) + (process-smtp smtp config)) + (o (exn) + (print-error-message o))) + (print "Terminating connection.") (close-input-port in-port) - (close-output-port out-port)) - (server-loop listener config)) - -(define (smtp-reply reply out-port) - (write-line reply out-port)) - -(define (smtp-greeting out-port) - (smtp-reply (conc "220 thelambdalab.xyz LambdaMail v" lambdamail-version) out-port)) - -(define (smtp-ok out-port) - (smtp-reply "250 OK" out-port)) - -(define (smtp-intermediate out-port) - (smtp-reply "354 Intermediate" out-port)) - -(define (smtp-close out-port) - (smtp-reply "221 Closing transmission channel" out-port)) + (close-output-port out-port) + (server-loop listener config))) -(define (smtp-no out-port) - (smtp-reply "502 Command not implemented" out-port)) +;;; SMTP processing loop +;; -(define (process-smtp in-port out-port) +(define (process-smtp smtp config) (let loop ((msg (make-empty-message)) - (line-orig (read-line in-port))) + (line-orig (smtp 'get-line))) (if (string? line-orig) (let ((line (string-downcase line-orig))) + (print "got " line) (cond ((string-prefix? "helo" line) (message-helo-set! msg (string-drop line (string-length "helo"))) - (print "got " line) - (smtp-ok out-port) - (loop msg (read-line in-port))) + (smtp 'ok) + (loop msg (smtp 'get-line))) ((string-prefix? "mail from:" line) - (print "got " line) (message-from-set! msg (string-drop line (string-length "mail from:"))) - (smtp-ok out-port) - (loop msg (read-line in-port))) + (smtp 'ok) + (loop msg (smtp 'get-line))) ((string-prefix? "rcpt to:" line) - (print "got " line) (message-to-set! msg (string-drop line (string-length "rcpt to:"))) - (smtp-ok out-port) - (loop msg (read-line in-port))) + (smtp 'ok) + (loop msg (smtp 'get-line))) ((string-prefix? "data" line) - (print "got " line) - (smtp-intermediate out-port) - (let text-loop ((text-line (read-line in-port)) + (smtp 'intermediate) + (let text-loop ((text-line (smtp 'get-line)) (text "")) - (print "Received '" text-line "'") (if (string=? "." text-line) (message-text-set! msg text) - (text-loop (read-line in-port) - (conc text text-line)))) - (deliver-message msg) - (smtp-ok out-port) + (text-loop (smtp 'get-line) + (conc text text-line "\n")))) + (deliver-message msg config) + (smtp 'ok) (loop (make-empty-message) - (read-line in-port))) + (smtp 'get-line))) ((string-prefix? "quit" line) - (smtp-close out-port) + (smtp 'close) 'done) ((string=? "" line) - (loop msg (read-line in-port))) + (loop msg (smtp 'get-line))) (else - (smtp-no out-port) - (print "got " line) - (loop msg (read-line in-port))))) + (smtp 'not-implemented) + (loop msg (smtp 'get-line))))) 'done))) - -(define (deliver-message msg) - (print "Message delivered:") - (print " * From: " (message-from msg)) - (print " * To: " (message-to msg)) - (print " * Text: " (message-text msg))) - -(run-server (make-config 25)) + + +;;; Message delivery +;; + +(define (get-to-addresses config) + (map (lambda (p) (cons + (conc "<" (car p) "@" (config-host config) ">") + (cdr p))) + (map (lambda (file) (cons (pathname-file file) file)) + (glob (conc (config-spool-dir config) "/*"))))) + +(define (remove-angle-brackets addr) + (let ((left-idx (substring-index "<" addr)) + (right-idx (substring-index ">" addr))) + (substring addr (+ left-idx 1) right-idx))) + +(define (deliver-message msg config) + (let ((dest (assoc (message-to msg) (get-to-addresses config)))) + (if dest + (begin + (with-output-to-file (cdr dest) + (lambda () + (print "\nFrom " (remove-angle-brackets (message-from msg))) + (print (message-text msg))) + #:append) + (print "Message DELIVERED:")) + (print "Message REJECTED:")) + (print " * From: " (message-from msg)) + (print " * To: " (message-to msg)))) + + +;;; Command line argument parsing +;; + +(define (print-usage progname) + (print "Usage: " progname " hostname [port [spooldir]]")) + +(define (main) + (let ((progname (pathname-file (car (argv)))) + (args (cdr (argv))) + (config (make-config "" 25 "/var/spool/mail"))) + (if (null? args) + (print-usage progname) + (begin + (config-host-set! config (car args)) + (unless (null? (cdr args)) + (config-port-set! config (string->number (cadr args))) + (unless (null? (cddr args)) + (config-spool-dir-set! (caddr args)))) + (run-server config))))) + +(main) + +;; (run-server (make-config "thelambdalab.xyz" 2525 "/var/spool/mail"))