#!/usr/bin/csi -s

(use regex tcp-server extras posix (srfi 13))
(eval-when (compile) (declare (fixnum-arithmetic)))

;; settings

(define official-name (get-host-name))
(define mail-queue-dir ".")
(define smtp-port 2525)
(define no-disk-i/o #f)
(define echo-io #f)

;; socket i/o wrappers

(define (read-line-crlf)		; fuck Klensin -- use read-line
  (let loop ((c (read-char))
             (accum '()))
    (cond ((eof-object? c) c)
          ((and (eqv? c #\return)
                (eqv? (peek-char) #\newline))
           (read-char)
	   (reverse-list->string accum)
	   ;; a smart chicken would see that reverse-list->string and
	   ;; cons are the only users of accum and ensure an efficient
	   ;; string representation.
          (else (loop (read-char) (cons c accum)))))))

(define (send fmt . args)
  (let ((s (format "~?\r\n" fmt args)))
    (display s)
    (if echo-io (display (conc "> " s) (current-error-port)))))

(define (retr)
  (let ((line (read-line)))
    (if echo-io (display-line (conc "< " line) (current-error-port)))
    line))

;; utilities

(define-macro (if-let var expr k1 k2)
  `(let ((,var ,expr))
     (if ,var ,k1 ,k2)))

(define (quick-match n rx line)
  (if-let m (string-match (if (string? rx) (regexp rx) rx) line)
    (if (pair? n)
      (map (cut list-ref m <>) n)
      (list-ref m n))
    #f))

(define display-line write-line)	; OCD

(define (error-message exn)
  (with-output-to-string (print-error-message exn)))

;; read-mail-data

(define unique-identifier
  (let ((counter 0))
    (lambda ()
      (conc (current-seconds-string) "." (current-process-id) "_"
            (critical-section (set! counter (+ 1 counter)) counter)
            "." (get-host-name)))))

(define (current-seconds-string)
  (quick-match 1 (regexp "([0-9]+)") (->string (current-seconds))))

(define (strip-initial-dot line)
  (if (and (> (string-length line) 0) (eqv? #\. (string-ref line 0)))
    ;; since our use of of the result is purely functional, a smart
    ;; enough chicken would use a shared substring below.
    (substring line 1 (string-length line))
    line))

(define (open-queue-file name)
  (open-output-file*
   (file-open name
	      (bitwise-ior open/write open/excl open/creat)
	      (bitwise-ior perm/irusr perm/iwusr))))

(define-macro (i/o . body)
  `(unless no-disk-i/o ,body))

(define (read-mail-data mail-from rcpt-to)
  (handle-exceptions exn
    (begin
      (print-call-chain)
      (conc "451 exception raised: " (error-message exn)))

    (let* ((uniq (unique-identifier))
           (tmp (conc mail-queue-dir "/tmp/" uniq))
           (new (conc mail-queue-dir "/new/" uniq))
           (mail-queue-port (i/o open-queue-file tmp)))

      (i/o fprintf mail-queue-port "Return-path: ~A\n" mail-from)
      (i/o fprintf mail-queue-port "Envelope-to: ~A\n" rcpt-to)

      (send "354 begin data input, ending with \".\" on a line by itself.")

      (let loop ((line (retr)))
	(cond ((eof-object? line) (delete-file* tmp) #f)
	      ((string=? line ".")
	       (i/o close-output-port mail-queue-port)
	       ;; insert spam filter
	       (i/o rename-file tmp new)
	       (if no-disk-i/o
		 (conc "250 ok. benchmark mode: mail not saved. #" uniq)
		 (conc "250 ok. mail written safely to disk. #" uniq)))
	      (else (i/o display-line (strip-initial-dot line) mail-queue-port)
		    (loop (retr))))))))

;; main loop

(define (smtp-cmd-split line)
  (if-let m (quick-match '(1 3) "([^ ][^ ][^ ][^ ])( +(.*))?" line)
    (values (string->symbol (string-upcase (car m))) (cadr m))
    '(#f #f)))

; This rx accepts precisely the same range of input as the algorithm
; described in http://cr.yp.to/smtp/address.html except multiple @ are
; disallowed.  It correctly recognizes quotes and escapes; however, it
; does not remove them.  It does remove "source routes".

(define route-rx "(@[^:]+:)?")
(define address-part-rx "([^@>\"\\]+|\\\\[^@]|\"[^@\"]*\")+")
(define rcpt-to-rx
  (regexp (conc "TO: *<" route-rx "(" address-part-rx "(@" official-name ")?)>")))
(define mail-from-rx
  (regexp (conc "FROM: *<" route-rx "(" address-part-rx "@" address-part-rx ")>")))

(define (parse-rcpt-to line) (quick-match 2 rcpt-to-rx line))
(define (parse-mail-from line) (quick-match 2 mail-from-rx line))

(define (smtp-server)
  (handle-exceptions exn
    (begin
      (print-error-message exn (current-error-port))
      (print-call-chain)
      (send "421 shutting down. exception raised: ~A" (error-message exn)))

    (send "220 ~A ESMTP" official-name)

    (let loop ((line (retr)) (from #f) (to #f))

      (define (cont #!optional (s #f) #!key (from from) (to to))
        (if s (send s)) (loop (retr) from to))

      (unless (eof-object? line)
        (receive (cmd args) (smtp-cmd-split line)
	  (case cmd
            ((#f) (cont))  ; empty line.  "500 bad syntax"?
            ((EHLO) (send "250-~A" official-name)
		    (send "250-PIPELINING")
		    (cont "250 8BITMIME"))
            ((HELO) (cont (conc "250 " official-name) from: #f to: #f))
            ((MAIL) (if-let sender (parse-mail-from args)
                      (cont "250 ok" from: sender)
                      (cont "553 name not allowed")))
            ((RCPT) (if to
                      (cont "452 too many recipients")
                      (if-let box (parse-rcpt-to args)
                        (cont "250 ok" to: box)
                        (cont "553 bad mailbox"))))
            ((DATA) (if (not (and from to))
                      (cont "503 bad sequence of commands; use MAIL and RCPT before DATA")
                      (cont (read-mail-data from to) from: #f to: #f)))
            ((RSET) (cont "250 ok" from: #f to: #f))
            ((NOOP) (cont "250 ok"))
            ((VRFY) (cont "252 send some mail, i'll try my best."))
            ((QUIT) (send "221 closing connection"))
            (else (cont "500 command unrecognized"))))))))

(define (smtpd #!optional (verbose #t))
  (set-signal-handler! signal/term exit)
  ((make-tcp-server (tcp-listen smtp-port) smtp-server) verbose))

(eval-when (load) (smtpd #f))