;; 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)