X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=lambdamail.git;a=blobdiff_plain;f=lambdamail.scm;h=a2fd01d5f1bc95dedae12f1bab762987adc0372b;hp=c3a68c1a2f37c97711015f4818a06ab64e3a7ede;hb=d65171f4b3d1734ee7d13884cdb9da9ba99a3f7c;hpb=716c2b0f7ffa6e8b0821d3b293a20154fd9e3f3a diff --git a/lambdamail.scm b/lambdamail.scm index c3a68c1..a2fd01d 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -17,7 +17,7 @@ (chicken sort) srfi-1 srfi-13 matchable base64) -(define lambdamail-version "LambdaMail v1.2.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 () @@ -277,9 +289,15 @@ (define ((make-outgoing-smtp-session tcp-in tcp-out) . command) (match command (('expect codes ...) - (let ((result (read-line tcp-in))) - (print "Expecting one of " codes " got " result) - (or-list (map (lambda (code) (string-prefix? code result)) codes)))) + (let loop ((result (read-line tcp-in))) + (if (and (> (string-length result) 3) + (eq? (string-ref result 3) #\-)) + (loop (read-line tcp-in)) ;status continues on next line + (begin + (print "Expecting one of " codes " got " result) + (or-list (map (lambda (code) + (string-prefix? code result)) + codes)))))) (('send strings ...) (print "Sending " (if (> (string-length (car strings)) 30) (string-take (car strings) 30) @@ -343,4 +361,6 @@ (main) ;; (define (test) - ;; (run-server (make-config "localhost" 2525 "spool" '() '()))) +;; (run-server (make-config "localhost" 2525 "spool" '() '()))) + +;; (test)