1 ;; Super-basic bell-and-whistle-free SMTP server.
3 ;; Intended for a single-user system
14 (chicken process-context)
15 (chicken process-context posix)
17 srfi-1 srfi-13 matchable base64)
19 (define lambdamail-version "0.0.1")
21 (define-record config host port spool-dir user group)
22 (define-record message to from text helo user password)
23 (define (make-empty-message) (make-message "" "" "" "" "" ""))
25 (define outbound-mail-queue '())
28 ;;; Server initialization
31 (define (drop-privs config)
32 (let ((uid (config-user config))
33 (gid (config-group config)))
34 (if (not (null? gid)) ; Group first, since only root can switch groups.
35 (set! (current-group-id) gid))
37 (set! (current-user-id) uid))))
39 (define (run-server config)
40 (set-buffering-mode! (current-output-port) #:line)
41 (let ((listener (tcp-listen (config-port config) 10 "::")))
42 (print "LambdaMail v" lambdamail-version
43 " listening on port " (config-port config) " ...")
44 (print "(Host name: " (config-host config)
45 ", Spool dir: " (config-spool-dir config) ")")
47 (server-loop listener config)))
53 (define (server-loop listener config)
54 (let-values (((in-port out-port) (tcp-accept listener)))
55 (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
56 (print "Accepted connection from " remote-ip " on " (seconds->string)))
58 (let ((smtp-session (make-smtp-session in-port out-port config)))
60 (process-smtp smtp-session config))
62 (print-error-message o)))
63 (print "Terminating connection.")
64 (close-input-port in-port)
65 (close-output-port out-port))
66 (print "Attempting delivery of " (length outbound-mail-queue) " mail items.")
67 (set! outbound-mail-queue
68 (filter (lambda (msg) (not (deliver-message msg config)))
70 (server-loop listener config))
72 ;;; SMTP processing loop
75 (define (make-smtp-session in-port out-port config)
76 (let ((smtp-say (lambda args (write-line (conc (apply conc args) "\r") out-port)))
81 (('get-line) (read-line in-port))
82 (('set-user! u) (set! user u))
83 (('set-password! p) (set! password p))
85 (('password) password)
86 (('auth-success) (smtp-say "235 Authentication successful"))
87 (('greet) (smtp-say "220 " (config-host config)
88 " LambdaMail v" lambdamail-version))
89 (('ok) (smtp-say "250 ok"))
91 (smtp-say "250-" (config-host config) " Hello " host)
92 (smtp-say "250 AUTH PLAIN"))
93 (('intermediate) (smtp-say "354 intermediate"))
94 (('close) (smtp-say "221 closing transmission channel"))
95 (('not-implemented) (smtp-say "502 command not implemented"))))))
97 (define (process-smtp smtp-session config)
98 (let loop ((msg (make-empty-message)))
99 (let ((line-orig (smtp-session 'get-line)))
100 (if (string? line-orig)
101 (let ((line (string-downcase line-orig)))
102 (print "got " line-orig)
104 ((string-prefix? "helo" line)
105 (message-helo-set! msg (string-drop line (string-length "helo")))
108 ((string-prefix? "ehlo" line)
109 (smtp-session 'ehlo (string-drop line (+ 1 (string-length "ehlo"))))
111 ((string-prefix? "auth plain" line)
112 (let* ((auth-string (string-drop line-orig (+ 1 (string-length "auth plain"))))
113 (auth-decoded (base64-decode auth-string))
114 (auth-list (string-split auth-decoded "\x00"))
115 (user (car auth-list))
116 (password (cadr auth-list)))
117 (smtp-session 'set-user! user)
118 (smtp-session 'set-password! password)
119 (print "Attempted login, user: " user ", password: " password)
120 (smtp-session 'auth-success)
122 ((string-prefix? "mail from:" line)
123 (message-from-set! msg (string-drop line (string-length "mail from:")))
126 ((string-prefix? "rcpt to:" line)
127 (message-to-set! msg (string-drop line (string-length "rcpt to:")))
130 ((string-prefix? "data" line)
131 (smtp-session 'intermediate)
132 (let text-loop ((text-line (smtp-session 'get-line))
134 (if (string=? "." text-line)
135 (message-text-set! msg text)
136 (text-loop (smtp-session 'get-line)
137 (conc text text-line "\n"))))
138 (message-user-set! msg (smtp-session 'user))
139 (message-password-set! msg (smtp-session 'password))
140 (set! outbound-mail-queue (cons msg outbound-mail-queue))
142 (loop (make-empty-message)))
143 ((string-prefix? "quit" line)
144 (smtp-session 'close)
149 (smtp-session 'not-implemented)
157 (define (get-to-addresses config)
158 (map (lambda (p) (cons
159 (conc "<" (car p) "@" (config-host config) ">")
161 (map (lambda (file) (cons (pathname-file file) file))
162 (glob (conc (config-spool-dir config) "/*")))))
164 (define (remove-angle-brackets addr)
165 (let ((left-idx (substring-index "<" addr))
166 (right-idx (substring-index ">" addr)))
167 (substring addr (+ left-idx 1) right-idx)))
169 (define (deliver-message-local msg dest-dir)
170 (print "Delivering to maildir " dest-dir)
171 (with-output-to-file (conc dest-dir "/" (current-seconds))
173 (print (message-text msg)))))
175 (define (deliver-message msg config)
176 (let ((dest (assoc (message-to msg) (get-to-addresses config))))
178 (let ((dest-file (cdr dest)))
179 (if (directory-exists? dest-file)
180 (deliver-message-local msg dest-file))
181 (print "Message DELIVERED:"))
182 (print "Message REJECTED:"))
183 (print " * From: " (message-from msg))
184 (print " * To: " (message-to msg)))
188 ;;; Command line argument parsing
191 (define (print-usage progname)
193 progname " -h/--help\n"
194 progname " [-u/--user UID] [-g/--group GID] hostname [[port [spooldir]]\n"
196 "The -u and -g options can be used to set the UID and GID of the process\n"
197 "following the creation of the TCP port listener (which often requires root)."))
200 (let ((progname (pathname-file (car (argv))))
201 (config (make-config "" 25 "/var/spool/mail" '() '())))
202 (if (null? (cdr (argv)))
203 (print-usage progname)
204 (let loop ((args (cdr (argv))))
205 (let ((this-arg (car args))
206 (rest-args (cdr args)))
207 (if (string-prefix? "-" this-arg)
209 ((or (equal? this-arg "-u")
210 (equal? this-arg "--user"))
211 (config-user-set! config (string->number (car rest-args)))
212 (loop (cdr rest-args)))
213 ((or (equal? this-arg "-g")
214 (equal? this-arg "--group"))
215 (config-group-set! config (string->number (car rest-args)))
216 (loop (cdr rest-args)))
217 ((or (equal? this-arg "-h")
218 (equal? this-arg "--help"))
219 (print-usage progname))
221 (print "Unknown option " this-arg "\n")
222 (print-usage progname)))
224 (config-host-set! config this-arg)
225 (unless (null? rest-args)
226 (config-port-set! config (string->number (car rest-args)))
227 (unless (null? (cdr rest-args))
228 (config-spool-dir-set! config (cadr rest-args))))
229 (run-server config))))))))
233 ;; (run-server (make-config "thelambdalab.xyz" 2525 "/var/spool/mail"))