siss/siss.lisp

;;;; the Somewhat Immature SMTP Server

(in-package :siss)

(defparameter *max-recipients* 50)
(defparameter *max-line-length* 512)
(defparameter *max-data-line-length* 1001)
(defparameter *bad-hosts*
  (make-hash-table
   :test #'equal
   :synchronized t)
  "Hash table for hosts that hit the evil counter.")
(defparameter +sayings+
  #("250-Wonderful day for it, isn't it?"
    "250-Please remain calm"
    "250-Deliver the mail into the mail delivery tube"
    "250-Delivery of your mail is not guaranteed."
    "250-I'm a server!")
  "Stupid sayings to echo back on EHLO.")

(defun get-saying ()
  (elt +sayings+ (random (length +sayings+))))

(defun stream-read-sequence-until (stream end-element seq
                                   &key (start 0) (end (array-total-size seq)) (read-func #'read-byte))
  (declare (type stream stream) (type vector seq))
  (assert (typep end-element (stream-element-type stream)))
  (let ((count 0)
        (orig-fill-pointer (fill-pointer seq)))
    (setf (fill-pointer seq) (array-total-size seq))
    (loop
      (when (= start end)
        (return count))
      (let ((element (funcall read-func stream)))
        (setf (aref seq start) element)
        (incf start)
        (incf count)
        (when (eq element end-element)
          (setf (fill-pointer seq) (+ orig-fill-pointer count))
          (return count))))))

(defclass smtp-conn ()
  ((sock
    :initarg :sock
    :accessor conn-sock)
   (remote-host
    :initarg :remote-host
    :accessor conn-remote-host)
   (tlsp
    :initform nil
    :accessor conn-tlsp)))

(defun write-crlf-bytes (stream)
  "Write CRLF to STREAM, as bytes."
  (write-byte #.(char-code #\return) stream)
  (write-byte #.(char-code #\linefeed) stream))

(defun write-line-bytes (stream line)
  "Write LINE, a string, as UTF-8 encoded octets to STREAM."
  (write-sequence (babel:string-to-octets line
                                          :encoding :utf-8)
                  stream)
  (write-crlf-bytes stream))

(defun conn-write (conn line)
  "Writes LINE to CONN's socket."
  (with-accessors ((sock conn-sock) (ra conn-remote-host)) conn
    (format *debug-io* "~&~A --> ~A~%" ra line)
    (write-line-bytes sock line)
    (force-output sock)))

(defclass smtp-conn-initial (smtp-conn) ())

(defclass smtp-conn-ehlo (smtp-conn)
  ((domain
    :initarg :domain
    :accessor conn-domain)))

(defclass smtp-conn-from (smtp-conn-ehlo)
  ((from-addr
    :initarg :from-addr
    :accessor conn-from-addr)
   (to-addrs
    :initform nil
    :accessor conn-to-addrs)))

(defclass smtp-conn-data (smtp-conn-from)
  ((mail-data
    :initform (make-array (* 1024 8)
                          :element-type 'flexi-streams:octet
                          :initial-element 0
                          :fill-pointer 0
                          :adjustable t)
    :accessor conn-mail-data)))

(defclass smtp-conn-delivered (smtp-conn-data) ())

(defgeneric process-smtp-command (conn cmd)
  (:documentation "Processes the SMTP command object CMD on connection CONN."))

(defmethod process-smtp-command ((conn smtp-conn) cmd)
  (declare (ignore cmd))
  (conn-write conn "500 I'm not sure I follow. (command unrecognized, malformed, or in the wrong place)"))

(defmethod process-smtp-command ((conn smtp-conn) (cmd cmd-rset))
  (declare (ignore cmd))
  (conn-write conn "250 I know no-thing. Noooo-thing!")
  (change-class conn 'smtp-conn-initial))

(defmethod process-smtp-command ((conn smtp-conn) (cmd cmd-quit))
  (declare (ignore cmd))
  (conn-write conn "221 kthxbai")
  (throw 'end-conn nil))

(defmethod process-smtp-command ((conn smtp-conn) (cmd cmd-noop))
  (declare (ignore cmd))
  (conn-write conn "250 Well, that was a waste of some CPU cycles, wasn't it?"))

(defmethod process-smtp-command ((conn smtp-conn-initial) (cmd helo-or-ehlo))
  (if (typep cmd 'ehlo)
      (progn
        (conn-write conn (get-saying))
        (when (and *ssl-key-path* *ssl-cert-path*)
          (conn-write conn "250-STARTTLS"))
        (conn-write conn "250-SMTPUTF8")
        (conn-write conn "250-8BITMIME")
        (conn-write conn (format nil "250 SIZE ~A" *max-size-bytes*)))
      (conn-write conn (format nil "250 Hey ~A, I'm ~A o/" (supplied-domain cmd) *our-fqdn*)))
  (change-class conn 'smtp-conn-ehlo
                :domain (supplied-domain cmd)))

(defmethod process-smtp-command ((conn smtp-conn-ehlo) (cmd mail-from))
  (when (and (mail-size cmd) (> (mail-size cmd) *max-size-bytes*))
    (conn-write conn (format nil "552 Your message (~A bytes) is too big; the maximum message size is ~A bytes" (mail-size cmd) *max-size-bytes*))
    (return-from process-smtp-command))
  (conn-write conn "250 Sofa, so good.")
  (change-class conn 'smtp-conn-from
                :from-addr (mail-addr cmd)))

(defmethod process-smtp-command ((conn smtp-conn-from) (cmd rcpt-to))
  (when (> (length (conn-to-addrs conn)) 100)
    (conn-write conn "452 Too many recipients")
    (return-from process-smtp-command))
  (unless (string= (nth-value 1 (split-address (mail-addr cmd))) *our-mail-domain*)
    (conn-write conn "550 I can't handle mail for that domain (relaying isn't implemented)")
    (return-from process-smtp-command))
  (push (mail-addr cmd) (conn-to-addrs conn))
  (conn-write conn "250 OK"))

(defmethod process-smtp-command ((conn smtp-conn-from) (cmd cmd-data))
  (when (eql (length (conn-to-addrs conn)) 0)
    (conn-write conn "554 Wait, who am I sending this to again? (please send RCPT TO first)")
    (return-from process-smtp-command))
  (conn-write conn "354 Ready to ingest juicy email data. End with <CRLF>.<CRLF>")
  (change-class conn 'smtp-conn-data))

(defun format-remote-host (host)
  (or
   (ignore-errors
    (format nil "~A.~A.~A.~A" (elt host 0) (elt host 1) (elt host 2) (elt host 3)))
   (format nil "<~A>" host)))

(defun add-mail-headers (conn)
  "Adds some Received, Return-Path etc. headers to the mail data object of CONN."
  (with-accessors ((mail-data conn-mail-data)) conn
    (let ((out (make-string-output-stream)))
      (labels ((crlf ()
                 (write-char #\Return out)
                 (write-char #\Linefeed out)))
        (format out "Return-Path: <~A>" (conn-from-addr conn))
        (crlf)
        (format out "Delivered-To: ~A" (first (conn-to-addrs conn)))
        (crlf)
        (format out "Received: from ~A ([~A]) by ~A (siss) with ~A id ~A for <~A>; ~A"
                (conn-domain conn)
                (conn-remote-host conn)
                *our-fqdn*
                (if (conn-tlsp conn) "ESMTPS" "SMTP")
                (random 1000000000)
                (first (conn-to-addrs conn))
                (local-time:format-rfc1123-timestring nil (local-time:now)))
        (crlf)
        (let ((header-octets (babel:string-to-octets (get-output-stream-string out))))
          (loop
            for octet across header-octets
            do (vector-push-extend octet mail-data)))))))

(defun data-loop (conn)
  "Loops, receiving mail data from CONN's socket and adding it to CONN's internal buffer, until all the mail data is received."
  (with-accessors ((stream conn-sock) (mail-data conn-mail-data)) conn
    (let ((headers-length (length mail-data)))
      (loop
        (block loop-body
          (when (>= (length mail-data) (+ *max-size-bytes* headers-length))
            (conn-write conn (format nil "552 Data transfer interrupted: your message data (~A bytes) is too big; the maximum message size is ~A bytes" (- (length mail-data) headers-length) *max-size-bytes*))
            (error "Maximum message size exceeded"))
          (let* ((start-idx (length mail-data))
                 (new-length (+ start-idx *max-data-line-length*)))
            (setf mail-data (adjust-array mail-data new-length
                                          :fill-pointer start-idx))
            (let* ((bytes-read (stream-read-sequence-until stream #.(char-code #\linefeed) mail-data
                                                           :start start-idx))
                   (string-read (subseq mail-data start-idx (+ start-idx bytes-read))))
              (when (>= bytes-read *max-data-line-length*)
                (conn-write conn "500 Data line too long")
                (return-from loop-body))
              (when (eql bytes-read 0)
                (error "Unexpected EOF"))
              (when (and (<= bytes-read 3)
                         (eql (elt string-read 0) #.(char-code #\.)))
                ;; Get rid of the last <CRLF>.<CRLF>
                (setf (fill-pointer mail-data) (max (- (length mail-data) bytes-read 2) 0))
                (return)))))))))

(defun send-initial-header (conn)
  (conn-write conn (format nil "220 ~A ESMTP nom nom, feed me your mail" *our-fqdn*)))

(define-condition too-much-evil-error (error) ())

(defun mail-loop (conn)
  "Loops, receiving SMTP messages from CONN's socket and applying them to CONN, until the user disconnects or an error is thrown."
  (send-initial-header conn)
  (with-accessors ((stream conn-sock) (tlsp conn-tlsp) (ra conn-remote-host)) conn
    (let ((line-buf (make-array *max-line-length*
                                :element-type '(unsigned-byte 8)
                                :fill-pointer 0))
          (evil-count 0)
          (lines-processed 0))
      (loop
        (block loop-body
          (labels ((on-evil-action ()
                     (when (> (incf evil-count) 7)
                       (error 'too-much-evil-error))))
            (setf (fill-pointer line-buf) 0)
            (let ((bytes-read (stream-read-sequence-until stream (char-code #\linefeed) line-buf)))
              (when (>= bytes-read *max-line-length*)
                (conn-write conn "500 Line too long")
                (on-evil-action)
                (return-from loop-body))
              (when (eql bytes-read 0)
                (error "Unexpected EOF"))
              (incf lines-processed)
              (when (> lines-processed 50)
                (error 'too-much-evil-error))
              (let* ((line (babel:octets-to-string line-buf
                                                   :encoding :utf-8
                                                   :errorp nil))
                     (line (string-right-trim '(#\Space #\Tab #\Return #\Linefeed) line))
                     (smtp-command (parse-smtp-command line)))
                (format *debug-io* "~&~A <-- ~A~%" ra line)
                (unless smtp-command
                  (when (and *enable-proxy-protocol* (uiop:string-prefix-p "PROXY " line))
                    (let ((proxy-src (extract-proxy-source-address line)))
                      (format *debug-io* "~&PROXY protocol: got source address ~A~%" proxy-src)
                      (when proxy-src
                        (setf (conn-remote-host conn) proxy-src)
                        (return-from loop-body))))
                  (on-evil-action)
                  (conn-write conn "500 Couldn't parse SMTP command. Did you read the RFC?")
                  (return-from loop-body))
                (when (and (typep smtp-command 'starttls) (not tlsp)
                           *ssl-key-path* *ssl-cert-path*)
                  (conn-write conn "220 [encryption noises]")
                  (setf stream (cl+ssl:make-ssl-server-stream stream
                                                              :certificate *ssl-cert-path*
                                                              :key *ssl-key-path*))
                  (setf tlsp t)
                  (change-class conn 'smtp-conn-initial)
                  (return-from loop-body))
                (process-smtp-command conn smtp-command)
                (when (typep conn 'smtp-conn-data)
                  (add-mail-headers conn)
                  (data-loop conn)
                  (handler-case
                      (let ((tid (deliver-mail conn)))
                        (conn-write conn (format nil "250 Mail delivered as #~A \o/" tid)))
                    (error (e)
                      (format *error-output* "~&failed to deliver!~%~A~%" e)
                      (conn-write conn "451 Couldn't deliver mail; retry?")))
                  (change-class conn 'smtp-conn-delivered))))))))))

(defun deliver-mail (conn)
  "Delivers the mail data stored in CONN. Returns the RT ticket ID, if delivery was successful."
  (let* ((mail (conn-mail-data conn))
         (first-to-addr (first (conn-to-addrs conn)))
         (to-localpart (split-address first-to-addr))
         (queue-to-use (or
                        (cdr (assoc to-localpart *recipient-queue-mappings*))
                        *default-rt-queue*)))
    (format *debug-io* "~&got a mail:~%~A~%"
            (babel:octets-to-string mail
                                    :errorp nil))
    (format *debug-io* "~&intended for ~A@ => queue ~A~%" to-localpart queue-to-use)
    (multiple-value-bind (filtered-mail spamp spam-header)
        (if (and *sa-host* *sa-port*)
            (bounded-spamc-process mail)
            mail)
      (when spam-header
        (format *debug-io* "~&mail spam result: ~A~%" spam-header))
      (when spamp
        (setf queue-to-use *spam-rt-queue*))
      (multiple-value-bind (ticket-id body)
          (upload-email-to-rt filtered-mail queue-to-use)
        (if ticket-id
            (format *debug-io* "~&delivered as ticket ~A!~%" ticket-id)
            (error "RT returned error: ~A" body))
        ticket-id))))

(defun make-smtp-conn (sock)
  "Make a SMTP-CONN object out of SOCK."
  (let ((remote-addr (usocket:get-peer-address sock)))
    (make-instance 'smtp-conn-initial
                   :remote-host (format-remote-host remote-addr)
                   :sock (usocket:socket-stream sock))))

(defun smtp-listen (host port)
  (let ((master-socket (usocket:socket-listen host port
                                              :reuse-address t
                                              :element-type '(unsigned-byte 8))))
    (unwind-protect
         (loop
           (let* ((sock (usocket:socket-accept master-socket))
                  (conn (make-smtp-conn sock)))
             (symbol-macrolet
                 ((evilness (gethash (conn-remote-host conn) *bad-hosts*)))
               (if (and evilness (> evilness 5))
                   (usocket:socket-close sock)
                   (progn
                     (format *debug-io* "~&hark, a client from ~A~%" (conn-remote-host conn))
                     (bt:make-thread
                      (lambda ()
                        (unwind-protect
                             (handler-case
                                 (catch 'end-conn
                                   (mail-loop conn))
                               (end-of-file () (format *debug-io* "~&an eof! how rude.~%"))
                               (babel-encodings:character-decoding-error (e) (format *debug-io* "~&a dodgy character!~%~A~%" e))
                               (cl+ssl::ssl-error-ssl (e) (format *debug-io* "~&ssl error: ~A~%" e))
                               (simple-error (e) (format *debug-io* "~&the simplest of errors: ~A~%" e))
                               (too-much-evil-error ()
                                 (unless evilness
                                   (setf evilness 0))
                                 (incf evilness)
                                 (format *error-output* "~&host ~A is evil. current evilness score: ~A~%" (conn-remote-host conn) evilness))
                               (stream-error (e) (format *debug-io* "~&stream error: ~A~%" e))
                               (error (e)
                                 (format *error-output* "~&error on connection!~%~A~%" e)
                                 (ignore-errors
                                  (conn-write conn "421 Internal server error"))))
                          (ignore-errors
                           (usocket:socket-close sock))))
                      :name (format nil "SMTP thread for ~A" (conn-remote-host conn))))))))
      (ignore-errors (usocket:socket-close master-socket)))))

(defun read-spamd-line (line-buf stream)
  "Read a header line from the spamd stream STREAM, using LINE-BUF to store the data."
  (setf (fill-pointer line-buf) 0)
  (loop
    with byte
    do (progn
         (setf byte (read-byte stream))
         (vector-push-extend byte line-buf))
    while (not (eql byte #.(char-code #\linefeed))))
  (string-right-trim '(#\Space #\Tab #\Return #\Linefeed)
                     (babel:octets-to-string line-buf)))

(defun bounded-spamc-process (mail-data &optional (timeout *sa-timeout*))
  "Like SPAMC-PROCESS, but uses a thread and waits at most TIMEOUT seconds before giving up and just returning the mail data back."
  (let ((thread (sb-thread:make-thread
                 (lambda ()
                   (handler-case
                       (spamc-process mail-data)
                     (error (e)
                       (format *error-output* "~&failed to spamc process: ~A~%" e)
                       mail-data)))
                 :name "spamc thread")))
    (handler-case
        (sb-thread:join-thread thread
                               :timeout timeout)
      (sb-thread:join-thread-error () mail-data))))

(defun spamc-process (mail-data)
  "Send MAIL-DATA, a MIME-encoded email blob, over to a SpamAssassin spamd server, returning (VALUES DATA SPAMP SPAM-HEADER), where DATA is the mail blob after processing, SPAMP is a boolean indicating whether or not the mail is spam, and SPAM-HEADER (if SPAMP is T) is a textual description of the spam score."
  (let* ((sock (usocket:socket-connect *sa-host* *sa-port*
                                       :element-type '(unsigned-byte 8)))
         (stream (usocket:socket-stream sock)))
    ;; Send the mail for processing
    (write-line-bytes stream "PROCESS SPAMC/1.5")
    (write-line-bytes stream (format nil "Content-length: ~A" (length mail-data)))
    (write-crlf-bytes stream)
    (write-sequence mail-data stream)
    (force-output stream)
    (usocket:socket-shutdown sock :output)
    (let* ((line-buf (make-array *max-data-line-length* ; good first approximation
                                 :element-type '(unsigned-byte 8)
                                 :fill-pointer 0))
           (first-line (read-spamd-line line-buf stream))
           (ret-code (parse-integer (elt (split-sequence:split-sequence #\Space first-line) 1))))
      (when (not (eql ret-code 0))
        (error "spamd returned an error: ~A" first-line))
      (let* ((headers (loop
                        with line
                        do (setf line (read-spamd-line line-buf stream))
                        while (> (length line) 0)
                        collect (multiple-value-bind (header-name header-value)
                                    (split-at line (position #\: line))
                                  (cons header-name (subseq header-value 1)))))
             (content-length (parse-integer (cdr (assoc "Content-length" headers
                                                        :test #'string=))))
             (spam-header (cdr (assoc "Spam" headers
                                      :test #'string=)))
             (ret-buf (make-array (min content-length *max-spamd-content-length*)
                                  :element-type '(unsigned-byte 8)
                                  :fill-pointer 0)))
        (handler-case
            (loop
              do (vector-push (read-byte stream) ret-buf))
          (end-of-file () nil))
        (values ret-buf
                (uiop:string-prefix-p "True" spam-header)
                spam-header)))))

(defun make-rt-email-body (mail-data queue action)
  "Hack: RT breaks if we send it a filename in the multipart/form-data request body. To work around this, we just write our own request body instead of using Drakma's (which will unconditionally append a filename). This function returns a lambda we can pass to DRAKMA:HTTP-REQUEST that writes out the request body, as well as returning a Content-Type."
  (let ((boundary (format nil "----------~A" (drakma::make-random-string))))
    (values
     (lambda (stream)
       (labels ((crlf ()
                  (write-char #\Return stream)
                  (write-char #\Linefeed stream))
                (write-header (name)
                  (format stream "--~A" boundary)
                  (crlf)
                  (format stream "Content-Disposition: form-data; name=\"~A\"" name)
                  (crlf)))
         (write-header "queue")
         (crlf) (format stream "~A" queue) (crlf)
         (write-header "action")
         (crlf) (format stream "~A" action) (crlf)
         (write-header "message")
         (format stream "Content-Type: application/octet-stream")
         (crlf) (crlf) (write-sequence mail-data stream) (crlf)
         (format stream "--~A--" boundary) (crlf)))
     (format nil "multipart/form-data; boundary=~A" boundary))))

(defun upload-email-to-rt (mail-data queue &key (action "correspond"))
  "Upload the MIME-encoded email stored in MAIL-DATA to the RT server, aiming to enqueue it in the QUEUE queue.
Returns the RT ticket ID of the new ticket if successful, and the complete body as 2nd value."
  (multiple-value-bind (request-body content-type)
      (make-rt-email-body mail-data queue action)
    (let ((body
            (drakma:http-request *rt-gateway-url*
                                 :method :post
                                 :content-type content-type
                                 :content request-body)))
      (let ((ticket-id (extract-rt-ticket-id body)))
        (values ticket-id body)))))

(defmacro load-env-vars (&rest env-var-pairs)
  `(progn
     ,@(loop
         for evp in env-var-pairs
         collect (destructuring-bind
                     (name variable &key func (required t)) evp
                   (let ((var-sym (gensym))
                         (func (or func 'identity)))
                     `(let ((,var-sym (uiop:getenv ,name)))
                        (when ,var-sym
                          (setf ,variable (funcall (function ,func) ,var-sym)))
                        (unless (or ,variable (not ,required))
                          (error "The ~A environment variable must be set." ,name))))))))

(defun real-main ()
  (load-env-vars
   ("SISS_MAX_SIZE_BYTES" *max-size-bytes*
                          :func parse-integer)
   ("SISS_MAX_SPAMD_SIZE_BYTES" *max-spamd-content-length*
                                :func parse-integer
                                :required nil)
   ("SISS_OUR_FQDN" *our-fqdn*)
   ("SISS_OUR_MAIL_DOMAIN" *our-mail-domain*
                           :required nil)
   ("SISS_RT_GATEWAY_URL" *rt-gateway-url*)
   ("SISS_SSL_CERT_PATH" *ssl-cert-path*
                         :required nil)
   ("SISS_SSL_KEY_PATH" *ssl-key-path*
                        :required nil)
   ("SISS_DEFAULT_RT_QUEUE" *default-rt-queue*)
   ("SISS_SPAM_RT_QUEUE" *spam-rt-queue*)
   ("SISS_RECIPIENT_QUEUE_MAPPINGS" *recipient-queue-mappings*
                                    :func read-from-string
                                    :required nil)
   ("SISS_SA_HOST" *sa-host*
                   :required nil)
   ("SISS_SA_PORT" *sa-port*
                   :func parse-integer
                   :required nil)
   ("SISS_SA_TIMEOUT" *sa-timeout*
                      :func parse-integer)
   ("SISS_LISTEN_HOST" *listen-host*
                       :required nil)
   ("SISS_LISTEN_PORT" *listen-port*
                       :func parse-integer
                       :required nil)
   ("SISS_ENABLE_PROXY_PROTOCOL" *enable-proxy-protocol*
                                 :required nil))
  (when (not *max-spamd-content-length*)
    (setf *max-spamd-content-length* (* *max-size-bytes* 2)))
  (when (not *our-mail-domain*)
    (setf *our-mail-domain* *our-fqdn*))
  (format t "*** Somewhat Immature SMTP Server, version 0.0.1~%")
  (format t "*** (an eta insane idea: https://theta.eu.org/)~%")
  (format t "[+] I am host '~A', doing mail for '~A'.~%" *our-fqdn* *our-mail-domain*)
  (format t "[+] Mails get posted to the RT gateway URL '~A'.~%" *rt-gateway-url*)
  (if (and *ssl-cert-path* *ssl-key-path*)
      (format t "[+] SSL is enabled. Using cert '~A' with key '~A'.~%" *ssl-cert-path* *ssl-key-path*)
      (format t "[-] SSL is disabled.~%"))
  (if (and *sa-host* *sa-port*)
      (format t "[+] Mails will be checked using the SpamAssassin server hosted at ~A:~A (timeout ~A secs).~%" *sa-host* *sa-port* *sa-timeout*)
      (format t "[-] SpamAssassin checking is disabled.~%"))
  (format t "[+] The default RT queue is '~A' (spam goes to '~A').~%" *default-rt-queue* *spam-rt-queue*)
  (when *recipient-queue-mappings*
    (format t "[+] The following custom mappings are defined: ~A~%" *recipient-queue-mappings*))
  (when *enable-proxy-protocol*
    (format t "[+] The haproxy PROXY protocol is enabled. (WARNING: Do not allow hosts to connect directly to this server!)~%"))
  (format t "[+] Listening for incoming SMTP connections on '~A', port ~A...~%" *listen-host* *listen-port*)
  (smtp-listen *listen-host* *listen-port*))

(defun report-error-and-die (err)
  (trivial-backtrace:print-backtrace err
                                     :output *error-output*)
  (sb-ext:exit :code 1 :abort t))

(defun main ()
  "Hacky main() function for running this in 'the real world' (outside emacs)"
  (setf *debugger-hook* (lambda (condition hook)
                          (declare (ignore hook))
                          (report-error-and-die condition)))
  (real-main))