github/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2026-04-27 04:08:23 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #4024 from penpot/staging-migration

Browse Source 
🐛 Bugfixes and enhancements to the components migration process
This commit is contained in:
Andrey Antukh 2024-01-25 16:11:41 +01:00 committed by GitHub
commit faa4467b02
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
42 changed files with 1743 additions and 793 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.clj-kondo/config.edn
View File

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

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

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

71
backend/resources/log4j2-experiments.xml Normal file
View File

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

49
backend/scripts/repl-test Executable file
View File

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

5
backend/src/app/config.clj
View File

@ -209,7 +209,6 @@
(s/def ::telemetry-uri ::us/string)
(s/def ::telemetry-with-taiga ::us/boolean)
(s/def ::tenant ::us/string)
(s/def ::svgo-max-procs ::us/integer)
(s/def ::config
(s/keys :opt-un [::secret-key
@ -329,9 +328,7 @@
::telemetry-uri
::telemetry-referer
::telemetry-with-taiga
::tenant
::svgo-max-procs]))
::tenant]))
(def default-flags
[:enable-backend-api-doc

23
backend/src/app/db.clj
View File

@ -517,9 +517,11 @@
(defn rollback!
([conn]
(let [^Connection conn (get-connection conn)]
(l/trc :hint "explicit rollback requested")
(.rollback conn)))
(if (and (map? conn) (::savepoint conn))
(rollback! conn (::savepoint conn))
(let [^Connection conn (get-connection conn)]
(l/trc :hint "explicit rollback requested")
(.rollback conn))))
([conn ^Savepoint sp]
(let [^Connection conn (get-connection conn)]
(l/trc :hint "explicit rollback requested (savepoint)")
@ -538,8 +540,13 @@
(let [conn (::conn system)
sp (savepoint conn)]
(try
(let [result (apply f system params)]
(release! conn sp)
(let [system' (-> system
(assoc ::savepoint sp)
(dissoc ::rollback))
result (apply f system' params)]
(if (::rollback system)
(rollback! conn sp)
(release! conn sp))
result)
(catch Throwable cause
(.rollback ^Connection conn ^Savepoint sp)
@ -547,8 +554,10 @@
(::pool system)
(with-atomic [conn (::pool system)]
(let [system (assoc system ::conn conn)
result (apply f system params)]
(let [system' (-> system
(assoc ::conn conn)
(dissoc ::rollback))
result (apply f system' params)]
(when (::rollback system)
(rollback! conn))
result))

672
backend/src/app/features/components_v2.clj
View File

@ -16,21 +16,30 @@
[app.common.files.migrations :as fmg]
[app.common.files.shapes-helpers :as cfsh]
[app.common.files.validate :as cfv]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.geom.shapes.path :as gshp]
[app.common.logging :as l]
[app.common.math :as mth]
[app.common.schema :as sm]
[app.common.svg :as csvg]
[app.common.svg.shapes-builder :as sbuilder]
[app.common.types.color :as ctc]
[app.common.types.component :as ctk]
[app.common.types.components-list :as ctkl]
[app.common.types.container :as ctn]
[app.common.types.file :as ctf]
[app.common.types.page :as ctp]
[app.common.types.pages-list :as ctpl]
[app.common.types.shape :as cts]
[app.common.types.shape-tree :as ctst]
[app.common.types.shape.path :as ctsp]
[app.common.types.shape.text :as ctsx]
[app.common.uuid :as uuid]
[app.db :as db]
[app.db.sql :as sql]
[app.features.fdata :as fdata]
[app.http.sse :as sse]
[app.media :as media]
@ -41,29 +50,34 @@
[app.storage.tmp :as tmp]
[app.svgo :as svgo]
[app.util.blob :as blob]
[app.util.cache :as cache]
[app.util.pointer-map :as pmap]
[app.util.time :as dt]
[buddy.core.codecs :as bc]
[cuerdas.core :as str]
[datoteka.io :as io]
[promesa.core :as p]))
[promesa.exec :as px]
[promesa.util :as pu]))
(def ^:dynamic *stats*
"A dynamic var for setting up state for collect stats globally."
nil)
(def ^:dynamic *skip-on-error*
"A dynamic var for setting up the default error behavior."
true)
(def ^:dynamic *cache*
"A dynamic var for setting up a cache instance."
nil)
(def ^:dynamic *skip-on-graphic-error*
"A dynamic var for setting up the default error behavior for graphics processing."
nil)
(def ^:dynamic ^:private *system*
"An internal var for making the current `system` available to all
internal functions without the need to explicitly pass it top down."
nil)
(def ^:dynamic ^:private *max-procs*
"A dynamic variable that can optionally indicates the maxumum number
of concurrent graphics migration processes."
(def ^:dynamic ^:private *team-id*
"A dynamic var that holds the current processing team-id."
nil)
(def ^:dynamic ^:private *file-stats*
@ -91,21 +105,279 @@
;; FILE PREPARATION BEFORE MIGRATION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def valid-color? (sm/lazy-validator ::ctc/recent-color))
(def valid-fill? (sm/lazy-validator ::cts/fill))
(def valid-stroke? (sm/lazy-validator ::cts/stroke))
(def valid-flow? (sm/lazy-validator ::ctp/flow))
(def valid-text-content?
(sm/lazy-validator ::ctsx/content))
(def valid-path-content?
(sm/lazy-validator ::ctsp/content))
(def valid-path-segment?
(sm/lazy-validator ::ctsp/segment))
(def valid-rgb-color-string?
(sm/lazy-validator ::ctc/rgb-color))
(defn- prepare-file-data
"Apply some specific migrations or fixes to things that are allowed in v1 but not in v2,
or that are the result of old bugs."
[file-data libraries]
(let [detached-ids (volatile! #{})
detach-shape
(fn [container shape]
;; Detach a shape. If it's inside a component, add it to detached-ids, for further use.
;; Detach a shape. If it's inside a component, add it to detached-ids. This list
;; is used later to process any other copy that was referencing a detached copy.
(let [is-component? (let [root-shape (ctst/get-shape container (:id container))]
(and (some? root-shape) (nil? (:parent-id root-shape))))]
(when is-component?
(vswap! detached-ids conj (:id shape)))
(ctk/detach-shape shape)))
fix-bad-children
(fn [file-data]
;; Remove any child that does not exist. And also remove duplicated children.
(letfn [(fix-container
[container]
(d/update-when container :objects update-vals (partial fix-shape container)))
(fix-shape
[container shape]
(let [objects (:objects container)]
(d/update-when shape :shapes
(fn [shapes]
(->> shapes
(d/removev #(nil? (get objects %)))
(into [] (distinct)))))))]
(-> file-data
(update :pages-index update-vals fix-container)
(d/update-when :components update-vals fix-container))))
fix-missing-image-metadata
(fn [file-data]
;; Delete broken image shapes with no metadata.
(letfn [(fix-container
[container]
(d/update-when container :objects #(reduce-kv fix-shape % %)))
(fix-shape
[objects id shape]
(if (and (cfh/image-shape? shape)
(nil? (:metadata shape)))
(-> objects
(dissoc id)
(d/update-in-when [(:parent-id shape) :shapes]
(fn [shapes] (filterv #(not= id %) shapes))))
objects))]
(-> file-data
(update :pages-index update-vals fix-container)
(d/update-when :components update-vals fix-container))))
fix-page-invalid-options
(fn [file-data]
(letfn [(update-page [page]
(update page :options fix-options))
(fix-background [options]
(if (and (contains? options :background)
(not (valid-rgb-color-string? (:background options))))
(dissoc options :background)
options))
(fix-options [options]
(-> options
;; Some pages has invalid data on flows, we proceed just to
;; delete them.
(d/update-when :flows #(filterv valid-flow? %))
(fix-background)))]
(update file-data :pages-index update-vals update-page)))
delete-big-geometry-shapes
(fn [file-data]
;; At some point in time, we had a bug that generated shapes
;; with huge geometries that did not validate the
;; schema. Since we don't have a way to fix those shapes, we
;; simply proceed to delete it. We ignore path type shapes
;; because they have not been affected by the bug.
(letfn [(fix-container
[container]
(d/update-when container :objects #(reduce-kv fix-shape % %)))
(fix-shape
[objects id shape]
(cond
(or (cfh/path-shape? shape)
(cfh/bool-shape? shape))
objects
(or (and (number? (:x shape)) (not (sm/valid-safe-number? (:x shape))))
(and (number? (:y shape)) (not (sm/valid-safe-number? (:y shape))))
(and (number? (:width shape)) (not (sm/valid-safe-number? (:width shape))))
(and (number? (:height shape)) (not (sm/valid-safe-number? (:height shape)))))
(-> objects
(dissoc id)
(d/update-in-when [(:parent-id shape) :shapes]
(fn [shapes] (filterv #(not= id %) shapes))))
:else
objects))]
(-> file-data
(update :pages-index update-vals fix-container)
(d/update-when :components update-vals fix-container))))
fix-misc-shape-issues
(fn [file-data]
(letfn [(fix-container [container]
(d/update-when container :objects update-vals fix-shape))
(fix-shape [shape]
(cond-> shape
;; Some shapes has invalid gap value
(contains? shape :layout-gap)
(d/update-in-when [:layout-gap :column-gap]
(fn [gap]
(if (or (= gap ##Inf)
(= gap ##-Inf))
0
gap)))
;; Fix broken fills
(seq (:fills shape))
(update :fills (fn [fills] (filterv valid-fill? fills)))
;; Fix broken strokes
(seq (:strokes shape))
(update :strokes (fn [strokes] (filterv valid-stroke? strokes)))
;; Fix some broken layout related attrs, probably
;; of copypaste on flex layout betatest period
(true? (:layout shape))
(assoc :layout :flex)
(number? (:layout-gap shape))
(as-> shape (let [n (:layout-gap shape)]
(assoc shape :layout-gap {:row-gap n :column-gap n})))))]
(-> file-data
(update :pages-index update-vals fix-container)
(d/update-when :components update-vals fix-container))))
;; There are some bugs in the past that allows convert text to
;; path and this fix tries to identify this cases and fix them converting
;; the shape back to text shape
fix-text-shapes-converted-to-path
(fn [file-data]
(letfn [(fix-container [container]
(d/update-when container :objects update-vals fix-shape))
(fix-shape [shape]
(if (and (cfh/path-shape? shape)
(contains? shape :content)
(some? (:selrect shape))
(valid-text-content? (:content shape)))
(let [selrect (:selrect shape)]
(-> shape
(assoc :x (:x selrect))
(assoc :y (:y selrect))
(assoc :width (:width selrect))
(assoc :height (:height selrect))
(assoc :type :text)))
shape))]
(-> file-data
(update :pages-index update-vals fix-container)
(d/update-when :components update-vals fix-container))))
fix-broken-paths
(fn [file-data]
(letfn [(fix-container [container]
(d/update-when container :objects update-vals fix-shape))
(fix-shape [shape]
(cond
(and (cfh/path-shape? shape)
(seq (:content shape))
(not (valid-path-content? (:content shape))))
(let [shape (update shape :content fix-path-content)
[points selrect] (gshp/content->points+selrect shape (:content shape))]
(-> shape
(dissoc :bool-content)
(dissoc :bool-type)
(assoc :points points)
(assoc :selrect selrect)))
;; When we fount a bool shape with no content,
;; we convert it to a simple rect
(and (cfh/bool-shape? shape)
(not (seq (:bool-content shape))))
(let [selrect (or (:selrect shape)
(grc/make-rect))
points (grc/rect->points selrect)]
(-> shape
(assoc :x (:x selrect))
(assoc :y (:y selrect))
(assoc :width (:height selrect))
(assoc :height (:height selrect))
(assoc :selrect selrect)
(assoc :points points)
(assoc :type :rect)
(assoc :transform (gmt/matrix))
(assoc :transform-inverse (gmt/matrix))
(dissoc :bool-content)
(dissoc :shapes)
(dissoc :content)))
:else
shape))
(fix-path-content [content]
(let [[seg1 :as content] (filterv valid-path-segment? content)]
(if (and seg1 (not= :move-to (:command seg1)))
(let [params (select-keys (:params seg1) [:x :y])]
(into [{:command :move-to :params params}] content))
content)))]
(-> file-data
(update :pages-index update-vals fix-container)
(d/update-when :components update-vals fix-container))))
fix-recent-colors
(fn [file-data]
;; Remove invalid colors in :recent-colors
(d/update-when file-data :recent-colors
(fn [colors]
(filterv valid-color? colors))))
fix-broken-parents
(fn [file-data]
;; Find children shapes whose parent-id is not set to the parent that contains them.
;; Remove them from the parent :shapes list.
(letfn [(fix-container
[container]
(d/update-when container :objects #(reduce-kv fix-shape % %)))
(fix-shape
[objects id shape]
(reduce (fn [objects child-id]
(let [child (get objects child-id)]
(cond-> objects
(and (some? child) (not= id (:parent-id child)))
(d/update-in-when [id :shapes]
(fn [shapes] (filterv #(not= child-id %) shapes))))))
objects
(:shapes shape)))]
(-> file-data
(update :pages-index update-vals fix-container)
(d/update-when :components update-vals fix-container))))
fix-orphan-shapes
(fn [file-data]
;; Find shapes that are not listed in their parent's children list.
@ -127,13 +399,13 @@
(-> file-data
(update :pages-index update-vals fix-container)
(update :components update-vals fix-container))))
(d/update-when :components update-vals fix-container))))
remove-nested-roots
(fn [file-data]
;; Remove :component-root in head shapes that are nested.
(letfn [(fix-container [container]
(update container :objects update-vals (partial fix-shape container)))
(d/update-when container :objects update-vals (partial fix-shape container)))
(fix-shape [container shape]
(let [parent (ctst/get-shape container (:parent-id shape))]
@ -144,13 +416,13 @@
(-> file-data
(update :pages-index update-vals fix-container)
(update :components update-vals fix-container))))
(d/update-when :components update-vals fix-container))))
add-not-nested-roots
(fn [file-data]
;; Add :component-root in head shapes that are not nested.
(letfn [(fix-container [container]
(update container :objects update-vals (partial fix-shape container)))
(d/update-when container :objects update-vals (partial fix-shape container)))
(fix-shape [container shape]
(let [parent (ctst/get-shape container (:parent-id shape))]
@ -161,13 +433,13 @@
(-> file-data
(update :pages-index update-vals fix-container)
(update :components update-vals fix-container))))
(d/update-when :components update-vals fix-container))))
fix-orphan-copies
(fn [file-data]
;; Detach shapes that were inside a copy (have :shape-ref) but now they aren't.
(letfn [(fix-container [container]
(update container :objects update-vals (partial fix-shape container)))
(d/update-when container :objects update-vals (partial fix-shape container)))
(fix-shape [container shape]
(let [parent (ctst/get-shape container (:parent-id shape))]
@ -179,7 +451,7 @@
(-> file-data
(update :pages-index update-vals fix-container)
(update :components update-vals fix-container))))
(d/update-when :components update-vals fix-container))))
remap-refs
(fn [file-data]
@ -223,32 +495,32 @@
(-> file-data
(update :pages-index update-vals fix-container)
(update :components update-vals fix-container))))
(d/update-when :components update-vals fix-container))))
fix-copies-of-detached
fix-converted-copies
(fn [file-data]
;; Find any copy that is referencing a detached shape inside a component, and
;; undo the nested copy, converting it into a direct copy.
;; If the user has created a copy and then converted into a path or bool,
;; detach it because the synchronization will no longer work.
(letfn [(fix-container [container]
(update container :objects update-vals fix-shape))
(d/update-when container :objects update-vals (partial fix-shape container)))
(fix-shape [container shape]
(if (and (ctk/instance-head? shape)
(or (cfh/path-shape? shape)
(cfh/bool-shape? shape)))
(detach-shape container shape)
shape))]
(fix-shape [shape]
(cond-> shape
(@detached-ids (:shape-ref shape))
(dissoc shape
:component-id
:component-file
:component-root)))]
(-> file-data
(update :pages-index update-vals fix-container)
(update :components update-vals fix-container))))
(d/update-when :components update-vals fix-container))))
transform-to-frames
(fn [file-data]
;; Transform component and copy heads to frames, and set the
;; frame-id of its childrens
(letfn [(fix-container [container]
(update container :objects update-vals fix-shape))
(d/update-when container :objects update-vals fix-shape))
(fix-shape [shape]
(if (or (nil? (:parent-id shape)) (ctk/instance-head? shape))
@ -262,7 +534,7 @@
shape))]
(-> file-data
(update :pages-index update-vals fix-container)
(update :components update-vals fix-container))))
(d/update-when :components update-vals fix-container))))
remap-frame-ids
(fn [file-data]
@ -270,7 +542,7 @@
;; to point to the head instance.
(letfn [(fix-container
[container]
(update container :objects update-vals (partial fix-shape container)))
(d/update-when container :objects update-vals (partial fix-shape container)))
(fix-shape
[container shape]
@ -280,14 +552,14 @@
shape)))]
(-> file-data
(update :pages-index update-vals fix-container)
(update :components update-vals fix-container))))
(d/update-when :components update-vals fix-container))))
fix-frame-ids
(fn [file-data]
;; Ensure that frame-id of all shapes point to the parent or to the frame-id
;; of the parent, and that the destination is indeed a frame.
(letfn [(fix-container [container]
(update container :objects #(cfh/reduce-objects % fix-shape %)))
(d/update-when container :objects #(cfh/reduce-objects % fix-shape %)))
(fix-shape [objects shape]
(let [parent (when (:parent-id shape)
@ -304,7 +576,7 @@
(-> file-data
(update :pages-index update-vals fix-container)
(update :components update-vals fix-container))))
(d/update-when :components update-vals fix-container))))
fix-component-nil-objects
(fn [file-data]
@ -316,38 +588,89 @@
(dissoc component :objects))
component))]
(-> file-data
(update :components update-vals fix-component))))
(d/update-when :components update-vals fix-component))))
fix-false-copies
(fn [file-data]
;; Find component heads that are not main-instance but have not :shape-ref.
;; Also shapes that have :shape-ref but are not in a copy.
(letfn [(fix-container
[container]
(update container :objects update-vals fix-shape))
(d/update-when container :objects update-vals (partial fix-shape container)))
(fix-shape
[shape]
(if (and (ctk/instance-head? shape)
(not (ctk/main-instance? shape))
(not (ctk/in-component-copy? shape)))
(ctk/detach-shape shape)
[container shape]
(if (or (and (ctk/instance-head? shape)
(not (ctk/main-instance? shape))
(not (ctk/in-component-copy? shape)))
(and (ctk/in-component-copy? shape)
(nil? (ctn/get-head-shape (:objects container) shape {:allow-main? true}))))
(detach-shape container shape)
shape))]
(-> file-data
(update :pages-index update-vals fix-container)
(update :components update-vals fix-container))))]
(d/update-when :components update-vals fix-container))))
fix-copies-of-detached
(fn [file-data]
;; Find any copy that is referencing a shape inside a component that have
;; been detached in a previous fix. If so, undo the nested copy, converting
;; it into a direct copy.
;;
;; WARNING: THIS SHOULD BE CALLED AT THE END OF THE PROCESS.
(letfn [(fix-container [container]
(d/update-when container :objects update-vals fix-shape))
(fix-shape [shape]
(cond-> shape
(@detached-ids (:shape-ref shape))
(dissoc shape
:component-id
:component-file
:component-root)))]
(-> file-data
(update :pages-index update-vals fix-container)
(d/update-when :components update-vals fix-container))))
fix-shape-nil-parent-id
(fn [file-data]
;; Ensure that parent-id and frame-id are not nil
(letfn [(fix-container [container]
(d/update-when container :objects update-vals fix-shape))
(fix-shape [shape]
(let [frame-id (or (:frame-id shape)
uuid/zero)
parent-id (or (:parent-id shape)
frame-id)]
(assoc shape :frame-id frame-id
:parent-id parent-id)))]
(-> file-data
(update :pages-index update-vals fix-container))))]
(-> file-data
(fix-page-invalid-options)
(fix-bad-children)
(fix-misc-shape-issues)
(fix-recent-colors)
(fix-missing-image-metadata)
(fix-text-shapes-converted-to-path)
(fix-broken-paths)
(delete-big-geometry-shapes)
(fix-broken-parents)
(fix-orphan-shapes)
(fix-orphan-copies)
(remove-nested-roots)
(add-not-nested-roots)
(fix-orphan-copies)
(remap-refs)
(fix-copies-of-detached)
(fix-converted-copies)
(transform-to-frames)
(remap-frame-ids)
(fix-frame-ids)
(fix-component-nil-objects)
(fix-false-copies))))
(fix-false-copies)
(fix-shape-nil-parent-id)
(fix-copies-of-detached)))) ; <- Do not add fixes after this one
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; COMPONENTS MIGRATION
@ -574,7 +897,7 @@
(if (> ext-idx 0) (subs filename 0 ext-idx) filename)))
(defn- collect-and-persist-images
[svg-data file-id]
[svg-data file-id media-id]
(letfn [(process-image [{:keys [href] :as item}]
(try
(let [item (if (str/starts-with? href "data:")
@ -601,12 +924,13 @@
;; The media processing adds the data to the
;; input map and returns it.
(media/run {:cmd :info :input item}))
(catch Throwable cause
(l/warn :hint "unexpected exception on processing internal image shape (skiping)"
:cause cause)
(when-not *skip-on-error*
(throw cause)))))
(catch Throwable _
(let [team-id *team-id*]
(l/wrn :hint "unable to process embedded images on svg file"
:team-id (str team-id)
:file-id (str file-id)
:media-id (str media-id)))
nil)))
(persist-image [acc {:keys [path size width height mtype href] :as item}]
(let [storage (::sto/storage *system*)
@ -642,23 +966,33 @@
(completing persist-image) {}))]
(assoc svg-data :image-data images))))
(defn- get-svg-content
(defn- resolve-sobject-id
[id]
(let [fmobject (db/get *system* :file-media-object {:id id}
{::sql/columns [:media-id]})]
(:media-id fmobject)))
(defn- get-sobject-content
[id]
(let [storage (::sto/storage *system*)
conn (::db/conn *system*)
fmobject (db/get conn :file-media-object {:id id})
sobject (sto/get-object storage (:media-id fmobject))]
sobject (sto/get-object storage id)]
(with-open [stream (sto/get-object-data storage sobject)]
(slurp stream))))
(defn- create-shapes-for-svg
[{:keys [id] :as mobj} file-id objects frame-id position]
(let [svg-text (get-svg-content id)
svg-text (svgo/optimize *system* svg-text)
svg-data (-> (csvg/parse svg-text)
(assoc :name (:name mobj))
(collect-and-persist-images file-id))]
(let [get-svg (fn [sid]
(let [svg-text (get-sobject-content sid)
svg-text (svgo/optimize *system* svg-text)]
(-> (csvg/parse svg-text)
(assoc :name (:name mobj)))))
sid (resolve-sobject-id id)
svg-data (if (cache/cache? *cache*)
(cache/get *cache* sid (px/wrap-bindings get-svg))
(get-svg sid))
svg-data (collect-and-persist-images svg-data file-id id)]
(sbuilder/create-svg-shapes svg-data position objects frame-id frame-id #{} false)))
@ -717,42 +1051,64 @@
(defn- create-media-grid
[fdata page-id frame-id grid media-group]
(let [process (fn [mobj position]
(let [position (gpt/add position (gpt/point grid-gap grid-gap))
tp1 (dt/tpoint)]
(try
(process-media-object fdata page-id frame-id mobj position)
(catch Throwable cause
(l/wrn :hint "unable to process file media object (skiping)"
:file-id (str (:id fdata))
:id (str (:id mobj))
:cause cause)
(if-not *skip-on-error*
(throw cause)
nil))
(finally
(l/trc :hint "graphic processed"
:file-id (str (:id fdata))
:media-id (str (:id mobj))
:elapsed (dt/format-duration (tp1)))))))]
(letfn [(process [fdata mobj position]
(let [position (gpt/add position (gpt/point grid-gap grid-gap))
tp (dt/tpoint)
err (volatile! false)]
(try
(let [changes (process-media-object fdata page-id frame-id mobj position)]
(cp/process-changes fdata changes false))
(catch Throwable cause
(vreset! err true)
(let [cause (pu/unwrap-exception cause)
edata (ex-data cause)
team-id *team-id*]
(cond
(instance? org.xml.sax.SAXParseException cause)
(l/inf :hint "skip processing media object: invalid svg found"
:team-id (str team-id)
:file-id (str (:id fdata))
:id (str (:id mobj)))
(instance? org.graalvm.polyglot.PolyglotException cause)
(l/inf :hint "skip processing media object: invalid svg found"
:team-id (str team-id)
:file-id (str (:id fdata))
:id (str (:id mobj)))
(= (:type edata) :not-found)
(l/inf :hint "skip processing media object: underlying object does not exist"
:team-id (str team-id)
:file-id (str (:id fdata))
:id (str (:id mobj)))
:else
(let [skip? *skip-on-graphic-error*]
(l/wrn :hint "unable to process file media object"
:skiped skip?
:team-id (str team-id)
:file-id (str (:id fdata))
:id (str (:id mobj))
:cause cause)
(when-not skip?
(throw cause))))
nil))
(finally
(let [elapsed (tp)]
(l/trc :hint "graphic processed"
:file-id (str (:id fdata))
:media-id (str (:id mobj))
:error @err
:elapsed (dt/format-duration elapsed)))))))]
(->> (d/zip media-group grid)
(partition-all (or *max-procs* 1))
(mapcat (fn [partition]
(->> partition
(map (fn [[mobj position]]
(sse/tap {:type :migration-progress
:section :graphics
:name (:name mobj)})
(p/vthread (process mobj position))))
(doall)
(map deref)
(doall))))
(filter some?)
(reduce (fn [fdata changes]
(-> (assoc-in fdata [:options :components-v2] true)
(cp/process-changes changes false)))
fdata))))
(reduce (fn [fdata [mobj position]]
(sse/tap {:type :migration-progress
:section :graphics
:name (:name mobj)})
(or (process fdata mobj position) fdata))
(assoc-in fdata [:options :components-v2] true)))))
(defn- migrate-graphics
[fdata]
@ -821,9 +1177,13 @@
(decode-row)
(update :data assoc :id id)
(update :data fdata/process-pointers deref)
(update :data fdata/process-objects (partial into {}))
(update :data (fn [data]
(if (> (:version data) 22)
(assoc data :version 22)
data)))
(fmg/migrate-file))))
(defn- get-team
[system team-id]
(-> (db/get system :team {:id team-id}
@ -832,17 +1192,12 @@
(decode-row)))
(defn- validate-file!
[file libs throw-on-validate?]
(try
(cfv/validate-file! file libs)
(cfv/validate-file-schema! file)
(catch Throwable cause
(if throw-on-validate?
(throw cause)
(l/wrn :hint "migrate:file:validation-error" :cause cause)))))
[file libs]
(cfv/validate-file! file libs)
(cfv/validate-file-schema! file))
(defn- process-file
[{:keys [::db/conn] :as system} id & {:keys [validate? throw-on-validate?]}]
[{:keys [::db/conn] :as system} id & {:keys [validate?]}]
(let [file (get-file system id)
libs (->> (files/get-file-libraries conn id)
@ -855,7 +1210,7 @@
(update :features conj "components/v2"))
_ (when validate?
(validate-file! file libs throw-on-validate?))
(validate-file! file libs))
file (if (contains? (:features file) "fdata/objects-map")
(fdata/enable-objects-map file)
@ -876,12 +1231,13 @@
(dissoc file :data)))
(def ^:private sql:get-and-lock-team-files
"SELECT f.id
FROM file AS f
JOIN project AS p ON (p.id = f.project_id)
WHERE p.team_id = ?
AND p.deleted_at IS NULL
AND f.deleted_at IS NULL
FOR UPDATE")
(defn- get-and-lock-files
@ -901,21 +1257,33 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn migrate-file!
[system file-id & {:keys [validate? throw-on-validate? max-procs]}]
(let [tpoint (dt/tpoint)]
[system file-id & {:keys [validate? skip-on-graphic-error? label]}]
(let [tpoint (dt/tpoint)]
(binding [*file-stats* (atom {})
*max-procs* max-procs]
*skip-on-graphic-error* skip-on-graphic-error?]
(try
(l/dbg :hint "migrate:file:start" :file-id (str file-id))
(l/dbg :hint "migrate:file:start"
:file-id (str file-id)
:validate validate?
:skip-on-graphic-error skip-on-graphic-error?)
(let [system (update system ::sto/storage media/configure-assets-storage)]
(db/tx-run! system
(fn [system]
(binding [*system* system]
(fsnap/take-file-snapshot! system {:file-id file-id :label "migration/components-v2"})
(process-file system file-id
:validate? validate?
:throw-on-validate? throw-on-validate?)))))
(try
(binding [*system* system]
(when (string? label)
(fsnap/take-file-snapshot! system {:file-id file-id
:label (str "migration/" label)}))
(process-file system file-id :validate? validate?))
(catch Throwable cause
(let [team-id *team-id*]
(l/wrn :hint "error on processing file"
:team-id (str team-id)
:file-id (str file-id))
(throw cause)))))))
(finally
(let [elapsed (tpoint)
components (get @*file-stats* :processed/components 0)
@ -925,46 +1293,52 @@
:file-id (str file-id)
:graphics graphics
:components components
:validate validate?
:elapsed (dt/format-duration elapsed))
(some-> *stats* (swap! update :processed/files (fnil inc 0)))
(some-> *team-stats* (swap! update :processed/files (fnil inc 0)))))))))
(defn migrate-team!
[system team-id & {:keys [validate? throw-on-validate? max-procs]}]
[system team-id & {:keys [validate? skip-on-graphic-error? label]}]
(l/dbg :hint "migrate:team:start"
:team-id (dm/str team-id))
(let [tpoint (dt/tpoint)
err (volatile! false)
migrate-file
(fn [system file-id]
(migrate-file! system file-id
:max-procs max-procs
:label label
:validate? validate?
:throw-on-validate? throw-on-validate?))
:skip-on-graphic-error? skip-on-graphic-error?))
migrate-team
(fn [{:keys [::db/conn] :as system} {:keys [id features] :as team}]
(let [features (-> features
(disj "ephimeral/v2-migration")
(conj "components/v2")
(conj "layout/grid")
(conj "styles/v2"))]
(fn [{:keys [::db/conn] :as system} team-id]
(let [{:keys [id features]} (get-team system team-id)]
(if (contains? features "components/v2")
(l/inf :hint "team already migrated")
(let [features (-> features
(disj "ephimeral/v2-migration")
(conj "components/v2")
(conj "layout/grid")
(conj "styles/v2"))]
(run! (partial migrate-file system)
(get-and-lock-files conn id))
(run! (partial migrate-file system)
(get-and-lock-files conn id))
(update-team-features! conn id features)))]
(update-team-features! conn id features)))))]
(binding [*team-stats* (atom {})]
(binding [*team-stats* (atom {})
*team-id* team-id]
(try
(db/tx-run! system (fn [system]
(db/exec-one! system ["SET idle_in_transaction_session_timeout = 0"])
(let [team (get-team system team-id)]
(if (contains? (:features team) "components/v2")
(l/inf :hint "team already migrated")
(migrate-team system team)))))
(db/tx-run! system migrate-team team-id)
(catch Throwable cause
(vreset! err true)
(throw cause))
(finally
(let [elapsed (tpoint)
components (get @*team-stats* :processed/components 0)
@ -973,9 +1347,21 @@
(some-> *stats* (swap! update :processed/teams (fnil inc 0)))
(l/dbg :hint "migrate:team:end"
:team-id (dm/str team-id)
:files files
:components components
:graphics graphics
:elapsed (dt/format-duration elapsed))))))))
(if (cache/cache? *cache*)
(let [cache-stats (cache/stats *cache*)]
(l/dbg :hint "migrate:team:end"
:team-id (dm/str team-id)
:files files
:components components
:graphics graphics
:crt (mth/to-fixed (:hit-rate cache-stats) 2)
:crq (str (:req-count cache-stats))
:error @err
:elapsed (dt/format-duration elapsed)))
(l/dbg :hint "migrate:team:end"
:team-id (dm/str team-id)
:files files
:components components
:graphics graphics
:elapsed (dt/format-duration elapsed)))))))))

4
backend/src/app/features/fdata.clj
View File

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

6
backend/src/app/main.clj
View File

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

7
backend/src/app/redis.clj
View File

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

115
backend/src/app/rpc/climit.clj
View File

@ -36,24 +36,14 @@
(-> (str id)
(subs 1)))
(defn- create-bulkhead-cache
[config]
(letfn [(load-fn [[id skey]]
(when-let [config (get config id)]
(l/trc :hint "insert into cache" :id (id->str id) :key skey)
(pbh/create :permits (or (:permits config) (:concurrency config))
:queue (or (:queue config) (:queue-size config))
:timeout (:timeout config)
:type :semaphore)))
(on-remove [key _ cause]
(defn- create-cache
[{:keys [::wrk/executor]}]
(letfn [(on-remove [key _ cause]
(let [[id skey] key]
(l/trc :hint "evict from cache" :id (id->str id) :key skey :reason (str cause))))]
(cache/create :executor :same-thread
(l/dbg :hint "destroy limiter" :id (id->str id) :key skey :reason (str cause))))]
(cache/create :executor executor
:on-remove on-remove
:keepalive "5m"
:load-fn load-fn)))
:keepalive "5m")))
(s/def ::config/permits ::us/integer)
(s/def ::config/queue ::us/integer)
@ -70,7 +60,7 @@
(s/def ::path ::fs/path)
(defmethod ig/pre-init-spec ::rpc/climit [_]
(s/keys :req [::mtx/metrics ::path]))
(s/keys :req [::mtx/metrics ::wrk/executor ::path]))
(defmethod ig/init-key ::rpc/climit
[_ {:keys [::path ::mtx/metrics] :as cfg}]
@ -78,7 +68,7 @@
(when-let [params (some->> path slurp edn/read-string)]
(l/inf :hint "initializing concurrency limit" :config (str path))
(us/verify! ::config params)
{::cache (create-bulkhead-cache params)
{::cache (create-cache cfg)
::config params
::mtx/metrics metrics})))
@ -89,13 +79,17 @@
(s/def ::rpc/climit
(s/nilable ::instance))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- create-limiter
[config [id skey]]
(l/dbg :hint "create limiter" :id (id->str id) :key skey)
(pbh/create :permits (or (:permits config) (:concurrency config))
:queue (or (:queue config) (:queue-size config))
:timeout (:timeout config)
:type :semaphore))
(defn invoke!
[cache metrics id key f]
(if-let [limiter (cache/get cache [id key])]
(defn- invoke!
[config cache metrics id key f]
(if-let [limiter (cache/get cache [id key] (partial create-limiter config))]
(let [tpoint (dt/tpoint)
labels (into-array String [(id->str id)])
wrapped (fn []
@ -147,7 +141,7 @@
:queue (:queue stats)
:max-permits (:max-permits stats)
:max-queue (:max-queue stats))
(pbh/invoke! limiter wrapped))
(px/invoke! limiter wrapped))
(catch ExceptionInfo cause
(let [{:keys [type code]} (ex-data cause)]
(if (= :bulkhead-error type)
@ -160,9 +154,43 @@
(measure! (pbh/get-stats limiter)))))
(do
(l/wrn :hint "unable to load limiter" :id (id->str id))
(l/wrn :hint "no limiter found" :id (id->str id))
(f))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MIDDLEWARE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def noop-fn (constantly nil))
(defn wrap
[{:keys [::rpc/climit ::mtx/metrics]} f {:keys [::id ::key-fn] :or {key-fn noop-fn} :as mdata}]
(if (and (some? climit) (some? id))
(let [cache (::cache climit)
config (::config climit)]
(if-let [config (get config id)]
(do
(l/dbg :hint "instrumenting method"
:limit (id->str id)
:service-name (::sv/name mdata)
:timeout (:timeout config)
:permits (:permits config)
:queue (:queue config)
:keyed? (not= key-fn noop-fn))
(fn [cfg params]
(invoke! config cache metrics id (key-fn params) (partial f cfg params))))
(do
(l/wrn :hint "no config found for specified queue" :id (id->str id))
f)))
f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn configure
[{:keys [::rpc/climit]} id]
(us/assert! ::rpc/climit climit)
@ -171,37 +199,14 @@
(defn run!
"Run a function in context of climit.
Intended to be used in virtual threads."
([{:keys [::id ::cache ::mtx/metrics]} f]
(if (and cache id)
(invoke! cache metrics id nil f)
([{:keys [::id ::cache ::config ::mtx/metrics]} f]
(if-let [config (get config id)]
(invoke! config cache metrics id nil f)
(f)))
([{:keys [::id ::cache ::mtx/metrics]} f executor]
([{:keys [::id ::cache ::config ::mtx/metrics]} f executor]
(let [f #(p/await! (px/submit! executor f))]
(if (and cache id)
(invoke! cache metrics id nil f)
(if-let [config (get config id)]
(invoke! config cache metrics id nil f)
(f)))))
(def noop-fn (constantly nil))
(defn wrap
[{:keys [::rpc/climit ::mtx/metrics]} f {:keys [::id ::key-fn] :or {key-fn noop-fn} :as mdata}]
(if (and (some? climit) (some? id))
(if-let [config (get-in climit [::config id])]
(let [cache (::cache climit)]
(l/dbg :hint "instrumenting method"
:limit (id->str id)
:service-name (::sv/name mdata)
:timeout (:timeout config)
:permits (:permits config)
:queue (:queue config)
:keyed? (not= key-fn noop-fn))
(fn [cfg params]
(invoke! cache metrics id (key-fn params) (partial f cfg params))))
(do
(l/wrn :hint "no config found for specified queue" :id (id->str id))
f))
f))

4
backend/src/app/rpc/commands/binfile.clj
View File

@ -664,9 +664,7 @@
(case feature
"components/v2"
(feat.compv2/migrate-file! options file-id
:max-procs 2
:validate? validate?
:throw-on-validate? true)
:validate? validate?)
"fdata/shape-data-type"
nil

46
backend/src/app/rpc/commands/files.clj
View File

@ -226,23 +226,37 @@
[{:keys [::db/conn] :as cfg} {:keys [id] :as file}]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)
pmap/*tracked* (pmap/create-tracked)]
(let [file (fmg/migrate-file file)]
(let [;; For avoid unnecesary overhead of creating multiple pointers and
;; handly internally with objects map in their worst case (when
;; probably all shapes and all pointers will be readed in any
;; case), we just realize/resolve them before applying the
;; migration to the file
file (-> file
(update :data feat.fdata/process-pointers deref)
(update :data feat.fdata/process-objects (partial into {}))
(fmg/migrate-file))
;; NOTE: when file is migrated, we break the rule of no perform
;; mutations on get operations and update the file with all
;; migrations applied
;;
;; NOTE: the following code will not work on read-only mode, it
;; is a known issue; we keep is not implemented until we really
;; need this
(when (fmg/migrated? file)
(db/update! conn :file
{:data (blob/encode (:data file))
:features (db/create-array conn "text" (:features file))}
{:id id})
;; When file is migrated, we break the rule of no perform
;; mutations on get operations and update the file with all
;; migrations applied
;;
;; WARN: he following code will not work on read-only mode,
;; it is a known issue; we keep is not implemented until we
;; really need this.
file (if (contains? (:features file) "fdata/objects-map")
(feat.fdata/enable-objects-map file)
file)
file (if (contains? (:features file) "fdata/pointer-map")
(feat.fdata/enable-pointer-map file)
file)]
(when (contains? (:features file) "fdata/pointer-map")
(feat.fdata/persist-pointers! cfg id)))
(db/update! conn :file
{:data (blob/encode (:data file))
:features (db/create-array conn "text" (:features file))}
{:id id})
(when (contains? (:features file) "fdata/pointer-map")
(feat.fdata/persist-pointers! cfg id))
file)))
@ -266,7 +280,7 @@
::db/remove-deleted (not include-deleted?)
::sql/for-update lock-for-update?})
(decode-row))]
(if migrate?
(if (and migrate? (fmg/need-migration? file))
(migrate-file cfg file)
file)))

73
backend/src/app/rpc/commands/files_create.clj
View File

@ -18,14 +18,12 @@
[app.loggers.audit :as-alias audit]
[app.loggers.webhooks :as-alias webhooks]
[app.rpc :as-alias rpc]
[app.rpc.commands.files :as files]
[app.rpc.commands.projects :as projects]
[app.rpc.commands.teams :as teams]
[app.rpc.doc :as-alias doc]
[app.rpc.permissions :as perms]
[app.rpc.quotes :as quotes]
[app.util.blob :as blob]
[app.util.objects-map :as omap]
[app.util.pointer-map :as pmap]
[app.util.services :as sv]
[app.util.time :as dt]
@ -50,47 +48,52 @@
"expected a valid connection"
(db/connection? conn))
(let [id (or id (uuid/next))
(binding [pmap/*tracked* (pmap/create-tracked)
cfeat/*current* features]
(let [id (or id (uuid/next))
pointers (pmap/create-tracked)
pmap? (contains? features "fdata/pointer-map")
omap? (contains? features "fdata/objects-map")
data (binding [pmap/*tracked* pointers
cfeat/*current* features
cfeat/*wrap-with-objects-map-fn* (if omap? omap/wrap identity)
cfeat/*wrap-with-pointer-map-fn* (if pmap? pmap/wrap identity)]
(if create-page
data (if create-page
(ctf/make-file-data id)
(ctf/make-file-data id nil)))
(ctf/make-file-data id nil))
features (->> (set/difference features cfeat/frontend-only-features)
(db/create-array conn "text"))
file {:id id
:project-id project-id
:name name
:revn revn
:is-shared is-shared
:data data
:features features
:ignore-sync-until ignore-sync-until
:modified-at modified-at
:deleted-at deleted-at}
file (db/insert! conn :file
(d/without-nils
{:id id
:project-id project-id
:name name
:revn revn
:is-shared is-shared
:data (blob/encode data)
:features features
:ignore-sync-until ignore-sync-until
:modified-at modified-at
:deleted-at deleted-at}))]
file (if (contains? features "fdata/objects-map")
(feat.fdata/enable-objects-map file)
file)
(binding [pmap/*tracked* pointers]
(feat.fdata/persist-pointers! cfg id))
file (if (contains? features "fdata/pointer-map")
(feat.fdata/enable-pointer-map file)
file)
(->> (assoc params :file-id id :role :owner)
(create-file-role! conn))
file (d/without-nils file)]
(db/update! conn :project
{:modified-at (dt/now)}
{:id project-id})
(db/insert! conn :file
(-> file
(update :data blob/encode)
(update :features db/encode-pgarray conn "text"))
{::db/return-keys false})
(files/decode-row file)))
(when (contains? features "fdata/pointer-map")
(feat.fdata/persist-pointers! cfg id))
(->> (assoc params :file-id id :role :owner)
(create-file-role! conn))
(db/update! conn :project
{:modified-at (dt/now)}
{:id project-id})
file)))
(def ^:private schema:create-file
[:map {:title "create-file"}

31
backend/src/app/rpc/commands/files_update.clj
View File

@ -292,9 +292,20 @@
(let [file (update file :data (fn [data]
(-> data
(blob/decode)
(assoc :id (:id file))
(fmg/migrate-data)
(d/without-nils))))
(assoc :id (:id file)))))
;; For avoid unnecesary overhead of creating multiple pointers
;; and handly internally with objects map in their worst
;; case (when probably all shapes and all pointers will be
;; readed in any case), we just realize/resolve them before
;; applying the migration to the file
file (if (fmg/need-migration? file)
(-> file
(update :data feat.fdata/process-pointers deref)
(update :data feat.fdata/process-objects (partial into {}))
(fmg/migrate-file))
file)
;; WARNING: this ruins performance; maybe we need to find
;; some other way to do general validation
@ -305,14 +316,20 @@
(into [file] (map (fn [{:keys [id]}]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)
pmap/*tracked* nil]
;; We do not resolve the objects maps here
;; because there is a lower probability that all
;; shapes needed to be loded into memory, so we
;; leeave it on lazy status
(-> (files/get-file cfg id :migrate? false)
(update :data feat.fdata/process-pointers deref) ; ensure all pointers resolved
(fmg/migrate-file))))))
(d/index-by :id)))
file (-> (files/check-version! file)
(update :revn inc)
(update :data cpc/process-changes changes))]
(update :data cpc/process-changes changes)
(update :data d/without-nils))]
(when (contains? cf/flags :soft-file-validation)
(soft-validate-file! file libs))
@ -329,12 +346,10 @@
(val/validate-file-schema! file))
(cond-> file
(and (contains? cfeat/*current* "fdata/objects-map")
(not (contains? cfeat/*previous* "fdata/objects-map")))
(contains? cfeat/*current* "fdata/objects-map")
(feat.fdata/enable-objects-map)
(and (contains? cfeat/*current* "fdata/pointer-map")
(not (contains? cfeat/*previous* "fdata/pointer-map")))
(contains? cfeat/*current* "fdata/pointer-map")
(feat.fdata/enable-pointer-map)
:always

382
backend/src/app/srepl/components_v2.clj
View File

@ -6,13 +6,18 @@
(ns app.srepl.components-v2
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.common.pprint :as pp]
[app.common.uuid :as uuid]
[app.db :as db]
[app.features.components-v2 :as feat]
[app.main :as main]
[app.svgo :as svgo]
[app.util.cache :as cache]
[app.util.time :as dt]
[app.worker :as-alias wrk]
[cuerdas.core :as str]
[promesa.core :as p]
[promesa.exec :as px]
[promesa.exec.semaphore :as ps]
[promesa.util :as pu]))
@ -35,14 +40,9 @@
(fn [_ _ oldv newv]
(when (not= (:processed/files oldv)
(:processed/files newv))
(let [total (:total/files newv)
completed (:processed/files newv)
progress (/ (* completed 100.0) total)
elapsed (tpoint)]
(let [elapsed (tpoint)]
(l/dbg :hint "progress"
:completed (:processed/files newv)
:total (:total/files newv)
:progress (str (int progress) "%")
:elapsed (dt/format-duration elapsed))))))
(defn- report-progress-teams
@ -50,88 +50,147 @@
(fn [_ _ oldv newv]
(when (not= (:processed/teams oldv)
(:processed/teams newv))
(let [total (:total/teams newv)
completed (:processed/teams newv)
progress (/ (* completed 100.0) total)
progress (str (int progress) "%")
(let [completed (:processed/teams newv)
elapsed (dt/format-duration (tpoint))]
(when (fn? on-progress)
(on-progress {:total total
:elapsed elapsed
:completed completed
:progress progress}))
(on-progress {:elapsed elapsed
:completed completed}))
(l/dbg :hint "progress"
:completed completed
:progress progress
:elapsed elapsed)))))
(defn- get-total-files
[pool & {:keys [team-id]}]
(if (some? team-id)
(let [sql (str/concat
"SELECT count(f.id) AS count FROM file AS f "
" JOIN project AS p ON (p.id = f.project_id) "
" WHERE p.team_id = ? AND f.deleted_at IS NULL "
" AND p.deleted_at IS NULL")
res (db/exec-one! pool [sql team-id])]
(:count res))
(def ^:private sql:get-teams-by-created-at
"WITH teams AS (
SELECT id, features
FROM team
WHERE deleted_at IS NULL
ORDER BY created_at DESC
) SELECT * FROM TEAMS %(pred)s")
(let [sql (str/concat
"SELECT count(id) AS count FROM file "
" WHERE deleted_at IS NULL")
res (db/exec-one! pool [sql])]
(:count res))))
(def ^:private sql:get-teams-by-graphics
"WITH teams AS (
SELECT t.id, t.features,
(SELECT count(*)
FROM file_media_object AS fmo
JOIN file AS f ON (f.id = fmo.file_id)
JOIN project AS p ON (p.id = f.project_id)
WHERE p.team_id = t.id
AND fmo.mtype = 'image/svg+xml'
AND fmo.is_local = false) AS graphics
FROM team AS t
WHERE t.deleted_at IS NULL
ORDER BY 3 ASC
)
SELECT * FROM teams %(pred)s")
(defn- get-total-teams
[pool]
(let [sql (str/concat
"SELECT count(id) AS count FROM team "
" WHERE deleted_at IS NULL")
res (db/exec-one! pool [sql])]
(:count res)))
(def ^:private sql:get-teams-by-activity
"WITH teams AS (
SELECT t.id, t.features,
(SELECT coalesce(max(date_trunc('month', f.modified_at)), date_trunc('month', t.modified_at))
FROM file AS f
JOIN project AS p ON (f.project_id = p.id)
WHERE p.team_id = t.id) AS updated_at,
(SELECT coalesce(count(*), 0)
FROM file AS f
JOIN project AS p ON (f.project_id = p.id)
WHERE p.team_id = t.id) AS total_files
FROM team AS t
WHERE t.deleted_at IS NULL
ORDER BY 3 DESC, 4 DESC
)
SELECT * FROM teams %(pred)s")
(def ^:private sql:get-teams-by-report
"WITH teams AS (
SELECT t.id t.features, mr.name
FROM migration_report AS mr
JOIN team AS t ON (t.id = mr.team_id)
WHERE t.deleted_at IS NULL
AND mr.error IS NOT NULL
ORDER BY mr.created_at
) SELECT id, features FROM teams %(pred)s")
(defn- mark-team-migration!
[{:keys [::db/pool]} team-id]
;; We execute this out of transaction because we want this
;; change to be visible to all other sessions before starting
;; the migration
(let [sql (str "UPDATE team SET features = "
" array_append(features, 'ephimeral/v2-migration') "
" WHERE id = ?")]
(db/exec-one! pool [sql team-id])))
(defn- read-pred
[entries]
(let [entries (if (and (vector? entries)
(keyword? (first entries)))
[entries]
entries)]
(loop [params []
queries []
entries (seq entries)]
(if-let [[op val field] (first entries)]
(let [field (name field)
cond (case op
:lt (str/ffmt "% < ?" field)
:lte (str/ffmt "% <= ?" field)
:gt (str/ffmt "% > ?" field)
:gte (str/ffmt "% >= ?" field)
:eq (str/ffmt "% = ?" field))]
(recur (conj params val)
(conj queries cond)
(rest entries)))
(defn- unmark-team-migration!
[{:keys [::db/pool]} team-id]
;; We execute this out of transaction because we want this
;; change to be visible to all other sessions before starting
;; the migration
(let [sql (str "UPDATE team SET features = "
" array_remove(features, 'ephimeral/v2-migration') "
" WHERE id = ?")]
(db/exec-one! pool [sql team-id])))
(def ^:private sql:get-teams
"SELECT id, features
FROM team
WHERE deleted_at IS NULL
ORDER BY created_at ASC")
(let [sql (apply str "WHERE " (str/join " AND " queries))]
(apply vector sql params))))))
(defn- get-teams
[conn]
(->> (db/cursor conn sql:get-teams)
(map feat/decode-row)))
[conn query pred]
(let [query (d/nilv query :created-at)
sql (case query
:created-at sql:get-teams-by-created-at
:activity sql:get-teams-by-activity
:graphics sql:get-teams-by-graphics
:report sql:get-teams-by-report)
sql (if pred
(let [[pred-sql & pred-params] (read-pred pred)]
(apply vector
(str/format sql {:pred pred-sql})
pred-params))
[(str/format sql {:pred ""})])]
(->> (db/cursor conn sql {:chunk-size 500})
(map feat/decode-row)
(remove (fn [{:keys [features]}]
(contains? features "components/v2")))
(map :id))))
(def ^:private sql:report-table
"CREATE UNLOGGED TABLE IF NOT EXISTS migration_report (
id bigserial NOT NULL,
label text NOT NULL,
team_id UUID NOT NULL,
error text NULL,
created_at timestamptz NOT NULL DEFAULT now(),
elapsed bigint NOT NULL,
PRIMARY KEY (label, created_at, id)
)")
(defn- create-report-table!
[system]
(db/exec-one! system [sql:report-table]))
(defn- clean-reports!
[system label]
(db/delete! system :migration-report {:label label}))
(defn- report!
[system team-id label elapsed error]
(db/insert! system :migration-report
{:label label
:team-id team-id
:elapsed (inst-ms elapsed)
:error error}
{::db/return-keys false}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn migrate-file!
[system file-id & {:keys [rollback? max-procs]
:or {rollback? true}}]
[file-id & {:keys [rollback? validate? label] :or {rollback? true validate? false}}]
(l/dbg :hint "migrate:start" :rollback rollback?)
(let [tpoint (dt/tpoint)
file-id (if (string? file-id)
@ -139,8 +198,10 @@
file-id)]
(binding [feat/*stats* (atom {})]
(try
(-> (assoc system ::db/rollback rollback?)
(feat/migrate-file! file-id :max-procs max-procs))
(-> (assoc main/system ::db/rollback rollback?)
(feat/migrate-file! file-id
:validate? validate?
:label label))
(-> (deref feat/*stats*)
(assoc :elapsed (dt/format-duration (tpoint))))
@ -153,47 +214,36 @@
(l/dbg :hint "migrate:end" :rollback rollback? :elapsed elapsed)))))))
(defn migrate-team!
[{:keys [::db/pool] :as system} team-id & {:keys [rollback? skip-on-error validate? max-procs]
:or {rollback? true
skip-on-error true
validate? false
max-procs 1}
:as opts}]
[team-id & {:keys [rollback? skip-on-graphic-error? validate? label]
:or {rollback? true
validate? true
skip-on-graphic-error? false}}]
(l/dbg :hint "migrate:start" :rollback rollback?)
(let [team-id (if (string? team-id)
(parse-uuid team-id)
team-id)
total (get-total-files pool :team-id team-id)
stats (atom {:total/files total})
stats (atom {})
tpoint (dt/tpoint)]
(add-watch stats :progress-report (report-progress-files tpoint))
(binding [feat/*stats* stats
feat/*skip-on-error* skip-on-error]
(binding [feat/*stats* stats]
(try
(mark-team-migration! system team-id)
(-> (assoc system ::db/rollback rollback?)
(-> (assoc main/system ::db/rollback rollback?)
(feat/migrate-team! team-id
:max-procs max-procs
:label label
:validate? validate?
:throw-on-validate? (not skip-on-error)))
:skip-on-graphic-error? skip-on-graphic-error?))
(print-stats!
(-> (deref feat/*stats*)
(dissoc :total/files)
(assoc :elapsed (dt/format-duration (tpoint)))))
(catch Throwable cause
(l/dbg :hint "migrate:error" :cause cause))
(finally
(unmark-team-migration! system team-id)
(let [elapsed (dt/format-duration (tpoint))]
(l/dbg :hint "migrate:end" :rollback rollback? :elapsed elapsed)))))))
@ -204,98 +254,118 @@
until thw maximum number of jobs is reached which by default has the
value of `1`. This is controled with the `:max-jobs` option.
Each tram migration process also can start multiple procs for
graphics migration, the total of that procs is controled with the
`:max-procs` option.
If you want to run this on multiple machines you will need to specify
the total number of partitions and the current partition.
Internally, the graphics migration process uses SVGO module which by
default has a limited number of maximum concurent
operations (globally), ensure setting up correct number with
PENPOT_SVGO_MAX_PROCS environment variable."
In order to get the report table populated, you will need to provide
a correct `:label`. That label is also used for persist a file
snaphot before continue with the migration."
[& {:keys [max-jobs max-items max-time rollback? validate? query
pred max-procs cache on-start on-progress on-error on-end
skip-on-graphic-error? label partitions current-partition]
:or {validate? false
rollback? true
max-jobs 1
current-partition 1
skip-on-graphic-error? true
max-items Long/MAX_VALUE}}]
[{:keys [::db/pool] :as system} & {:keys [max-jobs max-procs max-items
rollback? validate? preset
skip-on-error max-time
on-start on-progress on-error on-end]
:or {validate? false
rollback? true
skip-on-error true
preset :shutdown-on-failure
max-jobs 1
max-procs 10
max-items Long/MAX_VALUE}
:as opts}]
(when (int? partitions)
(when-not (int? current-partition)
(throw (IllegalArgumentException. "missing `current-partition` parameter")))
(when-not (<= 0 current-partition partitions)
(throw (IllegalArgumentException. "invalid value on `current-partition` parameter"))))
(let [total (get-total-teams pool)
stats (atom {:total/teams (min total max-items)})
(let [stats (atom {})
tpoint (dt/tpoint)
mtime (some-> max-time dt/duration)
tpoint (dt/tpoint)
mtime (some-> max-time dt/duration)
factory (px/thread-factory :virtual false :prefix "penpot/migration/")
executor (px/cached-executor :factory factory)
scope (px/structured-task-scope :preset preset :factory :virtual)
sjobs (ps/create :permits max-jobs)
max-procs (or max-procs max-jobs)
sjobs (ps/create :permits max-jobs)
sprocs (ps/create :permits max-procs)
cache (if (int? cache)
(cache/create :executor executor
:max-items cache)
nil)
migrate-team
(fn [{:keys [id features] :as team}]
(fn [team-id]
(let [tpoint (dt/tpoint)]
(try
(db/tx-run! (assoc main/system ::db/rollback rollback?)
(fn [system]
(db/exec-one! system ["SET idle_in_transaction_session_timeout = 0"])
(feat/migrate-team! system team-id
:label label
:validate? validate?
:skip-on-graphic-error? skip-on-graphic-error?)))
(when (string? label)
(report! main/system team-id label (tpoint) nil))
(catch Throwable cause
(l/wrn :hint "unexpected error on processing team (skiping)"
:team-id (str team-id)
:cause cause)
(when (string? label)
(report! main/system team-id label (tpoint) (ex-message cause))))
(finally
(ps/release! sjobs)))))
process-team
(fn [team-id]
(ps/acquire! sjobs)
(let [ts (tpoint)]
(cond
(and mtime (neg? (compare mtime ts)))
(if (and mtime (neg? (compare mtime ts)))
(do
(l/inf :hint "max time constraint reached"
:team-id (str id)
:team-id (str team-id)
:elapsed (dt/format-duration ts))
(ps/release! sjobs)
(reduced nil))
(or (contains? features "ephimeral/v2-migration")
(contains? features "components/v2"))
(do
(l/dbg :hint "skip team" :team-id (str id))
(ps/release! sjobs))
:else
(px/submit! scope (fn []
(try
(mark-team-migration! system id)
(-> (assoc system ::db/rollback rollback?)
(feat/migrate-team! id
:max-procs max-procs
:validate? validate?
:throw-on-validate? (not skip-on-error)))
(catch Throwable cause
(l/err :hint "unexpected error on processing team"
:team-id (str id)
:cause cause))
(finally
(ps/release! sjobs)
(unmark-team-migration! system id))))))))]
(px/run! executor (partial migrate-team team-id)))))]
(l/dbg :hint "migrate:start"
:label label
:rollback rollback?
:total total
:max-jobs max-jobs
:max-procs max-procs
:max-items max-items)
(add-watch stats :progress-report (report-progress-teams tpoint on-progress))
(binding [feat/*stats* stats
feat/*skip-on-error* skip-on-error]
feat/*cache* cache
svgo/*semaphore* sprocs]
(try
(when (fn? on-start)
(on-start {:total total :rollback rollback?}))
(on-start {:rollback rollback?}))
(db/tx-run! system
(fn [{:keys [::db/conn]}]
(run! (partial migrate-team)
(->> (get-teams conn)
(take max-items)))))
(try
(p/await! scope)
(finally
(pu/close! scope)))
(when (string? label)
(create-report-table! main/system)
(clean-reports! main/system label))
(db/tx-run! main/system
(fn [{:keys [::db/conn] :as system}]
(db/exec! conn ["SET statement_timeout = 0"])
(db/exec! conn ["SET idle_in_transaction_session_timeout = 0"])
(run! process-team
(->> (get-teams conn query pred)
(filter (fn [team-id]
(if (int? partitions)
(= current-partition (-> (uuid/hash-int team-id)
(mod partitions)
(inc)))
true)))
(take max-items)))
;; Close and await tasks
(pu/close! executor)))
(if (fn? on-end)
(-> (deref stats)

3
backend/src/app/srepl/helpers.clj
View File

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

25
backend/src/app/storage/s3.clj
View File

@ -51,6 +51,7 @@
software.amazon.awssdk.services.s3.model.DeleteObjectsRequest
software.amazon.awssdk.services.s3.model.DeleteObjectsResponse
software.amazon.awssdk.services.s3.model.GetObjectRequest
software.amazon.awssdk.services.s3.model.NoSuchKeyException
software.amazon.awssdk.services.s3.model.ObjectIdentifier
software.amazon.awssdk.services.s3.model.PutObjectRequest
software.amazon.awssdk.services.s3.model.S3Error
@ -126,17 +127,19 @@
(defmethod impl/get-object-data :s3
[backend object]
(us/assert! ::backend backend)
(letfn [(no-such-key? [cause]
(instance? software.amazon.awssdk.services.s3.model.NoSuchKeyException cause))
(handle-not-found [cause]
(ex/raise :type :not-found
:code :object-not-found
:hint "s3 object not found"
:cause cause))]
(-> (get-object-data backend object)
(p/catch no-such-key? handle-not-found)
(p/await!))))
(let [result (p/await (get-object-data backend object))]
(if (ex/exception? result)
(cond
(ex/instance? NoSuchKeyException result)
(ex/raise :type :not-found
:code :object-not-found
:hint "s3 object not found"
:cause result)
:else
(throw result))
result)))
(defmethod impl/get-object-bytes :s3
[backend object]
@ -298,7 +301,7 @@
[path]
(proxy [FilterInputStream] [(io/input-stream path)]
(close []
(fs/delete path)
(ex/ignoring (fs/delete path))
(proxy-super close))))
(defn- get-object-data

51
backend/src/app/svgo.clj
View File

@ -7,16 +7,10 @@
(ns app.svgo
"A SVG Optimizer service"
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.jsrt :as jsrt]
[app.common.logging :as l]
[app.common.spec :as us]
[app.worker :as-alias wrk]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[promesa.exec :as px]
[promesa.exec.bulkhead :as bh]
[promesa.exec.semaphore :as ps]
[promesa.util :as pu]))
@ -26,40 +20,23 @@
nil)
(defn optimize
[system data]
(dm/assert! "expect data to be a string" (string? data))
(letfn [(optimize-fn [pool]
(jsrt/run! pool
(fn [context]
(jsrt/set! context "svgData" data)
(jsrt/eval! context "penpotSvgo.optimize(svgData, {plugins: ['safeAndFastPreset']})"))))]
(try
(some-> *semaphore* ps/acquire!)
(let [{:keys [::jsrt/pool ::wrk/executor]} (::optimizer system)]
(dm/assert! "expect optimizer instance" (jsrt/pool? pool))
(px/invoke! executor (partial optimize-fn pool)))
(finally
(some-> *semaphore* ps/release!)))))
(s/def ::max-procs (s/nilable ::us/integer))
(defmethod ig/pre-init-spec ::optimizer [_]
(s/keys :req [::wrk/executor ::max-procs]))
(defmethod ig/prep-key ::optimizer
[_ cfg]
(merge {::max-procs 20} (d/without-nils cfg)))
[{pool ::optimizer} data]
(try
(some-> *semaphore* ps/acquire!)
(jsrt/run! pool
(fn [context]
(jsrt/set! context "svgData" data)
(jsrt/eval! context "penpotSvgo.optimize(svgData, {plugins: ['safeAndFastPreset']})")))
(finally
(some-> *semaphore* ps/release!))))
(defmethod ig/init-key ::optimizer
[_ {:keys [::wrk/executor ::max-procs]}]
(l/inf :hint "initializing svg optimizer pool" :max-procs max-procs)
(let [init (jsrt/resource->source "app/common/svg/optimizer.js")
executor (bh/create :type :executor :executor executor :permits max-procs)]
{::jsrt/pool (jsrt/pool :init init)
::wrk/executor executor}))
[_ _]
(l/inf :hint "initializing svg optimizer pool")
(let [init (jsrt/resource->source "app/common/svg/optimizer.js")]
(jsrt/pool :init init)))
(defmethod ig/halt-key! ::optimizer
[_ {:keys [::jsrt/pool]}]
[_ pool]
(l/info :hint "stopping svg optimizer pool")
(pu/close! pool))

80
backend/src/app/util/cache.clj
View File

@ -9,61 +9,71 @@
(:refer-clojure :exclude [get])
(:require
[app.util.time :as dt]
[promesa.core :as p]
[promesa.exec :as px])
(:import
com.github.benmanes.caffeine.cache.AsyncCache
com.github.benmanes.caffeine.cache.AsyncLoadingCache
com.github.benmanes.caffeine.cache.CacheLoader
com.github.benmanes.caffeine.cache.Cache
com.github.benmanes.caffeine.cache.Caffeine
com.github.benmanes.caffeine.cache.RemovalListener
com.github.benmanes.caffeine.cache.stats.CacheStats
java.time.Duration
java.util.concurrent.Executor
java.util.function.Function))
(set! *warn-on-reflection* true)
(defn create-listener
(defprotocol ICache
(get [_ k] [_ k load-fn] "get cache entry")
(invalidate! [_] [_ k] "invalidate cache"))
(defprotocol ICacheStats
(stats [_] "get stats"))
(defn- create-listener
[f]
(reify RemovalListener
(onRemoval [_ key val cause]
(when val
(f key val cause)))))
(defn create-loader
[f]
(reify CacheLoader
(load [_ key]
(f key))))
(defn- get-stats
[^Cache cache]
(let [^CacheStats stats (.stats cache)]
{:hit-rate (.hitRate stats)
:hit-count (.hitCount stats)
:req-count (.requestCount stats)
:miss-count (.missCount stats)
:miss-rate (.missRate stats)}))
(defn create
[& {:keys [executor on-remove load-fn keepalive]}]
(as-> (Caffeine/newBuilder) builder
(if on-remove (.removalListener builder (create-listener on-remove)) builder)
(if executor (.executor builder ^Executor (px/resolve-executor executor)) builder)
(if keepalive (.expireAfterAccess builder ^Duration (dt/duration keepalive)) builder)
(if load-fn
(.buildAsync builder ^CacheLoader (create-loader load-fn))
(.buildAsync builder))))
[& {:keys [executor on-remove max-size keepalive]}]
(let [cache (as-> (Caffeine/newBuilder) builder
(if (fn? on-remove) (.removalListener builder (create-listener on-remove)) builder)
(if executor (.executor builder ^Executor (px/resolve-executor executor)) builder)
(if keepalive (.expireAfterAccess builder ^Duration (dt/duration keepalive)) builder)
(if (int? max-size) (.maximumSize builder (long max-size)) builder)
(.recordStats builder)
(.buildAsync builder))
cache (.synchronous ^AsyncCache cache)]
(reify
ICache
(get [_ k]
(.getIfPresent ^Cache cache ^Object k))
(get [_ k load-fn]
(.get ^Cache cache
^Object k
^Function (reify Function
(apply [_ k]
(load-fn k)))))
(invalidate! [_]
(.invalidateAll ^Cache cache))
(invalidate! [_ k]
(.invalidateAll ^Cache cache ^Object k))
(defn invalidate-all!
[^AsyncCache cache]
(.invalidateAll (.synchronous cache)))
(defn get
([cache key]
(assert (instance? AsyncLoadingCache cache) "should be AsyncLoadingCache instance")
(p/await! (.get ^AsyncLoadingCache cache ^Object key)))
([cache key not-found-fn]
(assert (instance? AsyncCache cache) "should be AsyncCache instance")
(p/await! (.get ^AsyncCache cache
^Object key
^Function (reify
Function
(apply [_ key]
(not-found-fn key)))))))
ICacheStats
(stats [_]
(get-stats cache)))))
(defn cache?
[o]
(or (instance? AsyncCache o)
(instance? AsyncLoadingCache o)))
(satisfies? ICache o))

56
backend/src/app/util/pointer_map.clj
View File

@ -166,32 +166,36 @@
(assoc [this key val]
(when-not loaded? (load! this))
(let [odata (assoc odata key val)
mdata (assoc mdata :created-at (dt/now))
id (if modified? id (uuid/next))
pmap (PointerMap. id
mdata
odata
true
true)]
(some-> *tracked* (swap! assoc id pmap))
pmap))
(let [odata' (assoc odata key val)]
(if (identical? odata odata')
this
(let [mdata (assoc mdata :created-at (dt/now))
id (if modified? id (uuid/next))
pmap (PointerMap. id
mdata
odata'
true
true)]
(some-> *tracked* (swap! assoc id pmap))
pmap))))
(assocEx [_ _ _]
(throw (UnsupportedOperationException. "method not implemented")))
(without [this key]
(when-not loaded? (load! this))
(let [odata (dissoc odata key)
mdata (assoc mdata :created-at (dt/now))
id (if modified? id (uuid/next))
pmap (PointerMap. id
mdata
odata
true
true)]
(some-> *tracked* (swap! assoc id pmap))
pmap))
(let [odata' (dissoc odata key)]
(if (identical? odata odata')
this
(let [mdata (assoc mdata :created-at (dt/now))
id (if modified? id (uuid/next))
pmap (PointerMap. id
mdata
odata'
true
true)]
(some-> *tracked* (swap! assoc id pmap))
pmap))))
Counted
(count [this]
@ -206,6 +210,8 @@
(defn create
([]
(let [id (uuid/next)
mdata (assoc *metadata* :created-at (dt/now))
pmap (PointerMap. id mdata {} true true)]
(some-> *tracked* (swap! assoc id pmap))
@ -225,7 +231,15 @@
(do
(some-> *tracked* (swap! assoc (get-id data) data))
data)
(into (create) data)))
(let [mdata (assoc (meta data) :created-at (dt/now))
id (uuid/next)
pmap (PointerMap. id
mdata
data
true
true)]
(some-> *tracked* (swap! assoc id pmap))
pmap)))
(fres/add-handlers!
{:name "penpot/pointer-map/v1"

1
backend/src/app/util/time.clj
View File

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

29
backend/test/backend_tests/rpc_file_test.clj
View File

@ -166,18 +166,21 @@
:name "test"
:id page-id}])
;; Check the number of fragments
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(t/is (= 2 (count rows))))
;; Check the number of fragments
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(t/is (= 2 (count rows))))
;; The file-gc should remove unused fragments
;; The file-gc should mark for remove unused fragments
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
;; Check the number of fragments
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(t/is (= 2 (count rows))))
;; The objects-gc should remove unused fragments
(let [res (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 0 (:processed res))))
;; Check the number of fragments
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(t/is (= 2 (count rows))))
;; Add shape to page that should add a new fragment
(update-file!
@ -202,10 +205,14 @@
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(t/is (= 3 (count rows))))
;; The file-gc should remove unused fragments
;; The file-gc should mark for remove unused fragments
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
;; The objects-gc should remove unused fragments
(let [res (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 0 (:processed res))))
;; Check the number of fragments; should be 3 because changes
;; are also holding pointers to fragments;
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
@ -235,8 +242,6 @@
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(t/is (= 2 (count rows)))))))
(t/deftest file-gc-task-with-thumbnails
(letfn [(add-file-media-object [& {:keys [profile-id file-id]}]
(let [mfile {:filename "sample.jpg"

2
common/deps.edn
View File

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

13
common/src/app/common/data.cljc
View File

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

35
common/src/app/common/exceptions.cljc
View File

@ -7,10 +7,12 @@
(ns app.common.exceptions
"A helpers for work with exceptions."
#?(:cljs (:require-macros [app.common.exceptions]))
(:refer-clojure :exclude [instance?])
(:require
#?(:clj [clojure.stacktrace :as strace])
[app.common.pprint :as pp]
[app.common.schema :as sm]
[clojure.core :as c]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[expound.alpha :as expound])
@ -20,6 +22,9 @@
#?(:clj (set! *warn-on-reflection* true))
(def ^:dynamic *data-length* 8)
(def ^:dynamic *data-level* 8)
(defmacro error
[& {:keys [type hint] :as params}]
`(ex-info ~(or hint (name type))
@ -49,20 +54,38 @@
(defn ex-info?
[v]
(instance? #?(:clj clojure.lang.IExceptionInfo :cljs cljs.core.ExceptionInfo) v))
(c/instance? #?(:clj clojure.lang.IExceptionInfo :cljs cljs.core.ExceptionInfo) v))
(defn error?
[v]
(instance? #?(:clj clojure.lang.IExceptionInfo :cljs cljs.core.ExceptionInfo) v))
(c/instance? #?(:clj clojure.lang.IExceptionInfo :cljs cljs.core.ExceptionInfo) v))
(defn exception?
[v]
(instance? #?(:clj java.lang.Throwable :cljs js/Error) v))
(c/instance? #?(:clj java.lang.Throwable :cljs js/Error) v))
#?(:clj
(defn runtime-exception?
[v]
(instance? RuntimeException v)))
(c/instance? RuntimeException v)))
#?(:clj
(defn instance?
[class cause]
(loop [cause cause]
(if (c/instance? class cause)
true
(if-let [cause (ex-cause cause)]
(recur cause)
false)))))
;; NOTE: idea for a macro for error handling
;; (pu/try-let [cause (p/await (get-object-data backend object))]
;; (ex/instance? NoSuchKeyException cause)
;; (ex/raise :type :not-found
;; :code :object-not-found
;; :hint "s3 object not found"
;; :cause cause))
(defn explain
[data & {:as opts}]
@ -91,8 +114,8 @@
data? true
explain? true
chain? true
data-length 8
data-level 5}}]
data-length *data-length*
data-level *data-level*}}]
(letfn [(print-trace-element [^StackTraceElement e]
(let [class (.getClassName e)

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

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

210
common/src/app/common/files/migrations.cljc
View File

@ -19,9 +19,11 @@
[app.common.geom.shapes.text :as gsht]
[app.common.logging :as l]
[app.common.math :as mth]
[app.common.schema :as sm]
[app.common.svg :as csvg]
[app.common.text :as txt]
[app.common.types.shape :as cts]
[app.common.types.shape.shadow :as ctss]
[app.common.uuid :as uuid]
[cuerdas.core :as str]))
@ -31,6 +33,10 @@
(defmulti migrate :version)
(defn need-migration?
[{:keys [data]}]
(> cfd/version (:version data 0)))
(defn migrate-data
([data] (migrate-data data version))
([data to-version]
@ -318,19 +324,21 @@
(= "#7B7D85" fill-color)))
(dissoc :fill-color :fill-opacity))))
(update-container [{:keys [objects] :as container}]
(loop [objects objects
shapes (->> (vals objects)
(filter cfh/image-shape?))]
(if-let [shape (first shapes)]
(let [{:keys [id frame-id] :as shape'} (process-shape shape)]
(if (identical? shape shape')
(recur objects (rest shapes))
(recur (-> objects
(assoc id shape')
(d/update-when frame-id dissoc :thumbnail))
(rest shapes))))
(assoc container :objects objects))))]
(update-container [container]
(if (contains? container :objects)
(loop [objects (:objects container)
shapes (->> (vals objects)
(filter cfh/image-shape?))]
(if-let [shape (first shapes)]
(let [{:keys [id frame-id] :as shape'} (process-shape shape)]
(if (identical? shape shape')
(recur objects (rest shapes))
(recur (-> objects
(assoc id shape')
(d/update-when frame-id dissoc :thumbnail))
(rest shapes))))
(assoc container :objects objects)))
container))]
(-> data
(update :pages-index update-vals update-container)
@ -380,7 +388,7 @@
(assign-fills)))
(update-container [container]
(update container :objects update-vals update-object))]
(d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
@ -409,7 +417,7 @@
(assoc :fills [])))
(update-container [container]
(update container :objects update-vals update-object))]
(d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
@ -424,7 +432,7 @@
(dissoc :position-data)))
(update-container [container]
(update container :objects update-vals update-object))]
(d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
@ -440,7 +448,7 @@
(dissoc :position-data)))
(update-container [container]
(update container :objects update-vals update-object))]
(d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
@ -527,7 +535,7 @@
(assoc object :frame-id calculated-frame-id)))
(update-container [container]
(update container :objects #(update-vals % (partial update-object %))))]
(d/update-when container :objects #(update-vals % (partial update-object %))))]
(-> data
(update :pages-index update-vals update-container)
@ -565,22 +573,7 @@
(update :content #(txt/transform-nodes invalid-node? fix-node %)))))
(update-container [container]
(update container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
(defmethod migrate 30
[data]
(letfn [(update-object [object]
(if (and (cfh/frame-shape? object)
(not (:shapes object)))
(assoc object :shapes [])
object))
(update-container [container]
(update container :objects update-vals update-object))]
(d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
@ -613,7 +606,8 @@
object)))
(update-container [container]
(update container :objects update-vals update-object))]
(d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
@ -624,13 +618,13 @@
;; Ensure all root objects are well formed shapes.
(if (= (:id object) uuid/zero)
(-> object
(assoc :parent-id uuid/zero
:frame-id uuid/zero)
(assoc :parent-id uuid/zero)
(assoc :frame-id uuid/zero)
(cts/setup-shape))
object))
(update-container [container]
(update container :objects update-vals update-object))]
(d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container))))
@ -642,7 +636,7 @@
(dissoc object :x :y :width :height)
object))
(update-container [container]
(update container :objects update-vals update-object))]
(d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
@ -694,8 +688,144 @@
shape)))
(update-container [container]
(update container :objects update-vals update-shape))]
(d/update-when container :objects update-vals update-shape))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
(defmethod migrate 39
[data]
(letfn [(update-shape [shape]
(if (and (cfh/bool-shape? shape)
(not (contains? shape :bool-content)))
(assoc shape :bool-content [])
shape))
(update-container [container]
(d/update-when container :objects update-vals update-shape))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
(defmethod migrate 40
[data]
(letfn [(update-shape [{:keys [content shapes] :as shape}]
;; Fix frame shape that in reallity is a path shape
(if (and (cfh/frame-shape? shape)
(contains? shape :selrect)
(seq content)
(not (seq shapes))
(contains? (first content) :command))
(-> shape
(assoc :type :path)
(assoc :x nil)
(assoc :y nil)
(assoc :width nil)
(assoc :height nil))
shape))
(update-container [container]
(d/update-when container :objects update-vals update-shape))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
(defmethod migrate 41
[data]
(letfn [(update-shape [shape]
(cond
(or (cfh/bool-shape? shape)
(cfh/path-shape? shape))
shape
;; Fix all shapes that has geometry broken but still
;; preservers the selrect, so we recalculate the
;; geometry from selrect.
(and (contains? shape :selrect)
(or (nil? (:x shape))
(nil? (:y shape))
(nil? (:width shape))
(nil? (:height shape))))
(let [selrect (:selrect shape)]
(-> shape
(assoc :x (:x selrect))
(assoc :y (:y selrect))
(assoc :width (:width selrect))
(assoc :height (:height selrect))))
:else
shape))
(update-container [container]
(d/update-when container :objects update-vals update-shape))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
(defmethod migrate 42
[data]
(letfn [(update-object [object]
(if (and (or (cfh/frame-shape? object)
(cfh/group-shape? object)
(cfh/bool-shape? object))
(not (:shapes object)))
(assoc object :shapes [])
object))
(update-container [container]
(d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
(def ^:private valid-fill?
(sm/lazy-validator ::cts/fill))
(defmethod migrate 43
[data]
(letfn [(update-text-node [node]
(-> node
(d/update-when :fills #(filterv valid-fill? %))
(d/without-nils)))
(update-object [object]
(if (cfh/text-shape? object)
(update object :content #(txt/transform-nodes identity update-text-node %))
object))
(update-container [container]
(d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
(def ^:private valid-shadow?
(sm/lazy-validator ::ctss/shadow))
(defmethod migrate 44
[data]
(letfn [(fix-shadow [shadow]
(if (string? (:color shadow))
(let [color {:color (:color shadow)
:opacity 1}]
(assoc shadow :color color))
shadow))
(update-object [object]
(d/update-when object :shadow
#(into []
(comp (map fix-shadow)
(filter valid-shadow?))
%)))
(update-container [container]
(d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))

13
common/src/app/common/files/repair.cljc
View File

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

116
common/src/app/common/files/validate.cljc
View File

@ -26,6 +26,7 @@
#{:invalid-geometry
:parent-not-found
:child-not-in-parent
:duplicated-children
:child-not-found
:frame-not-found
:invalid-frame
@ -105,7 +106,7 @@
(nil? (:selrect shape))
(nil? (:points shape))))
(report-error :invalid-geometry
"Shape greometry is invalid"
"Shape geometry is invalid"
shape file page)))
(defn- check-parent-children
@ -123,6 +124,11 @@
(str/ffmt "Shape % not in parent's children list" (:id shape))
shape file page)))
(when-not (= (count (:shapes shape)) (count (distinct (:shapes shape))))
(report-error :duplicated-children
(str/ffmt "Shape % has duplicated children" (:id shape))
shape file page))
(doseq [child-id (:shapes shape)]
(let [child (ctst/get-shape page child-id)]
(if (nil? child)
@ -367,64 +373,63 @@
[shape-id file page libraries & {:keys [context] :or {context :not-component}}]
(let [shape (ctst/get-shape page shape-id)]
(when (some? shape)
(do
(check-geometry shape file page)
(check-parent-children shape file page)
(check-frame shape file page)
(check-geometry shape file page)
(check-parent-children shape file page)
(check-frame shape file page)
(if (ctk/instance-head? shape)
(if (not= :frame (:type shape))
(report-error :instance-head-not-frame
"Instance head should be a frame"
(if (ctk/instance-head? shape)
(if (not= :frame (:type shape))
(report-error :instance-head-not-frame
"Instance head should be a frame"
shape file page)
(if (ctk/instance-root? shape)
(if (ctk/main-instance? shape)
(if (not= context :not-component)
(report-error :root-main-not-allowed
"Root main component not allowed inside other component"
shape file page)
(check-shape-main-root-top shape file page libraries))
(if (not= context :not-component)
(report-error :root-copy-not-allowed
"Root copy component not allowed inside other component"
shape file page)
(check-shape-copy-root-top shape file page libraries)))
(if (ctk/main-instance? shape)
;; mains can't be nested into mains
(if (or (= context :not-component) (= context :main-top))
(report-error :nested-main-not-allowed
"Nested main component only allowed inside other component"
shape file page)
(check-shape-main-root-nested shape file page libraries))
(if (= context :not-component)
(report-error :nested-copy-not-allowed
"Nested copy component only allowed inside other component"
shape file page)
(check-shape-copy-root-nested shape file page libraries)))))
(if (ctk/in-component-copy? shape)
(if-not (#{:copy-top :copy-nested :copy-any} context)
(report-error :not-head-copy-not-allowed
"Non-root copy only allowed inside a copy"
shape file page)
(check-shape-copy-not-root shape file page libraries))
(if (ctk/instance-root? shape)
(if (ctk/main-instance? shape)
(if (not= context :not-component)
(report-error :root-main-not-allowed
"Root main component not allowed inside other component"
shape file page)
(check-shape-main-root-top shape file page libraries))
(if (not= context :not-component)
(report-error :root-copy-not-allowed
"Root copy component not allowed inside other component"
shape file page)
(check-shape-copy-root-top shape file page libraries)))
(if (ctk/main-instance? shape)
;; mains can't be nested into mains
(if (or (= context :not-component) (= context :main-top))
(report-error :nested-main-not-allowed
"Nested main component only allowed inside other component"
shape file page)
(check-shape-main-root-nested shape file page libraries))
(if (= context :not-component)
(report-error :nested-copy-not-allowed
"Nested copy component only allowed inside other component"
shape file page)
(check-shape-copy-root-nested shape file page libraries)))))
(if (ctk/in-component-copy? shape)
(if-not (#{:copy-top :copy-nested :copy-any} context)
(report-error :not-head-copy-not-allowed
"Non-root copy only allowed inside a copy"
(if (ctn/inside-component-main? (:objects page) shape)
(if-not (#{:main-top :main-nested :main-any} context)
(report-error :not-head-main-not-allowed
"Non-root main only allowed inside a main component"
shape file page)
(check-shape-copy-not-root shape file page libraries))
(check-shape-main-not-root shape file page libraries))
(if (ctn/inside-component-main? (:objects page) shape)
(if-not (#{:main-top :main-nested :main-any} context)
(report-error :not-head-main-not-allowed
"Non-root main only allowed inside a main component"
shape file page)
(check-shape-main-not-root shape file page libraries))
(if (#{:main-top :main-nested :main-any} context)
(report-error :not-component-not-allowed
"Not compoments are not allowed inside a main"
shape file page)
(check-shape-not-component shape file page libraries)))))))))
(if (#{:main-top :main-nested :main-any} context)
(report-error :not-component-not-allowed
"Not compoments are not allowed inside a main"
shape file page)
(check-shape-not-component shape file page libraries))))))))
(defn- check-component
"Validate semantic coherence of a component. Report all errors found."
@ -484,6 +489,9 @@
(sm/lazy-explainer ::ctf/data))
(defn validate-file-schema!
"Validates the file itself, without external dependencies, it
performs the schema checking and some semantical validation of the
content."
[{:keys [id data] :as file}]
(when-not (valid-fdata? data)
(ex/raise :type :validation

1
common/src/app/common/geom/shapes/path.cljc
View File

@ -981,6 +981,7 @@
selrect (-> points
(gco/transform-points points-center transform-inverse)
(grc/points->rect))]
[points selrect]))
(defn open-path?

7
common/src/app/common/schema.cljc
View File

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

10
common/src/app/common/schema/generators.cljc
View File

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

56
common/src/app/common/svg.cljc
View File

@ -31,7 +31,7 @@
(def xml-id-regex #"#([:A-Z_a-z\xC0-\xD6\xD8-\xF6\xF8-\u02FF\u0370-\u037D\u037F-\u1FFF\u200C-\u200D\u2070-\u218F\u2C00-\u2FEF\u3001-\uD7FF\uF900-\uFDCF\uFDF0-\uFFFD\u10000-\uEFFFF][\.\-\:0-9\xB7A-Z_a-z\xC0-\xD6\xD8-\xF6\xF8-\u02FF\u0300-\u036F\u0370-\u037D\u037F-\u1FFF\u200C-\u200D\u203F-\u2040\u2070-\u218F\u2C00-\u2FEF\u3001-\uD7FF\uF900-\uFDCF\uFDF0-\uFFFD\u10000-\uEFFFF]*)")
(def matrices-regex #"(matrix|translate|scale|rotate|skewX|skewY)\(([^\)]*)\)")
(def number-regex #"[+-]?\d*(\.\d+)?(e[+-]?\d+)?")
(def number-regex #"[+-]?\d*(\.\d+)?([eE][+-]?\d+)?")
(def tags-to-remove #{:linearGradient :radialGradient :metadata :mask :clipPath :filter :title})
@ -759,40 +759,39 @@
;; Transforms spec:
;; https://www.w3.org/TR/SVG11/single-page.html#coords-TransformAttribute
(defn format-translate-params
(defn- format-translate-params
[params]
(assert (or (= (count params) 1) (= (count params) 2)))
(if (= (count params) 1)
[(gpt/point (nth params 0) 0)]
[(gpt/point (nth params 0) (nth params 1))]))
(defn format-scale-params
(defn- format-scale-params
[params]
(assert (or (= (count params) 1) (= (count params) 2)))
(if (= (count params) 1)
[(gpt/point (nth params 0))]
[(gpt/point (nth params 0) (nth params 1))]))
(defn format-rotate-params
(defn- format-rotate-params
[params]
(assert (or (= (count params) 1) (= (count params) 3)) (str "??" (count params)))
(if (= (count params) 1)
[(nth params 0) (gpt/point 0 0)]
[(nth params 0) (gpt/point (nth params 1) (nth params 2))]))
(defn format-skew-x-params
(defn- format-skew-x-params
[params]
(assert (= (count params) 1))
[(nth params 0) 0])
(defn format-skew-y-params
(defn- format-skew-y-params
[params]
(assert (= (count params) 1))
[0 (nth params 0)])
(defn to-matrix
[{:keys [type params]}]
(assert (#{"matrix" "translate" "scale" "rotate" "skewX" "skewY"} type))
(defn- to-matrix
[type params]
(case type
"matrix" (apply gmt/matrix params)
"translate" (apply gmt/translate-matrix (format-translate-params params))
@ -802,19 +801,17 @@
"skewY" (apply gmt/skew-matrix (format-skew-y-params params))))
(defn parse-transform
[transform-attr]
(if transform-attr
(let [process-matrix
(fn [[_ type params]]
(let [params (->> (re-seq number-regex params)
(filter #(-> % first seq))
(map (comp d/parse-double first)))]
{:type type :params params}))
[transform]
(if (string? transform)
(->> (re-seq matrices-regex transform)
(map (fn [[_ type params]]
(let [params (->> (re-seq number-regex params)
(map first)
(keep not-empty)
(map d/parse-double))]
(to-matrix type params))))
(reduce gmt/multiply (gmt/matrix)))
matrices (->> (re-seq matrices-regex transform-attr)
(map process-matrix)
(map to-matrix))]
(reduce gmt/multiply (gmt/matrix) matrices))
(gmt/matrix)))
(defn format-move [[x y]] (str "M" x " " y))
@ -872,17 +869,21 @@
transform
(update :transform append-transform))))
(defn inherit-attributes [group-attrs {:keys [attrs] :as node}]
(defn inherit-attributes
[group-attrs {:keys [attrs] :as node}]
(if (map? node)
(let [attrs (-> (format-styles attrs)
(add-transform (:transform group-attrs)))
(let [attrs (-> (format-styles attrs)
(add-transform (:transform group-attrs)))
group-attrs (format-styles group-attrs)
;; Don't inherit a property that is already in the style attribute
inherit-style (-> (:style group-attrs) (d/without-keys (keys attrs)))
inheritable-props (->> inheritable-props (remove #(contains? (:styles attrs) %)))
group-attrs (-> group-attrs (assoc :style inherit-style))
attrs (d/deep-merge (select-keys group-attrs inheritable-props) attrs)]
attrs (-> (select-keys group-attrs inheritable-props)
(d/deep-merge attrs)
(d/without-nils))]
(assoc node :attrs attrs))
node))
@ -964,8 +965,7 @@
is-other? #{:r :stroke-width}]
(if is-percent?
;; JS parseFloat removes the % symbol
(let [attr-num (d/parse-double attr-val)]
(let [attr-num (d/parse-double (str/rtrim attr-val "%"))]
(str (cond
(is-x? attr-key) (fix-coord :x :width attr-num)
(is-y? attr-key) (fix-coord :y :height attr-num)
@ -981,7 +981,7 @@
(fix-percent-attr-numeric [_ attr-val]
(let [is-percent? (str/ends-with? attr-val "%")]
(if is-percent?
(str (let [attr-num (d/parse-double attr-val)]
(str (let [attr-num (d/parse-double (str/rtrim attr-val "%"))]
(/ attr-num 100)))
attr-val)))

60
common/src/app/common/svg/shapes_builder.cljc
View File

@ -57,13 +57,15 @@
clean-value))
(defn- svg-dimensions
[data]
(let [width (dm/get-in data [:attrs :width] 100)
height (dm/get-in data [:attrs :height] 100)
viewbox (or (dm/get-in data [:attrs :viewBox])
[{:keys [attrs] :as data}]
(let [width (:width attrs 100)
height (:height attrs 100)
viewbox (or (:viewBox attrs)
(dm/str "0 0 " width " " height))
[x y width height] (->> (str/split viewbox #"\s+")
[x y width height] (->> (str/split viewbox #"[\s,]+")
(map d/parse-double))
width (if (= width 0) 1 width)
height (if (= height 0) 1 height)]
@ -303,6 +305,11 @@
rx (d/nilv r rx)
ry (d/nilv r ry)
;; There are some svg circles in the internet that does not
;; have cx and cy attrs, so we default them to 0
cx (d/nilv cx 0)
cy (d/nilv cy 0)
origin (gpt/negate (gpt/point svg-data))
rect (grc/make-rect
@ -502,8 +509,16 @@
att-refs (csvg/find-attr-references attrs)
defs (get svg-data :defs)
references (csvg/find-def-references defs att-refs)
href-id (-> (or (:href attrs) (:xlink:href attrs) " ") (subs 1))
use-tag? (and (= :use tag) (contains? defs href-id))]
href-id (or (:href attrs) (:xlink:href attrs) " ")
href-id (if (and (string? href-id)
(pos? (count href-id)))
(subs href-id 1)
href-id)
use-tag? (and (= :use tag)
(some? href-id)
(contains? defs href-id))]
(if use-tag?
(let [;; Merge the data of the use definition with the properties passed as attributes
@ -532,21 +547,20 @@
:image (create-image-shape name frame-id svg-data element)
#_other (create-raw-svg name frame-id svg-data element))]
(when (some? shape)
(let [shape (-> shape
(assoc :svg-defs (select-keys defs references))
(setup-fill)
(setup-stroke)
(setup-opacity)
(setup-other)
(update :svg-attrs (fn [attrs]
(if (empty? (:style attrs))
(dissoc attrs :style)
attrs))))]
[(cond-> shape
hidden (assoc :hidden true))
[(-> shape
(assoc :svg-defs (select-keys defs references))
(setup-fill)
(setup-stroke)
(setup-opacity)
(setup-other)
(update :svg-attrs (fn [attrs]
(if (empty? (:style attrs))
(dissoc attrs :style)
attrs)))
(cond-> ^boolean hidden
(assoc :hidden true)))
(cond->> (:content element)
(contains? csvg/parent-tags tag)
(mapv #(csvg/inherit-attributes attrs %)))]))))))
(cond->> (:content element)
(contains? csvg/parent-tags tag)
(mapv (partial csvg/inherit-attributes attrs)))])))))

53
common/src/app/common/time.cljc
View File

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

26
common/src/app/common/types/color.cljc
View File

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

11
common/src/app/common/types/page.cljc
View File

@ -7,7 +7,6 @@
(ns app.common.types.page
(:require
[app.common.data :as d]
[app.common.features :as cfeat]
[app.common.schema :as sm]
[app.common.types.color :as-alias ctc]
[app.common.types.grid :as ctg]
@ -71,13 +70,9 @@
(defn make-empty-page
[id name]
(let [wrap-objects-fn cfeat/*wrap-with-objects-map-fn*
wrap-pointer-fn cfeat/*wrap-with-pointer-map-fn*]
(-> empty-page-data
(assoc :id id)
(assoc :name name)
(update :objects wrap-objects-fn)
(wrap-pointer-fn))))
(-> empty-page-data
(assoc :id id)
(assoc :name name)))
;; --- Helpers for flow

117
common/src/app/common/types/shape.cljc
View File

@ -25,6 +25,7 @@
[app.common.types.shape.export :as ctse]
[app.common.types.shape.interactions :as ctsi]
[app.common.types.shape.layout :as ctsl]
[app.common.types.shape.path :as ctsp]
[app.common.types.shape.shadow :as ctss]
[app.common.types.shape.text :as ctsx]
[app.common.uuid :as uuid]
@ -46,6 +47,7 @@
:bool
:rect
:path
:text
:circle
:svg-raw
:image})
@ -126,21 +128,24 @@
[:stroke-color-gradient {:optional true} ::ctc/gradient]
[:stroke-image {:optional true} ::ctc/image-color]])
(sm/define! ::minimal-shape-attrs
(sm/define! ::shape-base-attrs
[:map {:title "ShapeMinimalRecord"}
[:id {:optional false} ::sm/uuid]
[:name {:optional false} :string]
[:type {:optional false} [::sm/one-of shape-types]]
[:x {:optional false} [:maybe ::sm/safe-number]]
[:y {:optional false} [:maybe ::sm/safe-number]]
[:width {:optional false} [:maybe ::sm/safe-number]]
[:height {:optional false} [:maybe ::sm/safe-number]]
[:selrect {:optional false} ::selrect]
[:points {:optional false} ::points]
[:transform {:optional false} ::gmt/matrix]
[:transform-inverse {:optional false} ::gmt/matrix]
[:parent-id {:optional false} ::sm/uuid]
[:frame-id {:optional false} ::sm/uuid]])
[:id ::sm/uuid]
[:name :string]
[:type [::sm/one-of shape-types]]
[:selrect ::selrect]
[:points ::points]
[:transform ::gmt/matrix]
[:transform-inverse ::gmt/matrix]
[:parent-id ::sm/uuid]
[:frame-id ::sm/uuid]])
(sm/define! ::shape-geom-attrs
[:map {:title "ShapeGeometryAttrs"}
[:x ::sm/safe-number]
[:y ::sm/safe-number]
[:width ::sm/safe-number]
[:height ::sm/safe-number]])
(sm/define! ::shape-attrs
[:map {:title "ShapeAttrs"}
@ -199,7 +204,7 @@
(sm/define! ::group-attrs
[:map {:title "GroupAttrs"}
[:type [:= :group]]
[:shapes {:optional true} [:maybe [:vector {:gen/max 10 :gen/min 1} ::sm/uuid]]]])
[:shapes [:vector {:gen/max 10 :gen/min 1} ::sm/uuid]]])
(sm/define! ::frame-attrs
[:map {:title "FrameAttrs"}
@ -212,7 +217,7 @@
(sm/define! ::bool-attrs
[:map {:title "BoolAttrs"}
[:type [:= :bool]]
[:shapes {:optional true} [:maybe [:vector {:gen/max 10 :gen/min 1} ::sm/uuid]]]
[:shapes [:vector {:gen/max 10 :gen/min 1} ::sm/uuid]]
;; FIXME: improve this schema
[:bool-type :keyword]
@ -252,16 +257,7 @@
(sm/define! ::path-attrs
[:map {:title "PathAttrs"}
[:type [:= :path]]
[:x {:optional true} [:maybe ::sm/safe-number]]
[:y {:optional true} [:maybe ::sm/safe-number]]
[:width {:optional true} [:maybe ::sm/safe-number]]
[:height {:optional true} [:maybe ::sm/safe-number]]
[:content
{:optional true}
[:vector
[:map
[:command :keyword]
[:params {:optional true} [:maybe :map]]]]]])
[:content ::ctsp/content]])
(sm/define! ::text-attrs
[:map {:title "TextAttrs"}
@ -271,72 +267,96 @@
(sm/define! ::shape-map
[:multi {:dispatch :type :title "Shape"}
[:group
[:merge {:title "GroupShape"}
[:and {:title "GroupShape"}
::shape-base-attrs
::shape-geom-attrs
::shape-attrs
::minimal-shape-attrs
::group-attrs
::ctsl/layout-child-attrs]]
[:frame
[:merge {:title "FrameShape"}
::minimal-shape-attrs
[:and {:title "FrameShape"}
::shape-base-attrs
::shape-geom-attrs
::frame-attrs
::ctsl/layout-attrs
::ctsl/layout-child-attrs]]
[:bool
[:merge {:title "BoolShape"}
[:and {:title "BoolShape"}
::shape-base-attrs
::shape-attrs
::minimal-shape-attrs
::bool-attrs
::ctsl/layout-child-attrs]]
[:rect
[:merge {:title "RectShape"}
[:and {:title "RectShape"}
::shape-base-attrs
::shape-geom-attrs
::shape-attrs
::minimal-shape-attrs
::rect-attrs
::ctsl/layout-child-attrs]]
[:circle
[:merge {:title "CircleShape"}
[:and {:title "CircleShape"}
::shape-base-attrs
::shape-geom-attrs
::shape-attrs
::minimal-shape-attrs
::circle-attrs
::ctsl/layout-child-attrs]]
[:image
[:merge {:title "ImageShape"}
[:and {:title "ImageShape"}
::shape-base-attrs
::shape-geom-attrs
::shape-attrs
::minimal-shape-attrs
::image-attrs
::ctsl/layout-child-attrs]]
[:svg-raw
[:merge {:title "SvgRawShape"}
[:and {:title "SvgRawShape"}
::shape-base-attrs
::shape-geom-attrs
::shape-attrs
::minimal-shape-attrs
::svg-raw-attrs
::ctsl/layout-child-attrs]]
[:path
[:merge {:title "PathShape"}
[:and {:title "PathShape"}
::shape-base-attrs
::shape-attrs
::minimal-shape-attrs
::path-attrs
::ctsl/layout-child-attrs]]
[:text
[:merge {:title "TextShape"}
[:and {:title "TextShape"}
::shape-base-attrs
::shape-geom-attrs
::shape-attrs
::minimal-shape-attrs
::text-attrs
::ctsl/layout-child-attrs]]])
(sm/define! ::shape
[:and
{:title "Shape"
:gen/gen (->> (sg/generator ::shape-map)
:gen/gen (->> (sg/generator ::shape-base-attrs)
(sg/mcat (fn [{:keys [type] :as shape}]
(sg/let [attrs1 (sg/generator ::shape-attrs)
attrs2 (sg/generator ::shape-geom-attrs)
attrs3 (case type
:text (sg/generator ::text-attrs)
:path (sg/generator ::path-attrs)
:svg-raw (sg/generator ::svg-raw-attrs)
:image (sg/generator ::image-attrs)
:circle (sg/generator ::circle-attrs)
:rect (sg/generator ::rect-attrs)
:bool (sg/generator ::bool-attrs)
:group (sg/generator ::group-attrs)
:frame (sg/generator ::frame-attrs))]
(if (or (= type :path)
(= type :bool))
(merge attrs1 shape attrs3)
(merge attrs1 shape attrs2 attrs3)))))
(sg/fmap map->Shape))}
::shape-map
[:fn shape?]])
@ -491,7 +511,12 @@
the shape. The props must have :x :y :width :height."
[{:keys [type] :as props}]
(let [shape (make-minimal-shape type)
shape (merge shape (d/without-nils props))
;; The props can be custom records that does not
;; work properly with without-nils, so we first make
;; it plain map for proceed
props (d/without-nils (into {} props))
shape (merge shape (d/without-nils (into {} props)))
shape (case (:type shape)
(:bool :path) (setup-path shape)
:image (-> shape setup-rect setup-image)

47
common/src/app/common/types/shape/path.cljc Normal file
View File

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

12
common/src/app/common/types/shape/shadow.cljc
View File

@ -7,8 +7,7 @@
(ns app.common.types.shape.shadow
(:require
[app.common.schema :as sm]
[app.common.types.color :as ctc]
[app.common.types.shape.shadow.color :as-alias shadow-color]))
[app.common.types.color :as ctc]))
(def styles #{:drop-shadow :inner-shadow})
@ -21,11 +20,4 @@
[:blur ::sm/safe-number]
[:spread ::sm/safe-number]
[:hidden :boolean]
;;FIXME: reuse color?
[:color
[:map
[:color {:optional true} :string]
[:opacity {:optional true} ::sm/safe-number]
[:gradient {:optional true} [:maybe ::ctc/gradient]]
[:file-id {:optional true} [:maybe ::sm/uuid]]
[:id {:optional true} [:maybe ::sm/uuid]]]]])
[:color ::ctc/color]])

9
common/src/app/common/uuid.cljc
View File

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