(line-orig (smtp 'get-line)))
(if (string? line-orig)
(let ((line (string-downcase line-orig)))
+ (print "got " line)
(cond
((string-prefix? "helo" line)
(message-helo-set! msg (string-drop line (string-length "helo")))
- (print "got " line)
(smtp 'ok)
(loop msg (smtp 'get-line)))
((string-prefix? "mail from:" line)
- (print "got " line)
(message-from-set! msg (string-drop line (string-length "mail from:")))
(smtp 'ok)
(loop msg (smtp 'get-line)))
((string-prefix? "rcpt to:" line)
- (print "got " line)
(message-to-set! msg (string-drop line (string-length "rcpt to:")))
(smtp 'ok)
(loop msg (smtp 'get-line)))
((string-prefix? "data" line)
- (print "got " line)
(smtp 'intermediate)
(let text-loop ((text-line (smtp 'get-line))
(text ""))
- (print "Received '" text-line "'")
(if (string=? "." text-line)
(message-text-set! msg text)
(text-loop (smtp 'get-line)
- (conc text "\n" text-line))))
+ (conc text text-line "\n"))))
(deliver-message msg config)
(smtp 'ok)
(loop (make-empty-message)
(loop msg (smtp 'get-line)))
(else
(smtp 'not-implemented)
- (print "got " line)
(loop msg (smtp 'get-line)))))
'done)))
;;; Message delivery
;;
+(define (get-to-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)))
+
(define (deliver-message msg config)
- (print "Message delivered:")
- (print " * From: " (message-from msg))
- (print " * To: " (message-to msg))
- (print " * Text: " (message-text msg)))
+ (let ((dest (assoc (message-to msg) (get-to-addresses config))))
+ (if dest
+ (begin
+ (with-output-to-file (cdr dest)
+ (lambda ()
+ (print "\nFrom " (remove-angle-brackets (message-from msg)))
+ (print (message-text msg)))
+ #:append)
+ (print "Message DELIVERED:"))
+ (print "Message REJECTED:"))
+ (print " * From: " (message-from msg))
+ (print " * To: " (message-to msg))))
;;; Command line argument parsing