Implemented authentication for remote delivery.

diff --git a/lambdamail.scm b/lambdamail.scm
index fe9519e..55398dc 100644 (file)
--- a/lambdamail.scm
+++ b/lambdamail.scm
@@ -148,7 +148,7 @@
           (loop msg received-messages)))))))
 
 
-;;; Delivering messages
+;;; Sending/Delivering messages
 ;;
 
 (define (deliver-messages config messages)
@@ -156,34 +156,51 @@
   (filter (lambda (msg) (not (deliver-message msg config)))
           messages))
 
-(define (get-to-addresses config)
+(define (get-local-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)))
+       (map (lambda (file)
+              (list (pathname-file file) file
+                    (let ((password-file (conc file ".auth")))
+                      (if (file-exists? password-file)
+                          (with-input-from-file password-file read-line)
+                          #f))))
+            (filter directory-exists?
+                    (glob (conc (config-spool-dir config) "/*"))))))
 
 (define (deliver-message-local msg dest-dir)
-  (print "Delivering to maildir " dest-dir)
   (with-output-to-file (conc dest-dir "/" (current-seconds))
     (lambda ()
       (print (message-text msg)))))
 
+(define (deliver-message-remote msg)
+  (print "TODO"))
+
 (define (deliver-message msg config)
-  (let ((dest (assoc (message-to msg) (get-to-addresses config))))
-    (if dest
-        (let ((dest-file (cdr dest)))
-          (if (directory-exists? dest-file)
-              (deliver-message-local msg dest-file))
-          (print "Message DELIVERED:"))
-        (print "Message REJECTED:"))
-    (print " * From: " (message-from msg))
-    (print " * To: " (message-to msg)))
+  (let* ((local-addresses (get-local-addresses config))
+         (dest (assoc (message-to msg) local-addresses))
+         (orig (assoc (message-from msg) local-addresses)))
+    (cond
+     (dest
+      (let ((dest-dir (cadr dest)))
+        (deliver-message-local msg dest-file))
+      (print "Message DELIVERED (local):"))
+     (orig
+      (let ((password (caddr orig)))
+        (if (and
+             (string=? (conc "<" (message-user msg) "@" (config-host config) ">")
+                       (message-from msg))
+             password
+             (string=? (message-password msg) password))
+            (begin
+              (deliver-message-remote msg)
+              (print "Message DELIVERED (remote):"))
+            (print "Message DELIVERY REJECTED (auth failure):"))))
+     (else
+      (print "Message DELIVERY REJECTED (relay forbidden):"))))
+  (print " * From: " (message-from msg))
+  (print " * To: " (message-to msg))
   #t)
 
 
@@ -232,4 +249,5 @@
 
 (main)
 
-;; (run-server (make-config "thelambdalab.xyz" 2525 "/var/spool/mail"))
+;; (define (test)
+;;   (run-server (make-config "localhost" 2525 "spool" '() '())))