From: Tim Vaughan Date: Mon, 19 Aug 2019 13:47:22 +0000 (+0200) Subject: Initial commit. X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=c8c1c8e27eebf2858cae726f3f55c9e7ee1c6733;p=lambdamail.git Initial commit. --- c8c1c8e27eebf2858cae726f3f55c9e7ee1c6733 diff --git a/lambdamail.scm b/lambdamail.scm new file mode 100644 index 0000000..cd501f1 --- /dev/null +++ b/lambdamail.scm @@ -0,0 +1,92 @@ +;; Super-basic bell-and-whistle-free SMTP server. +;; +;; Intended for a single-user system + +(import tcp6 + (chicken port) + (chicken io) + (chicken string) + (chicken pathname) + (chicken file) + (chicken time posix) + srfi-1 srfi-13 matchable) + +(define lambdamail-version "0.0.1") + +(define-record config port) +(define-record message to from text helo) +(define (make-empty-message) (make-message "" "" "" "")) + +(define (run-server config) + (set-buffering-mode! (current-output-port) #:line) + (let ((listener (tcp-listen (config-port config) 10 "::"))) + (print "LambdaMail listening on port " (config-port config) " ...") + (server-loop listener config))) + +(define (server-loop listener config) + (let-values (((in-port out-port) (tcp-accept listener))) + (let-values (((local-ip remote-ip) (tcp-addresses in-port))) + (print "Accepted connection from " remote-ip " on " (seconds->string))) + (write-line (conc "Welcome to lambamail v" lambdamail-version) out-port) + (process-smtp in-port out-port) + (print "Connection terminated.") + (close-input-port in-port) + (close-output-port out-port)) + (server-loop listener config)) + +(define (smtp-reply reply out-port) + (write-line (conc reply "\r\n") out-port)) + +(define (smtp-ok out-port) + (smtp-reply "250 OK" out-port)) + +(define (smtp-close out-port) + (smtp-reply "221 Closing transmission channel" out-port)) + +(define (smtp-no out-port) + (smtp-reply "502 Command not implemented" out-port)) + +(define (process-smtp in-port out-port) + (let loop ((msg (make-empty-message)) + (line (string-downcase (read-line in-port)))) + (cond + ((string-prefix? "helo" line) + (message-helo-set! msg (string-drop line (string-length "helo"))) + (smtp-ok out-port) + (loop msg (string-downcase (read-line in-port)))) + ((string-prefix? "mail from:" line) + (message-from-set! msg (string-drop line (string-length "mail from:"))) + (smtp-ok out-port) + (loop msg (string-downcase (read-line in-port)))) + ((string-prefix? "rcpt to:" line) + (message-to-set! msg (string-drop line (string-length "rcpt to:"))) + (smtp-ok out-port) + (loop msg (string-downcase (read-line in-port)))) + ((string-prefix? "data" line) + (let text-loop ((text-line (read-line in-port)) + (text "")) + (print "Received '" text-line "'") + (if (string=? "." text-line) + (message-text-set! msg text) + (text-loop (read-line in-port) + (conc text text-line)))) + (deliver-message msg) + (smtp-ok out-port) + (loop (make-empty-message) + (string-downcase (read-line in-port)))) + ((string-prefix? "quit" line) + (smtp-close out-port) + 'done) + (else + (smtp-no out-port))))) + +(define (deliver-message msg) + (print "Message delivered:") + (print " * From: " (message-from msg)) + (print " * To: " (message-to msg)) + (print " * Text: " (message-text msg))) + +(define (test) + (run-server (make-config 2525))) + +(test)