AUTH PLAIN implementation finished.

diff --git a/lambdamail.scm b/lambdamail.scm
index 1e9fb4d..73d5773 100644 (file)
--- a/lambdamail.scm
+++ b/lambdamail.scm
@@ -14,13 +14,11 @@
         (chicken process-context)
         (chicken process-context posix)
         (chicken condition)
-        srfi-1 srfi-13 matchable)
+        srfi-1 srfi-13 matchable base64)
 
 (define lambdamail-version "0.0.1")
 
-
-(define-record config
-  host port spool-dir user group)
+(define-record config host port spool-dir user group)
 (define-record message to from text helo)
 (define (make-empty-message) (make-message "" "" "" ""))
 
@@ -28,20 +26,25 @@
 ;;; SMTP transactions
 ;;
 
-(define ((make-smtp in-port out-port config) . msg)
-  (if (equal? msg '(get-line))
-      (read-line in-port)
-      (write-line (conc
-                   (match msg
-                     (('greeting) (conc "220 " (config-host config)
-                                       " LambdaMail v" lambdamail-version))
-                     (('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)))
+(define (make-smtp-session in-port out-port config)
+  (let ((smtp-say (lambda args (write-line (conc (apply conc args) "\r") out-port)))
+        (user "")
+        (password ""))
+    (lambda msg
+      (match msg
+        (('get-line) (read-line in-port))
+        (('set-user! u) (set! user u))
+        (('set-password! p) (set! password p))
+        (('auth-success) (smtp-say "235 Authentication successful"))
+        (('greet) (smtp-say "220 " (config-host config)
+                            " LambdaMail v" lambdamail-version))
+        (('ok) (smtp-say "250 ok"))
+        (('ehlo host)
+         (smtp-say "250-" (config-host config) " Hello " host)
+         (smtp-say "250 AUTH PLAIN"))
+        (('intermediate) (smtp-say "354 intermediate"))
+        (('close) (smtp-say "221 closing transmission channel"))
+        (('not-implemented) (smtp-say "502 command not implemented"))))))
 
 
 ;;; Server initialization
@@ -74,9 +77,9 @@
     (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
       (print "Accepted connection from " remote-ip " on " (seconds->string)))
     (condition-case
-        (let ((smtp (make-smtp in-port out-port config)))
-          (smtp 'greeting)
-          (process-smtp smtp config))
+        (let ((smtp-session (make-smtp-session in-port out-port config)))
+          (smtp-session 'greet)
+          (process-smtp smtp-session config))
       (o (exn)
          (print-error-message o)))
     (print "Terminating connection.")
@@ -87,49 +90,59 @@
 ;;; SMTP processing loop
 ;;
 
-(define (process-smtp smtp config)
-  (let loop ((msg (make-empty-message))
-             (line-orig (smtp 'get-line)))
-    (if (string? line-orig)
-        (let ((line (string-downcase line-orig)))
-          (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)
-            (loop msg (smtp 'get-line)))
-           ((string-prefix? "rcpt to:" line)
-            (message-to-set! msg (string-drop line (string-length "rcpt to:")))
-            (smtp 'ok)
-            (loop msg (smtp 'get-line)))
-           ((string-prefix? "data" line)
-            (smtp 'intermediate)
-            (let text-loop ((text-line (smtp 'get-line))
-                            (text ""))
-              (if (string=? "." text-line)
-                  (message-text-set! msg text)
-                  (text-loop (smtp 'get-line)
-                             (conc text text-line "\n"))))
-            (process-message msg config)
-            (smtp 'ok)
-            (loop (make-empty-message)
-                  (smtp 'get-line)))
-           ((string-prefix? "quit" line)
-            (smtp 'close)
-            'done)
-           ((string=? "" line)
-            (loop msg (smtp 'get-line)))
-           (else
-            (smtp 'not-implemented)
-            (loop msg (smtp 'get-line)))))
-        'done)))
+(define (process-smtp smtp-session config)
+  (let loop ((msg (make-empty-message)))
+    (let ((line-orig (smtp-session 'get-line)))
+      (if (string? line-orig)
+          (let ((line (string-downcase line-orig)))
+            (print "got " line-orig)
+            (cond
+             ((string-prefix? "helo" line)
+              (message-helo-set! msg (string-drop line (string-length "helo")))
+              (smtp-session 'ok)
+              (loop msg))
+             ((string-prefix? "ehlo" line)
+              (smtp-session 'ehlo (string-drop line (+ 1 (string-length "ehlo"))))
+              (loop msg))
+             ((string-prefix? "auth plain" line)
+              (let* ((auth-string (string-drop line-orig (+ 1 (string-length "auth plain"))))
+                     (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 'auth-success)
+                (loop msg)))
+             ((string-prefix? "mail from:" line)
+              (message-from-set! msg (string-drop line (string-length "mail from:")))
+              (smtp-session 'ok)
+              (loop msg))
+             ((string-prefix? "rcpt to:" line)
+              (message-to-set! msg (string-drop line (string-length "rcpt to:")))
+              (smtp-session 'ok)
+              (loop msg))
+             ((string-prefix? "data" line)
+              (smtp-session 'intermediate)
+              (let text-loop ((text-line (smtp-session 'get-line))
+                              (text ""))
+                (if (string=? "." text-line)
+                    (message-text-set! msg text)
+                    (text-loop (smtp-session 'get-line)
+                               (conc text text-line "\n"))))
+              (process-message msg config)
+              (smtp-session 'ok)
+              (loop (make-empty-message)))
+             ((string-prefix? "quit" line)
+              (smtp-session 'close)
+              'done)
+             ((string=? "" line)
+              (loop msg))
+             (else
+              (smtp-session 'not-implemented)
+              (loop msg))))
+          'done))))
 
 
 ;;; Message delivery