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)
18 srfi-1 srfi-13 matchable base64)
20 (define lambdamail-version "LambdaMail v1.5.0")
22 (define-record config host port spool-dir user group)
23 (define-record message to from text user password)
24 (define (make-empty-message) (make-message '() "" "" "" ""))
27 (time->string (seconds->local-time) "%d %b %Y %T %z"))
30 ;;; Server initialization
33 (define (drop-privs config)
34 (let ((uid (config-user config))
35 (gid (config-group config)))
36 (if (not (null? gid)) ; Group first, since only root can switch groups.
37 (set! (current-group-id) gid))
39 (set! (current-user-id) uid))))
41 (define (run-server config)
42 (set-buffering-mode! (current-output-port) #:line)
43 (let ((listener (tcp-listen (config-port config) 10 "::")))
44 (print lambdamail-version
45 " listening on port " (config-port config) " ...")
46 (print "(Host name: " (config-host config)
47 ", Spool dir: " (config-spool-dir config) ")")
49 (server-loop listener config '())))
55 (define (server-loop listener config undelivered-messages)
56 (let* ((messages (append (receive-messages listener config) undelivered-messages)))
57 (server-loop listener config (deliver-messages config messages))))
60 ;;; Receiving messages
63 (define (receive-messages listener config)
65 (print "*** Waiting for incoming mail")
66 (let-values (((in-port out-port) (tcp-accept listener)))
67 (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
68 (print "Accepted connection from " remote-ip " on " (time-stamp)))
70 (set! messages (process-smtp (make-smtp-session in-port out-port config) config))
72 (print-error-message o)))
73 (print "Terminating connection.")
74 (close-input-port in-port)
75 (close-output-port out-port))
78 (define (make-smtp-session in-port out-port config)
82 (('get-line) (read-line in-port))
83 (('send strings ...) (write-line (conc (apply conc strings) "\r") out-port))
84 (('set-helo! h) (set! helo h))
87 (define (smtp-command? cmd-string input-string)
88 (string-prefix? cmd-string (string-downcase input-string)))
90 (define (smtp-command-args cmd-string input-string)
91 (if (> (string-length input-string) (string-length cmd-string))
92 (string-trim (string-drop input-string (string-length cmd-string)))
95 (define (process-smtp smtp-session config)
96 (smtp-session 'send "220 " (config-host config) " " lambdamail-version)
97 (let loop ((msg (make-empty-message))
98 (received-messages '()))
99 (let ((line (smtp-session 'get-line)))
101 (if (not (string? line))
102 '() ; Don't keep anything on unexpected termination.
104 ((smtp-command? "helo" line)
105 (smtp-session 'set-helo! (smtp-command-args "helo" line))
106 (smtp-session 'send "250 ok")
107 (loop msg received-messages))
108 ((smtp-command? "ehlo" line)
109 (smtp-session 'set-helo! (smtp-command-args "helo" line))
111 "250-" (config-host config)
112 " Hello " (smtp-command-args "ehlo" line))
113 (smtp-session 'send "250 AUTH PLAIN")
114 ;; (smtp-session 'send "250 STARTTLS")
115 (loop msg received-messages))
116 ((smtp-command? "auth plain" line)
117 (let* ((auth-string (smtp-command-args "auth plain" line))
118 (auth-decoded (base64-decode auth-string))
119 (auth-list (string-split auth-decoded "\x00"))
120 (user (car auth-list))
121 (password (cadr auth-list)))
122 (message-user-set! msg user)
123 (message-password-set! msg password)
124 (print "Attempted login, user: " user ", password: " password)
125 (smtp-session 'send "235 authentication successful")
126 (loop msg received-messages)))
127 ((smtp-command? "mail from:" line)
128 (message-from-set! msg (smtp-command-args "mail from:" line))
129 (smtp-session 'send "250 ok")
130 (loop msg received-messages))
131 ((smtp-command? "rcpt to:" line)
132 (message-to-set! msg (cons (smtp-command-args "rcpt to:" line)
134 (if (message-valid? msg config)
135 (smtp-session 'send "250 ok")
136 (smtp-session 'send "551 relay forbidden"))
137 (loop msg received-messages))
138 ((smtp-command? "data" line)
139 (smtp-session 'send "354 intermediate")
140 (let text-loop ((text '()))
141 (let ((text-line (smtp-session 'get-line)))
142 (if (string=? "." text-line)
143 (message-text-set! msg text)
144 (text-loop (conc text text-line "\n")))))
145 (smtp-session 'send "250 ok")
146 (loop (make-empty-message) (append (get-single-recipient-messages msg smtp-session)
148 ((smtp-command? "quit" line)
149 (smtp-session 'send "221 closing transmission channel")
151 ((string=? "" (string-trim line))
152 (loop msg received-messages))
154 (smtp-session 'send "502 command not implemented")
155 (loop msg received-messages)))))))
157 (define (get-single-recipient-messages smtp-session msg)
160 (make-message to (message-from msg)
161 (conc "Received: from " (smtp-session 'helo) "\n"
162 "\tby " (config-host config) "\n"
164 "\t" (time-stamp) "\n"
167 (message-password msg)))
171 ;;; Message stamping and validation
174 (define (get-local-addresses config)
175 (map (lambda (p) (cons
176 (conc "<" (car p) "@" (config-host config) ">")
179 (list (pathname-file file) file
180 (let ((password-file (conc file ".auth")))
181 (if (file-exists? password-file)
182 (with-input-from-file password-file read-line)
184 (filter directory-exists?
185 (glob (conc (config-spool-dir config) "/*"))))))
187 (define (message-stamp msg config)
188 (let* ((local-addresses (get-local-addresses config))
189 (local-dest (assoc (message-to msg) local-addresses))
190 (local-src (assoc (message-from msg) local-addresses)))
193 (list #t 'local (cadr local-dest)))
195 (let ((password (caddr local-src)))
196 (if (and (string=? (conc "<" (message-user msg) "@" (config-host config) ">")
199 (string=? (message-password msg) password))
202 (print "Provided password " (message-password msg))
203 (print "Host password " password)
204 (list #f 'remote)))))
208 (define (message-valid? msg config)
209 (let ((stamp (message-stamp msg config)))
210 (print "Stamp: " stamp)
214 ;;; Sending/Delivering messages
217 (define (deliver-messages config messages)
218 (print "*** Attempting delivery of " (length messages) " mail items.")
219 (filter (lambda (msg) (not (deliver-message msg config)))
222 (define (deliver-message msg config)
223 (print "From: " (message-from msg))
224 (print "To: " (message-to msg))
226 (match (message-stamp msg config)
227 ((#t 'local dest-dir) (deliver-message-local msg dest-dir))
228 ((#t 'remote) (deliver-message-remote msg config))
230 (print "* REMOTE DELIVERY NOT ALLOWED (auth failure)")
233 (print "* DELIVERY NOT ALLOWED (relay forbidden)")
236 (print "* DELIVERY FAILED")
237 (print-error-message o)
242 (define (deliver-message-local msg dest-dir)
243 (with-output-to-file (conc dest-dir "/" (current-seconds))
245 (print (message-text msg))))
246 (print "* MESSAGE DELIVERED (local)")
252 (define (get-domain-from-email email-string)
253 (car (string-split (cadr (string-split email-string "@")) ">")))
255 ;; This is a hack - there's no built-in interface to res_query()
256 ;; in chicken, so we have to resort to a system call to dig...
257 (define (get-mail-server-for-domain domain)
258 (let* ((mx-lines (let-values (((in out id) (process (conc "dig " domain " mx +short"))))
259 (with-input-from-port in read-lines)))
260 (mx-entries (map (lambda (l)
261 (let ((s (string-split l)))
262 (list (string->number (car s))
263 (string-drop-right (cadr s) 1)))) ; remove trailing "."
265 (sorted-mx-entries (sort mx-entries (lambda (e f) (< (car e) (car f))))))
266 (if (null? sorted-mx-entries)
267 domain ; fall-back to email address domain if no mx entries
268 (cadar sorted-mx-entries)))) ; otherwise pick the highest priority server
270 (define (deliver-message-remote msg config)
271 (let* ((domain (get-domain-from-email (message-to msg)))
272 (mail-server (get-mail-server-for-domain domain)))
273 (print "Attempting delivery to " mail-server)
274 (let-values (((tcp-in tcp-out) (tcp-connect mail-server 25)))
275 (let ((smtp-session (make-outgoing-smtp-session tcp-in tcp-out)))
277 (smtp-session 'expect "220")
278 (smtp-session 'send "helo " (config-host config))
279 (smtp-session 'expect "250")
280 (smtp-session 'send "mail from:" (message-from msg))
281 (smtp-session 'expect "250")
282 (smtp-session 'send "rcpt to:" (message-to msg))
283 (smtp-session 'expect "250")
284 (smtp-session 'send "data")
285 (smtp-session 'expect "354")
286 (smtp-session 'send (message-text msg))
287 (smtp-session 'send ".")
288 (smtp-session 'expect "250" "5") ;Do not try again on rejects.
289 (smtp-session 'send "quit"))))
290 (close-input-port tcp-in)
291 (close-output-port tcp-out)
292 (print "Connection closed.")
294 (print "* MESSAGE DELIVERED (remote)")
295 (print "* REMOTE DELIVERY FAILED (unexpected server response)"))
299 (fold (lambda (a b) (or a b)) #f l))
301 (define ((make-outgoing-smtp-session tcp-in tcp-out) . command)
304 (let loop ((result (read-line tcp-in)))
305 (if (and (> (string-length result) 3)
306 (eq? (string-ref result 3) #\-))
307 (loop (read-line tcp-in)) ;status continues on next line
309 (print "Expecting one of " codes " got " result)
310 (or-list (map (lambda (code)
311 (string-prefix? code result))
314 (print "Sending " (if (> (string-length (car strings)) 30)
315 (string-take (car strings) 30)
317 (let ((processed-string
318 (string-translate* (conc (apply conc strings) "\n")
319 '(("\n" . "\r\n")))))
320 (write-string processed-string #f tcp-out)))))
323 ;;; Command line argument parsing
326 (define (print-usage progname)
328 progname " -h/--help\n"
329 progname " -v/--version\n"
330 progname " [-u/--user UID] [-g/--group GID] hostname [[port [spooldir]]\n"
332 "The -u and -g options can be used to set the UID and GID of the process\n"
333 "following the creation of the TCP port listener (which often requires root)."))
335 (define (print-version)
336 (print lambdamail-version))
339 (let ((progname (pathname-file (car (argv))))
340 (config (make-config "" 25 "/var/spool/mail" '() '())))
341 (if (null? (cdr (argv)))
342 (print-usage progname)
343 (let loop ((args (cdr (argv))))
344 (let ((this-arg (car args))
345 (rest-args (cdr args)))
346 (if (string-prefix? "-" this-arg)
348 ((or (equal? this-arg "-u")
349 (equal? this-arg "--user"))
350 (config-user-set! config (string->number (car rest-args)))
351 (loop (cdr rest-args)))
352 ((or (equal? this-arg "-g")
353 (equal? this-arg "--group"))
354 (config-group-set! config (string->number (car rest-args)))
355 (loop (cdr rest-args)))
356 ((or (equal? this-arg "-h")
357 (equal? this-arg "--help"))
358 (print-usage progname))
359 ((or (equal? this-arg "-v")
360 (equal? this-arg "--version"))
363 (print "Unknown option " this-arg "\n")
364 (print-usage progname)))
366 (config-host-set! config this-arg)
367 (unless (null? rest-args)
368 (config-port-set! config (string->number (car rest-args)))
369 (unless (null? (cdr rest-args))
370 (config-spool-dir-set! config (cadr rest-args))))
371 (run-server config))))))))
376 ;; (run-server (make-config "localhost" 2525 "spool" '() '())))