diff --git a/frontend/src/app/main/data/workspace.cljs b/frontend/src/app/main/data/workspace.cljs index 129a5bac4f..a587027bc6 100644 --- a/frontend/src/app/main/data/workspace.cljs +++ b/frontend/src/app/main/data/workspace.cljs @@ -9,33 +9,22 @@ [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.files.variant :as cfv] [app.common.geom.align :as gal] [app.common.geom.point :as gpt] [app.common.geom.proportions :as gpp] - [app.common.geom.rect :as grc] [app.common.geom.shapes :as gsh] - [app.common.geom.shapes.grid-layout :as gslg] [app.common.logging :as log] - [app.common.logic.libraries :as cll] [app.common.logic.shapes :as cls] - [app.common.schema :as sm] - [app.common.text :as txt] [app.common.transit :as t] [app.common.types.component :as ctc] [app.common.types.components-list :as ctkl] [app.common.types.container :as ctn] - [app.common.types.file :as ctf] [app.common.types.page :as ctp] [app.common.types.shape :as cts] [app.common.types.shape-tree :as ctst] - [app.common.types.shape.layout :as ctl] - [app.common.types.shape.text :as types.text] - [app.common.types.typography :as ctt] [app.common.uuid :as uuid] [app.config :as cf] [app.main.data.changes :as dch] @@ -51,6 +40,7 @@ [app.main.data.profile :as du] [app.main.data.project :as dpj] [app.main.data.workspace.bool :as dwb] + [app.main.data.workspace.clipboard :as dwcp] [app.main.data.workspace.collapse :as dwco] [app.main.data.workspace.colors :as dwcl] [app.main.data.workspace.comments :as dwcm] @@ -66,14 +56,12 @@ [app.main.data.workspace.layers :as dwly] [app.main.data.workspace.layout :as layout] [app.main.data.workspace.libraries :as dwl] - [app.main.data.workspace.media :as dwm] [app.main.data.workspace.notifications :as dwn] [app.main.data.workspace.path :as dwdp] [app.main.data.workspace.path.shapes-to-path :as dwps] [app.main.data.workspace.selection :as dws] [app.main.data.workspace.shape-layout :as dwsl] [app.main.data.workspace.shapes :as dwsh] - [app.main.data.workspace.texts :as dwtxt] [app.main.data.workspace.thumbnails :as dwth] [app.main.data.workspace.transforms :as dwt] [app.main.data.workspace.undo :as dwu] @@ -85,25 +73,20 @@ [app.main.features.pointer-map :as fpmap] [app.main.repo :as rp] [app.main.router :as rt] - [app.main.streams :as ms] [app.main.worker :as mw] [app.render-wasm :as wasm] [app.render-wasm.api :as api] - [app.util.code-gen.style-css :as css] [app.util.dom :as dom] [app.util.globals :as ug] [app.util.http :as http] [app.util.i18n :as i18n :refer [tr]] [app.util.storage :as storage] - [app.util.text.content :as tc] [app.util.timers :as tm] [app.util.webapi :as wapi] [beicon.v2.core :as rx] [cljs.spec.alpha :as s] - [clojure.set :as set] [cuerdas.core :as str] - [potok.v2.core :as ptk] - [promesa.core :as p])) + [potok.v2.core :as ptk])) (def default-workspace-local {:zoom 1}) (log/set-level! :debug) @@ -1318,952 +1301,6 @@ (update [_ state] (assoc-in state [:workspace-local :context-menu] nil)))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Clipboard -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn copy-selected - [] - (letfn [(sort-selected [state data] - (let [selected (dsh/lookup-selected state) - objects (dsh/lookup-page-objects state) - - ;; Narrow the objects map so it contains only relevant data for - ;; selected and its parents - objects (cfh/selected-subtree objects selected) - selected (->> (ctst/sort-z-index objects selected) - (reverse) - (into (d/ordered-set)))] - - (assoc data :selected selected))) - - (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 obj] - (let [obj (maybe-translate obj objects parent-frame-id) - ;; Texts can have different fills for pieces of the text - imgdata (concat - (->> (or (:position-data obj) [obj]) - (mapcat :fills) - (keep :fill-image)) - (->> (:strokes obj) - (keep :stroke-image)) - (when (cfh/image-shape? obj) - [(:metadata obj)]) - (when (:fill-image obj) - [(:fill-image obj)]))] - - (if (seq imgdata) - (->> (rx/from imgdata) - (rx/mapcat fetch-image) - (rx/reduce conj []) - (rx/map (fn [images] - (assoc obj ::images images)))) - (rx/of obj)))) - - (collect-variants [state shape] - (let [page-id (:current-page-id state) - data (dsh/lookup-file-data state) - objects (-> (dsh/get-page data page-id) - (get :objects)) - - components (cfv/find-variant-components data objects (:id shape))] - (into {} (map (juxt :id :variant-properties) components)))) - - - ;; Collects all the items together and split images into a - ;; separated data structure for a more easy paste process. - ;; Also collects the variant properties of the copied variants - (collect-data [state result {:keys [id ::images] :as item}] - (cond-> result - :always - (update :objects assoc id (dissoc item ::images)) - - (some? images) - (update :images into images) - - (ctc/is-variant-container? item) - (update :variant-properties merge (collect-variants state item)))) - - - - (maybe-translate [shape objects parent-frame-id] - (if (= parent-frame-id uuid/zero) - shape - (let [frame (get objects parent-frame-id)] - (gsh/translate-to-frame shape frame)))) - - ;; When copying an instance that is nested inside another one, we need to - ;; advance the shape refs to one or more levels of remote mains. - (advance-copies [state selected data] - (let [file (dsh/lookup-file state) - libraries (:files state) - ;; FIXME - page (dsh/lookup-page state) - heads (mapcat #(ctn/get-child-heads (:objects data) %) selected)] - (update data :objects - #(reduce (partial advance-copy file libraries page) - % - heads)))) - - (advance-copy [file libraries page objects shape] - (if (and (ctc/instance-head? shape) (not (ctc/main-instance? shape))) - (let [level-delta (ctn/get-nesting-level-delta (:objects page) shape uuid/zero)] - (if (pos? level-delta) - (reduce (partial advance-shape file libraries page level-delta) - objects - (cfh/get-children-with-self objects (:id shape))) - objects)) - objects)) - - (advance-shape [file libraries page level-delta objects shape] - (let [new-shape-ref (ctf/advance-shape-ref file page libraries shape level-delta {:include-deleted? true})] - (cond-> objects - (and (some? new-shape-ref) (not= new-shape-ref (:shape-ref shape))) - (assoc-in [(:id shape) :shape-ref] new-shape-ref)))) - - (on-copy-error [error] - (js/console.error "clipboard blocked:" error) - (rx/empty))] - - (ptk/reify ::copy-selected - ptk/WatchEvent - (watch [_ state _] - (let [text (wapi/get-current-selected-text)] - (if-not (str/empty? text) - (try - (wapi/write-to-clipboard text) - (catch :default e - (on-copy-error e))) - - (let [objects (dsh/lookup-page-objects state) - selected (->> (dsh/lookup-selected state) - (cfh/clean-loops objects)) - features (-> (get state :features) - (set/difference cfeat/frontend-only-features)) - - file-id (:current-file-id state) - frame-id (cfh/common-parent-frame objects selected) - file (dsh/lookup-file state file-id) - version (get file :version) - - initial {:type :copied-shapes - :features features - :version version - :file-id file-id - :selected selected - :objects {} - :images #{}} - - shapes (->> (cfh/selected-with-children objects selected) - (keep (d/getf objects)))] - - ;; The clipboard API doesn't handle well asynchronous calls because it expects to use - ;; the clipboard in an user interaction. If you do an async call the callback is outside - ;; the thread of the UI and so Safari blocks the copying event. - ;; We use the API `ClipboardItem` that allows promises to be passed and so the event - ;; will wait for the promise to resolve and everything should work as expected. - ;; This only works in the current versions of the browsers. - (if (some? (unchecked-get ug/global "ClipboardItem")) - (let [resolve-data-promise - (p/create - (fn [resolve reject] - (->> (rx/from shapes) - (rx/merge-map (partial prepare-object objects frame-id)) - (rx/reduce (partial collect-data state) initial) - (rx/map (partial sort-selected state)) - (rx/map (partial advance-copies state selected)) - (rx/map #(t/encode-str % {:type :json-verbose})) - (rx/map #(wapi/create-blob % "text/plain")) - (rx/subs! resolve reject))))] - (->> (rx/from (wapi/write-to-clipboard-promise "text/plain" resolve-data-promise)) - (rx/catch on-copy-error) - (rx/ignore))) - - ;; FIXME: this is to support Firefox versions below 116 that don't support - ;; `ClipboardItem` after the version 116 is less common we could remove this. - ;; https://caniuse.com/?search=ClipboardItem - (->> (rx/from shapes) - (rx/merge-map (partial prepare-object objects frame-id)) - (rx/reduce (partial collect-data state) initial) - (rx/map (partial sort-selected state)) - (rx/map (partial advance-copies state selected)) - (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-shapes) -(declare ^:private paste-transit-props) -(declare ^:private paste-html-text) -(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 - (cond - (str/empty? data) - (rx/empty) - - (re-find #"> (rx/concat - (->> (wapi/read-from-clipboard) - (rx/map decode-entry) - (rx/mapcat process-entry)) - (->> (wapi/read-image-from-clipboard) - (rx/map paste-image))) - (rx/take 1) - (rx/catch on-error)))))) - -(defn paste-from-event - "Perform a `paste` operation from user emmited event." - [event in-viewport?] - (ptk/reify ::paste-from-event - ptk/WatchEvent - (watch [_ state _] - (let [objects (dsh/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])))] - - ;; 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) - html-data (some-> pdata wapi/extract-html-text) - transit-data (ex/ignoring (some-> text-data t/decode-str))] - (cond - (and (string? text-data) (re-find #"> (rx/from image-data) - (rx/map paste-image)) - - (coll? transit-data) - (rx/of (paste-transit-shapes (assoc transit-data :in-viewport in-viewport?))) - - (and (string? html-data) (d/not-empty? html-data)) - (rx/of (paste-html-text html-data text-data)) - - (and (string? text-data) (d/not-empty? text-data)) - (rx/of (paste-text text-data)) - - :else - (rx/empty)))))))) - -(defn copy-selected-css - [] - (ptk/reify ::copy-selected-css - ptk/EffectEvent - (effect [_ state _] - (let [objects (dsh/lookup-page-objects state) - selected (->> (dsh/lookup-selected state) (mapv (d/getf objects))) - css (css/generate-style objects selected selected {:with-prelude? false})] - (wapi/write-to-clipboard css))))) - -(defn copy-selected-css-nested - [] - (ptk/reify ::copy-selected-css-nested - ptk/EffectEvent - (effect [_ state _] - (let [objects (dsh/lookup-page-objects state) - selected (->> (dsh/lookup-selected state) - (cfh/selected-with-children objects) - (mapv (d/getf objects))) - css (css/generate-style objects selected selected {:with-prelude? false})] - (wapi/write-to-clipboard css))))) - -(defn copy-selected-text - [] - (ptk/reify ::copy-selected-text - ptk/EffectEvent - (effect [_ state _] - (let [selected (dsh/lookup-selected state) - objects (dsh/lookup-page-objects state) - - text-shapes - (->> (cfh/selected-with-children objects selected) - (keep (d/getf objects)) - (filter cfh/text-shape?)) - - selected (into (d/ordered-set) (map :id) text-shapes) - - ;; Narrow the objects map so it contains only relevant data for - ;; selected and its parents - objects (cfh/selected-subtree objects selected) - selected (->> (ctst/sort-z-index objects selected) - (into (d/ordered-set))) - - text - (->> selected - (map - (fn [id] - (let [shape (get objects id)] - (-> shape :content txt/content->text)))) - (str/join "\n"))] - - (wapi/write-to-clipboard text))))) - -(defn copy-selected-props - [] - (ptk/reify ::copy-selected-props - ptk/WatchEvent - (watch [_ state _] - (letfn [(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 %))))) - - (resolve-images [data] - (let [images - (concat - (->> data :props :fills (keep :fill-image)) - (->> data :props :strokes (keep :stroke-image)))] - - (if (seq images) - (->> (rx/from images) - (rx/mapcat fetch-image) - (rx/reduce conj #{}) - (rx/map #(assoc data :images %))) - (rx/of data)))) - - (on-copy-error [error] - (js/console.error "clipboard blocked:" error) - (rx/empty))] - - (let [selected (dsh/lookup-selected state)] - (if (> (count selected) 1) - ;; If multiple items are selected don't do anything - (rx/empty) - - (let [selected (->> (dsh/lookup-selected state) first) - objects (dsh/lookup-page-objects state)] - (when-let [shape (get objects selected)] - (let [props (cts/extract-props shape) - features (-> (get state :features) - (set/difference cfeat/frontend-only-features)) - version (-> (dsh/lookup-file state) - (get :version)) - - copy-data {:type :copied-props - :features features - :version version - :props props - :images #{}}] - - ;; The clipboard API doesn't handle well asynchronous calls because it expects to use - ;; the clipboard in an user interaction. If you do an async call the callback is outside - ;; the thread of the UI and so Safari blocks the copying event. - ;; We use the API `ClipboardItem` that allows promises to be passed and so the event - ;; will wait for the promise to resolve and everything should work as expected. - ;; This only works in the current versions of the browsers. - (if (some? (unchecked-get ug/global "ClipboardItem")) - (let [resolve-data-promise - (p/create - (fn [resolve reject] - (->> (rx/of copy-data) - (rx/mapcat resolve-images) - (rx/map #(t/encode-str % {:type :json-verbose})) - (rx/map #(wapi/create-blob % "text/plain")) - (rx/subs! resolve reject))))] - - (->> (rx/from (wapi/write-to-clipboard-promise "text/plain" resolve-data-promise)) - (rx/catch on-copy-error) - (rx/ignore))) - ;; FIXME: this is to support Firefox versions below 116 that don't support - ;; `ClipboardItem` after the version 116 is less common we could remove this. - ;; https://caniuse.com/?search=ClipboardItem - (->> (rx/of copy-data) - (rx/mapcat resolve-images) - (rx/map #(wapi/write-to-clipboard (t/encode-str % {:type :json-verbose}))) - (rx/catch on-copy-error) - (rx/ignore)))))))))))) - -(defn paste-selected-props - [] - (ptk/reify ::paste-selected-props - ptk/WatchEvent - (watch [_ state _] - (when-not (-> state :workspace-global :read-only?) - (letfn [(decode-entry [entry] - (-> entry t/decode-str paste-transit-props)) - - (on-error [cause] - (let [data (ex-data cause)] - (if (:not-implemented data) - (rx/of (ntf/warn (tr "errors.clipboard-not-implemented"))) - (js/console.error "Clipboard error:" cause)) - (rx/empty)))] - - (->> (wapi/read-from-clipboard) - (rx/map decode-entry) - (rx/take 1) - (rx/catch on-error))))))) - -(defn selected-frame? [state] - (let [selected (dsh/lookup-selected state) - objects (dsh/lookup-page-objects state)] - - (and (= 1 (count selected)) - (= :frame (get-in objects [(first selected) :type]))))) - -(defn get-tree-root-shapes [tree] - ;; This fn gets a map of shapes and finds what shapes are parent of the rest - (let [shapes-in-tree (vals tree) - shape-ids (keys tree) - parent-ids (set (map #(:parent-id %) shapes-in-tree))] - (->> shape-ids - (filter #(contains? parent-ids %))))) - -(defn any-same-frame-from-selected? [state frame-ids] - (let [selected (first (dsh/lookup-selected state))] - (< 0 (count (filter #(= % selected) frame-ids))))) - -(defn frame-same-size? - [paste-obj frame-obj] - (and - (= (:heigth (:selrect (first (vals paste-obj)))) - (:heigth (:selrect frame-obj))) - (= (:width (:selrect (first (vals paste-obj)))) - (:width (:selrect frame-obj))))) - -(def ^:private - schema:paste-data-shapes - [:map {:title "paste-data-shapes"} - [: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]]) - -(def ^:private - schema:paste-data-props - [:map {:title "paste-data-props"} - [:type [:= :copied-props]] - [:features ::sm/set-of-strings] - [:version :int] - [:props - ;; todo type the properties - [:map-of :keyword :any]]]) - -(def schema:paste-data - [:multi {:title "paste-data" :dispatch :type} - [:copied-shapes schema:paste-data-shapes] - [:copied-props schema:paste-data-props]]) - -(def paste-data-valid? - (sm/lazy-validator schema:paste-data)) - -(defn- paste-transit-shapes - [{:keys [images] :as pdata}] - (letfn [(upload-media [file-id imgpart] - (->> (http/send! {:uri (:data imgpart) - :response-type :blob - :method :get}) - (rx/map :body) - (rx/map - (fn [blob] - {:name (:name imgpart) - :file-id file-id - :content blob - :is-local true})) - (rx/mapcat (partial rp/cmd! :upload-file-media-object)) - (rx/map #(assoc % :prev-id (:id imgpart)))))] - - (ptk/reify ::paste-transit-shapes - ptk/WatchEvent - (watch [_ state _] - (let [file-id (:current-file-id state) - features (get state :features)] - - (when-not (paste-data-valid? pdata) - (ex/raise :type :validation - :code :invalid-paste-data - :hibt "invalid paste data found")) - - (cfeat/check-paste-features! features (:features pdata)) - - (case (:type pdata) - :copied-shapes - (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))) - nil)))))) - -(defn- paste-transit-props - [pdata] - - (letfn [(upload-media [file-id imgpart] - (->> (http/send! {:uri (:data imgpart) - :response-type :blob - :method :get}) - (rx/map :body) - (rx/map - (fn [blob] - {:name (:name imgpart) - :file-id file-id - :content blob - :is-local true})) - (rx/mapcat (partial rp/cmd! :upload-file-media-object)) - (rx/map #(vector (:id imgpart) %)))) - - (update-image-data - [pdata media-map] - (update - pdata :props - (fn [props] - (-> props - (d/update-when - :fills - (fn [fills] - (mapv (fn [fill] - (cond-> fill - (some? (:fill-image fill)) - (update-in [:fill-image :id] #(get media-map % %)))) - fills))) - (d/update-when - :strokes - (fn [strokes] - (mapv (fn [stroke] - (cond-> stroke - (some? (:stroke-image stroke)) - (update-in [:stroke-image :id] #(get media-map % %)))) - strokes))))))) - - (upload-images - [file-id pdata] - (->> (rx/from (:images pdata)) - (rx/merge-map (partial upload-media file-id)) - (rx/reduce conj {}) - (rx/map (partial update-image-data pdata))))] - - (ptk/reify ::paste-transit-props - ptk/WatchEvent - (watch [_ state _] - (let [features (get state :features) - selected (dsh/lookup-selected state)] - - (when (paste-data-valid? pdata) - (cfeat/check-paste-features! features (:features pdata)) - (case (:type pdata) - :copied-props - - (rx/concat - (->> (rx/of pdata) - (rx/mapcat (partial upload-images (:current-file-id state))) - (rx/map - #(dwsh/update-shapes - selected - (fn [shape objects] (cts/patch-props shape (:props pdata) objects)) - {:with-objects? true}))) - (rx/of (ptk/data-event :layout/update {:ids selected}))) - ;; - (rx/empty)))))))) - -(defn paste-shapes - [{in-viewport? :in-viewport :as pdata}] - (letfn [(translate-media [mdata media-idx attr-path] - (let [id (-> (get-in mdata attr-path) - (:id)) - mobj (get media-idx id)] - (if mobj - (if (empty? attr-path) - (-> mdata - (assoc :id (:id mobj)) - (assoc :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 change] - (let [;; Texts can have different fills for pieces of the text - tr-fill-xf (map #(translate-media % media-idx [:fill-image])) - tr-stroke-xf (map #(translate-media % media-idx [:stroke-image]))] - (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 []) - (d/update-when :fill-image translate-media media-idx []) - (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 pobjects selected position] - (let [page-objects (dsh/lookup-page-objects state) - selected-objs (map (d/getf pobjects) selected) - first-selected-obj (first selected-objs) - page-selected (dsh/lookup-selected state) - wrapper (gsh/shapes->rect selected-objs) - orig-pos (gpt/point (:x1 wrapper) (:y1 wrapper)) - frame-id (first page-selected) - 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 pobjects) - only-one-root-shape? (and - (< 1 (count pobjects)) - (= 1 (count tree-root)))] - - (cond - (selected-frame? state) - - (if (or (any-same-frame-from-selected? state (keys pobjects)) - (and only-one-root-shape? - (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) - paste-x (+ (:width selected-frame-obj) (:x selected-frame-obj) 50) - paste-y (:y selected-frame-obj) - delta (gpt/subtract (gpt/point paste-x paste-y) orig-pos)] - - [parent-id delta index]) - - ;; Paste inside selected frame otherwise - (let [selected-frame-obj (get page-objects (first page-selected)) - origin-frame-id (:frame-id first-selected-obj) - origin-frame-object (get page-objects origin-frame-id) - - margin-x (-> (- (:width origin-frame-object) (+ (:x wrapper) (:width wrapper))) - (min (- (:width frame-object) (:width wrapper)))) - - margin-y (-> (- (:height origin-frame-object) (+ (:y wrapper) (:height wrapper))) - (min (- (:height frame-object) (:height wrapper)))) - - ;; Pasted objects mustn't exceed the selected frame x limit - paste-x (if (> (+ (:width wrapper) (:x1 wrapper)) (:width frame-object)) - (+ (- (:x frame-object) (:x orig-pos)) (- (:width frame-object) (:width wrapper) margin-x)) - (:x frame-object)) - - ;; Pasted objects mustn't exceed the selected frame y limit - paste-y (if (> (+ (:height wrapper) (:y1 wrapper)) (:height frame-object)) - (+ (- (:y frame-object) (:y orig-pos)) (- (:height frame-object) (:height wrapper) margin-y)) - (:y frame-object)) - - delta (if (= origin-frame-id uuid/zero) - ;; When the origin isn't in a frame the result is pasted in the center. - (gpt/subtract (gsh/shape->center frame-object) (grc/rect->center wrapper)) - ;; When pasting from one frame to another frame the object - ;; position must be limited to container boundaries. If - ;; the pasted object doesn't fit we try to: - ;; - ;; - Align it to the limits on the x and y axis - ;; - Respect the distance of the object to the right - ;; and bottom in the original frame - (gpt/point paste-x paste-y))] - [frame-id delta (dec (count (:shapes selected-frame-obj)))])) - - (empty? page-selected) - (let [frame-id (ctst/top-nested-frame page-objects position) - delta (gpt/subtract position orig-pos)] - [frame-id delta]) - - :else - (let [parent-id (:parent-id base) - delta (if in-viewport? - (gpt/subtract position orig-pos) - (gpt/subtract (gpt/point (:selrect base)) orig-pos))] - [parent-id delta index])))) - - ;; Change the indexes of the pasted shapes - (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 objects [% :id])) - (reduce set-index [{} (inc index)]) - first)] - - (if (and (add-obj? change) - (contains? map-ids (:old-id change))) - (assoc change :index (get map-ids (:old-id change))) - change))) - - (process-shape [file-id frame-id parent-id shape] - (cond-> shape - :always - (assoc :frame-id frame-id :parent-id parent-id) - - (and (or (cfh/group-shape? shape) - (cfh/bool-shape? shape)) - (nil? (:shapes shape))) - (assoc :shapes []) - - (cfh/text-shape? shape) - (ctt/remove-external-typographies file-id)))] - - (ptk/reify ::paste-shapes - ptk/WatchEvent - (watch [it state _] - (let [file-id (:current-file-id state) - page (dsh/lookup-page state) - - media-idx (->> (:images pdata) - (d/index-by :prev-id)) - - selected (:selected pdata) - - objects (:objects pdata) - - variant-props (:variant-properties pdata) - - - position (deref ms/mouse-position) - - ;; Calculate position for the pasted elements - [candidate-parent-id - delta - index] (calculate-paste-position state objects selected position) - - page-objects (:objects page) - - libraries (dsh/lookup-libraries state) - ldata (dsh/lookup-file-data state file-id) - - [parent-id - frame-id] (ctn/find-valid-parent-and-frame-ids candidate-parent-id page-objects (vals objects) true libraries) - - index (if (= candidate-parent-id parent-id) - index - 0) - - selected (if (and (ctl/flex-layout? page-objects parent-id) (not (ctl/reverse? page-objects parent-id))) - (into (d/ordered-set) (reverse selected)) - selected) - - objects (update-vals objects (partial process-shape file-id frame-id parent-id)) - - all-objects (merge page-objects objects) - - drop-cell (when (ctl/grid-layout? all-objects parent-id) - (gslg/get-drop-cell frame-id all-objects position)) - - changes (-> (pcb/empty-changes it) - (cll/generate-duplicate-changes all-objects page selected delta - libraries ldata file-id {:variant-props variant-props}) - (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)) - - orig-shapes (map (d/getf all-objects) selected) - - 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/concat - (->> (filter ctc/instance-head? orig-shapes) - (map (fn [{:keys [component-file]}] - (ptk/event ::ev/event - {::ev/name "use-library-component" - ::ev/origin "paste" - :external-library (not= file-id component-file)}))) - (rx/from)) - (rx/of (dwu/start-undo-transaction undo-id) - (dch/commit-changes changes) - (dws/select-shapes selected) - (ptk/data-event :layout/update {:ids [frame-id]}) - (dwu/commit-undo-transaction undo-id)))))))) - -(defn as-content [text] - (let [paragraphs (->> (str/lines text) - (map str/trim) - (mapv #(hash-map :type "paragraph" - :children [(merge txt/default-text-attrs {:text %})])))] - ;; if text is composed only by line breaks paragraphs is an empty list and should be nil - (when (d/not-empty? paragraphs) - {:type "root" - :children [{:type "paragraph-set" :children paragraphs}]}))) - -(defn calculate-paste-position [state] - (cond - ;; Pasting inside a frame - (selected-frame? state) - (let [page-selected (dsh/lookup-selected state) - page-objects (dsh/lookup-page-objects state) - frame-id (first page-selected) - frame-object (get page-objects frame-id)] - (gsh/shape->center frame-object)) - - :else - (deref ms/mouse-position))) - -(defn- paste-html-text - [html text] - (dm/assert! (string? html)) - (ptk/reify ::paste-html-text - ptk/WatchEvent - (watch [_ state _] - (let [root (dwtxt/create-root-from-html html) - content (tc/dom->cljs root)] - (when (types.text/valid-content? content) - (let [id (uuid/next) - width (max 8 (min (* 7 (count text)) 700)) - height 16 - {:keys [x y]} (calculate-paste-position state) - - shape {:id id - :type :text - :name (txt/generate-shape-name text) - :x x - :y y - :width width - :height height - :grow-type (if (> (count text) 100) :auto-height :auto-width) - :content content} - undo-id (js/Symbol)] - (rx/of (dwu/start-undo-transaction undo-id) - (dwsh/create-and-add-shape :text x y shape) - (dwu/commit-undo-transaction undo-id)))))))) - -(defn- paste-text - [text] - (dm/assert! (string? text)) - (ptk/reify ::paste-text - ptk/WatchEvent - (watch [_ state _] - (let [id (uuid/next) - width (max 8 (min (* 7 (count text)) 700)) - height 16 - {:keys [x y]} (calculate-paste-position state) - - shape {:id id - :type :text - :name (txt/generate-shape-name text) - :x x - :y y - :width width - :height height - :grow-type (if (> (count text) 100) :auto-height :auto-width) - :content (as-content text)} - undo-id (js/Symbol)] - - (rx/of (dwu/start-undo-transaction undo-id) - (dwsh/create-and-add-shape :text x y shape) - (dwu/commit-undo-transaction undo-id)))))) - -;; TODO: why not implement it in terms of upload-media-workspace? -(defn- paste-svg-text - [text] - (dm/assert! (string? text)) - (ptk/reify ::paste-svg-text - ptk/WatchEvent - (watch [_ state _] - (let [position (calculate-paste-position state) - file-id (:current-file-id state)] - (->> (dwm/svg->clj ["svg" text]) - (rx/map #(dwm/svg-uploaded % file-id position))))))) - -(defn- paste-image - [image] - (ptk/reify ::paste-image - ptk/WatchEvent - (watch [_ state _] - (let [file-id (:current-file-id state) - position (calculate-paste-position state) - params {:file-id file-id - :blobs [image] - :position position}] - (rx/of (dwm/upload-media-workspace params)))))) - (defn toggle-distances-display [value] (ptk/reify ::toggle-distances-display @@ -2271,12 +1308,6 @@ (update [_ state] (assoc-in state [:workspace-global :show-distances?] value)))) -(defn copy-link-to-clipboard - [] - (ptk/reify ::copy-link-to-clipboard - ptk/WatchEvent - (watch [_ _ _] - (wapi/write-to-clipboard (rt/get-current-href))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Interactions @@ -2507,6 +1538,19 @@ (dm/export dws/select-shapes) (dm/export dwe/start-edition-mode) +;; Clipboard +(dm/export dwcp/copy-selected) +(dm/export dwcp/paste-from-clipboard) +(dm/export dwcp/paste-from-event) +(dm/export dwcp/copy-selected-css) +(dm/export dwcp/copy-selected-css-nested) +(dm/export dwcp/copy-selected-text) +(dm/export dwcp/copy-selected-props) +(dm/export dwcp/paste-selected-props) +(dm/export dwcp/paste-shapes) +(dm/export dwcp/paste-data-valid?) +(dm/export dwcp/copy-link-to-clipboard) + ;; Drawing (dm/export dwd/select-for-drawing) diff --git a/frontend/src/app/main/data/workspace/clipboard.cljs b/frontend/src/app/main/data/workspace/clipboard.cljs new file mode 100644 index 0000000000..a8e41298cf --- /dev/null +++ b/frontend/src/app/main/data/workspace/clipboard.cljs @@ -0,0 +1,1004 @@ +;; This Source Code Form is subject to the terms of the Mozilla Public +;; License, v. 2.0. If a copy of the MPL was not distributed with this +;; file, You can obtain one at http://mozilla.org/MPL/2.0/. +;; +;; Copyright (c) KALEIDOS INC + +(ns app.main.data.workspace.clipboard + (:require + [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.files.variant :as cfv] + [app.common.geom.point :as gpt] + [app.common.geom.rect :as grc] + [app.common.geom.shapes :as gsh] + [app.common.geom.shapes.grid-layout :as gslg] + [app.common.logic.libraries :as cll] + [app.common.schema :as sm] + [app.common.text :as txt] + [app.common.transit :as t] + [app.common.types.component :as ctc] + [app.common.types.container :as ctn] + [app.common.types.file :as ctf] + [app.common.types.shape :as cts] + [app.common.types.shape-tree :as ctst] + [app.common.types.shape.layout :as ctl] + [app.common.types.shape.text :as types.text] + [app.common.types.typography :as ctt] + [app.common.uuid :as uuid] + [app.config :as cf] + [app.main.data.changes :as dch] + [app.main.data.event :as ev] + [app.main.data.helpers :as dsh] + [app.main.data.notifications :as ntf] + [app.main.data.persistence :as-alias dps] + [app.main.data.workspace.media :as dwm] + [app.main.data.workspace.selection :as dws] + [app.main.data.workspace.shapes :as dwsh] + [app.main.data.workspace.texts :as dwtxt] + [app.main.data.workspace.undo :as dwu] + [app.main.errors] + [app.main.repo :as rp] + [app.main.router :as rt] + [app.main.streams :as ms] + [app.util.code-gen.style-css :as css] + [app.util.globals :as ug] + [app.util.http :as http] + [app.util.i18n :as i18n :refer [tr]] + [app.util.text.content :as tc] + [app.util.webapi :as wapi] + [beicon.v2.core :as rx] + [clojure.set :as set] + [cuerdas.core :as str] + [potok.v2.core :as ptk] + [promesa.core :as p])) + +(defn copy-selected + [] + (letfn [(sort-selected [state data] + (let [selected (dsh/lookup-selected state) + objects (dsh/lookup-page-objects state) + + ;; Narrow the objects map so it contains only relevant data for + ;; selected and its parents + objects (cfh/selected-subtree objects selected) + selected (->> (ctst/sort-z-index objects selected) + (reverse) + (into (d/ordered-set)))] + + (assoc data :selected selected))) + + (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 obj] + (let [obj (maybe-translate obj objects parent-frame-id) + ;; Texts can have different fills for pieces of the text + imgdata (concat + (->> (or (:position-data obj) [obj]) + (mapcat :fills) + (keep :fill-image)) + (->> (:strokes obj) + (keep :stroke-image)) + (when (cfh/image-shape? obj) + [(:metadata obj)]) + (when (:fill-image obj) + [(:fill-image obj)]))] + + (if (seq imgdata) + (->> (rx/from imgdata) + (rx/mapcat fetch-image) + (rx/reduce conj []) + (rx/map (fn [images] + (assoc obj ::images images)))) + (rx/of obj)))) + + (collect-variants [state shape] + (let [page-id (:current-page-id state) + data (dsh/lookup-file-data state) + objects (-> (dsh/get-page data page-id) + (get :objects)) + + components (cfv/find-variant-components data objects (:id shape))] + (into {} (map (juxt :id :variant-properties) components)))) + + + ;; Collects all the items together and split images into a + ;; separated data structure for a more easy paste process. + ;; Also collects the variant properties of the copied variants + (collect-data [state result {:keys [id ::images] :as item}] + (cond-> result + :always + (update :objects assoc id (dissoc item ::images)) + + (some? images) + (update :images into images) + + (ctc/is-variant-container? item) + (update :variant-properties merge (collect-variants state item)))) + + + + (maybe-translate [shape objects parent-frame-id] + (if (= parent-frame-id uuid/zero) + shape + (let [frame (get objects parent-frame-id)] + (gsh/translate-to-frame shape frame)))) + + ;; When copying an instance that is nested inside another one, we need to + ;; advance the shape refs to one or more levels of remote mains. + (advance-copies [state selected data] + (let [file (dsh/lookup-file state) + libraries (:files state) + ;; FIXME + page (dsh/lookup-page state) + heads (mapcat #(ctn/get-child-heads (:objects data) %) selected)] + (update data :objects + #(reduce (partial advance-copy file libraries page) + % + heads)))) + + (advance-copy [file libraries page objects shape] + (if (and (ctc/instance-head? shape) (not (ctc/main-instance? shape))) + (let [level-delta (ctn/get-nesting-level-delta (:objects page) shape uuid/zero)] + (if (pos? level-delta) + (reduce (partial advance-shape file libraries page level-delta) + objects + (cfh/get-children-with-self objects (:id shape))) + objects)) + objects)) + + (advance-shape [file libraries page level-delta objects shape] + (let [new-shape-ref (ctf/advance-shape-ref file page libraries shape level-delta {:include-deleted? true})] + (cond-> objects + (and (some? new-shape-ref) (not= new-shape-ref (:shape-ref shape))) + (assoc-in [(:id shape) :shape-ref] new-shape-ref)))) + + (on-copy-error [error] + (js/console.error "clipboard blocked:" error) + (rx/empty))] + + (ptk/reify ::copy-selected + ptk/WatchEvent + (watch [_ state _] + (let [text (wapi/get-current-selected-text)] + (if-not (str/empty? text) + (try + (wapi/write-to-clipboard text) + (catch :default e + (on-copy-error e))) + + (let [objects (dsh/lookup-page-objects state) + selected (->> (dsh/lookup-selected state) + (cfh/clean-loops objects)) + features (-> (get state :features) + (set/difference cfeat/frontend-only-features)) + + file-id (:current-file-id state) + frame-id (cfh/common-parent-frame objects selected) + file (dsh/lookup-file state file-id) + version (get file :version) + + initial {:type :copied-shapes + :features features + :version version + :file-id file-id + :selected selected + :objects {} + :images #{}} + + shapes (->> (cfh/selected-with-children objects selected) + (keep (d/getf objects)))] + + ;; The clipboard API doesn't handle well asynchronous calls because it expects to use + ;; the clipboard in an user interaction. If you do an async call the callback is outside + ;; the thread of the UI and so Safari blocks the copying event. + ;; We use the API `ClipboardItem` that allows promises to be passed and so the event + ;; will wait for the promise to resolve and everything should work as expected. + ;; This only works in the current versions of the browsers. + (if (some? (unchecked-get ug/global "ClipboardItem")) + (let [resolve-data-promise + (p/create + (fn [resolve reject] + (->> (rx/from shapes) + (rx/merge-map (partial prepare-object objects frame-id)) + (rx/reduce (partial collect-data state) initial) + (rx/map (partial sort-selected state)) + (rx/map (partial advance-copies state selected)) + (rx/map #(t/encode-str % {:type :json-verbose})) + (rx/map #(wapi/create-blob % "text/plain")) + (rx/subs! resolve reject))))] + (->> (rx/from (wapi/write-to-clipboard-promise "text/plain" resolve-data-promise)) + (rx/catch on-copy-error) + (rx/ignore))) + + ;; FIXME: this is to support Firefox versions below 116 that don't support + ;; `ClipboardItem` after the version 116 is less common we could remove this. + ;; https://caniuse.com/?search=ClipboardItem + (->> (rx/from shapes) + (rx/merge-map (partial prepare-object objects frame-id)) + (rx/reduce (partial collect-data state) initial) + (rx/map (partial sort-selected state)) + (rx/map (partial advance-copies state selected)) + (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-shapes) +(declare ^:private paste-transit-props) +(declare ^:private paste-html-text) +(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 + (cond + (str/empty? data) + (rx/empty) + + (re-find #"> (rx/concat + (->> (wapi/read-from-clipboard) + (rx/map decode-entry) + (rx/mapcat process-entry)) + (->> (wapi/read-image-from-clipboard) + (rx/map paste-image))) + (rx/take 1) + (rx/catch on-error)))))) + +(defn paste-from-event + "Perform a `paste` operation from user emmited event." + [event in-viewport?] + (ptk/reify ::paste-from-event + ptk/WatchEvent + (watch [_ state _] + (let [objects (dsh/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])))] + + ;; 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) + html-data (some-> pdata wapi/extract-html-text) + transit-data (ex/ignoring (some-> text-data t/decode-str))] + (cond + (and (string? text-data) (re-find #"> (rx/from image-data) + (rx/map paste-image)) + + (coll? transit-data) + (rx/of (paste-transit-shapes (assoc transit-data :in-viewport in-viewport?))) + + (and (string? html-data) (d/not-empty? html-data)) + (rx/of (paste-html-text html-data text-data)) + + (and (string? text-data) (d/not-empty? text-data)) + (rx/of (paste-text text-data)) + + :else + (rx/empty)))))))) + +(defn copy-selected-css + [] + (ptk/reify ::copy-selected-css + ptk/EffectEvent + (effect [_ state _] + (let [objects (dsh/lookup-page-objects state) + selected (->> (dsh/lookup-selected state) (mapv (d/getf objects))) + css (css/generate-style objects selected selected {:with-prelude? false})] + (wapi/write-to-clipboard css))))) + +(defn copy-selected-css-nested + [] + (ptk/reify ::copy-selected-css-nested + ptk/EffectEvent + (effect [_ state _] + (let [objects (dsh/lookup-page-objects state) + selected (->> (dsh/lookup-selected state) + (cfh/selected-with-children objects) + (mapv (d/getf objects))) + css (css/generate-style objects selected selected {:with-prelude? false})] + (wapi/write-to-clipboard css))))) + +(defn copy-selected-text + [] + (ptk/reify ::copy-selected-text + ptk/EffectEvent + (effect [_ state _] + (let [selected (dsh/lookup-selected state) + objects (dsh/lookup-page-objects state) + + text-shapes + (->> (cfh/selected-with-children objects selected) + (keep (d/getf objects)) + (filter cfh/text-shape?)) + + selected (into (d/ordered-set) (map :id) text-shapes) + + ;; Narrow the objects map so it contains only relevant data for + ;; selected and its parents + objects (cfh/selected-subtree objects selected) + selected (->> (ctst/sort-z-index objects selected) + (into (d/ordered-set))) + + text + (->> selected + (map + (fn [id] + (let [shape (get objects id)] + (-> shape :content txt/content->text)))) + (str/join "\n"))] + + (wapi/write-to-clipboard text))))) + +(defn copy-selected-props + [] + (ptk/reify ::copy-selected-props + ptk/WatchEvent + (watch [_ state _] + (letfn [(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 %))))) + + (resolve-images [data] + (let [images + (concat + (->> data :props :fills (keep :fill-image)) + (->> data :props :strokes (keep :stroke-image)))] + + (if (seq images) + (->> (rx/from images) + (rx/mapcat fetch-image) + (rx/reduce conj #{}) + (rx/map #(assoc data :images %))) + (rx/of data)))) + + (on-copy-error [error] + (js/console.error "clipboard blocked:" error) + (rx/empty))] + + (let [selected (dsh/lookup-selected state)] + (if (> (count selected) 1) + ;; If multiple items are selected don't do anything + (rx/empty) + + (let [selected (->> (dsh/lookup-selected state) first) + objects (dsh/lookup-page-objects state)] + (when-let [shape (get objects selected)] + (let [props (cts/extract-props shape) + features (-> (get state :features) + (set/difference cfeat/frontend-only-features)) + version (-> (dsh/lookup-file state) + (get :version)) + + copy-data {:type :copied-props + :features features + :version version + :props props + :images #{}}] + + ;; The clipboard API doesn't handle well asynchronous calls because it expects to use + ;; the clipboard in an user interaction. If you do an async call the callback is outside + ;; the thread of the UI and so Safari blocks the copying event. + ;; We use the API `ClipboardItem` that allows promises to be passed and so the event + ;; will wait for the promise to resolve and everything should work as expected. + ;; This only works in the current versions of the browsers. + (if (some? (unchecked-get ug/global "ClipboardItem")) + (let [resolve-data-promise + (p/create + (fn [resolve reject] + (->> (rx/of copy-data) + (rx/mapcat resolve-images) + (rx/map #(t/encode-str % {:type :json-verbose})) + (rx/map #(wapi/create-blob % "text/plain")) + (rx/subs! resolve reject))))] + + (->> (rx/from (wapi/write-to-clipboard-promise "text/plain" resolve-data-promise)) + (rx/catch on-copy-error) + (rx/ignore))) + ;; FIXME: this is to support Firefox versions below 116 that don't support + ;; `ClipboardItem` after the version 116 is less common we could remove this. + ;; https://caniuse.com/?search=ClipboardItem + (->> (rx/of copy-data) + (rx/mapcat resolve-images) + (rx/map #(wapi/write-to-clipboard (t/encode-str % {:type :json-verbose}))) + (rx/catch on-copy-error) + (rx/ignore)))))))))))) + +(defn paste-selected-props + [] + (ptk/reify ::paste-selected-props + ptk/WatchEvent + (watch [_ state _] + (when-not (-> state :workspace-global :read-only?) + (letfn [(decode-entry [entry] + (-> entry t/decode-str paste-transit-props)) + + (on-error [cause] + (let [data (ex-data cause)] + (if (:not-implemented data) + (rx/of (ntf/warn (tr "errors.clipboard-not-implemented"))) + (js/console.error "Clipboard error:" cause)) + (rx/empty)))] + + (->> (wapi/read-from-clipboard) + (rx/map decode-entry) + (rx/take 1) + (rx/catch on-error))))))) + +(defn- selected-frame? [state] + (let [selected (dsh/lookup-selected state) + objects (dsh/lookup-page-objects state)] + + (and (= 1 (count selected)) + (= :frame (get-in objects [(first selected) :type]))))) + +(defn- get-tree-root-shapes [tree] + ;; This fn gets a map of shapes and finds what shapes are parent of the rest + (let [shapes-in-tree (vals tree) + shape-ids (keys tree) + parent-ids (set (map #(:parent-id %) shapes-in-tree))] + (->> shape-ids + (filter #(contains? parent-ids %))))) + +(defn- any-same-frame-from-selected? [state frame-ids] + (let [selected (first (dsh/lookup-selected state))] + (< 0 (count (filter #(= % selected) frame-ids))))) + +(defn- frame-same-size? + [paste-obj frame-obj] + (and + (= (:heigth (:selrect (first (vals paste-obj)))) + (:heigth (:selrect frame-obj))) + (= (:width (:selrect (first (vals paste-obj)))) + (:width (:selrect frame-obj))))) + +(def ^:private + schema:paste-data-shapes + [:map {:title "paste-data-shapes"} + [: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]]) + +(def ^:private + schema:paste-data-props + [:map {:title "paste-data-props"} + [:type [:= :copied-props]] + [:features ::sm/set-of-strings] + [:version :int] + [:props + ;; todo type the properties + [:map-of :keyword :any]]]) + +(def schema:paste-data + [:multi {:title "paste-data" :dispatch :type} + [:copied-shapes schema:paste-data-shapes] + [:copied-props schema:paste-data-props]]) + +(def paste-data-valid? + (sm/lazy-validator schema:paste-data)) + +(defn- paste-transit-shapes + [{:keys [images] :as pdata}] + (letfn [(upload-media [file-id imgpart] + (->> (http/send! {:uri (:data imgpart) + :response-type :blob + :method :get}) + (rx/map :body) + (rx/map + (fn [blob] + {:name (:name imgpart) + :file-id file-id + :content blob + :is-local true})) + (rx/mapcat (partial rp/cmd! :upload-file-media-object)) + (rx/map #(assoc % :prev-id (:id imgpart)))))] + + (ptk/reify ::paste-transit-shapes + ptk/WatchEvent + (watch [_ state _] + (let [file-id (:current-file-id state) + features (get state :features)] + + (when-not (paste-data-valid? pdata) + (ex/raise :type :validation + :code :invalid-paste-data + :hibt "invalid paste data found")) + + (cfeat/check-paste-features! features (:features pdata)) + + (case (:type pdata) + :copied-shapes + (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))) + nil)))))) + +(defn- paste-transit-props + [pdata] + + (letfn [(upload-media [file-id imgpart] + (->> (http/send! {:uri (:data imgpart) + :response-type :blob + :method :get}) + (rx/map :body) + (rx/map + (fn [blob] + {:name (:name imgpart) + :file-id file-id + :content blob + :is-local true})) + (rx/mapcat (partial rp/cmd! :upload-file-media-object)) + (rx/map #(vector (:id imgpart) %)))) + + (update-image-data + [pdata media-map] + (update + pdata :props + (fn [props] + (-> props + (d/update-when + :fills + (fn [fills] + (mapv (fn [fill] + (cond-> fill + (some? (:fill-image fill)) + (update-in [:fill-image :id] #(get media-map % %)))) + fills))) + (d/update-when + :strokes + (fn [strokes] + (mapv (fn [stroke] + (cond-> stroke + (some? (:stroke-image stroke)) + (update-in [:stroke-image :id] #(get media-map % %)))) + strokes))))))) + + (upload-images + [file-id pdata] + (->> (rx/from (:images pdata)) + (rx/merge-map (partial upload-media file-id)) + (rx/reduce conj {}) + (rx/map (partial update-image-data pdata))))] + + (ptk/reify ::paste-transit-props + ptk/WatchEvent + (watch [_ state _] + (let [features (get state :features) + selected (dsh/lookup-selected state)] + + (when (paste-data-valid? pdata) + (cfeat/check-paste-features! features (:features pdata)) + (case (:type pdata) + :copied-props + + (rx/concat + (->> (rx/of pdata) + (rx/mapcat (partial upload-images (:current-file-id state))) + (rx/map + #(dwsh/update-shapes + selected + (fn [shape objects] (cts/patch-props shape (:props pdata) objects)) + {:with-objects? true}))) + (rx/of (ptk/data-event :layout/update {:ids selected}))) + ;; + (rx/empty)))))))) + +(defn paste-shapes + [{in-viewport? :in-viewport :as pdata}] + (letfn [(translate-media [mdata media-idx attr-path] + (let [id (-> (get-in mdata attr-path) + (:id)) + mobj (get media-idx id)] + (if mobj + (if (empty? attr-path) + (-> mdata + (assoc :id (:id mobj)) + (assoc :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 change] + (let [;; Texts can have different fills for pieces of the text + tr-fill-xf (map #(translate-media % media-idx [:fill-image])) + tr-stroke-xf (map #(translate-media % media-idx [:stroke-image]))] + (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 []) + (d/update-when :fill-image translate-media media-idx []) + (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 pobjects selected position] + (let [page-objects (dsh/lookup-page-objects state) + selected-objs (map (d/getf pobjects) selected) + first-selected-obj (first selected-objs) + page-selected (dsh/lookup-selected state) + wrapper (gsh/shapes->rect selected-objs) + orig-pos (gpt/point (:x1 wrapper) (:y1 wrapper)) + frame-id (first page-selected) + 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 pobjects) + only-one-root-shape? (and + (< 1 (count pobjects)) + (= 1 (count tree-root)))] + + (cond + (selected-frame? state) + + (if (or (any-same-frame-from-selected? state (keys pobjects)) + (and only-one-root-shape? + (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) + paste-x (+ (:width selected-frame-obj) (:x selected-frame-obj) 50) + paste-y (:y selected-frame-obj) + delta (gpt/subtract (gpt/point paste-x paste-y) orig-pos)] + + [parent-id delta index]) + + ;; Paste inside selected frame otherwise + (let [selected-frame-obj (get page-objects (first page-selected)) + origin-frame-id (:frame-id first-selected-obj) + origin-frame-object (get page-objects origin-frame-id) + + margin-x (-> (- (:width origin-frame-object) (+ (:x wrapper) (:width wrapper))) + (min (- (:width frame-object) (:width wrapper)))) + + margin-y (-> (- (:height origin-frame-object) (+ (:y wrapper) (:height wrapper))) + (min (- (:height frame-object) (:height wrapper)))) + + ;; Pasted objects mustn't exceed the selected frame x limit + paste-x (if (> (+ (:width wrapper) (:x1 wrapper)) (:width frame-object)) + (+ (- (:x frame-object) (:x orig-pos)) (- (:width frame-object) (:width wrapper) margin-x)) + (:x frame-object)) + + ;; Pasted objects mustn't exceed the selected frame y limit + paste-y (if (> (+ (:height wrapper) (:y1 wrapper)) (:height frame-object)) + (+ (- (:y frame-object) (:y orig-pos)) (- (:height frame-object) (:height wrapper) margin-y)) + (:y frame-object)) + + delta (if (= origin-frame-id uuid/zero) + ;; When the origin isn't in a frame the result is pasted in the center. + (gpt/subtract (gsh/shape->center frame-object) (grc/rect->center wrapper)) + ;; When pasting from one frame to another frame the object + ;; position must be limited to container boundaries. If + ;; the pasted object doesn't fit we try to: + ;; + ;; - Align it to the limits on the x and y axis + ;; - Respect the distance of the object to the right + ;; and bottom in the original frame + (gpt/point paste-x paste-y))] + [frame-id delta (dec (count (:shapes selected-frame-obj)))])) + + (empty? page-selected) + (let [frame-id (ctst/top-nested-frame page-objects position) + delta (gpt/subtract position orig-pos)] + [frame-id delta]) + + :else + (let [parent-id (:parent-id base) + delta (if in-viewport? + (gpt/subtract position orig-pos) + (gpt/subtract (gpt/point (:selrect base)) orig-pos))] + [parent-id delta index])))) + + ;; Change the indexes of the pasted shapes + (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 objects [% :id])) + (reduce set-index [{} (inc index)]) + first)] + + (if (and (add-obj? change) + (contains? map-ids (:old-id change))) + (assoc change :index (get map-ids (:old-id change))) + change))) + + (process-shape [file-id frame-id parent-id shape] + (cond-> shape + :always + (assoc :frame-id frame-id :parent-id parent-id) + + (and (or (cfh/group-shape? shape) + (cfh/bool-shape? shape)) + (nil? (:shapes shape))) + (assoc :shapes []) + + (cfh/text-shape? shape) + (ctt/remove-external-typographies file-id)))] + + (ptk/reify ::paste-shapes + ptk/WatchEvent + (watch [it state _] + (let [file-id (:current-file-id state) + page (dsh/lookup-page state) + + media-idx (->> (:images pdata) + (d/index-by :prev-id)) + + selected (:selected pdata) + + objects (:objects pdata) + + variant-props (:variant-properties pdata) + + + position (deref ms/mouse-position) + + ;; Calculate position for the pasted elements + [candidate-parent-id + delta + index] (calculate-paste-position state objects selected position) + + page-objects (:objects page) + + libraries (dsh/lookup-libraries state) + ldata (dsh/lookup-file-data state file-id) + + [parent-id + frame-id] (ctn/find-valid-parent-and-frame-ids candidate-parent-id page-objects (vals objects) true libraries) + + index (if (= candidate-parent-id parent-id) + index + 0) + + selected (if (and (ctl/flex-layout? page-objects parent-id) (not (ctl/reverse? page-objects parent-id))) + (into (d/ordered-set) (reverse selected)) + selected) + + objects (update-vals objects (partial process-shape file-id frame-id parent-id)) + + all-objects (merge page-objects objects) + + drop-cell (when (ctl/grid-layout? all-objects parent-id) + (gslg/get-drop-cell frame-id all-objects position)) + + changes (-> (pcb/empty-changes it) + (cll/generate-duplicate-changes all-objects page selected delta + libraries ldata file-id {:variant-props variant-props}) + (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)) + + orig-shapes (map (d/getf all-objects) selected) + + 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/concat + (->> (filter ctc/instance-head? orig-shapes) + (map (fn [{:keys [component-file]}] + (ptk/event ::ev/event + {::ev/name "use-library-component" + ::ev/origin "paste" + :external-library (not= file-id component-file)}))) + (rx/from)) + (rx/of (dwu/start-undo-transaction undo-id) + (dch/commit-changes changes) + (dws/select-shapes selected) + (ptk/data-event :layout/update {:ids [frame-id]}) + (dwu/commit-undo-transaction undo-id)))))))) + +(defn- as-content [text] + (let [paragraphs (->> (str/lines text) + (map str/trim) + (mapv #(hash-map :type "paragraph" + :children [(merge txt/default-text-attrs {:text %})])))] + ;; if text is composed only by line breaks paragraphs is an empty list and should be nil + (when (d/not-empty? paragraphs) + {:type "root" + :children [{:type "paragraph-set" :children paragraphs}]}))) + +(defn- calculate-paste-position [state] + (cond + ;; Pasting inside a frame + (selected-frame? state) + (let [page-selected (dsh/lookup-selected state) + page-objects (dsh/lookup-page-objects state) + frame-id (first page-selected) + frame-object (get page-objects frame-id)] + (gsh/shape->center frame-object)) + + :else + (deref ms/mouse-position))) + +(defn- paste-html-text + [html text] + (dm/assert! (string? html)) + (ptk/reify ::paste-html-text + ptk/WatchEvent + (watch [_ state _] + (let [root (dwtxt/create-root-from-html html) + content (tc/dom->cljs root)] + (when (types.text/valid-content? content) + (let [id (uuid/next) + width (max 8 (min (* 7 (count text)) 700)) + height 16 + {:keys [x y]} (calculate-paste-position state) + + shape {:id id + :type :text + :name (txt/generate-shape-name text) + :x x + :y y + :width width + :height height + :grow-type (if (> (count text) 100) :auto-height :auto-width) + :content content} + undo-id (js/Symbol)] + (rx/of (dwu/start-undo-transaction undo-id) + (dwsh/create-and-add-shape :text x y shape) + (dwu/commit-undo-transaction undo-id)))))))) + +(defn- paste-text + [text] + (dm/assert! (string? text)) + (ptk/reify ::paste-text + ptk/WatchEvent + (watch [_ state _] + (let [id (uuid/next) + width (max 8 (min (* 7 (count text)) 700)) + height 16 + {:keys [x y]} (calculate-paste-position state) + + shape {:id id + :type :text + :name (txt/generate-shape-name text) + :x x + :y y + :width width + :height height + :grow-type (if (> (count text) 100) :auto-height :auto-width) + :content (as-content text)} + undo-id (js/Symbol)] + + (rx/of (dwu/start-undo-transaction undo-id) + (dwsh/create-and-add-shape :text x y shape) + (dwu/commit-undo-transaction undo-id)))))) + +;; TODO: why not implement it in terms of upload-media-workspace? +(defn- paste-svg-text + [text] + (dm/assert! (string? text)) + (ptk/reify ::paste-svg-text + ptk/WatchEvent + (watch [_ state _] + (let [position (calculate-paste-position state) + file-id (:current-file-id state)] + (->> (dwm/svg->clj ["svg" text]) + (rx/map #(dwm/svg-uploaded % file-id position))))))) + +(defn- paste-image + [image] + (ptk/reify ::paste-image + ptk/WatchEvent + (watch [_ state _] + (let [file-id (:current-file-id state) + position (calculate-paste-position state) + params {:file-id file-id + :blobs [image] + :position position}] + (rx/of (dwm/upload-media-workspace params)))))) + +(defn copy-link-to-clipboard + [] + (ptk/reify ::copy-link-to-clipboard + ptk/WatchEvent + (watch [_ _ _] + (wapi/write-to-clipboard (rt/get-current-href)))))