Initial commit.

diff --git a/lambdamail.scm b/lambdamail.scm
new file mode 100644 (file)
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)