From e7fc7be3229edbabaaf43259591e6ac8d1c89cc5 Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Tue, 20 Aug 2019 09:54:47 +0200 Subject: [PATCH] Added exception handling. --- lambdamail.scm | 135 +++++++++++++++++++++++++++++++++---------------- 1 file changed, 91 insertions(+), 44 deletions(-) diff --git a/lambdamail.scm b/lambdamail.scm index 5e714d7..ce5b188 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -10,99 +10,146 @@ (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 (conc reply "\r") 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))) (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) + (text-loop (smtp 'get-line) (conc text text-line)))) - (deliver-message msg) - (smtp-ok out-port) + (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) + (smtp 'not-implemented) (print "got " line) - (loop msg (read-line in-port))))) + (loop msg (smtp 'get-line))))) 'done))) + + +;;; Message delivery +;; -(define (deliver-message msg) +(define (deliver-message msg config) (print "Message delivered:") (print " * From: " (message-from msg)) (print " * To: " (message-to msg)) (print " * Text: " (message-text msg))) -(run-server (make-config 25)) + +;;; 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")) -- 2.20.1