lambdamail.scm

   1 ;; Super-basic bell-and-whistle-free SMTP server.
   2 ;;
   3 ;; Intended for a single-user system
   4
   5 (import tcp6
   6         (chicken port)
   7         (chicken io)
   8         (chicken string)
   9         (chicken pathname)
  10         (chicken file)
  11         (chicken time posix)
  12         srfi-1 srfi-13 matchable)
  13
  14 (define lambdamail-version "0.0.1")
  15
  16 (define-record config port)
  17 (define-record message to from text helo)
  18 (define (make-empty-message) (make-message "" "" "" ""))
  19
  20 (define (run-server config)
  21   (set-buffering-mode! (current-output-port) #:line)
  22   (let ((listener (tcp-listen (config-port config) 10 "::")))
  23     (print "LambdaMail listening on port " (config-port config) " ...")
  24     (server-loop listener config)))
  25
  26 (define (server-loop listener config)
  27   (let-values (((in-port out-port) (tcp-accept listener)))
  28     (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
  29       (print "Accepted connection from " remote-ip " on " (seconds->string)))
  30     (write-line (conc "Welcome to lambamail v" lambdamail-version) out-port)
  31     (process-smtp in-port out-port)
  32     (print "Connection terminated.")
  33     (close-input-port in-port)
  34     (close-output-port out-port))
  35   (server-loop listener config))
  36
  37 (define (smtp-reply reply out-port)
  38   (write-line (conc reply "\r\n") out-port))
  39
  40 (define (smtp-ok out-port)
  41   (smtp-reply "250 OK" out-port))
  42
  43 (define (smtp-close out-port)
  44   (smtp-reply "221 Closing transmission channel" out-port))
  45
  46 (define (smtp-no out-port)
  47   (smtp-reply "502 Command not implemented" out-port))
  48
  49 (define (process-smtp in-port out-port)
  50   (let loop ((msg (make-empty-message))
  51              (line (string-downcase (read-line in-port))))
  52     (cond
  53      ((string-prefix? "helo" line)
  54       (message-helo-set! msg (string-drop line (string-length "helo")))
  55       (smtp-ok out-port)
  56       (loop msg (string-downcase (read-line in-port))))
  57      ((string-prefix? "mail from:" line)
  58       (message-from-set! msg (string-drop line (string-length "mail from:")))
  59       (smtp-ok out-port)
  60       (loop msg (string-downcase (read-line in-port))))
  61      ((string-prefix? "rcpt to:" line)
  62       (message-to-set! msg (string-drop line (string-length "rcpt to:")))
  63       (smtp-ok out-port)
  64       (loop msg (string-downcase (read-line in-port))))
  65      ((string-prefix? "data" line)
  66       (let text-loop ((text-line (read-line in-port))
  67                       (text ""))
  68         (print "Received '" text-line "'")
  69         (if (string=? "." text-line)
  70             (message-text-set! msg text)
  71             (text-loop (read-line in-port)
  72                        (conc text text-line))))
  73       (deliver-message msg)
  74       (smtp-ok out-port)
  75       (loop (make-empty-message)
  76             (string-downcase (read-line in-port))))
  77      ((string-prefix? "quit" line)
  78       (smtp-close out-port)
  79       'done)
  80      (else
  81       (smtp-no out-port)))))
  82
  83 (define (deliver-message msg)
  84   (print "Message delivered:")
  85   (print " * From: " (message-from msg))
  86   (print " * To: " (message-to msg))
  87   (print " * Text: " (message-text msg)))
  88
  89 (define (test)
  90   (run-server (make-config 2525)))
  91
  92 (test)