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)))
82 ((string-prefix? "helo" line)
83 (message-helo-set! msg (string-drop line (string-length "helo")))
86 (loop msg (smtp 'get-line)))
87 ((string-prefix? "mail from:" line)
89 (message-from-set! msg (string-drop line (string-length "mail from:")))
91 (loop msg (smtp 'get-line)))
92 ((string-prefix? "rcpt to:" line)
94 (message-to-set! msg (string-drop line (string-length "rcpt to:")))
96 (loop msg (smtp 'get-line)))
97 ((string-prefix? "data" line)
100 (let text-loop ((text-line (smtp 'get-line))
102 (print "Received '" text-line "'")
103 (if (string=? "." text-line)
104 (message-text-set! msg text)
105 (text-loop (smtp 'get-line)
106 (conc text text-line))))
107 (deliver-message msg config)
109 (loop (make-empty-message)
111 ((string-prefix? "quit" line)
115 (loop msg (smtp 'get-line)))
117 (smtp 'not-implemented)
119 (loop msg (smtp 'get-line)))))
126 (define (deliver-message msg config)
127 (print "Message delivered:")
128 (print " * From: " (message-from msg))
129 (print " * To: " (message-to msg))
130 (print " * Text: " (message-text msg)))
133 ;;; Command line argument parsing
136 (define (print-usage progname)
137 (print "Usage: " progname " hostname [port [spooldir]]"))
140 (let ((progname (pathname-file (car (argv))))
142 (config (make-config "" 25 "/var/spool/mail")))
144 (print-usage progname)
146 (config-host-set! config (car args))
147 (unless (null? (cdr args))
148 (config-port-set! config (string->number (cadr args)))
149 (unless (null? (cddr args))
150 (config-spool-dir-set! (caddr args))))
151 (run-server config)))))
155 ;; (run-server (make-config "thelambdalab.xyz" 2525 "/var/spool/mail"))