penpot/backend/src/app/email.clj

;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS SUBSIDIARY SL

(ns app.email
  "Main api for send emails."
  (:refer-clojure :exclude [send])
  (:require
   [app.common.data :as d]
   [app.common.data.macros :as dm]
   [app.common.exceptions :as ex]
   [app.common.logging :as l]
   [app.common.pprint :as pp]
   [app.common.schema :as sm]
   [app.config :as cf]
   [app.db :as db]
   [app.db.sql :as sql]
   [app.jobs :as jobs]
   [app.util.template :as tmpl]
   [clojure.java.io :as io]
   [cuerdas.core :as str]
   [integrant.core :as ig])
  (:import
   jakarta.mail.internet.InternetAddress
   jakarta.mail.internet.MimeBodyPart
   jakarta.mail.internet.MimeMessage
   jakarta.mail.internet.MimeMultipart
   jakarta.mail.Message$RecipientType
   jakarta.mail.Session
   jakarta.mail.Transport
   java.util.Properties))

(defn clean
  "Clean and normalizes email address string"
  [email]
  (let [email (str/lower email)
        email (if (str/starts-with? email "mailto:")
                (subs email 7)
                email)
        email (if (or (str/starts-with? email "<")
                      (str/ends-with? email ">"))
                (str/trim email "<>")
                email)]
    email))

(defn get-domain
  [email]
  (let [email      (clean email)
        [_ domain] (str/split email "@" 2)]
    domain))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; EMAIL IMPL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn- parse-address
  ^"[Ljakarta.mail.internet.InternetAddress;"
  [v]
  (InternetAddress/parse ^String v))

(defn- resolve-recipient-type
  ^Message$RecipientType
  [type]
  (case type
    :to  Message$RecipientType/TO
    :cc  Message$RecipientType/CC
    :bcc Message$RecipientType/BCC))

(defn- assign-recipient
  [^MimeMessage mmsg type address]
  (if (sequential? address)
    (reduce #(assign-recipient %1 type %2) mmsg address)
    (let [address (parse-address address)
          type    (resolve-recipient-type type)]
      (.addRecipients mmsg type address)
      mmsg)))
(defn- assign-recipients
  [mmsg {:keys [to cc bcc] :as params}]
  (cond-> mmsg
    (some? to)  (assign-recipient :to to)
    (some? cc)  (assign-recipient :cc cc)
    (some? bcc) (assign-recipient :bcc bcc)))

(defn- assign-from
  [mmsg {:keys [::default-from] :as cfg} {:keys [from] :as params}]
  (let [from (or from default-from)]
    (when from
      (let [from (parse-address from)]
        (.addFrom ^MimeMessage mmsg from)))))

(defn- assign-reply-to
  [mmsg {:keys [::default-reply-to] :as cfg} {:keys [reply-to] :as params}]
  (let [reply-to (or reply-to default-reply-to)]
    (when reply-to
      (let [reply-to (parse-address reply-to)]
        (.setReplyTo ^MimeMessage mmsg reply-to)))))

(defn- assign-subject
  [mmsg {:keys [subject charset] :or {charset "utf-8"} :as params}]
  (assert (string? subject) "subject is mandatory")
  (.setSubject ^MimeMessage mmsg
               ^String subject
               ^String charset))

(defn- assign-extra-headers
  [^MimeMessage mmsg {:keys [headers extra-data] :as params}]
  (let [headers (assoc headers "X-Penpot-Data" extra-data)]
    (reduce-kv (fn [^MimeMessage mmsg k v]
                 (doto mmsg
                   (.addHeader (name k) (str v))))
               mmsg
               headers)))

(defn- assign-body
  [^MimeMessage mmsg {:keys [body charset attachments] :or {charset "utf-8"}}]
  (let [mixed-mpart  (MimeMultipart. "mixed")]
    (cond
      (string? body)
      (let [text-part (MimeBodyPart.)]
        (.setText text-part ^String body ^String charset)
        (.addBodyPart mixed-mpart text-part))

      (map? body)
      (let [content-part      (MimeBodyPart.)
            alternative-mpart (MimeMultipart. "alternative")]

        (when-let [content (get body "text/plain")]
          (let [text-part (MimeBodyPart.)]
            (.setText text-part ^String content ^String charset)
            (.addBodyPart alternative-mpart text-part)))

        (when-let [content (get body "text/html")]
          (let [html-part (MimeBodyPart.)]
            (.setContent html-part ^String content
                         (str "text/html; charset=" charset))
            (.addBodyPart alternative-mpart html-part)))

        (.setContent content-part alternative-mpart)
        (.addBodyPart mixed-mpart content-part))

      :else
      (throw (IllegalArgumentException. "invalid email body provided")))

    (doseq [[name content] attachments]
      (let [attachment-part (MimeBodyPart.)]
        (.setFileName attachment-part ^String name)
        (.setContent attachment-part ^String content (str "text/plain; charset=" charset))
        (.addBodyPart mixed-mpart attachment-part)))

    (.setContent mmsg mixed-mpart)
    mmsg))

(defn- opts->props
  [{:keys [::username ::tls ::host ::port ::timeout ::default-from]
    :or {timeout 30000}}]
  (reduce-kv
   (fn [^Properties props k v]
     (if (nil? v)
       props
       (doto props (.put ^String k  ^String (str v)))))
   (Properties.)
   {"mail.user" username
    "mail.host" host
    "mail.debug" (contains? cf/flags :smtp-debug)
    "mail.from" default-from
    "mail.smtp.auth" (boolean username)
    "mail.smtp.starttls.enable" tls
    "mail.smtp.starttls.required" tls
    "mail.smtp.host" host
    "mail.smtp.port" port
    "mail.smtp.user" username
    "mail.smtp.timeout" timeout
    "mail.smtp.connectiontimeout" timeout}))

(def ^:private schema:smtp-config
  [:map
   [::username {:optional true} :string]
   [::password {:optional true} :string]
   [::tls {:optional true} ::sm/boolean]
   [::ssl {:optional true} ::sm/boolean]
   [::host {:optional true} :string]
   [::port {:optional true} ::sm/int]
   [::default-from {:optional true} :string]
   [::default-reply-to {:optional true} :string]])

(def valid-smtp-config?
  (sm/check-fn schema:smtp-config))

(defn- create-smtp-session
  ^Session
  [cfg]
  (dm/assert!
   "expected valid smtp config"
   (valid-smtp-config? cfg))

  (let [props (opts->props cfg)]
    (Session/getInstance props)))

(defn- create-smtp-message
  ^MimeMessage
  [cfg session params]
  (let [mmsg (MimeMessage. ^Session session)]
    (assign-recipients mmsg params)
    (assign-from mmsg cfg params)
    (assign-reply-to mmsg cfg params)
    (assign-subject mmsg params)
    (assign-extra-headers mmsg params)
    (assign-body mmsg params)
    (.saveChanges ^MimeMessage mmsg)
    mmsg))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TEMPLATE EMAIL IMPL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def ^:private email-path "app/email/%(id)s/%(lang)s.%(type)s")

(defn- render-email-template-part
  [type id context]
  (let [lang (:lang context :en)
        path (str/format email-path {:id (name id)
                                     :lang (name lang)
                                     :type (name type)})]
    (some-> (io/resource path)
            (tmpl/render context))))

(defn- build-email-template
  [id context]
  (let [subj (render-email-template-part :subj id context)
        text (render-email-template-part :txt id context)
        html (render-email-template-part :html id context)]
    (when (or (not subj)
              (and (not text)
                   (not html)))
      (ex/raise :type :internal
                :code :missing-email-templates))
    {:subject subj
     :body (d/without-nils
            {"text/plain" text
             "text/html" html})}))

(def ^:private schema:params
  [:map {:title "Email Params"}
   [:to [:or ::sm/email [::sm/vec ::sm/email]]]
   [:reply-to {:optional true} ::sm/email]
   [:from {:optional true} ::sm/email]
   [:lang {:optional true} ::sm/text]
   [:subject {:optional true} ::sm/text]
   [:priority {:optional true} [:enum :high :low]]
   [:extra-data {:optional true} ::sm/text]
   [:body {:optional true}
    [:or :string [:map-of :string :string]]]
   [:attachments {:optional true}
    [:map-of :string :string]]])

(def ^:private check-params
  (sm/check-fn schema:params))

(defn template-factory
  [& {:keys [id schema]}]
  (assert (keyword? id) "id should be provided and it should be a keyword")
  (let [check-fn (if schema
                   (sm/check-fn schema)
                   (constantly nil))]
    (fn [params]
      (let [params (-> params check-params check-fn)
            email  (build-email-template id params)]
        (when-not email
          (ex/raise :type :internal
                    :code :email-template-does-not-exists
                    :hint "seems like the template is wrong or does not exists."
                    :template-id id))

        (cond-> (assoc email :id (name id))
          (:extra-data params)
          (assoc :extra-data (:extra-data params))

          (seq (:attachments params))
          (assoc :attachments (:attachments params))

          (:from params)
          (assoc :from (:from params))

          (:reply-to params)
          (assoc :reply-to (:reply-to params))

          (:to params)
          (assoc :to (:to params)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC HIGH-LEVEL API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn render
  [email-factory params]
  (email-factory params))

(defn send
  "Schedule an already defined email to be sent asynchronously
  using the unified jobs machinery. The first `cfg` parameter is the
  connectable context that provides the `::jobs/defs` registry (an RPC
  method cfg or the system) and can provide a default connection; the
  second `params` provides the email data and optionally `::factory`
  and `::reuse-conn`. When `::reuse-conn` is true the submission
  reuses the caller's existing `::db/conn` (from cfg) instead of
  acquiring a fresh one from the pool."
  [cfg {:keys [::reuse-conn ::factory] :as params}]
  (when (and reuse-conn (nil? (::db/conn cfg)))
    (ex/raise :type :validation
              :code :missing-connection
              :hint "reuse-conn requires the caller cfg to carry ::db/conn (call inside a transaction)"))
  (let [email (if factory
                (factory params)
                (-> params
                    (dissoc ::reuse-conn ::factory)
                    (check-params)))]
    (jobs/submit (cond-> (dissoc cfg ::db/conn)
                   reuse-conn (assoc ::db/conn (::db/conn cfg)))
                 {::jobs/name :sendmail
                  ::jobs/delay 0
                  ::jobs/max-retries 4
                  ::jobs/priority 200
                  ::jobs/params email})))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SENDMAIL FN / TASK HANDLER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(declare send-to-logger!)

(defn- sendmail-impl
  [cfg params]
  (when (contains? cf/flags :smtp)
    (let [session (create-smtp-session cfg)]
      (with-open [transport (.getTransport session (if (::ssl cfg) "smtps" "smtp"))]
        (.connect ^Transport transport
                  ^String (::host cfg)
                  ^String (::port cfg)
                  ^String (::username cfg)
                  ^String (::password cfg))

        (let [^MimeMessage message (create-smtp-message cfg session params)]
          (l/dbg :hint "sendmail"
                 :id (:id params)
                 :to (:to params)
                 :subject (str/trim (:subject params)))

          (.sendMessage ^Transport transport
                        ^MimeMessage message
                        (.getAllRecipients message))))))

  (when (contains? cf/flags :log-emails)
    (send-to-logger! cfg params)))

(defmethod ig/init-key ::sendmail
  [_ cfg]
  ;; the job handler: [context params]. The smtp deps are closed over
  ;; here, and this job has no use for the context.
  (fn [_context params]
    (sendmail-impl cfg params)))

(defmethod ig/init-key ::job-def
  [_ {sendmail ::sendmail}]
  {::jobs/name      :sendmail
   ::jobs/schema    schema:params
   ::jobs/handler   sendmail
   ::jobs/decoder   (sm/decoder schema:params sm/json-transformer)
   ::jobs/validator (sm/validator schema:params)})

(defn- send-to-logger!
  [_ email]
  (let [body (:body email)
        out  (with-out-str
               (println "email console dump:")
               (println "******** start email" (:id email) "**********")
               (pp/pprint (dissoc email :body))
               (if (string? body)
                 (println body)
                 (println (->> body
                               (filter #(= "text/plain" (:type %)))
                               (map :content)
                               first)))
               (println "******** end email" (:id email) "**********"))]
    (l/raw! :info out)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; EMAIL FACTORIES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def ^:private schema:feedback
  [:map
   [:feedback-subject ::sm/text]
   [:feedback-type ::sm/text]
   [:feedback-content ::sm/text]
   [:profile :map]])

(def user-feedback
  "A profile feedback email."
  (template-factory
   :id ::feedback
   :schema schema:feedback))

(def ^:private schema:register
  [:map [:name ::sm/text]])

(def register
  "A new profile registration welcome email."
  (template-factory
   :id ::register
   :schema schema:register))

(def ^:private schema:password-recovery
  [:map
   [:name ::sm/text]
   [:token ::sm/text]])

(def password-recovery
  "A password recovery notification email."
  (template-factory
   :id ::password-recovery
   :schema schema:password-recovery))

(def ^:private schema:password-changed
  [:map
   [:name ::sm/text]])

(def password-changed
  "A password changed notification email."
  (template-factory
   :id ::password-changed
   :schema schema:password-changed))

(def ^:private schema:change-email
  [:map
   [:name ::sm/text]
   [:pending-email ::sm/email]
   [:token ::sm/text]])

(def change-email
  "Password change confirmation email"
  (template-factory
   :id ::change-email
   :schema schema:change-email))

(def ^:private schema:organization-data
  [:map
   [:name ::sm/text]
   [:initials {:optional true} [:maybe :string]]
   [:logo {:optional true} [:maybe ::sm/uri]]
   [:avatar-bg-url {:optional true} [:maybe ::sm/uri]]
   [:sso-active {:optional true} [:maybe ::sm/boolean]]])

(def ^:private schema:invite-to-team
  [:map
   [:invited-by ::sm/text]
   [:team ::sm/text]
   [:organization {:optional true} [:maybe schema:organization-data]]
   [:token ::sm/text]])

(def invite-to-team
  "Teams member invitation email."
  (template-factory
   :id ::invite-to-team
   :schema schema:invite-to-team))

(def ^:private schema:invite-to-organization
  [:map
   [:invited-by ::sm/text]
   [:user-name [:maybe ::sm/text]]
   [:token ::sm/text]
   [:organization schema:organization-data]])

(def invite-to-organization
  "Organization member invitation email."
  (template-factory
   :id ::invite-to-organization
   :schema schema:invite-to-organization))

(def ^:private schema:organization-setup-sso
  [:map
   [:organization-name ::sm/text]])

(def organization-setup-sso
  "Email when an organization set up SSO"
  (template-factory
   :id ::organization-setup-sso
   :schema schema:organization-setup-sso))

(def ^:private schema:renewal-notice
  [:map
   [:user-name [:maybe :string]]
   [:renewal-date ::sm/text]
   [:estimated-amount ::sm/text]
   [:organizations [:vector schema:organization-data]]])

(def renewal-notice
  "Enterprise subscription renewal notice email."
  (template-factory
   :id ::renewal-notice
   :schema schema:renewal-notice))

(def ^:private schema:join-team
  [:map
   [:invited-by ::sm/text]
   [:team ::sm/text]
   [:team-id ::sm/uuid]])

(def join-team
  "Teams member joined after request email."
  (template-factory
   :id ::join-team
   :schema schema:join-team))

(def ^:private schema:request-file-access
  [:map
   [:requested-by ::sm/text]
   [:requested-by-email ::sm/text]
   [:team-name ::sm/text]
   [:team-id ::sm/uuid]
   [:file-name ::sm/text]
   [:file-id ::sm/uuid]
   [:page-id ::sm/uuid]])

(def request-file-access
  "File access request email."
  (template-factory
   :id ::request-file-access
   :schema schema:request-file-access))

(def request-file-access-yourpenpot
  "File access on Personal Projects request email."
  (template-factory
   :id ::request-file-access-yourpenpot
   :schema schema:request-file-access))

(def request-file-access-yourpenpot-view
  "File access on Personal Projects view mode request email."
  (template-factory
   :id ::request-file-access-yourpenpot-view
   :schema schema:request-file-access))

(def ^:private schema:request-team-access
  [:map
   [:requested-by ::sm/text]
   [:requested-by-email ::sm/text]
   [:team-name ::sm/text]
   [:team-id ::sm/uuid]])

(def request-team-access
  "Team access request email."
  (template-factory
   :id ::request-team-access
   :schema schema:request-team-access))

(def ^:private schema:comment-mention
  [:map
   [:name ::sm/text]
   [:source-user ::sm/text]
   [:comment-reference ::sm/text]
   [:comment-content ::sm/text]
   [:comment-url ::sm/text]])

(def comment-mention
  (template-factory
   :id ::comment-mention
   :schema schema:comment-mention))

(def ^:private schema:comment-thread
  [:map
   [:name ::sm/text]
   [:source-user ::sm/text]
   [:comment-reference ::sm/text]
   [:comment-content ::sm/text]
   [:comment-url ::sm/text]])

(def comment-thread
  (template-factory
   :id ::comment-thread
   :schema schema:comment-thread))

(def ^:private schema:comment-notification
  [:map
   [:name ::sm/text]
   [:source-user ::sm/text]
   [:comment-reference ::sm/text]
   [:comment-content ::sm/text]
   [:comment-url ::sm/text]])

(def comment-notification
  (template-factory
   :id ::comment-notification
   :schema schema:comment-notification))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BOUNCE/COMPLAINS HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def sql:profile-complaint-report
  "select (select count(*)
             from profile_complaint_report
            where type = 'complaint'
              and profile_id = ?
              and created_at > now() - ?::interval) as complaints,
          (select count(*)
             from profile_complaint_report
            where type = 'bounce'
              and profile_id = ?
              and created_at > now() - ?::interval) as bounces;")

(defn allow-send-emails?
  [conn profile]
  (when-not (:is-muted profile false)
    (let [complaint-threshold (cf/get :profile-complaint-threshold)
          complaint-max-age   (cf/get :profile-complaint-max-age)
          bounce-threshold    (cf/get :profile-bounce-threshold)
          bounce-max-age      (cf/get :profile-bounce-max-age)

          {:keys [complaints bounces] :as result}
          (db/exec-one! conn [sql:profile-complaint-report
                              (:id profile)
                              (db/interval complaint-max-age)
                              (:id profile)
                              (db/interval bounce-max-age)])]

      (and (< (or complaints 0) complaint-threshold)
           (< (or bounces 0) bounce-threshold)))))

(defn has-complaint-reports?
  ([conn email] (has-complaint-reports? conn email nil))
  ([conn email {:keys [threshold] :or {threshold 1}}]
   (let [reports (db/exec! conn (sql/select :global-complaint-report
                                            {:email email :type "complaint"}
                                            {:limit 10}))]
     (>= (count reports) threshold))))

(defn has-bounce-reports?
  ([conn email] (has-bounce-reports? conn email nil))
  ([conn email {:keys [threshold] :or {threshold 1}}]
   (let [reports (db/exec! conn (sql/select :global-complaint-report
                                            {:email email :type "bounce"}
                                            {:limit 10}))]
     (>= (count reports) threshold))))

(defn has-reports?
  ([conn email] (has-reports? conn email nil))
  ([conn email {:keys [threshold] :or {threshold 1}}]
   (let [reports (db/exec! conn (sql/select :global-complaint-report
                                            {:email email}
                                            {:limit 10}))]
     (>= (count reports) threshold))))