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

(define lambdamail-version "0.0.1")

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


;;; SMTP transactions
;;

(define (make-smtp-session in-port out-port config)
  (let ((smtp-say (lambda args (write-line (conc (apply conc args) "\r") out-port)))
        (user "")
        (password ""))
    (lambda msg
      (match msg
        (('get-line) (read-line in-port))
        (('set-user! u) (set! user u))
        (('set-password! p) (set! password p))
        (('auth-success) (smtp-say "235 Authentication successful"))
        (('greet) (smtp-say "220 " (config-host config)
                            " LambdaMail v" lambdamail-version))
        (('ok) (smtp-say "250 ok"))
        (('ehlo host)
         (smtp-say "250-" (config-host config) " Hello " host)
         (smtp-say "250 AUTH PLAIN"))
        (('intermediate) (smtp-say "354 intermediate"))
        (('close) (smtp-say "221 closing transmission channel"))
        (('not-implemented) (smtp-say "502 command not implemented"))))))


;;; Server initialization
;;

(define (drop-privs config)
  (let ((uid (config-user config))
        (gid (config-group config)))
    (if (not (null? gid)) ; Group first, since only root can switch groups.
        (set! (current-group-id) gid))
    (if (not (null? uid))
        (set! (current-user-id) uid))))

(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) ")")
    (drop-privs 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-session (make-smtp-session in-port out-port config)))
          (smtp-session 'greet)
          (process-smtp smtp-session 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-session config)
  (let loop ((msg (make-empty-message)))
    (let ((line-orig (smtp-session 'get-line)))
      (if (string? line-orig)
          (let ((line (string-downcase line-orig)))
            (print "got " line-orig)
            (cond
             ((string-prefix? "helo" line)
              (message-helo-set! msg (string-drop line (string-length "helo")))
              (smtp-session 'ok)
              (loop msg))
             ((string-prefix? "ehlo" line)
              (smtp-session 'ehlo (string-drop line (+ 1 (string-length "ehlo"))))
              (loop msg))
             ((string-prefix? "auth plain" line)
              (let* ((auth-string (string-drop line-orig (+ 1 (string-length "auth plain"))))
                     (auth-decoded (base64-decode auth-string))
                     (auth-list (string-split auth-decoded "\x00"))
                     (user (car auth-list))
                     (password (cadr auth-list)))
                (smtp-session 'set-user! user)
                (smtp-session 'set-password! password)
                (print "Attempted login, user: " user ", password: " password)
                (smtp-session 'auth-success)
                (loop msg)))
             ((string-prefix? "mail from:" line)
              (message-from-set! msg (string-drop line (string-length "mail from:")))
              (smtp-session 'ok)
              (loop msg))
             ((string-prefix? "rcpt to:" line)
              (message-to-set! msg (string-drop line (string-length "rcpt to:")))
              (smtp-session 'ok)
              (loop msg))
             ((string-prefix? "data" line)
              (smtp-session 'intermediate)
              (let text-loop ((text-line (smtp-session 'get-line))
                              (text ""))
                (if (string=? "." text-line)
                    (message-text-set! msg text)
                    (text-loop (smtp-session 'get-line)
                               (conc text text-line "\n"))))
              (process-message msg config)
              (smtp-session 'ok)
              (loop (make-empty-message)))
             ((string-prefix? "quit" line)
              (smtp-session 'close)
              'done)
             ((string=? "" line)
              (loop msg))
             (else
              (smtp-session 'not-implemented)
              (loop msg))))
          'done))))


;;; Message delivery
;;

(define (get-to-addresses config)
  (map (lambda (p) (cons
                    (conc "<" (car p) "@" (config-host config) ">")
                    (cdr p)))
       (map (lambda (file) (cons (pathname-file file) file))
            (glob (conc (config-spool-dir config) "/*")))))

(define (remove-angle-brackets addr)
  (let ((left-idx (substring-index "<" addr))
        (right-idx (substring-index ">" addr)))
    (substring addr (+ left-idx 1) right-idx)))

(define (deliver-message-maildir msg dest-dir)
  (print "Delivering to maildir " dest-dir)
  (with-output-to-file (conc dest-dir "/" (current-seconds))
    (lambda ()
      (print (message-text msg)))))

(define (process-message msg config)
  (let ((dest (assoc (message-to msg) (get-to-addresses config))))
    (if dest
        (let ((dest-file (cdr dest)))
          (if (directory-exists? dest-file)
              (deliver-message-maildir msg dest-file)
              (deliver-message-mbox msg dest-file))
          (print "Message DELIVERED:"))
        (print "Message REJECTED:"))
    (print " * From: " (message-from msg))
    (print " * To: " (message-to msg))))


;;; Command line argument parsing
;;

(define (print-usage progname)
  (print "Usage:\n"
         progname " -h/--help\n"
         progname " [-u/--user UID] [-g/--group GID] hostname [[port [spooldir]]\n"
         "\n"
         "The -u and -g options can be used to set the UID and GID of the process\n"
         "following the creation of the TCP port listener (which often requires root)."))

(define (main)
  (let ((progname (pathname-file (car (argv))))
        (config (make-config "" 25 "/var/spool/mail" '() '())))
    (if (null? (cdr (argv)))
        (print-usage progname)
        (let loop ((args (cdr (argv))))
          (let ((this-arg (car args))
                (rest-args (cdr args)))
            (if (string-prefix? "-" this-arg)
                (cond
                 ((or (equal? this-arg "-u")
                      (equal? this-arg "--user"))
                  (config-user-set! config (string->number (car rest-args)))
                  (loop (cdr rest-args)))
                 ((or (equal? this-arg "-g")
                      (equal? this-arg "--group"))
                  (config-group-set! config (string->number (car rest-args)))
                  (loop (cdr rest-args)))
                 ((or (equal? this-arg "-h")
                      (equal? this-arg "--help"))
                  (print-usage progname))
                 (else
                  (print "Unknown option " this-arg "\n")
                  (print-usage progname)))
                (begin
                  (config-host-set! config this-arg)
                  (unless (null? rest-args)
                    (config-port-set! config (string->number (car rest-args)))
                    (unless (null? (cdr rest-args))
                      (config-spool-dir-set! config (cadr rest-args))))
                  (run-server config))))))))

(main)

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