From: Tim Vaughan <tgvaughan@gmail.com>
Date: Tue, 20 Aug 2019 07:54:47 +0000 (+0200)
Subject: Added exception handling.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=e7fc7be3229edbabaaf43259591e6ac8d1c89cc5;p=lambdamail.git

Added exception handling.
---

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"))