Commit 47139ee4 authored by Kilian M. Haemmerle's avatar Kilian M. Haemmerle 💬
Browse files

Merge branch 'add-restarts-extract-domain' into 'master'

added a pair of restarts around 'extract-domain-from-email-address'

See merge request !10
parents 1aebe7dd 2d66a584
Loading
Loading
Loading
Loading
+62 −20
Original line number Diff line number Diff line
@@ -260,16 +260,58 @@ header is generated at all.")

(a:define-constant +message-id-header-key+ "Message-ID" :test #'string=)

(defun generate-message-id-header (header-value)
  (list +message-id-header-key+ header-value))
(defun generate-message-id-uuidv7@domain (sender-address)
  (restart-case
      (generate-email-message-id (extract-domain-from-email-address sender-address))
    (send-without-message-id ()
      :report "send email without message-id header"
      nil)
    (use-local-hostname ()
      :report (lambda (stream)
                (format stream
                        "use local-host-name (\"~a\") as domain part after the '@' in in the message-id header"
                        (usocket::get-host-name)))
      (generate-email-message-id (usocket::get-host-name)))
    (use-custom-domain-part (domain)
      :report "provide a string for the part after the '@' in in the message-id header"
      :interactive (lambda ()
                     (write-sequence "provide a string for the part after the '@' in in the message-id header: "
                                     *standard-output*)
                     (multiple-value-list (eval (read))))
      (generate-email-message-id domain))
    (use-custom-message-id (message-id)
      :report "provide a string that will be used as message-id header"
      :interactive (lambda ()
                     (write-sequence "provide a string that will be used as message-id header: "
                                     *standard-output*)
                     (multiple-value-list (eval (read))))
      message-id)))

(defparameter *message-id-generator* :uuidv7@domain)

(defgeneric generate-message-id-header (generator sender-address))

(defmethod generate-message-id-header ((generator string) sender-address)
  (declare (ignore sender-address))
  generator)

(defmethod generate-message-id-header ((generator null) sender-address)
  (declare (ignore sender-address))
  nil)

(defmethod generate-message-id-header ((generator (eql :uuidv7@domain)) sender-address)
  (generate-message-id-uuidv7@domain sender-address))

(defmethod generate-message-id-header ((generator (eql :uuidv7)) sender-address)
  (generate-message-id-header :uuidv7@domain sender-address))

(defun send-email (host from to subject message
		   &key ssl (port (if (eq :tls ssl) 465 25)) cc bcc reply-to extra-headers
		     html-message display-name authentication
		     attachments (buffer-size 256) envelope-sender
                     (external-format :utf-8) local-hostname
                     (message-id
                      (generate-email-message-id (extract-domain-from-email-address from))))
                     (message-id *message-id-generator*))
  (let ((message-id (generate-message-id-header message-id from)))
    (send-smtp host from (check-arg to "to") subject (mask-dot message)
	       :port port :cc (check-arg cc "cc") :bcc (check-arg bcc "bcc")
	       :reply-to reply-to
@@ -285,7 +327,7 @@ header is generated at all.")
	       :envelope-sender (or envelope-sender from)
               :external-format external-format
	       :ssl ssl
             :local-hostname (or local-hostname (get-host-name))))
               :local-hostname (or local-hostname (get-host-name)))))

(defun send-smtp (host from to subject message
                  &key ssl (port (if (eq :tls ssl) 465 25)) cc bcc
+6 −2
Original line number Diff line number Diff line
@@ -56,7 +56,11 @@
	   #:write-rfc5322-message
           #:write-rfc8822-message ;; deprecated
           #:*debug*
	   ))
           ;; restart-case case-names
           #:send-without-message-id
           #:use-local-hostname
           #:use-custom-domain-part
           #:use-custom-message-id))

(in-package :cl-smtp)