Penpot/penpot
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-04-04 11:01:20 -05:00
Code Issues Activity

Merge remote-tracking branch 'origin/staging' into develop

Browse source
This commit is contained in:
Andrey Antukh 2024-07-31 12:46:47 +02:00
commit 5cf64c1440
21 changed files with 561 additions and 244 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
backend/src/app/email.clj
View file

@ -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))))

132
backend/src/app/http/awsns.clj
View file

@ -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}))))

110
backend/src/app/rpc/commands/auth.clj
View file

@ -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))

47
backend/src/app/rpc/commands/profile.clj
View file

@ -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

13
backend/src/app/rpc/commands/teams.clj
View file

@ -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

41
backend/test/backend_tests/rpc_profile_test.clj
View file

@ -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

6
backend/test/backend_tests/rpc_team_test.clj
View file

@ -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

50
common/src/app/common/files/changes.cljc
View file

@ -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]

9
common/src/app/common/files/helpers.cljc
View file

@ -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))

25
common/src/app/common/logging.cljc
View file

@ -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]

16
common/src/app/common/logic/libraries.cljc
View file

@ -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

14
common/src/app/common/test_helpers/shapes.cljc
View file

@ -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))))

5
common/src/app/common/types/component.cljc
View file

@ -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)))

47
common/src/app/common/types/container.cljc
View file

@ -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))))

4
common/src/app/common/types/shape.cljc
View file

@ -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)

0
common/test/cases/detach-with-swap.penpot → common/test/cases/detach-with-nested.penpot
View file

178
common/test/common_tests/logic/comp_detach_with_swap_test.cljc → common/test/common_tests/logic/comp_detach_with_nested_test.cljc
View file

@ -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))))

3
frontend/src/app/main/ui/auth/recovery_request.cljs
View file

@ -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)))))

8
frontend/src/app/main/ui/auth/register.cljs
View file

@ -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"})

64
frontend/src/app/main/ui/dashboard/team.cljs
View file

@ -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 []

25
frontend/src/app/main/ui/settings/change_email.cljs
View file

@ -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]