1 ;; Super-basic bell-and-whistle-free SMTP server.
3 ;; Intended for a single-user system
12 srfi-1 srfi-13 matchable)
14 (define lambdamail-version "0.0.1")
16 (define-record config port)
17 (define-record message to from text helo)
18 (define (make-empty-message) (make-message "" "" "" ""))
20 (define (run-server config)
21 (set-buffering-mode! (current-output-port) #:line)
22 (let ((listener (tcp-listen (config-port config) 10 "::")))
23 (print "LambdaMail listening on port " (config-port config) " ...")
24 (server-loop listener config)))
26 (define (server-loop listener config)
27 (let-values (((in-port out-port) (tcp-accept listener)))
28 (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
29 (print "Accepted connection from " remote-ip " on " (seconds->string)))
30 (write-line (conc "Welcome to lambamail v" lambdamail-version) out-port)
31 (process-smtp in-port out-port)
32 (print "Connection terminated.")
33 (close-input-port in-port)
34 (close-output-port out-port))
35 (server-loop listener config))
37 (define (smtp-reply reply out-port)
38 (write-line (conc reply "\r\n") out-port))
40 (define (smtp-ok out-port)
41 (smtp-reply "250 OK" out-port))
43 (define (smtp-close out-port)
44 (smtp-reply "221 Closing transmission channel" out-port))
46 (define (smtp-no out-port)
47 (smtp-reply "502 Command not implemented" out-port))
49 (define (process-smtp in-port out-port)
50 (let loop ((msg (make-empty-message))
51 (line (string-downcase (read-line in-port))))
53 ((string-prefix? "helo" line)
54 (message-helo-set! msg (string-drop line (string-length "helo")))
56 (loop msg (string-downcase (read-line in-port))))
57 ((string-prefix? "mail from:" line)
58 (message-from-set! msg (string-drop line (string-length "mail from:")))
60 (loop msg (string-downcase (read-line in-port))))
61 ((string-prefix? "rcpt to:" line)
62 (message-to-set! msg (string-drop line (string-length "rcpt to:")))
64 (loop msg (string-downcase (read-line in-port))))
65 ((string-prefix? "data" line)
66 (let text-loop ((text-line (read-line in-port))
68 (print "Received '" text-line "'")
69 (if (string=? "." text-line)
70 (message-text-set! msg text)
71 (text-loop (read-line in-port)
72 (conc text text-line))))
75 (loop (make-empty-message)
76 (string-downcase (read-line in-port))))
77 ((string-prefix? "quit" line)
81 (smtp-no out-port)))))
83 (define (deliver-message msg)
84 (print "Message delivered:")
85 (print " * From: " (message-from msg))
86 (print " * To: " (message-to msg))
87 (print " * Text: " (message-text msg)))
90 (run-server (make-config 2525)))