Penpot/penpot
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-03-17 18:21:23 -05:00
Code Issues Activity

Merge pull request #4067 from penpot/staging-migration

Browse source 
⚡ & 🐛 More fixes and performance enhacements for the migration process
This commit is contained in:
Andrey Antukh 2024-02-02 10:56:49 +01:00 • committed by GitHub
commit 79105e8034
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
25 changed files with 790 additions and 372 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
backend/dev/user.clj
View file

@ -7,6 +7,7 @@
(ns user
(:require
[app.common.data :as d]
[app.common.debug :as debug]
[app.common.exceptions :as ex]
[app.common.files.helpers :as cfh]
[app.common.fressian :as fres]
@ -55,8 +56,12 @@
[promesa.exec :as px]))
(repl/disable-reload! (find-ns 'integrant.core))
(repl/disable-reload! (find-ns 'app.common.debug))
(set! *warn-on-reflection* true)
(add-tap #'debug/tap-handler)
;; --- Benchmarking Tools
(defmacro run-quick-bench
@ -132,12 +137,6 @@
;; :v6 v6
;; }])))
(defonce debug-tap
(do
(add-tap #(locking debug-tap
(prn "tap debug:" %)))
1))
(defn calculate-frames
[{:keys [data]}]

2
backend/resources/log4j2-devenv.xml
View file

@ -21,7 +21,7 @@
<Logger name="com.zaxxer.hikari" level="error"/>
<Logger name="org.postgresql" level="error" />
<Logger name="app.rpc.commands.binfile" level="debug" />
<Logger name="app.binfile" level="debug" />
<Logger name="app.storage.tmp" level="info" />
<Logger name="app.worker" level="trace" />
<Logger name="app.msgbus" level="info" />

421
backend/src/app/features/components_v2.clj
View file

@ -31,6 +31,7 @@
[app.common.types.components-list :as ctkl]
[app.common.types.container :as ctn]
[app.common.types.file :as ctf]
[app.common.types.grid :as ctg]
[app.common.types.page :as ctp]
[app.common.types.pages-list :as ctpl]
[app.common.types.shape :as cts]
@ -105,10 +106,20 @@
;; FILE PREPARATION BEFORE MIGRATION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def valid-color? (sm/lazy-validator ::ctc/recent-color))
(def valid-fill? (sm/lazy-validator ::cts/fill))
(def valid-stroke? (sm/lazy-validator ::cts/stroke))
(def valid-flow? (sm/lazy-validator ::ctp/flow))
(def valid-recent-color?
(sm/lazy-validator ::ctc/recent-color))
(def valid-color?
(sm/lazy-validator ::ctc/color))
(def valid-fill?
(sm/lazy-validator ::cts/fill))
(def valid-stroke?
(sm/lazy-validator ::cts/stroke))
(def valid-flow?
(sm/lazy-validator ::ctp/flow))
(def valid-text-content?
(sm/lazy-validator ::ctsx/content))
@ -122,30 +133,61 @@
(def valid-rgb-color-string?
(sm/lazy-validator ::ctc/rgb-color))
(def valid-shape-points?
(sm/lazy-validator ::cts/points))
(def valid-image-attrs?
(sm/lazy-validator ::cts/image-attrs))
(def valid-column-grid-params?
(sm/lazy-validator ::ctg/column-params))
(def valid-square-grid-params?
(sm/lazy-validator ::ctg/square-params))
(defn- prepare-file-data
"Apply some specific migrations or fixes to things that are allowed in v1 but not in v2,
or that are the result of old bugs."
[file-data libraries]
(let [detached-ids (volatile! #{})
detach-shape
(fn [container shape]
;; Detach a shape. If it's inside a component, add it to detached-ids. This list
;; is used later to process any other copy that was referencing a detached copy.
;; Detach a shape and make necessary adjustments.
(let [is-component? (let [root-shape (ctst/get-shape container (:id container))]
(and (some? root-shape) (nil? (:parent-id root-shape))))]
(when is-component?
(vswap! detached-ids conj (:id shape)))
(ctk/detach-shape shape)))
(and (some? root-shape) (nil? (:parent-id root-shape))))
parent (ctst/get-shape container (:parent-id shape))
in-copy? (ctn/in-any-component? (:objects container) parent)]
(letfn [(detach-recursive [container shape first?]
;; If the shape is inside a component, add it to detached-ids. This list is used
;; later to process other copies that was referencing a detached nested copy.
(when is-component?
(vswap! detached-ids conj (:id shape)))
;; Detach the shape and all children until we find a subinstance.
(if (or first? in-copy? (not (ctk/instance-head? shape)))
(as-> container $
(ctn/update-shape $ (:id shape) ctk/detach-shape)
(reduce #(detach-recursive %1 %2 false)
$
(map (d/getf (:objects container)) (:shapes shape))))
;; If this is a subinstance head and the initial shape whas not itself a
;; nested copy, stop detaching and promote it to root.
(ctn/update-shape container (:id shape) #(assoc % :component-root true))))]
(detach-recursive container shape true))))
fix-bad-children
(fn [file-data]
;; Remove any child that does not exist. And also remove duplicated children.
(letfn [(fix-container
[container]
(letfn [(fix-container [container]
(d/update-when container :objects update-vals (partial fix-shape container)))
(fix-shape
[container shape]
(fix-shape [container shape]
(let [objects (:objects container)]
(d/update-when shape :shapes
(fn [shapes]
@ -160,12 +202,10 @@
fix-missing-image-metadata
(fn [file-data]
;; Delete broken image shapes with no metadata.
(letfn [(fix-container
[container]
(letfn [(fix-container [container]
(d/update-when container :objects #(reduce-kv fix-shape % %)))
(fix-shape
[objects id shape]
(fix-shape [objects id shape]
(if (and (cfh/image-shape? shape)
(nil? (:metadata shape)))
(-> objects
@ -189,11 +229,28 @@
(dissoc options :background)
options))
(fix-saved-grids [options]
(d/update-when options :saved-grids
(fn [grids]
(cond-> grids
(and (contains? grids :column)
(not (valid-column-grid-params? (:column grids))))
(dissoc :column)
(and (contains? grids :row)
(not (valid-column-grid-params? (:row grids))))
(dissoc :row)
(and (contains? grids :square)
(not (valid-square-grid-params? (:square grids))))
(dissoc :square)))))
(fix-options [options]
(-> options
;; Some pages has invalid data on flows, we proceed just to
;; delete them.
(d/update-when :flows #(filterv valid-flow? %))
(fix-saved-grids)
(fix-background)))]
(update file-data :pages-index update-vals update-page)))
@ -203,11 +260,19 @@
;; fix that issues.
fix-file-data
(fn [file-data]
(-> file-data
(d/update-when :colors dissoc nil)
(d/update-when :typographies dissoc nil)))
(letfn [(fix-colors-library [colors]
(let [colors (dissoc colors nil)]
(reduce-kv (fn [colors id color]
(if (valid-color? color)
colors
(dissoc colors id)))
colors
colors)))]
(-> file-data
(d/update-when :colors fix-colors-library)
(d/update-when :typographies dissoc nil))))
delete-big-geometry-shapes
fix-big-geometry-shapes
(fn [file-data]
;; At some point in time, we had a bug that generated shapes
;; with huge geometries that did not validate the
@ -253,9 +318,16 @@
(fn [shapes] (filterv #(not= id %) shapes)))))
(and (cfh/text-shape? shape)
(not (seq (:content shape))))
(not (valid-text-content? (:content shape))))
(dissoc objects id)
(and (cfh/path-shape? shape)
(not (valid-path-content? (:content shape))))
(-> objects
(dissoc id)
(d/update-in-when [(:parent-id shape) :shapes]
(fn [shapes] (filterv #(not= id %) shapes))))
:else
objects))
@ -266,25 +338,125 @@
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
fix-misc-shape-issues
fix-shape-geometry
(fn [file-data]
(letfn [(fix-container [container]
(d/update-when container :objects update-vals fix-shape))
(fix-shape [shape]
(cond
(and (cfh/image-shape? shape)
(valid-image-attrs? shape)
(grc/valid-rect? (:selrect shape))
(not (valid-shape-points? (:points shape))))
(let [selrect (:selrect shape)
metadata (:metadata shape)
selrect (grc/make-rect
(:x selrect)
(:y selrect)
(:width metadata)
(:height metadata))
points (grc/rect->points selrect)]
(assoc shape
:selrect selrect
:points points))
(and (cfh/text-shape? shape)
(valid-text-content? (:content shape))
(not (valid-shape-points? (:points shape)))
(seq (:position-data shape)))
(let [selrect (->> (:position-data shape)
(map (juxt :x :y :width :height))
(map #(apply grc/make-rect %))
(grc/join-rects))
points (grc/rect->points selrect)]
(assoc shape
:x (:x selrect)
:y (:y selrect)
:width (:width selrect)
:height (:height selrect)
:selrect selrect
:points points))
(and (or (cfh/rect-shape? shape)
(cfh/svg-raw-shape? shape)
(cfh/circle-shape? shape))
(not (valid-shape-points? (:points shape)))
(grc/valid-rect? (:selrect shape)))
(let [selrect (if (grc/valid-rect? (:svg-viewbox shape))
(:svg-viewbox shape)
(:selrect shape))
points (grc/rect->points selrect)]
(assoc shape
:x (:x selrect)
:y (:y selrect)
:width (:width selrect)
:height (:height selrect)
:selrect selrect
:points points))
(and (= :icon (:type shape))
(grc/valid-rect? (:selrect shape))
(valid-shape-points? (:points shape)))
(-> shape
(assoc :type :rect)
(dissoc :content)
(dissoc :metadata)
(dissoc :segments)
(dissoc :x1 :y1 :x2 :y2))
(and (cfh/group-shape? shape)
(grc/valid-rect? (:selrect shape))
(not (valid-shape-points? (:points shape))))
(assoc shape :points (grc/rect->points (:selrect shape)))
:else
shape))]
(-> file-data
(update :pages-index update-vals fix-container)
(d/update-when :components update-vals fix-container))))
fix-misc-shape-issues
(fn [file-data]
(letfn [(fix-container [container]
(d/update-when container :objects update-vals fix-shape))
(fix-gap-value [gap]
(if (or (= gap ##Inf)
(= gap ##-Inf))
0
gap))
(fix-shape [shape]
(cond-> shape
;; Some shapes has invalid gap value
(contains? shape :layout-gap)
(d/update-in-when [:layout-gap :column-gap]
(fn [gap]
(if (or (= gap ##Inf)
(= gap ##-Inf))
0
gap)))
(update :layout-gap (fn [layout-gap]
(if (number? layout-gap)
{:row-gap layout-gap :column-gap layout-gap}
(-> layout-gap
(d/update-when :column-gap fix-gap-value)
(d/update-when :row-gap fix-gap-value)))))
;; Fix name if missing
(nil? (:name shape))
(assoc :name (d/name (:type shape)))
;; Remove v2 info from components that have been copied and pasted
;; from a v2 file
(some? (:main-instance shape))
(dissoc :main-instance)
(and (contains? shape :transform)
(not (gmt/valid-matrix? (:transform shape))))
(assoc :transform (gmt/matrix))
(and (contains? shape :transform-inverse)
(not (gmt/valid-matrix? (:transform-inverse shape))))
(assoc :transform-inverse (gmt/matrix))
;; Fix broken fills
(seq (:fills shape))
(update :fills (fn [fills] (filterv valid-fill? fills)))
@ -296,11 +468,7 @@
;; Fix some broken layout related attrs, probably
;; of copypaste on flex layout betatest period
(true? (:layout shape))
(assoc :layout :flex)
(number? (:layout-gap shape))
(as-> shape (let [n (:layout-gap shape)]
(assoc shape :layout-gap {:row-gap n :column-gap n})))))]
(assoc :layout :flex)))]
(-> file-data
(update :pages-index update-vals fix-container)
@ -342,13 +510,15 @@
(and (cfh/path-shape? shape)
(seq (:content shape))
(not (valid-path-content? (:content shape))))
(let [shape (update shape :content fix-path-content)
[points selrect] (gshp/content->points+selrect shape (:content shape))]
(-> shape
(dissoc :bool-content)
(dissoc :bool-type)
(assoc :points points)
(assoc :selrect selrect)))
(let [shape (update shape :content fix-path-content)]
(if (not (valid-path-content? (:content shape)))
shape
(let [[points selrect] (gshp/content->points+selrect shape (:content shape))]
(-> shape
(dissoc :bool-content)
(dissoc :bool-type)
(assoc :points points)
(assoc :selrect selrect)))))
;; When we fount a bool shape with no content,
;; we convert it to a simple rect
@ -390,18 +560,16 @@
;; Remove invalid colors in :recent-colors
(d/update-when file-data :recent-colors
(fn [colors]
(filterv valid-color? colors))))
(filterv valid-recent-color? colors))))
fix-broken-parents
(fn [file-data]
;; Find children shapes whose parent-id is not set to the parent that contains them.
;; Remove them from the parent :shapes list.
(letfn [(fix-container
[container]
(letfn [(fix-container [container]
(d/update-when container :objects #(reduce-kv fix-shape % %)))
(fix-shape
[objects id shape]
(fix-shape [objects id shape]
(reduce (fn [objects child-id]
(let [child (get objects child-id)]
(cond-> objects
@ -476,20 +644,33 @@
(fn [file-data]
;; Detach shapes that were inside a copy (have :shape-ref) but now they aren't.
(letfn [(fix-container [container]
(d/update-when container :objects update-vals (partial fix-shape container)))
(reduce fix-shape container (ctn/shapes-seq container)))
(fix-shape [container shape]
(let [parent (ctst/get-shape container (:parent-id shape))]
(let [shape (ctst/get-shape container (:id shape)) ; Get the possibly updated shape
parent (ctst/get-shape container (:parent-id shape))]
(if (and (ctk/in-component-copy? shape)
(not (ctk/instance-head? shape))
(not (ctk/in-component-copy? parent)))
(detach-shape container shape)
shape)))]
container)))]
(-> file-data
(update :pages-index update-vals fix-container)
(d/update-when :components update-vals fix-container))))
fix-components-without-id
(fn [file-data]
;; We have detected some components that have no :id attribute.
;; Regenerate it from the components map.
(letfn [(fix-component [id component]
(if (some? (:id component))
component
(assoc component :id id)))]
(-> file-data
(d/update-when :components #(d/mapm fix-component %)))))
remap-refs
(fn [file-data]
;; Remap shape-refs so that they point to the near main.
@ -523,11 +704,9 @@
(if (some? direct-shape-2)
;; If it exists, there is nothing else to do.
container
;; If not found, detach shape and all children (stopping if a nested instance is reached)
(let [children (ctn/get-children-in-instance (:objects container) (:id shape))]
(reduce #(ctn/update-shape %1 (:id %2) (partial detach-shape %1))
container
children))))))))
;; If not found, detach shape and all children.
;; container
(detach-shape container shape)))))))
container))]
(-> file-data
@ -539,14 +718,64 @@
;; If the user has created a copy and then converted into a path or bool,
;; detach it because the synchronization will no longer work.
(letfn [(fix-container [container]
(d/update-when container :objects update-vals (partial fix-shape container)))
(reduce fix-shape container (ctn/shapes-seq container)))
(fix-shape [container shape]
(if (and (ctk/instance-head? shape)
(or (cfh/path-shape? shape)
(cfh/bool-shape? shape)))
(detach-shape container shape)
shape))]
container))]
(-> file-data
(update :pages-index update-vals fix-container)
(d/update-when :components update-vals fix-container))))
wrap-non-group-component-roots
(fn [file-data]
;; Some components have a root that is not a group nor a frame
;; (e.g. a path or a svg-raw). We need to wrap them in a frame
;; for this one to became the root.
(letfn [(fix-component [component]
(let [root-shape (ctst/get-shape component (:id component))]
(if (or (cfh/group-shape? root-shape)
(cfh/frame-shape? root-shape))
component
(let [new-id (uuid/next)
frame (-> (cts/setup-shape
{:type :frame
:id (:id component)
:x (:x (:selrect root-shape))
:y (:y (:selrect root-shape))
:width (:width (:selrect root-shape))
:height (:height (:selrect root-shape))
:name (:name component)
:shapes [new-id]})
(assoc :frame-id nil
:parent-id nil))
root-shape' (assoc root-shape
:id new-id
:parent-id (:id frame)
:frame-id (:id frame))]
(update component :objects assoc
(:id frame) frame
(:id root-shape') root-shape')))))]
(-> file-data
(d/update-when :components update-vals fix-component))))
detach-non-group-instance-roots
(fn [file-data]
;; If there is a copy instance whose root is not a frame or a group, it cannot
;; be easily repaired, and anyway it's not working in production, so detach it.
(letfn [(fix-container [container]
(reduce fix-shape container (ctn/shapes-seq container)))
(fix-shape [container shape]
(if (and (ctk/instance-head? shape)
(not (#{:group :frame} (:type shape))))
(detach-shape container shape)
container))]
(-> file-data
(update :pages-index update-vals fix-container)
@ -554,7 +783,7 @@
transform-to-frames
(fn [file-data]
;; Transform component and copy heads to frames, and set the
;; Transform component and copy heads fron group to frames, and set the
;; frame-id of its childrens
(letfn [(fix-container [container]
(d/update-when container :objects update-vals fix-shape))
@ -631,9 +860,8 @@
(fn [file-data]
;; Find component heads that are not main-instance but have not :shape-ref.
;; Also shapes that have :shape-ref but are not in a copy.
(letfn [(fix-container
[container]
(d/update-when container :objects update-vals (partial fix-shape container)))
(letfn [(fix-container [container]
(reduce fix-shape container (ctn/shapes-seq container)))
(fix-shape
[container shape]
@ -643,74 +871,79 @@
(and (ctk/in-component-copy? shape)
(nil? (ctn/get-head-shape (:objects container) shape {:allow-main? true}))))
(detach-shape container shape)
shape))]
container))]
(-> file-data
(update :pages-index update-vals fix-container)
(d/update-when :components update-vals fix-container))))
fix-component-root-without-component
(fn [file-data]
;; Ensure that if component-root is set component-file and component-id are set too
(letfn [(fix-container [container]
(d/update-when container :objects update-vals fix-shape))
(fix-shape [shape]
(cond-> shape
(and (ctk/instance-root? shape)
(or (not (ctk/instance-head? shape))
(not (some? (:component-file shape)))))
(dissoc :component-id
:component-file
:component-root)))]
(-> file-data
(update :pages-index update-vals fix-container))))
fix-copies-of-detached
(fn [file-data]
;; Find any copy that is referencing a shape inside a component that have
;; been detached in a previous fix. If so, undo the nested copy, converting
;; it into a direct copy.
;;
;; WARNING: THIS SHOULD BE CALLED AT THE END OF THE PROCESS.
;; Find any copy that is referencing a shape inside a component that have
;; been detached in a previous fix. If so, undo the nested copy, converting
;; it into a direct copy.
;;
;; WARNING: THIS SHOULD BE CALLED AT THE END OF THE PROCESS.
(letfn [(fix-container [container]
(d/update-when container :objects update-vals fix-shape))
(fix-shape [shape]
(cond-> shape
(@detached-ids (:shape-ref shape))
(dissoc shape
:component-id
:component-file
:component-root)))]
(ctk/detach-shape)))]
(-> file-data
(update :pages-index update-vals fix-container)
(d/update-when :components update-vals fix-container))))
fix-shape-nil-parent-id
(fn [file-data]
;; Ensure that parent-id and frame-id are not nil
(letfn [(fix-container [container]
(d/update-when container :objects update-vals fix-shape))
(fix-shape [shape]
(let [frame-id (or (:frame-id shape)
uuid/zero)
parent-id (or (:parent-id shape)
frame-id)]
(assoc shape :frame-id frame-id
:parent-id parent-id)))]
(-> file-data
(update :pages-index update-vals fix-container))))]
(d/update-when :components update-vals fix-container))))]
(-> file-data
(fix-file-data)
(fix-page-invalid-options)
(fix-completly-broken-shapes)
(fix-bad-children)
(fix-misc-shape-issues)
(fix-recent-colors)
(fix-missing-image-metadata)
(fix-text-shapes-converted-to-path)
(fix-broken-paths)
(delete-big-geometry-shapes)
(fix-big-geometry-shapes)
(fix-shape-geometry)
(fix-completly-broken-shapes)
(fix-bad-children)
(fix-broken-parents)
(fix-orphan-shapes)
(fix-orphan-copies)
(remove-nested-roots)
(add-not-nested-roots)
(fix-components-without-id)
(remap-refs)
(fix-converted-copies)
(wrap-non-group-component-roots)
(detach-non-group-instance-roots)
(transform-to-frames)
(remap-frame-ids)
(fix-frame-ids)
(fix-component-nil-objects)
(fix-false-copies)
(fix-shape-nil-parent-id)
(fix-copies-of-detached)))) ; <- Do not add fixes after this one
(fix-component-root-without-component)
(fix-copies-of-detached); <- Do not add fixes after this and fix-orphan-copies call
; This extra call to fix-orphan-copies after fix-copies-of-detached because we can have detached subtrees with invalid shape-ref attributes
(fix-orphan-copies))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; COMPONENTS MIGRATION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

20
backend/src/app/http/debug.clj
View file

@ -100,11 +100,11 @@
(let [profile (profile/get-profile pool profile-id)
project-id (:default-project-id profile)]
(db/run! pool (fn [{:keys [::db/conn]}]
(create-file conn {:id file-id
:name (str "Cloned file: " filename)
:project-id project-id
:profile-id profile-id})
(db/run! pool (fn [{:keys [::db/conn] :as cfg}]
(create-file cfg {:id file-id
:name (str "Cloned file: " filename)
:project-id project-id
:profile-id profile-id})
(db/update! conn :file
{:data data}
{:id file-id})
@ -141,11 +141,11 @@
{::rres/status 200
::rres/body "OK UPDATED"})
(db/run! pool (fn [{:keys [::db/conn]}]
(create-file conn {:id file-id
:name fname
:project-id project-id
:profile-id profile-id})
(db/run! pool (fn [{:keys [::db/conn] :as cfg}]
(create-file cfg {:id file-id
:name fname
:project-id project-id
:profile-id profile-id})
(db/update! conn :file
{:data data}
{:id file-id})

16
backend/src/app/rpc/commands/binfile.clj
View file

@ -8,6 +8,7 @@
(:refer-clojure :exclude [assert])
(:require
[app.binfile.v1 :as bf.v1]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.db :as db]
[app.http.sse :as sse]
@ -50,11 +51,16 @@
::rres/headers {"content-type" "application/octet-stream"}
::rres/body (reify rres/StreamableResponseBody
(-write-body-to-stream [_ _ output-stream]
(-> cfg
(assoc ::bf.v1/ids #{file-id})
(assoc ::bf.v1/embed-assets embed-assets)
(assoc ::bf.v1/include-libraries include-libraries)
(bf.v1/export-files! output-stream))))}))
(try
(-> cfg
(assoc ::bf.v1/ids #{file-id})
(assoc ::bf.v1/embed-assets embed-assets)
(assoc ::bf.v1/include-libraries include-libraries)
(bf.v1/export-files! output-stream))
(catch Throwable cause
(l/err :hint "exception on exporting file"
:file-id (str file-id)
:cause cause)))))}))
;; --- Command: import-binfile

56
backend/src/app/srepl/components_v2.clj
View file

@ -188,17 +188,27 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn migrate-file!
[file-id & {:keys [rollback? validate? label] :or {rollback? true validate? false}}]
[file-id & {:keys [rollback? validate? label cache skip-on-graphic-error?]
:or {rollback? true
validate? false
skip-on-graphic-error? true}}]
(l/dbg :hint "migrate:start" :rollback rollback?)
(let [tpoint (dt/tpoint)
(let [tpoint (dt/tpoint)
file-id (if (string? file-id)
(parse-uuid file-id)
file-id)]
(binding [feat/*stats* (atom {})]
file-id)
cache (if (int? cache)
(cache/create :executor (::wrk/executor main/system)
:max-items cache)
nil)]
(binding [feat/*stats* (atom {})
feat/*cache* cache]
(try
(-> (assoc main/system ::db/rollback rollback?)
(feat/migrate-file! file-id
:validate? validate?
:skip-on-graphic-error? skip-on-graphic-error?
:label label))
(-> (deref feat/*stats*)
@ -212,22 +222,28 @@
(l/dbg :hint "migrate:end" :rollback rollback? :elapsed elapsed)))))))
(defn migrate-team!
[team-id & {:keys [rollback? skip-on-graphic-error? validate? label]
[team-id & {:keys [rollback? skip-on-graphic-error? validate? label cache]
:or {rollback? true
validate? true
skip-on-graphic-error? false}}]
skip-on-graphic-error? true}}]
(l/dbg :hint "migrate:start" :rollback rollback?)
(let [team-id (if (string? team-id)
(parse-uuid team-id)
team-id)
stats (atom {})
tpoint (dt/tpoint)]
(let [team-id (if (string? team-id)
(parse-uuid team-id)
team-id)
stats (atom {})
tpoint (dt/tpoint)
cache (if (int? cache)
(cache/create :executor (::wrk/executor main/system)
:max-items cache)
nil)]
(add-watch stats :progress-report (report-progress-files tpoint))
(binding [feat/*stats* stats]
(binding [feat/*stats* stats
feat/*cache* cache]
(try
(-> (assoc main/system ::db/rollback rollback?)
(feat/migrate-team! team-id
@ -286,7 +302,7 @@
sprocs (ps/create :permits max-procs)
cache (if (int? cache)
(cache/create :executor executor
(cache/create :executor (::wrk/executor main/system)
:max-items cache)
nil)
migrate-team
@ -382,3 +398,17 @@
(l/dbg :hint "migrate:end"
:rollback rollback?
:elapsed elapsed)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FILE PROCESS HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn delete-broken-files
[{:keys [id data] :as file}]
(if (-> data :options :components-v2 true?)
(do
(l/wrn :hint "found old components-v2 format"
:file-id (str id)
:file-name (:name file))
(assoc file :deleted-at (dt/now)))
file))

40
backend/src/app/srepl/helpers.clj
View file

@ -258,8 +258,11 @@
max-jobs
start-at
on-file
validate?
rollback?]
:or {max-jobs 1
max-items Long/MAX_VALUE
validate? true
rollback? true}}]
(l/dbg :hint "process:start"
@ -273,19 +276,19 @@
sjobs (ps/create :permits max-jobs)
process-file
(fn [file-id tpoint]
(fn [file-id idx tpoint]
(try
(l/trc :hint "process:file:start" :file-id (str file-id))
(l/trc :hint "process:file:start" :file-id (str file-id) :index idx)
(db/tx-run! (assoc main/system ::db/rollback rollback?)
(fn [{:keys [::db/conn] :as system}]
(let [file' (get-file* system file-id)
file (binding [*system* system]
(on-file file'))]
(when (and (some? file)
(not (identical? file file')))
(when (and (some? file) (not (identical? file file')))
(cfv/validate-file-schema! file)
(when validate?
(cfv/validate-file-schema! file))
(let [file (if (contains? (:features file) "fdata/objects-map")
(feat.fdata/enable-objects-map file)
@ -300,36 +303,43 @@
(db/update! conn :file
{:data (blob/encode (:data file))
:deleted-at (:deleted-at file)
:created-at (:created-at file)
:modified-at (:modified-at file)
:features (db/create-array conn "text" (:features file))
:revn (:revn file)}
{:id file-id}))))))
(catch Throwable cause
(l/wrn :hint "unexpected error on processing file (skiping)"
:file-id (str file-id)
:index idx
:cause cause))
(finally
(ps/release! sjobs)
(let [elapsed (dt/format-duration (tpoint))]
(l/trc :hint "process:file:end"
:file-id (str file-id)
:index idx
:elapsed elapsed)))))]
(try
(db/tx-run! main/system
(fn [{:keys [::db/conn] :as system}]
(db/exec! conn ["SET statement_timeout = 0"])
(db/exec! conn ["SET idle_in_transaction_session_timeout = 0"])
(run! (fn [file-id]
(ps/acquire! sjobs)
(px/run! executor (partial process-file file-id (dt/tpoint))))
(->> (db/cursor conn [sql:get-file-ids (or start-at (dt/now))])
(take max-items)
(map :id)))
;; Close and await tasks
(pu/close! executor)))
(try
(reduce (fn [idx file-id]
(ps/acquire! sjobs)
(px/run! executor (partial process-file file-id idx (dt/tpoint)))
(inc idx))
0
(->> (db/cursor conn [sql:get-file-ids (or start-at (dt/now))])
(take max-items)
(map :id)))
(finally
;; Close and await tasks
(pu/close! executor)))))
(catch Throwable cause
(l/dbg :hint "process:error" :cause cause))

15
common/src/app/common/data.cljc
View file

@ -57,6 +57,14 @@
#?(:cljs (instance? lkm/LinkedMap o)
:clj (instance? LinkedMap o)))
(defn vec2
"Creates a optimized vector compatible type of length 2 backed
internally with MapEntry impl because it has faster access method
for its fields."
[o1 o2]
#?(:clj (clojure.lang.MapEntry. o1 o2)
:cljs (cljs.core/->MapEntry o1 o2 nil)))
#?(:clj
(defmethod print-method clojure.lang.PersistentQueue [q, w]
;; Overload the printer for queues so they look like fish
@ -308,9 +316,12 @@
(defn mapm
"Map over the values of a map"
([mfn]
(map (fn [[key val]] [key (mfn key val)])))
(map (fn [[key val]] (vec2 key (mfn key val)))))
([mfn coll]
(into {} (mapm mfn) coll)))
(reduce-kv (fn [coll k v]
(assoc coll k (mfn k v)))
coll
coll)))
(defn removev
"Returns a vector of the items in coll for which (fn item) returns logical false"

36
common/src/app/common/debug.clj Normal file
View file

@ -0,0 +1,36 @@
;; 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.common.debug
(:require
[app.common.logging :as l]
[app.common.pprint :as pp]))
(defn pprint
[expr]
(l/raw! :debug
(binding [*print-level* pp/default-level
*print-length* pp/default-length]
(with-out-str
(println "tap dbg:")
(pp/pprint expr {:max-width pp/default-width})))))
(def store (atom {}))
(defn get-stored
[]
(deref store))
(defn tap-handler
[v]
(if (and (vector? v)
(keyword (first v)))
(let [[command obj] v]
(case command
(:print :prn :pprint) (pprint obj)
:store (reset! store obj)))
(pprint v)))

2
common/src/app/common/files/defaults.cljc
View file

@ -6,4 +6,4 @@
(ns app.common.files.defaults)
(def version 44)
(def version 46)

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

@ -484,7 +484,7 @@
(letfn [(red-fn [cur-idx id]
(let [[prev-idx _] (first cur-idx)
prev-idx (or prev-idx 0)
cur-idx (conj cur-idx [(inc prev-idx) id])]
cur-idx (conj cur-idx (d/vec2 (inc prev-idx) id))]
(rec-index cur-idx id)))
(rec-index [cur-idx id]
(let [object (get objects id)]
@ -509,10 +509,11 @@
(defn order-by-indexed-shapes
[objects ids]
(->> (indexed-shapes objects)
(sort-by first)
(filter (comp (into #{} ids) second))
(map second)))
(let [ids (if (set? ids) ids (set ids))]
(->> (indexed-shapes objects)
(filter (fn [o] (contains? ids (val o))))
(sort-by key)
(map val))))
(defn get-index-replacement
"Given a collection of shapes, calculate their positions

67
common/src/app/common/files/libraries_helpers.cljc
View file

@ -6,6 +6,7 @@
(ns app.common.files.libraries-helpers
(:require
[app.common.data :as d]
[app.common.files.changes-builder :as pcb]
[app.common.files.helpers :as cfh]
[app.common.types.component :as ctk]
@ -37,41 +38,50 @@
use it as root. Otherwise, create a frame (v2) or group (v1) that contains all ids. Then, make a
component with it, and link all shapes to their corresponding one in the component."
[it shapes objects page-id file-id components-v2 prepare-create-group prepare-create-board]
(let [changes (pcb/empty-changes it page-id)
from-singe-frame? (and (= 1 (count shapes)) (-> shapes first cfh/frame-shape?))
(let [changes (pcb/empty-changes it page-id)
shapes-count (count shapes)
first-shape (first shapes)
from-singe-frame?
(and (= 1 shapes-count)
(cfh/frame-shape? first-shape))
[root changes old-root-ids]
(if (and (= (count shapes) 1)
(or (and (= (:type (first shapes)) :group) (not components-v2))
(= (:type (first shapes)) :frame))
(not (ctk/instance-head? (first shapes))))
[(first shapes)
(if (and (= shapes-count 1)
(or (and (cfh/group-shape? first-shape)
(not components-v2))
(cfh/frame-shape? first-shape))
(not (ctk/instance-head? first-shape)))
[first-shape
(-> (pcb/empty-changes it page-id)
(pcb/with-objects objects))
(:shapes (first shapes))]
(:shapes first-shape)]
(let [root-name (if (= 1 (count shapes))
(:name (first shapes))
(let [root-name (if (= 1 shapes-count)
(:name first-shape)
"Component 1")
[root changes] (if-not components-v2
(prepare-create-group it ; These functions needs to be passed as argument
objects ; to avoid a circular dependence
page-id
shapes
root-name
(not (ctk/instance-head? (first shapes))))
(prepare-create-board changes
(uuid/next)
(:parent-id (first shapes))
objects
(map :id shapes)
nil
root-name
true))]
shape-ids (into (d/ordered-set) (map :id) shapes)
[root changes (map :id shapes)]))
[root changes]
(if-not components-v2
(prepare-create-group it ; These functions needs to be passed as argument
objects ; to avoid a circular dependence
page-id
shapes
root-name
(not (ctk/instance-head? first-shape)))
(prepare-create-board changes
(uuid/next)
(:parent-id first-shape)
objects
shape-ids
nil
root-name
true))]
[root changes shape-ids]))
changes
(cond-> changes
@ -79,8 +89,7 @@
(pcb/update-shapes
(:shapes root)
(fn [shape]
(-> shape
(assoc :constraints-h :scale :constraints-v :scale)))))
(assoc shape :constraints-h :scale :constraints-v :scale))))
objects' (assoc objects (:id root) root)

43
common/src/app/common/files/migrations.cljc
View file

@ -109,11 +109,14 @@
(assoc :points (grc/rect->points selrect))))))
(fix-empty-points [shape]
(let [shape (cond-> shape
(empty? (:selrect shape)) (cts/setup-rect))]
(cond-> shape
(empty? (:points shape))
(assoc :points (grc/rect->points (:selrect shape))))))
(if (empty? (:points shape))
(-> shape
(update :selrect (fn [selrect]
(if (map? selrect)
(grc/make-rect selrect)
selrect)))
(cts/setup-shape))
shape))
(update-object [object]
(cond-> object
@ -620,6 +623,10 @@
(-> object
(assoc :parent-id uuid/zero)
(assoc :frame-id uuid/zero)
;; We explicitly dissoc them and let the shape-setup
;; to regenerate it with valid values.
(dissoc :selrect)
(dissoc :points)
(cts/setup-shape))
object))
@ -843,3 +850,29 @@
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
(defmethod migrate 45
[data]
(letfn [(fix-shape [shape]
(let [frame-id (or (:frame-id shape)
uuid/zero)
parent-id (or (:parent-id shape)
frame-id)]
(assoc shape :frame-id frame-id
:parent-id parent-id)))
(update-container [container]
(d/update-when container :objects update-vals fix-shape))]
(-> data
(update :pages-index update-vals update-container))))
(defmethod migrate 46
[data]
(letfn [(update-object [object]
(dissoc object :thumbnail))
(update-container [container]
(d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))

165
common/src/app/common/files/shapes_helpers.cljc
View file

@ -39,16 +39,17 @@
(defn prepare-move-shapes-into-frame
[changes frame-id shapes objects]
(let [ordered-indexes (cfh/order-by-indexed-shapes objects shapes)
parent-id (get-in objects [frame-id :parent-id])
ordered-indexes (->> ordered-indexes (remove #(= % parent-id)))
to-move-shapes (map (d/getf objects) ordered-indexes)]
(if (d/not-empty? to-move-shapes)
(let [parent-id (dm/get-in objects [frame-id :parent-id])
shapes (remove #(= % parent-id) shapes)
to-move (->> shapes
(map (d/getf objects))
(not-empty))]
(if to-move
(-> changes
(cond-> (not (ctl/any-layout? objects frame-id))
(pcb/update-shapes ordered-indexes ctl/remove-layout-item-data))
(pcb/update-shapes ordered-indexes #(cond-> % (cfh/frame-shape? %) (assoc :hide-in-viewer true)))
(pcb/change-parent frame-id to-move-shapes 0)
(pcb/update-shapes shapes ctl/remove-layout-item-data))
(pcb/update-shapes shapes #(cond-> % (cfh/frame-shape? %) (assoc :hide-in-viewer true)))
(pcb/change-parent frame-id to-move 0)
(cond-> (ctl/grid-layout? objects frame-id)
(-> (pcb/update-shapes [frame-id] ctl/assign-cells {:with-objects? true})
(pcb/reorder-grid-children [frame-id]))))
@ -60,90 +61,102 @@
changes id parent-id objects selected index frame-name without-fill? nil))
([changes id parent-id objects selected index frame-name without-fill? target-cell-id]
(let [selected-objs (map #(get objects %) selected)
new-index (or index
(cfh/get-index-replacement selected objects))]
(when (d/not-empty? selected)
(let [srect (gsh/shapes->rect selected-objs)
selected-id (first selected)
(when-let [selected-objs (->> selected
(map (d/getf objects))
(not-empty))]
frame-id (dm/get-in objects [selected-id :frame-id])
parent-id (or parent-id (dm/get-in objects [selected-id :parent-id]))
base-parent (get objects parent-id)
(let [;; We calculate here the ordered selection because it is used
;; multiple times and this avoid the need of creating the index
;; manytimes for single operation.
selected' (cfh/order-by-indexed-shapes objects selected)
new-index (or index
(->> (first selected')
(cfh/get-position-on-parent objects)
(inc)))
layout-props
(when (and (= 1 (count selected))
(ctl/any-layout? base-parent))
(let [shape (get objects selected-id)]
(select-keys shape ctl/layout-item-props)))
srect (gsh/shapes->rect selected-objs)
selected-id (first selected)
selected-obj (get objects selected-id)
target-cell-id
(if (and (nil? target-cell-id)
(ctl/grid-layout? objects parent-id))
;; Find the top-left grid cell of the selected elements
(let [ncols (count (:layout-grid-columns base-parent))]
(->> selected
(map #(ctl/get-cell-by-shape-id base-parent %))
(apply min-key (fn [{:keys [row column]}] (+ (* ncols row) column)))
:id))
target-cell-id)
frame-id (get selected-obj :frame-id)
parent-id (or parent-id (get selected-obj :parent-id))
base-parent (get objects parent-id)
attrs {:type :frame
:x (:x srect)
:y (:y srect)
:width (:width srect)
:height (:height srect)}
layout-props
(when (and (= 1 (count selected))
(ctl/any-layout? base-parent))
(select-keys selected-obj ctl/layout-item-props))
shape (cts/setup-shape
(cond-> attrs
(some? id)
(assoc :id id)
target-cell-id
(if (and (nil? target-cell-id)
(ctl/grid-layout? objects parent-id))
;; Find the top-left grid cell of the selected elements
(let [ncols (count (:layout-grid-columns base-parent))]
(->> selected
(map #(ctl/get-cell-by-shape-id base-parent %))
(apply min-key (fn [{:keys [row column]}] (+ (* ncols row) column)))
:id))
target-cell-id)
(some? frame-name)
(assoc :name frame-name)
attrs
{:type :frame
:x (:x srect)
:y (:y srect)
:width (:width srect)
:height (:height srect)}
:always
(assoc :frame-id frame-id
:parent-id parent-id
:shapes (into [] selected))
shape
(cts/setup-shape
(cond-> attrs
(some? id)
(assoc :id id)
(some? layout-props)
(d/patch-object layout-props)
(some? frame-name)
(assoc :name frame-name)
(or (not= frame-id uuid/zero) without-fill?)
(assoc :fills [] :hide-in-viewer true)))
:always
(assoc :frame-id frame-id
:parent-id parent-id
:shapes (into [] selected))
shape (with-meta shape {:index new-index})
(some? layout-props)
(d/patch-object layout-props)
[shape changes]
(prepare-add-shape changes shape objects)
(or (not= frame-id uuid/zero) without-fill?)
(assoc :fills [] :hide-in-viewer true)))
changes
(prepare-move-shapes-into-frame changes (:id shape) selected objects)
shape
(with-meta shape {:index new-index})
changes
(cond-> changes
(ctl/grid-layout? objects (:parent-id shape))
(-> (pcb/update-shapes
[(:parent-id shape)]
(fn [parent objects]
;; This restores the grid layout before adding and moving the shapes
;; this is done because the add+move could have altered the layout and we
;; want to do it after both operations are completed. Also here we could
;; asign the new element to a target-cell
(-> parent
(assoc :layout-grid-cells (:layout-grid-cells base-parent))
(assoc :layout-grid-rows (:layout-grid-rows base-parent))
(assoc :layout-grid-columns (:layout-grid-columns base-parent))
[shape changes]
(prepare-add-shape changes shape objects)
(cond-> (some? target-cell-id)
(assoc-in [:layout-grid-cells target-cell-id :shapes] [(:id shape)]))
(ctl/assign-cells objects)))
{:with-objects? true})
changes
(prepare-move-shapes-into-frame changes (:id shape) selected' objects)
(pcb/reorder-grid-children [(:parent-id shape)])))]
changes
(cond-> changes
(ctl/grid-layout? objects (:parent-id shape))
(-> (pcb/update-shapes
[(:parent-id shape)]
(fn [parent objects]
;; This restores the grid layout before adding and moving the shapes
;; this is done because the add+move could have altered the layout and we
;; want to do it after both operations are completed. Also here we could
;; asign the new element to a target-cell
(-> parent
(assoc :layout-grid-cells (:layout-grid-cells base-parent))
(assoc :layout-grid-rows (:layout-grid-rows base-parent))
(assoc :layout-grid-columns (:layout-grid-columns base-parent))
[shape changes])))))
(cond-> (some? target-cell-id)
(assoc-in [:layout-grid-cells target-cell-id :shapes] [(:id shape)]))
(ctl/assign-cells objects)))
{:with-objects? true})
(pcb/reorder-grid-children [(:parent-id shape)])))]
[shape changes]))))
(defn prepare-create-empty-artboard

86
common/src/app/common/files/validate.cljc
View file

@ -98,7 +98,8 @@
(defn- check-geometry
"Validate that the shape has valid coordinates, selrect and points."
[shape file page]
(when (and (not (#{:path :bool} (:type shape)))
(when (and (not (or (cfh/path-shape? shape)
(cfh/bool-shape? shape)))
(or (nil? (:x shape)) ; This may occur in root shape (uuid/zero) in old files
(nil? (:y shape))
(nil? (:width shape))
@ -112,61 +113,64 @@
(defn- check-parent-children
"Validate parent and children exists, and the link is bidirectional."
[shape file page]
(let [parent (ctst/get-shape page (:parent-id shape))]
(let [parent (ctst/get-shape page (:parent-id shape))
shape-id (:id shape)
shapes (:shapes shape)]
(if (nil? parent)
(report-error :parent-not-found
(str/ffmt "Parent % not found" (:parent-id shape))
shape file page)
(do
(when-not (cfh/root? shape)
(when-not (some #{(:id shape)} (:shapes parent))
(when-not (some #(= shape-id %) (:shapes parent))
(report-error :child-not-in-parent
(str/ffmt "Shape % not in parent's children list" (:id shape))
(str/ffmt "Shape % not in parent's children list" shape-id)
shape file page)))
(when-not (= (count (:shapes shape)) (count (distinct (:shapes shape))))
(when-not (= (count shapes) (count (distinct shapes)))
(report-error :duplicated-children
(str/ffmt "Shape % has duplicated children" (:id shape))
(str/ffmt "Shape % has duplicated children" shape-id)
shape file page))
(doseq [child-id (:shapes shape)]
(doseq [child-id shapes]
(let [child (ctst/get-shape page child-id)]
(if (nil? child)
(report-error :child-not-found
(str/ffmt "Child % not found in parent %" child-id (:id shape))
(str/ffmt "Child % not found in parent %" child-id shape-id)
shape file page
:parent-id (:id shape)
:parent-id shape-id
:child-id child-id)
(when (not= (:parent-id child) (:id shape))
(when (not= (:parent-id child) shape-id)
(report-error :invalid-parent
(str/ffmt "Child % has invalid parent %" child-id (:id shape))
(str/ffmt "Child % has invalid parent %" child-id shape-id)
child file page
:parent-id (:id shape))))))))))
:parent-id shape-id)))))))))
(defn- check-frame
"Validate that the frame-id shape exists and is indeed a frame. Also
it must point to the parent shape (if this is a frame) or to the
frame-id of the parent (if not)."
[shape file page]
(let [frame (ctst/get-shape page (:frame-id shape))]
[{:keys [frame-id] :as shape} file page]
(let [frame (ctst/get-shape page frame-id)]
(if (nil? frame)
(report-error :frame-not-found
(str/ffmt "Frame % not found" (:frame-id shape))
(str/ffmt "Frame % not found" frame-id)
shape file page)
(if (not= (:type frame) :frame)
(report-error :invalid-frame
(str/ffmt "Frame % is not actually a frame" (:frame-id shape))
(str/ffmt "Frame % is not actually a frame" frame-id)
shape file page)
(let [parent (ctst/get-shape page (:parent-id shape))]
(when (some? parent)
(if (= (:type parent) :frame)
(when-not (= (:frame-id shape) (:id parent))
(when-not (= frame-id (:id parent))
(report-error :invalid-frame
(str/ffmt "Frame-id should point to parent %" (:id parent))
shape file page))
(when-not (= (:frame-id shape) (:frame-id parent))
(when-not (= frame-id (:frame-id parent))
(report-error :invalid-frame
(str/ffmt "Frame-id should point to parent frame %" (:frame-id parent))
(str/ffmt "Frame-id should point to parent frame %" frame-id)
shape file page)))))))))
(defn- check-component-main-head
@ -289,8 +293,7 @@
(check-component-main-head shape file page libraries)
(check-component-root shape file page)
(check-component-not-ref shape file page)
(doseq [child-id (:shapes shape)]
(check-shape child-id file page libraries :context :main-top)))
(run! #(check-shape % file page libraries :context :main-top) (:shapes shape)))
(defn- check-shape-main-root-nested
"Root shape of a nested main instance
@ -301,8 +304,7 @@
(check-component-main-head shape file page libraries)
(check-component-not-root shape file page)
(check-component-not-ref shape file page)
(doseq [child-id (:shapes shape)]
(check-shape child-id file page libraries :context :main-nested)))
(run! #(check-shape % file page libraries :context :main-nested) (:shapes shape)))
(defn- check-shape-copy-root-top
"Root shape of a top copy instance
@ -314,8 +316,7 @@
(check-component-not-main-head shape file page libraries)
(check-component-root shape file page)
(check-component-ref shape file page libraries)
(doseq [child-id (:shapes shape)]
(check-shape child-id file page libraries :context :copy-top)))
(run! #(check-shape % file page libraries :context :copy-top) (:shapes shape)))
(defn- check-shape-copy-root-nested
"Root shape of a nested copy instance
@ -326,8 +327,7 @@
(check-component-not-main-head shape file page libraries)
(check-component-not-root shape file page)
(check-component-ref shape file page libraries)
(doseq [child-id (:shapes shape)]
(check-shape child-id file page libraries :context :copy-nested)))
(run! #(check-shape % file page libraries :context :copy-nested) (:shapes shape)))
(defn- check-shape-main-not-root
"Not-root shape of a main instance (not any attribute)"
@ -335,8 +335,7 @@
(check-component-not-main-not-head shape file page)
(check-component-not-root shape file page)
(check-component-not-ref shape file page)
(doseq [child-id (:shapes shape)]
(check-shape child-id file page libraries :context :main-any)))
(run! #(check-shape % file page libraries :context :main-any) (:shapes shape)))
(defn- check-shape-copy-not-root
"Not-root shape of a copy instance :shape-ref"
@ -344,8 +343,7 @@
(check-component-not-main-not-head shape file page)
(check-component-not-root shape file page)
(check-component-ref shape file page libraries)
(doseq [child-id (:shapes shape)]
(check-shape child-id file page libraries :context :copy-any)))
(run! #(check-shape % file page libraries :context :copy-any) (:shapes shape)))
(defn- check-shape-not-component
"Shape is not in a component or is a fostered children (not any
@ -354,8 +352,7 @@
(check-component-not-main-not-head shape file page)
(check-component-not-root shape file page)
(check-component-not-ref shape file page)
(doseq [child-id (:shapes shape)]
(check-shape child-id file page libraries :context :not-component)))
(run! #(check-shape % file page libraries :context :not-component) (:shapes shape)))
(defn- check-shape
"Validate referential integrity and semantic coherence of
@ -439,6 +436,11 @@
"Objects list cannot be nil"
component file nil)))
(defn- get-orphan-shapes
[{:keys [objects] :as page}]
(let [xf (comp (map #(contains? objects (:parent-id %)))
(map :id))]
(into [] xf (vals objects))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC API: VALIDATION FUNCTIONS
@ -451,18 +453,14 @@
[{:keys [data features] :as file} libraries]
(when (contains? features "components/v2")
(binding [*errors* (volatile! [])]
(doseq [page (filter :id (ctpl/pages-seq data))]
(let [orphans (->> page
:objects
vals
(filter #(not (contains? (:objects page) (:parent-id %))))
(map :id))]
(check-shape uuid/zero file page libraries)
(doseq [shape-id orphans]
(check-shape shape-id file page libraries))))
(doseq [component (vals (:components data))]
(check-component component file))
(doseq [page (filter :id (ctpl/pages-seq data))]
(check-shape uuid/zero file page libraries)
(->> (get-orphan-shapes page)
(run! #(check-shape % file page libraries))))
(->> (vals (:components data))
(run! #(check-component % file)))
(-> *errors* deref not-empty))))

13
common/src/app/common/geom/matrix.cljc
View file

@ -67,7 +67,8 @@
([a b c d e f]
(pos->Matrix a b c d e f)))
(def number-regex #"[+-]?\d*(\.\d+)?(e[+-]?\d+)?")
(def number-regex
#"[+-]?\d*(\.\d+)?([eE][+-]?\d+)?")
(defn str->matrix
[matrix-str]
@ -76,8 +77,8 @@
(map (comp d/parse-double first)))]
(apply matrix params)))
(sm/def! ::matrix-map
[:map {:title "MatrixMap"}
(def ^:private schema:matrix-attrs
[:map {:title "MatrixAttrs"}
[:a ::sm/safe-double]
[:b ::sm/safe-double]
[:c ::sm/safe-double]
@ -85,6 +86,10 @@
[:e ::sm/safe-double]
[:f ::sm/safe-double]])
(def valid-matrix?
(sm/lazy-validator
[:and [:fn matrix?] schema:matrix-attrs]))
(sm/def! ::matrix
(letfn [(decode [o]
(if (map? o)
@ -101,7 +106,7 @@
(dm/get-prop o :f) ","))]
{:type ::matrix
:pred matrix?
:pred valid-matrix?
:type-properties
{:title "matrix"
:description "Matrix instance"

18
common/src/app/common/geom/point.cljc
View file

@ -41,12 +41,6 @@
[v]
(instance? Point v))
(sm/def! ::point-map
[:map {:title "PointMap"}
[:x ::sm/safe-number]
[:y ::sm/safe-number]])
;; FIXME: deprecated
(s/def ::x ::us/safe-number)
(s/def ::y ::us/safe-number)
@ -57,6 +51,16 @@
(s/def ::point
(s/and ::point-attrs point?))
(def ^:private schema:point-attrs
[:map {:title "PointAttrs"}
[:x ::sm/safe-number]
[:y ::sm/safe-number]])
(def valid-point?
(sm/lazy-validator
[:and [:fn point?] schema:point-attrs]))
(sm/def! ::point
(letfn [(decode [p]
(if (map? p)
@ -71,7 +75,7 @@
(dm/get-prop p :y)))]
{:type ::point
:pred point?
:pred valid-point?
:type-properties
{:title "point"
:description "Point"

27
common/src/app/common/geom/rect.cljc
View file

@ -12,6 +12,8 @@
[app.common.geom.point :as gpt]
[app.common.math :as mth]
[app.common.record :as rc]
[app.common.schema :as sm]
[app.common.schema.generators :as sg]
[app.common.transit :as t]))
(rc/defrecord Rect [x y width height x1 y1 x2 y2])
@ -66,6 +68,31 @@
h (mth/max height 0.01)]
(pos->Rect x y w h x y (+ x w) (+ y h))))))
(def ^:private schema:rect-attrs
[:map {:title "RectAttrs"}
[:x ::sm/safe-number]
[:y ::sm/safe-number]
[:width ::sm/safe-number]
[:height ::sm/safe-number]
[:x1 ::sm/safe-number]
[:y1 ::sm/safe-number]
[:x2 ::sm/safe-number]
[:y2 ::sm/safe-number]])
(sm/define! ::rect
[:and
{:gen/gen (->> (sg/tuple (sg/small-double)
(sg/small-double)
(sg/small-double)
(sg/small-double))
(sg/fmap #(apply make-rect %)))}
[:fn rect?]
schema:rect-attrs])
(def valid-rect?
(sm/lazy-validator
[:and [:fn rect?] schema:rect-attrs]))
(def empty-rect
(make-rect 0 0 0.01 0.01))

19
common/src/app/common/pprint.cljc
View file

@ -9,9 +9,26 @@
(:require
[me.flowthing.pp :as pp]))
(def default-level 8)
(def default-length 25)
(def default-width 120)
#?(:clj
(defn set-defaults
[& {:keys [level width length]}]
(when length
(alter-var-root #'default-length (constantly length)))
(when width
(alter-var-root #'default-width (constantly width)))
(when level
(alter-var-root #'default-level (constantly level)))
nil))
(defn pprint
[expr & {:keys [width level length]
:or {width 120 level 8 length 25}}]
:or {width default-width
level default-level
length default-length}}]
(binding [*print-level* level
*print-length* length]
(pp/pprint expr {:max-width width})))

39
common/src/app/common/svg.cljc
View file

@ -895,9 +895,10 @@
(defn map-nodes [mapfn node]
(let [update-content
(fn [content] (cond->> content
(vector? content)
(mapv (partial map-nodes mapfn))))]
(fn [content]
(cond->> content
(vector? content)
(mapv (partial map-nodes mapfn))))]
(cond-> node
(map? node)
@ -922,7 +923,8 @@
value)))
(defn fix-default-values
"Gives values to some SVG elements which defaults won't work when imported into the platform"
"Gives values to some SVG elements which defaults won't work when
imported into the platform"
[svg-data]
(let [add-defaults
(fn [{:keys [tag attrs] :as node}]
@ -984,29 +986,38 @@
(fix-percent-attrs-viewbox [attrs]
(d/mapm fix-percent-attr-viewbox attrs))
(fix-percent-attr-numeric [_ attr-val]
(let [is-percent? (str/ends-with? attr-val "%")]
(if is-percent?
(str (let [attr-num (d/parse-double (str/rtrim attr-val "%"))]
(/ attr-num 100)))
attr-val)))
(fix-percent-attr-numeric-val [val]
(let [val (d/parse-double (str/rtrim val "%"))]
(str (/ val 100))))
(fix-percent-attrs-numeric [attrs]
(d/mapm fix-percent-attr-numeric attrs))
(fix-percent-attr-numeric [attrs key val]
(cond
(= key :style)
attrs
(str/starts-with? (d/name key) "data-")
attrs
(str/ends-with? val "%")
(assoc attrs key (fix-percent-attr-numeric-val val))
:else
attrs))
(fix-percent-values [node]
(let [units (or (get-in node [:attrs :filterUnits])
(get-in node [:attrs :gradientUnits])
(get-in node [:attrs :patternUnits])
(get-in node [:attrs :clipUnits]))]
(cond-> node
(or (= "objectBoundingBox" units) (nil? units))
(update :attrs fix-percent-attrs-numeric)
(update :attrs #(reduce-kv fix-percent-attr-numeric % %))
(not= "objectBoundingBox" units)
(update :attrs fix-percent-attrs-viewbox))))]
(->> svg-data (map-nodes fix-percent-values)))))
(map-nodes fix-percent-values svg-data))))
(defn collect-images [svg-data]
(let [redfn (fn [acc {:keys [tag attrs]}]

5
common/src/app/common/svg/shapes_builder.cljc
View file

@ -193,7 +193,8 @@
(defn create-group
[name frame-id {:keys [x y width height offset-x offset-y] :as svg-data} {:keys [attrs]}]
(let [transform (csvg/parse-transform (:transform attrs))
attrs (-> (d/without-keys attrs csvg/inheritable-props)
attrs (-> attrs
(d/without-keys csvg/inheritable-props)
(csvg/attrs->props))
vbox (grc/make-rect offset-x offset-y width height)]
(cts/setup-shape
@ -304,6 +305,8 @@
rx (d/nilv r rx)
ry (d/nilv r ry)
rx (d/nilv rx 0)
ry (d/nilv ry 0)
;; There are some svg circles in the internet that does not
;; have cx and cy attrs, so we default them to 0

2
common/src/app/common/types/pages_list.cljc
View file

@ -34,7 +34,7 @@
(defn pages-seq
[fdata]
(vals (:pages-index fdata)))
(-> fdata :pages-index vals seq))
(defn update-page
[file-data page-id f]

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

@ -79,25 +79,6 @@
(def text-align-types
#{"left" "right" "center" "justify"})
(sm/define! ::selrect
[:and
{:title "Selrect"
:gen/gen (->> (sg/tuple (sg/small-double)
(sg/small-double)
(sg/small-double)
(sg/small-double))
(sg/fmap #(apply grc/make-rect %)))}
[:fn grc/rect?]
[:map
[:x ::sm/safe-number]
[:y ::sm/safe-number]
[:x1 ::sm/safe-number]
[:x2 ::sm/safe-number]
[:y1 ::sm/safe-number]
[:y2 ::sm/safe-number]
[:width ::sm/safe-number]
[:height ::sm/safe-number]]])
(sm/define! ::points
[:vector {:gen/max 4 :gen/min 4} ::gpt/point])
@ -133,7 +114,7 @@
[:id ::sm/uuid]
[:name :string]
[:type [::sm/one-of shape-types]]
[:selrect ::selrect]
[:selrect ::grc/rect]
[:points ::points]
[:transform ::gmt/matrix]
[:transform-inverse ::gmt/matrix]
@ -156,7 +137,7 @@
[:main-instance {:optional true} :boolean]
[:remote-synced {:optional true} :boolean]
[:shape-ref {:optional true} ::sm/uuid]
[:selrect {:optional true} ::selrect]
[:selrect {:optional true} ::grc/rect]
[:points {:optional true} ::points]
[:blocked {:optional true} :boolean]
[:collapsed {:optional true} :boolean]

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

@ -39,18 +39,7 @@
(def ^:private svgo-config
{:multipass false
:plugins
[{:name "safePreset"
:params {:overrides
{:convertColors
{:names2hex true
:shorthex false
:shortname false}
:convertTransform
{:matrixToTransform false
:convertToShorts false
:transformPrecision 4
:leadingZero false}}}}]})
:plugins ["safeAndFastPreset"]})
(defn svg->clj
[[name text]]

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

@ -72,13 +72,15 @@
(watch [it state _]
(let [page-id (:current-page-id state)
objects (wsh/lookup-page-objects state page-id)
shapes (->> shapes (remove #(dm/get-in objects [% :blocked])))
shapes (->> shapes
(remove #(dm/get-in objects [% :blocked]))
(cfh/order-by-indexed-shapes objects))
changes (-> (pcb/empty-changes it page-id)
(pcb/with-objects objects))
changes (cfsh/prepare-move-shapes-into-frame changes
frame-id
shapes
objects)]
changes (cfsh/prepare-move-shapes-into-frame changes frame-id shapes objects)]
(if (some? changes)
(rx/of (dch/commit-changes changes))
(rx/empty))))))