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 "LambdaMail v0.0.1")
21 (define-record config host port spool-dir user group)
22 (define-record message to from text user password)
23 (define (make-empty-message) (make-message "" "" "" "" ""))
26 (time->string (seconds->local-time) "%d %b %Y %T %z"))
29 ;;; Server initialization
32 (define (drop-privs config)
33 (let ((uid (config-user config))
34 (gid (config-group config)))
35 (if (not (null? gid)) ; Group first, since only root can switch groups.
36 (set! (current-group-id) gid))
38 (set! (current-user-id) uid))))
40 (define (run-server config)
41 (set-buffering-mode! (current-output-port) #:line)
42 (let ((listener (tcp-listen (config-port config) 10 "::")))
43 (print lambdamail-version
44 " listening on port " (config-port config) " ...")
45 (print "(Host name: " (config-host config)
46 ", Spool dir: " (config-spool-dir config) ")")
48 (server-loop listener config '())))
54 (define (server-loop listener config undelivered-messages)
55 (let* ((messages (append (receive-messages listener config) undelivered-messages)))
56 (server-loop listener config (deliver-messages config messages))))
59 ;;; Receiving messages
62 (define (receive-messages listener config)
64 (let-values (((in-port out-port) (tcp-accept listener)))
65 (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
66 (print "Accepted connection from " remote-ip " on " (time-stamp)))
68 (set! messages (process-smtp (make-smtp-session in-port out-port config) config))
70 (print-error-message o)))
71 (print "Terminating connection.")
72 (close-input-port in-port)
73 (close-output-port out-port))
76 (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-user! u) (set! user u))
85 (('set-password! p) (set! password p))
86 (('set-helo! h) (set! helo h))
88 (('password) password)
91 (define (smtp-command? cmd-string input-string)
92 (string-prefix? cmd-string (string-downcase input-string)))
94 (define (smtp-command-args cmd-string input-string)
95 (if (> (string-length input-string) (string-length cmd-string))
96 (string-trim (string-drop input-string (string-length cmd-string)))
99 (define (process-smtp smtp-session config)
100 (smtp-session 'send "220 " (config-host config) " " lambdamail-version)
101 (let loop ((msg (make-empty-message))
102 (received-messages '()))
103 (let ((line (smtp-session 'get-line)))
107 ((smtp-command? "helo" line)
108 (smtp-session 'set-helo! (smtp-command-args "helo" line))
109 (smtp-session 'send "250 ok")
110 (loop msg received-messages))
111 ((smtp-command? "ehlo" line)
112 (smtp-session 'set-helo! (smtp-command-args "helo" line))
114 "250-" (config-host config)
115 " Hello " (smtp-command-args "ehlo" line))
116 (smtp-session 'send "250 AUTH PLAIN")
117 ;; (smtp-session 'send "250 STARTTLS")
118 (loop msg received-messages))
119 ((smtp-command? "auth plain" line)
120 (let* ((auth-string (smtp-command-args "auth plain" line))
121 (auth-decoded (base64-decode auth-string))
122 (auth-list (string-split auth-decoded "\x00"))
123 (user (car auth-list))
124 (password (cadr auth-list)))
125 (smtp-session 'set-user! user)
126 (smtp-session 'set-password! password)
127 (print "Attempted login, user: " user ", password: " password)
128 (smtp-session 'send "235 authentication successful")
129 (loop msg received-messages)))
130 ((smtp-command? "mail from:" line)
131 (message-from-set! msg (smtp-command-args "mail from:" line))
132 (smtp-session 'send "250 ok")
133 (loop msg received-messages))
134 ((smtp-command? "rcpt to:" line)
135 (message-to-set! msg (smtp-command-args "rcpt to:" line))
136 (smtp-session 'send "250 ok")
137 (loop msg received-messages))
138 ((smtp-command? "data" line)
139 (smtp-session 'send "354 intermediate")
140 (let text-loop ((text (conc "Received: from " (smtp-session 'helo) "\n"
141 " by " (config-host config) "\n"
142 " for " (message-from msg)
143 "; " (time-stamp) "\n")))
144 (let ((text-line (smtp-session 'get-line)))
145 (if (string=? "." text-line)
146 (message-text-set! msg text)
147 (text-loop (conc text text-line "\n")))))
148 (message-user-set! msg (smtp-session 'user))
149 (message-password-set! msg (smtp-session 'password))
150 (smtp-session 'send "250 ok")
151 (loop (make-empty-message) (cons msg received-messages)))
152 ((smtp-command? "quit" line)
153 (smtp-session 'send "221 closing transmission channel")
155 ((string=? "" (string-trim line))
156 (loop msg received-messages))
158 (smtp-session 'send "502 command not implemented")
159 (loop msg received-messages)))))))
162 ;;; Sending/Delivering messages
165 (define (deliver-messages config messages)
167 "**** Attempting delivery of " (length messages) " mail items.")
168 (filter (lambda (msg) (not (deliver-message msg config)))
171 (define (deliver-message msg config)
174 (let* ((local-addresses (get-local-addresses config))
175 (dest (assoc (message-to msg) local-addresses))
176 (orig (assoc (message-from msg) local-addresses)))
179 (let ((dest-dir (cadr dest)))
180 (deliver-message-local msg dest-file))
181 (print "Message DELIVERED (local):"))
183 (let ((password (caddr orig)))
185 (string=? (conc "<" (message-user msg) "@" (config-host config) ">")
188 (string=? (message-password msg) password))
190 (deliver-message-remote msg config)
191 (print "Message DELIVERED (remote):"))
192 (print "Message REMOTE DELIVERY REJECTED (auth failure):"))))
194 (print "Message REMOTE DELIVERY REJECTED (relay forbidden):"))))
195 (print " * From: " (message-from msg))
196 (print " * To: " (message-to msg))
199 (print "Message delivery failed.")
200 (print-error-message o))))
204 (define (get-local-addresses config)
205 (map (lambda (p) (cons
206 (conc "<" (car p) "@" (config-host config) ">")
209 (list (pathname-file file) file
210 (let ((password-file (conc file ".auth")))
211 (if (file-exists? password-file)
212 (with-input-from-file password-file read-line)
214 (filter directory-exists?
215 (glob (conc (config-spool-dir config) "/*"))))))
217 (define (deliver-message-local msg dest-dir)
218 (with-output-to-file (conc dest-dir "/" (current-seconds))
220 (print (message-text msg)))))
225 (define (get-host-from-email email-string)
226 (car (string-split (cadr (string-split email-string "@")) ">")))
228 (define (deliver-message-remote msg config)
229 (let ((host (get-host-from-email (message-to msg))))
230 (print "Attempting delivery to host " host)
231 (let-values (((tcp-in tcp-out) (tcp-connect host 25)))
232 (let ((smtp-session (make-outgoing-smtp-session tcp-in tcp-out)))
234 (smtp-session 'expect "220")
235 (smtp-session 'send "helo " (config-host config))
236 (smtp-session 'expect "250")
237 (smtp-session 'send "mail from:" (message-from msg))
238 (smtp-session 'expect "250")
239 (smtp-session 'send "rcpt to:" (message-to msg))
240 (smtp-session 'expect "250")
241 (smtp-session 'send "data")
242 (smtp-session 'expect "354")
243 (smtp-session 'send (message-text msg))
244 (smtp-session 'send ".")
245 (smtp-session 'expect "250")
246 (smtp-session 'send "quit"))))
247 (close-input-port tcp-in)
248 (close-output-port tcp-out)
251 (define ((make-outgoing-smtp-session tcp-in tcp-out) . command)
254 (let ((result (read-line tcp-in)))
255 (print "Expecting " code " got " result)
256 (string-prefix? code result)))
258 (print "Sending " (if (> (string-length (car strings)) 30)
259 (string-take (car strings) 30)
261 (let ((processed-string
262 (string-translate* (conc (apply conc strings) "\n")
263 '(("\n" . "\r\n")))))
264 (write-string processed-string #f tcp-out)))))
266 ;;; Command line argument parsing
269 (define (print-usage progname)
271 progname " -h/--help\n"
272 progname " [-u/--user UID] [-g/--group GID] hostname [[port [spooldir]]\n"
274 "The -u and -g options can be used to set the UID and GID of the process\n"
275 "following the creation of the TCP port listener (which often requires root)."))
278 (let ((progname (pathname-file (car (argv))))
279 (config (make-config "" 25 "/var/spool/mail" '() '())))
280 (if (null? (cdr (argv)))
281 (print-usage progname)
282 (let loop ((args (cdr (argv))))
283 (let ((this-arg (car args))
284 (rest-args (cdr args)))
285 (if (string-prefix? "-" this-arg)
287 ((or (equal? this-arg "-u")
288 (equal? this-arg "--user"))
289 (config-user-set! config (string->number (car rest-args)))
290 (loop (cdr rest-args)))
291 ((or (equal? this-arg "-g")
292 (equal? this-arg "--group"))
293 (config-group-set! config (string->number (car rest-args)))
294 (loop (cdr rest-args)))
295 ((or (equal? this-arg "-h")
296 (equal? this-arg "--help"))
297 (print-usage progname))
299 (print "Unknown option " this-arg "\n")
300 (print-usage progname)))
302 (config-host-set! config this-arg)
303 (unless (null? rest-args)
304 (config-port-set! config (string->number (car rest-args)))
305 (unless (null? (cdr rest-args))
306 (config-spool-dir-set! config (cadr rest-args))))
307 (run-server config))))))))
312 ;; (run-server (make-config "localhost" 2525 "spool" '() '())))