Early checking of recipient validity.

[lambdamail.git] / lambdamail.scm

diff --git a/lambdamail.scm b/lambdamail.scm
index 38f8026..a5c9b3e 100644 (file)
--- a/lambdamail.scm
+++ b/lambdamail.scm
@@ -17,7 +17,7 @@
         (chicken sort)
         srfi-1 srfi-13 matchable base64)
 
-(define lambdamail-version "LambdaMail v1.4.0")
+(define lambdamail-version "LambdaMail v1.5.0")
 
 (define-record config host port spool-dir user group)
 (define-record message to from text user password)
@@ -76,18 +76,12 @@
     messages))
 
 (define (make-smtp-session in-port out-port config)
-  (let ((user "")
-        (password "")
-        (helo ""))
+  (let ((helo ""))
     (lambda command
       (match command
         (('get-line) (read-line in-port))
         (('send strings ...) (write-line (conc (apply conc strings) "\r") out-port))
-        (('set-user! u) (set! user u))
-        (('set-password! p) (set! password p))
         (('set-helo! h) (set! helo h))
-        (('user) user)
-        (('password) password)
         (('helo) helo)))))
 
 (define (smtp-command? cmd-string input-string)
@@ -125,8 +119,8 @@
                    (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)
+              (message-user-set! msg user)
+              (message-password-set! msg password)
               (print "Attempted login, user: " user ", password: " password)
               (smtp-session 'send "235 authentication successful")
               (loop msg received-messages)))
@@ -136,7 +130,9 @@
             (loop msg received-messages))
            ((smtp-command? "rcpt to:" line)
             (message-to-set! msg (smtp-command-args "rcpt to:" line))
-            (smtp-session 'send "250 ok")
+            (if (message-valid? msg config)
+                (smtp-session 'send "250 ok")
+                (smtp-session 'send "551 relay forbidden"))
             (loop msg received-messages))
            ((smtp-command? "data" line)
             (smtp-session 'send "354 intermediate")
@@ -148,8 +144,6 @@
                 (if (string=? "." text-line)
                     (message-text-set! msg text)
                     (text-loop (conc text text-line "\n")))))
-            (message-user-set! msg (smtp-session 'user))
-            (message-password-set! msg (smtp-session 'password))
             (smtp-session 'send "250 ok")
             (loop (make-empty-message) (cons msg received-messages)))
            ((smtp-command? "quit" line)
@@ -162,6 +156,49 @@
             (loop msg received-messages)))))))
 
 
+;;; Message stamping and validation
+;;
+
+(define (get-local-addresses config)
+  (map (lambda (p) (cons
+                    (conc "<" (car p) "@" (config-host config) ">")
+                    (cdr p)))
+       (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 (message-stamp msg config)
+  (let* ((local-addresses (get-local-addresses config))
+         (local-dest (assoc (message-to msg) local-addresses))
+         (local-src (assoc (message-from msg) local-addresses)))
+    (cond
+     (local-dest
+      (list #t 'local (cadr local-dest)))
+     (local-src
+      (let ((password (caddr local-src)))
+        (if (and (string=? (conc "<" (message-user msg) "@" (config-host config) ">")
+                           (message-from msg))
+                 password
+                 (string=? (message-password msg) password))
+            (list #t 'remote)
+            (begin
+              (print "Provided password " (message-password msg))
+              (print "Host password " password)
+              (list #f 'remote)))))
+     (else
+      (list #f 'relay)))))
+
+(define (message-valid? msg config)
+  (let ((stamp (message-stamp msg config)))
+    (print "Stamp: " stamp)
+    (car stamp)))
+
+
 ;;; Sending/Delivering messages
 ;;
 
@@ -174,47 +211,22 @@
   (print "From: " (message-from msg))
   (print "To: " (message-to msg))
   (condition-case
-      (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-dir)))
-         (orig
-          (let ((password (caddr orig)))
-            (if (and (string=? (conc "<" (message-user msg) "@" (config-host config) ">")
-                               (message-from msg))
-                     password
-                     (string=? (message-password msg) password))
-                (deliver-message-remote msg config)
-                (begin
-                  (print "* REMOTE DELIVERY NOT ALLOWED (auth failure)")
-                  #t))))
-         (else
-          (print "* REMOTE DELIVERY REJECTED (relay forbidden)")
-          #t)))
+    (match (message-stamp msg config)
+      ((#t 'local dest-dir) (deliver-message-local msg dest-dir))
+      ((#t 'remote) (deliver-message-remote msg config))
+      ((#f 'remote)
+       (print "* REMOTE DELIVERY NOT ALLOWED (auth failure)")
+       #t)
+      (else
+       (print "* DELIVERY NOT ALLOWED (relay forbidden)")
+       #t))
     (o (exn)
        (print "* DELIVERY FAILED")
        (print-error-message o)
        #t)))
 
-
 ;; Local delivery
 
-(define (get-local-addresses config)
-  (map (lambda (p) (cons
-                    (conc "<" (car p) "@" (config-host config) ">")
-                    (cdr p)))
-       (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)
   (with-output-to-file (conc dest-dir "/" (current-seconds))
     (lambda ()
@@ -346,7 +358,9 @@
                       (config-spool-dir-set! config (cadr rest-args))))
                   (run-server config))))))))
 
-(main)
+;; (main)
+
+(define (test)
+  (run-server (make-config "localhost" 2525 "spool" '() '())))
 
-;; (define (test)
-  ;; (run-server (make-config "localhost" 2525 "spool" '() '())))
+;; (test)