From bb0d46c4f46a5717ed8083abebece89112a99e00 Mon Sep 17 00:00:00 2001
From: Tim Vaughan <tgvaughan@gmail.com>
Date: Mon, 2 Sep 2019 15:34:20 +0200
Subject: [PATCH] Implementing AUTH PLAIN authentication.

---
 lambdamail.scm | 35 ++++++++++++++++-------------------
 1 file changed, 16 insertions(+), 19 deletions(-)

diff --git a/lambdamail.scm b/lambdamail.scm
index cffc81f..1e9fb4d 100644
--- a/lambdamail.scm
+++ b/lambdamail.scm
@@ -14,7 +14,7 @@
         (chicken process-context)
         (chicken process-context posix)
         (chicken condition)
-        srfi-1 srfi-13)
+        srfi-1 srfi-13 matchable)
 
 (define lambdamail-version "0.0.1")
 
@@ -28,17 +28,19 @@
 ;;; SMTP transactions
 ;;
 
-(define ((make-smtp in-port out-port config) type)
-  (if (eq? type 'get-line)
+(define ((make-smtp in-port out-port config) . msg)
+  (if (equal? msg '(get-line))
       (read-line in-port)
       (write-line (conc
-                   (case type
-                     ((greeting) (conc "220 " (config-host config)
+                   (match msg
+                     (('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"))
+                     (('ok) "250 ok")
+                     (('ehlo host) (conc "250-" (config-host config) " Hello " host "\r\n"
+                                    "250 AUTH PLAIN"))
+                     (('intermediate) "354 intermediate")
+                     (('close) "221 closing transmission channel")
+                     (('not-implemented) "502 command not implemented"))
                    "\r") out-port)))
 
 
@@ -90,12 +92,15 @@
              (line-orig (smtp 'get-line)))
     (if (string? line-orig)
         (let ((line (string-downcase line-orig)))
-          (print "got " line)
+          (print "got " line-orig)
           (cond
            ((string-prefix? "helo" line)
             (message-helo-set! msg (string-drop line (string-length "helo")))
             (smtp 'ok)
             (loop msg (smtp 'get-line)))
+           ((string-prefix? "ehlo" line)
+            (smtp 'ehlo (string-drop line (+ 1 (string-length "ehlo"))))
+            (loop msg (smtp 'get-line)))
            ((string-prefix? "mail from:" line)
             (message-from-set! msg (string-drop line (string-length "mail from:")))
             (smtp 'ok)
@@ -142,14 +147,6 @@
         (right-idx (substring-index ">" addr)))
     (substring addr (+ left-idx 1) right-idx)))
 
-(define (deliver-message-mbox msg dest-file)
-  (print "Delivering to mbox " dest-file)
-  (with-output-to-file dest-file
-    (lambda ()
-      (print "\nFrom " (remove-angle-brackets (message-from msg)))
-      (print (message-text msg)))
-    #:append))
-
 (define (deliver-message-maildir msg dest-dir)
   (print "Delivering to maildir " dest-dir)
   (with-output-to-file (conc dest-dir "/" (current-seconds))
@@ -209,7 +206,7 @@
                   (unless (null? rest-args)
                     (config-port-set! config (string->number (car rest-args)))
                     (unless (null? (cdr rest-args))
-                      (config-spool-dir-set! (cadr rest-args))))
+                      (config-spool-dir-set! config (cadr rest-args))))
                   (run-server config))))))))
 
 (main)
-- 
2.20.1