1 ;; Super-basic bell-and-whistle-free SMTP server.
3 ;; Intended for a single-user system
12 (chicken process-context)
14 srfi-1 srfi-13 matchable)
16 (define lambdamail-version "0.0.1")
21 (define-record message to from text helo)
22 (define (make-empty-message) (make-message "" "" "" ""))
28 (define ((make-smtp in-port out-port config) type)
29 (if (eq? type 'get-line)
33 ((greeting) (conc "220 " (config-host config)
34 " LambdaMail v" lambdamail-version))
36 ((intermediate) "354 intermediate")
37 ((close) "221 closing transmission channel")
38 ((not-implemented) "502 command not implemented"))
42 ;;; Server initialization
45 (define (run-server config)
46 (set-buffering-mode! (current-output-port) #:line)
47 (let ((listener (tcp-listen (config-port config) 10 "::")))
48 (print "LambdaMail v" lambdamail-version
49 " listening on port " (config-port config) " ...")
50 (print "(Host name: " (config-host config)
51 ", Spool dir: " (config-spool-dir config) ")")
52 (server-loop listener config)))
58 (define (server-loop listener config)
59 (let-values (((in-port out-port) (tcp-accept listener)))
60 (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
61 (print "Accepted connection from " remote-ip " on " (seconds->string)))
63 (let ((smtp (make-smtp in-port out-port config)))
65 (process-smtp smtp config))
67 (print-error-message o)))
68 (print "Terminating connection.")
69 (close-input-port in-port)
70 (close-output-port out-port)
71 (server-loop listener config)))
73 ;;; SMTP processing loop
76 (define (process-smtp smtp config)
77 (let loop ((msg (make-empty-message))
78 (line-orig (smtp 'get-line)))
79 (if (string? line-orig)
80 (let ((line (string-downcase line-orig)))
83 ((string-prefix? "helo" line)
84 (message-helo-set! msg (string-drop line (string-length "helo")))
86 (loop msg (smtp 'get-line)))
87 ((string-prefix? "mail from:" line)
88 (message-from-set! msg (string-drop line (string-length "mail from:")))
90 (loop msg (smtp 'get-line)))
91 ((string-prefix? "rcpt to:" line)
92 (message-to-set! msg (string-drop line (string-length "rcpt to:")))
94 (loop msg (smtp 'get-line)))
95 ((string-prefix? "data" line)
97 (let text-loop ((text-line (smtp 'get-line))
99 (if (string=? "." text-line)
100 (message-text-set! msg text)
101 (text-loop (smtp 'get-line)
102 (conc text text-line "\n"))))
103 (deliver-message msg config)
105 (loop (make-empty-message)
107 ((string-prefix? "quit" line)
111 (loop msg (smtp 'get-line)))
113 (smtp 'not-implemented)
114 (loop msg (smtp 'get-line)))))
121 (define (get-to-addresses config)
122 (map (lambda (p) (cons
123 (conc "<" (car p) "@" (config-host config) ">")
125 (map (lambda (file) (cons (pathname-file file) file))
126 (glob (conc (config-spool-dir config) "/*")))))
128 (define (remove-angle-brackets addr)
129 (let ((left-idx (substring-index "<" addr))
130 (right-idx (substring-index ">" addr)))
131 (substring addr (+ left-idx 1) right-idx)))
133 (define (deliver-message msg config)
134 (let ((dest (assoc (message-to msg) (get-to-addresses config))))
137 (with-output-to-file (cdr dest)
139 (print "\nFrom " (remove-angle-brackets (message-from msg)))
140 (print (message-text msg)))
142 (print "Message DELIVERED:"))
143 (print "Message REJECTED:"))
144 (print " * From: " (message-from msg))
145 (print " * To: " (message-to msg))))
148 ;;; Command line argument parsing
151 (define (print-usage progname)
152 (print "Usage: " progname " hostname [port [spooldir]]"))
155 (let ((progname (pathname-file (car (argv))))
157 (config (make-config "" 25 "/var/spool/mail")))
159 (print-usage progname)
161 (config-host-set! config (car args))
162 (unless (null? (cdr args))
163 (config-port-set! config (string->number (cadr args)))
164 (unless (null? (cddr args))
165 (config-spool-dir-set! (caddr args))))
166 (run-server config)))))
170 ;; (run-server (make-config "thelambdalab.xyz" 2525 "/var/spool/mail"))