diff --git a/backend/src/app/email.clj b/backend/src/app/email.clj index 8339e889b..03228e45b 100644 --- a/backend/src/app/email.clj +++ b/backend/src/app/email.clj @@ -446,3 +446,11 @@ {: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)))) diff --git a/backend/src/app/http/awsns.clj b/backend/src/app/http/awsns.clj index 88060bb20..77ae6c5d6 100644 --- a/backend/src/app/http/awsns.clj +++ b/backend/src/app/http/awsns.clj @@ -9,6 +9,7 @@ (:require [app.common.exceptions :as ex] [app.common.logging :as l] + [app.common.pprint :as pp] [app.db :as db] [app.db.sql :as sql] [app.http.client :as http] @@ -16,10 +17,10 @@ [app.setup :as-alias setup] [app.tokens :as tokens] [app.worker :as-alias wrk] + [clojure.data.json :as j] [clojure.spec.alpha :as s] [cuerdas.core :as str] [integrant.core :as ig] - [jsonista.core :as j] [promesa.exec :as px] [ring.request :as rreq] [ring.response :as-alias rres])) @@ -136,83 +137,110 @@ (defn- parse-json [v] - (ex/ignoring - (j/read-value v))) + (try + (j/read-str v) + (catch Throwable cause + (l/wrn :hint "unable to decode request body" + :cause cause)))) (defn- register-bounce-for-profile [{:keys [::db/pool]} {:keys [type kind profile-id] :as report}] (when (= kind "permanent") - (db/with-atomic [conn pool] - (db/insert! conn :profile-complaint-report + (try + (db/insert! pool :profile-complaint-report {:profile-id profile-id :type (name type) :content (db/tjson report)}) - ;; TODO: maybe also try to find profiles by mail and if exists - ;; register profile reports for them? - (doseq [recipient (:recipients report)] - (db/insert! conn :global-complaint-report - {:email (:email recipient) - :type (name type) - :content (db/tjson report)})) + (catch Throwable cause + (l/warn :hint "unable to persist profile complaint" + :cause cause))) - (let [profile (db/exec-one! conn (sql/select :profile {:id profile-id}))] - (when (some #(= (:email profile) (:email %)) (:recipients report)) - ;; If the report matches the profile email, this means that - ;; the report is for itself, can be caused when a user - ;; registers with an invalid email or the user email is - ;; permanently rejecting receiving the email. In this case we - ;; have no option to mark the user as muted (and in this case - ;; the profile will be also inactive. - (db/update! conn :profile - {:is-muted true} - {:id profile-id})))))) - -(defn- register-complaint-for-profile - [{:keys [::db/pool]} {:keys [type profile-id] :as report}] - (db/with-atomic [conn pool] - (db/insert! conn :profile-complaint-report - {:profile-id profile-id - :type (name type) - :content (db/tjson report)}) - - ;; TODO: maybe also try to find profiles by email and if exists - ;; register profile reports for them? - (doseq [email (:recipients report)] - (db/insert! conn :global-complaint-report - {:email email + (doseq [recipient (:recipients report)] + (db/insert! pool :global-complaint-report + {:email (:email recipient) :type (name type) :content (db/tjson report)})) - (let [profile (db/exec-one! conn (sql/select :profile {:id profile-id}))] - (when (some #(= % (:email profile)) (:recipients report)) + (let [profile (db/exec-one! pool (sql/select :profile {:id profile-id}))] + (when (some #(= (:email profile) (:email %)) (:recipients report)) ;; If the report matches the profile email, this means that - ;; the report is for itself, rare case but can happen; In this - ;; case just mark profile as muted (very rare case). - (db/update! conn :profile + ;; the report is for itself, can be caused when a user + ;; registers with an invalid email or the user email is + ;; permanently rejecting receiving the email. In this case we + ;; have no option to mark the user as muted (and in this case + ;; the profile will be also inactive. + + (l/inf :hint "mark profile: muted" + :profile-id (str (:id profile)) + :email (:email profile) + :reason "bounce report" + :report-id (:feedback-id report)) + + (db/update! pool :profile {:is-muted true} - {:id profile-id}))))) + {:id profile-id} + {::db/return-keys false}))))) + +(defn- register-complaint-for-profile + [{:keys [::db/pool]} {:keys [type profile-id] :as report}] + + (try + (db/insert! pool :profile-complaint-report + {:profile-id profile-id + :type (name type) + :content (db/tjson report)}) + (catch Throwable cause + (l/warn :hint "unable to persist profile complaint" + :cause cause))) + + ;; TODO: maybe also try to find profiles by email and if exists + ;; register profile reports for them? + (doseq [email (:recipients report)] + (db/insert! pool :global-complaint-report + {:email email + :type (name type) + :content (db/tjson report)})) + + (let [profile (db/exec-one! pool (sql/select :profile {:id profile-id}))] + (when (some #(= % (:email profile)) (:recipients report)) + ;; If the report matches the profile email, this means that + ;; the report is for itself, rare case but can happen; In this + ;; case just mark profile as muted (very rare case). + (l/inf :hint "mark profile: muted" + :profile-id (str (:id profile)) + :email (:email profile) + :reason "complaint report" + :report-id (:feedback-id report)) + + (db/update! pool :profile + {:is-muted true} + {:id profile-id} + {::db/return-keys false})))) (defn- process-report [cfg {:keys [type profile-id] :as report}] - (l/trace :action "processing report" :report (pr-str report)) (cond ;; In this case we receive a bounce/complaint notification without ;; confirmed identity, we just emit a warning but do nothing about ;; it because this is not a normal case. All notifications should ;; come with profile identity. (nil? profile-id) - (l/warn :msg "a notification without identity received from AWS" - :report (pr-str report)) + (l/wrn :hint "not-identified report" + ::l/body (pp/pprint-str report {:length 40 :level 6})) (= "bounce" type) - (register-bounce-for-profile cfg report) + (do + (l/trc :hint "bounce report" + ::l/body (pp/pprint-str report {:length 40 :level 6})) + (register-bounce-for-profile cfg report)) (= "complaint" type) - (register-complaint-for-profile cfg report) + (do + (l/trc :hint "complaint report" + ::l/body (pp/pprint-str report {:length 40 :level 6})) + (register-complaint-for-profile cfg report)) :else - (l/warn :msg "unrecognized report received from AWS" - :report (pr-str report)))) - - + (l/wrn :hint "unrecognized report" + ::l/body (pp/pprint-str report {:length 20 :level 4})))) diff --git a/backend/src/app/rpc/commands/auth.clj b/backend/src/app/rpc/commands/auth.clj index 50f575755..ff8bfdb8f 100644 --- a/backend/src/app/rpc/commands/auth.clj +++ b/backend/src/app/rpc/commands/auth.clj @@ -209,7 +209,19 @@ (str/lower (:password params))) (ex/raise :type :validation :code :email-as-password - :hint "you can't use your email as password"))) + :hint "you can't use your email as password")) + + (when (eml/has-bounce-reports? cfg (:email params)) + (ex/raise :type :restriction + :code :email-has-permanent-bounces + :email (:email params) + :hint "looks like the email has bounce reports")) + + (when (eml/has-complaint-reports? cfg (:email params)) + (ex/raise :type :restriction + :code :email-has-complaints + :email (:email params) + :hint "looks like the email has complaint reports"))) (defn prepare-register [{:keys [::db/pool] :as cfg} {:keys [email] :as params}] @@ -286,14 +298,17 @@ (try (-> (db/insert! conn :profile params) (profile/decode-row)) - (catch org.postgresql.util.PSQLException e - (let [state (.getSQLState e)] + (catch org.postgresql.util.PSQLException cause + (let [state (.getSQLState cause)] (if (not= state "23505") - (throw e) - (ex/raise :type :validation - :code :email-already-exists - :hint "email already exists" - :cause e))))))) + (throw cause) + + (do + (l/error :hint "not an error" :cause cause) + (ex/raise :type :validation + :code :email-already-exists + :hint "email already exists" + :cause cause)))))))) (defn create-profile-rels! [conn {:keys [id] :as profile}] @@ -398,20 +413,22 @@ ::audit/profile-id (:id profile)})) (do - (send-email-verification! cfg profile) + (when-not (eml/has-reports? conn (:email profile)) + (send-email-verification! cfg profile)) + (rph/with-meta {:email (:email profile)} {::audit/replace-props props ::audit/context {:action "email-verification"} ::audit/profile-id (:id profile)}))) :else - (let [elapsed? (elapsed-verify-threshold? profile) - bounce? (eml/has-bounce-reports? conn (:email profile)) - action (if bounce? - "ignore-because-bounce" - (if elapsed? - "resend-email-verification" - "ignore"))] + (let [elapsed? (elapsed-verify-threshold? profile) + complaints? (eml/has-reports? conn (:email profile)) + action (if complaints? + "ignore-because-complaints" + (if elapsed? + "resend-email-verification" + "ignore"))] (l/wrn :hint "repeated registry detected" :profile-id (str (:id profile)) @@ -446,7 +463,7 @@ ;; ---- COMMAND: Request Profile Recovery (defn- request-profile-recovery - [{:keys [::db/pool] :as cfg} {:keys [email] :as params}] + [{:keys [::db/conn] :as cfg} {:keys [email] :as params}] (letfn [(create-recovery-token [{:keys [id] :as profile}] (let [token (tokens/generate (::setup/props cfg) {:iss :password-recovery @@ -468,39 +485,42 @@ :extra-data ptoken}) nil))] - (db/with-atomic [conn pool] - (let [profile (->> (profile/clean-email email) - (profile/get-profile-by-email conn))] + (let [profile (->> (profile/clean-email email) + (profile/get-profile-by-email conn))] - (cond - (not profile) - (l/wrn :hint "attempt of profile recovery: no profile found" - :profile-email email) + (cond + (not profile) + (l/wrn :hint "attempt of profile recovery: no profile found" + :profile-email email) - (not (eml/allow-send-emails? conn profile)) - (l/wrn :hint "attempt of profile recovery: profile is muted" - :profile-id (str (:id profile)) - :profile-email (:email profile)) + (not (eml/allow-send-emails? conn profile)) + (l/wrn :hint "attempt of profile recovery: profile is muted" + :profile-id (str (:id profile)) + :profile-email (:email profile)) - (eml/has-bounce-reports? conn (:email profile)) - (l/wrn :hint "attempt of profile recovery: email has bounces" - :profile-id (str (:id profile)) - :profile-email (:email profile)) + (eml/has-bounce-reports? conn (:email profile)) + (l/wrn :hint "attempt of profile recovery: email has bounces" + :profile-id (str (:id profile)) + :profile-email (:email profile)) - (not (elapsed-verify-threshold? profile)) - (l/wrn :hint "attempt of profile recovery: retry attempt threshold not elapsed" - :profile-id (str (:id profile)) - :profile-email (:email profile)) + (eml/has-complaint-reports? conn (:email profile)) + (l/wrn :hint "attempt of profile recovery: email has complaints" + :profile-id (str (:id profile)) + :profile-email (:email profile)) + (not (elapsed-verify-threshold? profile)) + (l/wrn :hint "attempt of profile recovery: retry attempt threshold not elapsed" + :profile-id (str (:id profile)) + :profile-email (:email profile)) - :else - (do - (db/update! conn :profile - {:modified-at (dt/now)} - {:id (:id profile)}) - (->> profile - (create-recovery-token) - (send-email-notification conn)))))))) + :else + (do + (db/update! conn :profile + {:modified-at (dt/now)} + {:id (:id profile)}) + (->> profile + (create-recovery-token) + (send-email-notification conn))))))) (def schema:request-profile-recovery @@ -512,6 +532,6 @@ ::doc/added "1.15" ::sm/params schema:request-profile-recovery} [cfg params] - (request-profile-recovery cfg params)) + (db/tx-run! cfg request-profile-recovery params)) diff --git a/backend/src/app/rpc/commands/profile.clj b/backend/src/app/rpc/commands/profile.clj index 985a8b211..40b8b8a43 100644 --- a/backend/src/app/rpc/commands/profile.clj +++ b/backend/src/app/rpc/commands/profile.clj @@ -276,19 +276,19 @@ (sv/defmethod ::request-email-change {::doc/added "1.0" ::sm/params schema:request-email-change} - [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id email] :as params}] - (db/with-atomic [conn pool] - (let [profile (db/get-by-id conn :profile profile-id) - cfg (assoc cfg ::conn conn) - params (assoc params - :profile profile - :email (clean-email email))] - (if (contains? cf/flags :smtp) - (request-email-change! cfg params) - (change-email-immediately! cfg params))))) + [cfg {:keys [::rpc/profile-id email] :as params}] + (db/tx-run! cfg + (fn [cfg] + (let [profile (db/get-by-id cfg :profile profile-id) + params (assoc params + :profile profile + :email (clean-email email))] + (if (contains? cf/flags :smtp) + (request-email-change! cfg params) + (change-email-immediately! cfg params)))))) (defn- change-email-immediately! - [{:keys [::conn]} {:keys [profile email] :as params}] + [{:keys [::db/conn]} {:keys [profile email] :as params}] (when (not= email (:email profile)) (check-profile-existence! conn params)) @@ -299,7 +299,7 @@ {:changed true}) (defn- request-email-change! - [{:keys [::conn] :as cfg} {:keys [profile email] :as params}] + [{:keys [::db/conn] :as cfg} {:keys [profile email] :as params}] (let [token (tokens/generate (::setup/props cfg) {:iss :change-email :exp (dt/in-future "15m") @@ -319,9 +319,28 @@ :hint "looks like the profile has reported repeatedly as spam or has permanent bounces.")) (when (eml/has-bounce-reports? conn email) - (ex/raise :type :validation + (ex/raise :type :restriction :code :email-has-permanent-bounces - :hint "looks like the email you invite has been repeatedly reported as spam or permanent bounce")) + :email email + :hint "looks like the email has bounce reports")) + + (when (eml/has-complaint-reports? conn email) + (ex/raise :type :restriction + :code :email-has-complaints + :email email + :hint "looks like the email has spam complaint reports")) + + (when (eml/has-bounce-reports? conn (:email profile)) + (ex/raise :type :restriction + :code :email-has-permanent-bounces + :email (:email profile) + :hint "looks like the email has bounce reports")) + + (when (eml/has-complaint-reports? conn (:email profile)) + (ex/raise :type :restriction + :code :email-has-complaints + :email (:email profile) + :hint "looks like the email has spam complaint reports")) (eml/send! {::eml/conn conn ::eml/factory eml/change-email diff --git a/backend/src/app/rpc/commands/teams.clj b/backend/src/app/rpc/commands/teams.clj index 03c6027f2..74918de97 100644 --- a/backend/src/app/rpc/commands/teams.clj +++ b/backend/src/app/rpc/commands/teams.clj @@ -734,12 +734,19 @@ :email email :hint "the profile has reported repeatedly as spam or has bounces")) - ;; Secondly check if the invited member email is part of the global spam/bounce report. + ;; Secondly check if the invited member email is part of the global bounce report. (when (eml/has-bounce-reports? conn email) - (ex/raise :type :validation + (ex/raise :type :restriction :code :email-has-permanent-bounces :email email - :hint "the email you invite has been repeatedly reported as spam or bounce")) + :hint "the email you invite has been repeatedly reported as bounce")) + + ;; Secondly check if the invited member email is part of the global complain report. + (when (eml/has-complaint-reports? conn email) + (ex/raise :type :restriction + :code :email-has-complaints + :email email + :hint "the email you invite has been repeatedly reported as spam")) ;; When we have email verification disabled and invitation user is ;; already present in the database, we proceed to add it to the diff --git a/backend/test/backend_tests/rpc_profile_test.clj b/backend/test/backend_tests/rpc_profile_test.clj index 839494a17..7a90c9a81 100644 --- a/backend/test/backend_tests/rpc_profile_test.clj +++ b/backend/test/backend_tests/rpc_profile_test.clj @@ -590,9 +590,10 @@ (th/create-global-complaint-for pool {:type :bounce :email "user@example.com"}) (let [out (th/command! data)] - (t/is (th/success? out)) - (let [result (:result out)] - (t/is (contains? result :token)))))) + (t/is (not (th/success? out))) + (let [edata (-> out :error ex-data)] + (t/is (= :restriction (:type edata))) + (t/is (= :email-has-permanent-bounces (:code edata))))))) (t/deftest register-profile-with-complained-email (let [pool (:app.db/pool th/*system*) @@ -603,9 +604,11 @@ (th/create-global-complaint-for pool {:type :complaint :email "user@example.com"}) (let [out (th/command! data)] - (t/is (th/success? out)) - (let [result (:result out)] - (t/is (contains? result :token)))))) + (t/is (not (th/success? out))) + + (let [edata (-> out :error ex-data)] + (t/is (= :restriction (:type edata))) + (t/is (= :email-has-complaints (:code edata))))))) (t/deftest register-profile-with-email-as-password (let [data {::th/type :prepare-register-profile @@ -636,20 +639,26 @@ ;; with complaints (th/create-global-complaint-for pool {:type :complaint :email (:email data)}) - (let [out (th/command! data)] + (let [out (th/command! data)] ;; (th/print-result! out) (t/is (nil? (:result out))) - (t/is (= 2 (:call-count @mock)))) + + (let [edata (-> out :error ex-data)] + (t/is (= :restriction (:type edata))) + (t/is (= :email-has-complaints (:code edata)))) + + (t/is (= 1 (:call-count @mock)))) ;; with bounces (th/create-global-complaint-for pool {:type :bounce :email (:email data)}) - (let [out (th/command! data) - error (:error out)] + (let [out (th/command! data)] ;; (th/print-result! out) - (t/is (th/ex-info? error)) - (t/is (th/ex-of-type? error :validation)) - (t/is (th/ex-of-code? error :email-has-permanent-bounces)) - (t/is (= 2 (:call-count @mock))))))) + + (let [edata (-> out :error ex-data)] + (t/is (= :restriction (:type edata))) + (t/is (= :email-has-permanent-bounces (:code edata)))) + + (t/is (= 1 (:call-count @mock))))))) (t/deftest email-change-request-without-smtp @@ -714,7 +723,7 @@ out (th/command! data)] ;; (th/print-result! out) (t/is (nil? (:result out))) - (t/is (= 2 (:call-count @mock)))) + (t/is (= 1 (:call-count @mock)))) ;; with valid email and active user with global bounce (th/create-global-complaint-for pool {:type :bounce :email (:email profile2)}) @@ -723,7 +732,7 @@ (t/is (nil? (:result out))) (t/is (nil? (:error out))) ;; (th/print-result! out) - (t/is (= 2 (:call-count @mock)))))))) + (t/is (= 1 (:call-count @mock)))))))) (t/deftest update-profile-password diff --git a/backend/test/backend_tests/rpc_team_test.clj b/backend/test/backend_tests/rpc_team_test.clj index 3bd6ac3b9..8b4ccda3f 100644 --- a/backend/test/backend_tests/rpc_team_test.clj +++ b/backend/test/backend_tests/rpc_team_test.clj @@ -62,8 +62,8 @@ (th/reset-mock! mock) (let [data (assoc data :emails ["foo@bar.com"]) out (th/command! data)] - (t/is (th/success? out)) - (t/is (= 1 (:call-count (deref mock))))) + (t/is (not (th/success? out))) + (t/is (= 0 (:call-count (deref mock))))) ;; get invitation token (let [params {::th/type :get-team-invitation-token @@ -86,7 +86,7 @@ (t/is (= 0 (:call-count @mock))) (let [edata (-> out :error ex-data)] - (t/is (= :validation (:type edata))) + (t/is (= :restriction (:type edata))) (t/is (= :email-has-permanent-bounces (:code edata))))) ;; invite internal user that is muted diff --git a/common/src/app/common/files/changes.cljc b/common/src/app/common/files/changes.cljc index f3d0cc71e..d48d0b84d 100644 --- a/common/src/app/common/files/changes.cljc +++ b/common/src/app/common/files/changes.cljc @@ -711,52 +711,14 @@ (ctyl/delete-typography data id)) ;; === Operations - (defmethod process-operation :set [on-changed shape op] - (let [attr (:attr op) - group (get ctk/sync-attrs attr) - val (:val op) - shape-val (get shape attr) - ignore (or (:ignore-touched op) (= attr :position-data)) ;; position-data is a derived attribute and - ignore-geometry (:ignore-geometry op) ;; never triggers touched by itself - is-geometry? (and (or (= group :geometry-group) - (and (= group :content-group) (= (:type shape) :path))) - (not (#{:width :height} attr))) ;; :content in paths are also considered geometric - ;; TODO: the check of :width and :height probably may be removed - ;; after the check added in data/workspace/modifiers/check-delta - ;; function. Better check it and test toroughly when activating - ;; components-v2 mode. - in-copy? (ctk/in-component-copy? shape) - - ;; For geometric attributes, there are cases in that the value changes - ;; slightly (e.g. when rounding to pixel, or when recalculating text - ;; positions in different zoom levels). To take this into account, we - ;; ignore geometric changes smaller than 1 pixel. - equal? (if is-geometry? - (gsh/close-attrs? attr val shape-val 1) - (gsh/close-attrs? attr val shape-val))] - - ;; Notify when value has changed, except when it has not moved relative to the - ;; component head. - (when (and group (not equal?) (not (and ignore-geometry is-geometry?))) - (on-changed shape)) - - (cond-> shape - ;; Depending on the origin of the attribute change, we need or not to - ;; set the "touched" flag for the group the attribute belongs to. - ;; In some cases we need to ignore touched only if the attribute is - ;; geometric (position, width or transformation). - (and in-copy? group (not ignore) (not equal?) - (not (and ignore-geometry is-geometry?))) - (-> (update :touched cfh/set-touched-group group) - (dissoc :remote-synced)) - - (nil? val) - (dissoc attr) - - (some? val) - (assoc attr val)))) + (ctn/set-shape-attr shape + (:attr op) + (:val op) + :on-changed on-changed + :ignore-touched (:ignore-touched op) + :ignore-geometry (:ignore-geometry op))) (defmethod process-operation :set-touched [_ shape op] diff --git a/common/src/app/common/files/helpers.cljc b/common/src/app/common/files/helpers.cljc index 3856bc327..508bea799 100644 --- a/common/src/app/common/files/helpers.cljc +++ b/common/src/app/common/files/helpers.cljc @@ -357,15 +357,6 @@ ;; COMPONENTS HELPERS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defn set-touched-group - [touched group] - (when group - (conj (or touched #{}) group))) - -(defn touched-group? - [shape group] - ((or (:touched shape) #{}) group)) - (defn make-container [page-or-component type] (assoc page-or-component :type type)) diff --git a/common/src/app/common/logging.cljc b/common/src/app/common/logging.cljc index d7780ef70..f1eaee79d 100644 --- a/common/src/app/common/logging.cljc +++ b/common/src/app/common/logging.cljc @@ -153,14 +153,29 @@ (defn build-message [props] (loop [props (seq props) - result []] + result [] + body nil] (if-let [[k v] (first props)] - (if (simple-ident? k) + (cond + (simple-ident? k) (recur (next props) - (conj result (str (name k) "=" (pr-str v)))) + (conj result (str (name k) "=" (pr-str v))) + body) + + (= ::body k) (recur (next props) - result)) - (str/join ", " result)))) + result + v) + + :else + (recur (next props) + result + body)) + + (let [message (str/join ", " result)] + (if (string? body) + (str message "\n" body) + message))))) (defn build-stack-trace [cause] diff --git a/common/src/app/common/logic/libraries.cljc b/common/src/app/common/logic/libraries.cljc index 314970805..85382be2c 100644 --- a/common/src/app/common/logic/libraries.cljc +++ b/common/src/app/common/logic/libraries.cljc @@ -288,13 +288,23 @@ (some? (:shape-ref ref-shape)) (pcb/update-shapes [(:id shape)] #(assoc % :shape-ref (:shape-ref ref-shape))) - ;; When advancing level, if the referenced shape has a swap slot, it must be - ;; copied to the current shape, because the shape-ref now will not be pointing - ;; to a near main (except for first level subcopies). + ;; When advancing level, the normal touched groups (not swap slots) of the + ;; ref-shape must be merged into the current shape, because they refer to + ;; the new referenced shape. + (some? ref-shape) + (pcb/update-shapes + [(:id shape)] + #(assoc % :touched + (clojure.set/union (:touched shape) + (ctk/normal-touched-groups ref-shape)))) + + ;; Swap slot must also be copied if the current shape has not any, + ;; except if this is the first level subcopy. (and (some? (ctk/get-swap-slot ref-shape)) (nil? (ctk/get-swap-slot shape)) (not= (:id shape) shape-id)) (pcb/update-shapes [(:id shape)] #(ctk/set-swap-slot % (ctk/get-swap-slot ref-shape))))))] + (reduce skip-near changes children))) (defn prepare-restore-component diff --git a/common/src/app/common/test_helpers/shapes.cljc b/common/src/app/common/test_helpers/shapes.cljc index 3f9e1f544..408e1233e 100644 --- a/common/src/app/common/test_helpers/shapes.cljc +++ b/common/src/app/common/test_helpers/shapes.cljc @@ -12,6 +12,7 @@ [app.common.test-helpers.ids-map :as thi] [app.common.types.color :as ctc] [app.common.types.colors-list :as ctcl] + [app.common.types.container :as ctn] [app.common.types.file :as ctf] [app.common.types.pages-list :as ctpl] [app.common.types.shape :as cts] @@ -69,6 +70,19 @@ (thf/current-page file))] (ctst/get-shape page id))) +(defn update-shape + [file shape-label attr val & {:keys [page-label]}] + (let [page (if page-label + (thf/get-page file page-label) + (thf/current-page file)) + shape (ctst/get-shape page (thi/id shape-label))] + (ctf/update-file-data + file + (fn [file-data] + (ctpl/update-page file-data + (:id page) + #(ctst/set-shape % (ctn/set-shape-attr shape attr val))))))) + (defn sample-color [label & {:keys [] :as params}] (ctc/make-color (assoc params :id (thi/new-id! label)))) diff --git a/common/src/app/common/types/component.cljc b/common/src/app/common/types/component.cljc index b4060abed..cc064be50 100644 --- a/common/src/app/common/types/component.cljc +++ b/common/src/app/common/types/component.cljc @@ -202,6 +202,11 @@ [group] (str/starts-with? (name group) "swap-slot-")) +(defn normal-touched-groups + "Gets all touched groups that are not swap slots." + [shape] + (into #{} (remove swap-slot? (:touched shape)))) + (defn group->swap-slot [group] (uuid/uuid (subs (name group) 10))) diff --git a/common/src/app/common/types/container.cljc b/common/src/app/common/types/container.cljc index aedf4ebc2..3a7f88c12 100644 --- a/common/src/app/common/types/container.cljc +++ b/common/src/app/common/types/container.cljc @@ -501,7 +501,7 @@ ; original component doesn't exist or is deleted. So for this function purposes, they ; are removed from the list remove? (fn [shape] - (let [component (get-in libraries [(:component-file shape) :data :components (:component-id shape)])] + (let [component (get-in libraries [(:component-file shape) :data :components (:component-id shape)])] (and component (not (:deleted component))))) selected-components (cond->> (mapcat collect-main-shapes children objects) @@ -537,3 +537,48 @@ (if (or no-changes? (not (invalid-structure-for-component? objects parent children pasting? libraries))) [parent-id (get-frame parent-id)] (recur (:parent-id parent) objects children pasting? libraries)))))) + +;; --- SHAPE UPDATE + +(defn set-shape-attr + [shape attr val & {:keys [on-changed ignore-touched ignore-geometry]}] + (let [group (get ctk/sync-attrs attr) + shape-val (get shape attr) + ignore (or ignore-touched (= attr :position-data)) ;; position-data is a derived attribute and + is-geometry? (and (or (= group :geometry-group) ;; never triggers touched by itself + (and (= group :content-group) (= (:type shape) :path))) + (not (#{:width :height} attr))) ;; :content in paths are also considered geometric + ;; TODO: the check of :width and :height probably may be removed + ;; after the check added in data/workspace/modifiers/check-delta + ;; function. Better check it and test toroughly when activating + ;; components-v2 mode. + in-copy? (ctk/in-component-copy? shape) + + ;; For geometric attributes, there are cases in that the value changes + ;; slightly (e.g. when rounding to pixel, or when recalculating text + ;; positions in different zoom levels). To take this into account, we + ;; ignore geometric changes smaller than 1 pixel. + equal? (if is-geometry? + (gsh/close-attrs? attr val shape-val 1) + (gsh/close-attrs? attr val shape-val))] + + ;; Notify when value has changed, except when it has not moved relative to the + ;; component head. + (when (and on-changed group (not equal?) (not (and ignore-geometry is-geometry?))) + (on-changed shape)) + + (cond-> shape + ;; Depending on the origin of the attribute change, we need or not to + ;; set the "touched" flag for the group the attribute belongs to. + ;; In some cases we need to ignore touched only if the attribute is + ;; geometric (position, width or transformation). + (and in-copy? group (not ignore) (not equal?) + (not (and ignore-geometry is-geometry?))) + (-> (update :touched ctk/set-touched-group group) + (dissoc :remote-synced)) + + (nil? val) + (dissoc attr) + + (some? val) + (assoc attr val)))) diff --git a/common/src/app/common/types/shape.cljc b/common/src/app/common/types/shape.cljc index cbce60984..f7f9bc038 100644 --- a/common/src/app/common/types/shape.cljc +++ b/common/src/app/common/types/shape.cljc @@ -504,8 +504,8 @@ (assoc :proportion-lock true))) (defn setup-shape - "A function that initializes the geometric data of - the shape. The props must have :x :y :width :height." + "A function that initializes the geometric data of the shape. The props must + contain at least :x :y :width :height." [{:keys [type] :as props}] (let [shape (make-minimal-shape type) diff --git a/common/test/cases/detach-with-swap.penpot b/common/test/cases/detach-with-nested.penpot similarity index 100% rename from common/test/cases/detach-with-swap.penpot rename to common/test/cases/detach-with-nested.penpot diff --git a/common/test/common_tests/logic/comp_detach_with_swap_test.cljc b/common/test/common_tests/logic/comp_detach_with_nested_test.cljc similarity index 52% rename from common/test/common_tests/logic/comp_detach_with_swap_test.cljc rename to common/test/common_tests/logic/comp_detach_with_nested_test.cljc index 3d58fa51e..d7b999db3 100644 --- a/common/test/common_tests/logic/comp_detach_with_swap_test.cljc +++ b/common/test/common_tests/logic/comp_detach_with_nested_test.cljc @@ -4,7 +4,7 @@ ;; ;; Copyright (c) KALEIDOS INC -(ns common-tests.logic.comp-detach-with-swap-test +(ns common-tests.logic.comp-detach-with-nested-test (:require [app.common.files.changes-builder :as pcb] [app.common.logic.libraries :as cll] @@ -18,7 +18,7 @@ (t/use-fixtures :each thi/test-fixture) -;; Related .penpot file: common/test/cases/detach-with-swap.penpot +;; Related .penpot file: common/test/cases/detach-with-nested.penpot (defn- setup-file [] ;; {:r-ellipse} [:name Ellipse, :type :frame] # [Component :c-ellipse] @@ -195,3 +195,177 @@ (t/is (= (:shape-ref copy-nested-rectangle) (thi/id :rectangle))) (t/is (nil? (ctk/get-swap-slot copy-nested-rectangle))))) +(t/deftest test-propagate-touched + (let [;; ==== Setup + file (-> (setup-file) + (ths/update-shape :nested2-ellipse :fills (ths/sample-fills-color :fill-color "#fabada")) + (thc/instantiate-component :c-big-board + :copy-big-board + :children-labels [:copy-h-board-with-ellipse + :copy-nested2-h-ellipse + :copy-nested2-ellipse])) + + page (thf/current-page file) + nested2-ellipse (ths/get-shape file :nested2-ellipse) + copy-nested2-ellipse (ths/get-shape file :copy-nested2-ellipse) + + ;; ==== Action + changes (cll/generate-detach-instance (-> (pcb/empty-changes nil) + (pcb/with-page page) + (pcb/with-objects (:objects page))) + page + {(:id file) file} + (thi/id :copy-big-board)) + file' (thf/apply-changes file changes) + + ;; ==== Get + nested2-ellipse' (ths/get-shape file' :nested2-ellipse) + copy-nested2-ellipse' (ths/get-shape file' :copy-nested2-ellipse) + fills' (:fills copy-nested2-ellipse') + fill' (first fills')] + + ;; ==== Check + + ;; The touched group must be propagated to the copy, because now this copy + ;; has the original ellipse component as near main, but its attributes have + ;; been inherited from the ellipse inside big-board. + (t/is (= (:touched nested2-ellipse) #{:fill-group})) + (t/is (= (:touched copy-nested2-ellipse) nil)) + (t/is (= (:touched nested2-ellipse') #{:fill-group})) + (t/is (= (:touched copy-nested2-ellipse') #{:fill-group})) + (t/is (= (count fills') 1)) + (t/is (= (:fill-color fill') "#fabada")) + (t/is (= (:fill-opacity fill') 1)))) + +(t/deftest test-merge-touched + (let [;; ==== Setup + file (-> (setup-file) + (ths/update-shape :nested2-ellipse :fills (ths/sample-fills-color :fill-color "#fabada")) + (thc/instantiate-component :c-big-board + :copy-big-board + :children-labels [:copy-h-board-with-ellipse + :copy-nested2-h-ellipse + :copy-nested2-ellipse]) + (ths/update-shape :copy-nested2-ellipse :name "Modified name") + (ths/update-shape :copy-nested2-ellipse :fills (ths/sample-fills-color :fill-color "#abcdef"))) + + page (thf/current-page file) + nested2-ellipse (ths/get-shape file :nested2-ellipse) + copy-nested2-ellipse (ths/get-shape file :copy-nested2-ellipse) + + ;; ==== Action + changes (cll/generate-detach-instance (-> (pcb/empty-changes nil) + (pcb/with-page page) + (pcb/with-objects (:objects page))) + page + {(:id file) file} + (thi/id :copy-big-board)) + file' (thf/apply-changes file changes) + + ;; ==== Get + nested2-ellipse' (ths/get-shape file' :nested2-ellipse) + copy-nested2-ellipse' (ths/get-shape file' :copy-nested2-ellipse) + fills' (:fills copy-nested2-ellipse') + fill' (first fills')] + + ;; ==== Check + + ;; If the copy have been already touched, merge the groups and preserve the modifications. + (t/is (= (:touched nested2-ellipse) #{:fill-group})) + (t/is (= (:touched copy-nested2-ellipse) #{:name-group :fill-group})) + (t/is (= (:touched nested2-ellipse') #{:fill-group})) + (t/is (= (:touched copy-nested2-ellipse') #{:name-group :fill-group})) + (t/is (= (count fills') 1)) + (t/is (= (:fill-color fill') "#abcdef")) + (t/is (= (:fill-opacity fill') 1)))) + +(t/deftest test-dont-propagete-touched-when-swapped-copy + (let [;; ==== Setup + file (-> (setup-file) + (ths/update-shape :nested-rectangle :fills (ths/sample-fills-color :fill-color "#fabada")) + (thc/instantiate-component :c-big-board + :copy-big-board + :children-labels [:copy-h-board-with-ellipse + :copy-nested2-h-ellipse + :copy-nested2-ellipse]) + (thc/component-swap :copy-h-board-with-ellipse + :c-board-with-rectangle + :copy-h-board-with-rectangle + :children-labels [:copy-nested2-h-rectangle + :copy-nested2-rectangle])) + + page (thf/current-page file) + nested2-rectangle (ths/get-shape file :nested2-rectangle) + copy-nested2-rectangle (ths/get-shape file :copy-nested2-rectangle) + + ;; ==== Action + changes (cll/generate-detach-instance (-> (pcb/empty-changes nil) + (pcb/with-page page) + (pcb/with-objects (:objects page))) + page + {(:id file) file} + (thi/id :copy-big-board)) + file' (thf/apply-changes file changes) + + ;; ==== Get + nested2-rectangle' (ths/get-shape file' :nested2-rectangle) + copy-nested2-rectangle' (ths/get-shape file' :copy-nested2-rectangle) + fills' (:fills copy-nested2-rectangle') + fill' (first fills')] + + ;; ==== Check + + ;; If the copy has been swapped, there is nothing to propagate since it's already + ;; pointing to the swapped near main. + (t/is (= (:touched nested2-rectangle) nil)) + (t/is (= (:touched copy-nested2-rectangle) nil)) + (t/is (= (:touched nested2-rectangle') nil)) + (t/is (= (:touched copy-nested2-rectangle') nil)) + (t/is (= (count fills') 1)) + (t/is (= (:fill-color fill') "#fabada")) + (t/is (= (:fill-opacity fill') 1)))) + +(t/deftest test-propagate-touched-when-swapped-main + (let [;; ==== Setup + file (-> (setup-file) + (thc/component-swap :nested2-h-ellipse + :c-rectangle + :nested2-h-rectangle + :children-labels [:nested2-rectangle]) + (ths/update-shape :nested2-rectangle :fills (ths/sample-fills-color :fill-color "#fabada")) + (thc/instantiate-component :c-big-board + :copy-big-board + :children-labels [:copy-h-board-with-ellipse + :copy-nested2-h-rectangle + :copy-nested2-rectangle])) + + page (thf/current-page file) + nested2-rectangle (ths/get-shape file :nested2-rectangle) + copy-nested2-rectangle (ths/get-shape file :copy-nested2-rectangle) + + ;; ==== Action + changes (cll/generate-detach-instance (-> (pcb/empty-changes nil) + (pcb/with-page page) + (pcb/with-objects (:objects page))) + page + {(:id file) file} + (thi/id :copy-big-board)) + file' (thf/apply-changes file changes) + + ;; ==== Get + nested2-rectangle' (ths/get-shape file' :nested2-rectangle) + copy-nested2-rectangle' (ths/get-shape file' :copy-nested2-rectangle) + fills' (:fills copy-nested2-rectangle') + fill' (first fills')] + + ;; ==== Check + + ;; If the main has been swapped, there is no difference. It propagates the same as + ;; if it were the original component. + (t/is (= (:touched nested2-rectangle) #{:fill-group})) + (t/is (= (:touched copy-nested2-rectangle) nil)) + (t/is (= (:touched nested2-rectangle') #{:fill-group})) + (t/is (= (:touched copy-nested2-rectangle') #{:fill-group})) + (t/is (= (count fills') 1)) + (t/is (= (:fill-color fill') "#fabada")) + (t/is (= (:fill-opacity fill') 1)))) diff --git a/frontend/src/app/main/ui/auth/recovery_request.cljs b/frontend/src/app/main/ui/auth/recovery_request.cljs index d3ce49eaa..c409a318c 100644 --- a/frontend/src/app/main/ui/auth/recovery_request.cljs +++ b/frontend/src/app/main/ui/auth/recovery_request.cljs @@ -52,7 +52,8 @@ :profile-is-muted (rx/of (msg/error (tr "errors.profile-is-muted"))) - :email-has-permanent-bounces + (:email-has-permanent-bounces + :email-has-complaints) (rx/of (msg/error (tr "errors.email-has-permanent-bounces" (:email data)))) (rx/throw cause))))) diff --git a/frontend/src/app/main/ui/auth/register.cljs b/frontend/src/app/main/ui/auth/register.cljs index ae8e47d74..e85e3def9 100644 --- a/frontend/src/app/main/ui/auth/register.cljs +++ b/frontend/src/app/main/ui/auth/register.cljs @@ -43,7 +43,7 @@ on-error (mf/use-fn (fn [form cause] - (let [{:keys [type code]} (ex-data cause)] + (let [{:keys [type code] :as edata} (ex-data cause)] (condp = [type code] [:restriction :registration-disabled] (st/emit! (msg/error (tr "errors.registration-disabled"))) @@ -51,6 +51,12 @@ [:restriction :email-domain-is-not-allowed] (st/emit! (msg/error (tr "errors.email-domain-not-allowed"))) + [:restriction :email-has-permanent-bounces] + (st/emit! (msg/error (tr "errors.email-has-permanent-bounces" (:email edata)))) + + [:restriction :email-has-complaints] + (st/emit! (msg/error (tr "errors.email-has-permanent-bounces" (:email edata)))) + [:validation :email-as-password] (swap! form assoc-in [:errors :password] {:code "errors.email-as-password"}) diff --git a/frontend/src/app/main/ui/dashboard/team.cljs b/frontend/src/app/main/ui/dashboard/team.cljs index 3a0d3421f..85c7d67ed 100644 --- a/frontend/src/app/main/ui/dashboard/team.cljs +++ b/frontend/src/app/main/ui/dashboard/team.cljs @@ -62,10 +62,10 @@ {::mf/wrap [mf/memo] ::mf/wrap-props false} [{:keys [section team]}] - (let [on-nav-members (mf/use-fn #(st/emit! (dd/go-to-team-members))) - on-nav-settings (mf/use-fn #(st/emit! (dd/go-to-team-settings))) - on-nav-invitations (mf/use-fn #(st/emit! (dd/go-to-team-invitations))) - on-nav-webhooks (mf/use-fn #(st/emit! (dd/go-to-team-webhooks))) + (let [on-nav-members (mf/use-fn #(st/emit! (dd/go-to-team-members))) + on-nav-settings (mf/use-fn #(st/emit! (dd/go-to-team-settings))) + on-nav-invitations (mf/use-fn #(st/emit! (dd/go-to-team-invitations))) + on-nav-webhooks (mf/use-fn #(st/emit! (dd/go-to-team-webhooks))) members-section? (= section :dashboard-team-members) settings-section? (= section :dashboard-team-settings) @@ -168,21 +168,22 @@ (dd/fetch-team-invitations))) on-error - (fn [{:keys [type code] :as error}] - (cond - (and (= :validation type) - (= :profile-is-muted code)) - (st/emit! (msg/error (tr "errors.profile-is-muted")) - (modal/hide)) + (fn [_form cause] + (let [{:keys [type code] :as error} (ex-data cause)] + (cond + (and (= :validation type) + (= :profile-is-muted code)) + (st/emit! (msg/error (tr "errors.profile-is-muted")) + (modal/hide)) - (and (= :validation type) - (or (= :member-is-muted code) - (= :email-has-permanent-bounces code))) - (swap! error-text (tr "errors.email-spam-or-permanent-bounces" (:email error))) + (or (= :member-is-muted code) + (= :email-has-permanent-bounces code) + (= :email-has-complaints code)) + (swap! error-text (tr "errors.email-spam-or-permanent-bounces" (:email error))) - :else - (st/emit! (msg/error (tr "errors.generic")) - (modal/hide)))) + :else + (st/emit! (msg/error (tr "errors.generic")) + (modal/hide))))) on-submit (fn [form] @@ -574,22 +575,24 @@ on-error (mf/use-fn (mf/deps email) - (fn [{:keys [type code] :as error}] - (cond - (and (= :validation type) - (= :profile-is-muted code)) - (rx/of (msg/error (tr "errors.profile-is-muted"))) + (fn [cause] + (let [{:keys [type code] :as error} (ex-data cause)] + (cond + (and (= :validation type) + (= :profile-is-muted code)) + (rx/of (msg/error (tr "errors.profile-is-muted"))) - (and (= :validation type) - (= :member-is-muted code)) - (rx/of (msg/error (tr "errors.member-is-muted"))) + (and (= :validation type) + (= :member-is-muted code)) + (rx/of (msg/error (tr "errors.member-is-muted"))) - (and (= :validation type) - (= :email-has-permanent-bounces code)) - (rx/of (msg/error (tr "errors.email-has-permanent-bounces" email))) + (and (= :restriction type) + (or (= :email-has-permanent-bounces code) + (= :email-has-complaints code))) + (rx/of (msg/error (tr "errors.email-has-permanent-bounces" email))) - :else - (rx/throw error)))) + :else + (rx/throw cause))))) on-delete (mf/use-fn @@ -599,7 +602,6 @@ mdata {:on-success #(st/emit! (dd/fetch-team-invitations))}] (st/emit! (dd/delete-team-invitation (with-meta params mdata)))))) - on-resend-success (mf/use-fn (fn [] diff --git a/frontend/src/app/main/ui/settings/change_email.cljs b/frontend/src/app/main/ui/settings/change_email.cljs index 91f866e1a..f4998947b 100644 --- a/frontend/src/app/main/ui/settings/change_email.cljs +++ b/frontend/src/app/main/ui/settings/change_email.cljs @@ -21,21 +21,22 @@ [rumext.v2 :as mf])) (defn- on-error - [form error] - (case (:code (ex-data error)) - :email-already-exists - (swap! form (fn [data] - (let [error {:message (tr "errors.email-already-exists")}] - (assoc-in data [:errors :email-1] error)))) + [form cause] + (let [{:keys [code] :as error} (ex-data cause)] + (case code + :email-already-exists + (swap! form (fn [data] + (let [error {:message (tr "errors.email-already-exists")}] + (assoc-in data [:errors :email-1] error)))) - :profile-is-muted - (rx/of (msg/error (tr "errors.profile-is-muted"))) + :profile-is-muted + (rx/of (msg/error (tr "errors.profile-is-muted"))) - :email-has-permanent-bounces - (let [email (get @form [:data :email-1])] - (rx/of (msg/error (tr "errors.email-has-permanent-bounces" email)))) + (:email-has-permanent-bounces + :email-has-complaints) + (rx/of (msg/error (tr "errors.email-has-permanent-bounces" (:email error)))) - (rx/throw error))) + (rx/throw cause)))) (defn- on-success [profile data]