1 ;; Super-basic bell-and-whistle-free SMTP server.
3 ;; Intended for a single-user system
12 (chicken process-context)
13 srfi-1 srfi-13 matchable)
15 (define lambdamail-version "0.0.1")
17 (define-record config port)
18 (define-record message to from text helo)
19 (define (make-empty-message) (make-message "" "" "" ""))
21 (define (run-server config)
22 (set-buffering-mode! (current-output-port) #:line)
23 (let ((listener (tcp-listen (config-port config) 10 "::")))
24 (print "LambdaMail listening on port " (config-port config) " ...")
25 (server-loop listener config)))
27 (define (server-loop listener config)
28 (let-values (((in-port out-port) (tcp-accept listener)))
29 (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
30 (print "Accepted connection from " remote-ip " on " (seconds->string)))
31 (smtp-greeting out-port)
32 (process-smtp in-port out-port)
33 (print "Connection terminated.")
34 (close-input-port in-port)
35 (close-output-port out-port))
36 (server-loop listener config))
38 (define (smtp-reply reply out-port)
39 (write-line reply out-port))
41 (define (smtp-greeting out-port)
42 (smtp-reply (conc "220 thelambdalab.xyz LambdaMail v" lambdamail-version) out-port))
44 (define (smtp-ok out-port)
45 (smtp-reply "250 OK" out-port))
47 (define (smtp-intermediate out-port)
48 (smtp-reply "354 Intermediate" out-port))
50 (define (smtp-close out-port)
51 (smtp-reply "221 Closing transmission channel" out-port))
53 (define (smtp-no out-port)
54 (smtp-reply "502 Command not implemented" out-port))
56 (define (process-smtp in-port out-port)
57 (let loop ((msg (make-empty-message))
58 (line-orig (read-line in-port)))
59 (if (string? line-orig)
60 (let ((line (string-downcase line-orig)))
62 ((string-prefix? "helo" line)
63 (message-helo-set! msg (string-drop line (string-length "helo")))
66 (loop msg (read-line in-port)))
67 ((string-prefix? "mail from:" line)
69 (message-from-set! msg (string-drop line (string-length "mail from:")))
71 (loop msg (read-line in-port)))
72 ((string-prefix? "rcpt to:" line)
74 (message-to-set! msg (string-drop line (string-length "rcpt to:")))
76 (loop msg (read-line in-port)))
77 ((string-prefix? "data" line)
79 (smtp-intermediate out-port)
80 (let text-loop ((text-line (read-line in-port))
82 (print "Received '" text-line "'")
83 (if (string=? "." text-line)
84 (message-text-set! msg text)
85 (text-loop (read-line in-port)
86 (conc text text-line))))
89 (loop (make-empty-message)
91 ((string-prefix? "quit" line)
95 (loop msg (read-line in-port)))
99 (loop msg (read-line in-port)))))
102 (define (deliver-message msg)
103 (print "Message delivered:")
104 (print " * From: " (message-from msg))
105 (print " * To: " (message-to msg))
106 (print " * Text: " (message-text msg)))
108 (run-server (make-config 25))