diff --git a/.clj-kondo/config.edn b/.clj-kondo/config.edn
index 60606932bf..fe1d14d908 100644
--- a/.clj-kondo/config.edn
+++ b/.clj-kondo/config.edn
@@ -5,6 +5,7 @@
promesa.exec.csp/go-loop clojure.core/loop
rumext.v2/defc clojure.core/defn
promesa.util/with-open clojure.core/with-open
+ app.common.schema.generators/let clojure.core/let
app.common.data/export clojure.core/def
app.common.data.macros/get-in clojure.core/get-in
app.common.data.macros/with-open clojure.core/with-open
diff --git a/backend/resources/log4j2-devenv.xml b/backend/resources/log4j2-devenv.xml
index 7abb7a1885..ca1ab6739a 100644
--- a/backend/resources/log4j2-devenv.xml
+++ b/backend/resources/log4j2-devenv.xml
@@ -30,7 +30,7 @@
-
+
diff --git a/backend/resources/log4j2-experiments.xml b/backend/resources/log4j2-experiments.xml
new file mode 100644
index 0000000000..88542c2774
--- /dev/null
+++ b/backend/resources/log4j2-experiments.xml
@@ -0,0 +1,71 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/backend/scripts/repl-test b/backend/scripts/repl-test
new file mode 100755
index 0000000000..a1333a5317
--- /dev/null
+++ b/backend/scripts/repl-test
@@ -0,0 +1,49 @@
+#!/usr/bin/env bash
+
+source /home/penpot/backend/environ
+export PENPOT_FLAGS="$PENPOT_FLAGS disable-backend-worker"
+
+export OPTIONS="
+ -A:jmx-remote -A:dev \
+ -J-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager \
+ -J-Djdk.attach.allowAttachSelf \
+ -J-Dlog4j2.configurationFile=log4j2-experiments.xml \
+ -J-XX:-OmitStackTraceInFastThrow \
+ -J-XX:+UnlockDiagnosticVMOptions \
+ -J-XX:+DebugNonSafepoints \
+ -J-Djdk.tracePinnedThreads=full \
+ -J-Dpolyglot.engine.WarnInterpreterOnly=false \
+ -J--enable-preview";
+
+# Setup HEAP
+#export OPTIONS="$OPTIONS -J-Xms900m -J-Xmx900m -J-XX:+AlwaysPreTouch"
+export OPTIONS="$OPTIONS -J-Xms1g -J-Xmx25g"
+#export OPTIONS="$OPTIONS -J-Xms900m -J-Xmx900m -J-XX:+AlwaysPreTouch"
+
+export PENPOT_HTTP_SERVER_IO_THREADS=2
+export PENPOT_HTTP_SERVER_WORKER_THREADS=2
+
+# Increase virtual thread pool size
+# export OPTIONS="$OPTIONS -J-Djdk.virtualThreadScheduler.parallelism=16"
+
+# Disable C2 Compiler
+# export OPTIONS="$OPTIONS -J-XX:TieredStopAtLevel=1"
+
+# Disable all compilers
+# export OPTIONS="$OPTIONS -J-Xint"
+
+# Setup GC
+export OPTIONS="$OPTIONS -J-XX:+UseG1GC -J-Xlog:gc:logs/gc.log"
+
+
+# Setup GC
+#export OPTIONS="$OPTIONS -J-XX:+UseZGC -J-XX:+ZGenerational -J-Xlog:gc:gc.log"
+
+# Enable ImageMagick v7.x support
+# export OPTIONS="-J-Dim4java.useV7=true $OPTIONS";
+
+export OPTIONS_EVAL="nil"
+# export OPTIONS_EVAL="(set! *warn-on-reflection* true)"
+
+set -ex
+exec clojure $OPTIONS -M -e "$OPTIONS_EVAL" -m rebel-readline.main
\ No newline at end of file
diff --git a/backend/src/app/config.clj b/backend/src/app/config.clj
index b4fe60c652..a9e883b8ff 100644
--- a/backend/src/app/config.clj
+++ b/backend/src/app/config.clj
@@ -209,7 +209,6 @@
(s/def ::telemetry-uri ::us/string)
(s/def ::telemetry-with-taiga ::us/boolean)
(s/def ::tenant ::us/string)
-(s/def ::svgo-max-procs ::us/integer)
(s/def ::config
(s/keys :opt-un [::secret-key
@@ -329,9 +328,7 @@
::telemetry-uri
::telemetry-referer
::telemetry-with-taiga
- ::tenant
-
- ::svgo-max-procs]))
+ ::tenant]))
(def default-flags
[:enable-backend-api-doc
diff --git a/backend/src/app/db.clj b/backend/src/app/db.clj
index 942d01db7d..6e7407e17d 100644
--- a/backend/src/app/db.clj
+++ b/backend/src/app/db.clj
@@ -517,9 +517,11 @@
(defn rollback!
([conn]
- (let [^Connection conn (get-connection conn)]
- (l/trc :hint "explicit rollback requested")
- (.rollback conn)))
+ (if (and (map? conn) (::savepoint conn))
+ (rollback! conn (::savepoint conn))
+ (let [^Connection conn (get-connection conn)]
+ (l/trc :hint "explicit rollback requested")
+ (.rollback conn))))
([conn ^Savepoint sp]
(let [^Connection conn (get-connection conn)]
(l/trc :hint "explicit rollback requested (savepoint)")
@@ -538,8 +540,13 @@
(let [conn (::conn system)
sp (savepoint conn)]
(try
- (let [result (apply f system params)]
- (release! conn sp)
+ (let [system' (-> system
+ (assoc ::savepoint sp)
+ (dissoc ::rollback))
+ result (apply f system' params)]
+ (if (::rollback system)
+ (rollback! conn sp)
+ (release! conn sp))
result)
(catch Throwable cause
(.rollback ^Connection conn ^Savepoint sp)
@@ -547,8 +554,10 @@
(::pool system)
(with-atomic [conn (::pool system)]
- (let [system (assoc system ::conn conn)
- result (apply f system params)]
+ (let [system' (-> system
+ (assoc ::conn conn)
+ (dissoc ::rollback))
+ result (apply f system' params)]
(when (::rollback system)
(rollback! conn))
result))
diff --git a/backend/src/app/features/components_v2.clj b/backend/src/app/features/components_v2.clj
index 8eb6772403..e5e2673f73 100644
--- a/backend/src/app/features/components_v2.clj
+++ b/backend/src/app/features/components_v2.clj
@@ -16,21 +16,30 @@
[app.common.files.migrations :as fmg]
[app.common.files.shapes-helpers :as cfsh]
[app.common.files.validate :as cfv]
+ [app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
+ [app.common.geom.shapes.path :as gshp]
[app.common.logging :as l]
+ [app.common.math :as mth]
+ [app.common.schema :as sm]
[app.common.svg :as csvg]
[app.common.svg.shapes-builder :as sbuilder]
+ [app.common.types.color :as ctc]
[app.common.types.component :as ctk]
[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.pages-list :as ctpl]
[app.common.types.shape :as cts]
[app.common.types.shape-tree :as ctst]
+ [app.common.types.shape.path :as ctsp]
+ [app.common.types.shape.text :as ctsx]
[app.common.uuid :as uuid]
[app.db :as db]
+ [app.db.sql :as sql]
[app.features.fdata :as fdata]
[app.http.sse :as sse]
[app.media :as media]
@@ -41,29 +50,34 @@
[app.storage.tmp :as tmp]
[app.svgo :as svgo]
[app.util.blob :as blob]
+ [app.util.cache :as cache]
[app.util.pointer-map :as pmap]
[app.util.time :as dt]
[buddy.core.codecs :as bc]
[cuerdas.core :as str]
[datoteka.io :as io]
- [promesa.core :as p]))
+ [promesa.exec :as px]
+ [promesa.util :as pu]))
(def ^:dynamic *stats*
"A dynamic var for setting up state for collect stats globally."
nil)
-(def ^:dynamic *skip-on-error*
- "A dynamic var for setting up the default error behavior."
- true)
+(def ^:dynamic *cache*
+ "A dynamic var for setting up a cache instance."
+ nil)
+
+(def ^:dynamic *skip-on-graphic-error*
+ "A dynamic var for setting up the default error behavior for graphics processing."
+ nil)
(def ^:dynamic ^:private *system*
"An internal var for making the current `system` available to all
internal functions without the need to explicitly pass it top down."
nil)
-(def ^:dynamic ^:private *max-procs*
- "A dynamic variable that can optionally indicates the maxumum number
- of concurrent graphics migration processes."
+(def ^:dynamic ^:private *team-id*
+ "A dynamic var that holds the current processing team-id."
nil)
(def ^:dynamic ^:private *file-stats*
@@ -91,21 +105,279 @@
;; 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-text-content?
+ (sm/lazy-validator ::ctsx/content))
+
+(def valid-path-content?
+ (sm/lazy-validator ::ctsp/content))
+
+(def valid-path-segment?
+ (sm/lazy-validator ::ctsp/segment))
+
+(def valid-rgb-color-string?
+ (sm/lazy-validator ::ctc/rgb-color))
+
(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, for further use.
+ ;; 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.
(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)))
+ fix-bad-children
+ (fn [file-data]
+ ;; Remove any child that does not exist. And also remove duplicated children.
+ (letfn [(fix-container
+ [container]
+ (d/update-when container :objects update-vals (partial fix-shape container)))
+
+ (fix-shape
+ [container shape]
+ (let [objects (:objects container)]
+ (d/update-when shape :shapes
+ (fn [shapes]
+ (->> shapes
+ (d/removev #(nil? (get objects %)))
+ (into [] (distinct)))))))]
+
+ (-> file-data
+ (update :pages-index update-vals fix-container)
+ (d/update-when :components update-vals fix-container))))
+
+ fix-missing-image-metadata
+ (fn [file-data]
+ ;; Delete broken image shapes with no metadata.
+ (letfn [(fix-container
+ [container]
+ (d/update-when container :objects #(reduce-kv fix-shape % %)))
+
+ (fix-shape
+ [objects id shape]
+ (if (and (cfh/image-shape? shape)
+ (nil? (:metadata shape)))
+ (-> objects
+ (dissoc id)
+ (d/update-in-when [(:parent-id shape) :shapes]
+ (fn [shapes] (filterv #(not= id %) shapes))))
+ objects))]
+
+ (-> file-data
+ (update :pages-index update-vals fix-container)
+ (d/update-when :components update-vals fix-container))))
+
+ fix-page-invalid-options
+ (fn [file-data]
+ (letfn [(update-page [page]
+ (update page :options fix-options))
+
+ (fix-background [options]
+ (if (and (contains? options :background)
+ (not (valid-rgb-color-string? (:background options))))
+ (dissoc options :background)
+ options))
+
+ (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-background)))]
+
+ (update file-data :pages-index update-vals update-page)))
+
+ delete-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
+ ;; schema. Since we don't have a way to fix those shapes, we
+ ;; simply proceed to delete it. We ignore path type shapes
+ ;; because they have not been affected by the bug.
+ (letfn [(fix-container
+ [container]
+ (d/update-when container :objects #(reduce-kv fix-shape % %)))
+
+ (fix-shape
+ [objects id shape]
+ (cond
+ (or (cfh/path-shape? shape)
+ (cfh/bool-shape? shape))
+ objects
+
+ (or (and (number? (:x shape)) (not (sm/valid-safe-number? (:x shape))))
+ (and (number? (:y shape)) (not (sm/valid-safe-number? (:y shape))))
+ (and (number? (:width shape)) (not (sm/valid-safe-number? (:width shape))))
+ (and (number? (:height shape)) (not (sm/valid-safe-number? (:height shape)))))
+ (-> objects
+ (dissoc id)
+ (d/update-in-when [(:parent-id shape) :shapes]
+ (fn [shapes] (filterv #(not= id %) shapes))))
+
+ :else
+ objects))]
+
+ (-> 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-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)))
+
+ ;; Fix broken fills
+ (seq (:fills shape))
+ (update :fills (fn [fills] (filterv valid-fill? fills)))
+
+ ;; Fix broken strokes
+ (seq (:strokes shape))
+ (update :strokes (fn [strokes] (filterv valid-stroke? strokes)))
+
+ ;; 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})))))]
+
+ (-> file-data
+ (update :pages-index update-vals fix-container)
+ (d/update-when :components update-vals fix-container))))
+
+ ;; There are some bugs in the past that allows convert text to
+ ;; path and this fix tries to identify this cases and fix them converting
+ ;; the shape back to text shape
+
+ fix-text-shapes-converted-to-path
+ (fn [file-data]
+ (letfn [(fix-container [container]
+ (d/update-when container :objects update-vals fix-shape))
+
+ (fix-shape [shape]
+ (if (and (cfh/path-shape? shape)
+ (contains? shape :content)
+ (some? (:selrect shape))
+ (valid-text-content? (:content shape)))
+ (let [selrect (:selrect shape)]
+ (-> shape
+ (assoc :x (:x selrect))
+ (assoc :y (:y selrect))
+ (assoc :width (:width selrect))
+ (assoc :height (:height selrect))
+ (assoc :type :text)))
+ shape))]
+ (-> file-data
+ (update :pages-index update-vals fix-container)
+ (d/update-when :components update-vals fix-container))))
+
+ fix-broken-paths
+ (fn [file-data]
+ (letfn [(fix-container [container]
+ (d/update-when container :objects update-vals fix-shape))
+
+ (fix-shape [shape]
+ (cond
+ (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)))
+
+ ;; When we fount a bool shape with no content,
+ ;; we convert it to a simple rect
+ (and (cfh/bool-shape? shape)
+ (not (seq (:bool-content shape))))
+ (let [selrect (or (:selrect shape)
+ (grc/make-rect))
+ points (grc/rect->points selrect)]
+ (-> shape
+ (assoc :x (:x selrect))
+ (assoc :y (:y selrect))
+ (assoc :width (:height selrect))
+ (assoc :height (:height selrect))
+ (assoc :selrect selrect)
+ (assoc :points points)
+ (assoc :type :rect)
+ (assoc :transform (gmt/matrix))
+ (assoc :transform-inverse (gmt/matrix))
+ (dissoc :bool-content)
+ (dissoc :shapes)
+ (dissoc :content)))
+
+ :else
+ shape))
+
+ (fix-path-content [content]
+ (let [[seg1 :as content] (filterv valid-path-segment? content)]
+ (if (and seg1 (not= :move-to (:command seg1)))
+ (let [params (select-keys (:params seg1) [:x :y])]
+ (into [{:command :move-to :params params}] content))
+ content)))]
+
+ (-> file-data
+ (update :pages-index update-vals fix-container)
+ (d/update-when :components update-vals fix-container))))
+
+ fix-recent-colors
+ (fn [file-data]
+ ;; Remove invalid colors in :recent-colors
+ (d/update-when file-data :recent-colors
+ (fn [colors]
+ (filterv valid-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]
+ (d/update-when container :objects #(reduce-kv fix-shape % %)))
+
+ (fix-shape
+ [objects id shape]
+ (reduce (fn [objects child-id]
+ (let [child (get objects child-id)]
+ (cond-> objects
+ (and (some? child) (not= id (:parent-id child)))
+ (d/update-in-when [id :shapes]
+ (fn [shapes] (filterv #(not= child-id %) shapes))))))
+ objects
+ (:shapes shape)))]
+
+ (-> file-data
+ (update :pages-index update-vals fix-container)
+ (d/update-when :components update-vals fix-container))))
+
fix-orphan-shapes
(fn [file-data]
;; Find shapes that are not listed in their parent's children list.
@@ -127,13 +399,13 @@
(-> file-data
(update :pages-index update-vals fix-container)
- (update :components update-vals fix-container))))
+ (d/update-when :components update-vals fix-container))))
remove-nested-roots
(fn [file-data]
;; Remove :component-root in head shapes that are nested.
(letfn [(fix-container [container]
- (update container :objects update-vals (partial fix-shape container)))
+ (d/update-when container :objects update-vals (partial fix-shape container)))
(fix-shape [container shape]
(let [parent (ctst/get-shape container (:parent-id shape))]
@@ -144,13 +416,13 @@
(-> file-data
(update :pages-index update-vals fix-container)
- (update :components update-vals fix-container))))
+ (d/update-when :components update-vals fix-container))))
add-not-nested-roots
(fn [file-data]
;; Add :component-root in head shapes that are not nested.
(letfn [(fix-container [container]
- (update container :objects update-vals (partial fix-shape container)))
+ (d/update-when container :objects update-vals (partial fix-shape container)))
(fix-shape [container shape]
(let [parent (ctst/get-shape container (:parent-id shape))]
@@ -161,13 +433,13 @@
(-> file-data
(update :pages-index update-vals fix-container)
- (update :components update-vals fix-container))))
+ (d/update-when :components update-vals fix-container))))
fix-orphan-copies
(fn [file-data]
;; Detach shapes that were inside a copy (have :shape-ref) but now they aren't.
(letfn [(fix-container [container]
- (update container :objects update-vals (partial fix-shape container)))
+ (d/update-when container :objects update-vals (partial fix-shape container)))
(fix-shape [container shape]
(let [parent (ctst/get-shape container (:parent-id shape))]
@@ -179,7 +451,7 @@
(-> file-data
(update :pages-index update-vals fix-container)
- (update :components update-vals fix-container))))
+ (d/update-when :components update-vals fix-container))))
remap-refs
(fn [file-data]
@@ -223,32 +495,32 @@
(-> file-data
(update :pages-index update-vals fix-container)
- (update :components update-vals fix-container))))
+ (d/update-when :components update-vals fix-container))))
- fix-copies-of-detached
+ fix-converted-copies
(fn [file-data]
- ;; Find any copy that is referencing a detached shape inside a component, and
- ;; undo the nested copy, converting it into a direct copy.
+ ;; 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]
- (update container :objects update-vals fix-shape))
+ (d/update-when container :objects update-vals (partial fix-shape 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))]
- (fix-shape [shape]
- (cond-> shape
- (@detached-ids (:shape-ref shape))
- (dissoc shape
- :component-id
- :component-file
- :component-root)))]
(-> file-data
(update :pages-index update-vals fix-container)
- (update :components update-vals fix-container))))
+ (d/update-when :components update-vals fix-container))))
transform-to-frames
(fn [file-data]
;; Transform component and copy heads to frames, and set the
;; frame-id of its childrens
(letfn [(fix-container [container]
- (update container :objects update-vals fix-shape))
+ (d/update-when container :objects update-vals fix-shape))
(fix-shape [shape]
(if (or (nil? (:parent-id shape)) (ctk/instance-head? shape))
@@ -262,7 +534,7 @@
shape))]
(-> file-data
(update :pages-index update-vals fix-container)
- (update :components update-vals fix-container))))
+ (d/update-when :components update-vals fix-container))))
remap-frame-ids
(fn [file-data]
@@ -270,7 +542,7 @@
;; to point to the head instance.
(letfn [(fix-container
[container]
- (update container :objects update-vals (partial fix-shape container)))
+ (d/update-when container :objects update-vals (partial fix-shape container)))
(fix-shape
[container shape]
@@ -280,14 +552,14 @@
shape)))]
(-> file-data
(update :pages-index update-vals fix-container)
- (update :components update-vals fix-container))))
+ (d/update-when :components update-vals fix-container))))
fix-frame-ids
(fn [file-data]
;; Ensure that frame-id of all shapes point to the parent or to the frame-id
;; of the parent, and that the destination is indeed a frame.
(letfn [(fix-container [container]
- (update container :objects #(cfh/reduce-objects % fix-shape %)))
+ (d/update-when container :objects #(cfh/reduce-objects % fix-shape %)))
(fix-shape [objects shape]
(let [parent (when (:parent-id shape)
@@ -304,7 +576,7 @@
(-> file-data
(update :pages-index update-vals fix-container)
- (update :components update-vals fix-container))))
+ (d/update-when :components update-vals fix-container))))
fix-component-nil-objects
(fn [file-data]
@@ -316,38 +588,89 @@
(dissoc component :objects))
component))]
(-> file-data
- (update :components update-vals fix-component))))
+ (d/update-when :components update-vals fix-component))))
fix-false-copies
(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]
- (update container :objects update-vals fix-shape))
+ (d/update-when container :objects update-vals (partial fix-shape container)))
(fix-shape
- [shape]
- (if (and (ctk/instance-head? shape)
- (not (ctk/main-instance? shape))
- (not (ctk/in-component-copy? shape)))
- (ctk/detach-shape shape)
+ [container shape]
+ (if (or (and (ctk/instance-head? shape)
+ (not (ctk/main-instance? shape))
+ (not (ctk/in-component-copy? shape)))
+ (and (ctk/in-component-copy? shape)
+ (nil? (ctn/get-head-shape (:objects container) shape {:allow-main? true}))))
+ (detach-shape container shape)
shape))]
(-> file-data
(update :pages-index update-vals fix-container)
- (update :components update-vals fix-container))))]
+ (d/update-when :components 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.
+ (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)))]
+ (-> 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))))]
(-> file-data
+ (fix-page-invalid-options)
+ (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-broken-parents)
(fix-orphan-shapes)
+ (fix-orphan-copies)
(remove-nested-roots)
(add-not-nested-roots)
- (fix-orphan-copies)
(remap-refs)
- (fix-copies-of-detached)
+ (fix-converted-copies)
(transform-to-frames)
(remap-frame-ids)
(fix-frame-ids)
(fix-component-nil-objects)
- (fix-false-copies))))
+ (fix-false-copies)
+ (fix-shape-nil-parent-id)
+ (fix-copies-of-detached)))) ; <- Do not add fixes after this one
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; COMPONENTS MIGRATION
@@ -574,7 +897,7 @@
(if (> ext-idx 0) (subs filename 0 ext-idx) filename)))
(defn- collect-and-persist-images
- [svg-data file-id]
+ [svg-data file-id media-id]
(letfn [(process-image [{:keys [href] :as item}]
(try
(let [item (if (str/starts-with? href "data:")
@@ -601,12 +924,13 @@
;; The media processing adds the data to the
;; input map and returns it.
(media/run {:cmd :info :input item}))
-
- (catch Throwable cause
- (l/warn :hint "unexpected exception on processing internal image shape (skiping)"
- :cause cause)
- (when-not *skip-on-error*
- (throw cause)))))
+ (catch Throwable _
+ (let [team-id *team-id*]
+ (l/wrn :hint "unable to process embedded images on svg file"
+ :team-id (str team-id)
+ :file-id (str file-id)
+ :media-id (str media-id)))
+ nil)))
(persist-image [acc {:keys [path size width height mtype href] :as item}]
(let [storage (::sto/storage *system*)
@@ -642,23 +966,33 @@
(completing persist-image) {}))]
(assoc svg-data :image-data images))))
-(defn- get-svg-content
+(defn- resolve-sobject-id
+ [id]
+ (let [fmobject (db/get *system* :file-media-object {:id id}
+ {::sql/columns [:media-id]})]
+ (:media-id fmobject)))
+
+(defn- get-sobject-content
[id]
(let [storage (::sto/storage *system*)
- conn (::db/conn *system*)
- fmobject (db/get conn :file-media-object {:id id})
- sobject (sto/get-object storage (:media-id fmobject))]
-
+ sobject (sto/get-object storage id)]
(with-open [stream (sto/get-object-data storage sobject)]
(slurp stream))))
(defn- create-shapes-for-svg
[{:keys [id] :as mobj} file-id objects frame-id position]
- (let [svg-text (get-svg-content id)
- svg-text (svgo/optimize *system* svg-text)
- svg-data (-> (csvg/parse svg-text)
- (assoc :name (:name mobj))
- (collect-and-persist-images file-id))]
+ (let [get-svg (fn [sid]
+ (let [svg-text (get-sobject-content sid)
+ svg-text (svgo/optimize *system* svg-text)]
+ (-> (csvg/parse svg-text)
+ (assoc :name (:name mobj)))))
+
+ sid (resolve-sobject-id id)
+ svg-data (if (cache/cache? *cache*)
+ (cache/get *cache* sid (px/wrap-bindings get-svg))
+ (get-svg sid))
+
+ svg-data (collect-and-persist-images svg-data file-id id)]
(sbuilder/create-svg-shapes svg-data position objects frame-id frame-id #{} false)))
@@ -717,42 +1051,64 @@
(defn- create-media-grid
[fdata page-id frame-id grid media-group]
- (let [process (fn [mobj position]
- (let [position (gpt/add position (gpt/point grid-gap grid-gap))
- tp1 (dt/tpoint)]
- (try
- (process-media-object fdata page-id frame-id mobj position)
- (catch Throwable cause
- (l/wrn :hint "unable to process file media object (skiping)"
- :file-id (str (:id fdata))
- :id (str (:id mobj))
- :cause cause)
- (if-not *skip-on-error*
- (throw cause)
- nil))
- (finally
- (l/trc :hint "graphic processed"
- :file-id (str (:id fdata))
- :media-id (str (:id mobj))
- :elapsed (dt/format-duration (tp1)))))))]
+ (letfn [(process [fdata mobj position]
+ (let [position (gpt/add position (gpt/point grid-gap grid-gap))
+ tp (dt/tpoint)
+ err (volatile! false)]
+ (try
+ (let [changes (process-media-object fdata page-id frame-id mobj position)]
+ (cp/process-changes fdata changes false))
+
+ (catch Throwable cause
+ (vreset! err true)
+ (let [cause (pu/unwrap-exception cause)
+ edata (ex-data cause)
+ team-id *team-id*]
+ (cond
+ (instance? org.xml.sax.SAXParseException cause)
+ (l/inf :hint "skip processing media object: invalid svg found"
+ :team-id (str team-id)
+ :file-id (str (:id fdata))
+ :id (str (:id mobj)))
+
+ (instance? org.graalvm.polyglot.PolyglotException cause)
+ (l/inf :hint "skip processing media object: invalid svg found"
+ :team-id (str team-id)
+ :file-id (str (:id fdata))
+ :id (str (:id mobj)))
+
+ (= (:type edata) :not-found)
+ (l/inf :hint "skip processing media object: underlying object does not exist"
+ :team-id (str team-id)
+ :file-id (str (:id fdata))
+ :id (str (:id mobj)))
+
+ :else
+ (let [skip? *skip-on-graphic-error*]
+ (l/wrn :hint "unable to process file media object"
+ :skiped skip?
+ :team-id (str team-id)
+ :file-id (str (:id fdata))
+ :id (str (:id mobj))
+ :cause cause)
+ (when-not skip?
+ (throw cause))))
+ nil))
+ (finally
+ (let [elapsed (tp)]
+ (l/trc :hint "graphic processed"
+ :file-id (str (:id fdata))
+ :media-id (str (:id mobj))
+ :error @err
+ :elapsed (dt/format-duration elapsed)))))))]
(->> (d/zip media-group grid)
- (partition-all (or *max-procs* 1))
- (mapcat (fn [partition]
- (->> partition
- (map (fn [[mobj position]]
- (sse/tap {:type :migration-progress
- :section :graphics
- :name (:name mobj)})
- (p/vthread (process mobj position))))
- (doall)
- (map deref)
- (doall))))
- (filter some?)
- (reduce (fn [fdata changes]
- (-> (assoc-in fdata [:options :components-v2] true)
- (cp/process-changes changes false)))
- fdata))))
+ (reduce (fn [fdata [mobj position]]
+ (sse/tap {:type :migration-progress
+ :section :graphics
+ :name (:name mobj)})
+ (or (process fdata mobj position) fdata))
+ (assoc-in fdata [:options :components-v2] true)))))
(defn- migrate-graphics
[fdata]
@@ -821,9 +1177,13 @@
(decode-row)
(update :data assoc :id id)
(update :data fdata/process-pointers deref)
+ (update :data fdata/process-objects (partial into {}))
+ (update :data (fn [data]
+ (if (> (:version data) 22)
+ (assoc data :version 22)
+ data)))
(fmg/migrate-file))))
-
(defn- get-team
[system team-id]
(-> (db/get system :team {:id team-id}
@@ -832,17 +1192,12 @@
(decode-row)))
(defn- validate-file!
- [file libs throw-on-validate?]
- (try
- (cfv/validate-file! file libs)
- (cfv/validate-file-schema! file)
- (catch Throwable cause
- (if throw-on-validate?
- (throw cause)
- (l/wrn :hint "migrate:file:validation-error" :cause cause)))))
+ [file libs]
+ (cfv/validate-file! file libs)
+ (cfv/validate-file-schema! file))
(defn- process-file
- [{:keys [::db/conn] :as system} id & {:keys [validate? throw-on-validate?]}]
+ [{:keys [::db/conn] :as system} id & {:keys [validate?]}]
(let [file (get-file system id)
libs (->> (files/get-file-libraries conn id)
@@ -855,7 +1210,7 @@
(update :features conj "components/v2"))
_ (when validate?
- (validate-file! file libs throw-on-validate?))
+ (validate-file! file libs))
file (if (contains? (:features file) "fdata/objects-map")
(fdata/enable-objects-map file)
@@ -876,12 +1231,13 @@
(dissoc file :data)))
-
(def ^:private sql:get-and-lock-team-files
"SELECT f.id
FROM file AS f
JOIN project AS p ON (p.id = f.project_id)
WHERE p.team_id = ?
+ AND p.deleted_at IS NULL
+ AND f.deleted_at IS NULL
FOR UPDATE")
(defn- get-and-lock-files
@@ -901,21 +1257,33 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn migrate-file!
- [system file-id & {:keys [validate? throw-on-validate? max-procs]}]
- (let [tpoint (dt/tpoint)]
+ [system file-id & {:keys [validate? skip-on-graphic-error? label]}]
+ (let [tpoint (dt/tpoint)]
(binding [*file-stats* (atom {})
- *max-procs* max-procs]
+ *skip-on-graphic-error* skip-on-graphic-error?]
(try
- (l/dbg :hint "migrate:file:start" :file-id (str file-id))
+ (l/dbg :hint "migrate:file:start"
+ :file-id (str file-id)
+ :validate validate?
+ :skip-on-graphic-error skip-on-graphic-error?)
(let [system (update system ::sto/storage media/configure-assets-storage)]
(db/tx-run! system
(fn [system]
- (binding [*system* system]
- (fsnap/take-file-snapshot! system {:file-id file-id :label "migration/components-v2"})
- (process-file system file-id
- :validate? validate?
- :throw-on-validate? throw-on-validate?)))))
+ (try
+ (binding [*system* system]
+ (when (string? label)
+ (fsnap/take-file-snapshot! system {:file-id file-id
+ :label (str "migration/" label)}))
+ (process-file system file-id :validate? validate?))
+
+ (catch Throwable cause
+ (let [team-id *team-id*]
+ (l/wrn :hint "error on processing file"
+ :team-id (str team-id)
+ :file-id (str file-id))
+ (throw cause)))))))
+
(finally
(let [elapsed (tpoint)
components (get @*file-stats* :processed/components 0)
@@ -925,46 +1293,52 @@
:file-id (str file-id)
:graphics graphics
:components components
+ :validate validate?
:elapsed (dt/format-duration elapsed))
(some-> *stats* (swap! update :processed/files (fnil inc 0)))
(some-> *team-stats* (swap! update :processed/files (fnil inc 0)))))))))
(defn migrate-team!
- [system team-id & {:keys [validate? throw-on-validate? max-procs]}]
+ [system team-id & {:keys [validate? skip-on-graphic-error? label]}]
(l/dbg :hint "migrate:team:start"
:team-id (dm/str team-id))
(let [tpoint (dt/tpoint)
+ err (volatile! false)
migrate-file
(fn [system file-id]
(migrate-file! system file-id
- :max-procs max-procs
+ :label label
:validate? validate?
- :throw-on-validate? throw-on-validate?))
+ :skip-on-graphic-error? skip-on-graphic-error?))
migrate-team
- (fn [{:keys [::db/conn] :as system} {:keys [id features] :as team}]
- (let [features (-> features
- (disj "ephimeral/v2-migration")
- (conj "components/v2")
- (conj "layout/grid")
- (conj "styles/v2"))]
+ (fn [{:keys [::db/conn] :as system} team-id]
+ (let [{:keys [id features]} (get-team system team-id)]
+ (if (contains? features "components/v2")
+ (l/inf :hint "team already migrated")
+ (let [features (-> features
+ (disj "ephimeral/v2-migration")
+ (conj "components/v2")
+ (conj "layout/grid")
+ (conj "styles/v2"))]
- (run! (partial migrate-file system)
- (get-and-lock-files conn id))
+ (run! (partial migrate-file system)
+ (get-and-lock-files conn id))
- (update-team-features! conn id features)))]
+ (update-team-features! conn id features)))))]
- (binding [*team-stats* (atom {})]
+ (binding [*team-stats* (atom {})
+ *team-id* team-id]
(try
- (db/tx-run! system (fn [system]
- (db/exec-one! system ["SET idle_in_transaction_session_timeout = 0"])
- (let [team (get-team system team-id)]
- (if (contains? (:features team) "components/v2")
- (l/inf :hint "team already migrated")
- (migrate-team system team)))))
+ (db/tx-run! system migrate-team team-id)
+
+ (catch Throwable cause
+ (vreset! err true)
+ (throw cause))
+
(finally
(let [elapsed (tpoint)
components (get @*team-stats* :processed/components 0)
@@ -973,9 +1347,21 @@
(some-> *stats* (swap! update :processed/teams (fnil inc 0)))
- (l/dbg :hint "migrate:team:end"
- :team-id (dm/str team-id)
- :files files
- :components components
- :graphics graphics
- :elapsed (dt/format-duration elapsed))))))))
+ (if (cache/cache? *cache*)
+ (let [cache-stats (cache/stats *cache*)]
+ (l/dbg :hint "migrate:team:end"
+ :team-id (dm/str team-id)
+ :files files
+ :components components
+ :graphics graphics
+ :crt (mth/to-fixed (:hit-rate cache-stats) 2)
+ :crq (str (:req-count cache-stats))
+ :error @err
+ :elapsed (dt/format-duration elapsed)))
+
+ (l/dbg :hint "migrate:team:end"
+ :team-id (dm/str team-id)
+ :files files
+ :components components
+ :graphics graphics
+ :elapsed (dt/format-duration elapsed)))))))))
diff --git a/backend/src/app/features/fdata.clj b/backend/src/app/features/fdata.clj
index 68e58833cd..8a57a1aa17 100644
--- a/backend/src/app/features/fdata.clj
+++ b/backend/src/app/features/fdata.clj
@@ -27,7 +27,7 @@
(update :data (fn [fdata]
(-> fdata
(update :pages-index update-vals update-fn)
- (update :components update-vals update-fn))))
+ (d/update-when :components update-vals update-fn))))
(update :features conj "fdata/objects-map"))))
(defn process-objects
@@ -110,6 +110,6 @@
(update :data (fn [fdata]
(-> fdata
(update :pages-index update-vals pmap/wrap)
- (update :components pmap/wrap))))
+ (d/update-when :components pmap/wrap))))
(update :features conj "fdata/pointer-map")))
diff --git a/backend/src/app/main.clj b/backend/src/app/main.clj
index c80210a06b..7028be8bfe 100644
--- a/backend/src/app/main.clj
+++ b/backend/src/app/main.clj
@@ -301,7 +301,8 @@
::sto/storage (ig/ref ::sto/storage)}
:app.rpc/climit
- {::mtx/metrics (ig/ref ::mtx/metrics)}
+ {::mtx/metrics (ig/ref ::mtx/metrics)
+ ::wrk/executor (ig/ref ::wrk/executor)}
:app.rpc/rlimit
{::wrk/executor (ig/ref ::wrk/executor)}
@@ -410,8 +411,7 @@
::migrations (ig/ref :app.migrations/migrations)}
::svgo/optimizer
- {::wrk/executor (ig/ref ::wrk/executor)
- ::svgo/max-procs (cf/get :svgo-max-procs)}
+ {}
::audit.tasks/archive
{::props (ig/ref ::setup/props)
diff --git a/backend/src/app/redis.clj b/backend/src/app/redis.clj
index b730ab1063..58023fe00e 100644
--- a/backend/src/app/redis.clj
+++ b/backend/src/app/redis.clj
@@ -91,7 +91,7 @@
(s/def ::connect? ::us/boolean)
(s/def ::io-threads ::us/integer)
(s/def ::worker-threads ::us/integer)
-(s/def ::cache some?)
+(s/def ::cache cache/cache?)
(s/def ::redis
(s/keys :req [::resources
@@ -168,7 +168,7 @@
(defn- shutdown-resources
[{:keys [::resources ::cache ::timer]}]
- (cache/invalidate-all! cache)
+ (cache/invalidate! cache)
(when resources
(.shutdown ^ClientResources resources))
@@ -211,7 +211,8 @@
(defn get-or-connect
[{:keys [::cache] :as state} key options]
(us/assert! ::redis state)
- (let [connection (cache/get cache key (fn [_] (connect* state options)))]
+ (let [create (fn [_] (connect* state options))
+ connection (cache/get cache key create)]
(-> state
(dissoc ::cache)
(assoc ::connection connection))))
diff --git a/backend/src/app/rpc/climit.clj b/backend/src/app/rpc/climit.clj
index d6e4ccb51b..71c64b596a 100644
--- a/backend/src/app/rpc/climit.clj
+++ b/backend/src/app/rpc/climit.clj
@@ -36,24 +36,14 @@
(-> (str id)
(subs 1)))
-(defn- create-bulkhead-cache
- [config]
- (letfn [(load-fn [[id skey]]
- (when-let [config (get config id)]
- (l/trc :hint "insert into cache" :id (id->str id) :key skey)
- (pbh/create :permits (or (:permits config) (:concurrency config))
- :queue (or (:queue config) (:queue-size config))
- :timeout (:timeout config)
- :type :semaphore)))
-
- (on-remove [key _ cause]
+(defn- create-cache
+ [{:keys [::wrk/executor]}]
+ (letfn [(on-remove [key _ cause]
(let [[id skey] key]
- (l/trc :hint "evict from cache" :id (id->str id) :key skey :reason (str cause))))]
-
- (cache/create :executor :same-thread
+ (l/dbg :hint "destroy limiter" :id (id->str id) :key skey :reason (str cause))))]
+ (cache/create :executor executor
:on-remove on-remove
- :keepalive "5m"
- :load-fn load-fn)))
+ :keepalive "5m")))
(s/def ::config/permits ::us/integer)
(s/def ::config/queue ::us/integer)
@@ -70,7 +60,7 @@
(s/def ::path ::fs/path)
(defmethod ig/pre-init-spec ::rpc/climit [_]
- (s/keys :req [::mtx/metrics ::path]))
+ (s/keys :req [::mtx/metrics ::wrk/executor ::path]))
(defmethod ig/init-key ::rpc/climit
[_ {:keys [::path ::mtx/metrics] :as cfg}]
@@ -78,7 +68,7 @@
(when-let [params (some->> path slurp edn/read-string)]
(l/inf :hint "initializing concurrency limit" :config (str path))
(us/verify! ::config params)
- {::cache (create-bulkhead-cache params)
+ {::cache (create-cache cfg)
::config params
::mtx/metrics metrics})))
@@ -89,13 +79,17 @@
(s/def ::rpc/climit
(s/nilable ::instance))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; PUBLIC API
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defn- create-limiter
+ [config [id skey]]
+ (l/dbg :hint "create limiter" :id (id->str id) :key skey)
+ (pbh/create :permits (or (:permits config) (:concurrency config))
+ :queue (or (:queue config) (:queue-size config))
+ :timeout (:timeout config)
+ :type :semaphore))
-(defn invoke!
- [cache metrics id key f]
- (if-let [limiter (cache/get cache [id key])]
+(defn- invoke!
+ [config cache metrics id key f]
+ (if-let [limiter (cache/get cache [id key] (partial create-limiter config))]
(let [tpoint (dt/tpoint)
labels (into-array String [(id->str id)])
wrapped (fn []
@@ -147,7 +141,7 @@
:queue (:queue stats)
:max-permits (:max-permits stats)
:max-queue (:max-queue stats))
- (pbh/invoke! limiter wrapped))
+ (px/invoke! limiter wrapped))
(catch ExceptionInfo cause
(let [{:keys [type code]} (ex-data cause)]
(if (= :bulkhead-error type)
@@ -160,9 +154,43 @@
(measure! (pbh/get-stats limiter)))))
(do
- (l/wrn :hint "unable to load limiter" :id (id->str id))
+ (l/wrn :hint "no limiter found" :id (id->str id))
(f))))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; MIDDLEWARE
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def noop-fn (constantly nil))
+
+(defn wrap
+ [{:keys [::rpc/climit ::mtx/metrics]} f {:keys [::id ::key-fn] :or {key-fn noop-fn} :as mdata}]
+ (if (and (some? climit) (some? id))
+ (let [cache (::cache climit)
+ config (::config climit)]
+ (if-let [config (get config id)]
+ (do
+ (l/dbg :hint "instrumenting method"
+ :limit (id->str id)
+ :service-name (::sv/name mdata)
+ :timeout (:timeout config)
+ :permits (:permits config)
+ :queue (:queue config)
+ :keyed? (not= key-fn noop-fn))
+
+ (fn [cfg params]
+ (invoke! config cache metrics id (key-fn params) (partial f cfg params))))
+
+ (do
+ (l/wrn :hint "no config found for specified queue" :id (id->str id))
+ f)))
+
+ f))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PUBLIC API
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
(defn configure
[{:keys [::rpc/climit]} id]
(us/assert! ::rpc/climit climit)
@@ -171,37 +199,14 @@
(defn run!
"Run a function in context of climit.
Intended to be used in virtual threads."
- ([{:keys [::id ::cache ::mtx/metrics]} f]
- (if (and cache id)
- (invoke! cache metrics id nil f)
+ ([{:keys [::id ::cache ::config ::mtx/metrics]} f]
+ (if-let [config (get config id)]
+ (invoke! config cache metrics id nil f)
(f)))
- ([{:keys [::id ::cache ::mtx/metrics]} f executor]
+ ([{:keys [::id ::cache ::config ::mtx/metrics]} f executor]
(let [f #(p/await! (px/submit! executor f))]
- (if (and cache id)
- (invoke! cache metrics id nil f)
+ (if-let [config (get config id)]
+ (invoke! config cache metrics id nil f)
(f)))))
-(def noop-fn (constantly nil))
-
-(defn wrap
- [{:keys [::rpc/climit ::mtx/metrics]} f {:keys [::id ::key-fn] :or {key-fn noop-fn} :as mdata}]
- (if (and (some? climit) (some? id))
- (if-let [config (get-in climit [::config id])]
- (let [cache (::cache climit)]
- (l/dbg :hint "instrumenting method"
- :limit (id->str id)
- :service-name (::sv/name mdata)
- :timeout (:timeout config)
- :permits (:permits config)
- :queue (:queue config)
- :keyed? (not= key-fn noop-fn))
-
- (fn [cfg params]
- (invoke! cache metrics id (key-fn params) (partial f cfg params))))
-
- (do
- (l/wrn :hint "no config found for specified queue" :id (id->str id))
- f))
-
- f))
diff --git a/backend/src/app/rpc/commands/binfile.clj b/backend/src/app/rpc/commands/binfile.clj
index 81bb6e10a7..ebebbc42f8 100644
--- a/backend/src/app/rpc/commands/binfile.clj
+++ b/backend/src/app/rpc/commands/binfile.clj
@@ -664,9 +664,7 @@
(case feature
"components/v2"
(feat.compv2/migrate-file! options file-id
- :max-procs 2
- :validate? validate?
- :throw-on-validate? true)
+ :validate? validate?)
"fdata/shape-data-type"
nil
diff --git a/backend/src/app/rpc/commands/files.clj b/backend/src/app/rpc/commands/files.clj
index f6b6c615da..f2e6a19899 100644
--- a/backend/src/app/rpc/commands/files.clj
+++ b/backend/src/app/rpc/commands/files.clj
@@ -226,23 +226,37 @@
[{:keys [::db/conn] :as cfg} {:keys [id] :as file}]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)
pmap/*tracked* (pmap/create-tracked)]
- (let [file (fmg/migrate-file file)]
+ (let [;; For avoid unnecesary overhead of creating multiple pointers and
+ ;; handly internally with objects map in their worst case (when
+ ;; probably all shapes and all pointers will be readed in any
+ ;; case), we just realize/resolve them before applying the
+ ;; migration to the file
+ file (-> file
+ (update :data feat.fdata/process-pointers deref)
+ (update :data feat.fdata/process-objects (partial into {}))
+ (fmg/migrate-file))
- ;; NOTE: when file is migrated, we break the rule of no perform
- ;; mutations on get operations and update the file with all
- ;; migrations applied
- ;;
- ;; NOTE: the following code will not work on read-only mode, it
- ;; is a known issue; we keep is not implemented until we really
- ;; need this
- (when (fmg/migrated? file)
- (db/update! conn :file
- {:data (blob/encode (:data file))
- :features (db/create-array conn "text" (:features file))}
- {:id id})
+ ;; When file is migrated, we break the rule of no perform
+ ;; mutations on get operations and update the file with all
+ ;; migrations applied
+ ;;
+ ;; WARN: he following code will not work on read-only mode,
+ ;; it is a known issue; we keep is not implemented until we
+ ;; really need this.
+ file (if (contains? (:features file) "fdata/objects-map")
+ (feat.fdata/enable-objects-map file)
+ file)
+ file (if (contains? (:features file) "fdata/pointer-map")
+ (feat.fdata/enable-pointer-map file)
+ file)]
- (when (contains? (:features file) "fdata/pointer-map")
- (feat.fdata/persist-pointers! cfg id)))
+ (db/update! conn :file
+ {:data (blob/encode (:data file))
+ :features (db/create-array conn "text" (:features file))}
+ {:id id})
+
+ (when (contains? (:features file) "fdata/pointer-map")
+ (feat.fdata/persist-pointers! cfg id))
file)))
@@ -266,7 +280,7 @@
::db/remove-deleted (not include-deleted?)
::sql/for-update lock-for-update?})
(decode-row))]
- (if migrate?
+ (if (and migrate? (fmg/need-migration? file))
(migrate-file cfg file)
file)))
diff --git a/backend/src/app/rpc/commands/files_create.clj b/backend/src/app/rpc/commands/files_create.clj
index 59273f033e..dbbd1c04d1 100644
--- a/backend/src/app/rpc/commands/files_create.clj
+++ b/backend/src/app/rpc/commands/files_create.clj
@@ -18,14 +18,12 @@
[app.loggers.audit :as-alias audit]
[app.loggers.webhooks :as-alias webhooks]
[app.rpc :as-alias rpc]
- [app.rpc.commands.files :as files]
[app.rpc.commands.projects :as projects]
[app.rpc.commands.teams :as teams]
[app.rpc.doc :as-alias doc]
[app.rpc.permissions :as perms]
[app.rpc.quotes :as quotes]
[app.util.blob :as blob]
- [app.util.objects-map :as omap]
[app.util.pointer-map :as pmap]
[app.util.services :as sv]
[app.util.time :as dt]
@@ -50,47 +48,52 @@
"expected a valid connection"
(db/connection? conn))
- (let [id (or id (uuid/next))
+ (binding [pmap/*tracked* (pmap/create-tracked)
+ cfeat/*current* features]
+ (let [id (or id (uuid/next))
- pointers (pmap/create-tracked)
- pmap? (contains? features "fdata/pointer-map")
- omap? (contains? features "fdata/objects-map")
-
- data (binding [pmap/*tracked* pointers
- cfeat/*current* features
- cfeat/*wrap-with-objects-map-fn* (if omap? omap/wrap identity)
- cfeat/*wrap-with-pointer-map-fn* (if pmap? pmap/wrap identity)]
- (if create-page
+ data (if create-page
(ctf/make-file-data id)
- (ctf/make-file-data id nil)))
+ (ctf/make-file-data id nil))
- features (->> (set/difference features cfeat/frontend-only-features)
- (db/create-array conn "text"))
+ file {:id id
+ :project-id project-id
+ :name name
+ :revn revn
+ :is-shared is-shared
+ :data data
+ :features features
+ :ignore-sync-until ignore-sync-until
+ :modified-at modified-at
+ :deleted-at deleted-at}
- file (db/insert! conn :file
- (d/without-nils
- {:id id
- :project-id project-id
- :name name
- :revn revn
- :is-shared is-shared
- :data (blob/encode data)
- :features features
- :ignore-sync-until ignore-sync-until
- :modified-at modified-at
- :deleted-at deleted-at}))]
+ file (if (contains? features "fdata/objects-map")
+ (feat.fdata/enable-objects-map file)
+ file)
- (binding [pmap/*tracked* pointers]
- (feat.fdata/persist-pointers! cfg id))
+ file (if (contains? features "fdata/pointer-map")
+ (feat.fdata/enable-pointer-map file)
+ file)
- (->> (assoc params :file-id id :role :owner)
- (create-file-role! conn))
+ file (d/without-nils file)]
- (db/update! conn :project
- {:modified-at (dt/now)}
- {:id project-id})
+ (db/insert! conn :file
+ (-> file
+ (update :data blob/encode)
+ (update :features db/encode-pgarray conn "text"))
+ {::db/return-keys false})
- (files/decode-row file)))
+ (when (contains? features "fdata/pointer-map")
+ (feat.fdata/persist-pointers! cfg id))
+
+ (->> (assoc params :file-id id :role :owner)
+ (create-file-role! conn))
+
+ (db/update! conn :project
+ {:modified-at (dt/now)}
+ {:id project-id})
+
+ file)))
(def ^:private schema:create-file
[:map {:title "create-file"}
diff --git a/backend/src/app/rpc/commands/files_update.clj b/backend/src/app/rpc/commands/files_update.clj
index 03e1b04da4..134a127946 100644
--- a/backend/src/app/rpc/commands/files_update.clj
+++ b/backend/src/app/rpc/commands/files_update.clj
@@ -292,9 +292,20 @@
(let [file (update file :data (fn [data]
(-> data
(blob/decode)
- (assoc :id (:id file))
- (fmg/migrate-data)
- (d/without-nils))))
+ (assoc :id (:id file)))))
+
+ ;; For avoid unnecesary overhead of creating multiple pointers
+ ;; and handly internally with objects map in their worst
+ ;; case (when probably all shapes and all pointers will be
+ ;; readed in any case), we just realize/resolve them before
+ ;; applying the migration to the file
+ file (if (fmg/need-migration? file)
+ (-> file
+ (update :data feat.fdata/process-pointers deref)
+ (update :data feat.fdata/process-objects (partial into {}))
+ (fmg/migrate-file))
+ file)
+
;; WARNING: this ruins performance; maybe we need to find
;; some other way to do general validation
@@ -305,14 +316,20 @@
(into [file] (map (fn [{:keys [id]}]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)
pmap/*tracked* nil]
+ ;; We do not resolve the objects maps here
+ ;; because there is a lower probability that all
+ ;; shapes needed to be loded into memory, so we
+ ;; leeave it on lazy status
(-> (files/get-file cfg id :migrate? false)
(update :data feat.fdata/process-pointers deref) ; ensure all pointers resolved
(fmg/migrate-file))))))
(d/index-by :id)))
+
file (-> (files/check-version! file)
(update :revn inc)
- (update :data cpc/process-changes changes))]
+ (update :data cpc/process-changes changes)
+ (update :data d/without-nils))]
(when (contains? cf/flags :soft-file-validation)
(soft-validate-file! file libs))
@@ -329,12 +346,10 @@
(val/validate-file-schema! file))
(cond-> file
- (and (contains? cfeat/*current* "fdata/objects-map")
- (not (contains? cfeat/*previous* "fdata/objects-map")))
+ (contains? cfeat/*current* "fdata/objects-map")
(feat.fdata/enable-objects-map)
- (and (contains? cfeat/*current* "fdata/pointer-map")
- (not (contains? cfeat/*previous* "fdata/pointer-map")))
+ (contains? cfeat/*current* "fdata/pointer-map")
(feat.fdata/enable-pointer-map)
:always
diff --git a/backend/src/app/srepl/components_v2.clj b/backend/src/app/srepl/components_v2.clj
index fec852f082..5e6a697bb7 100644
--- a/backend/src/app/srepl/components_v2.clj
+++ b/backend/src/app/srepl/components_v2.clj
@@ -6,13 +6,18 @@
(ns app.srepl.components-v2
(:require
+ [app.common.data :as d]
[app.common.logging :as l]
[app.common.pprint :as pp]
+ [app.common.uuid :as uuid]
[app.db :as db]
[app.features.components-v2 :as feat]
+ [app.main :as main]
+ [app.svgo :as svgo]
+ [app.util.cache :as cache]
[app.util.time :as dt]
+ [app.worker :as-alias wrk]
[cuerdas.core :as str]
- [promesa.core :as p]
[promesa.exec :as px]
[promesa.exec.semaphore :as ps]
[promesa.util :as pu]))
@@ -35,14 +40,9 @@
(fn [_ _ oldv newv]
(when (not= (:processed/files oldv)
(:processed/files newv))
- (let [total (:total/files newv)
- completed (:processed/files newv)
- progress (/ (* completed 100.0) total)
- elapsed (tpoint)]
+ (let [elapsed (tpoint)]
(l/dbg :hint "progress"
:completed (:processed/files newv)
- :total (:total/files newv)
- :progress (str (int progress) "%")
:elapsed (dt/format-duration elapsed))))))
(defn- report-progress-teams
@@ -50,88 +50,147 @@
(fn [_ _ oldv newv]
(when (not= (:processed/teams oldv)
(:processed/teams newv))
- (let [total (:total/teams newv)
- completed (:processed/teams newv)
- progress (/ (* completed 100.0) total)
- progress (str (int progress) "%")
+ (let [completed (:processed/teams newv)
elapsed (dt/format-duration (tpoint))]
-
(when (fn? on-progress)
- (on-progress {:total total
- :elapsed elapsed
- :completed completed
- :progress progress}))
-
+ (on-progress {:elapsed elapsed
+ :completed completed}))
(l/dbg :hint "progress"
:completed completed
- :progress progress
:elapsed elapsed)))))
-(defn- get-total-files
- [pool & {:keys [team-id]}]
- (if (some? team-id)
- (let [sql (str/concat
- "SELECT count(f.id) AS count FROM file AS f "
- " JOIN project AS p ON (p.id = f.project_id) "
- " WHERE p.team_id = ? AND f.deleted_at IS NULL "
- " AND p.deleted_at IS NULL")
- res (db/exec-one! pool [sql team-id])]
- (:count res))
+(def ^:private sql:get-teams-by-created-at
+ "WITH teams AS (
+ SELECT id, features
+ FROM team
+ WHERE deleted_at IS NULL
+ ORDER BY created_at DESC
+ ) SELECT * FROM TEAMS %(pred)s")
- (let [sql (str/concat
- "SELECT count(id) AS count FROM file "
- " WHERE deleted_at IS NULL")
- res (db/exec-one! pool [sql])]
- (:count res))))
+(def ^:private sql:get-teams-by-graphics
+ "WITH teams AS (
+ SELECT t.id, t.features,
+ (SELECT count(*)
+ FROM file_media_object AS fmo
+ JOIN file AS f ON (f.id = fmo.file_id)
+ JOIN project AS p ON (p.id = f.project_id)
+ WHERE p.team_id = t.id
+ AND fmo.mtype = 'image/svg+xml'
+ AND fmo.is_local = false) AS graphics
+ FROM team AS t
+ WHERE t.deleted_at IS NULL
+ ORDER BY 3 ASC
+ )
+ SELECT * FROM teams %(pred)s")
-(defn- get-total-teams
- [pool]
- (let [sql (str/concat
- "SELECT count(id) AS count FROM team "
- " WHERE deleted_at IS NULL")
- res (db/exec-one! pool [sql])]
- (:count res)))
+(def ^:private sql:get-teams-by-activity
+ "WITH teams AS (
+ SELECT t.id, t.features,
+ (SELECT coalesce(max(date_trunc('month', f.modified_at)), date_trunc('month', t.modified_at))
+ FROM file AS f
+ JOIN project AS p ON (f.project_id = p.id)
+ WHERE p.team_id = t.id) AS updated_at,
+ (SELECT coalesce(count(*), 0)
+ FROM file AS f
+ JOIN project AS p ON (f.project_id = p.id)
+ WHERE p.team_id = t.id) AS total_files
+ FROM team AS t
+ WHERE t.deleted_at IS NULL
+ ORDER BY 3 DESC, 4 DESC
+ )
+ SELECT * FROM teams %(pred)s")
+(def ^:private sql:get-teams-by-report
+ "WITH teams AS (
+ SELECT t.id t.features, mr.name
+ FROM migration_report AS mr
+ JOIN team AS t ON (t.id = mr.team_id)
+ WHERE t.deleted_at IS NULL
+ AND mr.error IS NOT NULL
+ ORDER BY mr.created_at
+ ) SELECT id, features FROM teams %(pred)s")
-(defn- mark-team-migration!
- [{:keys [::db/pool]} team-id]
- ;; We execute this out of transaction because we want this
- ;; change to be visible to all other sessions before starting
- ;; the migration
- (let [sql (str "UPDATE team SET features = "
- " array_append(features, 'ephimeral/v2-migration') "
- " WHERE id = ?")]
- (db/exec-one! pool [sql team-id])))
+(defn- read-pred
+ [entries]
+ (let [entries (if (and (vector? entries)
+ (keyword? (first entries)))
+ [entries]
+ entries)]
+ (loop [params []
+ queries []
+ entries (seq entries)]
+ (if-let [[op val field] (first entries)]
+ (let [field (name field)
+ cond (case op
+ :lt (str/ffmt "% < ?" field)
+ :lte (str/ffmt "% <= ?" field)
+ :gt (str/ffmt "% > ?" field)
+ :gte (str/ffmt "% >= ?" field)
+ :eq (str/ffmt "% = ?" field))]
+ (recur (conj params val)
+ (conj queries cond)
+ (rest entries)))
-(defn- unmark-team-migration!
- [{:keys [::db/pool]} team-id]
- ;; We execute this out of transaction because we want this
- ;; change to be visible to all other sessions before starting
- ;; the migration
- (let [sql (str "UPDATE team SET features = "
- " array_remove(features, 'ephimeral/v2-migration') "
- " WHERE id = ?")]
- (db/exec-one! pool [sql team-id])))
-
-(def ^:private sql:get-teams
- "SELECT id, features
- FROM team
- WHERE deleted_at IS NULL
- ORDER BY created_at ASC")
+ (let [sql (apply str "WHERE " (str/join " AND " queries))]
+ (apply vector sql params))))))
(defn- get-teams
- [conn]
- (->> (db/cursor conn sql:get-teams)
- (map feat/decode-row)))
+ [conn query pred]
+ (let [query (d/nilv query :created-at)
+ sql (case query
+ :created-at sql:get-teams-by-created-at
+ :activity sql:get-teams-by-activity
+ :graphics sql:get-teams-by-graphics
+ :report sql:get-teams-by-report)
+
+ sql (if pred
+ (let [[pred-sql & pred-params] (read-pred pred)]
+ (apply vector
+ (str/format sql {:pred pred-sql})
+ pred-params))
+ [(str/format sql {:pred ""})])]
+
+ (->> (db/cursor conn sql {:chunk-size 500})
+ (map feat/decode-row)
+ (remove (fn [{:keys [features]}]
+ (contains? features "components/v2")))
+ (map :id))))
+
+(def ^:private sql:report-table
+ "CREATE UNLOGGED TABLE IF NOT EXISTS migration_report (
+ id bigserial NOT NULL,
+ label text NOT NULL,
+ team_id UUID NOT NULL,
+ error text NULL,
+ created_at timestamptz NOT NULL DEFAULT now(),
+ elapsed bigint NOT NULL,
+ PRIMARY KEY (label, created_at, id)
+ )")
+
+(defn- create-report-table!
+ [system]
+ (db/exec-one! system [sql:report-table]))
+
+(defn- clean-reports!
+ [system label]
+ (db/delete! system :migration-report {:label label}))
+
+(defn- report!
+ [system team-id label elapsed error]
+ (db/insert! system :migration-report
+ {:label label
+ :team-id team-id
+ :elapsed (inst-ms elapsed)
+ :error error}
+ {::db/return-keys false}))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn migrate-file!
- [system file-id & {:keys [rollback? max-procs]
- :or {rollback? true}}]
-
+ [file-id & {:keys [rollback? validate? label] :or {rollback? true validate? false}}]
(l/dbg :hint "migrate:start" :rollback rollback?)
(let [tpoint (dt/tpoint)
file-id (if (string? file-id)
@@ -139,8 +198,10 @@
file-id)]
(binding [feat/*stats* (atom {})]
(try
- (-> (assoc system ::db/rollback rollback?)
- (feat/migrate-file! file-id :max-procs max-procs))
+ (-> (assoc main/system ::db/rollback rollback?)
+ (feat/migrate-file! file-id
+ :validate? validate?
+ :label label))
(-> (deref feat/*stats*)
(assoc :elapsed (dt/format-duration (tpoint))))
@@ -153,47 +214,36 @@
(l/dbg :hint "migrate:end" :rollback rollback? :elapsed elapsed)))))))
(defn migrate-team!
- [{:keys [::db/pool] :as system} team-id & {:keys [rollback? skip-on-error validate? max-procs]
- :or {rollback? true
- skip-on-error true
- validate? false
- max-procs 1}
- :as opts}]
+ [team-id & {:keys [rollback? skip-on-graphic-error? validate? label]
+ :or {rollback? true
+ validate? true
+ skip-on-graphic-error? false}}]
(l/dbg :hint "migrate:start" :rollback rollback?)
(let [team-id (if (string? team-id)
(parse-uuid team-id)
team-id)
- total (get-total-files pool :team-id team-id)
- stats (atom {:total/files total})
+ stats (atom {})
tpoint (dt/tpoint)]
(add-watch stats :progress-report (report-progress-files tpoint))
- (binding [feat/*stats* stats
- feat/*skip-on-error* skip-on-error]
-
+ (binding [feat/*stats* stats]
(try
- (mark-team-migration! system team-id)
-
- (-> (assoc system ::db/rollback rollback?)
+ (-> (assoc main/system ::db/rollback rollback?)
(feat/migrate-team! team-id
- :max-procs max-procs
+ :label label
:validate? validate?
- :throw-on-validate? (not skip-on-error)))
-
+ :skip-on-graphic-error? skip-on-graphic-error?))
(print-stats!
(-> (deref feat/*stats*)
- (dissoc :total/files)
(assoc :elapsed (dt/format-duration (tpoint)))))
(catch Throwable cause
(l/dbg :hint "migrate:error" :cause cause))
(finally
- (unmark-team-migration! system team-id)
-
(let [elapsed (dt/format-duration (tpoint))]
(l/dbg :hint "migrate:end" :rollback rollback? :elapsed elapsed)))))))
@@ -204,98 +254,118 @@
until thw maximum number of jobs is reached which by default has the
value of `1`. This is controled with the `:max-jobs` option.
- Each tram migration process also can start multiple procs for
- graphics migration, the total of that procs is controled with the
- `:max-procs` option.
+ If you want to run this on multiple machines you will need to specify
+ the total number of partitions and the current partition.
- Internally, the graphics migration process uses SVGO module which by
- default has a limited number of maximum concurent
- operations (globally), ensure setting up correct number with
- PENPOT_SVGO_MAX_PROCS environment variable."
+ In order to get the report table populated, you will need to provide
+ a correct `:label`. That label is also used for persist a file
+ snaphot before continue with the migration."
+ [& {:keys [max-jobs max-items max-time rollback? validate? query
+ pred max-procs cache on-start on-progress on-error on-end
+ skip-on-graphic-error? label partitions current-partition]
+ :or {validate? false
+ rollback? true
+ max-jobs 1
+ current-partition 1
+ skip-on-graphic-error? true
+ max-items Long/MAX_VALUE}}]
- [{:keys [::db/pool] :as system} & {:keys [max-jobs max-procs max-items
- rollback? validate? preset
- skip-on-error max-time
- on-start on-progress on-error on-end]
- :or {validate? false
- rollback? true
- skip-on-error true
- preset :shutdown-on-failure
- max-jobs 1
- max-procs 10
- max-items Long/MAX_VALUE}
- :as opts}]
+ (when (int? partitions)
+ (when-not (int? current-partition)
+ (throw (IllegalArgumentException. "missing `current-partition` parameter")))
+ (when-not (<= 0 current-partition partitions)
+ (throw (IllegalArgumentException. "invalid value on `current-partition` parameter"))))
- (let [total (get-total-teams pool)
- stats (atom {:total/teams (min total max-items)})
+ (let [stats (atom {})
+ tpoint (dt/tpoint)
+ mtime (some-> max-time dt/duration)
- tpoint (dt/tpoint)
- mtime (some-> max-time dt/duration)
+ factory (px/thread-factory :virtual false :prefix "penpot/migration/")
+ executor (px/cached-executor :factory factory)
- scope (px/structured-task-scope :preset preset :factory :virtual)
- sjobs (ps/create :permits max-jobs)
+ max-procs (or max-procs max-jobs)
+ sjobs (ps/create :permits max-jobs)
+ sprocs (ps/create :permits max-procs)
+ cache (if (int? cache)
+ (cache/create :executor executor
+ :max-items cache)
+ nil)
migrate-team
- (fn [{:keys [id features] :as team}]
+ (fn [team-id]
+ (let [tpoint (dt/tpoint)]
+ (try
+ (db/tx-run! (assoc main/system ::db/rollback rollback?)
+ (fn [system]
+ (db/exec-one! system ["SET idle_in_transaction_session_timeout = 0"])
+ (feat/migrate-team! system team-id
+ :label label
+ :validate? validate?
+ :skip-on-graphic-error? skip-on-graphic-error?)))
+
+ (when (string? label)
+ (report! main/system team-id label (tpoint) nil))
+
+ (catch Throwable cause
+ (l/wrn :hint "unexpected error on processing team (skiping)"
+ :team-id (str team-id)
+ :cause cause)
+ (when (string? label)
+ (report! main/system team-id label (tpoint) (ex-message cause))))
+
+ (finally
+ (ps/release! sjobs)))))
+
+ process-team
+ (fn [team-id]
(ps/acquire! sjobs)
(let [ts (tpoint)]
- (cond
- (and mtime (neg? (compare mtime ts)))
+ (if (and mtime (neg? (compare mtime ts)))
(do
(l/inf :hint "max time constraint reached"
- :team-id (str id)
+ :team-id (str team-id)
:elapsed (dt/format-duration ts))
(ps/release! sjobs)
(reduced nil))
- (or (contains? features "ephimeral/v2-migration")
- (contains? features "components/v2"))
- (do
- (l/dbg :hint "skip team" :team-id (str id))
- (ps/release! sjobs))
-
- :else
- (px/submit! scope (fn []
- (try
- (mark-team-migration! system id)
- (-> (assoc system ::db/rollback rollback?)
- (feat/migrate-team! id
- :max-procs max-procs
- :validate? validate?
- :throw-on-validate? (not skip-on-error)))
- (catch Throwable cause
- (l/err :hint "unexpected error on processing team"
- :team-id (str id)
- :cause cause))
- (finally
- (ps/release! sjobs)
- (unmark-team-migration! system id))))))))]
+ (px/run! executor (partial migrate-team team-id)))))]
(l/dbg :hint "migrate:start"
+ :label label
:rollback rollback?
- :total total
:max-jobs max-jobs
- :max-procs max-procs
:max-items max-items)
(add-watch stats :progress-report (report-progress-teams tpoint on-progress))
(binding [feat/*stats* stats
- feat/*skip-on-error* skip-on-error]
+ feat/*cache* cache
+ svgo/*semaphore* sprocs]
(try
(when (fn? on-start)
- (on-start {:total total :rollback rollback?}))
+ (on-start {:rollback rollback?}))
- (db/tx-run! system
- (fn [{:keys [::db/conn]}]
- (run! (partial migrate-team)
- (->> (get-teams conn)
- (take max-items)))))
- (try
- (p/await! scope)
- (finally
- (pu/close! scope)))
+ (when (string? label)
+ (create-report-table! main/system)
+ (clean-reports! main/system label))
+ (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! process-team
+ (->> (get-teams conn query pred)
+ (filter (fn [team-id]
+ (if (int? partitions)
+ (= current-partition (-> (uuid/hash-int team-id)
+ (mod partitions)
+ (inc)))
+ true)))
+ (take max-items)))
+
+ ;; Close and await tasks
+ (pu/close! executor)))
(if (fn? on-end)
(-> (deref stats)
diff --git a/backend/src/app/srepl/helpers.clj b/backend/src/app/srepl/helpers.clj
index f1a267e48d..5e2a26ee96 100644
--- a/backend/src/app/srepl/helpers.clj
+++ b/backend/src/app/srepl/helpers.clj
@@ -69,7 +69,8 @@
(fn [system]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer system id)]
(-> (files/get-file system id :migrate? migrate?)
- (update :data feat.fdata/process-pointers deref))))))
+ (update :data feat.fdata/process-pointers deref)
+ (update :data feat.fdata/process-objects (partial into {})))))))
(defn validate
"Validate structure, referencial integrity and semantic coherence of
diff --git a/backend/src/app/storage/s3.clj b/backend/src/app/storage/s3.clj
index e019ad2676..1bbb38b16a 100644
--- a/backend/src/app/storage/s3.clj
+++ b/backend/src/app/storage/s3.clj
@@ -51,6 +51,7 @@
software.amazon.awssdk.services.s3.model.DeleteObjectsRequest
software.amazon.awssdk.services.s3.model.DeleteObjectsResponse
software.amazon.awssdk.services.s3.model.GetObjectRequest
+ software.amazon.awssdk.services.s3.model.NoSuchKeyException
software.amazon.awssdk.services.s3.model.ObjectIdentifier
software.amazon.awssdk.services.s3.model.PutObjectRequest
software.amazon.awssdk.services.s3.model.S3Error
@@ -126,17 +127,19 @@
(defmethod impl/get-object-data :s3
[backend object]
(us/assert! ::backend backend)
- (letfn [(no-such-key? [cause]
- (instance? software.amazon.awssdk.services.s3.model.NoSuchKeyException cause))
- (handle-not-found [cause]
- (ex/raise :type :not-found
- :code :object-not-found
- :hint "s3 object not found"
- :cause cause))]
- (-> (get-object-data backend object)
- (p/catch no-such-key? handle-not-found)
- (p/await!))))
+ (let [result (p/await (get-object-data backend object))]
+ (if (ex/exception? result)
+ (cond
+ (ex/instance? NoSuchKeyException result)
+ (ex/raise :type :not-found
+ :code :object-not-found
+ :hint "s3 object not found"
+ :cause result)
+ :else
+ (throw result))
+
+ result)))
(defmethod impl/get-object-bytes :s3
[backend object]
@@ -298,7 +301,7 @@
[path]
(proxy [FilterInputStream] [(io/input-stream path)]
(close []
- (fs/delete path)
+ (ex/ignoring (fs/delete path))
(proxy-super close))))
(defn- get-object-data
diff --git a/backend/src/app/svgo.clj b/backend/src/app/svgo.clj
index 70d7c6b2b3..a846fa7680 100644
--- a/backend/src/app/svgo.clj
+++ b/backend/src/app/svgo.clj
@@ -7,16 +7,10 @@
(ns app.svgo
"A SVG Optimizer service"
(:require
- [app.common.data :as d]
- [app.common.data.macros :as dm]
[app.common.jsrt :as jsrt]
[app.common.logging :as l]
- [app.common.spec :as us]
[app.worker :as-alias wrk]
- [clojure.spec.alpha :as s]
[integrant.core :as ig]
- [promesa.exec :as px]
- [promesa.exec.bulkhead :as bh]
[promesa.exec.semaphore :as ps]
[promesa.util :as pu]))
@@ -26,40 +20,23 @@
nil)
(defn optimize
- [system data]
- (dm/assert! "expect data to be a string" (string? data))
-
- (letfn [(optimize-fn [pool]
- (jsrt/run! pool
- (fn [context]
- (jsrt/set! context "svgData" data)
- (jsrt/eval! context "penpotSvgo.optimize(svgData, {plugins: ['safeAndFastPreset']})"))))]
- (try
- (some-> *semaphore* ps/acquire!)
- (let [{:keys [::jsrt/pool ::wrk/executor]} (::optimizer system)]
- (dm/assert! "expect optimizer instance" (jsrt/pool? pool))
- (px/invoke! executor (partial optimize-fn pool)))
- (finally
- (some-> *semaphore* ps/release!)))))
-
-(s/def ::max-procs (s/nilable ::us/integer))
-
-(defmethod ig/pre-init-spec ::optimizer [_]
- (s/keys :req [::wrk/executor ::max-procs]))
-
-(defmethod ig/prep-key ::optimizer
- [_ cfg]
- (merge {::max-procs 20} (d/without-nils cfg)))
+ [{pool ::optimizer} data]
+ (try
+ (some-> *semaphore* ps/acquire!)
+ (jsrt/run! pool
+ (fn [context]
+ (jsrt/set! context "svgData" data)
+ (jsrt/eval! context "penpotSvgo.optimize(svgData, {plugins: ['safeAndFastPreset']})")))
+ (finally
+ (some-> *semaphore* ps/release!))))
(defmethod ig/init-key ::optimizer
- [_ {:keys [::wrk/executor ::max-procs]}]
- (l/inf :hint "initializing svg optimizer pool" :max-procs max-procs)
- (let [init (jsrt/resource->source "app/common/svg/optimizer.js")
- executor (bh/create :type :executor :executor executor :permits max-procs)]
- {::jsrt/pool (jsrt/pool :init init)
- ::wrk/executor executor}))
+ [_ _]
+ (l/inf :hint "initializing svg optimizer pool")
+ (let [init (jsrt/resource->source "app/common/svg/optimizer.js")]
+ (jsrt/pool :init init)))
(defmethod ig/halt-key! ::optimizer
- [_ {:keys [::jsrt/pool]}]
+ [_ pool]
(l/info :hint "stopping svg optimizer pool")
(pu/close! pool))
diff --git a/backend/src/app/util/cache.clj b/backend/src/app/util/cache.clj
index c5aa733e6f..65861e1797 100644
--- a/backend/src/app/util/cache.clj
+++ b/backend/src/app/util/cache.clj
@@ -9,61 +9,71 @@
(:refer-clojure :exclude [get])
(:require
[app.util.time :as dt]
- [promesa.core :as p]
[promesa.exec :as px])
(:import
com.github.benmanes.caffeine.cache.AsyncCache
- com.github.benmanes.caffeine.cache.AsyncLoadingCache
- com.github.benmanes.caffeine.cache.CacheLoader
+ com.github.benmanes.caffeine.cache.Cache
com.github.benmanes.caffeine.cache.Caffeine
com.github.benmanes.caffeine.cache.RemovalListener
+ com.github.benmanes.caffeine.cache.stats.CacheStats
java.time.Duration
java.util.concurrent.Executor
java.util.function.Function))
(set! *warn-on-reflection* true)
-(defn create-listener
+(defprotocol ICache
+ (get [_ k] [_ k load-fn] "get cache entry")
+ (invalidate! [_] [_ k] "invalidate cache"))
+
+(defprotocol ICacheStats
+ (stats [_] "get stats"))
+
+(defn- create-listener
[f]
(reify RemovalListener
(onRemoval [_ key val cause]
(when val
(f key val cause)))))
-(defn create-loader
- [f]
- (reify CacheLoader
- (load [_ key]
- (f key))))
+(defn- get-stats
+ [^Cache cache]
+ (let [^CacheStats stats (.stats cache)]
+ {:hit-rate (.hitRate stats)
+ :hit-count (.hitCount stats)
+ :req-count (.requestCount stats)
+ :miss-count (.missCount stats)
+ :miss-rate (.missRate stats)}))
(defn create
- [& {:keys [executor on-remove load-fn keepalive]}]
- (as-> (Caffeine/newBuilder) builder
- (if on-remove (.removalListener builder (create-listener on-remove)) builder)
- (if executor (.executor builder ^Executor (px/resolve-executor executor)) builder)
- (if keepalive (.expireAfterAccess builder ^Duration (dt/duration keepalive)) builder)
- (if load-fn
- (.buildAsync builder ^CacheLoader (create-loader load-fn))
- (.buildAsync builder))))
+ [& {:keys [executor on-remove max-size keepalive]}]
+ (let [cache (as-> (Caffeine/newBuilder) builder
+ (if (fn? on-remove) (.removalListener builder (create-listener on-remove)) builder)
+ (if executor (.executor builder ^Executor (px/resolve-executor executor)) builder)
+ (if keepalive (.expireAfterAccess builder ^Duration (dt/duration keepalive)) builder)
+ (if (int? max-size) (.maximumSize builder (long max-size)) builder)
+ (.recordStats builder)
+ (.buildAsync builder))
+ cache (.synchronous ^AsyncCache cache)]
+ (reify
+ ICache
+ (get [_ k]
+ (.getIfPresent ^Cache cache ^Object k))
+ (get [_ k load-fn]
+ (.get ^Cache cache
+ ^Object k
+ ^Function (reify Function
+ (apply [_ k]
+ (load-fn k)))))
+ (invalidate! [_]
+ (.invalidateAll ^Cache cache))
+ (invalidate! [_ k]
+ (.invalidateAll ^Cache cache ^Object k))
-(defn invalidate-all!
- [^AsyncCache cache]
- (.invalidateAll (.synchronous cache)))
-
-(defn get
- ([cache key]
- (assert (instance? AsyncLoadingCache cache) "should be AsyncLoadingCache instance")
- (p/await! (.get ^AsyncLoadingCache cache ^Object key)))
- ([cache key not-found-fn]
- (assert (instance? AsyncCache cache) "should be AsyncCache instance")
- (p/await! (.get ^AsyncCache cache
- ^Object key
- ^Function (reify
- Function
- (apply [_ key]
- (not-found-fn key)))))))
+ ICacheStats
+ (stats [_]
+ (get-stats cache)))))
(defn cache?
[o]
- (or (instance? AsyncCache o)
- (instance? AsyncLoadingCache o)))
+ (satisfies? ICache o))
diff --git a/backend/src/app/util/pointer_map.clj b/backend/src/app/util/pointer_map.clj
index 6e8e76b828..bb7b252939 100644
--- a/backend/src/app/util/pointer_map.clj
+++ b/backend/src/app/util/pointer_map.clj
@@ -166,32 +166,36 @@
(assoc [this key val]
(when-not loaded? (load! this))
- (let [odata (assoc odata key val)
- mdata (assoc mdata :created-at (dt/now))
- id (if modified? id (uuid/next))
- pmap (PointerMap. id
- mdata
- odata
- true
- true)]
- (some-> *tracked* (swap! assoc id pmap))
- pmap))
+ (let [odata' (assoc odata key val)]
+ (if (identical? odata odata')
+ this
+ (let [mdata (assoc mdata :created-at (dt/now))
+ id (if modified? id (uuid/next))
+ pmap (PointerMap. id
+ mdata
+ odata'
+ true
+ true)]
+ (some-> *tracked* (swap! assoc id pmap))
+ pmap))))
(assocEx [_ _ _]
(throw (UnsupportedOperationException. "method not implemented")))
(without [this key]
(when-not loaded? (load! this))
- (let [odata (dissoc odata key)
- mdata (assoc mdata :created-at (dt/now))
- id (if modified? id (uuid/next))
- pmap (PointerMap. id
- mdata
- odata
- true
- true)]
- (some-> *tracked* (swap! assoc id pmap))
- pmap))
+ (let [odata' (dissoc odata key)]
+ (if (identical? odata odata')
+ this
+ (let [mdata (assoc mdata :created-at (dt/now))
+ id (if modified? id (uuid/next))
+ pmap (PointerMap. id
+ mdata
+ odata'
+ true
+ true)]
+ (some-> *tracked* (swap! assoc id pmap))
+ pmap))))
Counted
(count [this]
@@ -206,6 +210,8 @@
(defn create
([]
(let [id (uuid/next)
+
+
mdata (assoc *metadata* :created-at (dt/now))
pmap (PointerMap. id mdata {} true true)]
(some-> *tracked* (swap! assoc id pmap))
@@ -225,7 +231,15 @@
(do
(some-> *tracked* (swap! assoc (get-id data) data))
data)
- (into (create) data)))
+ (let [mdata (assoc (meta data) :created-at (dt/now))
+ id (uuid/next)
+ pmap (PointerMap. id
+ mdata
+ data
+ true
+ true)]
+ (some-> *tracked* (swap! assoc id pmap))
+ pmap)))
(fres/add-handlers!
{:name "penpot/pointer-map/v1"
diff --git a/backend/src/app/util/time.clj b/backend/src/app/util/time.clj
index d3611d71e6..7785966245 100644
--- a/backend/src/app/util/time.clj
+++ b/backend/src/app/util/time.clj
@@ -123,7 +123,6 @@
FileTime
(inst-ms* [v] (.toMillis ^FileTime v)))
-
(defmethod print-method Duration
[mv ^java.io.Writer writer]
(.write writer (str "#app/duration \"" (str/lower (subs (str mv) 2)) "\"")))
diff --git a/backend/test/backend_tests/rpc_file_test.clj b/backend/test/backend_tests/rpc_file_test.clj
index 6be373a29c..510aadd892 100644
--- a/backend/test/backend_tests/rpc_file_test.clj
+++ b/backend/test/backend_tests/rpc_file_test.clj
@@ -166,18 +166,21 @@
:name "test"
:id page-id}])
- ;; Check the number of fragments
- (let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
- (t/is (= 2 (count rows))))
-
- ;; Check the number of fragments
- (let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
- (t/is (= 2 (count rows))))
-
- ;; The file-gc should remove unused fragments
+ ;; The file-gc should mark for remove unused fragments
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
+ ;; Check the number of fragments
+ (let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
+ (t/is (= 2 (count rows))))
+
+ ;; The objects-gc should remove unused fragments
+ (let [res (th/run-task! :objects-gc {:min-age 0})]
+ (t/is (= 0 (:processed res))))
+
+ ;; Check the number of fragments
+ (let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
+ (t/is (= 2 (count rows))))
;; Add shape to page that should add a new fragment
(update-file!
@@ -202,10 +205,14 @@
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(t/is (= 3 (count rows))))
- ;; The file-gc should remove unused fragments
+ ;; The file-gc should mark for remove unused fragments
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
+ ;; The objects-gc should remove unused fragments
+ (let [res (th/run-task! :objects-gc {:min-age 0})]
+ (t/is (= 0 (:processed res))))
+
;; Check the number of fragments; should be 3 because changes
;; are also holding pointers to fragments;
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
@@ -235,8 +242,6 @@
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(t/is (= 2 (count rows)))))))
-
-
(t/deftest file-gc-task-with-thumbnails
(letfn [(add-file-media-object [& {:keys [profile-id file-id]}]
(let [mfile {:filename "sample.jpg"
diff --git a/common/deps.edn b/common/deps.edn
index f8c649fab6..61c52e9099 100644
--- a/common/deps.edn
+++ b/common/deps.edn
@@ -32,7 +32,7 @@
funcool/tubax {:mvn/version "2021.05.20-0"}
funcool/cuerdas {:mvn/version "2023.11.09-407"}
- funcool/promesa {:git/sha "484b7f5c0d08d817746caa685ed9ac5583eb37fa"
+ funcool/promesa {:git/sha "0c5ed6ad033515a2df4b55addea044f60e9653d0"
:git/url "https://github.com/funcool/promesa"}
funcool/datoteka {:mvn/version "3.0.66"
diff --git a/common/src/app/common/data.cljc b/common/src/app/common/data.cljc
index d814b14392..12e3f7762b 100644
--- a/common/src/app/common/data.cljc
+++ b/common/src/app/common/data.cljc
@@ -7,7 +7,7 @@
(ns app.common.data
"A collection if helpers for working with data structures and other
data resources."
- (:refer-clojure :exclude [read-string hash-map merge name update-vals
+ (:refer-clojure :exclude [read-string hash-map merge name
parse-double group-by iteration concat mapcat
parse-uuid max min])
#?(:cljs
@@ -216,12 +216,19 @@
[coll]
(into [] (remove nil?) coll))
+
(defn without-nils
"Given a map, return a map removing key-value
pairs when value is `nil`."
- ([] (remove (comp nil? val)))
+ ([]
+ (remove (comp nil? val)))
([data]
- (into {} (without-nils) data)))
+ (reduce-kv (fn [data k v]
+ (if (nil? v)
+ (dissoc data k)
+ data))
+ data
+ data)))
(defn without-qualified
([]
diff --git a/common/src/app/common/exceptions.cljc b/common/src/app/common/exceptions.cljc
index b01914ca56..2070986fe3 100644
--- a/common/src/app/common/exceptions.cljc
+++ b/common/src/app/common/exceptions.cljc
@@ -7,10 +7,12 @@
(ns app.common.exceptions
"A helpers for work with exceptions."
#?(:cljs (:require-macros [app.common.exceptions]))
+ (:refer-clojure :exclude [instance?])
(:require
#?(:clj [clojure.stacktrace :as strace])
[app.common.pprint :as pp]
[app.common.schema :as sm]
+ [clojure.core :as c]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[expound.alpha :as expound])
@@ -20,6 +22,9 @@
#?(:clj (set! *warn-on-reflection* true))
+(def ^:dynamic *data-length* 8)
+(def ^:dynamic *data-level* 8)
+
(defmacro error
[& {:keys [type hint] :as params}]
`(ex-info ~(or hint (name type))
@@ -49,20 +54,38 @@
(defn ex-info?
[v]
- (instance? #?(:clj clojure.lang.IExceptionInfo :cljs cljs.core.ExceptionInfo) v))
+ (c/instance? #?(:clj clojure.lang.IExceptionInfo :cljs cljs.core.ExceptionInfo) v))
(defn error?
[v]
- (instance? #?(:clj clojure.lang.IExceptionInfo :cljs cljs.core.ExceptionInfo) v))
+ (c/instance? #?(:clj clojure.lang.IExceptionInfo :cljs cljs.core.ExceptionInfo) v))
(defn exception?
[v]
- (instance? #?(:clj java.lang.Throwable :cljs js/Error) v))
+ (c/instance? #?(:clj java.lang.Throwable :cljs js/Error) v))
#?(:clj
(defn runtime-exception?
[v]
- (instance? RuntimeException v)))
+ (c/instance? RuntimeException v)))
+
+#?(:clj
+ (defn instance?
+ [class cause]
+ (loop [cause cause]
+ (if (c/instance? class cause)
+ true
+ (if-let [cause (ex-cause cause)]
+ (recur cause)
+ false)))))
+
+;; NOTE: idea for a macro for error handling
+;; (pu/try-let [cause (p/await (get-object-data backend object))]
+;; (ex/instance? NoSuchKeyException cause)
+;; (ex/raise :type :not-found
+;; :code :object-not-found
+;; :hint "s3 object not found"
+;; :cause cause))
(defn explain
[data & {:as opts}]
@@ -91,8 +114,8 @@
data? true
explain? true
chain? true
- data-length 8
- data-level 5}}]
+ data-length *data-length*
+ data-level *data-level*}}]
(letfn [(print-trace-element [^StackTraceElement e]
(let [class (.getClassName e)
diff --git a/common/src/app/common/files/defaults.cljc b/common/src/app/common/files/defaults.cljc
index 12e18921eb..e35914d73f 100644
--- a/common/src/app/common/files/defaults.cljc
+++ b/common/src/app/common/files/defaults.cljc
@@ -6,4 +6,4 @@
(ns app.common.files.defaults)
-(def version 38)
+(def version 44)
diff --git a/common/src/app/common/files/migrations.cljc b/common/src/app/common/files/migrations.cljc
index c5952d5718..39d448597c 100644
--- a/common/src/app/common/files/migrations.cljc
+++ b/common/src/app/common/files/migrations.cljc
@@ -19,9 +19,11 @@
[app.common.geom.shapes.text :as gsht]
[app.common.logging :as l]
[app.common.math :as mth]
+ [app.common.schema :as sm]
[app.common.svg :as csvg]
[app.common.text :as txt]
[app.common.types.shape :as cts]
+ [app.common.types.shape.shadow :as ctss]
[app.common.uuid :as uuid]
[cuerdas.core :as str]))
@@ -31,6 +33,10 @@
(defmulti migrate :version)
+(defn need-migration?
+ [{:keys [data]}]
+ (> cfd/version (:version data 0)))
+
(defn migrate-data
([data] (migrate-data data version))
([data to-version]
@@ -318,19 +324,21 @@
(= "#7B7D85" fill-color)))
(dissoc :fill-color :fill-opacity))))
- (update-container [{:keys [objects] :as container}]
- (loop [objects objects
- shapes (->> (vals objects)
- (filter cfh/image-shape?))]
- (if-let [shape (first shapes)]
- (let [{:keys [id frame-id] :as shape'} (process-shape shape)]
- (if (identical? shape shape')
- (recur objects (rest shapes))
- (recur (-> objects
- (assoc id shape')
- (d/update-when frame-id dissoc :thumbnail))
- (rest shapes))))
- (assoc container :objects objects))))]
+ (update-container [container]
+ (if (contains? container :objects)
+ (loop [objects (:objects container)
+ shapes (->> (vals objects)
+ (filter cfh/image-shape?))]
+ (if-let [shape (first shapes)]
+ (let [{:keys [id frame-id] :as shape'} (process-shape shape)]
+ (if (identical? shape shape')
+ (recur objects (rest shapes))
+ (recur (-> objects
+ (assoc id shape')
+ (d/update-when frame-id dissoc :thumbnail))
+ (rest shapes))))
+ (assoc container :objects objects)))
+ container))]
(-> data
(update :pages-index update-vals update-container)
@@ -380,7 +388,7 @@
(assign-fills)))
(update-container [container]
- (update container :objects update-vals update-object))]
+ (d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
@@ -409,7 +417,7 @@
(assoc :fills [])))
(update-container [container]
- (update container :objects update-vals update-object))]
+ (d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
@@ -424,7 +432,7 @@
(dissoc :position-data)))
(update-container [container]
- (update container :objects update-vals update-object))]
+ (d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
@@ -440,7 +448,7 @@
(dissoc :position-data)))
(update-container [container]
- (update container :objects update-vals update-object))]
+ (d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
@@ -527,7 +535,7 @@
(assoc object :frame-id calculated-frame-id)))
(update-container [container]
- (update container :objects #(update-vals % (partial update-object %))))]
+ (d/update-when container :objects #(update-vals % (partial update-object %))))]
(-> data
(update :pages-index update-vals update-container)
@@ -565,22 +573,7 @@
(update :content #(txt/transform-nodes invalid-node? fix-node %)))))
(update-container [container]
- (update container :objects update-vals update-object))]
-
- (-> data
- (update :pages-index update-vals update-container)
- (update :components update-vals update-container))))
-
-(defmethod migrate 30
- [data]
- (letfn [(update-object [object]
- (if (and (cfh/frame-shape? object)
- (not (:shapes object)))
- (assoc object :shapes [])
- object))
-
- (update-container [container]
- (update container :objects update-vals update-object))]
+ (d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
@@ -613,7 +606,8 @@
object)))
(update-container [container]
- (update container :objects update-vals update-object))]
+ (d/update-when container :objects update-vals update-object))]
+
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
@@ -624,13 +618,13 @@
;; Ensure all root objects are well formed shapes.
(if (= (:id object) uuid/zero)
(-> object
- (assoc :parent-id uuid/zero
- :frame-id uuid/zero)
+ (assoc :parent-id uuid/zero)
+ (assoc :frame-id uuid/zero)
(cts/setup-shape))
object))
(update-container [container]
- (update container :objects update-vals update-object))]
+ (d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container))))
@@ -642,7 +636,7 @@
(dissoc object :x :y :width :height)
object))
(update-container [container]
- (update container :objects update-vals update-object))]
+ (d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
@@ -694,8 +688,144 @@
shape)))
(update-container [container]
- (update container :objects update-vals update-shape))]
+ (d/update-when container :objects update-vals update-shape))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
+
+(defmethod migrate 39
+ [data]
+ (letfn [(update-shape [shape]
+ (if (and (cfh/bool-shape? shape)
+ (not (contains? shape :bool-content)))
+ (assoc shape :bool-content [])
+ shape))
+
+ (update-container [container]
+ (d/update-when container :objects update-vals update-shape))]
+
+ (-> data
+ (update :pages-index update-vals update-container)
+ (update :components update-vals update-container))))
+
+(defmethod migrate 40
+ [data]
+ (letfn [(update-shape [{:keys [content shapes] :as shape}]
+ ;; Fix frame shape that in reallity is a path shape
+ (if (and (cfh/frame-shape? shape)
+ (contains? shape :selrect)
+ (seq content)
+ (not (seq shapes))
+ (contains? (first content) :command))
+ (-> shape
+ (assoc :type :path)
+ (assoc :x nil)
+ (assoc :y nil)
+ (assoc :width nil)
+ (assoc :height nil))
+ shape))
+
+ (update-container [container]
+ (d/update-when container :objects update-vals update-shape))]
+
+ (-> data
+ (update :pages-index update-vals update-container)
+ (update :components update-vals update-container))))
+
+(defmethod migrate 41
+ [data]
+ (letfn [(update-shape [shape]
+ (cond
+ (or (cfh/bool-shape? shape)
+ (cfh/path-shape? shape))
+ shape
+
+ ;; Fix all shapes that has geometry broken but still
+ ;; preservers the selrect, so we recalculate the
+ ;; geometry from selrect.
+ (and (contains? shape :selrect)
+ (or (nil? (:x shape))
+ (nil? (:y shape))
+ (nil? (:width shape))
+ (nil? (:height shape))))
+ (let [selrect (:selrect shape)]
+ (-> shape
+ (assoc :x (:x selrect))
+ (assoc :y (:y selrect))
+ (assoc :width (:width selrect))
+ (assoc :height (:height selrect))))
+
+ :else
+ shape))
+
+ (update-container [container]
+ (d/update-when container :objects update-vals update-shape))]
+
+ (-> data
+ (update :pages-index update-vals update-container)
+ (update :components update-vals update-container))))
+
+(defmethod migrate 42
+ [data]
+ (letfn [(update-object [object]
+ (if (and (or (cfh/frame-shape? object)
+ (cfh/group-shape? object)
+ (cfh/bool-shape? object))
+ (not (:shapes object)))
+ (assoc object :shapes [])
+ object))
+
+ (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))))
+
+(def ^:private valid-fill?
+ (sm/lazy-validator ::cts/fill))
+
+(defmethod migrate 43
+ [data]
+ (letfn [(update-text-node [node]
+ (-> node
+ (d/update-when :fills #(filterv valid-fill? %))
+ (d/without-nils)))
+
+ (update-object [object]
+ (if (cfh/text-shape? object)
+ (update object :content #(txt/transform-nodes identity update-text-node %))
+ object))
+
+ (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))))
+
+(def ^:private valid-shadow?
+ (sm/lazy-validator ::ctss/shadow))
+
+(defmethod migrate 44
+ [data]
+ (letfn [(fix-shadow [shadow]
+ (if (string? (:color shadow))
+ (let [color {:color (:color shadow)
+ :opacity 1}]
+ (assoc shadow :color color))
+ shadow))
+
+ (update-object [object]
+ (d/update-when object :shadow
+ #(into []
+ (comp (map fix-shadow)
+ (filter valid-shadow?))
+ %)))
+
+ (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))))
diff --git a/common/src/app/common/files/repair.cljc b/common/src/app/common/files/repair.cljc
index 8aead05bc2..4a824682e9 100644
--- a/common/src/app/common/files/repair.cljc
+++ b/common/src/app/common/files/repair.cljc
@@ -66,6 +66,19 @@
(pcb/with-file-data file-data)
(pcb/update-shapes [(:parent-id shape)] repair-shape))))
+(defmethod repair-error :duplicated-children
+ [_ {:keys [shape page-id] :as error} file-data _]
+ (let [repair-shape
+ (fn [shape]
+ ; Remove duplicated
+ (log/debug :hint " -> remove duplicated children")
+ (update shape :shapes distinct))]
+
+ (log/dbg :hint "repairing shape :duplicated-children" :id (:id shape) :name (:name shape) :page-id page-id)
+ (-> (pcb/empty-changes nil page-id)
+ (pcb/with-file-data file-data)
+ (pcb/update-shapes [(:id shape)] repair-shape))))
+
(defmethod repair-error :child-not-found
[_ {:keys [shape page-id args] :as error} file-data _]
(let [repair-shape
diff --git a/common/src/app/common/files/validate.cljc b/common/src/app/common/files/validate.cljc
index 514e48ab16..01373f93c8 100644
--- a/common/src/app/common/files/validate.cljc
+++ b/common/src/app/common/files/validate.cljc
@@ -26,6 +26,7 @@
#{:invalid-geometry
:parent-not-found
:child-not-in-parent
+ :duplicated-children
:child-not-found
:frame-not-found
:invalid-frame
@@ -105,7 +106,7 @@
(nil? (:selrect shape))
(nil? (:points shape))))
(report-error :invalid-geometry
- "Shape greometry is invalid"
+ "Shape geometry is invalid"
shape file page)))
(defn- check-parent-children
@@ -123,6 +124,11 @@
(str/ffmt "Shape % not in parent's children list" (:id shape))
shape file page)))
+ (when-not (= (count (:shapes shape)) (count (distinct (:shapes shape))))
+ (report-error :duplicated-children
+ (str/ffmt "Shape % has duplicated children" (:id shape))
+ shape file page))
+
(doseq [child-id (:shapes shape)]
(let [child (ctst/get-shape page child-id)]
(if (nil? child)
@@ -367,64 +373,63 @@
[shape-id file page libraries & {:keys [context] :or {context :not-component}}]
(let [shape (ctst/get-shape page shape-id)]
(when (some? shape)
- (do
- (check-geometry shape file page)
- (check-parent-children shape file page)
- (check-frame shape file page)
+ (check-geometry shape file page)
+ (check-parent-children shape file page)
+ (check-frame shape file page)
- (if (ctk/instance-head? shape)
- (if (not= :frame (:type shape))
- (report-error :instance-head-not-frame
- "Instance head should be a frame"
+ (if (ctk/instance-head? shape)
+ (if (not= :frame (:type shape))
+ (report-error :instance-head-not-frame
+ "Instance head should be a frame"
+ shape file page)
+
+ (if (ctk/instance-root? shape)
+ (if (ctk/main-instance? shape)
+ (if (not= context :not-component)
+ (report-error :root-main-not-allowed
+ "Root main component not allowed inside other component"
+ shape file page)
+ (check-shape-main-root-top shape file page libraries))
+
+ (if (not= context :not-component)
+ (report-error :root-copy-not-allowed
+ "Root copy component not allowed inside other component"
+ shape file page)
+ (check-shape-copy-root-top shape file page libraries)))
+
+ (if (ctk/main-instance? shape)
+ ;; mains can't be nested into mains
+ (if (or (= context :not-component) (= context :main-top))
+ (report-error :nested-main-not-allowed
+ "Nested main component only allowed inside other component"
+ shape file page)
+ (check-shape-main-root-nested shape file page libraries))
+
+ (if (= context :not-component)
+ (report-error :nested-copy-not-allowed
+ "Nested copy component only allowed inside other component"
+ shape file page)
+ (check-shape-copy-root-nested shape file page libraries)))))
+
+ (if (ctk/in-component-copy? shape)
+ (if-not (#{:copy-top :copy-nested :copy-any} context)
+ (report-error :not-head-copy-not-allowed
+ "Non-root copy only allowed inside a copy"
shape file page)
+ (check-shape-copy-not-root shape file page libraries))
- (if (ctk/instance-root? shape)
- (if (ctk/main-instance? shape)
- (if (not= context :not-component)
- (report-error :root-main-not-allowed
- "Root main component not allowed inside other component"
- shape file page)
- (check-shape-main-root-top shape file page libraries))
-
- (if (not= context :not-component)
- (report-error :root-copy-not-allowed
- "Root copy component not allowed inside other component"
- shape file page)
- (check-shape-copy-root-top shape file page libraries)))
-
- (if (ctk/main-instance? shape)
- ;; mains can't be nested into mains
- (if (or (= context :not-component) (= context :main-top))
- (report-error :nested-main-not-allowed
- "Nested main component only allowed inside other component"
- shape file page)
- (check-shape-main-root-nested shape file page libraries))
-
- (if (= context :not-component)
- (report-error :nested-copy-not-allowed
- "Nested copy component only allowed inside other component"
- shape file page)
- (check-shape-copy-root-nested shape file page libraries)))))
-
- (if (ctk/in-component-copy? shape)
- (if-not (#{:copy-top :copy-nested :copy-any} context)
- (report-error :not-head-copy-not-allowed
- "Non-root copy only allowed inside a copy"
+ (if (ctn/inside-component-main? (:objects page) shape)
+ (if-not (#{:main-top :main-nested :main-any} context)
+ (report-error :not-head-main-not-allowed
+ "Non-root main only allowed inside a main component"
shape file page)
- (check-shape-copy-not-root shape file page libraries))
+ (check-shape-main-not-root shape file page libraries))
- (if (ctn/inside-component-main? (:objects page) shape)
- (if-not (#{:main-top :main-nested :main-any} context)
- (report-error :not-head-main-not-allowed
- "Non-root main only allowed inside a main component"
- shape file page)
- (check-shape-main-not-root shape file page libraries))
-
- (if (#{:main-top :main-nested :main-any} context)
- (report-error :not-component-not-allowed
- "Not compoments are not allowed inside a main"
- shape file page)
- (check-shape-not-component shape file page libraries)))))))))
+ (if (#{:main-top :main-nested :main-any} context)
+ (report-error :not-component-not-allowed
+ "Not compoments are not allowed inside a main"
+ shape file page)
+ (check-shape-not-component shape file page libraries))))))))
(defn- check-component
"Validate semantic coherence of a component. Report all errors found."
@@ -484,6 +489,9 @@
(sm/lazy-explainer ::ctf/data))
(defn validate-file-schema!
+ "Validates the file itself, without external dependencies, it
+ performs the schema checking and some semantical validation of the
+ content."
[{:keys [id data] :as file}]
(when-not (valid-fdata? data)
(ex/raise :type :validation
diff --git a/common/src/app/common/geom/shapes/path.cljc b/common/src/app/common/geom/shapes/path.cljc
index 018beaeb39..84f0b52418 100644
--- a/common/src/app/common/geom/shapes/path.cljc
+++ b/common/src/app/common/geom/shapes/path.cljc
@@ -981,6 +981,7 @@
selrect (-> points
(gco/transform-points points-center transform-inverse)
(grc/points->rect))]
+
[points selrect]))
(defn open-path?
diff --git a/common/src/app/common/schema.cljc b/common/src/app/common/schema.cljc
index 7fed63b77b..b1e743f643 100644
--- a/common/src/app/common/schema.cljc
+++ b/common/src/app/common/schema.cljc
@@ -14,6 +14,7 @@
[app.common.schema.generators :as sg]
[app.common.schema.openapi :as-alias oapi]
[app.common.schema.registry :as sr]
+ [app.common.time :as tm]
[app.common.uri :as u]
[app.common.uuid :as uuid]
[clojure.core :as c]
@@ -625,7 +626,8 @@
{:title "inst"
:description "Satisfies Inst protocol"
:error/message "expected to be number in safe range"
- :gen/gen (sg/small-int)
+ :gen/gen (->> (sg/small-int)
+ (sg/fmap (fn [v] (tm/instant v))))
::oapi/type "number"
::oapi/format "int64"}})
@@ -658,6 +660,9 @@
;; ---- PREDICATES
+(def valid-safe-number?
+ (lazy-validator ::safe-number))
+
(def check-safe-int!
(check-fn ::safe-int))
diff --git a/common/src/app/common/schema/generators.cljc b/common/src/app/common/schema/generators.cljc
index f1aa8c90fd..83e00bfd87 100644
--- a/common/src/app/common/schema/generators.cljc
+++ b/common/src/app/common/schema/generators.cljc
@@ -5,7 +5,7 @@
;; Copyright (c) KALEIDOS INC
(ns app.common.schema.generators
- (:refer-clojure :exclude [set subseq uuid for filter map])
+ (:refer-clojure :exclude [set subseq uuid for filter map let])
#?(:cljs (:require-macros [app.common.schema.generators]))
(:require
[app.common.schema.registry :as sr]
@@ -37,6 +37,10 @@
[& params]
`(tp/for-all ~@params))
+(defmacro let
+ [& params]
+ `(tg/let ~@params))
+
(defn check!
[p & {:keys [num] :or {num 20} :as options}]
(tc/quick-check num p (assoc options :reporter-fn default-reporter-fn :max-size 50)))
@@ -124,6 +128,10 @@
[f g]
(tg/fmap f g))
+(defn mcat
+ [f g]
+ (tg/bind g f))
+
(defn tuple
[& opts]
(apply tg/tuple opts))
diff --git a/common/src/app/common/svg.cljc b/common/src/app/common/svg.cljc
index 6bca95abab..e0c718362b 100644
--- a/common/src/app/common/svg.cljc
+++ b/common/src/app/common/svg.cljc
@@ -31,7 +31,7 @@
(def xml-id-regex #"#([:A-Z_a-z\xC0-\xD6\xD8-\xF6\xF8-\u02FF\u0370-\u037D\u037F-\u1FFF\u200C-\u200D\u2070-\u218F\u2C00-\u2FEF\u3001-\uD7FF\uF900-\uFDCF\uFDF0-\uFFFD\u10000-\uEFFFF][\.\-\:0-9\xB7A-Z_a-z\xC0-\xD6\xD8-\xF6\xF8-\u02FF\u0300-\u036F\u0370-\u037D\u037F-\u1FFF\u200C-\u200D\u203F-\u2040\u2070-\u218F\u2C00-\u2FEF\u3001-\uD7FF\uF900-\uFDCF\uFDF0-\uFFFD\u10000-\uEFFFF]*)")
(def matrices-regex #"(matrix|translate|scale|rotate|skewX|skewY)\(([^\)]*)\)")
-(def number-regex #"[+-]?\d*(\.\d+)?(e[+-]?\d+)?")
+(def number-regex #"[+-]?\d*(\.\d+)?([eE][+-]?\d+)?")
(def tags-to-remove #{:linearGradient :radialGradient :metadata :mask :clipPath :filter :title})
@@ -759,40 +759,39 @@
;; Transforms spec:
;; https://www.w3.org/TR/SVG11/single-page.html#coords-TransformAttribute
-(defn format-translate-params
+(defn- format-translate-params
[params]
(assert (or (= (count params) 1) (= (count params) 2)))
(if (= (count params) 1)
[(gpt/point (nth params 0) 0)]
[(gpt/point (nth params 0) (nth params 1))]))
-(defn format-scale-params
+(defn- format-scale-params
[params]
(assert (or (= (count params) 1) (= (count params) 2)))
(if (= (count params) 1)
[(gpt/point (nth params 0))]
[(gpt/point (nth params 0) (nth params 1))]))
-(defn format-rotate-params
+(defn- format-rotate-params
[params]
(assert (or (= (count params) 1) (= (count params) 3)) (str "??" (count params)))
(if (= (count params) 1)
[(nth params 0) (gpt/point 0 0)]
[(nth params 0) (gpt/point (nth params 1) (nth params 2))]))
-(defn format-skew-x-params
+(defn- format-skew-x-params
[params]
(assert (= (count params) 1))
[(nth params 0) 0])
-(defn format-skew-y-params
+(defn- format-skew-y-params
[params]
(assert (= (count params) 1))
[0 (nth params 0)])
-(defn to-matrix
- [{:keys [type params]}]
- (assert (#{"matrix" "translate" "scale" "rotate" "skewX" "skewY"} type))
+(defn- to-matrix
+ [type params]
(case type
"matrix" (apply gmt/matrix params)
"translate" (apply gmt/translate-matrix (format-translate-params params))
@@ -802,19 +801,17 @@
"skewY" (apply gmt/skew-matrix (format-skew-y-params params))))
(defn parse-transform
- [transform-attr]
- (if transform-attr
- (let [process-matrix
- (fn [[_ type params]]
- (let [params (->> (re-seq number-regex params)
- (filter #(-> % first seq))
- (map (comp d/parse-double first)))]
- {:type type :params params}))
+ [transform]
+ (if (string? transform)
+ (->> (re-seq matrices-regex transform)
+ (map (fn [[_ type params]]
+ (let [params (->> (re-seq number-regex params)
+ (map first)
+ (keep not-empty)
+ (map d/parse-double))]
+ (to-matrix type params))))
+ (reduce gmt/multiply (gmt/matrix)))
- matrices (->> (re-seq matrices-regex transform-attr)
- (map process-matrix)
- (map to-matrix))]
- (reduce gmt/multiply (gmt/matrix) matrices))
(gmt/matrix)))
(defn format-move [[x y]] (str "M" x " " y))
@@ -872,17 +869,21 @@
transform
(update :transform append-transform))))
-(defn inherit-attributes [group-attrs {:keys [attrs] :as node}]
+(defn inherit-attributes
+ [group-attrs {:keys [attrs] :as node}]
(if (map? node)
- (let [attrs (-> (format-styles attrs)
- (add-transform (:transform group-attrs)))
+ (let [attrs (-> (format-styles attrs)
+ (add-transform (:transform group-attrs)))
+ group-attrs (format-styles group-attrs)
;; Don't inherit a property that is already in the style attribute
inherit-style (-> (:style group-attrs) (d/without-keys (keys attrs)))
inheritable-props (->> inheritable-props (remove #(contains? (:styles attrs) %)))
group-attrs (-> group-attrs (assoc :style inherit-style))
- attrs (d/deep-merge (select-keys group-attrs inheritable-props) attrs)]
+ attrs (-> (select-keys group-attrs inheritable-props)
+ (d/deep-merge attrs)
+ (d/without-nils))]
(assoc node :attrs attrs))
node))
@@ -964,8 +965,7 @@
is-other? #{:r :stroke-width}]
(if is-percent?
- ;; JS parseFloat removes the % symbol
- (let [attr-num (d/parse-double attr-val)]
+ (let [attr-num (d/parse-double (str/rtrim attr-val "%"))]
(str (cond
(is-x? attr-key) (fix-coord :x :width attr-num)
(is-y? attr-key) (fix-coord :y :height attr-num)
@@ -981,7 +981,7 @@
(fix-percent-attr-numeric [_ attr-val]
(let [is-percent? (str/ends-with? attr-val "%")]
(if is-percent?
- (str (let [attr-num (d/parse-double attr-val)]
+ (str (let [attr-num (d/parse-double (str/rtrim attr-val "%"))]
(/ attr-num 100)))
attr-val)))
diff --git a/common/src/app/common/svg/shapes_builder.cljc b/common/src/app/common/svg/shapes_builder.cljc
index fc4b370ae7..343507f770 100644
--- a/common/src/app/common/svg/shapes_builder.cljc
+++ b/common/src/app/common/svg/shapes_builder.cljc
@@ -57,13 +57,15 @@
clean-value))
(defn- svg-dimensions
- [data]
- (let [width (dm/get-in data [:attrs :width] 100)
- height (dm/get-in data [:attrs :height] 100)
- viewbox (or (dm/get-in data [:attrs :viewBox])
+ [{:keys [attrs] :as data}]
+ (let [width (:width attrs 100)
+ height (:height attrs 100)
+ viewbox (or (:viewBox attrs)
(dm/str "0 0 " width " " height))
- [x y width height] (->> (str/split viewbox #"\s+")
+
+ [x y width height] (->> (str/split viewbox #"[\s,]+")
(map d/parse-double))
+
width (if (= width 0) 1 width)
height (if (= height 0) 1 height)]
@@ -303,6 +305,11 @@
rx (d/nilv r rx)
ry (d/nilv r ry)
+
+ ;; There are some svg circles in the internet that does not
+ ;; have cx and cy attrs, so we default them to 0
+ cx (d/nilv cx 0)
+ cy (d/nilv cy 0)
origin (gpt/negate (gpt/point svg-data))
rect (grc/make-rect
@@ -502,8 +509,16 @@
att-refs (csvg/find-attr-references attrs)
defs (get svg-data :defs)
references (csvg/find-def-references defs att-refs)
- href-id (-> (or (:href attrs) (:xlink:href attrs) " ") (subs 1))
- use-tag? (and (= :use tag) (contains? defs href-id))]
+
+ href-id (or (:href attrs) (:xlink:href attrs) " ")
+ href-id (if (and (string? href-id)
+ (pos? (count href-id)))
+ (subs href-id 1)
+ href-id)
+
+ use-tag? (and (= :use tag)
+ (some? href-id)
+ (contains? defs href-id))]
(if use-tag?
(let [;; Merge the data of the use definition with the properties passed as attributes
@@ -532,21 +547,20 @@
:image (create-image-shape name frame-id svg-data element)
#_other (create-raw-svg name frame-id svg-data element))]
-
(when (some? shape)
- (let [shape (-> shape
- (assoc :svg-defs (select-keys defs references))
- (setup-fill)
- (setup-stroke)
- (setup-opacity)
- (setup-other)
- (update :svg-attrs (fn [attrs]
- (if (empty? (:style attrs))
- (dissoc attrs :style)
- attrs))))]
- [(cond-> shape
- hidden (assoc :hidden true))
+ [(-> shape
+ (assoc :svg-defs (select-keys defs references))
+ (setup-fill)
+ (setup-stroke)
+ (setup-opacity)
+ (setup-other)
+ (update :svg-attrs (fn [attrs]
+ (if (empty? (:style attrs))
+ (dissoc attrs :style)
+ attrs)))
+ (cond-> ^boolean hidden
+ (assoc :hidden true)))
- (cond->> (:content element)
- (contains? csvg/parent-tags tag)
- (mapv #(csvg/inherit-attributes attrs %)))]))))))
+ (cond->> (:content element)
+ (contains? csvg/parent-tags tag)
+ (mapv (partial csvg/inherit-attributes attrs)))])))))
diff --git a/common/src/app/common/time.cljc b/common/src/app/common/time.cljc
index c32c82411e..6cd8601d66 100644
--- a/common/src/app/common/time.cljc
+++ b/common/src/app/common/time.cljc
@@ -4,16 +4,16 @@
;;
;; Copyright (c) KALEIDOS INC
-;; Here we put the time functions that are common between frontend and backend.
-;; In the future we may create an unified API for both.
-
(ns app.common.time
+ "A new cross-platform date and time API. It should be prefered over
+ a platform specific implementation found on `app.util.time`."
#?(:cljs
(:require
["luxon" :as lxn])
:clj
(:import
- java.time.Instant)))
+ java.time.Instant
+ java.time.Duration)))
#?(:cljs
(def DateTime lxn/DateTime))
@@ -24,4 +24,47 @@
(defn now
[]
#?(:clj (Instant/now)
- :cljs (.local ^js DateTime)))
\ No newline at end of file
+ :cljs (.local ^js DateTime)))
+
+(defn instant
+ [s]
+ #?(:clj (Instant/ofEpochMilli s)
+ :cljs (.fromMillis ^js DateTime s #js {:zone "local" :setZone false})))
+
+#?(:cljs
+ (extend-protocol IComparable
+ DateTime
+ (-compare [it other]
+ (if ^boolean (.equals it other)
+ 0
+ (if (< (inst-ms it) (inst-ms other)) -1 1)))
+
+ Duration
+ (-compare [it other]
+ (if ^boolean (.equals it other)
+ 0
+ (if (< (inst-ms it) (inst-ms other)) -1 1)))))
+
+
+#?(:cljs
+ (extend-type DateTime
+ cljs.core/IEquiv
+ (-equiv [o other]
+ (and (instance? DateTime other)
+ (== (.valueOf o) (.valueOf other))))))
+
+#?(:cljs
+ (extend-protocol cljs.core/Inst
+ DateTime
+ (inst-ms* [inst] (.toMillis ^js inst))
+
+ Duration
+ (inst-ms* [inst] (.toMillis ^js inst)))
+
+ :clj
+ (extend-protocol clojure.core/Inst
+ Duration
+ (inst-ms* [v] (.toMillis ^Duration v))
+
+ Instant
+ (inst-ms* [v] (.toEpochMilli ^Instant v))))
diff --git a/common/src/app/common/types/color.cljc b/common/src/app/common/types/color.cljc
index 8049628941..3a726d77a5 100644
--- a/common/src/app/common/types/color.cljc
+++ b/common/src/app/common/types/color.cljc
@@ -70,18 +70,20 @@
[:offset ::sm/safe-number]]]]])
(sm/define! ::color
- [:map {:title "Color"}
- [:id {:optional true} ::sm/uuid]
- [:name {:optional true} :string]
- [:path {:optional true} [:maybe :string]]
- [:value {:optional true} [:maybe :string]]
- [:color {:optional true} [:maybe ::rgb-color]]
- [:opacity {:optional true} [:maybe ::sm/safe-number]]
- [:modified-at {:optional true} ::sm/inst]
- [:ref-id {:optional true} ::sm/uuid]
- [:ref-file {:optional true} ::sm/uuid]
- [:gradient {:optional true} [:maybe ::gradient]]
- [:image {:optional true} [:maybe ::image-color]]])
+ [:and
+ [:map {:title "Color"}
+ [:id {:optional true} ::sm/uuid]
+ [:name {:optional true} :string]
+ [:path {:optional true} [:maybe :string]]
+ [:value {:optional true} [:maybe :string]]
+ [:color {:optional true} [:maybe ::rgb-color]]
+ [:opacity {:optional true} [:maybe ::sm/safe-number]]
+ [:modified-at {:optional true} ::sm/inst]
+ [:ref-id {:optional true} ::sm/uuid]
+ [:ref-file {:optional true} ::sm/uuid]
+ [:gradient {:optional true} [:maybe ::gradient]]
+ [:image {:optional true} [:maybe ::image-color]]]
+ [::sm/contains-any {:strict true} [:color :gradient :image]]])
(sm/define! ::recent-color
[:and
diff --git a/common/src/app/common/types/page.cljc b/common/src/app/common/types/page.cljc
index ec24c52a27..6c1d427dff 100644
--- a/common/src/app/common/types/page.cljc
+++ b/common/src/app/common/types/page.cljc
@@ -7,7 +7,6 @@
(ns app.common.types.page
(:require
[app.common.data :as d]
- [app.common.features :as cfeat]
[app.common.schema :as sm]
[app.common.types.color :as-alias ctc]
[app.common.types.grid :as ctg]
@@ -71,13 +70,9 @@
(defn make-empty-page
[id name]
- (let [wrap-objects-fn cfeat/*wrap-with-objects-map-fn*
- wrap-pointer-fn cfeat/*wrap-with-pointer-map-fn*]
- (-> empty-page-data
- (assoc :id id)
- (assoc :name name)
- (update :objects wrap-objects-fn)
- (wrap-pointer-fn))))
+ (-> empty-page-data
+ (assoc :id id)
+ (assoc :name name)))
;; --- Helpers for flow
diff --git a/common/src/app/common/types/shape.cljc b/common/src/app/common/types/shape.cljc
index 28289219d4..cdc7ccb163 100644
--- a/common/src/app/common/types/shape.cljc
+++ b/common/src/app/common/types/shape.cljc
@@ -25,6 +25,7 @@
[app.common.types.shape.export :as ctse]
[app.common.types.shape.interactions :as ctsi]
[app.common.types.shape.layout :as ctsl]
+ [app.common.types.shape.path :as ctsp]
[app.common.types.shape.shadow :as ctss]
[app.common.types.shape.text :as ctsx]
[app.common.uuid :as uuid]
@@ -46,6 +47,7 @@
:bool
:rect
:path
+ :text
:circle
:svg-raw
:image})
@@ -126,21 +128,24 @@
[:stroke-color-gradient {:optional true} ::ctc/gradient]
[:stroke-image {:optional true} ::ctc/image-color]])
-(sm/define! ::minimal-shape-attrs
+(sm/define! ::shape-base-attrs
[:map {:title "ShapeMinimalRecord"}
- [:id {:optional false} ::sm/uuid]
- [:name {:optional false} :string]
- [:type {:optional false} [::sm/one-of shape-types]]
- [:x {:optional false} [:maybe ::sm/safe-number]]
- [:y {:optional false} [:maybe ::sm/safe-number]]
- [:width {:optional false} [:maybe ::sm/safe-number]]
- [:height {:optional false} [:maybe ::sm/safe-number]]
- [:selrect {:optional false} ::selrect]
- [:points {:optional false} ::points]
- [:transform {:optional false} ::gmt/matrix]
- [:transform-inverse {:optional false} ::gmt/matrix]
- [:parent-id {:optional false} ::sm/uuid]
- [:frame-id {:optional false} ::sm/uuid]])
+ [:id ::sm/uuid]
+ [:name :string]
+ [:type [::sm/one-of shape-types]]
+ [:selrect ::selrect]
+ [:points ::points]
+ [:transform ::gmt/matrix]
+ [:transform-inverse ::gmt/matrix]
+ [:parent-id ::sm/uuid]
+ [:frame-id ::sm/uuid]])
+
+(sm/define! ::shape-geom-attrs
+ [:map {:title "ShapeGeometryAttrs"}
+ [:x ::sm/safe-number]
+ [:y ::sm/safe-number]
+ [:width ::sm/safe-number]
+ [:height ::sm/safe-number]])
(sm/define! ::shape-attrs
[:map {:title "ShapeAttrs"}
@@ -199,7 +204,7 @@
(sm/define! ::group-attrs
[:map {:title "GroupAttrs"}
[:type [:= :group]]
- [:shapes {:optional true} [:maybe [:vector {:gen/max 10 :gen/min 1} ::sm/uuid]]]])
+ [:shapes [:vector {:gen/max 10 :gen/min 1} ::sm/uuid]]])
(sm/define! ::frame-attrs
[:map {:title "FrameAttrs"}
@@ -212,7 +217,7 @@
(sm/define! ::bool-attrs
[:map {:title "BoolAttrs"}
[:type [:= :bool]]
- [:shapes {:optional true} [:maybe [:vector {:gen/max 10 :gen/min 1} ::sm/uuid]]]
+ [:shapes [:vector {:gen/max 10 :gen/min 1} ::sm/uuid]]
;; FIXME: improve this schema
[:bool-type :keyword]
@@ -252,16 +257,7 @@
(sm/define! ::path-attrs
[:map {:title "PathAttrs"}
[:type [:= :path]]
- [:x {:optional true} [:maybe ::sm/safe-number]]
- [:y {:optional true} [:maybe ::sm/safe-number]]
- [:width {:optional true} [:maybe ::sm/safe-number]]
- [:height {:optional true} [:maybe ::sm/safe-number]]
- [:content
- {:optional true}
- [:vector
- [:map
- [:command :keyword]
- [:params {:optional true} [:maybe :map]]]]]])
+ [:content ::ctsp/content]])
(sm/define! ::text-attrs
[:map {:title "TextAttrs"}
@@ -271,72 +267,96 @@
(sm/define! ::shape-map
[:multi {:dispatch :type :title "Shape"}
[:group
- [:merge {:title "GroupShape"}
+ [:and {:title "GroupShape"}
+ ::shape-base-attrs
+ ::shape-geom-attrs
::shape-attrs
- ::minimal-shape-attrs
::group-attrs
::ctsl/layout-child-attrs]]
[:frame
- [:merge {:title "FrameShape"}
- ::minimal-shape-attrs
+ [:and {:title "FrameShape"}
+ ::shape-base-attrs
+ ::shape-geom-attrs
::frame-attrs
::ctsl/layout-attrs
::ctsl/layout-child-attrs]]
[:bool
- [:merge {:title "BoolShape"}
+ [:and {:title "BoolShape"}
+ ::shape-base-attrs
::shape-attrs
- ::minimal-shape-attrs
::bool-attrs
::ctsl/layout-child-attrs]]
[:rect
- [:merge {:title "RectShape"}
+ [:and {:title "RectShape"}
+ ::shape-base-attrs
+ ::shape-geom-attrs
::shape-attrs
- ::minimal-shape-attrs
::rect-attrs
::ctsl/layout-child-attrs]]
[:circle
- [:merge {:title "CircleShape"}
+ [:and {:title "CircleShape"}
+ ::shape-base-attrs
+ ::shape-geom-attrs
::shape-attrs
- ::minimal-shape-attrs
::circle-attrs
::ctsl/layout-child-attrs]]
[:image
- [:merge {:title "ImageShape"}
+ [:and {:title "ImageShape"}
+ ::shape-base-attrs
+ ::shape-geom-attrs
::shape-attrs
- ::minimal-shape-attrs
::image-attrs
::ctsl/layout-child-attrs]]
[:svg-raw
- [:merge {:title "SvgRawShape"}
+ [:and {:title "SvgRawShape"}
+ ::shape-base-attrs
+ ::shape-geom-attrs
::shape-attrs
- ::minimal-shape-attrs
::svg-raw-attrs
::ctsl/layout-child-attrs]]
[:path
- [:merge {:title "PathShape"}
+ [:and {:title "PathShape"}
+ ::shape-base-attrs
::shape-attrs
- ::minimal-shape-attrs
::path-attrs
::ctsl/layout-child-attrs]]
[:text
- [:merge {:title "TextShape"}
+ [:and {:title "TextShape"}
+ ::shape-base-attrs
+ ::shape-geom-attrs
::shape-attrs
- ::minimal-shape-attrs
::text-attrs
::ctsl/layout-child-attrs]]])
(sm/define! ::shape
[:and
{:title "Shape"
- :gen/gen (->> (sg/generator ::shape-map)
+ :gen/gen (->> (sg/generator ::shape-base-attrs)
+ (sg/mcat (fn [{:keys [type] :as shape}]
+ (sg/let [attrs1 (sg/generator ::shape-attrs)
+ attrs2 (sg/generator ::shape-geom-attrs)
+ attrs3 (case type
+ :text (sg/generator ::text-attrs)
+ :path (sg/generator ::path-attrs)
+ :svg-raw (sg/generator ::svg-raw-attrs)
+ :image (sg/generator ::image-attrs)
+ :circle (sg/generator ::circle-attrs)
+ :rect (sg/generator ::rect-attrs)
+ :bool (sg/generator ::bool-attrs)
+ :group (sg/generator ::group-attrs)
+ :frame (sg/generator ::frame-attrs))]
+ (if (or (= type :path)
+ (= type :bool))
+ (merge attrs1 shape attrs3)
+ (merge attrs1 shape attrs2 attrs3)))))
(sg/fmap map->Shape))}
::shape-map
[:fn shape?]])
@@ -491,7 +511,12 @@
the shape. The props must have :x :y :width :height."
[{:keys [type] :as props}]
(let [shape (make-minimal-shape type)
- shape (merge shape (d/without-nils props))
+
+ ;; The props can be custom records that does not
+ ;; work properly with without-nils, so we first make
+ ;; it plain map for proceed
+ props (d/without-nils (into {} props))
+ shape (merge shape (d/without-nils (into {} props)))
shape (case (:type shape)
(:bool :path) (setup-path shape)
:image (-> shape setup-rect setup-image)
diff --git a/common/src/app/common/types/shape/path.cljc b/common/src/app/common/types/shape/path.cljc
new file mode 100644
index 0000000000..d633bb85c6
--- /dev/null
+++ b/common/src/app/common/types/shape/path.cljc
@@ -0,0 +1,47 @@
+;; 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.types.shape.path
+ (:require
+ [app.common.schema :as sm]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SCHEMA
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(sm/define! ::segment
+ [:multi {:title "PathSegment" :dispatch :command}
+ [:line-to
+ [:map
+ [:command [:= :line-to]]
+ [:params
+ [:map
+ [:x ::sm/safe-number]
+ [:y ::sm/safe-number]]]]]
+ [:close-path
+ [:map
+ [:command [:= :close-path]]]]
+ [:move-to
+ [:map
+ [:command [:= :move-to]]
+ [:params
+ [:map
+ [:x ::sm/safe-number]
+ [:y ::sm/safe-number]]]]]
+ [:curve-to
+ [:map
+ [:command [:= :curve-to]]
+ [:params
+ [:map
+ [:x ::sm/safe-number]
+ [:y ::sm/safe-number]
+ [:c1x ::sm/safe-number]
+ [:c1y ::sm/safe-number]
+ [:c2x ::sm/safe-number]
+ [:c2y ::sm/safe-number]]]]]])
+
+(sm/define! ::content
+ [:vector ::segment])
diff --git a/common/src/app/common/types/shape/shadow.cljc b/common/src/app/common/types/shape/shadow.cljc
index d04886fa3a..cc2fd81c3c 100644
--- a/common/src/app/common/types/shape/shadow.cljc
+++ b/common/src/app/common/types/shape/shadow.cljc
@@ -7,8 +7,7 @@
(ns app.common.types.shape.shadow
(:require
[app.common.schema :as sm]
- [app.common.types.color :as ctc]
- [app.common.types.shape.shadow.color :as-alias shadow-color]))
+ [app.common.types.color :as ctc]))
(def styles #{:drop-shadow :inner-shadow})
@@ -21,11 +20,4 @@
[:blur ::sm/safe-number]
[:spread ::sm/safe-number]
[:hidden :boolean]
- ;;FIXME: reuse color?
- [:color
- [:map
- [:color {:optional true} :string]
- [:opacity {:optional true} ::sm/safe-number]
- [:gradient {:optional true} [:maybe ::ctc/gradient]]
- [:file-id {:optional true} [:maybe ::sm/uuid]]
- [:id {:optional true} [:maybe ::sm/uuid]]]]])
+ [:color ::ctc/color]])
diff --git a/common/src/app/common/uuid.cljc b/common/src/app/common/uuid.cljc
index b205c64534..2086a0a5bd 100644
--- a/common/src/app/common/uuid.cljc
+++ b/common/src/app/common/uuid.cljc
@@ -75,3 +75,12 @@
with base62. It is only safe to use with uuid v4 and penpot custom v8"
[id]
(impl/short-v8 (dm/str id))))
+
+#?(:clj
+ (defn hash-int
+ [id]
+ (let [a (.getMostSignificantBits ^UUID id)
+ b (.getLeastSignificantBits ^UUID id)]
+ (+ (clojure.lang.Murmur3/hashLong a)
+ (clojure.lang.Murmur3/hashLong b)))))
+