;; 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)
        (chicken process-context)
        (chicken condition)
        srfi-1 srfi-13 matchable)

(define lambdamail-version "0.0.1")


(define-record config
  host port spool-dir)
(define-record message to from text helo)
(define (make-empty-message) (make-message "" "" "" ""))


;;; SMTP transactions
;;

(define ((make-smtp in-port out-port config) type)
  (if (eq? type 'get-line)
      (read-line in-port)
      (write-line (conc
                   (case type
                     ((greeting) (conc "220 " (config-host config)
                                       " LambdaMail v" lambdamail-version))
                     ((ok) "250 ok")
                     ((intermediate) "354 intermediate")
                     ((close) "221 closing transmission channel")
                     ((not-implemented) "502 command not implemented"))
                   "\r") out-port)))


;;; Server initialization
;;

(define (run-server config)
  (set-buffering-mode! (current-output-port) #:line)
  (let ((listener (tcp-listen (config-port config) 10 "::")))
    (print "LambdaMail v" lambdamail-version
           " listening on port " (config-port config) " ...")
    (print "(Host name: " (config-host config)
           ", Spool dir: " (config-spool-dir config) ")")
    (server-loop listener config)))


;;; Main server loop
;;

(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)))
    (condition-case
        (let ((smtp (make-smtp in-port out-port config)))
          (smtp 'greeting)
          (process-smtp smtp config))
      (o (exn)
         (print-error-message o)))
    (print "Terminating connection.")
    (close-input-port in-port)
    (close-output-port out-port)
    (server-loop listener config)))

;;; SMTP processing loop
;;

(define (process-smtp smtp config)
  (let loop ((msg (make-empty-message))
             (line-orig (smtp 'get-line)))
    (if (string? line-orig)
        (let ((line (string-downcase line-orig)))
          (cond
           ((string-prefix? "helo" line)
            (message-helo-set! msg (string-drop line (string-length "helo")))
            (print "got " line)
            (smtp 'ok)
            (loop msg (smtp 'get-line)))
           ((string-prefix? "mail from:" line)
            (print "got " line)
            (message-from-set! msg (string-drop line (string-length "mail from:")))
            (smtp 'ok)
            (loop msg (smtp 'get-line)))
           ((string-prefix? "rcpt to:" line)
            (print "got " line)
            (message-to-set! msg (string-drop line (string-length "rcpt to:")))
            (smtp 'ok)
            (loop msg (smtp 'get-line)))
           ((string-prefix? "data" line)
            (print "got " line)
            (smtp 'intermediate)
            (let text-loop ((text-line (smtp 'get-line))
                            (text ""))
              (print "Received '" text-line "'")
              (if (string=? "." text-line)
                  (message-text-set! msg text)
                  (text-loop (smtp 'get-line)
                             (conc text text-line))))
            (deliver-message msg config)
            (smtp 'ok)
            (loop (make-empty-message)
                  (smtp 'get-line)))
           ((string-prefix? "quit" line)
            (smtp 'close)
            'done)
           ((string=? "" line)
            (loop msg (smtp 'get-line)))
           (else
            (smtp 'not-implemented)
            (print "got " line)
            (loop msg (smtp 'get-line)))))
        'done)))


;;; Message delivery
;;
 
(define (deliver-message msg config)
  (print "Message delivered:")
  (print " * From: " (message-from msg))
  (print " * To: " (message-to msg))
  (print " * Text: " (message-text msg)))


;;; Command line argument parsing
;;

(define (print-usage progname)
  (print "Usage: " progname " hostname [port [spooldir]]"))

(define (main)
  (let ((progname (pathname-file (car (argv))))
        (args (cdr (argv)))
        (config (make-config "" 25 "/var/spool/mail")))
    (if (null? args)
        (print-usage progname)
        (begin
          (config-host-set! config (car args))
          (unless (null? (cdr args))
            (config-port-set! config (string->number (cadr args)))
            (unless (null? (cddr args))
              (config-spool-dir-set! (caddr args))))
          (run-server config)))))

(main)

;; (run-server (make-config "thelambdalab.xyz" 2525 "/var/spool/mail"))