Merge pull request #4024 from penpot/staging-migration

🐛 Bugfixes and enhancements to the components migration process

.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

backend/resources/log4j2-devenv.xml

@@ -30,7 +30,7 @@
     <Logger name="app.util.websocket" level="info" />
     <Logger name="app.redis" level="info" />
     <Logger name="app.rpc.rlimit" level="info" />
-    <Logger name="app.rpc.climit" level="info" />
+    <Logger name="app.rpc.climit" level="debug" />
     <Logger name="app.common.files.migrations" level="info" />
 
     <Logger name="app.loggers" level="debug" additivity="false">

backend/resources/log4j2-experiments.xml

@@ -0,0 +1,71 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<Configuration status="info" monitorInterval="30">
+  <Appenders>
+    <Console name="console" target="SYSTEM_OUT">
+      <PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] %level{length=1} %logger{36} - %msg%n"
+                     alwaysWriteExceptions="true" />
+    </Console>
+
+    <RollingFile name="main" fileName="logs/main.log" filePattern="logs/main-%i.log">
+      <PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] %level{length=1} %logger{36} - %msg%n"
+                     alwaysWriteExceptions="true" />
+      <Policies>
+        <SizeBasedTriggeringPolicy size="50M"/>
+      </Policies>
+      <DefaultRolloverStrategy max="9"/>
+    </RollingFile>
+
+    <RollingFile name="reports" fileName="logs/reports.log" filePattern="logs/reports-%i.log">
+      <PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] %level{length=1} %logger{36} - %msg%n"
+                     alwaysWriteExceptions="true" />
+      <Policies>
+        <SizeBasedTriggeringPolicy size="100M"/>
+      </Policies>
+      <DefaultRolloverStrategy max="9"/>
+    </RollingFile>
+  </Appenders>
+
+  <Loggers>
+    <Logger name="io.lettuce" level="error" />
+    <Logger name="com.zaxxer.hikari" level="error"/>
+    <Logger name="org.postgresql" level="error" />
+
+    <Logger name="app.rpc.commands.binfile" level="debug" />
+    <Logger name="app.storage.tmp" level="info" />
+    <Logger name="app.worker" level="trace" />
+    <Logger name="app.msgbus" level="info" />
+    <Logger name="app.http.websocket" level="info" />
+    <Logger name="app.http.sse" level="info" />
+    <Logger name="app.util.websocket" level="info" />
+    <Logger name="app.redis" level="info" />
+    <Logger name="app.rpc.rlimit" level="info" />
+    <Logger name="app.rpc.climit" level="debug" />
+    <Logger name="app.common.files.migrations" level="info" />
+
+    <Logger name="app.loggers" level="debug" additivity="false">
+      <AppenderRef ref="main" level="debug" />
+    </Logger>
+
+    <Logger name="app.features" level="all" additivity="true">
+      <AppenderRef ref="reports" level="warn" />
+      <!-- <AppenderRef ref="main" level="debug" /> -->
+    </Logger>
+
+    <Logger name="app.srepl" level="all" additivity="true">
+      <AppenderRef ref="reports" level="warn" />
+      <!-- <AppenderRef ref="main" level="trace" /> -->
+    </Logger>
+
+    <Logger name="app" level="all" additivity="false">
+      <AppenderRef ref="main" level="trace" />
+    </Logger>
+
+    <Logger name="user" level="trace" additivity="false">
+      <AppenderRef ref="main" level="trace" />
+    </Logger>
+
+    <Root level="info">
+      <AppenderRef ref="main" />
+    </Root>
+  </Loggers>
+</Configuration>

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

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
+                   ::tenant]))
-
-                   ::svgo-max-procs]))
 
 (def default-flags
   [:enable-backend-api-doc

backend/src/app/db.clj

@@ -517,9 +517,11 @@
 
 (defn rollback!
   ([conn]
-   (let [^Connection conn (get-connection conn)]
+   (if (and (map? conn) (::savepoint conn))
-     (l/trc :hint "explicit rollback requested")
+     (rollback! conn (::savepoint conn))
-     (.rollback 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)]
+        (let [system' (-> system
-          (release! conn sp)
+                          (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)
+      (let [system' (-> system
-            result (apply f system params)]
+                        (assoc ::conn conn)
+                        (dissoc ::rollback))
+            result  (apply f system' params)]
         (when (::rollback system)
           (rollback! conn))
         result))

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*
+(def ^:dynamic *cache*
-  "A dynamic var for setting up the default error behavior."
+  "A dynamic var for setting up a cache instance."
-  true)
+  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*
+(def ^:dynamic ^:private *team-id*
-  "A dynamic variable that can optionally indicates the maxumum number
+  "A dynamic var that holds the current processing team-id."
-  of concurrent graphics migration processes."
   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
+          ;; If the user has created a copy and then converted into a path or bool,
-          ;; undo the nested copy, converting it into a direct copy.
+          ;; 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]
+                    [container shape]
-                    (if (and (ctk/instance-head? shape)
+                    (if (or (and (ctk/instance-head? shape)
-                             (not (ctk/main-instance? shape))
+                                 (not (ctk/main-instance? shape))
-                             (not (ctk/in-component-copy? shape)))
+                                 (not (ctk/in-component-copy? shape)))
-                      (ctk/detach-shape 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 _
-              (catch Throwable cause
+                (let [team-id *team-id*]
-                (l/warn :hint "unexpected exception on processing internal image shape (skiping)"
+                  (l/wrn :hint "unable to process embedded images on svg file"
-                        :cause cause)
+                         :team-id (str team-id)
-                (when-not *skip-on-error*
+                         :file-id (str file-id)
-                  (throw cause)))))
+                         :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*)
+        sobject  (sto/get-object storage id)]
-        fmobject (db/get conn :file-media-object {:id id})
-        sobject  (sto/get-object storage (:media-id fmobject))]
-
     (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)
+  (let [get-svg (fn [sid]
-        svg-text (svgo/optimize *system* svg-text)
+                  (let [svg-text (get-sobject-content sid)
-        svg-data (-> (csvg/parse svg-text)
+                        svg-text (svgo/optimize *system* svg-text)]
-                     (assoc :name (:name mobj))
+                    (-> (csvg/parse svg-text)
-                     (collect-and-persist-images file-id))]
+                        (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]
+  (letfn [(process [fdata mobj position]
-                   (let [position (gpt/add position (gpt/point grid-gap grid-gap))
+            (let [position (gpt/add position (gpt/point grid-gap grid-gap))
-                         tp1      (dt/tpoint)]
+                  tp       (dt/tpoint)
-                     (try
+                  err      (volatile! false)]
-                       (process-media-object fdata page-id frame-id mobj position)
+              (try
-                       (catch Throwable cause
+                (let [changes (process-media-object fdata page-id frame-id mobj position)]
-                         (l/wrn :hint "unable to process file media object (skiping)"
+                  (cp/process-changes fdata changes false))
-                                :file-id (str (:id fdata))
+
-                                :id (str (:id mobj))
+                (catch Throwable cause
-                                :cause cause)
+                  (vreset! err true)
-                         (if-not *skip-on-error*
+                  (let [cause (pu/unwrap-exception cause)
-                           (throw cause)
+                        edata (ex-data cause)
-                           nil))
+                        team-id *team-id*]
-                       (finally
+                    (cond
-                         (l/trc :hint "graphic processed"
+                      (instance? org.xml.sax.SAXParseException cause)
-                                :file-id (str (:id fdata))
+                      (l/inf :hint "skip processing media object: invalid svg found"
-                                :media-id (str (:id mobj))
+                             :team-id (str team-id)
-                                :elapsed (dt/format-duration (tp1)))))))]
+                             :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))
+         (reduce (fn [fdata [mobj position]]
-         (mapcat (fn [partition]
+                   (sse/tap {:type :migration-progress
-                   (->> partition
+                             :section :graphics
-                        (map (fn [[mobj position]]
+                             :name (:name mobj)})
-                               (sse/tap {:type :migration-progress
+                   (or (process fdata mobj position) fdata))
-                                         :section :graphics
+                 (assoc-in fdata [:options :components-v2] true)))))
-                                         :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))))
 
 (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?]
+  [file libs]
-  (try
+  (cfv/validate-file! file libs)
-    (cfv/validate-file! file libs)
+  (cfv/validate-file-schema! file))
-    (cfv/validate-file-schema! file)
-    (catch Throwable cause
-      (if throw-on-validate?
-        (throw cause)
-        (l/wrn :hint "migrate:file:validation-error" :cause cause)))))
 
 (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]}]
+  [system file-id & {:keys [validate? skip-on-graphic-error? label]}]
-  (let [tpoint  (dt/tpoint)]
+  (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]
+                        (try
-                          (fsnap/take-file-snapshot! system {:file-id file-id :label "migration/components-v2"})
+                          (binding [*system* system]
-                          (process-file system file-id
+                            (when (string? label)
-                                        :validate? validate?
+                              (fsnap/take-file-snapshot! system {:file-id file-id
-                                        :throw-on-validate? throw-on-validate?)))))
+                                                                 :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}]
+        (fn [{:keys [::db/conn] :as system} team-id]
-          (let [features (-> features
+          (let [{:keys [id features]} (get-team system team-id)]
-                             (disj "ephimeral/v2-migration")
+            (if (contains? features "components/v2")
-                             (conj "components/v2")
+              (l/inf :hint "team already migrated")
-                             (conj "layout/grid")
+              (let [features (-> features
-                             (conj "styles/v2"))]
+                                 (disj "ephimeral/v2-migration")
+                                 (conj "components/v2")
+                                 (conj "layout/grid")
+                                 (conj "styles/v2"))]
 
-            (run! (partial migrate-file system)
+                (run! (partial migrate-file system)
-                  (get-and-lock-files conn id))
+                      (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/tx-run! system migrate-team team-id)
-                             (db/exec-one! system ["SET idle_in_transaction_session_timeout = 0"])
+
-                             (let [team (get-team system team-id)]
+        (catch Throwable cause
-                               (if (contains? (:features team) "components/v2")
+          (vreset! err true)
-                                 (l/inf :hint "team already migrated")
+          (throw cause))
-                                 (migrate-team system team)))))
+
         (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"
+            (if (cache/cache? *cache*)
-                   :team-id (dm/str team-id)
+              (let [cache-stats (cache/stats *cache*)]
-                   :files files
+                (l/dbg :hint "migrate:team:end"
-                   :components components
+                       :team-id (dm/str team-id)
-                   :graphics graphics
+                       :files files
-                   :elapsed (dt/format-duration elapsed))))))))
+                       :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)))))))))

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

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)

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

backend/src/app/rpc/climit.clj

@@ -36,24 +36,14 @@
   (-> (str id)
       (subs 1)))
 
-(defn- create-bulkhead-cache
+(defn- create-cache
-  [config]
+  [{:keys [::wrk/executor]}]
-  (letfn [(load-fn [[id skey]]
+  (letfn [(on-remove [key _ cause]
-            (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]
             (let [[id skey] key]
-              (l/trc :hint "evict from cache" :id (id->str id) :key skey :reason (str cause))))]
+              (l/dbg :hint "destroy limiter" :id (id->str id) :key skey :reason (str cause))))]
-
+    (cache/create :executor executor
-    (cache/create :executor :same-thread
                   :on-remove on-remove
-                  :keepalive "5m"
+                  :keepalive "5m")))
-                  :load-fn load-fn)))
 
 (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))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defn- create-limiter
-;; PUBLIC API
+  [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!
+(defn- invoke!
-  [cache metrics id key f]
+  [config cache metrics id key f]
-  (if-let [limiter (cache/get cache [id key])]
+  (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]
+  ([{:keys [::id ::cache ::config ::mtx/metrics]} f]
-   (if (and cache id)
+   (if-let [config (get config id)]
-     (invoke! cache metrics id nil f)
+     (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)
+     (if-let [config (get config id)]
-       (invoke! cache metrics id nil f)
+       (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))

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?)
-                                       :validate? validate?
-                                       :throw-on-validate? true)
 
             "fdata/shape-data-type"
             nil

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
+          ;; When file is migrated, we break the rule of no perform
-      ;; mutations on get operations and update the file with all
+          ;; mutations on get operations and update the file with all
-      ;; migrations applied
+          ;; migrations applied
-      ;;
+          ;;
-      ;; NOTE: the following code will not work on read-only mode, it
+          ;; WARN: he following code will not work on read-only mode,
-      ;; is a known issue; we keep is not implemented until we really
+          ;; it is a known issue; we keep is not implemented until we
-      ;; need this
+          ;; really need this.
-      (when (fmg/migrated? file)
+          file (if (contains? (:features file) "fdata/objects-map")
-        (db/update! conn :file
+                 (feat.fdata/enable-objects-map file)
-                    {:data (blob/encode (:data file))
+                 file)
-                     :features (db/create-array conn "text" (:features file))}
+          file (if (contains? (:features file) "fdata/pointer-map")
-                    {:id id})
+                 (feat.fdata/enable-pointer-map file)
+                 file)]
 
-        (when (contains? (:features file) "fdata/pointer-map")
+      (db/update! conn :file
-          (feat.fdata/persist-pointers! cfg id)))
+                  {: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)))
 

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)
+          data     (if create-page
-        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
                      (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)
+          file     {:id id
-                      (db/create-array conn "text"))
+                    :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
+          file     (if (contains? features "fdata/objects-map")
-                             (d/without-nils
+                     (feat.fdata/enable-objects-map file)
-                              {:id id
+                     file)
-                               :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}))]
 
-    (binding [pmap/*tracked* pointers]
+          file     (if (contains? features "fdata/pointer-map")
-      (feat.fdata/persist-pointers! cfg id))
+                     (feat.fdata/enable-pointer-map file)
+                     file)
 
-    (->> (assoc params :file-id id :role :owner)
+          file     (d/without-nils file)]
-         (create-file-role! conn))
 
-    (db/update! conn :project
+      (db/insert! conn :file
-                {:modified-at (dt/now)}
+                  (-> file
-                {:id project-id})
+                      (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"}

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))
+                                      (assoc :id (:id file)))))
-                                      (fmg/migrate-data)
+
-                                      (d/without-nils))))
+        ;; 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")
+      (contains? cfeat/*current* "fdata/objects-map")
-           (not (contains? cfeat/*previous* "fdata/objects-map")))
       (feat.fdata/enable-objects-map)
 
-      (and (contains? cfeat/*current* "fdata/pointer-map")
+      (contains? cfeat/*current* "fdata/pointer-map")
-           (not (contains? cfeat/*previous* "fdata/pointer-map")))
       (feat.fdata/enable-pointer-map)
 
       :always

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)
+      (let [elapsed (tpoint)]
-            completed (:processed/files newv)
-            progress  (/ (* completed 100.0) total)
-            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)
+      (let [completed (:processed/teams newv)
-            completed (:processed/teams newv)
-            progress  (/ (* completed 100.0) total)
-            progress  (str (int progress) "%")
             elapsed   (dt/format-duration (tpoint))]
-
         (when (fn? on-progress)
-          (on-progress {:total total
+          (on-progress {:elapsed elapsed
-                        :elapsed elapsed
+                        :completed completed}))
-                        :completed completed
-                        :progress progress}))
-
         (l/dbg :hint "progress"
                :completed completed
-               :progress progress
                :elapsed elapsed)))))
 
-(defn- get-total-files
+(def ^:private sql:get-teams-by-created-at
-  [pool & {:keys [team-id]}]
+  "WITH teams AS (
-  (if (some? team-id)
+     SELECT id, features
-    (let [sql (str/concat
+       FROM team
-               "SELECT count(f.id) AS count FROM file AS f "
+      WHERE deleted_at IS NULL
-               "  JOIN project AS p ON (p.id = f.project_id) "
+      ORDER BY created_at DESC
-               " WHERE p.team_id = ? AND f.deleted_at IS NULL "
+   ) SELECT * FROM TEAMS %(pred)s")
-               "  AND p.deleted_at IS NULL")
-          res (db/exec-one! pool [sql team-id])]
-      (:count res))
 
-    (let [sql (str/concat
+(def ^:private sql:get-teams-by-graphics
-               "SELECT count(id) AS count FROM file "
+  "WITH teams AS (
-               " WHERE deleted_at IS NULL")
+     SELECT t.id, t.features,
-          res (db/exec-one! pool [sql])]
+            (SELECT count(*)
-      (:count res))))
+               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
+(def ^:private sql:get-teams-by-activity
-  [pool]
+  "WITH teams AS (
-  (let [sql (str/concat
+     SELECT t.id, t.features,
-             "SELECT count(id) AS count FROM team "
+            (SELECT coalesce(max(date_trunc('month', f.modified_at)), date_trunc('month', t.modified_at))
-             " WHERE deleted_at IS NULL")
+               FROM file AS f
-        res (db/exec-one! pool [sql])]
+               JOIN project AS p ON (f.project_id = p.id)
-    (:count res)))
+              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!
+(defn- read-pred
-  [{:keys [::db/pool]} team-id]
+  [entries]
-  ;; We execute this out of transaction because we want this
+  (let [entries (if (and (vector? entries)
-  ;; change to be visible to all other sessions before starting
+                         (keyword? (first entries)))
-  ;; the migration
+                  [entries]
-  (let [sql (str "UPDATE team SET features = "
+                  entries)]
-                 "    array_append(features, 'ephimeral/v2-migration') "
+    (loop [params  []
-                 " WHERE id = ?")]
+           queries []
-    (db/exec-one! pool [sql team-id])))
+           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!
+        (let [sql (apply str "WHERE " (str/join " AND " queries))]
-  [{:keys [::db/pool]} team-id]
+          (apply vector sql params))))))
-  ;; 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")
 
 (defn- get-teams
-  [conn]
+  [conn query pred]
-  (->> (db/cursor conn sql:get-teams)
+  (let [query (d/nilv query :created-at)
-       (map feat/decode-row)))
+        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]
+  [file-id & {:keys [rollback? validate? label] :or {rollback? true validate? false}}]
-                     :or {rollback? true}}]
-
   (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?)
+        (-> (assoc main/system ::db/rollback rollback?)
-            (feat/migrate-file! file-id :max-procs max-procs))
+            (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]
+  [team-id & {:keys [rollback? skip-on-graphic-error? validate? label]
-                                             :or {rollback? true
+              :or {rollback? true
-                                                  skip-on-error true
+                   validate? true
-                                                  validate? false
+                   skip-on-graphic-error? false}}]
-                                                  max-procs 1}
-                                             :as opts}]
 
   (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 {})
-        stats     (atom {:total/files total})
         tpoint    (dt/tpoint)]
 
     (add-watch stats :progress-report (report-progress-files tpoint))
 
-    (binding [feat/*stats* stats
+    (binding [feat/*stats* stats]
-              feat/*skip-on-error* skip-on-error]
-
       (try
-        (mark-team-migration! system team-id)
+        (-> (assoc main/system ::db/rollback rollback?)
-
-        (-> (assoc 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
+  If you want to run this on multiple machines you will need to specify
-  graphics migration, the total of that procs is controled with the
+  the total number of partitions and the current partition.
-  `:max-procs` option.
 
-  Internally, the graphics migration process uses SVGO module which by
+  In order to get the report table populated, you will need to provide
-  default has a limited number of maximum concurent
+  a correct `:label`. That label is also used for persist a file
-  operations (globally), ensure setting up correct number with
+  snaphot before continue with the migration."
-  PENPOT_SVGO_MAX_PROCS environment variable."
+  [& {: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
+  (when (int? partitions)
-                                            rollback? validate? preset
+    (when-not (int? current-partition)
-                                            skip-on-error max-time
+      (throw (IllegalArgumentException. "missing `current-partition` parameter")))
-                                            on-start on-progress on-error on-end]
+    (when-not (<= 0 current-partition partitions)
-                                     :or {validate? false
+      (throw (IllegalArgumentException. "invalid value on `current-partition` parameter"))))
-                                          rollback? true
-                                          skip-on-error true
-                                          preset :shutdown-on-failure
-                                          max-jobs 1
-                                          max-procs 10
-                                          max-items Long/MAX_VALUE}
-                                     :as opts}]
 
-  (let [total  (get-total-teams pool)
+  (let [stats     (atom {})
-        stats  (atom {:total/teams (min total max-items)})
+        tpoint    (dt/tpoint)
+        mtime     (some-> max-time dt/duration)
 
-        tpoint (dt/tpoint)
+        factory   (px/thread-factory :virtual false :prefix "penpot/migration/")
-        mtime  (some-> max-time dt/duration)
+        executor  (px/cached-executor :factory factory)
 
-        scope  (px/structured-task-scope :preset preset :factory :virtual)
+        max-procs (or max-procs max-jobs)
-        sjobs  (ps/create :permits 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
+            (if (and mtime (neg? (compare mtime ts)))
-              (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")
+              (px/run! executor (partial migrate-team team-id)))))]
-                  (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))))))))]
 
     (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
+        (when (string? label)
-                    (fn [{:keys [::db/conn]}]
+          (create-report-table! main/system)
-                      (run! (partial migrate-team)
+          (clean-reports! main/system label))
-                            (->> (get-teams conn)
-                                 (take max-items)))))
-        (try
-          (p/await! scope)
-          (finally
-            (pu/close! scope)))
 
+        (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)

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

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)
+  (let [result (p/await (get-object-data backend object))]
-        (p/catch no-such-key? handle-not-found)
+    (if (ex/exception? result)
-        (p/await!))))
+      (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

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]
+  [{pool ::optimizer} data]
-  (dm/assert! "expect data to be a string" (string? data))
+  (try
-
+    (some-> *semaphore* ps/acquire!)
-  (letfn [(optimize-fn [pool]
+    (jsrt/run! pool
-            (jsrt/run! pool
+               (fn [context]
-                       (fn [context]
+                 (jsrt/set! context "svgData" data)
-                         (jsrt/set! context "svgData" data)
+                 (jsrt/eval! context "penpotSvgo.optimize(svgData, {plugins: ['safeAndFastPreset']})")))
-                         (jsrt/eval! context "penpotSvgo.optimize(svgData, {plugins: ['safeAndFastPreset']})"))))]
+    (finally
-    (try
+      (some-> *semaphore* ps/release!))))
-      (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)))
 
 (defmethod ig/init-key ::optimizer
-  [_ {:keys [::wrk/executor ::max-procs]}]
+  [_ _]
-  (l/inf :hint "initializing svg optimizer pool" :max-procs max-procs)
+  (l/inf :hint "initializing svg optimizer pool")
-  (let [init     (jsrt/resource->source "app/common/svg/optimizer.js")
+  (let [init (jsrt/resource->source "app/common/svg/optimizer.js")]
-        executor (bh/create :type :executor :executor executor :permits max-procs)]
+    (jsrt/pool :init init)))
-    {::jsrt/pool (jsrt/pool :init init)
-     ::wrk/executor executor}))
 
 (defmethod ig/halt-key! ::optimizer
-  [_ {:keys [::jsrt/pool]}]
+  [_ pool]
   (l/info :hint "stopping svg optimizer pool")
   (pu/close! pool))

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.Cache
-   com.github.benmanes.caffeine.cache.CacheLoader
    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
+(defn- get-stats
-  [f]
+  [^Cache cache]
-  (reify CacheLoader
+  (let [^CacheStats stats (.stats cache)]
-    (load [_ key]
+    {:hit-rate (.hitRate stats)
-      (f key))))
+     :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]}]
+  [& {:keys [executor on-remove max-size keepalive]}]
-  (as-> (Caffeine/newBuilder) builder
+  (let [cache (as-> (Caffeine/newBuilder) builder
-    (if on-remove (.removalListener builder (create-listener on-remove)) builder)
+                (if (fn? on-remove) (.removalListener builder (create-listener on-remove)) builder)
-    (if executor (.executor builder ^Executor (px/resolve-executor executor)) builder)
+                (if executor  (.executor builder ^Executor (px/resolve-executor executor)) builder)
-    (if keepalive (.expireAfterAccess builder ^Duration (dt/duration keepalive)) builder)
+                (if keepalive (.expireAfterAccess builder ^Duration (dt/duration keepalive)) builder)
-    (if load-fn
+                (if (int? max-size) (.maximumSize builder (long max-size)) builder)
-      (.buildAsync builder ^CacheLoader (create-loader load-fn))
+                (.recordStats builder)
-      (.buildAsync 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!
+      ICacheStats
-  [^AsyncCache cache]
+      (stats [_]
-  (.invalidateAll (.synchronous cache)))
+        (get-stats 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)))))))
 
 (defn cache?
   [o]
-  (or (instance? AsyncCache o)
+  (satisfies? ICache o))
-      (instance? AsyncLoadingCache o)))

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)
+    (let [odata' (assoc odata key val)]
-          mdata (assoc mdata :created-at (dt/now))
+      (if (identical? odata odata')
-          id    (if modified? id (uuid/next))
+        this
-          pmap  (PointerMap. id
+        (let [mdata (assoc mdata :created-at (dt/now))
-                             mdata
+              id    (if modified? id (uuid/next))
-                             odata
+              pmap  (PointerMap. id
-                             true
+                                 mdata
-                             true)]
+                                 odata'
-      (some-> *tracked* (swap! assoc id pmap))
+                                 true
-      pmap))
+                                 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)
+    (let [odata' (dissoc odata key)]
-          mdata (assoc mdata :created-at (dt/now))
+      (if (identical? odata odata')
-          id    (if modified? id (uuid/next))
+        this
-          pmap  (PointerMap. id
+        (let [mdata (assoc mdata :created-at (dt/now))
-                             mdata
+              id    (if modified? id (uuid/next))
-                             odata
+              pmap  (PointerMap. id
-                             true
+                                 mdata
-                             true)]
+                                 odata'
-      (some-> *tracked* (swap! assoc id pmap))
+                                 true
-      pmap))
+                                 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"

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)) "\"")))

backend/test/backend_tests/rpc_file_test.clj

@@ -166,18 +166,21 @@
          :name "test"
          :id page-id}])
 
-      ;; Check the number of fragments
+      ;; The file-gc should mark for remove unused 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
       (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"

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"

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

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-length *data-length*
-                               data-level 5}}]
+                               data-level *data-level*}}]
 
      (letfn [(print-trace-element [^StackTraceElement e]
                (let [class (.getClassName e)

common/src/app/common/files/defaults.cljc

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

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}]
+          (update-container [container]
-            (loop [objects objects
+            (if (contains? container :objects)
-                   shapes  (->> (vals objects)
+              (loop [objects (:objects container)
-                                (filter cfh/image-shape?))]
+                     shapes  (->> (vals objects)
-              (if-let [shape (first shapes)]
+                                  (filter cfh/image-shape?))]
-                (let [{:keys [id frame-id] :as shape'} (process-shape shape)]
+                (if-let [shape (first shapes)]
-                  (if (identical? shape shape')
+                  (let [{:keys [id frame-id] :as shape'} (process-shape shape)]
-                    (recur objects (rest shapes))
+                    (if (identical? shape shape')
-                    (recur (-> objects
+                      (recur objects (rest shapes))
-                               (assoc id shape')
+                      (recur (-> objects
-                               (d/update-when frame-id dissoc :thumbnail))
+                                 (assoc id shape')
-                           (rest shapes))))
+                                 (d/update-when frame-id dissoc :thumbnail))
-                (assoc container :objects objects))))]
+                             (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))]
+            (d/update-when 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))]
 
     (-> 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
+                  (assoc :parent-id uuid/zero)
-                         :frame-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))))

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

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-geometry shape file page)
+      (check-parent-children shape file page)
-        (check-parent-children shape file page)
+      (check-frame shape file page)
-        (check-frame shape file page)
 
-        (if (ctk/instance-head? shape)
+      (if (ctk/instance-head? shape)
-          (if (not= :frame (:type shape))
+        (if (not= :frame (:type shape))
-            (report-error :instance-head-not-frame
+          (report-error :instance-head-not-frame
-                          "Instance head should be a 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 (ctn/inside-component-main? (:objects page) shape)
-              (if (ctk/main-instance? shape)
+            (if-not (#{:main-top :main-nested :main-any} context)
-                (if (not= context :not-component)
+              (report-error :not-head-main-not-allowed
-                  (report-error :root-main-not-allowed
+                            "Non-root main only allowed inside a main component"
-                                "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))
+              (check-shape-main-not-root shape file page libraries))
 
-            (if (ctn/inside-component-main? (:objects page) shape)
+            (if (#{:main-top :main-nested :main-any} context)
-              (if-not (#{:main-top :main-nested :main-any} context)
+              (report-error :not-component-not-allowed
-                (report-error :not-head-main-not-allowed
+                            "Not compoments are not allowed inside a main"
-                              "Non-root main only allowed inside a main component"
+                            shape file page)
-                              shape file page)
+              (check-shape-not-component shape file page libraries))))))))
-                (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)))))))))
 
 (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

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?

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

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

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
+(defn- to-matrix
-  [{:keys [type params]}]
+  [type params]
-  (assert (#{"matrix" "translate" "scale" "rotate" "skewX" "skewY"} type))
   (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]
+  [transform]
-  (if transform-attr
+  (if (string? transform)
-    (let [process-matrix
+    (->> (re-seq matrices-regex transform)
-          (fn [[_ type params]]
+         (map (fn [[_ type params]]
-            (let [params (->> (re-seq number-regex params)
+                (let [params (->> (re-seq number-regex params)
-                              (filter #(-> % first seq))
+                                  (map first)
-                              (map (comp d/parse-double first)))]
+                                  (keep not-empty)
-              {:type type :params params}))
+                                  (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)
+    (let [attrs             (-> (format-styles attrs)
-                    (add-transform (:transform group-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 (str/rtrim attr-val "%"))]
-                  (let [attr-num (d/parse-double 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)))
 

common/src/app/common/svg/shapes_builder.cljc

@@ -57,13 +57,15 @@
     clean-value))
 
 (defn- svg-dimensions
-  [data]
+  [{:keys [attrs] :as data}]
-  (let [width   (dm/get-in data [:attrs :width] 100)
+  (let [width   (:width attrs 100)
-        height  (dm/get-in data [:attrs :height] 100)
+        height  (:height attrs 100)
-        viewbox (or (dm/get-in data [:attrs :viewBox])
+        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
+          [(-> shape
-                          (assoc :svg-defs (select-keys defs references))
+               (assoc :svg-defs (select-keys defs references))
-                          (setup-fill)
+               (setup-fill)
-                          (setup-stroke)
+               (setup-stroke)
-                          (setup-opacity)
+               (setup-opacity)
-                          (setup-other)
+               (setup-other)
-                          (update :svg-attrs (fn [attrs]
+               (update :svg-attrs (fn [attrs]
-                                               (if (empty? (:style attrs))
+                                    (if (empty? (:style attrs))
-                                                 (dissoc attrs :style)
+                                      (dissoc attrs :style)
-                                                 attrs))))]
+                                      attrs)))
-            [(cond-> shape
+               (cond-> ^boolean hidden
-               hidden (assoc :hidden true))
+                 (assoc :hidden true)))
 
-             (cond->> (:content element)
+           (cond->> (:content element)
-               (contains? csvg/parent-tags tag)
+             (contains? csvg/parent-tags tag)
-               (mapv #(csvg/inherit-attributes attrs %)))]))))))
+             (mapv (partial csvg/inherit-attributes attrs)))])))))

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)))
+     :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))))

common/src/app/common/types/color.cljc

@@ -70,18 +70,20 @@
       [:offset ::sm/safe-number]]]]])
 
 (sm/define! ::color
-  [:map {:title "Color"}
+  [:and
-   [:id {:optional true} ::sm/uuid]
+   [:map {:title "Color"}
-   [:name {:optional true} :string]
+    [:id {:optional true} ::sm/uuid]
-   [:path {:optional true} [:maybe :string]]
+    [:name {:optional true} :string]
-   [:value {:optional true} [:maybe :string]]
+    [:path {:optional true} [:maybe :string]]
-   [:color {:optional true} [:maybe ::rgb-color]]
+    [:value {:optional true} [:maybe :string]]
-   [:opacity {:optional true} [:maybe ::sm/safe-number]]
+    [:color {:optional true} [:maybe ::rgb-color]]
-   [:modified-at {:optional true} ::sm/inst]
+    [:opacity {:optional true} [:maybe ::sm/safe-number]]
-   [:ref-id {:optional true} ::sm/uuid]
+    [:modified-at {:optional true} ::sm/inst]
-   [:ref-file {:optional true} ::sm/uuid]
+    [:ref-id {:optional true} ::sm/uuid]
-   [:gradient {:optional true} [:maybe ::gradient]]
+    [:ref-file {:optional true} ::sm/uuid]
-   [:image {:optional true} [:maybe ::image-color]]])
+    [:gradient {:optional true} [:maybe ::gradient]]
+    [:image {:optional true} [:maybe ::image-color]]]
+   [::sm/contains-any {:strict true} [:color :gradient :image]]])
 
 (sm/define! ::recent-color
   [:and

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*
+  (-> empty-page-data
-        wrap-pointer-fn cfeat/*wrap-with-pointer-map-fn*]
+      (assoc :id id)
-    (-> empty-page-data
+      (assoc :name name)))
-        (assoc :id id)
-        (assoc :name name)
-        (update :objects wrap-objects-fn)
-        (wrap-pointer-fn))))
 
 ;; --- Helpers for flow
 

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]
+   [:id ::sm/uuid]
-   [:name {:optional false} :string]
+   [:name :string]
-   [:type {:optional false} [::sm/one-of shape-types]]
+   [:type [::sm/one-of shape-types]]
-   [:x {:optional false} [:maybe ::sm/safe-number]]
+   [:selrect ::selrect]
-   [:y {:optional false} [:maybe ::sm/safe-number]]
+   [:points ::points]
-   [:width {:optional false} [:maybe ::sm/safe-number]]
+   [:transform ::gmt/matrix]
-   [:height {:optional false} [:maybe ::sm/safe-number]]
+   [:transform-inverse ::gmt/matrix]
-   [:selrect {:optional false} ::selrect]
+   [:parent-id ::sm/uuid]
-   [:points {:optional false} ::points]
+   [:frame-id ::sm/uuid]])
-   [:transform {:optional false} ::gmt/matrix]
+
-   [:transform-inverse {:optional false} ::gmt/matrix]
+(sm/define! ::shape-geom-attrs
-   [:parent-id {:optional false} ::sm/uuid]
+  [:map {:title "ShapeGeometryAttrs"}
-   [:frame-id {:optional false} ::sm/uuid]])
+   [: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]]
+   [:content ::ctsp/content]])
-   [: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]]]]]])
 
 (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"}
+    [:and {:title "FrameShape"}
-     ::minimal-shape-attrs
+     ::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)

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

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.color :as ctc]))
-   [app.common.types.shape.shadow.color :as-alias shadow-color]))
 
 (def styles #{:drop-shadow :inner-shadow})
 
@@ -21,11 +20,4 @@
    [:blur ::sm/safe-number]
    [:spread ::sm/safe-number]
    [:hidden :boolean]
-    ;;FIXME: reuse color?
+   [:color ::ctc/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]]]]])

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