3pp-mirror/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-08-01 16:28:42 +02:00
Code Issues Projects Releases Packages Wiki Activity

Merge pull request #3847 from penpot/niwinz-develop-enhancements-11

Browse source 
✨ Add enhancements and safety checks to copy paste
This commit is contained in:
Aitor Moreno 2023-11-24 14:25:55 +01:00 • committed by GitHub
commit 0528c26b5e
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
50 changed files with 1199 additions and 831 deletions
Download patch file Download diff file Expand all files Collapse all files

166
frontend/src/app/main/data/comments.cljs
View file

@ -17,38 +17,40 @@
[beicon.core :as rx]
[potok.core :as ptk]))
(def schema:comment-thread
[:map {:title "CommentThread"}
[:id ::sm/uuid]
[:page-id ::sm/uuid]
[:file-id ::sm/uuid]
[:project-id ::sm/uuid]
[:owner-id ::sm/uuid]
[:page-name :string]
[:file-name :string]
[:seqn :int]
[:content :string]
[:participants ::sm/set-of-uuid]
[:created-at ::sm/inst]
[:modified-at ::sm/inst]
[:position ::gpt/point]
[:count-unread-comments {:optional true} :int]
[:count-comments {:optional true} :int]])
(def ^:private schema:comment-thread
(sm/define
[:map {:title "CommentThread"}
[:id ::sm/uuid]
[:page-id ::sm/uuid]
[:file-id ::sm/uuid]
[:project-id ::sm/uuid]
[:owner-id ::sm/uuid]
[:page-name :string]
[:file-name :string]
[:seqn :int]
[:content :string]
[:participants ::sm/set-of-uuid]
[:created-at ::sm/inst]
[:modified-at ::sm/inst]
[:position ::gpt/point]
[:count-unread-comments {:optional true} :int]
[:count-comments {:optional true} :int]]))
(def schema:comment
[:map {:title "CommentThread"}
[:id ::sm/uuid]
[:thread-id ::sm/uuid]
[:owner-id ::sm/uuid]
[:created-at ::sm/inst]
[:modified-at ::sm/inst]
[:content :string]])
(def ^:private schema:comment
(sm/define
[:map {:title "Comment"}
[:id ::sm/uuid]
[:thread-id ::sm/uuid]
[:owner-id ::sm/uuid]
[:created-at ::sm/inst]
[:modified-at ::sm/inst]
[:content :string]]))
(def comment-thread?
(sm/pred-fn schema:comment-thread))
(def check-comment-thread!
(sm/check-fn schema:comment-thread))
(def comment?
(sm/pred-fn schema:comment))
(def check-comment!
(sm/check-fn schema:comment))
(declare create-draft-thread)
(declare retrieve-comment-threads)
@ -68,16 +70,20 @@
(update-in [:comments id] assoc (:id comment) comment)))))
(def schema:create-thread-on-workspace
[:map
[:page-id ::sm/uuid]
[:file-id ::sm/uuid]
[:position ::gpt/point]
[:content :string]])
(def ^:private
schema:create-thread-on-workspace
(sm/define
[:map {:title "created-thread-on-workspace"}
[:page-id ::sm/uuid]
[:file-id ::sm/uuid]
[:position ::gpt/point]
[:content :string]]))
(defn create-thread-on-workspace
[params]
(dm/assert! (sm/valid? schema:create-thread-on-workspace params))
(dm/assert!
(sm/check! schema:create-thread-on-workspace params))
(ptk/reify ::create-thread-on-workspace
ptk/WatchEvent
(watch [_ state _]
@ -107,17 +113,21 @@
(update :workspace-drawing dissoc :comment)
(update-in [:comments id] assoc (:id comment) comment)))))
(def schema:create-thread-on-viewer
[:map
[:page-id ::sm/uuid]
[:file-id ::sm/uuid]
[:frame-id ::sm/uuid]
[:position ::gpt/point]
[:content :string]])
(def ^:private
schema:create-thread-on-viewer
(sm/define
[:map {:title "created-thread-on-viewer"}
[:page-id ::sm/uuid]
[:file-id ::sm/uuid]
[:frame-id ::sm/uuid]
[:position ::gpt/point]
[:content :string]]))
(defn create-thread-on-viewer
[params]
(dm/assert! (sm/valid? schema:create-thread-on-viewer params))
(dm/assert!
(sm/check! schema:create-thread-on-viewer params))
(ptk/reify ::create-thread-on-viewer
ptk/WatchEvent
(watch [_ state _]
@ -146,7 +156,11 @@
(defn update-comment-thread
[{:keys [id is-resolved] :as thread}]
(dm/assert! (comment-thread? thread))
(dm/assert!
"expected valid comment thread"
(check-comment-thread! thread))
(ptk/reify ::update-comment-thread
IDeref
(-deref [_] {:is-resolved is-resolved})
@ -168,8 +182,14 @@
(defn add-comment
[thread content]
(dm/assert! (comment-thread? thread))
(dm/assert! (string? content))
(dm/assert!
"expected valid comment thread"
(check-comment-thread! thread))
(dm/assert!
"expected valid content"
(string? content))
(letfn [(created [comment state]
(update-in state [:comments (:id thread)] assoc (:id comment) comment))]
@ -189,7 +209,10 @@
(defn update-comment
[{:keys [id content thread-id] :as comment}]
(dm/assert! (comment? comment))
(dm/assert!
"expected valid comment"
(check-comment! comment))
(ptk/reify ::update-comment
ptk/UpdateEvent
(update [_ state]
@ -204,7 +227,9 @@
(defn delete-comment-thread-on-workspace
[{:keys [id] :as thread}]
(dm/assert! (comment-thread? thread))
(dm/assert!
"expected valid comment thread"
(check-comment-thread! thread))
(ptk/reify ::delete-comment-thread-on-workspace
ptk/UpdateEvent
(update [_ state]
@ -222,7 +247,9 @@
(defn delete-comment-thread-on-viewer
[{:keys [id] :as thread}]
(dm/assert! (comment-thread? thread))
(dm/assert!
"expected valid comment thread"
(check-comment-thread! thread))
(ptk/reify ::delete-comment-thread-on-viewer
ptk/UpdateEvent
(update [_ state]
@ -241,7 +268,9 @@
(defn delete-comment
[{:keys [id thread-id] :as comment}]
(dm/assert! (comment? comment))
(dm/assert!
"expected valid comment"
(check-comment! comment))
(ptk/reify ::delete-comment
ptk/UpdateEvent
(update [_ state]
@ -256,7 +285,9 @@
(defn refresh-comment-thread
[{:keys [id file-id] :as thread}]
(dm/assert! (comment-thread? thread))
(dm/assert!
"expected valid comment thread"
(check-comment-thread! thread))
(letfn [(fetched [thread state]
(assoc-in state [:comment-threads id] thread))]
(ptk/reify ::refresh-comment-thread
@ -338,7 +369,9 @@
(defn open-thread
[{:keys [id] :as thread}]
(dm/assert! (comment-thread? thread))
(dm/assert!
"expected valid comment thread"
(check-comment-thread! thread))
(ptk/reify ::open-comment-thread
ptk/UpdateEvent
(update [_ state]
@ -379,15 +412,18 @@
(update [_ state]
(update state :comments-local merge params))))
(def schema:create-draft
[:map
[:page-id ::sm/uuid]
[:file-id ::sm/uuid]
[:position ::gpt/point]])
(def ^:private
schema:create-draft
(sm/define
[:map {:title "create-draft"}
[:page-id ::sm/uuid]
[:file-id ::sm/uuid]
[:position ::gpt/point]]))
(defn create-draft
[params]
(dm/assert! (sm/valid? schema:create-draft params))
(dm/assert!
(sm/check! schema:create-draft params))
(ptk/reify ::create-draft
ptk/UpdateEvent
(update [_ state]
@ -452,11 +488,14 @@
(filter #(contains? (:participants %) (:id profile))))))
(defn update-comment-thread-frame
([thread ]
([thread]
(update-comment-thread-frame thread uuid/zero))
([thread frame-id]
(dm/assert! (comment-thread? thread))
(dm/assert!
"expected valid comment thread"
(check-comment-thread! thread))
(ptk/reify ::update-comment-thread-frame
ptk/UpdateEvent
(update [_ state]
@ -473,7 +512,10 @@
(defn detach-comment-thread
"Detach comment threads that are inside a frame when that frame is deleted"
[ids]
(dm/assert! (sm/coll-of-uuid? ids))
(dm/assert!
"expected a valid coll of uuid's"
(sm/check-coll-of-uuid! ids))
(ptk/reify ::detach-comment-thread
ptk/WatchEvent
(watch [_ state _]

22
frontend/src/app/main/data/dashboard.cljs
View file

@ -468,7 +468,10 @@
[{:keys [emails role team-id resend?] :as params}]
(dm/assert! (keyword? role))
(dm/assert! (uuid? team-id))
(dm/assert! (sm/set-of-emails? emails))
(dm/assert!
"expected a valid set of emails"
(sm/check-set-of-emails! emails))
(ptk/reify ::invite-team-members
IDeref
@ -487,7 +490,10 @@
(defn copy-invitation-link
[{:keys [email team-id] :as params}]
(dm/assert! (sm/email? email))
(dm/assert!
"expected a valid email"
(sm/check-email! email))
(dm/assert! (uuid? team-id))
(ptk/reify ::copy-invitation-link
@ -515,7 +521,10 @@
(defn update-team-invitation-role
[{:keys [email team-id role] :as params}]
(dm/assert! (sm/email? email))
(dm/assert!
"expected a valid email"
(sm/check-email! email))
(dm/assert! (uuid? team-id))
(dm/assert! (keyword? role)) ;; FIXME validate role
@ -534,7 +543,7 @@
(defn delete-team-invitation
[{:keys [email team-id] :as params}]
(dm/assert! (sm/email? email))
(dm/assert! (sm/check-email! email))
(dm/assert! (uuid? team-id))
(ptk/reify ::delete-team-invitation
ptk/WatchEvent
@ -891,9 +900,12 @@
(defn move-files
[{:keys [ids project-id] :as params}]
(dm/assert! (sm/set-of-uuid? ids))
(dm/assert! (uuid? project-id))
(dm/assert!
"expected a valid set of uuids"
(sm/check-set-of-uuid! ids))
(ptk/reify ::move-files
IDeref
(-deref [_]

53
frontend/src/app/main/data/messages.cljs
View file

@ -18,38 +18,37 @@
(def default-animation-timeout 600)
(def default-timeout 5000)
(def schema:message
[:map {:title "Message"}
[:type [::sm/one-of #{:success :error :info :warning}]]
[:status {:optional true}
[::sm/one-of #{:visible :hide}]]
[:position {:optional true}
[::sm/one-of #{:fixed :floating :inline}]]
[:controls {:optional true}
[::sm/one-of #{:none :close :inline-actions :bottom-actions}]]
[:tag {:optional true}
[:or :string :keyword]]
[:timeout {:optional true}
[:maybe :int]]
[:actions {:optional true}
[:vector
[:map
[:label :string]
[:callback ::sm/fn]]]]
[:links {:optional true}
[:vector
[:map
[:label :string]
[:callback ::sm/fn]]]]])
(def message?
(sm/pred-fn schema:message))
(def ^:private
schema:message
(sm/define
[:map {:title "Message"}
[:type [::sm/one-of #{:success :error :info :warning}]]
[:status {:optional true}
[::sm/one-of #{:visible :hide}]]
[:position {:optional true}
[::sm/one-of #{:fixed :floating :inline}]]
[:controls {:optional true}
[::sm/one-of #{:none :close :inline-actions :bottom-actions}]]
[:tag {:optional true}
[:or :string :keyword]]
[:timeout {:optional true}
[:maybe :int]]
[:actions {:optional true}
[:vector
[:map
[:label :string]
[:callback ::sm/fn]]]]
[:links {:optional true}
[:vector
[:map
[:label :string]
[:callback ::sm/fn]]]]]))
(defn show
[data]
(dm/assert!
"expected valid message map"
(message? data))
(sm/check! schema:message data))
(ptk/reify ::show
ptk/UpdateEvent

26
frontend/src/app/main/data/shortcuts.cljs
View file

@ -127,16 +127,17 @@
;; --- EVENT: push
(def schema:shortcuts
[:map-of
:keyword
[:map
[:command [:or :string [:vector :any]]]
[:fn {:optional true} fn?]
[:tooltip {:optional true} :string]]])
(def ^:private
schema:shortcuts
(sm/define
[:map-of :keyword
[:map
[:command [:or :string [:vector :any]]]
[:fn {:optional true} fn?]
[:tooltip {:optional true} :string]]]))
(def shortcuts?
(sm/pred-fn schema:shortcuts))
(def check-shortcuts!
(sm/check-fn schema:shortcuts))
(defn- wrap-cb
[key cb]
@ -169,8 +170,11 @@
(defn push-shortcuts
[key shortcuts]
(dm/assert! (keyword? key))
(dm/assert! (shortcuts? shortcuts))
(dm/assert!
"expected valid parameters"
(and (keyword? key)
(check-shortcuts! shortcuts)))
(ptk/reify ::push-shortcuts
ptk/UpdateEvent

63
frontend/src/app/main/data/users.cljs
View file

@ -26,17 +26,19 @@
;; --- SCHEMAS
(def schema:profile
[:map {:title "Profile"}
[:id ::sm/uuid]
[:created-at {:optional true} :any]
[:fullname {:optional true} :string]
[:email {:optional true} :string]
[:lang {:optional true} :string]
[:theme {:optional true} :string]])
(def ^:private
schema:profile
(sm/define
[:map {:title "Profile"}
[:id ::sm/uuid]
[:created-at {:optional true} :any]
[:fullname {:optional true} :string]
[:email {:optional true} :string]
[:lang {:optional true} :string]
[:theme {:optional true} :string]]))
(def profile?
(sm/pred-fn schema:profile))
(def check-profile!
(sm/check-fn schema:profile))
;; --- HELPERS
@ -289,7 +291,10 @@
(defn update-profile
[data]
(dm/assert! (profile? data))
(dm/assert!
"expected valid profile data"
(check-profile! data))
(ptk/reify ::update-profile
ptk/WatchEvent
(watch [_ _ stream]
@ -343,9 +348,13 @@
;; Social registered users don't have old-password
[:password-old {:optional true} [:maybe :string]]])
(defn update-password
[data]
(dm/assert! (sm/valid? schema:update-password data))
(dm/assert!
"expected valid parameters"
(sm/check! schema:update-password data))
(ptk/reify ::update-password
ptk/WatchEvent
(watch [_ _ _]
@ -475,14 +484,19 @@
;; --- EVENT: request-profile-recovery
(def schema:request-profile-recovery
[:map {:closed true}
[:email ::sm/email]])
(def ^:private
schema:request-profile-recovery
(sm/define
[:map {:title "request-profile-recovery" :closed true}
[:email ::sm/email]]))
;; FIXME: check if we can use schema for proper filter
(defn request-profile-recovery
[data]
(dm/assert! (sm/valid? schema:request-profile-recovery data))
(dm/assert!
"expected valid parameters"
(sm/check! schema:request-profile-recovery data))
(ptk/reify ::request-profile-recovery
ptk/WatchEvent
(watch [_ _ _]
@ -496,14 +510,19 @@
;; --- EVENT: recover-profile (Password)
(def schema:recover-profile
[:map {:closed true}
[:password :string]
[:token :string]])
(def ^:private
schema:recover-profile
(sm/define
[:map {:title "recover-profile" :closed true}
[:password :string]
[:token :string]]))
(defn recover-profile
[data]
(dm/assert! (sm/valid? schema:recover-profile data))
(dm/assert!
"expected valid arguments"
(sm/check! schema:recover-profile data))
(ptk/reify ::recover-profile
ptk/WatchEvent
(watch [_ _ _]

51
frontend/src/app/main/data/viewer.cljs
View file

@ -46,15 +46,20 @@
(declare zoom-to-fill)
(declare zoom-to-fit)
(def schema:initialize
[:map
[:file-id ::sm/uuid]
[:share-id {:optional true} [:maybe ::sm/uuid]]
[:page-id {:optional true} ::sm/uuid]])
(def ^:private
schema:initialize
(sm/define
[:map {:title "initialize"}
[:file-id ::sm/uuid]
[:share-id {:optional true} [:maybe ::sm/uuid]]
[:page-id {:optional true} ::sm/uuid]]))
(defn initialize
[{:keys [file-id share-id interactions-show?] :as params}]
(dm/assert! (sm/valid? schema:initialize params))
(dm/assert!
"expected valid params"
(sm/check! schema:initialize params))
(ptk/reify ::initialize
ptk/UpdateEvent
(update [_ state]
@ -92,18 +97,20 @@
;; --- Data Fetching
(def schema:fetch-bundle
[:map
[:page-id ::sm/uuid]
[:file-id ::sm/uuid]
[:share-id {:optional true} ::sm/uuid]])
(def ^:private valid-fetch-bundle-params?
(sm/pred-fn schema:fetch-bundle))
(def ^:private
schema:fetch-bundle
(sm/define
[:map {:title "fetch-bundle"}
[:page-id ::sm/uuid]
[:file-id ::sm/uuid]
[:share-id {:optional true} ::sm/uuid]]))
(defn- fetch-bundle
[{:keys [file-id share-id] :as params}]
(dm/assert! (valid-fetch-bundle-params? params))
(dm/assert!
"expected valid params"
(sm/check! schema:fetch-bundle params))
(ptk/reify ::fetch-bundle
ptk/WatchEvent
@ -486,9 +493,11 @@
(go-to-frame frame-id nil))
([frame-id animation]
(dm/assert! (uuid? frame-id))
(dm/assert! (or (nil? animation)
(ctsi/animation? animation)))
(dm/assert!
"expected valid parameters"
(and (uuid? frame-id)
(or (nil? animation)
(ctsi/check-animation! animation))))
(ptk/reify ::go-to-frame
ptk/UpdateEvent
@ -587,7 +596,7 @@
(dm/assert! (or (nil? background-overlay)
(boolean? background-overlay)))
(dm/assert! (or (nil? animation)
(ctsi/animation? animation)))
(ctsi/check-animation! animation)))
(ptk/reify ::open-overlay
ptk/UpdateEvent
(update [_ state]
@ -617,7 +626,7 @@
(dm/assert! (or (nil? background-overlay)
(boolean? background-overlay)))
(dm/assert! (or (nil? animation)
(ctsi/animation? animation)))
(ctsi/check-animation! animation)))
(ptk/reify ::toggle-overlay
ptk/UpdateEvent
@ -645,7 +654,7 @@
([frame-id animation]
(dm/assert! (uuid? frame-id))
(dm/assert! (or (nil? animation)
(ctsi/animation? animation)))
(ctsi/check-animation! animation)))
(ptk/reify ::close-overlay
ptk/UpdateEvent

615
frontend/src/app/main/data/workspace.cljs
View file

@ -9,6 +9,8 @@
[app.common.attrs :as attrs]
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.features :as cfeat]
[app.common.files.changes-builder :as pcb]
[app.common.files.helpers :as cfh]
[app.common.geom.align :as gal]
@ -17,6 +19,7 @@
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.geom.shapes.grid-layout :as gslg]
[app.common.schema :as sm]
[app.common.text :as txt]
[app.common.transit :as t]
[app.common.types.component :as ctk]
@ -77,6 +80,7 @@
[app.util.webapi :as wapi]
[beicon.core :as rx]
[cljs.spec.alpha :as s]
[clojure.set :as set]
[cuerdas.core :as str]
[potok.core :as ptk]))
@ -669,8 +673,11 @@
(defn update-shape
[id attrs]
(dm/assert! (uuid? id))
(dm/assert! (cts/valid-shape-attrs? attrs))
(dm/assert!
"expected valid parameters"
(and (cts/check-shape-attrs! attrs)
(uuid? id)))
(ptk/reify ::update-shape
ptk/WatchEvent
(watch [_ _ _]
@ -712,7 +719,10 @@
(defn update-selected-shapes
[attrs]
(dm/assert! (cts/valid-shape-attrs? attrs))
(dm/assert!
"expected valid shape attrs"
(cts/check-shape-attrs! attrs))
(ptk/reify ::update-selected-shapes
ptk/WatchEvent
(watch [_ state _]
@ -1525,60 +1535,47 @@
(assoc data :selected selected)))
;; Retrieve all ids of selected shapes with corresponding
;; children; this is needed because each shape should be
;; processed one by one because of async events (data url
;; fetching).
(collect-object-ids [objects res id]
(let [obj (get objects id)]
(reduce (partial collect-object-ids objects)
(assoc res id obj)
(:shapes obj))))
(fetch-image [entry]
(let [url (cf/resolve-file-media entry)]
(->> (http/send! {:method :get
:uri url
:response-type :blob})
(rx/map :body)
(rx/mapcat wapi/read-file-as-data-url)
(rx/map #(assoc entry :data %)))))
;; Prepare the shape object. Mainly needed for image shapes
;; for retrieve the image data and convert it to the
;; data-url.
(prepare-object [objects parent-frame-id {:keys [type] :as obj}]
(let [obj (maybe-translate obj objects parent-frame-id)
(prepare-object [objects parent-frame-id obj]
(let [obj (maybe-translate obj objects parent-frame-id)
;; Texts can have different fills for pieces of the text
fill-images-data (->> (or (:position-data obj) [obj])
(map :fills)
(reduce into [])
(filter :fill-image)
(map :fill-image))
imgdata (concat
(->> (or (:position-data obj) [obj])
(mapcat :fills)
(keep :fill-image))
(->> (:strokes obj)
(keep :stroke-image))
(when (cfh/image-shape? obj)
[(:metadata obj)]))]
stroke-images-data (->> (:strokes obj)
(filter :stroke-image)
(map :stroke-image))
images-data (concat
fill-images-data
stroke-images-data
(when (= type :image)
[(:metadata obj)]))]
(if (> (count images-data) 0)
(->> (rx/from images-data)
(rx/mapcat (fn [image-data]
(let [url (cf/resolve-file-media image-data)]
(->> (http/send! {:method :get
:uri url
:response-type :blob})
(rx/map :body)
(rx/mapcat wapi/read-file-as-data-url)
(rx/map #(assoc image-data :data %))))))
(if (seq imgdata)
(->> (rx/from imgdata)
(rx/mapcat fetch-image)
(rx/reduce conj [])
(rx/map
(fn [images]
(assoc obj ::data images))))
(rx/map (fn [images]
(assoc obj ::images images))))
(rx/of obj))))
;; Collects all the items together and split images into a
;; separated data structure for a more easy paste process.
(collect-data [res {:keys [id] :as item}]
(let [res (update res :objects assoc id (dissoc item ::data))]
(if (::data item)
(update res :images into (::data item))
res)))
(collect-data [result {:keys [id ::images] :as item}]
(cond-> result
:always
(update :objects assoc id (dissoc item ::images))
(some? images)
(update :images into images)))
(maybe-translate [shape objects parent-frame-id]
(if (= parent-frame-id uuid/zero)
@ -1587,122 +1584,128 @@
(gsh/translate-to-frame shape frame))))
(on-copy-error [error]
(js/console.error "Clipboard blocked:" error)
(js/console.error "clipboard blocked:" error)
(rx/empty))]
(ptk/reify ::copy-selected
ptk/WatchEvent
(watch [_ state _]
(let [objects (wsh/lookup-page-objects state)
selected (->> (wsh/lookup-selected state)
(cfh/clean-loops objects))
parent-frame-id (cfh/common-parent-frame objects selected)
pdata (reduce (partial collect-object-ids objects) {} selected)
initial {:type :copied-shapes
:file-id (:current-file-id state)
:selected selected
:objects {}
:images #{}}
selected_text (.. js/window getSelection toString)]
(if (not-empty selected_text)
(let [text (wapi/get-current-selected-text)]
(if-not (str/empty? text)
(try
(wapi/write-to-clipboard selected_text)
(wapi/write-to-clipboard text)
(catch :default e
(on-copy-error e)))
(->> (rx/from (seq (vals pdata)))
(rx/merge-map (partial prepare-object objects parent-frame-id))
(rx/reduce collect-data initial)
(rx/map (partial sort-selected state))
(rx/map t/encode-str)
(rx/map wapi/write-to-clipboard)
(rx/catch on-copy-error)
(rx/ignore))))))))
(declare paste-shape)
(declare paste-text)
(declare paste-image)
(declare paste-svg)
(let [objects (wsh/lookup-page-objects state)
selected (->> (wsh/lookup-selected state)
(cfh/clean-loops objects))
features (features/get-team-enabled-features state)
(def paste
(ptk/reify ::paste
ptk/WatchEvent
(watch [_ _ _]
(try
(let [clipboard-str (wapi/read-from-clipboard)
file-id (:current-file-id state)
frame-id (cfh/common-parent-frame objects selected)
version (dm/get-in state [:workspace-data :version])
paste-transit-str
(->> clipboard-str
(rx/filter t/transit?)
(rx/map t/decode-str)
(rx/filter #(= :copied-shapes (:type %)))
(rx/map #(select-keys % [:selected :objects]))
(rx/map paste-shape))
initial {:type :copied-shapes
:features features
:version version
:file-id file-id
:selected selected
:objects {}
:images #{}}
paste-plain-text-str
(->> clipboard-str
(rx/filter (comp not empty?))
(rx/map paste-text))
shapes (->> (cfh/selected-with-children objects selected)
(keep (d/getf objects)))]
paste-image-str
(->> (rx/from shapes)
(rx/merge-map (partial prepare-object objects frame-id))
(rx/reduce collect-data initial)
(rx/map (partial sort-selected state))
(rx/map #(t/encode-str % {:type :json-verbose}))
(rx/map wapi/write-to-clipboard)
(rx/catch on-copy-error)
(rx/ignore)))))))))
(declare ^:private paste-transit)
(declare ^:private paste-text)
(declare ^:private paste-image)
(declare ^:private paste-svg-text)
(declare ^:private paste-shapes)
(defn paste-from-clipboard
"Perform a `paste` operation using the Clipboard API."
[]
(letfn [(decode-entry [entry]
(try
[:transit (t/decode-str entry)]
(catch :default _cause
[:text entry])))
(process-entry [[type data]]
(case type
:text
(if (str/empty? data)
(rx/empty)
(rx/of (paste-text data)))
:transit
(rx/of (paste-transit data))))
(on-error [cause]
(let [data (ex-data cause)]
(if (:not-implemented data)
(rx/of (msg/warn (tr "errors.clipboard-not-implemented")))
(js/console.error "Clipboard error:" cause))
(rx/empty)))]
(ptk/reify ::paste-from-clipboard
ptk/WatchEvent
(watch [_ _ _]
(->> (rx/concat
(->> (wapi/read-from-clipboard)
(rx/map decode-entry)
(rx/mapcat process-entry))
(->> (wapi/read-image-from-clipboard)
(rx/map paste-image))]
(rx/map paste-image)))
(rx/take 1)
(rx/catch on-error))))))
(->> (rx/concat paste-transit-str
paste-plain-text-str
paste-image-str)
(rx/take 1)
(rx/catch
(fn [err]
(js/console.error "Clipboard error:" err)
(rx/empty)))))
(catch :default e
(let [data (ex-data e)]
(if (:not-implemented data)
(rx/of (msg/warn (tr "errors.clipboard-not-implemented")))
(js/console.error "ERROR" e))))))))
(defn paste-from-event
"Perform a `paste` operation from user emmited event."
[event in-viewport?]
(ptk/reify ::paste-from-event
ptk/WatchEvent
(watch [_ state _]
(try
(let [objects (wsh/lookup-page-objects state)
paste-data (wapi/read-from-paste-event event)
image-data (wapi/extract-images paste-data)
text-data (wapi/extract-text paste-data)
decoded-data (and (t/transit? text-data)
(t/decode-str text-data))
(let [objects (wsh/lookup-page-objects state)
edit-id (dm/get-in state [:workspace-local :edition])
is-editing? (and edit-id (= :text (get-in objects [edit-id :type])))]
edit-id (get-in state [:workspace-local :edition])
is-editing-text? (and edit-id (= :text (get-in objects [edit-id :type])))]
;; Some paste events can be fired while we're editing a text
;; we forbid that scenario so the default behaviour is executed
(when-not is-editing-text?
;; Some paste events can be fired while we're editing a text
;; we forbid that scenario so the default behaviour is executed
(if is-editing?
(rx/empty)
(let [pdata (wapi/read-from-paste-event event)
image-data (some-> pdata wapi/extract-images)
text-data (some-> pdata wapi/extract-text)
transit-data (ex/ignoring (some-> text-data t/decode-str))]
(cond
(and (string? text-data)
(str/includes? text-data "<svg"))
(rx/of (paste-svg text-data))
(str/includes? text-data "<svg "))
(rx/of (paste-svg-text text-data))
(seq image-data)
(rx/from (map paste-image image-data))
(->> (rx/from image-data)
(rx/map paste-image))
(coll? decoded-data)
(->> (rx/of decoded-data)
(rx/filter #(= :copied-shapes (:type %)))
(rx/map #(paste-shape % in-viewport?)))
(coll? transit-data)
(rx/of (paste-transit (assoc transit-data :in-viewport in-viewport?)))
(string? text-data)
(rx/of (paste-text text-data))
:else
(rx/empty))))
(catch :default err
(js/console.error "Clipboard error:" err))))))
(rx/empty))))))))
(defn selected-frame? [state]
(let [selected (wsh/lookup-selected state)
@ -1731,15 +1734,63 @@
(= (:width (:selrect (first (vals paste-obj))))
(:width (:selrect frame-obj)))))
(defn- paste-shape
[{selected :selected
paste-objects :objects ;; rename this because here comes only the clipboard shapes,
images :images ;; not the whole page tree of shapes.
:as data}
in-viewport?]
(letfn [;; Given a file-id and img (part generated by the
;; copy-selected event), uploads the new media.
(upload-media [file-id imgpart]
(defn- check-paste-features!
"Function used for check feature compability between currently
enabled features set on the application with the provided featured
set by the paste data."
[enabled-features paste-features]
(let [not-supported (-> enabled-features
(set/difference paste-features)
;; NOTE: we don't want to raise a feature-mismatch
;; exception for features which don't require an
;; explicit file migration process or has no real
;; effect on file data structure
(set/difference cfeat/no-migration-features))]
(when (seq not-supported)
(ex/raise :type :restriction
:code :missing-features-in-paste-content
:feature (first not-supported)
:hint (str/ffmt "expected features '%' not present in pasted content"
(str/join "," not-supported)))))
(let [not-supported (set/difference enabled-features cfeat/supported-features)]
(when (seq not-supported)
(ex/raise :type :restriction
:code :paste-feature-not-supported
:feature (first not-supported)
:hint (str/ffmt "features '%' not supported in the application"
(str/join "," not-supported)))))
(let [not-supported (-> paste-features
(set/difference enabled-features)
(set/difference cfeat/backend-only-features)
(set/difference cfeat/frontend-only-features))]
(when (seq not-supported)
(ex/raise :type :restriction
:code :paste-feature-not-enabled
:feature (first not-supported)
:hint (str/ffmt "paste features '%' not enabled on the application"
(str/join "," not-supported))))))
(def ^:private schema:paste-data
(sm/define
[:map {:title "paste-data"}
[:type [:= :copied-shapes]]
[:features ::sm/set-of-strings]
[:version :int]
[:file-id ::sm/uuid]
[:selected ::sm/set-of-uuid]
[:objects
[:map-of ::sm/uuid :map]]
[:images [:set :map]]
[:position {:optional true} ::gpt/point]]))
(defn- paste-transit
[{:keys [images] :as pdata}]
(letfn [(upload-media [file-id imgpart]
(->> (http/send! {:uri (:data imgpart)
:response-type :blob
:method :get})
@ -1750,51 +1801,70 @@
:file-id file-id
:content blob
:is-local true}))
(rx/mapcat #(rp/cmd! :upload-file-media-object %))
(rx/map (fn [media]
(assoc media :prev-id (:id imgpart))))))
(rx/mapcat (partial rp/cmd! :upload-file-media-object))
(rx/map #(assoc % :prev-id (:id imgpart)))))]
(translate-staled-media [mdata attribute media-idx]
(let [id (get-in mdata [attribute :id])
(ptk/reify ::paste-transit
ptk/WatchEvent
(watch [_ state _]
(let [file-id (:current-file-id state)
features (features/get-team-enabled-features state)]
(sm/validate! schema:paste-data pdata
{:hint "invalid paste data"
:code :invalid-paste-data})
(check-paste-features! features (:features pdata))
(if (= file-id (:file-id pdata))
(let [pdata (assoc pdata :images [])]
(rx/of (paste-shapes pdata)))
(->> (rx/from images)
(rx/merge-map (partial upload-media file-id))
(rx/reduce conj [])
(rx/map #(assoc pdata :images %))
(rx/map paste-shapes))))))))
(defn paste-shapes
[{in-viewport? :in-viewport :as pdata}]
(letfn [(translate-media [mdata media-idx attr-path]
(let [id (get-in mdata attr-path)
mobj (get media-idx id)]
(if mobj
(update mdata attribute #(assoc %
:id (:id mobj)
:path (:path mobj)))
(update-in mdata attr-path (fn [value]
(-> value
(assoc :id (:id mobj))
(assoc :path (:path mobj)))))
mdata)))
(add-obj? [chg]
(= (:type chg) :add-obj))
;; Analyze the rchange and replace staled media and
;; references to the new uploaded media-objects.
(process-rchange [media-idx item]
(process-rchange [media-idx change]
(let [;; Texts can have different fills for pieces of the text
obj (:obj item)
fills (mapv #(translate-staled-media % :fill-image media-idx) (:fills obj))
strokes (mapv #(translate-staled-media % :stroke-image media-idx) (:strokes obj))
position-data (->> (:position-data obj)
(mapv (fn [p-data]
(let [fills (mapv #(translate-staled-media % :fill-image media-idx) (:fills p-data))]
(assoc p-data :fills fills)))))
content (txt/transform-nodes #(translate-staled-media % :fill-image media-idx) (:content obj))]
tr-fill-xf (map #(translate-media % media-idx [:fill-image :id]))
tr-stroke-xf (map #(translate-media % media-idx [:stroke-image :id]))]
(if (= (:type item) :add-obj)
(-> item
(update-in [:obj :metadata]
(fn [{:keys [id] :as mdata}]
(if-let [mobj (get media-idx id)]
(assoc mdata
:id (:id mobj)
:path (:path mobj))
mdata)))
(assoc-in [:obj :fills] fills)
(assoc-in [:obj :strokes] strokes)
(assoc-in [:obj :content] content)
(cond->
(> (count position-data) 0) (assoc-in [:obj :position-data] position-data)))
item)))
(if (add-obj? change)
(update change :obj (fn [obj]
(-> obj
(update :fills #(into [] tr-fill-xf %))
(update :strokes #(into [] tr-stroke-xf %))
(d/update-when :metadata translate-media media-idx [:id])
(d/update-when :content
(fn [content]
(txt/xform-nodes tr-fill-xf content)))
(d/update-when :position-data
(fn [position-data]
(mapv (fn [pos-data]
(update pos-data :fills #(into [] tr-fill-xf %)))
position-data))))))
change)))
(calculate-paste-position [state mouse-pos in-viewport?]
(calculate-paste-position [state pobjects selected position]
(let [page-objects (wsh/lookup-page-objects state)
selected-objs (map #(get paste-objects %) selected)
selected-objs (map (d/getf pobjects) selected)
first-selected-obj (first selected-objs)
page-selected (wsh/lookup-selected state)
wrapper (gsh/shapes->rect selected-objs)
@ -1803,12 +1873,12 @@
frame-object (get page-objects frame-id)
base (cfh/get-base-shape page-objects page-selected)
index (cfh/get-position-on-parent page-objects (:id base))
tree-root (get-tree-root-shapes paste-objects)
tree-root (get-tree-root-shapes pobjects)
only-one-root-shape? (and
(< 1 (count paste-objects))
(< 1 (count pobjects))
(= 1 (count tree-root)))
all-objects (merge page-objects paste-objects)
comps-nesting-loop? (not (->> (keys paste-objects)
all-objects (merge page-objects pobjects)
comps-nesting-loop? (not (->> (keys pobjects)
(map #(cfh/components-nesting-loop? all-objects % (:id base)))
(every? nil?)))]
@ -1816,13 +1886,13 @@
comps-nesting-loop?
;; Avoid placing a shape as a direct or indirect child of itself,
;; or inside its main component if it's in a copy.
[uuid/zero uuid/zero (gpt/subtract mouse-pos orig-pos)]
[uuid/zero uuid/zero (gpt/subtract position orig-pos)]
(selected-frame? state)
(if (or (any-same-frame-from-selected? state (keys paste-objects))
(if (or (any-same-frame-from-selected? state (keys pobjects))
(and only-one-root-shape?
(frame-same-size? paste-objects (first tree-root))))
(frame-same-size? pobjects (first tree-root))))
;; Paste next to selected frame, if selected is itself or of the same size as the copied
(let [selected-frame-obj (get page-objects (first page-selected))
parent-id (:parent-id base)
@ -1866,114 +1936,119 @@
[frame-id frame-id delta (dec (count (:shapes selected-frame-obj )))]))
(empty? page-selected)
(let [frame-id (ctst/top-nested-frame page-objects mouse-pos)
delta (gpt/subtract mouse-pos orig-pos)]
(let [frame-id (ctst/top-nested-frame page-objects position)
delta (gpt/subtract position orig-pos)]
[frame-id frame-id delta])
:else
(let [frame-id (:frame-id base)
parent-id (:parent-id base)
delta (if in-viewport?
(gpt/subtract mouse-pos orig-pos)
(gpt/subtract position orig-pos)
(gpt/subtract (gpt/point (:selrect base)) orig-pos))]
[frame-id parent-id delta index]))))
;; Change the indexes of the pasted shapes
(change-add-obj-index [paste-objects selected index change]
(let [index (or index -1) ;; if there is no current element selected, we want the first (inc index) to be 0
(change-add-obj-index [objects selected index change]
(let [;; if there is no current element selected, we want
;; the first (inc index) to be 0
index (d/nilv index -1)
set-index (fn [[result index] id]
[(assoc result id index) (inc index)])
;; FIXME: optimize ???
map-ids
(->> selected
(map #(get-in paste-objects [% :id]))
(map #(get-in objects [% :id]))
(reduce set-index [{} (inc index)])
first)]
(if (and (= :add-obj (:type change))
(if (and (add-obj? change)
(contains? map-ids (:old-id change)))
(assoc change :index (get map-ids (:old-id change)))
change)))
;; Proceed with the standard shape paste process.
(do-paste [it state mouse-pos media]
(let [libraries (wsh/get-libraries state)
file-id (:current-file-id state)
page (wsh/lookup-page state)
page-objects (:objects page)
media-idx (d/index-by :prev-id media)
(process-shape [file-id frame-id parent-id shape]
(cond-> shape
:always
(assoc :frame-id frame-id :parent-id parent-id)
;; Calculate position for the pasted elements
[frame-id parent-id delta index] (calculate-paste-position state mouse-pos in-viewport?)
(and (or (cfh/group-shape? shape)
(cfh/bool-shape? shape))
(nil? (:shapes shape)))
(assoc :shapes [])
;; We don't want to change the structure of component copies
;; If the parent-id or the frame-id are component-copies, we need to get the first not copy parent
parent-id (:id (ctn/get-first-not-copy-parent page-objects parent-id))
frame-id (:id (ctn/get-first-not-copy-parent page-objects frame-id))
(cfh/text-shape? shape)
(ctt/remove-external-typographies file-id)))]
process-shape
(fn [_ shape]
(let [assign-shapes? (and (or (cfh/group-shape? shape)
(cfh/bool-shape? shape))
(nil? (:shapes shape)))]
(-> shape
(assoc :frame-id frame-id :parent-id parent-id)
(cond-> assign-shapes?
(assoc :shapes []))
;; if is a text, remove references to external typographies
(cond-> (= (:type shape) :text)
(ctt/remove-external-typographies file-id)))))
paste-objects (->> paste-objects (d/mapm process-shape))
all-objects (merge (:objects page) paste-objects)
library-data (wsh/get-file state file-id)
changes (-> (dws/prepare-duplicate-changes all-objects page selected delta it libraries library-data file-id)
(pcb/amend-changes (partial process-rchange media-idx))
(pcb/amend-changes (partial change-add-obj-index paste-objects selected index)))
;; Adds a resize-parents operation so the groups are updated. We add all the new objects
new-objects-ids (->> changes :redo-changes (filter #(= (:type %) :add-obj)) (mapv :id))
drop-cell
(when (ctl/grid-layout? all-objects parent-id)
(gslg/get-drop-cell frame-id all-objects mouse-pos))
changes (pcb/resize-parents changes new-objects-ids)
selected (->> changes
:redo-changes
(filter #(= (:type %) :add-obj))
(filter #(selected (:old-id %)))
(map #(get-in % [:obj :id]))
(into (d/ordered-set)))
changes
(cond-> changes
(some? drop-cell)
(pcb/update-shapes [parent-id]
#(ctl/add-children-to-cell % selected all-objects drop-cell)))
undo-id (js/Symbol)]
(rx/of (dwu/start-undo-transaction undo-id)
(dch/commit-changes changes)
(dws/select-shapes selected)
(ptk/data-event :layout/update [frame-id])
(dwu/commit-undo-transaction undo-id))))]
(ptk/reify ::paste-shape
(ptk/reify ::paste-shapes
ptk/WatchEvent
(watch [it state _]
(let [file-id (:current-file-id state)
mouse-pos (deref ms/mouse-position)]
(if (= file-id (:file-id data))
(do-paste it state mouse-pos [])
(->> (rx/from images)
(rx/merge-map (partial upload-media file-id))
(rx/reduce conj [])
(rx/mapcat (partial do-paste it state mouse-pos)))))))))
(let [
file-id (:current-file-id state)
page (wsh/lookup-page state)
media-idx (->> (:media pdata)
(d/index-by :prev-id))
selected (:selected pdata)
objects (:objects pdata)
position (deref ms/mouse-position)
;; Calculate position for the pasted elements
[frame-id
parent-id
delta
index] (calculate-paste-position state objects selected position)
;; We don't want to change the structure of component
;; copies If the parent-id or the frame-id are
;; component-copies, we need to get the first not copy
;; parent
parent-id (:id (ctn/get-first-not-copy-parent (:objects page) parent-id))
frame-id (:id (ctn/get-first-not-copy-parent (:objects page) frame-id))
objects (update-vals objects (partial process-shape file-id frame-id parent-id))
all-objects (merge (:objects page) objects)
libraries (wsh/get-libraries state)
ldata (wsh/get-file state file-id)
drop-cell (when (ctl/grid-layout? all-objects parent-id)
(gslg/get-drop-cell frame-id all-objects position))
changes (-> (dws/prepare-duplicate-changes all-objects page selected delta it libraries ldata file-id)
(pcb/amend-changes (partial process-rchange media-idx))
(pcb/amend-changes (partial change-add-obj-index objects selected index)))
;; Adds a resize-parents operation so the groups are
;; updated. We add all the new objects
changes (->> (:redo-changes changes)
(filter add-obj?)
(map :id)
(pcb/resize-parents changes))
selected (into (d/ordered-set)
(comp
(filter add-obj?)
(filter #(contains? selected (:old-id %)))
(map :obj)
(map :id))
(:redo-changes changes))
changes (cond-> changes
(some? drop-cell)
(pcb/update-shapes [parent-id]
#(ctl/add-children-to-cell % selected all-objects drop-cell)))
undo-id (js/Symbol)]
(rx/of (dwu/start-undo-transaction undo-id)
(dch/commit-changes changes)
(dws/select-shapes selected)
(ptk/data-event :layout/update [frame-id])
(dwu/commit-undo-transaction undo-id)))))))
(defn as-content [text]
(let [paragraphs (->> (str/lines text)
@ -1998,7 +2073,7 @@
:else
(deref ms/mouse-position)))
(defn paste-text
(defn- paste-text
[text]
(dm/assert! (string? text))
(ptk/reify ::paste-text
@ -2025,10 +2100,10 @@
(dwu/commit-undo-transaction undo-id))))))
;; TODO: why not implement it in terms of upload-media-workspace?
(defn- paste-svg
(defn- paste-svg-text
[text]
(dm/assert! (string? text))
(ptk/reify ::paste-svg
(ptk/reify ::paste-svg-text
ptk/WatchEvent
(watch [_ state _]
(let [position (calculate-paste-position state)
@ -2038,14 +2113,14 @@
(defn- paste-image
[image]
(ptk/reify ::paste-bin-impl
(ptk/reify ::paste-image
ptk/WatchEvent
(watch [_ state _]
(let [file-id (get-in state [:workspace-file :id])
(let [file-id (dm/get-in state [:workspace-file :id])
position (calculate-paste-position state)
params {:file-id file-id
:blobs [image]
:position position}]
params {:file-id file-id
:blobs [image]
:position position}]
(rx/of (dwm/upload-media-workspace params))))))
(defn toggle-distances-display [value]

10
frontend/src/app/main/data/workspace/changes.cljs
View file

@ -53,7 +53,11 @@
([ids update-fn] (update-shapes ids update-fn nil))
([ids update-fn {:keys [reg-objects? save-undo? stack-undo? attrs ignore-tree page-id ignore-remote? ignore-touched undo-group]
:or {reg-objects? false save-undo? true stack-undo? false ignore-remote? false ignore-touched false}}]
(dm/assert! (sm/coll-of-uuid? ids))
(dm/assert!
"expected a valid coll of uuid's"
(sm/check-coll-of-uuid! ids))
(dm/assert! (fn? update-fn))
(ptk/reify ::update-shapes
@ -212,8 +216,8 @@
(try
(dm/assert!
"expect valid vector of changes"
(and (cpc/valid-changes? redo-changes)
(cpc/valid-changes? undo-changes)))
(and (cpc/check-changes! redo-changes)
(cpc/check-changes! undo-changes)))
(update-in state path (fn [file]
(-> file

5
frontend/src/app/main/data/workspace/colors.cljs
View file

@ -278,7 +278,10 @@
(defn add-shadow
[ids shadow]
(dm/assert! (sm/coll-of-uuid? ids))
(dm/assert!
"expected a valid coll of uuid's"
(sm/check-coll-of-uuid! ids))
(ptk/reify ::add-shadow
ptk/WatchEvent
(watch [_ _ _]

62
frontend/src/app/main/data/workspace/comments.cljs
View file

@ -81,7 +81,10 @@
(defn center-to-comment-thread
[{:keys [position] :as thread}]
(dm/assert! (dcm/comment-thread? thread))
(dm/assert!
"expected valid comment thread"
(dcm/check-comment-thread! thread))
(ptk/reify ::center-to-comment-thread
ptk/UpdateEvent
(update [_ state]
@ -97,7 +100,9 @@
(defn navigate
[thread]
(dm/assert! (dcm/comment-thread? thread))
(dm/assert!
"expected valid comment thread"
(dcm/check-comment-thread! thread))
(ptk/reify ::open-comment-thread
ptk/WatchEvent
(watch [_ _ stream]
@ -118,36 +123,41 @@
(update-comment-thread-position thread [new-x new-y] nil))
([thread [new-x new-y] frame-id]
(dm/assert! (dcm/comment-thread? thread))
(ptk/reify ::update-comment-thread-position
ptk/WatchEvent
(watch [it state _]
(let [thread-id (:id thread)
page (wsh/lookup-page state)
page-id (:id page)
objects (wsh/lookup-page-objects state page-id)
new-frame-id (if (nil? frame-id)
(ctst/get-frame-id-by-position objects (gpt/point new-x new-y))
(:frame-id thread))
thread (assoc thread
:position (gpt/point new-x new-y)
:frame-id new-frame-id)
(dm/assert!
"expected valid comment thread"
(dcm/check-comment-thread! thread))
(ptk/reify ::update-comment-thread-position
ptk/WatchEvent
(watch [it state _]
(let [thread-id (:id thread)
page (wsh/lookup-page state)
page-id (:id page)
objects (wsh/lookup-page-objects state page-id)
new-frame-id (if (nil? frame-id)
(ctst/get-frame-id-by-position objects (gpt/point new-x new-y))
(:frame-id thread))
thread (assoc thread
:position (gpt/point new-x new-y)
:frame-id new-frame-id)
changes
(-> (pcb/empty-changes it)
(pcb/with-page page)
(pcb/update-page-option :comment-threads-position assoc thread-id (select-keys thread [:position :frame-id])))]
changes
(-> (pcb/empty-changes it)
(pcb/with-page page)
(pcb/update-page-option :comment-threads-position assoc thread-id (select-keys thread [:position :frame-id])))]
(rx/merge
(rx/of (dwc/commit-changes changes))
(->> (rp/cmd! :update-comment-thread-position thread)
(rx/catch #(rx/throw {:type :update-comment-thread-position}))
(rx/ignore))))))))
(rx/merge
(rx/of (dwc/commit-changes changes))
(->> (rp/cmd! :update-comment-thread-position thread)
(rx/catch #(rx/throw {:type :update-comment-thread-position}))
(rx/ignore))))))))
;; Move comment threads that are inside a frame when that frame is moved"
(defmethod ptk/resolve ::move-frame-comment-threads
[_ ids]
(dm/assert! (sm/coll-of-uuid? ids))
(dm/assert!
"expected a valid coll of uuid's"
(sm/check-coll-of-uuid! ids))
(ptk/reify ::move-frame-comment-threads
ptk/WatchEvent
(watch [_ state _]

4
frontend/src/app/main/data/workspace/guides.cljs
View file

@ -25,7 +25,7 @@
(defn update-guides [guide]
(dm/assert!
"expected valid guide"
(ctp/guide? guide))
(ctp/check-page-guide! guide))
(ptk/reify ::update-guides
ptk/WatchEvent
@ -40,7 +40,7 @@
(defn remove-guide [guide]
(dm/assert!
"expected valid guide"
(ctp/guide? guide))
(ctp/check-page-guide! guide))
(ptk/reify ::remove-guide
ptk/UpdateEvent

31
frontend/src/app/main/data/workspace/libraries.cljs
View file

@ -114,7 +114,10 @@
(defn add-recent-color
[color]
(dm/assert! (ctc/valid-recent-color? color))
(dm/assert!
"expected valid recent color map"
(ctc/check-recent-color! color))
(ptk/reify ::add-recent-color
ptk/WatchEvent
(watch [it _ _]
@ -144,8 +147,11 @@
(defn update-color
[color file-id]
(dm/assert! (ctc/valid-color? color))
(dm/assert! (uuid? file-id))
(dm/assert!
"expected valid parameters"
(and (ctc/check-color! color)
(uuid? file-id)))
(ptk/reify ::update-color
ptk/WatchEvent
@ -183,7 +189,10 @@
(defn add-media
[media]
(dm/assert! (ctf/valid-media-object? media))
(dm/assert!
"expected valid media object"
(ctf/check-media-object! media))
(ptk/reify ::add-media
ptk/WatchEvent
(watch [it _ _]
@ -227,7 +236,10 @@
([typography] (add-typography typography true))
([typography edit?]
(let [typography (update typography :id #(or % (uuid/next)))]
(dm/assert! (ctt/typography? typography))
(dm/assert!
"expected valid typography"
(ctt/check-typography! typography))
(ptk/reify ::add-typography
IDeref
(-deref [_] typography)
@ -256,8 +268,11 @@
(defn update-typography
[typography file-id]
(dm/assert! (ctt/typography? typography))
(dm/assert! (uuid? file-id))
(dm/assert!
"expected valid typography and file-id"
(and (ctt/check-typography! typography)
(uuid? file-id)))
(ptk/reify ::update-typography
ptk/WatchEvent
@ -607,7 +622,7 @@
(defn ext-library-changed
[library-id modified-at revn changes]
(dm/assert! (uuid? library-id))
(dm/assert! (ch/valid-changes? changes))
(dm/assert! (ch/check-changes! changes))
(ptk/reify ::ext-library-changed
ptk/UpdateEvent
(update [_ state]

37
frontend/src/app/main/data/workspace/media.cljs
View file

@ -163,15 +163,6 @@
(rx/merge-map svg->clj)
(rx/do on-svg)))))
(def schema:process-media-objects
[:map
[:file-id ::sm/uuid]
[:local? :boolean]
[:name {:optional true} :string]
[:data {:optional true} :any] ; FIXME
[:uris {:optional true} [:sequential :string]]
[:mtype {:optional true} :string]])
(defn handle-media-error [error on-error]
(if (ex/ex-info? error)
(handle-media-error (ex-data error) on-error)
@ -205,10 +196,22 @@
(.error js/console "ERROR" error)
(rx/of (msg/error (tr "errors.cannot-upload")))))))
(def ^:private
schema:process-media-objects
(sm/define
[:map {:title "process-media-objects"}
[:file-id ::sm/uuid]
[:local? :boolean]
[:name {:optional true} :string]
[:data {:optional true} :any] ; FIXME
[:uris {:optional true} [:sequential :string]]
[:mtype {:optional true} :string]]))
(defn- process-media-objects
[{:keys [uris on-error] :as params}]
(dm/assert!
(and (sm/valid? schema:process-media-objects params)
(and (sm/check! schema:process-media-objects params)
(or (contains? params :blobs)
(contains? params :uris))))
@ -392,14 +395,18 @@
:on-svg #(st/emit! (process-svg-component %)))]
(process-media-objects params)))
(def schema:clone-media-object
[:map
[:file-id ::sm/uuid]
[:object-id ::sm/uuid]])
(def ^:private
schema:clone-media-object
(sm/define
[:map {:title "clone-media-object"}
[:file-id ::sm/uuid]
[:object-id ::sm/uuid]]))
(defn clone-media-object
[{:keys [file-id object-id] :as params}]
(dm/assert! (sm/valid? schema:clone-media-object params))
(dm/assert!
(sm/check! schema:clone-media-object params))
(ptk/reify ::clone-media-objects
ptk/WatchEvent
(watch [_ _ _]

48
frontend/src/app/main/data/workspace/notifications.cljs
View file

@ -184,18 +184,23 @@
:updated-at (dt/now)
:page-id page-id))))))
(def schema:handle-file-change
[:map
[:type :keyword]
[:profile-id ::sm/uuid]
[:file-id ::sm/uuid]
[:session-id ::sm/uuid]
[:revn :int]
[:changes ::cpc/changes]])
(def ^:private
schema:handle-file-change
(sm/define
[:map {:title "handle-file-change"}
[:type :keyword]
[:profile-id ::sm/uuid]
[:file-id ::sm/uuid]
[:session-id ::sm/uuid]
[:revn :int]
[:changes ::cpc/changes]]))
(defn handle-file-change
[{:keys [file-id changes] :as msg}]
(dm/assert! (sm/valid? schema:handle-file-change msg))
(dm/assert!
"expected valid arguments"
(sm/check! schema:handle-file-change msg))
(ptk/reify ::handle-file-change
IDeref
(-deref [_] {:changes changes})
@ -241,19 +246,24 @@
(when-not (empty? changes-by-pages)
(rx/from (map process-page-changes changes-by-pages))))))))
(def schema:handle-library-change
[:map
[:type :keyword]
[:profile-id ::sm/uuid]
[:file-id ::sm/uuid]
[:session-id ::sm/uuid]
[:revn :int]
[:modified-at ::sm/inst]
[:changes ::cpc/changes]])
(def ^:private
schema:handle-library-change
(sm/define
[:map {:title "handle-library-change"}
[:type :keyword]
[:profile-id ::sm/uuid]
[:file-id ::sm/uuid]
[:session-id ::sm/uuid]
[:revn :int]
[:modified-at ::sm/inst]
[:changes ::cpc/changes]]))
(defn handle-library-change
[{:keys [file-id modified-at changes revn] :as msg}]
(dm/assert! (sm/valid? schema:handle-library-change msg))
(dm/assert!
"expected valid arguments"
(sm/check! schema:handle-library-change msg))
(ptk/reify ::handle-library-change
ptk/WatchEvent
(watch [_ state _]

10
frontend/src/app/main/data/workspace/path/changes.cljs
View file

@ -9,7 +9,7 @@
[app.common.data.macros :as dm]
[app.common.files.changes-builder :as pcb]
[app.main.data.workspace.changes :as dch]
[app.main.data.workspace.path.common :refer [content?]]
[app.main.data.workspace.path.common :refer [check-path-content!]]
[app.main.data.workspace.path.helpers :as helpers]
[app.main.data.workspace.path.state :as st]
[app.main.data.workspace.state-helpers :as wsh]
@ -19,8 +19,12 @@
(defn generate-path-changes
"Generates changes to update the new content of the shape"
[it objects page-id shape old-content new-content]
(dm/assert! (content? old-content))
(dm/assert! (content? new-content))
(dm/assert!
"expected valid path content"
(and (check-path-content! old-content)
(check-path-content! new-content)))
(let [shape-id (:id shape)
[old-points old-selrect]

36
frontend/src/app/main/data/workspace/path/common.cljs
View file

@ -22,23 +22,27 @@
:elliptical-arc
:close-path})
(def schema:content
[:vector {:title "PathContent"}
[:map {:title "PathContentEntry"}
[:command [::sm/one-of valid-commands]]
;; FIXME: remove the `?` from prop name
[:relative? {:optional true} :boolean]
[:params {:optional true}
[:map {:title "PathContentEntryParams"}
[:x :double]
[:y :double]
[:c1x {:optional true} :double]
[:c1y {:optional true} :double]
[:c2x {:optional true} :double]
[:c2y {:optional true} :double]]]]])
;; FIXME: should this schema be defined on common.types ?
(def content?
(sm/pred-fn schema:content))
(def ^:private
schema:path-content
(sm/define
[:vector {:title "PathContent"}
[:map {:title "PathContentEntry"}
[:command [::sm/one-of valid-commands]]
;; FIXME: remove the `?` from prop name
[:relative? {:optional true} :boolean]
[:params {:optional true}
[:map {:title "PathContentEntryParams"}
[:x :double]
[:y :double]
[:c1x {:optional true} :double]
[:c1y {:optional true} :double]
[:c2x {:optional true} :double]
[:c2y {:optional true} :double]]]]]))
(def check-path-content!
(sm/check-fn schema:path-content))
(defn init-path []
(ptk/reify ::init-path))

8
frontend/src/app/main/data/workspace/path/drawing.cljs
View file

@ -20,7 +20,7 @@
[app.main.data.workspace.drawing.common :as dwdc]
[app.main.data.workspace.edition :as dwe]
[app.main.data.workspace.path.changes :as changes]
[app.main.data.workspace.path.common :as common :refer [content?]]
[app.main.data.workspace.path.common :as common :refer [check-path-content!]]
[app.main.data.workspace.path.helpers :as helpers]
[app.main.data.workspace.path.state :as st]
[app.main.data.workspace.path.streams :as streams]
@ -262,7 +262,11 @@
ptk/UpdateEvent
(update [_ state]
(let [content (get-in state [:workspace-drawing :object :content] [])]
(dm/assert! (content? content))
(dm/assert!
"expected valid path content"
(check-path-content! content))
(if (> (count content) 1)
(assoc-in state [:workspace-drawing :object :initialized?] true)
state)))

2
frontend/src/app/main/data/workspace/persistence.cljs
View file

@ -238,7 +238,7 @@
[file-id {:keys [revn changes]}]
(dm/assert! (uuid? file-id))
(dm/assert! (int? revn))
(dm/assert! (cpc/valid-changes? changes))
(dm/assert! (cpc/check-changes! changes))
(ptk/reify ::shapes-changes-persisted
ptk/UpdateEvent

12
frontend/src/app/main/data/workspace/shapes.cljs
View file

@ -27,9 +27,6 @@
[beicon.core :as rx]
[potok.core :as ptk]))
(def valid-shape-map?
(sm/pred-fn ::cts/shape))
(defn add-shape
([shape]
(add-shape shape {}))
@ -37,7 +34,7 @@
(dm/verify!
"expected a valid shape"
(cts/valid-shape? shape))
(cts/check-shape! shape))
(ptk/reify ::add-shape
ptk/WatchEvent
@ -94,7 +91,10 @@
([ids] (delete-shapes nil ids {}))
([page-id ids] (delete-shapes page-id ids {}))
([page-id ids options]
(dm/assert! (sm/set-of-uuid? ids))
(dm/assert!
"expected a valid set of uuid's"
(sm/check-set-of-uuid! ids))
(ptk/reify ::delete-shapes
ptk/WatchEvent
(watch [it state _]
@ -376,7 +376,7 @@
(dm/assert!
"expected valid shape-attrs value for `flags`"
(cts/valid-shape-attrs? flags))
(cts/check-shape-attrs! flags))
(ptk/reify ::update-shape-flags
ptk/WatchEvent

2
frontend/src/app/main/data/workspace/texts.cljs
View file

@ -427,7 +427,7 @@
shape))]
(let [ids (->> (keys props) (filter changed-text?))]
(let [ids (into #{} (filter changed-text?) (keys props))]
(rx/of (dwu/start-undo-transaction undo-id)
(dch/update-shapes ids update-fn {:reg-objects? true
:stack-undo? true

22
frontend/src/app/main/data/workspace/undo.cljs
View file

@ -24,13 +24,15 @@
;; Undo / Redo
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def schema:undo-entry
[:map
[:undo-changes [:vector ::cpc/change]]
[:redo-changes [:vector ::cpc/change]]])
(def ^:private
schema:undo-entry
(sm/define
[:map {:title "undo-entry"}
[:undo-changes [:vector ::cpc/change]]
[:redo-changes [:vector ::cpc/change]]]))
(def undo-entry?
(sm/pred-fn schema:undo-entry))
(def check-undo-entry!
(sm/check-fn schema:undo-entry))
(def MAX-UNDO-SIZE 50)
@ -89,8 +91,12 @@
(defn append-undo
[entry stack?]
(dm/assert! (boolean? stack?))
(dm/assert! (undo-entry? entry))
(dm/assert!
"expected valid undo entry"
(check-undo-entry! entry))
(dm/assert!
(boolean? stack?))
(ptk/reify ::append-undo
ptk/UpdateEvent

30
frontend/src/app/main/errors.cljs
View file

@ -114,17 +114,29 @@
;; the user perspective a error flash message should be visualized but
;; user can continue operate on the application. Can happen in backend
;; and frontend.
(defmethod ptk/handle-error :validation
[error]
(ts/schedule
#(st/emit! (msg/show {:content "Validation error"
:type :error
:timeout 3000})))
[{:keys [code] :as error}]
(print-group! "Validation Error"
(fn []
(print-data! error)
(print-explain! error))))
(print-explain! error)))
(cond
(= code :invalid-paste-data)
(let [message (tr "errors.paste-data-validation")]
(st/async-emit!
(msg/show {:content message
:type :error
:timeout 3000})))
:else
(let [message (tr "errors.generic-validation")]
(st/async-emit!
(msg/show {:content message
:type :error
:timeout 3000})))))
;; This is a pure frontend error that can be caused by an active
@ -232,6 +244,12 @@
(let [message (tr "errors.max-quote-reached" (:target error))]
(st/emit! (modal/show {:type :alert :message message})))
(or (= :paste-feature-not-enabled code)
(= :missing-features-in-paste-content code)
(= :paste-feature-not-supported code))
(let [message (tr "errors.feature-not-supported" (:feature error))]
(st/emit! (modal/show {:type :alert :message message})))
:else
(ptk/handle-error {:type :server-error :data error})))

5
frontend/src/app/main/store.cljs
View file

@ -8,6 +8,7 @@
(:require
[app.common.logging :as log]
[app.util.object :as obj]
[app.util.timers :as tm]
[beicon.core :as rx]
[okulary.core :as l]
[potok.core :as ptk]))
@ -86,6 +87,10 @@
(apply ptk/emit! state (cons event events))
nil))
(defn async-emit!
[& params]
(tm/schedule #(apply emit! params)))
(defonce ongoing-tasks (l/atom #{}))
(add-watch ongoing-tasks ::ongoing-tasks

13
frontend/src/app/main/ui/dashboard/project_menu.cljs
View file

@ -6,8 +6,6 @@
(ns app.main.ui.dashboard.project-menu
(:require
[app.common.data.macros :as dm]
[app.common.schema :as sm]
[app.main.data.dashboard :as dd]
[app.main.data.messages :as msg]
[app.main.data.modal :as modal]
@ -21,19 +19,8 @@
[app.util.router :as rt]
[rumext.v2 :as mf]))
(def schema:project-menu
[:map {:title "UIProjectMenu"}
[:project some?]
[:show? :boolean]
[:on-menu-close {:optional true} ::sm/fn]
[:on-error {:optional true} ::sm/fn]
[:top {:optional true} [:maybe :double]]
[:left {:optional true} [:maybe :double]]
[:on-import {:optional true} ::sm/fn]])
(mf/defc project-menu
[{:keys [project show? on-edit on-menu-close top left on-import] :as props}]
(dm/assert! (sm/valid? schema:project-menu props))
(let [top (or top 0)
left (or left 0)

4
frontend/src/app/main/ui/workspace/context_menu.cljs
View file

@ -154,7 +154,7 @@
(let [do-copy #(st/emit! (dw/copy-selected))
do-cut #(st/emit! (dw/copy-selected)
(dw/delete-selected))
do-paste #(st/emit! dw/paste)
do-paste #(st/emit! (dw/paste-from-clipboard))
do-duplicate #(st/emit! (dw/duplicate-selected true))]
[:*
[:& menu-entry {:title (tr "workspace.shape.menu.copy")
@ -531,7 +531,7 @@
(mf/defc viewport-context-menu
[]
(let [focus (mf/deref refs/workspace-focus-selected)
do-paste #(st/emit! dw/paste)
do-paste #(st/emit! (dw/paste-from-clipboard))
do-hide-ui #(st/emit! (-> (dw/toggle-layout-flag :hide-ui)
(vary-meta assoc ::ev/origin "workspace-context-menu")))
do-toggle-focus-mode #(st/emit! (dw/toggle-focus-mode))]

13
frontend/src/app/main/ui/workspace/viewport/actions.cljs
View file

@ -501,13 +501,16 @@
:blobs (seq files)}]
(st/emit! (dwm/upload-media-workspace params))))))))
(defn on-paste [disable-paste in-viewport? workspace-read-only?]
(mf/use-callback
(defn on-paste
[disable-paste in-viewport? workspace-read-only?]
(mf/use-fn
(mf/deps workspace-read-only?)
(fn [event]
;; We disable the paste just after mouse-up of a middle button so when panning won't
;; paste the content into the workspace
;; We disable the paste just after mouse-up of a middle button so
;; when panning won't paste the content into the workspace
(let [tag-name (-> event dom/get-target dom/get-tag-name)]
(when (and (not (#{"INPUT" "TEXTAREA"} tag-name)) (not @disable-paste) (not workspace-read-only?))
(when (and (not (#{"INPUT" "TEXTAREA"} tag-name))
(not @disable-paste)
(not workspace-read-only?))
(st/emit! (dw/paste-from-event event @in-viewport?)))))))

6
frontend/src/app/util/object.cljs
View file

@ -6,7 +6,7 @@
(ns app.util.object
"A collection of helpers for work with javascript objects."
(:refer-clojure :exclude [set! new get get-in merge clone contains? array?])
(:refer-clojure :exclude [set! new get get-in merge clone contains? array? into-array])
(:require
[cuerdas.core :as str]))
@ -14,6 +14,10 @@
[o]
(.isArray js/Array o))
(defn into-array
[o]
(js/Array.from o))
(defn create [] #js {})
(defn get

55
frontend/src/app/util/webapi.cljs
View file

@ -93,6 +93,10 @@
(create-blob content mtype)))
(defn get-current-selected-text
[]
(.. js/window getSelection toString))
(defn write-to-clipboard
[data]
(assert (string? data) "`data` should be string")
@ -101,44 +105,47 @@
(defn read-from-clipboard
[]
(let [cboard (unchecked-get js/navigator "clipboard")]
(if (.-readText ^js cboard)
(rx/from (.readText ^js cboard))
(throw (ex-info "This browser does not implement read from clipboard protocol"
{:not-implemented true})))))
(try
(let [cboard (unchecked-get js/navigator "clipboard")]
(if (.-readText ^js cboard)
(rx/from (.readText ^js cboard))
(rx/throw (ex-info "This browser does not implement read from clipboard protocol"
{:not-implemented true}))))
(catch :default cause
(rx/throw cause))))
(defn read-image-from-clipboard
[]
(let [cboard (unchecked-get js/navigator "clipboard")
read-item (fn [item]
(let [img-type (->> (.-types ^js item)
(d/seek #(str/starts-with? % "image/")))]
(if img-type
(rx/from (.getType ^js item img-type))
(rx/empty))))]
(->> (rx/from (.read ^js cboard)) ;; Get a stream of item lists
(rx/mapcat identity) ;; Convert each item into an emission
(rx/switch-map read-item))))
(try
(let [cboard (unchecked-get js/navigator "clipboard")
read-item (fn [item]
(let [img-type (->> (.-types ^js item)
(d/seek #(str/starts-with? % "image/")))]
(if img-type
(rx/from (.getType ^js item img-type))
(rx/empty))))]
(->> (rx/from (.read ^js cboard)) ;; Get a stream of item lists
(rx/mapcat identity) ;; Convert each item into an emission
(rx/switch-map read-item)))
(catch :default cause
(rx/throw cause))))
(defn read-from-paste-event
[event]
(let [target (.-target ^js event)]
(when (and (not (.-isContentEditable target)) ;; ignore when pasting into
(not= (.-tagName target) "INPUT")) ;; an editable control
(when (and (not (.-isContentEditable ^js target)) ;; ignore when pasting into
(not= (.-tagName ^js target) "INPUT")) ;; an editable control
(.. ^js event getBrowserEvent -clipboardData))))
(defn extract-text
[clipboard-data]
(when clipboard-data
(.getData clipboard-data "text")))
(.getData clipboard-data "text"))
(defn extract-images
"Get image files from clipboard data. Returns a native js array."
[clipboard-data]
(when clipboard-data
(let [file-list (-> (.-files ^js clipboard-data))]
(->> (range (.-length ^js file-list))
(map #(.item ^js file-list %))
(filter #(str/starts-with? (.-type %) "image/"))))))
(let [files (obj/into-array (.-files ^js clipboard-data))]
(.filter ^js files #(str/starts-with? (obj/get % "type") "image/"))))
(defn create-canvas-element
[width height]

27
frontend/src/app/worker.cljs
View file

@ -24,23 +24,24 @@
;; --- Messages Handling
(def schema:message
[:map {:title "WorkerMessage"}
[:sender-id ::sm/uuid]
[:payload
[:map
[:cmd :keyword]]]
[:buffer? {:optional true} :boolean]])
(def message?
(sm/pred-fn schema:message))
(def ^:private
schema:message
(sm/define
[:map {:title "WorkerMessage"}
[:sender-id ::sm/uuid]
[:payload
[:map
[:cmd :keyword]]]
[:buffer? {:optional true} :boolean]]))
(def buffer (rx/subject))
(defn- handle-message
"Process the message and returns to the client"
[{:keys [sender-id payload transfer] :as message}]
(dm/assert! (message? message))
(dm/assert!
"expected valid message"
(sm/check! schema:message message))
(letfn [(post [msg]
(let [msg (-> msg (assoc :reply-to sender-id) (wm/encode))]
(.postMessage js/self msg)))
@ -86,7 +87,9 @@
(defn- drop-message
"Sends to the client a notification that its messages have been dropped"
[{:keys [sender-id] :as message}]
(dm/assert! (message? message))
(dm/assert!
"expected valid message"
(sm/check! schema:message message))
(.postMessage js/self (wm/encode {:reply-to sender-id
:dropped true})))