You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
539 lines
25 KiB
539 lines
25 KiB
;;;; 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))
|