From 38004e6bb2bcf33935aa42af2ba6e1e0f5637a5a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=81lvaro=20Tejero-Cantero?= <807608+alvorithm@users.noreply.github.com> Date: Thu, 27 Aug 2026 18:54:56 +0200 Subject: [PATCH] :sparkles: Add the graph subsystem and graph visualization console to the backend (#11101) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * :tada: Basic lbug connection for ingestion * :sparkles: Add Penpot-to-Ladybug graph ingest vertical slice * :sparkles: Use embedded Ladybug Java API instead of CLI * :recycle: Share Ladybug connection across ingest and stats * :sparkles: Validate graph ingest projections with Malli * :sparkles: Project nested shapes recursively into the graph * :zap: Load graph ingest via Ladybug COPY bulk import * :bug: Fix graph COPY ingest for multiline text names * :sparkles: Add Ladybug graph export to debug UI * :sparkles: Add debug graph console for in-memory Cypher queries * :sparkles: Add live file-change feed to debug graph console * :sparkles: Incrementally sync debug graph from Penpot file changes * :sparkles: Handle mov-objects in debug graph sync * :bug: Fix batch delete sync and keep graph console feed alive * :recycle: Derive graph node schema from Malli registry * :sparkles: Add G6 graph view to debug graph console POC per work/g6/plan.md. New /dbg/actions/graph-data exports the in-memory Ladybug session as plain JSON (per-table node queries + multi-table IsChildOf match, row cap 100k with truncation flag). Console page renders it with AntV G6 v5 (jsDelivr CDN, antv-dagre BT layout, color+glyph per node table, validated palette) and refetches debounced on live :file-change messages. Signed-off-by: Álvaro Tejero Cantero * :bug: Fix list-column CSV ingest and serialize graph session access COPY failed on any file with container shapes: list-typed DDL columns (shapes UUID[], points STRING[], strokes JSON[], ...) were JSON-encoded in staging CSVs, which Ladybug's list parser rejects. Write Kuzu list literals instead, typed per column. Also: value->clj no longer crashes on LIST/STRUCT values (binding lacks value_get_value support; fall back to string), and the debug session Connection is now guarded by a per-session lock — it was shared unsynchronized between the msgbus sync loop and HTTP query/export handlers, and one lost DETACH DELETE was observed under concurrent refetch load. Signed-off-by: Álvaro Tejero Cantero * :sparkles: Split graph console in two columns; add file tree and fullscreen Graph view moves to its own sticky right column (overrides .widget max-width). New /dbg/actions/graph-files endpoint lists teams -> projects -> files for the profile; the console renders it as a collapsible tree where clicking a file loads it. Maximize button fullscreens the graph panel and resizes G6 on fullscreenchange. Signed-off-by: Álvaro Tejero Cantero * :recycle: Replace fullscreen with in-page expand for graph view Fullscreen API took over the whole output and broke window-manager splits (and is denied in some environments). The Expand button now toggles a fixed-position overlay covering the page while keeping browser chrome; Esc restores. Column positioning moved from inline style to the stylesheet so the expanded class can override it. Signed-off-by: Álvaro Tejero Cantero * :sparkles: Fold containers as collapsible combos in graph view Non-empty containers (Page, Frame, Group, Boolean, SVGRaw) render as nested G6 rect combos holding their own node plus direct children; Document stays a plain node. Double-click folds/expands (collapse-expand behavior); collapsed combos show a member count and re-route child edges. Fold state is read back from getComboData and re-marked on every refetch, so it survives live redraws. Layout gains sortByCombo to keep same-rank nodes grouped by box. Signed-off-by: Álvaro Tejero Cantero * :zap: Fix graph view freeze on large files; add fold toggle and root rule Root cause of the tab freeze on ~1700-node files was G6's default entrance animation: measured 1700 nodes at >2 min animated vs 1.5 s with animation: false. Secondary cost was antv-dagre (~7 s at that size); since IsChildOf is a tree, an O(n) tidy layout (depth = rank, post-order leaf slots, parents centered) computed client-side replaces it and renders the same file in ~1.4 s. A guard skips auto-render above 4000 nodes with an explicit Render-anyway button, so opening the console with a huge session loaded stays responsive. Folding is now switchable ('fold containers' checkbox, persisted in localStorage) and generalized: any node with children folds except the IsChildOf root of the loaded graph, so Documents (and later Projects/Teams) fold automatically once they gain a parent node. Signed-off-by: Álvaro Tejero Cantero * :sparkles: Add layout dropdown to graph view Adds a layout + +
+ + Open graph console +
+ + + {% endif %}
Import binfile: Import penpot file in binary format. diff --git a/backend/resources/app/templates/graph-console.tmpl b/backend/resources/app/templates/graph-console.tmpl new file mode 100644 index 0000000000..8746e65ec3 --- /dev/null +++ b/backend/resources/app/templates/graph-console.tmpl @@ -0,0 +1,1758 @@ +{% extends "app/templates/base.tmpl" %} + +{% block title %} +Graph Console +{% endblock %} + +{% block content %} + +
+ +
+

← Back to debug

+ +
+
+ +
+ Load graph from Penpot + + Click file or paste UUID to load Penpot file into an in-memory + Ladybug database. Loading a new file replaces the previous one. + +
Loading…
+
+
+ + {% if session %} + + + {% else %} + + {% endif %} +
+
+ {% if session %} +
+ {% endif %} +
+ + {% if session %} +
+ Loaded session ({{session.loaded-at}}) + +

+ File: {{session.name}} +
+ + Revisions: ingested at {{session.revn}} · graph now + {% if session.graph-revn %}{{session.graph-revn}}{% else %}{{session.revn}}{% endif %} +
+ Graph size: …
+ Schema: {{session.schema-version}} +

+

+ Feed: connecting… + +

+ +
+ + + +
+ Query graph, read-only (LadybugDB Cypher) +
+
+ +
+
+ +
+
+
+ +
+ {% if error %} +
+ Error + 
{{error}}
+
+ {% endif %} + + {% if query-result %} +
+ Results ({{query-result.row-count}} rows{% if query-result.truncated? %}, truncated{% endif %}) +
+ + + + {% for column in query-result.columns %} + + {% endfor %} + + + + {% for row in query-result.rows %} + + {% for cell in row %} + + {% endfor %} + + {% endfor %} + +
{{column}}
{{cell}}
+
+
+ {% endif %} +
+ {% endif %} + +
+ + {% if session %} +
+
+ Graph view + + + + + + + + + Live view of the in-memory Ladybug graph (AntV G6). Double-click + folds containers when folding is on. + +
+
+
+ + + +
+
+ {% endif %} + +
+
+
+ + + + + +{% if session %} + + +{% endif %} +{% endblock %} diff --git a/backend/scripts/_env b/backend/scripts/_env index 724b55f05b..5e4b02b80a 100644 --- a/backend/scripts/_env +++ b/backend/scripts/_env @@ -93,7 +93,8 @@ export JAVA_OPTS="\ -XX:-OmitStackTraceInFastThrow \ --sun-misc-unsafe-memory-access=allow \ --enable-preview \ - --enable-native-access=ALL-UNNAMED"; + --enable-native-access=ALL-UNNAMED \ + --add-opens=java.base/java.nio=ALL-UNNAMED"; function setup_minio() { if [ "${PENPOT_OBJECTS_STORAGE_BACKEND}" != "s3" ]; then diff --git a/backend/scripts/run.template.sh b/backend/scripts/run.template.sh index cff4afc870..19f47e6c0a 100644 --- a/backend/scripts/run.template.sh +++ b/backend/scripts/run.template.sh @@ -18,7 +18,7 @@ if [ -f ./environ ]; then source ./environ fi -export JAVA_OPTS="-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager -Dlog4j2.configurationFile=log4j2.xml -XX:-OmitStackTraceInFastThrow --sun-misc-unsafe-memory-access=allow --enable-native-access=ALL-UNNAMED --enable-preview $JVM_OPTS $JAVA_OPTS" +export JAVA_OPTS="-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager -Dlog4j2.configurationFile=log4j2.xml -XX:-OmitStackTraceInFastThrow --sun-misc-unsafe-memory-access=allow --enable-native-access=ALL-UNNAMED --add-opens=java.base/java.nio=ALL-UNNAMED --enable-preview $JVM_OPTS $JAVA_OPTS" ENTRYPOINT=${1:-app.main}; diff --git a/backend/src/app/graph/arrow.clj b/backend/src/app/graph/arrow.clj new file mode 100644 index 0000000000..55be1b8b64 --- /dev/null +++ b/backend/src/app/graph/arrow.clj @@ -0,0 +1,370 @@ +;; 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 Sucursal en España SL + +(ns app.graph.arrow + "Bulk Ladybug ingest through in-memory Arrow. + + Rows are built as Arrow `VectorSchemaRoot`s in the JVM's off-heap memory, + handed to Ladybug as a virtual table, and `COPY`d into the real one. No file + is written and no value is rendered as text for the engine to re-parse, so + nothing in this path needs escaping. Arrow carries MAP, STRUCT, fixed-size + arrays and multi-line strings natively. + + The type language is Ladybug's, read recursively by `app.graph.schema.values`; + this namespace adds the matching Arrow `Field` and a writer for each shape. + `values/coerce` shapes a value first — a matrix into six doubles, a colour + into a packed integer — exactly as it does for the Cypher path, so the two + writers cannot disagree. + + Engine facts this file depends on, each verified against lbug 0.19.1: + + - An Arrow table is **not** a `COPY` source identifier, but it *is* a + MATCH-able node label: `COPY T FROM (MATCH (n:stg) RETURN n.a AS a, …)`. + - A MAP vector's `entries` child struct must be non-nullable, and + `MapVector/getWriter` silently promotes it to a sparse union — so map + vectors are built from an explicit `Field` and filled child-first. + - Ladybug quotes the column and table names it interpolates into the staged + table's DDL, and does not quote a STRUCT member name. So a top-level field + arrives plain and a struct member whose name is a reserved word (`column`) + arrives backticked. + - `createArrowRelTable` resolves a UUID-keyed endpoint only from a + `FixedSizeBinary(16)` column carrying the `arrow.uuid` extension, so edges + are staged as a node table and joined by the `COPY` subquery instead." + (:require + [app.common.json :as json] + [app.graph.ladybug :as ladybug] + [app.graph.schema.nodes :as nodes] + [app.graph.schema.values :as values] + [clojure.string :as str]) + (:import + com.ladybugdb.Connection + com.ladybugdb.QueryResult + java.nio.charset.StandardCharsets + java.util.ArrayList + java.util.List + org.apache.arrow.memory.BufferAllocator + org.apache.arrow.memory.RootAllocator + org.apache.arrow.vector.BigIntVector + org.apache.arrow.vector.BitVector + org.apache.arrow.vector.complex.ListVector + org.apache.arrow.vector.complex.MapVector + org.apache.arrow.vector.complex.StructVector + org.apache.arrow.vector.FieldVector + org.apache.arrow.vector.Float8Vector + org.apache.arrow.vector.TimeStampMicroVector + org.apache.arrow.vector.types.FloatingPointPrecision + org.apache.arrow.vector.types.pojo.ArrowType$Bool + org.apache.arrow.vector.types.pojo.ArrowType$FloatingPoint + org.apache.arrow.vector.types.pojo.ArrowType$Int + org.apache.arrow.vector.types.pojo.ArrowType$List + org.apache.arrow.vector.types.pojo.ArrowType$Map + org.apache.arrow.vector.types.pojo.ArrowType$Struct + org.apache.arrow.vector.types.pojo.ArrowType$Timestamp + org.apache.arrow.vector.types.pojo.ArrowType$Utf8 + org.apache.arrow.vector.types.pojo.Field + org.apache.arrow.vector.types.pojo.FieldType + org.apache.arrow.vector.types.pojo.Schema + org.apache.arrow.vector.types.TimeUnit + org.apache.arrow.vector.UInt4Vector + org.apache.arrow.vector.VarCharVector + org.apache.arrow.vector.VectorSchemaRoot)) + +(set! *warn-on-reflection* true) + +;; --------------------------------------------------------------- allocator + +(defn with-allocator! + "Invoke `(f allocator)` with a fresh Arrow `RootAllocator`. + + The allocator must outlive the Ladybug connection, because Ladybug releases + its references to the staged buffers only when the Arrow tables are dropped — + which happens on connection close at the latest. Closing it first surfaces as + `IllegalStateException: Memory was leaked`, *thrown while unwinding*, which + hides whatever actually failed. Any diagnostic here must catch inside this + scope." + [f] + (with-open [allocator (RootAllocator.)] + (f allocator))) + +;; ------------------------------------------------------ Ladybug type → Field + +(def ^:private scalar-arrow-type + "Ladybug scalar → Arrow type. `UUID` and `JSON` ride as UTF-8: Ladybug + accepts a string into either column and does the conversion itself, which is + cheaper than teaching this side two more binary layouts." + {"STRING" #(ArrowType$Utf8.) + "UUID" #(ArrowType$Utf8.) + "JSON" #(ArrowType$Utf8.) + "INT64" #(ArrowType$Int. 64 true) + "UINT32" #(ArrowType$Int. 32 false) + "DOUBLE" #(ArrowType$FloatingPoint. FloatingPointPrecision/DOUBLE) + "BOOLEAN" #(ArrowType$Bool.) + "TIMESTAMP" #(ArrowType$Timestamp. TimeUnit/MICROSECOND nil)}) + +(defn column-field + "Arrow `Field` for a column of `ladybug-type`, recursively. + + `nullable?` is false only where Arrow's own invariants demand it — a MAP's + `entries` struct and its key." + (^Field [^String field-name ladybug-type] + (column-field field-name ladybug-type true)) + (^Field [^String field-name ladybug-type nullable?] + (cond + ;; A list first: `STRUCT(…)[]` starts with `STRUCT(` but is a list of them. + (ladybug/list-type? ladybug-type) + (Field. field-name (FieldType. nullable? (ArrowType$List.) nil) + [(column-field "item" (values/list-element ladybug-type))]) + + (ladybug/map-type? ladybug-type) + (let [[key-type value-type] (values/map-types ladybug-type)] + (Field. field-name (FieldType. nullable? (ArrowType$Map. false) nil) + [(Field. "entries" (FieldType. false (ArrowType$Struct.) nil) + [(column-field "key" key-type false) + (column-field "value" value-type)])])) + + (ladybug/struct-type? ladybug-type) + (Field. field-name (FieldType. nullable? (ArrowType$Struct.) nil) + ;; Backticks kept: Ladybug quotes none of these when it names the + ;; staged struct's fields, so `column` has to arrive quoted. + (mapv (fn [[field field-type]] (column-field field field-type)) + (values/struct-fields-quoted ladybug-type))) + + :else + (if-let [mk (get scalar-arrow-type ladybug-type)] + (Field. field-name (FieldType. nullable? (mk) nil) nil) + (throw (ex-info (str "no Arrow mapping for Ladybug type: " ladybug-type) + {:ladybug-type ladybug-type})))))) + +;; ------------------------------------------------------------------- writer + +(defn- utf8 + ^bytes [v] + (.getBytes (if (keyword? v) (name v) (str v)) StandardCharsets/UTF_8)) + +(defn- epoch-micros + ^long [v] + (let [^java.time.Instant inst + (cond + (instance? java.time.Instant v) v + (instance? java.util.Date v) (.toInstant ^java.util.Date v) + :else (java.time.Instant/parse (str v)))] + (+ (* (.getEpochSecond inst) 1000000) (long (quot (.getNano inst) 1000))))) + +(defn- write-scalar! + [^FieldVector fv ladybug-type ^long idx v] + (case ladybug-type + ("STRING" "UUID") (.setSafe ^VarCharVector fv idx (utf8 v)) + ;; A JSON column holds JSON, not a Clojure value's print form: `str` on a + ;; map yields `{:fill-color "#000000"}`, which is EDN and which every + ;; consumer of `fills`, `content` or `position_data` would fail to parse. + ;; Same encoder the Cypher path uses (`app.graph.ladybug/format-json`). + "JSON" (.setSafe ^VarCharVector fv idx + (.getBytes ^String (json/encode v) + StandardCharsets/UTF_8)) + "INT64" (.setSafe ^BigIntVector fv idx (long v)) + "UINT32" (.setSafe ^UInt4Vector fv idx (unchecked-int (long v))) + "DOUBLE" (.setSafe ^Float8Vector fv idx (double v)) + "BOOLEAN" (.setSafe ^BitVector fv idx (if v 1 0)) + "TIMESTAMP" (.setSafe ^TimeStampMicroVector fv idx (epoch-micros v)) + (throw (ex-info (str "no Arrow writer for Ladybug type: " ladybug-type) + {:ladybug-type ladybug-type})))) + +(defn write-value! + "Write already-coerced `v` into `fv` at `idx`, per `ladybug-type`. + + `map-key-fn` renders the keys of a `MAP(STRING, …)`, for the same reason + `app.graph.ladybug/format-typed-value` takes one: the right spelling is a + property of the column, not of the writer." + ;; `idx` is deliberately unhinted: Clojure only accepts primitive args on fns + ;; of four or fewer, and the map-key renderer has to travel with the value. + [^FieldVector fv ladybug-type idx v map-key-fn] + (if (nil? v) + (.setNull fv (int idx)) + (cond + (ladybug/list-type? ladybug-type) + (let [^ListVector lv fv + child (.getDataVector lv) + element-type (values/list-element ladybug-type) + elements (vec (if (or (sequential? v) (set? v)) v [v])) + start (.startNewValue lv (int idx))] + (dotimes [i (count elements)] + (write-value! child element-type (+ start i) (nth elements i) map-key-fn)) + (.endValue lv (int idx) (count elements))) + + (ladybug/map-type? ladybug-type) + (let [^MapVector mv fv + ^StructVector entries (.getDataVector mv) + [key-type value-type] (values/map-types ladybug-type) + key-vec (.getChild entries "key") + value-vec (.getChild entries "value") + render-key (if (and map-key-fn (= "STRING" key-type)) map-key-fn identity) + pairs (vec (seq v)) + start (.startNewValue mv (int idx))] + (dotimes [i (count pairs)] + (let [[k mv'] (nth pairs i) + at (+ start i)] + ;; The entries struct is non-nullable: every slot must be defined. + (.setIndexDefined entries (int at)) + (write-value! key-vec key-type at (render-key k) nil) + (write-value! value-vec value-type at mv' map-key-fn))) + (.endValue mv (int idx) (count pairs))) + + (ladybug/struct-type? ladybug-type) + (let [^StructVector sv fv] + (.setIndexDefined sv (int idx)) + (doseq [[quoted-field field-type] (values/struct-fields-quoted ladybug-type)] + ;; The child is named with its backticks; the coerced value is keyed + ;; without them. + (write-value! (.getChild sv quoted-field) field-type idx + (get v (str/replace quoted-field "`" "")) map-key-fn))) + + :else + (write-scalar! fv ladybug-type (long idx) v)))) + +;; ------------------------------------------------------------------ batches + +(defn- fill-vector! + [^VectorSchemaRoot root ^String field-name ladybug-type rows value-fn map-key-fn] + (let [^FieldVector fv (.getVector root field-name)] + (.allocateNew fv) + (dotimes [i (count rows)] + (write-value! fv ladybug-type i + (values/coerce ladybug-type (value-fn (nth rows i))) + map-key-fn)) + (.setValueCount fv (count rows)))) + +(defn- node-batch + "One `VectorSchemaRoot` holding every projected row of `table`. + + Fields carry the plain column name. Ladybug quotes every identifier it + interpolates into the staged table's DDL, so a name that is a reserved word + (`Page.index`, `Document.options`) arrives unquoted and a name arriving + pre-quoted comes out doubly backticked and fails to parse. The `COPY` + projection below is Cypher, not DDL, so it quotes the same names itself." + ^VectorSchemaRoot [^BufferAllocator allocator table rows] + (let [columns (nodes/column-keys table) + fields (mapv (fn [k] (column-field (nodes/column-name table k) + (nodes/column-ladybug-type table k))) + columns) + root (VectorSchemaRoot/create (Schema. ^List fields) allocator)] + (doseq [k columns] + (fill-vector! root (nodes/column-name table k) + (nodes/column-ladybug-type table k) + rows #(get % k) (nodes/column-map-key-fn table k))) + (.setRowCount root (count rows)) + root)) + +(def ^:private edge-fields + "Edge staging columns. `id` is the staging table's own key — Ladybug wants a + first column to key the virtual table on — and `from`/`to` land as STRING, + hence the cast in the join." + [(Field. "id" (FieldType. true (ArrowType$Utf8.) nil) nil) + (Field. "from" (FieldType. true (ArrowType$Utf8.) nil) nil) + (Field. "to" (FieldType. true (ArrowType$Utf8.) nil) nil) + (Field. "position" (FieldType. true (ArrowType$Int. 64 true) nil) nil)]) + +(defn- edge-batch + ^VectorSchemaRoot [^BufferAllocator allocator edges] + (let [root (VectorSchemaRoot/create (Schema. ^List edge-fields) allocator) + ^VarCharVector iv (.getVector root "id") + ^VarCharVector fv (.getVector root "from") + ^VarCharVector tv (.getVector root "to") + ^BigIntVector pv (.getVector root "position") + n (count edges)] + (doseq [^FieldVector v [iv fv tv pv]] (.allocateNew v)) + (dotimes [i n] + (let [{:keys [from-id to-id position]} (nth edges i)] + (.setSafe iv i (utf8 i)) + (.setSafe fv i (utf8 from-id)) + (.setSafe tv i (utf8 to-id)) + (if (nil? position) (.setNull pv i) (.setSafe pv i (long position))))) + (doseq [^FieldVector v [iv fv tv pv]] (.setValueCount v n)) + (.setRowCount root n) + root)) + +;; ------------------------------------------------------------------ staging + +(defn- batches + ^List [^VectorSchemaRoot root] + (doto (ArrayList.) (.add root))) + +(defn- check! + [^QueryResult result hint data] + (when-not (.isSuccess result) + (throw (ex-info (str hint ": " (.getErrorMessage result)) + (assoc data :err (.getErrorMessage result)))))) + +(defn- with-staged-table! + "Create Arrow table `staging-name` from `root`, run `(f)`, always drop it." + [^Connection conn ^BufferAllocator allocator ^String staging-name + ^VectorSchemaRoot root data f] + (try + (with-open [^QueryResult r (.createArrowTable conn staging-name (batches root) allocator)] + (check! r "createArrowTable failed" data)) + (f) + (finally + ;; Dropped even on failure: the staged buffers stay referenced by Ladybug + ;; until it is, and the allocator's leak check fires on close otherwise. + (try (.close ^QueryResult (.dropArrowTable conn staging-name)) + (catch Throwable _ nil))))) + +(defn- copy-node-table! + [^Connection conn table ^String staging-name] + (let [projection (str/join ", " (for [k (nodes/column-keys table) + :let [c (nodes/cypher-property-key table k)]] + (str "n." c " AS " c))) + statement (str "COPY `" table "` FROM (MATCH (n:" staging-name ") " + "RETURN " projection ");")] + (with-open [^QueryResult r (.query conn statement)] + (check! r (str "COPY node table failed: " table) + {:table table :statement statement})))) + +(defn- copy-edge-group! + "Load one FROM/TO pair of `IsChildOf`. + + `createArrowRelTable` is unusable here — it cannot resolve endpoints against a + UUID-keyed node table — so the edge list is staged as a node table and the + endpoints are resolved by the subquery. The `WHERE` is clause-level because + this dialect prohibits an inline pattern `WHERE`, and both sides are pinned by + label so the join cannot reach outside the pair." + [^Connection conn from-table to-table ^String staging-name] + (let [statement (str "COPY `IsChildOf` FROM (" + "MATCH (e:" staging-name "), " + "(a:" (nodes/match-label from-table) "), " + "(b:" (nodes/match-label to-table) ") " + "WHERE a.id = cast(e.from AS UUID) " + "AND b.id = cast(e.to AS UUID) " + "RETURN a.id, b.id, e.position) " + "(from='" from-table "', to='" to-table "');")] + (with-open [^QueryResult r (.query conn statement)] + (check! r (str "COPY edge group failed: " from-table " -> " to-table) + {:from-table from-table :to-table to-table :statement statement})))) + +(defn- staging-name + [prefix & parts] + (str/replace (str/join "_" (cons (str "stg_" prefix) parts)) #"[^A-Za-z0-9_]" "_")) + +;; --------------------------------------------------------------------- load + +(defn load-projection! + "Load projected nodes and edges into an open Ladybug connection. + + `allocator` must outlive `conn` — see `with-allocator!`." + [^Connection conn {:keys [nodes edges]} ^BufferAllocator allocator] + (doseq [[table rows] (sort-by key nodes) + :when (seq rows)] + (let [name (staging-name "node" table)] + (with-open [root (node-batch allocator table rows)] + (with-staged-table! conn allocator name root {:table table} + #(copy-node-table! conn table name))))) + (doseq [[[from-table to-table] group] + (sort-by key (group-by (juxt :from-table :to-table) edges)) + :when (seq group)] + (let [name (staging-name "edge" from-table to-table)] + (with-open [root (edge-batch allocator group)] + (with-staged-table! conn allocator name root + {:from-table from-table :to-table to-table} + #(copy-edge-group! conn from-table to-table name)))))) diff --git a/backend/src/app/graph/debug.clj b/backend/src/app/graph/debug.clj new file mode 100644 index 0000000000..277b1ae177 --- /dev/null +++ b/backend/src/app/graph/debug.clj @@ -0,0 +1,383 @@ +;; 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 Sucursal en España SL + +(ns app.graph.debug + "In-memory Ladybug sessions for the debug graph console." + (:require + [app.common.exceptions :as ex] + [app.common.logging :as l] + [app.common.time :as ct] + [app.graph.ingest :as graph.ingest] + [app.graph.ladybug :as ladybug] + [app.graph.schema.nodes :as nodes] + [app.graph.sync :as graph.sync] + [app.msgbus :as mbus] + [clojure.java.io :as io] + [clojure.string :as str] + [promesa.exec.csp :as sp]) + (:import + com.ladybugdb.Connection + com.ladybugdb.Database)) + +(set! *warn-on-reflection* true) + +(def default-query + "Default console query, written to be self-explanatory in the textarea. + The `filter_*` columns carry node ids for the graph-view result filter; + the results table hides them (see `hide-filter-columns` and the + template's `renderQueryOutput`)." + (str "MATCH (s)-[r]->(t)\n" + "// WHERE some condition\n" + "RETURN label(s) AS src, s.name,\n" + " label(r) AS rel,\n" + " t.name, label(t) AS tgt,\n" + "\n" + "// filter_* columns omitted from table; these needed for graph view\n" + "s.id AS filter_src_id, t.id AS filter_tgt_id;")) + +(defonce ^:private sessions + (atom {})) + +(defn- session-key + [profile-id] + (str profile-id)) + +(defn- destroy-session! + [{:keys [conn db sync-ch msgbus]}] + (when sync-ch + (sp/close! sync-ch) + (when msgbus + (mbus/purge! msgbus [sync-ch]))) + (when conn + (ex/ignoring (.close ^Connection conn))) + (when db + (ex/ignoring (.close ^Database db)))) + +(defn- slim-ingest-meta + "Drop full projection rows from session meta. + + `build-index` needs `:nodes`/`:edges` once; keeping them in the session + duplicates the entire graph on the JVM heap for every Load." + [meta] + (update meta :projection #(select-keys % [:stats]))) + +(defn- format-cell + [value] + (cond + (nil? value) "NULL" + (string? value) value + :else (str value))) + +(defn- format-query-result + [{:keys [columns rows truncated?]}] + {:columns (mapv str columns) + :rows (mapv (fn [row] + (mapv format-cell row)) + rows) + :truncated? truncated? + :row-count (count rows)}) + +(defn- apply-file-change! + [conn profile-id {:keys [changes revn file-id]}] + (try + (some-> (get @sessions (session-key profile-id)) + (as-> current + (when (= file-id (:file-id current)) + (let [lock (:lock current) + result (locking lock + (graph.sync/apply-changes! + conn (:index current) changes revn)) + sync-at (ct/now)] + (swap! sessions assoc-in [(session-key profile-id) :index] + (:index result)) + (swap! sessions update-in [(session-key profile-id) :meta] + (fn [meta] + (cond-> (-> meta + (update :sync dissoc :error) + (assoc-in [:sync :last-at] sync-at) + (assoc-in [:sync :last-applied] (:applied result)) + (assoc-in [:sync :last-skipped] (:skipped result))) + (seq (:applied result)) + (assoc :revn (:revn result))))) + (when (seq (:skipped result)) + (l/dbg :hint "graph sync skipped changes" + :file-id (str file-id) + :revn revn + :skipped (:skipped result))))))) + (catch Throwable cause + (l/wrn :hint "graph sync failed" + :file-id (str file-id) + :cause cause) + (swap! sessions assoc-in [(session-key profile-id) :meta :sync :error] + (ex-message cause))))) + +(defn- start-sync-loop! + [{:keys [conn profile-id file-id] :as session}] + (if-let [msgbus (:msgbus session)] + (let [sync-ch (sp/chan :buf (sp/dropping-buffer 64))] + (mbus/sub! msgbus :topic file-id :chan sync-ch) + ;; Recur ONLY while the channel is open. A bare `(recur)` after + ;; `take!` returns nil would spin forever and pin this Connection + ;; (and its Ladybug Database native memory) across every Load. + (sp/go-loop [] + (when-let [message (sp/take! sync-ch)] + (when (= :file-change (:type message)) + (apply-file-change! conn profile-id message)) + (recur))) + (assoc session :sync-ch sync-ch)) + session)) + +(defn session-info + "Return a public view of the current session for `profile-id`, if any." + [profile-id] + (when-let [{:keys [file-id meta loaded-at index]} (get @sessions (session-key profile-id))] + {:file-id file-id + :name (:name meta) + :revn (:revn meta) + :graph-revn (:revn index) + :schema-version (:schema-version meta) + :projection (:projection meta) + :sync (:sync meta) + :loaded-at (ct/format-inst loaded-at :iso)})) + +(defn sync-status + "Return incremental sync status for the active session." + [profile-id] + (when-let [session (get @sessions (session-key profile-id))] + (let [{:keys [file-id meta index loaded-at]} session] + {:file-id file-id + :revn (:revn meta) + :graph-revn (:revn index) + :sync (:sync meta) + :loaded-at (ct/format-inst loaded-at :iso)}))) + +(defn unload-session! + "Close and discard the in-memory graph for `profile-id`." + [profile-id] + (when-let [session (get @sessions (session-key profile-id))] + (destroy-session! session)) + (swap! sessions dissoc (session-key profile-id))) + +(defn load-session! + "Ingest `file-id` into a new in-memory Ladybug database for `profile-id`." + [cfg profile-id file-id] + (unload-session! profile-id) + (let [^Database db (Database.) + ^Connection conn (Connection. db) + msgbus (::mbus/msgbus cfg)] + (.setQueryTimeout conn 0) + (ladybug/ensure-extensions! conn) + (try + (let [meta (graph.ingest/ingest-on-connection! cfg conn file-id + :db-path ":memory:" + :skip-stats? true + :skip-validation? true) + index (graph.sync/build-index file-id (:revn meta) (:projection meta)) + ;; Discard projection rows after indexing — they are only needed + ;; to seed the sync index and would otherwise leak heap on each Load. + meta (slim-ingest-meta meta) + session + ;; :lock serializes access to the shared Connection between the + ;; msgbus sync loop (writes) and HTTP handlers (reads); the Java + ;; binding gives no thread-safety guarantee for one Connection. + (-> {:db db + :conn conn + :lock (Object.) + :file-id file-id + :meta meta + :index index + :msgbus msgbus + :profile-id profile-id + :loaded-at (ct/now)} + start-sync-loop!)] + (swap! sessions assoc (session-key profile-id) session) + meta) + (catch Throwable cause + (destroy-session! {:conn conn :db db :msgbus msgbus}) + (throw cause))))) + +(defn query-session! + "Run a read-only `statement` against the in-memory graph for `profile-id`. + + The statement is bound against the live schema before it runs, so a query + naming a table or a property that does not exist reports the binder's own + message and executes nothing. The engine's read/write analysis then decides + whether it may run at all: the console is an inspection surface, and a + session graph is rebuilt from the file by Reload, so a mutation from here + would produce a graph no rebuild reproduces." + [profile-id statement] + (when (str/blank? statement) + (ex/raise :type :validation + :code :missing-query + :hint "cypher query is required")) + (if-let [{:keys [conn lock]} (get @sessions (session-key profile-id))] + (locking lock + (let [{:keys [ok? error read-only?]} (ladybug/validate-on-connection! conn statement)] + (when-not ok? + (ex/raise :type :validation + :code :graph-query-invalid + :hint error)) + (when-not read-only? + (ex/raise :type :validation + :code :graph-query-not-read-only + :hint "the graph console runs read-only queries")) + (-> (ladybug/query-on-connection! conn statement) + format-query-result))) + (ex/raise :type :not-found + :code :graph-session-not-loaded + :hint "load a file graph before running queries"))) + +(def ^:private export-max-rows + "Row cap for graph-view export queries; far above expected per-file node + and edge counts. `:truncated` in the export signals when it was hit." + 100000) + +(defn- export-nodes + [conn] + (reduce + (fn [acc {:keys [table]}] + (let [stmt (str "MATCH (n:" (nodes/match-label table) + ") RETURN n.id AS id, n.name AS name;") + {:keys [rows truncated?]} + (ladybug/query-on-connection! conn stmt :max-rows export-max-rows)] + (-> acc + (update :nodes into + (map (fn [[id label]] + {:id (str id) :label (str label) :table table})) + rows) + (update :truncated? #(or % truncated?))))) + {:nodes [] :truncated? false} + nodes/node-types)) + +(defn rel-tables + "Every relationship table in the open database, with whether it carries a + `position` property. + + Read from the catalog rather than listed here, so a newly ported transform's + rel table appears in the graph view without the console being told about it." + [conn] + (for [[table] (:rows (ladybug/query-on-connection! + conn "CALL show_tables() WHERE type = 'REL' RETURN name;" + :max-rows 1000)) + :let [props (->> (ladybug/query-on-connection! + conn (str "CALL table_info('" table "') RETURN *;") + :max-rows 1000) + :rows + (into #{} (map (comp str second))))]] + {:table table :position? (contains? props "position")})) + +(defn- export-edges + [conn] + (reduce + (fn [acc {:keys [table position?]}] + (let [stmt (str "MATCH (a)-[r:`" table "`]->(b) " + "RETURN a.id AS source, b.id AS target, " + (if position? "r.position" "NULL") " AS position, " + "'" table "' AS rel;") + {:keys [rows truncated?]} + (ladybug/query-on-connection! conn stmt :max-rows export-max-rows)] + (-> acc + (update :edges into + (map (fn [[source target position rel]] + (cond-> {:source (str source) + :target (str target) + :rel (str rel)} + (some? position) (assoc :position position)))) + rows) + (update :truncated? #(or % truncated?))))) + {:edges [] :truncated? false} + (rel-tables conn))) + +(defn- bm-usage-bytes + "Buffer-manager memory in use by this session's in-memory database + (`CALL bm_info()` → [mem_limit mem_usage]); nil if the call fails." + [conn] + (ex/ignoring + (-> (ladybug/query-on-connection! conn "CALL bm_info() RETURN *;" :max-rows 1) + :rows first second))) + +(defn export-graph-data! + "Export the node/edge inventory of the in-memory graph for `profile-id` + as plain data for the debug graph view. Returns nil when no session is + loaded. Queries the Ladybug database (not the sync index) so the view + reflects actual DB state, including drift." + [profile-id] + (when-let [{:keys [conn lock file-id index]} (get @sessions (session-key profile-id))] + (locking lock + (let [{:keys [nodes] nodes-truncated? :truncated?} (export-nodes conn) + {:keys [edges] edges-truncated? :truncated?} (export-edges conn)] + {:file-id (str file-id) + :revn (:revn index) + :truncated (boolean (or nodes-truncated? edges-truncated?)) + :bm-bytes (bm-usage-bytes conn) + :nodes nodes + :edges edges})))) + +(defn- delete-tree! + [^java.io.File file] + (when (.exists file) + (doseq [f (reverse (file-seq file))] + (.delete ^java.io.File f)))) + +(defn export-session-database! + "Materialize the in-memory session graph of `profile-id` as a `.lbug` file. + + The console's graph is in-memory and live-synced, so it can differ from a + fresh projection of the same file — which is exactly when someone wants to + take it away and query it elsewhere. There is no \"save this database\" + primitive, so the transfer goes through Ladybug's `EXPORT DATABASE` (Parquet + per table) into a fresh on-disk database via `IMPORT DATABASE`. + + Note the round trip drops table comments. Nothing in the graph is addressed + by a table comment: every table is resolved by name, so the loss costs + nothing. + + Returns the path of the written database, or nil when no session is loaded. + The caller owns the file and must delete it once streamed." + [profile-id] + (when-let [{:keys [conn lock file-id]} (get @sessions (session-key profile-id))] + (let [stamp (System/nanoTime) + staging (io/file (System/getProperty "java.io.tmpdir") + (str "penpot-graph-session-" file-id "-" stamp)) + db-path (str (io/file (System/getProperty "java.io.tmpdir") + (str file-id "-session-" stamp ".lbug")))] + (try + (locking lock + (ladybug/exec-on-connection! + conn [(str "EXPORT DATABASE '" (.getAbsolutePath staging) + "' (format='parquet');")])) + (ladybug/with-connection! db-path + (fn [target] + (ladybug/exec-on-connection! + target [(str "IMPORT DATABASE '" (.getAbsolutePath staging) "';") + "CHECKPOINT;"]))) + db-path + (finally + (delete-tree! staging)))))) + +(defn- hide-filter-columns + "Drop `filter_*` columns from a query result before HTML table render; + they exist to feed node ids to the graph-view filter, not for reading. + The JSON response path keeps the full result." + [{:keys [columns rows] :as result}] + (let [idxs (vec (keep-indexed + (fn [i c] (when-not (str/starts-with? (str c) "filter_") i)) + columns))] + (if (or (empty? idxs) (= (count idxs) (count columns))) + result + (assoc result + :columns (mapv (vec columns) idxs) + :rows (mapv (fn [row] (mapv (vec row) idxs)) rows))))) + +(defn console-context + "Build template data for the graph debug console page." + [profile-id & {:keys [query query-result error message]}] + {:session (session-info profile-id) + :query (or query default-query) + :query-result (some-> query-result hide-filter-columns) + :error error + :message message + :default-query default-query}) diff --git a/backend/src/app/graph/ingest.clj b/backend/src/app/graph/ingest.clj new file mode 100644 index 0000000000..af0644ee4d --- /dev/null +++ b/backend/src/app/graph/ingest.clj @@ -0,0 +1,106 @@ +;; 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 Sucursal en España SL + +(ns app.graph.ingest + "Penpot file -> Ladybug graph projection." + (:require + [app.binfile.common :as bfc] + [app.common.exceptions :as ex] + [app.common.logging :as l] + [app.common.types.file :as ctf] + [app.db :as db] + [app.graph.arrow :as graph.arrow] + [app.graph.ladybug :as ladybug] + [app.graph.meta :as graph.meta] + [app.graph.projection.document :as projection.document] + [app.graph.projection.transforms :as projection.transforms] + [app.graph.schema :as schema] + [app.graph.stats :as stats] + [app.srepl.helpers :as h]) + (:import + com.ladybugdb.Connection + org.apache.arrow.memory.BufferAllocator)) + +(defn- fetch-file! + [system file-id] + (let [file-id (h/parse-uuid file-id) + file (db/run! system #(bfc/get-file % file-id :realize? true))] + (when-not file + (ex/raise :type :not-found + :code :file-not-found + :file-id (str file-id))) + (when-not (:data file) + (ex/raise :type :validation + :code :file-without-data + :hint "file has no data to project" + :file-id (str file-id))) + [file-id file])) + +(defn- ingest-on-connection*! + [system ^Connection conn file-id ^BufferAllocator allocator + {:keys [db-path skip-stats? skip-validation?] :or {skip-stats? true}}] + (let [[file-id file] (fetch-file! system file-id) + db-path (or db-path (ladybug/db-path-for-file file-id)) + data (:data file)] + (when-not skip-validation? + (ctf/check-file-data data)) + (l/inf :hint "graph ingest" + :file-id (str file-id) + :revn (:revn file) + :db-path db-path + :schema schema/schema-version) + (let [ddl (schema/ddl-statements) + {:keys [nodes edges stats]} + (projection.document/projection-data data file)] + (ladybug/exec-on-connection! conn ddl) + (graph.arrow/load-projection! conn {:nodes nodes :edges edges} allocator) + (ladybug/exec-on-connection! conn ["CHECKPOINT;"]) + (let [transforms (projection.transforms/apply-transforms! system conn data file)] + ;; Written last: its presence doubles as the build-complete marker. + (graph.meta/write! conn {:file-id file-id + :revn (:revn file)}) + {:file-id file-id + :revn (:revn file) + :name (or (:name data) (:name file)) + :db-path db-path + :schema-version schema/schema-version + :projection {:stats stats + :nodes nodes + :edges edges} + :transforms transforms + :stats (when-not skip-stats? + (stats/summarize-connection conn))})))) + +(defn ingest-on-connection! + "Project `file-id` into an already open Ladybug `conn`. + + Takes an `:arrow-alloc` when the caller already owns one; otherwise it makes + a short-lived allocator around this call. A caller that opened the connection + itself should pass its own, because the allocator has to be closed *after* + the connection — see `app.graph.arrow/with-allocator!`." + [system ^Connection conn file-id & {:keys [arrow-alloc] :as opts}] + (if arrow-alloc + (ingest-on-connection*! system conn file-id arrow-alloc opts) + (graph.arrow/with-allocator! + (fn [allocator] (ingest-on-connection*! system conn file-id allocator opts))))) + +(defn ingest-file! + [system file-id & {:keys [db-path reset-db? skip-stats? skip-validation?] + :or {reset-db? true}}] + (let [db-path (or db-path (ladybug/db-path-for-file (h/parse-uuid file-id)))] + (when reset-db? + (ladybug/reset-db-path! db-path)) + ;; Allocator outermost: Ladybug holds the staged Arrow buffers until its + ;; tables are dropped, which is no later than connection close, so the + ;; allocator must be closed after the connection and the database. + (graph.arrow/with-allocator! + (fn [allocator] + (ladybug/with-connection! db-path + (fn [conn] + (ingest-on-connection*! system conn file-id allocator + {:db-path db-path + :skip-stats? skip-stats? + :skip-validation? skip-validation?}))))))) diff --git a/backend/src/app/graph/ladybug.clj b/backend/src/app/graph/ladybug.clj new file mode 100644 index 0000000000..81d117c26e --- /dev/null +++ b/backend/src/app/graph/ladybug.clj @@ -0,0 +1,504 @@ +;; 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 Sucursal en España SL + +(ns app.graph.ladybug + "Ladybug access layer for graph-backed Penpot. + + Uses the embedded Java API (`com.ladybugdb/lbug`)." + (:require + [app.common.exceptions :as ex] + [app.common.json :as json] + [app.graph.schema.values :as values] + [clojure.string :as str] + [datoteka.fs :as fs]) + (:import + com.ladybugdb.Connection + com.ladybugdb.Database + com.ladybugdb.FlatTuple + com.ladybugdb.PreparedStatement + com.ladybugdb.QueryResult + com.ladybugdb.Value)) + +(set! *warn-on-reflection* true) + +(defn default-graph-dir + [] + (or (System/getenv "PENPOT_GRAPH_DIR") "/tmp/penpot-graph")) + +(defn db-path-for-file + [file-id] + (str (fs/path (default-graph-dir) (str file-id ".lbug")))) + +(defn- memory-db-path? + [db-path] + (= db-path ":memory:")) + +(defn reset-db-path! + [db-path] + (when-not (memory-db-path? db-path) + (when (fs/exists? db-path) + (fs/delete db-path)))) + +(defn escape-cypher-string + [s] + (-> (str s) + (str/replace "\\" "\\\\") + (str/replace "'" "\\'"))) + +(defn format-uuid + [id] + (str "uuid('" (str id) "')")) + +(defn format-string + [s] + (str "'" (escape-cypher-string s) "'")) + +(defn format-int + [n] + (str (long n))) + +(defn format-number + [n] + (if (== n (long n)) + (format-int n) + (str (double n)))) + +(defn format-json + [v] + (str "json('" (escape-cypher-string (json/encode v)) "')")) + +(defn format-timestamp + "Ladybug TIMESTAMP literal of the form `timestamp('')`." + [v] + (let [s (cond + (instance? java.time.Instant v) + (.toString ^java.time.Instant v) + + (instance? java.util.Date v) + (.toString (.toInstant ^java.util.Date v)) + + (string? v) + v + + :else + (str v))] + (str "timestamp('" (escape-cypher-string s) "')"))) + +(defn format-value + [v] + (cond + (nil? v) "NULL" + (uuid? v) (format-uuid v) + (instance? java.time.Instant v) (format-timestamp v) + (instance? java.util.Date v) (format-timestamp v) + (string? v) (format-string v) + (number? v) (format-number v) + (boolean? v) (if v "true" "false") + (keyword? v) (format-string (name v)) + (map? v) (format-json v) + (coll? v) (format-json v) + :else (format-string (str v)))) + +(defn map-type? + "Is `ladybug-type` a MAP column?" + [ladybug-type] + (and (string? ladybug-type) + (str/starts-with? ladybug-type "MAP(") + (not (str/ends-with? ladybug-type "]")))) + +(defn list-type? + "Is this a list or fixed-size array type? Checked before MAP and STRUCT, + since `STRUCT(…)[]` starts with `STRUCT(` but is a list of them." + [ladybug-type] + (and (string? ladybug-type) + (some? (re-matches #".+\[\d*\]$" ladybug-type)))) + +(defn struct-type? + [ladybug-type] + (and (string? ladybug-type) + (str/starts-with? ladybug-type "STRUCT(") + (not (list-type? ladybug-type)))) + +(declare format-typed-value) + +(defn- format-typed-list + "Cypher LIST literal, elements formatted by the element type. + + Handles `T[]` and the fixed-size `T[n]` alike: the size constrains the column, + not the literal." + [ladybug-type v] + (let [element (second (re-matches #"(.+?)\[\d*\]$" ladybug-type)) + elems (if (or (sequential? v) (set? v)) (seq v) [v])] + (str "[" (str/join ", " (map #(format-typed-value element %) elems)) "]"))) + +(defn- format-struct + "Cypher STRUCT literal, `{field: value, …}`. + + *Every* declared field is emitted, NULL where the value has none: a struct + literal's type is its field list, so omitting a field yields a different type + and Ladybug refuses the implicit cast (`STRUCT(m2 DOUBLE, m4 DOUBLE)` cannot + be assigned to `STRUCT(m1 …, m2 …, m3 …, m4 …)`). Penpot's layout margins are + exactly that case — a shape sets only the sides it overrides." + [ladybug-type v] + (let [fields (values/struct-fields ladybug-type)] + (str "{" + (str/join ", " + (for [[field field-type] fields + :let [fv (get v field)]] + ;; Backticked for the same reason as in the DDL: a field + ;; named `column` is a keyword and will not parse bare. + ;; A bare NULL is typed STRING, which changes the struct's + ;; type as surely as omitting the field would, so absent + ;; fields get a NULL cast to their declared type. + (str "`" field "`: " + (if (nil? fv) + (str "cast(NULL, '" field-type "')") + (format-typed-value field-type fv))))) + "}"))) + +(defn format-typed-value + "Cypher literal for `v` in a column of `ladybug-type`. + + Recursive over the type language, because the types are: a + `MAP(UUID, STRUCT(…))` needs its keys, its fields and each field's own type + honoured. `app.graph.schema.values/coerce` shapes the value first — turning a + matrix record into six doubles, a hex colour into a packed integer — so this + function only has to escape plain data. + + `map-key-fn` renders the keys of a `MAP(STRING, …)`; the caller supplies it + because the right form is a property of the column, not of this function + (`app.graph.schema.contract/map-key-fn`)." + ([ladybug-type v] (format-typed-value ladybug-type v nil)) + ([ladybug-type v map-key-fn] + (let [v (values/coerce ladybug-type v)] + (cond + (nil? v) + "NULL" + + (list-type? ladybug-type) + (format-typed-list ladybug-type v) + + (map-type? ladybug-type) + (let [[key-type value-type] (values/map-types ladybug-type) + entries (seq v) + format-key (if (and map-key-fn (= "STRING" key-type)) + #(format-string (map-key-fn (key %))) + #(format-typed-value key-type (key %)))] + (str "map([" (str/join ", " (map format-key entries)) + "], [" + (str/join ", " (map #(format-typed-value value-type (val %)) entries)) + "])")) + + (struct-type? ladybug-type) + (format-struct ladybug-type v) + + (= ladybug-type "JSON") + (format-json v) + + ;; Coerce string ids from transit edge-cases into UUID literals. + (= ladybug-type "UUID") + (format-uuid v) + + (= ladybug-type "TIMESTAMP") + (format-timestamp v) + + :else + (format-value v))))) + +(defn- ensure-semicolon + [statement] + (let [s (str/trim (str statement))] + (if (str/ends-with? s ";") s (str s ";")))) + +(defn- value->clj + [^Value value] + (when-not (.isNull value) + (let [v (try + (.getValue value) + (catch Exception _ + ;; LIST/STRUCT values are not supported by the binding's + ;; getValue (\"value_get_value\"); fall back to the textual + ;; representation so console queries do not crash. + (.toString value)))] + (cond + (instance? Long v) v + (instance? Integer v) (long v) + (instance? Double v) v + :else v)))) + +(defn- check-success! + [^QueryResult result statement] + (when-not (.isSuccess result) + (let [err (.getErrorMessage result)] + (ex/raise :type :internal + :code :ladybug-query-failed + :hint (str "Ladybug query failed: " err) + :statement statement + :err err)))) + +(defn- query-columns + [^QueryResult result] + (let [ncols (.getNumColumns result)] + (vec (for [i (range ncols)] + (.getColumnName result (long i)))))) + +(defn- query-row + [^FlatTuple tuple ncols] + (vec (for [i (range ncols)] + (with-open [^Value value (.getValue tuple (long i))] + (value->clj value))))) + +(def ^:private default-query-max-rows 200) + +(defn- read-query-rows + [^QueryResult result ncols max-rows] + (loop [rows [] n 0] + (if (and (< n max-rows) (.hasNext result)) + (let [row (with-open [^FlatTuple tuple (.getNext result)] + (query-row tuple ncols))] + (recur (conj rows row) (inc n))) + rows))) + +(defn query-on-connection! + "Execute a Cypher query on `conn` and return tabular results. + + Returns `{:columns [...] :rows [[...] ...] :truncated? bool}`." + [^Connection conn statement & {:keys [max-rows] + :or {max-rows default-query-max-rows}}] + (let [cypher (ensure-semicolon statement)] + (with-open [^QueryResult result (.query conn cypher)] + (check-success! result cypher) + (let [ncols (long (.getNumColumns result)) + columns (query-columns result) + rows (read-query-rows result ncols max-rows) + total (long (.getNumTuples result))] + {:columns columns + :rows rows + :truncated? (and (pos? total) (> total (count rows)))})))) + +(def ^:private default-query-timeout-ms + "0 disables query timeout (recommended for bulk COPY ingest)." + 0) + +(defn- scalar-value + [^Connection conn statement] + (let [cypher (ensure-semicolon statement)] + (with-open [^QueryResult result (.query conn cypher)] + (check-success! result cypher) + (when (.hasNext result) + (with-open [^FlatTuple tuple (.getNext result)] + (with-open [^Value value (.getValue tuple 0)] + (value->clj value))))))) + +(defn- extension-statement-ok? + [err-msg] + (let [err (str/lower-case (or err-msg ""))] + (or (str/includes? err "already loaded") + (str/includes? err "already installed")))) + +(defn- run-extension-statement! + [^Connection conn statement] + (let [cypher (ensure-semicolon statement)] + (with-open [^QueryResult result (.query conn cypher)] + (when-not (.isSuccess result) + (let [err (.getErrorMessage result)] + (when-not (extension-statement-ok? err) + (check-success! result cypher))))))) + +(defn ensure-extensions! + "Install and load Ladybug extensions required by graph ingest and sync." + [^Connection conn] + (run-extension-statement! conn "INSTALL json;") + (run-extension-statement! conn "LOAD json;")) + +(defn- run-statements! + [^Connection conn statements] + (doseq [statement statements] + (let [cypher (ensure-semicolon statement)] + (with-open [^QueryResult result (.query conn cypher)] + (check-success! result cypher))))) + +(defn- ensure-db-path! + [db-path] + (when-not (memory-db-path? db-path) + (fs/create-dir (fs/parent db-path)))) + +(defn with-connection! + "Open a Ladybug connection for `db-path` and invoke `(f conn)`. + + Options: + - `:query-timeout-ms` query timeout in milliseconds (default 0, disabled) + + For `:memory:`, the database only lives for the duration of this call; + all reads and writes must happen inside `f`." + [db-path f & {:keys [query-timeout-ms] + :or {query-timeout-ms default-query-timeout-ms}}] + (ensure-db-path! db-path) + (let [^Database db (if (memory-db-path? db-path) + (Database.) + (Database. (str db-path)))] + (try + (let [^Connection conn (Connection. db)] + (try + (.setQueryTimeout conn (long query-timeout-ms)) + (ensure-extensions! conn) + (f conn) + (finally + (.close conn)))) + (finally + (.close db))))) + +(defn exec-on-connection! + "Execute Cypher statements on an open Ladybug connection." + [^Connection conn statements] + (assert (sequential? statements) "statements should be a sequential collection") + (run-statements! conn statements)) + +;; --- prepared statements + +(defn- ->param-value + "Clojure scalar → `Value` for prepared-statement binding. + + This is the only `Value` constructor on the write path, so every parameter + is wrapped here. Parameters are scalars: the `Value` constructor takes no + list or map, so `MAP`, `STRUCT` and `T[]` columns stay literal-rendered + (`format-typed-value`) and the `:else` raise below means a caller tried to + bind one." + ^Value [v] + (cond + (nil? v) (Value/createNull) ; no explicit type needed + (uuid? v) (Value. ^Object v) ; native UUID + (string? v) (Value. ^Object v) + (boolean? v) (Value. ^Object v) + (integer? v) (Value. ^Object (long v)) + (number? v) (Value. ^Object (double v)) + (keyword? v) (Value. ^Object (name v)) + + (instance? java.time.Instant v) ; native TIMESTAMP + (Value. ^Object v) + + (instance? java.util.Date v) + (Value. ^Object (.toInstant ^java.util.Date v)) + + :else + (ex/raise :type :internal + :code :ladybug-unsupported-param + :hint (str "cannot bind a " (type v) " as a Ladybug parameter; " + "compound columns must be literal-rendered") + :value v))) + +(defn- as-statement + "Normalize a statement to `{:cypher … :params …}`. + + A bare string binds nothing, so the sync builders can convert to bound + parameters one family at a time." + [stmt] + (if (map? stmt) + (update stmt :params #(or % {})) + {:cypher stmt :params {}})) + +(defn prepare-on-connection! + "Parse and bind `statement` on `conn` without executing it. + + The returned `PreparedStatement` is a JNI resource: the caller closes it." + ^PreparedStatement [^Connection conn statement] + (let [cypher (ensure-semicolon statement) + ps (.prepare conn cypher)] + (when-not (.isSuccess ps) + (let [err (.getErrorMessage ps)] + (.close ps) + (ex/raise :type :internal + :code :ladybug-prepare-failed + :hint (str "Ladybug prepare failed: " err) + :statement cypher + :err err))) + ps)) + +(defn execute-prepared! + "Bind `params` into `ps` and execute it on `conn`. + + `params` keys are parameter names without the `$` (keyword or string); + values are scalars. Every bound `Value` is closed, including the ones built + before a later parameter is rejected." + [^Connection conn ^PreparedStatement ps params] + (let [vmap (java.util.HashMap.)] + (try + (doseq [[k v] params] + (.put vmap (name k) (->param-value v))) + (with-open [^QueryResult result (.execute conn ps vmap)] + (check-success! result "")) + (finally + (run! #(.close ^Value %) (.values vmap)))))) + +(defn exec-prepared-on-connection! + "Prepare all statements, then execute all of them. + + A parse or bind failure in *any* statement aborts the batch before the first + mutation runs — the bind-level batch gate. Statements are + `{:cypher … :params {…}}` maps or bare strings." + [^Connection conn stmts] + (assert (sequential? stmts) "statements should be a sequential collection") + (let [prepared (volatile! [])] + (try + (doseq [stmt stmts] + (let [{:keys [cypher params]} (as-statement stmt)] + (vswap! prepared conj {:ps (prepare-on-connection! conn cypher) + :params params}))) + (doseq [{:keys [ps params]} @prepared] + (execute-prepared! conn ps params)) + (finally + (run! #(.close ^PreparedStatement (:ps %)) @prepared))))) + +(defn validate-on-connection! + "Binder gate: parse and semantic-check `statement` against the live schema, + without executing it. + + Returns `{:ok? … :error … :read-only? …}`. Unlike `prepare-on-connection!` + a failure is a return value rather than a raise: the callers are gates (the + CI binder gate, the console read-only gate) that report it. `:read-only?` is + the engine's own read/write analysis." + [^Connection conn statement] + (with-open [^PreparedStatement ps (.prepare conn (ensure-semicolon statement))] + (let [ok? (.isSuccess ps)] + {:ok? ok? + :error (when-not ok? (.getErrorMessage ps)) + :read-only? (when ok? (.isReadOnly ps))}))) + +(defn query-scalar-on-connection! + "Execute a query expected to return a single scalar value on `conn`." + [^Connection conn statement] + (scalar-value conn statement)) + +(defn exec! + "Execute Cypher statements against a Ladybug database. + + `db-path` is either `:memory:` or a filesystem path to a `.lbug` database." + [db-path statements] + (with-connection! db-path + (fn [conn] + (exec-on-connection! conn statements)))) + +(defn query-scalar! + "Execute a query expected to return a single scalar value." + [db-path statement] + (with-connection! db-path + (fn [conn] + (query-scalar-on-connection! conn statement)))) + +(defn smoke-test! + "Run a minimal CREATE + count against Ladybug." + [& {:keys [db-path] :or {db-path ":memory:"}}] + (when-not (memory-db-path? db-path) + (reset-db-path! db-path)) + (with-connection! db-path + (fn [^Connection conn] + (run-statements! conn + ["CREATE NODE TABLE Person(name STRING, age INT64, PRIMARY KEY(name));" + "CREATE (:Person {name: 'Alice', age: 25});" + "CREATE (:Person {name: 'Bob', age: 30});"]) + {:db-path db-path + :person-count (scalar-value conn + "MATCH (a:Person) RETURN count(a) AS c;")}))) diff --git a/backend/src/app/graph/meta.clj b/backend/src/app/graph/meta.clj new file mode 100644 index 0000000000..129babd1fa --- /dev/null +++ b/backend/src/app/graph/meta.clj @@ -0,0 +1,59 @@ +;; 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 Sucursal en España SL + +(ns app.graph.meta + "`GraphMeta`: the graph's own account of who built it and from what. + + A projected graph is a cache of a file at a revision, built by a known + schema. The row records both, so a reader can decide whether to reuse the + database or rebuild it: a `schema_version` that no longer matches the + registry, or a `source_revn` behind the file's, means the cache is stale. + + The row is written *last* in a build, so its presence also marks the build + complete. + + Keyed by `source_file_id` rather than holding a single row: a closure graph + is a union of per-file builds, and each contributing file keeps its own + provenance." + (:require + [app.common.time :as ct] + [app.graph.ladybug :as ladybug] + [app.graph.schema.nodes :as nodes]) + (:import + com.ladybugdb.Connection)) + +(set! *warn-on-reflection* true) + +(def table + "GraphMeta") + +(def producer + "penpot") + +(def ddl + "DDL for the provenance table." + (str "CREATE NODE TABLE `" table "` (" + "`source_file_id` UUID, " + "`producer` STRING, " + "`producer_version` STRING, " + "`schema_version` STRING, " + "`source_revn` INT64, " + "`built_at` TIMESTAMP, " + "PRIMARY KEY (`source_file_id`));")) + +(defn write! + "Record what this build produced for `file-id`." + [^Connection conn {:keys [file-id revn]}] + (ladybug/exec-on-connection! conn [ddl]) + (ladybug/exec-on-connection! + conn + [(str "MERGE (m:`" table "` {source_file_id: " (ladybug/format-uuid file-id) "}) " + "SET m.producer = " (ladybug/format-string producer) ", " + "m.producer_version = " (ladybug/format-string (or (System/getenv "PENPOT_BUILD") "devenv")) ", " + "m.schema_version = " (ladybug/format-string nodes/schema-version) ", " + "m.source_revn = " (ladybug/format-int (or revn 0)) ", " + "m.built_at = " (ladybug/format-timestamp (ct/now)) ";")])) + diff --git a/backend/src/app/graph/projection/document.clj b/backend/src/app/graph/projection/document.clj new file mode 100644 index 0000000000..9d0eec6851 --- /dev/null +++ b/backend/src/app/graph/projection/document.clj @@ -0,0 +1,214 @@ +;; 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 Sucursal en España SL + +(ns app.graph.projection.document + "Project a Penpot file-data map into Ladybug nodes and structural edges. + + Projects Document, Page, Component, the full shape tree (skipping the root + frame), and `IsChildOf` edges from shapes/pages/components to their parent. + + Two denormalizations happen here rather than in a later pass, because the + walk already has both answers in hand and a post-ingest statement would have + to rediscover them: + + - `page-id` on every shape, from the page the walk is currently in; + - `component-id` propagated from an instance head down to its descendants, + from the head context the walk carries." + (:require + [app.common.logging :as l] + [app.common.uuid :as uuid] + [app.graph.schema.nodes :as nodes])) + +(def root-frame-id + uuid/zero) + +(defn- document-attrs + "The Document node's attrs: the file row, minus its data blob. + + `:options` is lifted out of the blob before it goes: it is file-level + configuration a consumer wants without opening `:data`." + [file data] + (-> file + (assoc :id (or (:id data) (:id file))) + (cond-> (:options data) (assoc :options (:options data))) + (dissoc :data))) + +(defn- page-attrs + [page index] + (-> page + (dissoc :objects) + (cond-> (some? index) (assoc :index (long index))))) + +(defn- component-attrs + [component] + (-> component + (dissoc :objects) + ;; schema:component requires :path; some legacy rows omit it + (update :path #(or % "")))) + +(defn- shape-table + [shape] + (nodes/table-for-type (:type shape))) + +(defn denormalized-shape + "`shape` with `page-id` set and an inherited `component-id` filled in. + + A shape that carries its own `component-id` keeps it; `component-ctx` only + fills the gap for descendants (see `descend-component-ctx`)." + [shape page-id component-ctx] + (cond-> (assoc shape :page-id page-id) + (and (uuid? component-ctx) (nil? (:component-id shape))) + (assoc :component-id component-ctx))) + +(defn- shape-node-attrs + [table shape page-id component-ctx] + (nodes/project-attrs table (denormalized-shape shape page-id component-ctx))) + +(defn descend-component-ctx + "The component context to pass to `shape`'s children. + + Inheritance stops at the nearest ancestor Frame carrying a `component-id`, + and any intermediate shape that carries one is a barrier: + + - a Frame with its own `component-id` becomes the new context (it is an + instance head, and its descendants belong to *it*, not to an outer head); + - any other shape carrying a `component-id` blocks inheritance below it + without being able to supply one, since only Frames are heads; + - otherwise the context passes through unchanged." + [table shape ctx] + (let [own (:component-id shape)] + (cond + (and (some? own) (= table "Frame")) own + (some? own) ::blocked + :else ctx))) + +(defn- container-table? + [table] + (contains? nodes/container-tables table)) + +(defn- child-shape-ids + "Child ids in Penpot z-order (reversed from the stored :shapes list)." + [parent] + (when-let [shapes (:shapes parent)] + (vec (reverse shapes)))) + +(defn- initial-acc + [] + {:nodes {} + :edges [] + :stats {:documents 0 :pages 0 :components 0 :shapes 0}}) + +(declare project-shape-ids) + +(defn- project-shape + [objects acc table shape parent-table parent-id position page-id component-ctx] + (let [shape-id (:id shape) + acc' (-> acc + (update-in [:nodes table] (fnil conj []) + (shape-node-attrs table shape page-id component-ctx)) + (update :edges conj {:from-table table + :from-id shape-id + :to-table parent-table + :to-id parent-id + :position position}) + (update-in [:stats :shapes] inc))] + (if-let [child-ids (when (container-table? table) + (child-shape-ids shape))] + (project-shape-ids objects acc' table shape-id child-ids page-id + (descend-component-ctx table shape component-ctx)) + acc'))) + +(defn- project-shape-ids + [objects acc parent-table parent-id child-ids page-id component-ctx] + (reduce + (fn [acc [position shape-id]] + (if-let [shape (get objects shape-id)] + (if-let [table (shape-table shape)] + (project-shape objects acc table shape parent-table parent-id position + page-id component-ctx) + (do + (l/wrn :hint "unsupported shape type for graph slice" + :shape-id (str shape-id) + :type (:type shape)) + acc)) + (do + (l/wrn :hint "missing shape in page objects" + :shape-id (str shape-id)) + acc))) + acc + (map-indexed vector child-ids))) + +(defn- project-page + [acc doc-id page position] + (let [page-id (:id page) + objects (:objects page) + root (get objects root-frame-id) + page-node (nodes/project-attrs "Page" (page-attrs page position)) + acc' (-> acc + (update-in [:nodes "Page"] (fnil conj []) page-node) + (update :edges conj {:from-table "Page" + :from-id page-id + :to-table "Document" + :to-id doc-id + :position position}) + (update-in [:stats :pages] inc))] + (if-let [top-level-ids (child-shape-ids root)] + (project-shape-ids objects acc' "Page" page-id top-level-ids page-id nil) + acc'))) + +(defn- project-component + [acc doc-id component position] + (if (:deleted component) + acc + (let [comp-id (:id component) + node (nodes/project-attrs "Component" (component-attrs component))] + (-> acc + (update-in [:nodes "Component"] (fnil conj []) node) + (update :edges conj {:from-table "Component" + :from-id comp-id + :to-table "Document" + :to-id doc-id + :position position}) + (update-in [:stats :components] inc))))) + +(defn- project-components + [acc doc-id components] + (reduce (fn [acc [position [_id component]]] + (project-component acc doc-id component position)) + acc + (map-indexed vector components))) + +(defn projection-data + "Build node/edge rows for projecting `data` into Ladybug. + + Returns `{:nodes {table [attrs ...]} :edges [...] :stats {...}}`." + [data file] + (let [doc-id (or (:id data) (:id file)) + doc-node (nodes/project-attrs "Document" (document-attrs file data)) + ;; `:pages` is the tab order the user sees, and `Page.index` and the + ;; page's `IsChildOf.position` are that order. Child shapes are + ;; reversed on the way in (`child-shape-ids`) because their stored + ;; list runs bottom to top; pages have no such second ordering. + pages (seq (:pages data)) + comps (seq (:components data)) + acc0 (-> (initial-acc) + (update-in [:nodes "Document"] (fnil conj []) doc-node) + (assoc-in [:stats :documents] 1)) + acc (cond-> acc0 + (seq comps) + (project-components doc-id comps)) + acc (if (empty? pages) + acc + (reduce (fn [acc [position page-id]] + (if-let [page (get-in data [:pages-index page-id])] + (project-page acc doc-id page position) + (do + (l/wrn :hint "missing page in pages-index" + :page-id (str page-id)) + acc))) + acc + (map-indexed vector pages)))] + (select-keys acc [:nodes :edges :stats]))) diff --git a/backend/src/app/graph/projection/transforms.clj b/backend/src/app/graph/projection/transforms.clj new file mode 100644 index 0000000000..dc87392983 --- /dev/null +++ b/backend/src/app/graph/projection/transforms.clj @@ -0,0 +1,149 @@ +;; 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 Sucursal en España SL + +(ns app.graph.projection.transforms + "Derived graph links: edges a reader could compute from the projected + columns, materialized once at build time so a query does not have to. + + Each entry in `registry` names the transform, the relationship it produces, + and the function that produces it, so adding one is a single entry and + nothing else has to be told about it." + (:require + [app.common.logging :as l] + [app.graph.ladybug :as ladybug] + [app.graph.schema.nodes :as nodes]) + (:import + com.ladybugdb.Connection)) + +(set! *warn-on-reflection* true) + +(defn- run-scalar! + [^Connection conn statement] + (or (ladybug/query-scalar-on-connection! conn statement) 0)) + +(defn- link-component-instances! + "`IsInstanceOf` from Frame instance heads to their Component. + + Every head is linked, the main instance and any copy root alike. + + `component-file` is what makes a head a head here, not `component-id` alone. + `app.common.types.component/instance-of?` requires both, and the projection + denormalizes `component-id` down the shape tree + (`app.graph.projection.document`), so on its own it no longer distinguishes a + head from a shape that merely lives inside one. `component-file` is not + denormalized and remains the head marker Penpot itself uses." + [^Connection conn] + (run-scalar! conn + (str "MATCH (f:Frame), (c:Component) " + "WHERE f.component_id = c.id " + "AND f.component_file IS NOT NULL " + "AND NOT COALESCE(c.deleted, false) " + "MERGE (f)-[:IsInstanceOf]->(c) " + "RETURN count(*);"))) + +(defn- shape-pair-statements + "One statement per (from, to) shape-table pair. + + Ladybug cannot create a relationship bound by multiple node labels in a + single `MERGE`, a constraint inherited from Kùzu, which it forks (upstream + issue kuzudb/kuzu#5841). The loop over label pairs is that dialect + constraint, not a modelling choice." + [f] + (for [from nodes/shape-tables + to nodes/shape-tables] + (f from to))) + +(defn- link-shape-refs! + "`RefersTo` from an instance shape to its homologue in the main instance, + driven by `shape-ref`." + [^Connection conn] + (reduce + (fn [total statement] (+ total (run-scalar! conn statement))) + 0 + (shape-pair-statements + (fn [from to] + (str "MATCH (s:" (nodes/match-label from) "), (t:" (nodes/match-label to) ") " + "WHERE s.shape_ref = t.id " + "MERGE (s)-[:RefersTo]->(t) " + "RETURN count(*);"))))) + +(def ^:private swap-slot-prefix "swap-slot-") + +(def ^:private slot-uuid-expr + ;; Ladybug `substring` is 1-indexed; 36 = RFC 4122 UUID text length. + (str "substring(touched_key, " (inc (count swap-slot-prefix)) ", 36)")) + +(defn- link-swap-slots! + "`FillsSwapSlot` from a swapped-in shape to the slot it replaces. + + Penpot records a component sub-shape swap as a `swap-slot-` entry in + the *replacing* shape's `touched` set, where `` names the replaced + slot shape in the main instance. The entries are then stripped from + `touched`, as `app.common.types.component/normal-touched-groups` does, so a + reader of `touched` sees design edits rather than swap bookkeeping. + + Stripping makes this the one transform that writes a column another + transform could read. Anything reading `touched` has to run before it." + [^Connection conn] + (let [linked + (reduce + (fn [total statement] (+ total (run-scalar! conn statement))) + 0 + (shape-pair-statements + (fn [from to] + (str "MATCH (s:" (nodes/match-label from) ") " + "WHERE size(s.touched) > 0 " + "UNWIND s.touched AS touched_key " + "WITH s, touched_key " + "WHERE STARTS_WITH(touched_key, '" swap-slot-prefix "') " + "WITH s, CAST(" slot-uuid-expr ", 'UUID') AS slot_id " + "MATCH (t:" (nodes/match-label to) ") " + "WHERE t.id = slot_id AND s.id <> t.id " + "MERGE (s)-[r:FillsSwapSlot {slot_id: slot_id}]->(t) " + "RETURN count(r);"))))] + ;; Strip unconditionally: an entry may name a slot that was garbage + ;; collected, so "no edge created" does not mean "nothing to strip". + (doseq [table nodes/shape-tables] + (ladybug/exec-on-connection! + conn + [(str "MATCH (s:" (nodes/match-label table) ") " + "WHERE size(s.touched) > 0 " + "SET s.touched = list_filter(s.touched, x -> " + "NOT STARTS_WITH(x, '" swap-slot-prefix "'));")])) + linked)) + +(def registry + "Every transform this backend applies. + + `:id` names the transform in the ingest report and the log. `:rel` names + the relationship it produces. The three registered here read disjoint + columns, so the vector order is not load-bearing. The one ordering + constraint that exists is stated on `link-swap-slots!`." + [{:id "link-component-instances" :rel :IsInstanceOf :run link-component-instances!} + {:id "link-shape-refs" :rel :RefersTo :run link-shape-refs!} + {:id "link-swap-slots" :rel :FillsSwapSlot :run link-swap-slots!}]) + +(defn apply-transforms! + "Apply every registered transform to an already loaded graph. + + Returns `{:ids [...] :counts {...} :transforms n}`, where `:ids` names what + ran and `:counts` gives the edges each one produced." + [_system ^Connection conn _data _file] + (reduce + (fn [acc {:keys [id rel run]}] + (let [n (run conn)] + (l/inf :hint "graph transform" :transform id :edges n) + (-> acc + (update :ids conj id) + (update :counts assoc rel n) + (assoc rel n)))) + {:ids [] :counts {} :transforms (count registry)} + registry)) + +(defn transform-ids + "Ids of every transform in the registry." + [] + (mapv :id registry)) diff --git a/backend/src/app/graph/report.clj b/backend/src/app/graph/report.clj new file mode 100644 index 0000000000..f026ff3a52 --- /dev/null +++ b/backend/src/app/graph/report.clj @@ -0,0 +1,65 @@ +;; 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 Sucursal en España SL + +(ns app.graph.report + (:require + [clojure.core :as c] + [clojure.string :as str])) + +(defn- println! + [& lines] + (doseq [line lines] + (println line))) + +(defn- section-title + [title] + (println! (str "\n" title) + (str (apply str (repeat (count title) "─"))))) + +(defn- kv-line + [k v] + (format " %-14s %s" (str k ":") v)) + +(defn- print-node-counts + [nodes] + (doseq [[table count] (sort-by first nodes) + :when (pos? (long count))] + (println! (kv-line table count)))) + +(defn print-ingest! + "Pretty-print the result map returned by `app.graph.ingest/ingest-file!`." + [{:keys [file-id revn name db-path schema-version projection transforms stats]}] + (section-title "Graph ingest") + (println! (kv-line "File" (str name " (" file-id ")")) + (kv-line "Revision" revn) + (kv-line "Schema" schema-version) + (kv-line "Database" db-path)) + + (when-let [pstats (:stats projection)] + (section-title "Projection") + (doseq [[k v] (sort-by key pstats)] + (println! (kv-line (c/name k) v)))) + + (section-title "Transforms") + (println! (kv-line "Applied" (or (:transforms transforms) 0))) + (doseq [[rel count] (sort-by key (:counts transforms))] + (println! (kv-line (c/name rel) count))) + (when-let [ids (seq (:ids transforms))] + (println! (kv-line "Recorded" (str/join ", " ids)))) + + (when stats + (section-title "Graph counts") + (when-let [nodes (:nodes stats)] + (println! " Nodes") + (print-node-counts nodes)) + (when-let [edges (:edges stats)] + (println! " Edges") + (doseq [[rel count] (sort-by key edges) + :when (pos? (long count))] + (println! (kv-line (c/name rel) count))))) + + (println!) + nil) diff --git a/backend/src/app/graph/schema.clj b/backend/src/app/graph/schema.clj new file mode 100644 index 0000000000..0aace14bea --- /dev/null +++ b/backend/src/app/graph/schema.clj @@ -0,0 +1,30 @@ +;; 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 Sucursal en España SL + +(ns app.graph.schema + "Ladybug DDL facade for the graph-backed Penpot vertical slice. + + Node metadata and DDL generation live in `app.graph.schema.nodes`." + (:require + [app.graph.schema.nodes :as nodes])) + +(def schema-version + nodes/schema-version) + +(def container-node-tables + nodes/container-tables) + +(def shape-node-tables + nodes/shape-tables) + +(def node-tables + (mapv (fn [{:keys [table schema]}] + {:name table :schema schema}) + nodes/node-types)) + +(defn ddl-statements + [] + (nodes/ddl-statements)) diff --git a/backend/src/app/graph/schema/contract.clj b/backend/src/app/graph/schema/contract.clj new file mode 100644 index 0000000000..684a12dd2e --- /dev/null +++ b/backend/src/app/graph/schema/contract.clj @@ -0,0 +1,150 @@ +;; 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 Sucursal en España SL + +(ns app.graph.schema.contract + "Deliberate choices in Penpot's graph schema, recorded as data. + + Penpot must pick a spelling and a type for every graph column. A Ladybug + column gets both once, at table creation, and neither widens afterwards. The + choices are therefore worth making deliberately and worth recording. + + Three of them live here: + + - `column-name` maps a Penpot key to its column. The rule is snake_case of + the key, and `renames` records every exception. + - `dropped-keys` and `per-table-dropped` name Penpot keys that deliberately + get no column. + - `type-overrides` pins the Ladybug type where the Malli-derived one + (`app.graph.schema.types`) is coarser than the column deserves. + + Each entry carries its reason. A divergence from the default rule is then a + diff to review rather than a silent rename." + (:require + [app.common.json :as json] + [clojure.string :as str])) + +(def ^:private renames + "Penpot key to column name, where the column is not snake_case of the key. + + Keyed by the Penpot key alone: no shape type gives one of these a second + meaning, so a per-table map would only add ceremony." + {;; `bool` collides with the Ladybug type name, so the column is named after + ;; the table (`Boolean`) rather than after Penpot's `:bool` shape type. + :bool-type "boolean_type" + + ;; The column records what the file saved, which can lag what the shape + ;; tree implies. The `saved_` prefix marks it as the stored value rather + ;; than a derivation. + :component-root "saved_component_root" + + ;; The value is a list, so the plural is accurate. + :shadow "shadows" + + ;; The column spells the revision number out. + :revn "revision"}) + +(def dropped-keys + "Penpot keys projected by the Malli registry that get no column. + + Dropping is right only when the column would be dead weight for every reader + of the graph. A key a reader might learn from belongs in `unprojected-keys` + instead." + {:deleted-at + "Only non-nil for a soft-deleted file, and a deleted file is never ingested." + + :pixel-grid-color + "Viewer chrome: the color of the editor's pixel grid, not design content." + + :pixel-grid-opacity + "Viewer chrome, as above."}) + +(def unprojected-keys + "Penpot keys that should become graph columns and do not have one yet. + + Distinct from `dropped-keys` on purpose: these are a debt the projection + owes, not a decision to discard data. Keeping the two apart means a new + upstream attribute cannot be quietly buried in the drop list." + {:background-blur + "Landed upstream behind a default-on flag. No column for it yet."}) + +(def ^:private per-table-dropped + "Keys dropped only on certain tables. + + `:grids` is the standing case: Penpot's shape schema admits it on every + shape, but only a Frame ever carries one. Emitting an always-null column on + ten other tables would widen every multi-table scan for nothing." + {:grids #{"Boolean" "Circle" "Group" "Image" "Path" "Rectangle" "SVGRaw" "Text"}}) + +(def type-overrides + "Ladybug column type per column name, where the derived type is too coarse. + + `app.graph.schema.types` derives a type from the Malli schema, which is the + right default but coarser than the column deserves in places: a Malli `:map` + becomes `JSON`, where a native Ladybug MAP or a fixed-size array lets a + consumer read a tensor row without parsing. + + Only load-bearing divergences are pinned here, in the order they became + load-bearing." + {;; Must be a native MAP: a JSON blob cannot be indexed by key in Cypher, so + ;; `map_keys` and `map_extract` cannot reach a single token at all. + "applied_tokens" "MAP(STRING, STRING)" + + ;; `grc/schema:rect` is an inline `:and` over a map, not the registered + ;; `::grc/rect`, so `app.graph.schema.types` cannot recognize it by type. + ;; Four doubles rather than the eight-field struct: `x1`/`y1`/`x2`/`y2` are + ;; derivable from `x`/`y`/`width`/`height`, and a fixed-size array is a + ;; tensor row a consumer reads without parsing. + "selrect" "DOUBLE[4]" + + ;; The SVG provenance attributes are typed `:map` in the shape schema on + ;; purpose. Legacy files hold them as plain maps rather than as + ;; `::grc/rect` and `::gmt/matrix` records, and a tighter *schema* would + ;; reject those files + ;; (`app.common.types.shape/schema:shape-generic-attrs`). A tighter + ;; *column* is free: `app.graph.schema.values/coerce` reads either form. + "svg_viewbox" "DOUBLE[4]" + "svg_transform" "DOUBLE[6]" + + ;; `:fills` is an `:or` over the packed `app.common.types.fills` value and + ;; a plain vector of fill maps, so the schema alone cannot say it is a + ;; collection. It always is one, and a fill has enough optional shape + ;; (solid, gradient, image) that JSON per element is the honest element + ;; type. + "fills" "JSON[]"}) + +(def ^:private map-key-fns + "How to render the *keys* of a MAP column, per column. + + A column name is schema, so it is snake_case. The keys inside a MAP are + values, so they keep the spelling their producer used. `applied_tokens` is + keyed by shape attribute in the camelCase form + `app.common.json/write-camel-key` produces: `strokeWidth`, not + `stroke-width`." + {"applied_tokens" json/write-camel-key}) + +(defn map-key-fn + "Key renderer for a MAP column. `name` unless the column says otherwise." + [column] + (get map-key-fns column name)) + +(defn column-name + "The graph column name for Penpot key `k`. + + Default: snake_case of the key. `renames` overrides." + [k] + (or (get renames k) + (str/replace (name k) "-" "_"))) + +(defn drop-key? + "Should key `k` be omitted from `table`'s columns?" + [table k] + (or (contains? dropped-keys k) + (contains? (get per-table-dropped k #{}) table))) + +(defn ladybug-type + "The pinned Ladybug type for `column`, or `fallback` when nothing is pinned." + [column fallback] + (get type-overrides column fallback)) diff --git a/backend/src/app/graph/schema/nodes.clj b/backend/src/app/graph/schema/nodes.clj new file mode 100644 index 0000000000..c81802415d --- /dev/null +++ b/backend/src/app/graph/schema/nodes.clj @@ -0,0 +1,343 @@ +;; 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 Sucursal en España SL + +(ns app.graph.schema.nodes + "Single source of truth for graph node tables. + + Each registry entry declares Penpot Malli sources plus projection + options (`:drop`, optional `:extra`). Derived artifacts — Ladybug + DDL, Arrow fields, validation, type dispatch — all flow from that. + + This registry is the single source of the graph schema. A Ladybug column + gets its name and its type once, at table creation, and there is no + widening afterwards. Every divergence between a Penpot key and its column + is recorded in `app.graph.schema.contract`." + (:require + [app.common.exceptions :as ex] + [app.common.schema :as sm] + [app.common.time :as ct] + [app.common.types.component :as ctk] + [app.common.types.file :as ctf] + [app.common.types.page :as ctp] + [app.graph.ladybug :as ladybug] + [app.graph.schema.contract :as contract] + [app.graph.schema.projection :as projection] + [app.graph.schema.types :as types] + [clojure.string :as str])) + +(def schema-version + "penpot-graph-slice-4") + +(def ^:private document-projection + {:source ctf/schema:file + :drop [:data] + ;; Attributes a file map carries that `ctf/schema:file` does not declare. + ;; + ;; They belong here rather than in that schema, even though the graph wants + ;; them, because `schema:file` is on the *write* path too: + ;; `app.binfile.common/update-file!` derives its UPDATE columns from a file + ;; map's keys, so declaring `:backend` there made it try to write a `backend` + ;; column, which the `file` table does not have — it is synthesized on read. + ;; A projection `:extra` is local to the graph and cannot reach a write. + ;; + ;; `:options` is lifted out of `:data` before the blob is dropped + ;; (`app.graph.projection.document/document-attrs`); the rest come off the file + ;; map as `get-file` returns it. + :extra [:map + [:options {:optional true} [:maybe :map]] + [:backend {:optional true} [:maybe :string]] + [:comment-thread-seqn {:optional true} [:maybe :int]] + [:ignore-sync-until {:optional true} [:maybe ::ct/inst]]]}) + +(def ^:private page-projection + {:source ctp/schema:page + :drop [:objects]}) + +(def ^:private component-projection + {:source ctk/schema:component + :drop [:objects] + ;; Soft-delete flag used at runtime; not in schema:component. + :extra [:map + [:deleted {:optional true} :boolean] + [:annotation {:optional true} :string]]}) + +(def ^:private shape-projection + {:drop [:type]}) + +(def ^:private shape-node-types + [{:table "Frame" :penpot-type :frame :container? true} + {:table "Group" :penpot-type :group :container? true} + {:table "Boolean" :penpot-type :bool :container? true} + {:table "SVGRaw" :penpot-type :svg-raw :container? true} + {:table "Rectangle" :penpot-type :rect} + {:table "Circle" :penpot-type :circle} + {:table "Path" :penpot-type :path} + {:table "Text" :penpot-type :text} + {:table "Image" :penpot-type :image}]) + +(defn- resolve-schema + [{:keys [schema source drop extra penpot-type]}] + (or schema + (when penpot-type + (projection/project-shape-schema penpot-type + {:drop drop + :extra extra})) + (projection/project-schema source + {:drop drop + :extra extra}))) + +(defn- shape-node-entry + [{:keys [table penpot-type container?] :as entry}] + (let [projection (-> shape-projection + (merge (:projection entry)) + (assoc :penpot-type penpot-type))] + {:table table + :pk :id + :penpot-type penpot-type + :container? container? + :projection projection + :schema (resolve-schema projection)})) + +(def node-types + "Ordered node registry." + (into [{:table "Document" + :pk :id + :projection document-projection + :schema (resolve-schema document-projection)} + {:table "Page" + :pk :id + :projection page-projection + :schema (resolve-schema page-projection)} + {:table "Component" + :pk :id + :projection component-projection + :schema (resolve-schema component-projection)}] + (map shape-node-entry shape-node-types))) + +(def ^:private by-table + (into {} (map (juxt :table identity) node-types))) + +(def ^:private by-penpot-type + (into {} (keep (fn [{:keys [penpot-type table]}] + (when penpot-type [penpot-type table])) + node-types))) + +(def container-tables + (into #{} (comp (filter :container?) (map :table)) node-types)) + +(def shape-tables + (into [] (comp (filter :penpot-type) (map :table)) node-types)) + +(defn table-for-type + "Map a Penpot shape `:type` keyword to a Ladybug node table name." + [penpot-type] + (get by-penpot-type (keyword penpot-type))) + +(defn node-entry + [table] + (get by-table table)) + +(defn projection-for + "Return the projection options map for `table`." + [table] + (:projection (node-entry table))) + +(defn- entry-child-schema + "Return the value schema from a Malli map entry (`[k s]` or `[k props s]`)." + [entry] + (if (> (count entry) 2) + (nth entry 2) + (nth entry 1))) + +(defn column-name + "Graph column name for projected key `k` on `table`." + [_table k] + (contract/column-name k)) + +(defn column-ladybug-type + "Ladybug column type for projected key `k` on `table`." + [table k] + (some (fn [entry] + (when (= k (first entry)) + (contract/ladybug-type (column-name table k) + (types/ladybug-type (entry-child-schema entry))))) + (projection/schema-map-entries (:schema (node-entry table))))) + +(defn column-keys + "Projected column keys for `table`, in registry order. + + Keys the contract drops on this table are omitted, so the column order, the + Arrow batch, and the DDL cannot disagree about what exists." + [table] + (into [] + (comp (map first) + (remove #(contract/drop-key? table %))) + (projection/schema-map-entries (:schema (node-entry table))))) + +(defn columns + "Projected column names for `table`, in registry order." + [table] + (mapv #(column-name table %) (column-keys table))) + +(def ^:private validate-node-fn + (memoize + (fn [table] + (let [{:keys [schema]} (node-entry table)] + (sm/check-fn schema + :type :validation + :code (keyword "graph-node-projection" (str/lower-case table)) + :hint (str "invalid graph node projection for " table)))))) + +(defn- projection-error-hint + [table explain] + (str "invalid graph node projection for " table + (when explain + (str "\n" (sm/humanize-explain explain))))) + +(defn validate-node + "Validate and return projected node attrs for `table`." + [table value] + (let [{:keys [schema]} (node-entry table)] + (try + ((validate-node-fn table) value) + (catch clojure.lang.ExceptionInfo e + (let [data (ex-data e) + explain (or (::sm/explain data) + (sm/explain schema value))] + (ex/raise :type :validation + :code (keyword "graph-node-projection" (str/lower-case table)) + :hint (projection-error-hint table explain) + :table table + ::sm/explain explain + :cause e)))))) + +(defn- get-projected-attr + "The attribute under `k`, keyword or string key. + + `if-some`, not `or`: `false` and `0` are values, and falling through on them + is how `opacity 0` became `nil` and then the column default." + [attrs k] + (if-some [v (get attrs k)] + v + (when (keyword? k) (get attrs (name k))))) + +(defn- raise-empty-projection! + [table attrs] + (ex/raise :type :validation + :code (keyword "graph-node-projection" (str/lower-case table)) + :hint (str "empty graph node projection for " table + "; columns=" (count (column-keys table)) + " shape-keys=" (vec (keys attrs))))) + +(defn project-attrs + "Select and validate the projected columns for `table` from `attrs`." + [table attrs] + ;; `some?`, not truthiness: `false` and `0` are values. Dropping them sent + ;; `opacity 0` to the column default of 1.0 — a fully transparent shape + ;; projected as opaque. + (let [projected (into {} + (keep (fn [k] + (let [v (get-projected-attr attrs k)] + (when (some? v) [k v]))) + (column-keys table)))] + (when (empty? projected) + (raise-empty-projection! table attrs)) + (validate-node table projected))) + +(defn match-label + "Cypher node label for MATCH; backtick-wrapped when required by Ladybug." + [table] + (if (#{"Group" "Boolean"} table) + (str "`" table "`") + table)) + +(defn cypher-property-key + "Backtick-wrapped column name for inline Cypher literals." + [table k] + (str "`" (column-name table k) "`")) + +(defn column-map-key-fn + "How a MAP column of `table` renders its keys. + + A MAP's keys are values, not schema, so they keep the spelling their consumer + parsed — `applied_tokens` is keyed in camelCase. Both writers need this, so it + lives next to the column's type rather than in either of them." + [table k] + (contract/map-key-fn (column-name table k))) + +(defn format-column-value + "Cypher literal for `v` in column `k` of `table`. + + The single place that knows both the column's Ladybug type and the contract + detail that a MAP column may render its keys differently from `name` — used + by the bulk loader's post-COPY fixups and by the incremental sync alike, so + the two cannot disagree about a value's shape." + [table k v] + (ladybug/format-typed-value (column-ladybug-type table k) + v + (column-map-key-fn table k))) + +(defn- create-node-table-ddl + [{:keys [table pk]}] + (let [cols (for [k (column-keys table)] + (str "`" (column-name table k) "` " (column-ladybug-type table k)))] + (str "CREATE NODE TABLE `" table "` (" + (str/join ", " (concat cols + [(str "PRIMARY KEY (`" (column-name table pk) "`)")])) + ");"))) + +(defn is-child-of-ddl + [] + (str "CREATE REL TABLE `IsChildOf` (" + "FROM `Page` TO `Document`, " + "FROM `Component` TO `Document`, " + (str/join ", " + (concat + (map (fn [shape] + (str "FROM `" shape "` TO `Page`")) + shape-tables) + (for [shape shape-tables + container container-tables] + (str "FROM `" shape "` TO `" container "`")))) + ", `position` INT64);")) + +(defn is-instance-of-ddl + "Frame instance heads → Component." + [] + "CREATE REL TABLE `IsInstanceOf` (FROM `Frame` TO `Component`);") + +(defn- shape-to-shape-rel-ddl + "A rel table over the full shape × shape product. + + Created up-front rather than on demand: the bulk loader must never race on + lazy table creation, and a consumer can then tell \"this producer cannot + emit that pair\" from \"this document happens to have none\"." + [rel props] + (str "CREATE REL TABLE `" rel "` (" + (str/join ", " (for [from shape-tables + to shape-tables] + (str "FROM `" from "` TO `" to "`"))) + (when (seq props) (str ", " (str/join ", " props))) + ");")) + +(defn refers-to-ddl + "Instance shape → its homologue in the component main instance, resolved + from `shape-ref`." + [] + (shape-to-shape-rel-ddl "RefersTo" nil)) + +(defn fills-swap-slot-ddl + "Swapped-in shape → the slot shape it replaces." + [] + (shape-to-shape-rel-ddl "FillsSwapSlot" ["`slot_id` UUID"])) + +(defn ddl-statements + [] + (-> (mapv create-node-table-ddl node-types) + (conj (is-child-of-ddl)) + (conj (is-instance-of-ddl)) + (conj (refers-to-ddl)) + (conj (fills-swap-slot-ddl)))) \ No newline at end of file diff --git a/backend/src/app/graph/schema/projection.clj b/backend/src/app/graph/schema/projection.clj new file mode 100644 index 0000000000..4d0e969329 --- /dev/null +++ b/backend/src/app/graph/schema/projection.clj @@ -0,0 +1,85 @@ +;; 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 Sucursal en España SL + +(ns app.graph.schema.projection + "Derive Ladybug node column schemas from Penpot Malli sources. + + Start from the canonical schema and remove the keys that must not become + graph columns." + (:require + [app.common.exceptions :as ex] + [app.common.schema :as sm] + [app.common.types.shape :as cts] + [malli.core :as m])) + +(def ^:private malli-opts sm/default-options) + +(defn- coerce-schema + "Normalize Malli sources to a compiled schema, unwrapping `:val` nodes." + [schema] + (loop [s (cond + (sm/schema? schema) schema + :else (sm/schema schema))] + (if (= :malli.core/val (sm/type s)) + (recur (first (sm/children s))) + s))) + +(defn- unsupported-projection-schema! + [schema] + (ex/raise :type :internal + :code :unsupported-projection-schema + :hint (str "unsupported projection schema type: " + (sm/type (coerce-schema schema))))) + +(defn schema-map-entries + "Map entries for `schema`, flattening `:merge` composites." + [schema] + (let [s (coerce-schema schema)] + (or (seq (sm/entries s)) + (unsupported-projection-schema! schema)))) + +(defn- select-projected-keys + "Project `schema` to a flat map schema, optionally dropping keys." + [schema drop-keys] + (let [s (coerce-schema schema) + keys (if (seq drop-keys) + (remove (set drop-keys) (sm/keys s)) + (sm/keys s))] + (sm/select-keys s (vec keys)))) + +(defn shape-type-schema + "Return the compiled Penpot Malli branch for shape type `penpot-type`. + + `m/entries` on the shape `:multi` yields MapEntries whose values are + compiled branch schemas (wrapped in `:val`). `m/children` returns raw + entry forms and must not be used here." + [penpot-type] + (let [kw (keyword penpot-type) + multi (sm/schema cts/schema:shape-attrs)] + (or (some (fn [entry] + (when (= kw (key entry)) + (val entry))) + (m/entries multi malli-opts)) + (ex/raise :type :validation + :code :unknown-shape-type + :hint (str "unknown penpot shape type: " kw))))) + +(defn project-schema + "Build a graph node schema from canonical Malli `source`. + + Options: + - `:drop` - keys removed from the source + - `:extra` - optional extra `[:map ...]` merged on top" + [source {:keys [drop extra]}] + (let [projected (select-projected-keys source drop)] + (if extra + (sm/merge projected (coerce-schema extra)) + projected))) + +(defn project-shape-schema + "Project `:drop` from the Penpot schema for `penpot-type`." + [penpot-type opts] + (project-schema (shape-type-schema penpot-type) opts)) diff --git a/backend/src/app/graph/schema/types.clj b/backend/src/app/graph/schema/types.clj new file mode 100644 index 0000000000..a905d92dcc --- /dev/null +++ b/backend/src/app/graph/schema/types.clj @@ -0,0 +1,174 @@ +;; 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 Sucursal en España SL + +(ns app.graph.schema.types + "Map Malli schemas to Ladybug column types. + + Ladybug is schema-first and strongly typed: every property key gets its type + at table-creation time, and there is no widening later. That makes this + mapping the whole of the graph's typing, and it is worth being tight — a + column typed `DOUBLE[4]` is four numbers a consumer reads as a tensor row, + where the same value as `JSON` is text somebody has to parse and trust. So + JSON is the fallback of last resort, taken only where the Malli schema + genuinely admits shapes no single column can hold. + + Three groups, in the order the mapping tries them: + + 1. **Scalars** (`base-type->ladybug`) — the leaf Malli types. + 2. **Registered composites** (`custom-type->ladybug`) — Penpot's own value + types whose *layout* is fixed even though Malli only sees a map or a + string: a matrix is six doubles, a point two, a rect four, a hex colour + one packed integer. These are named explicitly because the tight encoding + is a modelling decision, not something derivable from the schema. + 3. **Structure** — collections become `T[]`, `:map-of` becomes `MAP(k, v)`, + and a closed map of scalars becomes a `STRUCT`. Anything that could be + more than one shape (a `:multi`, an `:or`, an optional-keyed map) becomes + `JSON`, because a Ladybug column cannot be two types. + + Every encoding here has a matching value formatter in `app.graph.ladybug`. + The two must move together: a column type with no case there falls back to + guessing the literal from the runtime value." + (:require + [app.common.logging :as l] + [app.common.schema :as sm] + [app.common.time :as ct] + [clojure.string :as str] + [malli.core :as m])) + +(def ^:private malli-opts sm/default-options) + +(def ^:private base-type->ladybug + {::sm/uuid "UUID" + ::sm/safe-number "DOUBLE" + ::sm/safe-double "DOUBLE" + ::sm/safe-int "INT64" + ::sm/number "DOUBLE" + ::sm/boolean "BOOLEAN" + ::sm/int "INT64" + ::ct/inst "TIMESTAMP" + :uuid "UUID" + :string "STRING" + :int "INT64" + :double "DOUBLE" + :float "DOUBLE" + :boolean "BOOLEAN" + :keyword "STRING" + :inst "TIMESTAMP"}) + +(def ^:private custom-type->ladybug + "Penpot value types with a fixed layout Malli does not express. + + Fixed-size arrays are the point of each: they are dense, they need no + parsing, and a consumer can read a whole column as a tensor. + + - `::gmt/matrix` — the affine transform, `[a b c d e f]`. + - `::gpt/point` — `[x y]`. + - `::grc/rect` — `[x y width height]`. `x1`/`y1`/`x2`/`y2` are dropped: they + are derivable from those four, and carrying them would double the column. + - `::clr/hex-color` — `#RRGGBB` packed as `0xRRGGBBAA`, so colours compare + and group without string handling." + {:app.common.geom.matrix/matrix "DOUBLE[6]" + :app.common.geom.point/point "DOUBLE[2]" + :app.common.geom.rect/rect "DOUBLE[4]" + :app.common.types.color/hex-color "UINT32"}) + +(def ^:private collection-types + #{:vector :sequential :set ::sm/vec ::sm/set ::sm/coll}) + +(def ^:private string-collection-types + "Registered collection schemas whose element type is not in `children`." + {::sm/set-of-strings "STRING[]" + ::sm/set-of-keywords "STRING[]" + ::sm/set-of-uuid "UUID[]" + ::sm/vec-of-uuid "UUID[]"}) + +(defn- normalize-schema + "Resolve refs, but stop at a schema this namespace maps explicitly. + + Order matters: `::grc/rect` derefs to an `:and` over a map, and following + that would lose the fixed-size-array encoding." + [schema] + (let [s (sm/schema schema)] + (if (and (m/-ref-schema? s) + (not (contains? custom-type->ladybug (m/type s))) + (not (contains? string-collection-types (m/type s)))) + (recur (m/deref s malli-opts)) + s))) + +(declare ladybug-type) + +(defn- entry-child + "The value schema of a Malli map entry (`[k s]` or `[k props s]`)." + [entry] + (if (> (count entry) 2) (nth entry 2) (nth entry 1))) + +(defn- entry-optional? + [entry] + (and (> (count entry) 2) + (:optional (nth entry 1)))) + +(defn- struct-type + "`STRUCT(...)` for a closed map of scalars, or nil when JSON is the honest answer. + + A struct is a fixed layout: every field present, every field a single type. + An optional key would make the column's shape depend on the row, and a nested + collection or map makes it recursive — Ladybug allows nesting, but a consumer + reading such a column gains nothing over JSON, so the line is drawn at + scalars." + [s] + (let [entries (m/entries s malli-opts)] + (when (and (seq entries) + (not-any? entry-optional? entries)) + (let [fields (for [entry entries + :let [t (ladybug-type (entry-child entry))]] + (when (and t + (not= "JSON" t) + (not (str/includes? t "("))) + ;; snake_case like a column name, and always + ;; backtick-quoted: a grid cell has a field called + ;; `column`, which is a Ladybug keyword, and an unquoted + ;; one fails to parse in the DDL *and* in every literal. + ;; The catalog reports them unquoted. + (str "`" (str/replace (name (key entry)) "-" "_") "` " t)))] + (when (every? some? fields) + (str "STRUCT(" (str/join ", " fields) ")")))))) + +(defn ladybug-type + "Return the Ladybug column type for a Malli child schema." + [schema] + (let [s (normalize-schema schema) + t (m/type s)] + (or (base-type->ladybug t) + (custom-type->ladybug t) + (string-collection-types t) + (when (contains? collection-types t) + (when-let [child (first (m/children s malli-opts))] + (str (ladybug-type child) "[]"))) + (case t + (:maybe :and) (ladybug-type (first (m/children s malli-opts))) + + ;; `::sm/one-of` is how Penpot spells a closed set of keywords — + ;; `:blend-mode`, `:grow-type`, every `:layout-*`. One keyword, one + ;; string. + (:enum ::sm/one-of) "STRING" + + :map-of + (let [[key-schema value-schema] (m/children s malli-opts)] + (str "MAP(" (ladybug-type key-schema) ", " + (ladybug-type value-schema) ")")) + + :map (or (struct-type s) "JSON") + + ;; A schema we do not recognize. If it has no children it is a leaf — + ;; one of Penpot's registered keyword or enum schemas, say — and a + ;; string holds it exactly. If it has children it is a composite whose + ;; shape we cannot pin down, and JSON is the honest answer. + (if (empty? (m/children s malli-opts)) + "STRING" + (do + (l/wrn :hint "unmapped composite malli type, defaulting to JSON" + :malli-type t) + "JSON")))))) diff --git a/backend/src/app/graph/schema/values.clj b/backend/src/app/graph/schema/values.clj new file mode 100644 index 0000000000..e93b74f499 --- /dev/null +++ b/backend/src/app/graph/schema/values.clj @@ -0,0 +1,202 @@ +;; 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 Sucursal en España SL + +(ns app.graph.schema.values + "Shape a Penpot value into the plain data its Ladybug column type wants. + + Ladybug is strongly typed, and `app.graph.schema.types` maps Penpot's Malli + schemas onto types as tight as it can — a matrix is `DOUBLE[6]`, a rect + `DOUBLE[4]`, a colour `UINT32`, a closed map a `STRUCT`. A tight column is + only worth having if the writer actually fills it in that shape, which is + what this namespace does: it turns records and maps into the numbers, vectors + and plain maps the type names. + + It deliberately stops there. Serialization belongs to the writer — Cypher + literals in `app.graph.ladybug`, Arrow vectors in `app.graph.arrow` — so that + shaping a value and writing it are separate concerns and each has one home. + + The type language is the Ladybug one, read recursively: `T[]`, `T[n]`, + `MAP(k, v)`, `STRUCT(name t, …)`. Anything else is passed through." + (:require + [app.common.geom.matrix :as gmt] + [app.common.geom.point :as gpt] + [app.common.types.color :as clr] + [clojure.string :as str])) + +(defn- split-args + "Split a comma-separated type argument list, respecting nesting. + + `\"UUID, STRUCT(a INT64, b INT64)\"` → `[\"UUID\" \"STRUCT(a INT64, b INT64)\"]`." + [s] + (loop [chars (seq s) depth 0 current (StringBuilder.) out []] + (if-let [c (first chars)] + (cond + (and (= c \,) (zero? depth)) + (recur (rest chars) depth (StringBuilder.) (conj out (str/trim (str current)))) + + (or (= c \() (= c \[)) + (recur (rest chars) (inc depth) (.append current c) out) + + (or (= c \)) (= c \])) + (recur (rest chars) (dec depth) (.append current c) out) + + :else + (recur (rest chars) depth (.append current c) out)) + (let [last-arg (str/trim (str current))] + (cond-> out (seq last-arg) (conj last-arg)))))) + +(defn- parse-list + "`[element-type]` when `t` is a list or fixed-size array type, else nil. + + `DOUBLE[]` and `DOUBLE[4]` are both lists of doubles as far as shaping goes; + the size only matters to the DDL." + [t] + (when-let [[_ element] (re-matches #"(.+?)\[\d*\]$" t)] + [element])) + +(defn- parse-map + "`[key-type value-type]` when `t` is a MAP type, else nil." + [t] + (when-let [[_ args] (re-matches #"MAP\((.*)\)$" t)] + (let [[k v] (split-args args)] + (when (and k v) [k v])))) + +(defn- parse-struct + "`[[field-name field-type] …]` when `t` is a STRUCT type, else nil. + + Field names arrive backtick-quoted (see `app.graph.schema.types`). The + quoting is syntax, so it is stripped by default and re-applied by the writer — + except for the Arrow writer, which needs it kept (`keep-quotes?`)." + [t keep-quotes?] + (when-let [[_ args] (re-matches #"STRUCT\((.*)\)$" t)] + (for [arg (split-args args) + :let [idx (str/index-of arg " ")] + :when idx] + [(cond-> (subs arg 0 idx) (not keep-quotes?) (str/replace "`" "")) + (str/trim (subs arg (inc idx)))]))) + +(def ^:private struct-field-keys + "Field name → the Penpot keys that may hold it. + + A STRUCT field name is the snake_case of the Penpot key, but a value arrives + with its original key, and some arrive from JSON with the string form. Both + are tried before giving up." + (memoize + (fn [field] + [(keyword (str/replace field "_" "-")) + (keyword field) + field + (str/replace field "_" "-")]))) + +(defn- struct-field + [value field] + (some (fn [k] (when (contains? value k) (get value k))) + (struct-field-keys field))) + +(defn- fixed-vector + "`v` as a plain vector of numbers, for a `DOUBLE[n]` column. + + Records come first because they are what a realized snapshot holds; the map + forms are what a JSON round-trip leaves behind." + [v] + (cond + (gmt/matrix? v) [(:a v) (:b v) (:c v) (:d v) (:e v) (:f v)] + (gpt/point? v) [(:x v) (:y v)] + + ;; A rect: four of the eight fields, the rest being derivable. + (and (map? v) (contains? v :width) (contains? v :height)) + [(:x v) (:y v) (:width v) (:height v)] + + (and (map? v) (contains? v :x) (contains? v :y)) + [(:x v) (:y v)] + + (and (map? v) (contains? v :a) (contains? v :f)) + [(:a v) (:b v) (:c v) (:d v) (:e v) (:f v)] + + (sequential? v) (vec v) + :else nil)) + +(defn- packed-color + "`#RRGGBB` as the packed integer `0xRRGGBBAA`. + + Alpha defaults to opaque: the column holds a colour, and any opacity Penpot + keeps alongside it is a separate attribute." + [v] + (cond + (integer? v) v + (and (string? v) (clr/valid-hex-color? v)) + (let [rgb (Long/parseLong (subs v 1) 16)] + (bit-or (bit-shift-left rgb 8) 0xFF)) + :else nil)) + +(def struct-fields + "`[[field-name field-type] …]` for a STRUCT type, memoized. + + Public because the writers need the same field list to emit a literal." + (memoize (fn [ladybug-type] (vec (parse-struct ladybug-type false))))) + +(def struct-fields-quoted + "`struct-fields` with the DDL's backticks intact. + + Only the Arrow writer wants this: Ladybug names a staged struct's fields from + the Arrow child names and quotes none of them, so a field whose name is a + reserved word — a layout grid cell's `column` — has to arrive already quoted + or `createArrowTable` fails outright." + (memoize (fn [ladybug-type] (vec (parse-struct ladybug-type true))))) + +(def map-types + "`[key-type value-type]` for a MAP type, memoized." + (memoize (fn [ladybug-type] (parse-map ladybug-type)))) + +(def list-element + "Element type of a `T[]` / `T[n]` column, memoized; nil when not a list." + (memoize (fn [ladybug-type] (first (parse-list ladybug-type))))) + +(declare coerce) + +(defn- coerce-struct + [fields v] + (when (map? v) + (into {} + (keep (fn [[field field-type]] + (when-some [fv (struct-field v field)] + [field (coerce field-type fv)]))) + fields))) + +(defn coerce + "`v` as the plain data a column of `ladybug-type` holds. + + Returns `nil` when the value cannot be shaped that way, which callers treat + as \"write NULL\" — a wrong shape in a strongly typed column fails the whole + load, so declining is better than guessing." + [ladybug-type v] + (cond + (nil? v) nil + (not (string? ladybug-type)) v + + (= "UINT32" ladybug-type) (packed-color v) + + ;; Fixed-size numeric arrays are records: matrix, point, rect. + (re-matches #"DOUBLE\[\d+\]" ladybug-type) (fixed-vector v) + + :else + (if-let [[element] (parse-list ladybug-type)] + (when (or (sequential? v) (set? v)) + ;; A set has no order, so its column would otherwise vary between + ;; builds of the same file. Sorting makes it deterministic — which is + ;; what lets two builds be diffed at all, and what a stable golden + ;; needs. Sequential values keep their order: for `shapes` and + ;; `points`, the order *is* the content. + (let [elements (mapv #(coerce element %) v)] + (if (set? v) (vec (sort-by str elements)) elements))) + (if-let [[key-type value-type] (parse-map ladybug-type)] + (when (map? v) + (into {} + (map (fn [[k mv]] [(coerce key-type k) (coerce value-type mv)])) + v)) + (if-let [fields (seq (parse-struct ladybug-type false))] + (coerce-struct fields v) + v))))) diff --git a/backend/src/app/graph/stats.clj b/backend/src/app/graph/stats.clj new file mode 100644 index 0000000000..06a4eb2330 --- /dev/null +++ b/backend/src/app/graph/stats.clj @@ -0,0 +1,48 @@ +;; 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 Sucursal en España SL + +(ns app.graph.stats + (:require + [app.graph.ladybug :as ladybug] + [app.graph.schema.nodes :as nodes])) + +(defn- count-on-connection + [conn statement] + (or (ladybug/query-scalar-on-connection! conn statement) 0)) + +(defn- rel-table-names + "Relationship tables present in the open database. + + Read from the catalog so a newly ported transform's edges are counted + without this namespace being told about it." + [conn] + (->> (ladybug/query-on-connection! + conn "CALL show_tables() WHERE type = 'REL' RETURN name;" :max-rows 1000) + :rows + (map first))) + +(defn summarize-connection + "Return node/edge counts using an open Ladybug connection." + [conn] + {:nodes (into {} + (map (fn [table] + [table (count-on-connection + conn + (str "MATCH (n:" (nodes/match-label table) ") " + "RETURN count(n) AS " table "_c;"))]) + (map :table nodes/node-types))) + :edges (into {} + (map (fn [rel] + [(keyword rel) + (count-on-connection + conn + (str "MATCH ()-[e:`" rel "`]->() RETURN count(e) AS c;"))])) + (rel-table-names conn))}) + +(defn summarize + "Return node/edge counts from the graph database." + [db-path] + (ladybug/with-connection! db-path summarize-connection)) diff --git a/backend/src/app/graph/sync.clj b/backend/src/app/graph/sync.clj new file mode 100644 index 0000000000..cb32fe2d47 --- /dev/null +++ b/backend/src/app/graph/sync.clj @@ -0,0 +1,900 @@ +;; 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 Sucursal en España SL + +(ns app.graph.sync + "Incremental Ladybug graph updates from Penpot file-change events." + (:require + [app.common.logging :as l] + [app.common.uuid :as uuid] + [app.graph.ladybug :as ladybug] + [app.graph.projection.document :as projection.document] + [app.graph.schema.nodes :as nodes] + [clojure.string :as str]) + (:import + com.ladybugdb.Connection)) + +(set! *warn-on-reflection* true) + +(def ^:private supported-change-types + #{:add-obj :mod-obj :del-obj + :add-page :del-page :mod-page :mov-objects + :add-component :mod-component :del-component + :restore-component :purge-component}) + +(defn- shape-table + [shape] + (nodes/table-for-type (:type shape))) + +(defn- build-parent-map + [edges] + (into {} + (map (fn [{:keys [from-id to-id to-table]}] + [from-id {:parent-id to-id :parent-table to-table}])) + edges)) + +(defn- build-children-map + [edges] + (reduce (fn [acc {:keys [from-id to-id]}] + (update acc to-id (fnil conj #{}) from-id)) + {} + edges)) + +(defn- resolve-page-id + [shape-id parents pages] + (loop [id shape-id] + (cond + (contains? pages id) id + (get parents id) (recur (:parent-id (parents id))) + :else nil))) + +(defn- node-attrs-id + [attrs] + (cond + (map? attrs) (or (:id attrs) (get attrs "id")) + (and (vector? attrs) (= 2 (count attrs))) + (let [[k v] attrs] + (when (or (= k :id) (= k "id")) v)))) + +(defn- table-rows + "Normalize a projection table value to a vector of attribute maps." + [nodes table] + (let [rows (or (get nodes table) (get nodes (keyword table)))] + (cond + (nil? rows) [] + (map? rows) [rows] + (sequential? rows) (vec rows) + :else []))) + +(defn- document-id-from-nodes + [nodes file-id] + (or (some node-attrs-id (table-rows nodes "Document")) + file-id)) + +(defn- page-index-entry + [attrs] + (let [id (node-attrs-id attrs)] + [id {:id id + :name (:name attrs) + :index (long (:index attrs 0))}])) + +(defn- index-pages + [nodes] + (into {} (map page-index-entry (table-rows nodes "Page")))) + +(defn- component-index-entry + [attrs] + (let [id (node-attrs-id attrs)] + [id {:id id + :name (:name attrs) + :deleted (boolean (:deleted attrs))}])) + +(defn- index-components + [nodes] + (into {} (map component-index-entry (table-rows nodes "Component")))) + +(defn- shape-index-table? + [table] + (not (contains? #{"Document" "Page" "Component" + :Document :Page :Component} + table))) + +(defn- shape-index-entry + [table attrs parents pages edges] + (let [shape-id (node-attrs-id attrs) + {:keys [parent-id parent-table]} (parents shape-id) + edge (first (filter #(= shape-id (:from-id %)) edges))] + [shape-id {:id shape-id + :name (:name attrs) + :table table + :parent-id parent-id + :parent-table parent-table + :position (long (:position edge 0)) + :frame-id (:frame-id attrs) + ;; The projection already denormalized these; re-deriving + ;; page-id from the parent chain would only be a second way to + ;; get the same answer. `:component-ctx` is what later + ;; `:add-obj` children inherit — it is the shape's effective + ;; component-id, which loses the barrier case of a *non-Frame* + ;; carrying its own `component-id` (indistinguishable once + ;; denormalized). Cold projection keeps the distinction. Only a + ;; graph synced across such a shape can drift, and a Reload + ;; rebuilds it. + :component-ctx (:component-id attrs) + :page-id (or (:page-id attrs) + (resolve-page-id shape-id parents pages))}])) + +(defn- index-shapes + [nodes edges parents pages] + (reduce + (fn [acc [table _]] + (into acc (map #(shape-index-entry table % parents pages edges) + (table-rows nodes table)))) + {} + (filter (fn [[table _]] (shape-index-table? table)) nodes))) + +(defn build-index + "Build a sync index from a full graph projection." + [file-id revn {:keys [nodes edges]}] + (let [doc-id (document-id-from-nodes nodes file-id) + pages (index-pages nodes) + components (index-components nodes) + parents (build-parent-map edges) + children-index (build-children-map edges) + shapes (index-shapes nodes edges parents pages)] + {:file-id file-id + :doc-id doc-id + :revn (long revn) + :pages pages + :components components + :shapes shapes + :children children-index})) + + +(defn- format-node-value + [table k v] + (nodes/format-column-value table k v)) + +(defn- create-node-statement + [table attrs] + (let [label (nodes/match-label table) + pairs (for [k (nodes/column-keys table) + :let [v (get attrs k)] + :when (some? v)] + (str (nodes/cypher-property-key table k) ": " + (format-node-value table k v)))] + (str "CREATE (:" label " {" (str/join ", " pairs) "});"))) + +(defn- delete-node-statement + [table shape-id] + (str "MATCH (n:" (nodes/match-label table) " {id: " (ladybug/format-uuid shape-id) "}) " + "DETACH DELETE n;")) + +(defn- create-edge-statement + [{:keys [from-table from-id to-table to-id position]}] + (str "MATCH (s:" (nodes/match-label from-table) " {id: " (ladybug/format-uuid from-id) "}), " + "(p:" (nodes/match-label to-table) " {id: " (ladybug/format-uuid to-id) "}) " + "CREATE (s)-[:IsChildOf {position: " (ladybug/format-int position) "}]->(p);")) + +(defn- create-instance-of-statement + "Link a Frame instance head to its Component. + + No-op when the Component is absent (e.g. library component not ingested)." + [frame-id component-id] + (str "MATCH (f:Frame {id: " (ladybug/format-uuid frame-id) "}), " + "(c:Component {id: " (ladybug/format-uuid component-id) "}) " + "WHERE NOT COALESCE(c.deleted, false) " + "MERGE (f)-[:IsInstanceOf]->(c);")) + +(defn- delete-instance-of-statement + [frame-id] + (str "MATCH (f:Frame {id: " (ladybug/format-uuid frame-id) "})" + "-[r:IsInstanceOf]->(:Component) " + "DELETE r;")) + +(defn- instance-of-statements + "Cypher to (re)link `IsInstanceOf` after add/mod of a Frame's component-id." + [table shape-id component-id] + (when (= table "Frame") + (cond-> [(delete-instance-of-statement shape-id)] + (some? component-id) + (conj (create-instance-of-statement shape-id component-id))))) + +(defn- delete-edge-statement + [{:keys [from-table from-id to-table to-id]}] + (str "MATCH (s:" (nodes/match-label from-table) " {id: " (ladybug/format-uuid from-id) "})" + "-[r:IsChildOf]->" + "(p:" (nodes/match-label to-table) " {id: " (ladybug/format-uuid to-id) "}) " + "DELETE r;")) + +(defn- set-edge-position-statement + [{:keys [from-table from-id to-table to-id position]}] + (str "MATCH (s:" (nodes/match-label from-table) " {id: " (ladybug/format-uuid from-id) "})" + "-[r:IsChildOf]->" + "(p:" (nodes/match-label to-table) " {id: " (ladybug/format-uuid to-id) "}) " + "SET r.position = " (ladybug/format-int position) ";")) + +(defn- set-node-attr-statement + [table shape-id attr value] + (str "MATCH (s:" (nodes/match-label table) " {id: " (ladybug/format-uuid shape-id) "}) " + "SET s." (nodes/cypher-property-key table attr) " = " + (format-node-value table attr value) ";")) + +(defn- set-page-name-statement + [page-id name] + (str "MATCH (p:Page {id: " (ladybug/format-uuid page-id) "}) " + "SET p.name = " (ladybug/format-string name) ";")) + +(defn- remove-node-attr-statement + "Clear a property. Ladybug has no Neo4j-style REMOVE; SET to NULL." + [table shape-id attr] + (str "MATCH (s:" (nodes/match-label table) " {id: " (ladybug/format-uuid shape-id) "}) " + "SET s." (nodes/cypher-property-key table attr) " = NULL;")) + +(defn- index-add-component! + [index {:keys [id name doc-id]}] + (-> index + (assoc-in [:components id] {:id id :name name :deleted false}) + (update :children update doc-id (fnil conj #{}) id))) + +(defn- index-remove-component! + [index component-id] + (let [doc-id (:doc-id index)] + (-> index + (update :components dissoc component-id) + (update :children update doc-id #(disj (or % #{}) component-id))))) + + +(defn- set-document-revision-statement + "Set the Document's revision number. + + `app.graph.schema.contract` names the column `revision`, not `revn`. The name + is produced by `nodes/cypher-property-key`, so this statement and the DDL + cannot disagree." + [doc-id revn] + (str "MATCH (d:Document {id: " (ladybug/format-uuid doc-id) "}) " + "SET d." (nodes/cypher-property-key "Document" :revn) " = " + (ladybug/format-int revn) ";")) + +(defn- resolve-parent-for-add + [index {:keys [parent-id frame-id page-id]}] + (let [pid (or parent-id frame-id)] + (if (or (nil? pid) (uuid/zero? pid)) + (when page-id + {:parent-id page-id :parent-table "Page"}) + (if-let [shape (get-in index [:shapes pid])] + {:parent-id pid :parent-table (:table shape)} + (when (get-in index [:pages pid]) + {:parent-id pid :parent-table "Page"}))))) + +(defn- index-add-shape! + [index {:keys [id name table parent-id parent-table position page-id + frame-id component-ctx]}] + (-> index + (assoc-in [:shapes id] + {:id id + :name name + :table table + :parent-id parent-id + :parent-table parent-table + :position position + :frame-id frame-id + :component-ctx component-ctx + :page-id page-id}) + (update :children update parent-id (fnil conj #{}) id))) + +(defn- index-remove-shape! + [index shape-id] + (if-let [shape (get-in index [:shapes shape-id])] + (-> index + (update :shapes dissoc shape-id) + (update :children update (:parent-id shape) + #(disj (or % #{}) shape-id)) + (update :children dissoc shape-id)) + index)) + +(defn- index-add-page! + [index {:keys [id name doc-id] page-index :index}] + (-> index + (assoc-in [:pages id] {:id id :name name :index page-index}) + (update :children update doc-id (fnil conj #{}) id))) + +(defn- index-move-shape! + [index shape-id {:keys [parent-id parent-table position page-id frame-id]}] + (let [old-parent (get-in index [:shapes shape-id :parent-id])] + (-> index + (assoc-in [:shapes shape-id :parent-id] parent-id) + (assoc-in [:shapes shape-id :parent-table] parent-table) + (assoc-in [:shapes shape-id :position] position) + (assoc-in [:shapes shape-id :frame-id] frame-id) + (cond-> page-id (assoc-in [:shapes shape-id :page-id] page-id)) + (update :children update old-parent #(disj (or % #{}) shape-id)) + (update :children update parent-id (fnil conj #{}) shape-id)))) + +;; --- the columns that restate parenthood +;; +;; A shape carries `parent_id` and `frame_id`, and a container carries the +;; ordered `shapes` list. All three restate what `IsChildOf` already says, and +;; the cold projection writes them from the file, so this path has to keep +;; them in step or a synced graph stops matching a rebuilt one. + +(defn- shape-parent-id + "The `parent_id` a shape's own column holds. + + A top-level shape's parent in the file is the page's root frame, which the + graph does not materialize, so `IsChildOf` points at the Page while the + column holds `uuid/zero`." + [parent-id parent-table] + (if (= "Page" parent-table) uuid/zero parent-id)) + +(defn- frame-id-under + "The `frame_id` a shape gets when its parent is `parent-id`. + + Penpot's rule, from `app.common.files.changes` `:mov-objects`: the parent + itself when the parent is a Frame, the parent's own frame otherwise." + [index parent-id parent-table] + (cond + (= "Page" parent-table) uuid/zero + (= "Frame" parent-table) parent-id + :else (get-in index [:shapes parent-id :frame-id] uuid/zero))) + +(defn- frame-id-updates + "`[shape-id frame-id]` for a moved shape and everything that follows it. + + A Frame keeps its descendants pointing at itself, so the walk stops there. + Any other shape carries its subtree onto the new frame." + [index shape-id frame-id] + (into [[shape-id frame-id]] + (when (not= "Frame" (get-in index [:shapes shape-id :table])) + (mapcat #(frame-id-updates index % frame-id) + (get-in index [:children shape-id] #{}))))) + +(defn- child-shapes-value + "A container's stored `shapes` list, rebuilt from the index. + + `IsChildOf.position` counts from the last entry of that list + (`app.graph.projection.document/child-shape-ids` reverses it), so reversing the + children ordered by position gives the list back." + [index parent-id] + (->> (get-in index [:children parent-id] #{}) + (sort-by #(get-in index [:shapes % :position] 0)) + reverse + vec)) + +(defn- insert-position + "The graph position the lowest of `k` shapes takes when they are inserted + into a parent that already holds `n-before` children. + + A container's stored `:shapes` list runs bottom to top, and the graph + numbers children in Penpot z-order, so the two run opposite ways. An append + to the stored list, which is what `:add-obj` does without an `:index`, is + therefore position 0 and pushes every sibling up by one. The block occupies + the result and the `k - 1` positions above it, the first shape highest." + [n-before {:keys [index]} after-position] + (cond + (some? after-position) (long after-position) + (some? index) (max 0 (- n-before (long index))) + :else 0)) + +(defn- renumber-siblings + "Shift `parent-id`'s children at or above `from` by `delta`. + + Returns `[index statements]`. `except` names children the caller is placing + itself." + [index parent-id parent-table from delta except] + (reduce + (fn [[idx stmts] child-id] + (let [pos (get-in idx [:shapes child-id :position])] + (if (and (some? pos) (not (contains? except child-id)) (>= (long pos) (long from))) + (let [pos' (+ (long pos) (long delta))] + [(assoc-in idx [:shapes child-id :position] pos') + (conj stmts (set-edge-position-statement + {:from-table (get-in idx [:shapes child-id :table]) + :from-id child-id + :to-table parent-table + :to-id parent-id + :position pos'}))]) + [idx stmts]))) + [index []] + (vec (get-in index [:children parent-id] #{})))) + +(defn- set-children-statements + "Refresh the `shapes` column of every container in `parent-ids`. + + A Page has no such column: its top-level shapes hang off a root frame the + graph never materializes." + [index parent-ids] + (into [] + (comp (distinct) + (keep (fn [parent-id] + (let [table (get-in index [:shapes parent-id :table])] + (when (contains? nodes/container-tables table) + (set-node-attr-statement + table parent-id :shapes + (child-shapes-value index parent-id))))))) + parent-ids)) + +(defn- mov-object-ids + [shapes] + (let [coll (cond + (nil? shapes) [] + (sequential? shapes) shapes + (uuid? shapes) [shapes] + (map? shapes) (if-let [id (or (:id shapes) (get shapes "id"))] + [id] + []) + :else [])] + (into [] + (keep (fn [shape] + (when shape + (if (uuid? shape) shape (:id shape))))) + coll))) + +(defn- detach-shape + "Take `shape-id` out of its current parent and close the gap it leaves. + + Returns `[index statements]`. The edge itself is left alone: the caller + either replaces it or deletes it." + [index shape-id] + (let [{:keys [parent-id parent-table position]} (get-in index [:shapes shape-id]) + index (update-in index [:children parent-id] #(disj (or % #{}) shape-id)) + [index stmts] (renumber-siblings index parent-id parent-table + (inc (long (or position 0))) -1 #{})] + [(assoc-in index [:shapes shape-id :position] nil) stmts])) + +(defn- apply-mov-objects + [index {:keys [shapes page-id] :as change}] + (let [shape-ids (mov-object-ids shapes) + parent (resolve-parent-for-add index + (assoc change + :frame-id (:parent-id change) + :page-id page-id))] + (cond + (empty? shape-ids) + {:index index :statements [] :applied? true} + + (not parent) + {:index index :statements [] :applied? false :reason :missing-parent} + + :else + (let [parent-id (:parent-id parent) + parent-table (:parent-table parent) + page-id' (or page-id + (when (= parent-table "Page") parent-id) + (get-in index [:shapes (first shape-ids) :page-id])) + known (filterv #(get-in index [:shapes %]) shape-ids) + old-parents (mapv #(get-in index [:shapes % :parent-id]) known) + ;; Penpot removes the shapes from wherever they were, then inserts + ;; the block into the target, so the target's width is measured + ;; after the removals. + [index detach-stmts] + (reduce (fn [[idx stmts] shape-id] + (let [[idx' s] (detach-shape idx shape-id)] + [idx' (into stmts s)])) + [index []] + known) + n-before (count (get-in index [:children parent-id] #{})) + after-pos (get-in index [:shapes (:after-shape change) :position]) + lowest (insert-position n-before change after-pos) + k (count known) + [index shift-stmts] + (renumber-siblings index parent-id parent-table lowest k #{})] + (loop [index index + statements (into detach-stmts shift-stmts) + entries (map-indexed vector known)] + (if-let [[offset shape-id] (first entries)] + (let [shape (get-in index [:shapes shape-id]) + position (+ lowest (- k 1 (long offset))) + frame-id (frame-id-under index parent-id parent-table) + frame-writes (frame-id-updates index shape-id frame-id) + edge {:from-table (:table shape) + :from-id shape-id + :to-table parent-table + :to-id parent-id + :position position} + moved? (not= parent-id (:parent-id shape)) + statements (-> statements + (cond-> moved? + (conj (delete-edge-statement + {:from-table (:table shape) + :from-id shape-id + :to-table (:parent-table shape) + :to-id (:parent-id shape)}))) + (conj (if moved? + (create-edge-statement edge) + (set-edge-position-statement edge)))) + ;; The shape's own columns restate the edge, and the frame + ;; follows the whole subtree the shape carries with it. + statements (if-not moved? + statements + (into (conj statements + (set-node-attr-statement + (:table shape) shape-id :parent-id + (shape-parent-id parent-id parent-table))) + (map (fn [[sid fid]] + (set-node-attr-statement + (get-in index [:shapes sid :table]) + sid :frame-id fid))) + frame-writes)) + index (index-move-shape! index shape-id + {:parent-id parent-id + :parent-table parent-table + :position position + :frame-id frame-id + :page-id page-id'}) + index (reduce (fn [idx [sid fid]] + (assoc-in idx [:shapes sid :frame-id] fid)) + index + frame-writes)] + (recur index statements (rest entries))) + {:index index + :statements (into statements + (set-children-statements index (conj old-parents parent-id))) + :applied? true})))))) + +(defn- index-remove-page! + [index page-id] + (let [doc-id (:doc-id index)] + (-> index + (update :pages dissoc page-id) + (update :children update doc-id #(disj (or % #{}) page-id)) + (update :children dissoc page-id)))) + +(defn- mod-attrs-for-table + [table] + (disj (set (nodes/column-keys table)) :id)) + +(defn- apply-add-obj + [index change] + (let [{:keys [id obj page-id]} change + table (shape-table obj)] + (if-not table + {:index index :statements [] :applied? false :reason :unsupported-shape-type} + (let [parent (resolve-parent-for-add index change)] + (if-not parent + {:index index :statements [] :applied? false :reason :missing-parent} + (let [parent-id (:parent-id parent) + parent-table (:parent-table parent) + n-before (count (get-in index [:children parent-id] #{})) + position (insert-position n-before change nil) + [index shift-stmts] + (renumber-siblings index parent-id parent-table position 1 #{}) + ;; The same denormalizations the cold projection performs, so + ;; a live-synced graph and a rebuilt one carry equal columns. + resolved-page-id + (or page-id + (when (= parent-table "Page") parent-id) + (get-in index [:shapes parent-id :page-id])) + parent-ctx (get-in index [:shapes parent-id :component-ctx]) + shape (projection.document/denormalized-shape + (assoc obj :id id) resolved-page-id parent-ctx) + attrs (nodes/project-attrs table shape) + edge {:from-table table + :from-id id + :to-table parent-table + :to-id parent-id + :position position} + stmts (-> shift-stmts + (conj (create-node-statement table attrs)) + (conj (create-edge-statement edge)) + (into (instance-of-statements table id (:component-id attrs)))) + index' (index-add-shape! index + {:id id + :name (:name attrs) + :table table + :parent-id parent-id + :parent-table parent-table + :position position + :frame-id (:frame-id attrs) + :component-ctx (projection.document/descend-component-ctx + table shape parent-ctx) + :page-id resolved-page-id})] + {:index index' + :statements (into stmts (set-children-statements index' [parent-id])) + :applied? true})))))) + +(defn- apply-mod-obj + [index {:keys [id operations]}] + (if-let [shape (get-in index [:shapes id])] + (let [table (:table shape) + syncable (mod-attrs-for-table table) + set-ops (filter #(and (= :set (:type %)) + (contains? syncable (:attr %))) + operations)] + (if (empty? set-ops) + {:index index :statements [] :applied? false :reason :unsupported-operations} + (let [updates (into {} (map (juxt :attr :val) set-ops)) + statements + (into (vec (for [[attr value] updates] + (set-node-attr-statement table id attr value))) + ;; Relink when component-id is among the synced attrs. + (when (contains? updates :component-id) + (instance-of-statements table id (:component-id updates)))) + index' (reduce (fn [idx [attr value]] + (assoc-in idx [:shapes id attr] value)) + index + updates)] + {:index index' + :statements statements + :applied? true}))) + {:index index :statements [] :applied? false :reason :missing-shape})) + +(defn- delete-order-deepest-first + [children root-id] + (letfn [(post-order [id] + (into (mapcat post-order (get children id #{})) + [id]))] + (post-order root-id))) + +(defn- apply-del-obj + [index {:keys [id]}] + (if-let [root (get-in index [:shapes id])] + (let [to-delete (delete-order-deepest-first (:children index) id) + statements + (vec (mapcat (fn [shape-id] + (let [{:keys [table parent-id parent-table]} + (get-in index [:shapes shape-id])] + [(delete-edge-statement + {:from-table table + :from-id shape-id + :to-table parent-table + :to-id parent-id}) + (delete-node-statement table shape-id)])) + to-delete)) + index' (reduce index-remove-shape! index to-delete) + ;; Only the deleted subtree's own parent survives to be renumbered: + ;; every other parent in `to-delete` goes with it. + [index' shift-stmts] + (renumber-siblings index' (:parent-id root) (:parent-table root) + (inc (long (or (:position root) 0))) -1 #{})] + {:index index' + :statements (-> statements + (into shift-stmts) + (into (set-children-statements index' [(:parent-id root)]))) + :applied? true}) + ;; Penpot emits one :del-obj per selected shape; an earlier change in the + ;; same batch may have already removed this node (e.g. parent + child). + {:index index :statements [] :applied? true})) + +(defn- apply-add-page + [index {:keys [id name page]}] + (let [page-id (or id (:id page)) + page (or page {:id page-id :name name}) + page (nodes/project-attrs "Page" {:id page-id + :name (or (:name page) "Page") + :index (count (:pages index))}) + doc-id (:doc-id index) + position (count (:pages index)) + edge {:from-table "Page" + :from-id page-id + :to-table "Document" + :to-id doc-id + :position position}] + {:index (index-add-page! index + {:id page-id + :name (:name page) + :index (:index page) + :doc-id doc-id}) + :statements [(create-node-statement "Page" page) + (create-edge-statement edge)] + :applied? true})) + +(defn- apply-del-page + [index {:keys [id]}] + (if (get-in index [:pages id]) + (let [shape-ids (into #{} + (comp (filter #(= id (get-in index [:shapes % :page-id]))) + (filter #(= "Page" (get-in index [:shapes % :parent-table])))) + (keys (:shapes index))) + del-shapes + (reduce (fn [acc shape-id] + (let [result (apply-del-obj acc {:type :del-obj :id shape-id})] + (if (:applied? result) + (-> acc + (assoc :index (:index result)) + (update :statements into (:statements result))) + acc))) + {:index index :statements []} + shape-ids) + statements + (conj (:statements del-shapes) + (delete-edge-statement {:from-table "Page" + :from-id id + :to-table "Document" + :to-id (:doc-id index)}) + (delete-node-statement "Page" id))] + {:index (-> (:index del-shapes) (index-remove-page! id)) + :statements statements + :applied? true}) + {:index index :statements [] :applied? false :reason :missing-page})) + +(defn- apply-mod-page + [index {:keys [id name]}] + (if (and (string? name) (get-in index [:pages id])) + {:index (assoc-in index [:pages id :name] name) + :statements [(set-page-name-statement id name)] + :applied? true} + {:index index :statements [] :applied? false :reason :unsupported-page-change})) + +(defn- component-syncable-attrs + "Projected Component columns that sync may SET (everything but :id)." + [] + (disj (set (nodes/column-keys "Component")) :id)) + +(defn- component-attrs-from-change + "Build CREATE attrs for `:add-component` (objects are not projected)." + [{:keys [id name path main-instance-id main-instance-page + annotation variant-id variant-properties]}] + (cond-> {:id id + :name (or name "Component") + :path (or path "") + :main-instance-id main-instance-id + :main-instance-page main-instance-page} + (some? annotation) (assoc :annotation annotation) + (some? variant-id) (assoc :variant-id variant-id) + (seq variant-properties) (assoc :variant-properties variant-properties))) + +(defn- apply-add-component + [index {:keys [id] :as change}] + (if (get-in index [:components id]) + {:index index :statements [] :applied? true} + (let [doc-id (:doc-id index) + position (count (:components index)) + attrs (nodes/project-attrs "Component" (component-attrs-from-change change)) + edge {:from-table "Component" + :from-id id + :to-table "Document" + :to-id doc-id + :position position}] + {:index (index-add-component! index + {:id id + :name (:name attrs) + :doc-id doc-id}) + :statements [(create-node-statement "Component" attrs) + (create-edge-statement edge)] + :applied? true}))) + +(defn- apply-mod-component + "Update projected Component attrs from a `:mod-component` change. + + Nil optional values clear the property (Penpot dissocs them). `:objects` + is never projected — shape trees live on pages." + [index {:keys [id] :as change}] + (let [syncable (component-syncable-attrs) + sets (into {} + (keep (fn [[k v]] + (when (and (contains? syncable k) (some? v)) + [k v]))) + (dissoc change :type :id :objects)) + removes (into [] + (keep (fn [[k v]] + (when (and (contains? syncable k) (nil? v)) + k))) + (dissoc change :type :id :objects)) + stmts (into (mapv (fn [[k v]] + (set-node-attr-statement "Component" id k v)) + sets) + (map #(remove-node-attr-statement "Component" id %) removes)) + index' (if (get-in index [:components id]) + (cond-> index + (contains? sets :name) + (assoc-in [:components id :name] (:name sets))) + (assoc-in index [:components id] + {:id id + :name (:name sets) + :deleted false}))] + (if (empty? stmts) + {:index index :statements [] :applied? true} + {:index index' :statements stmts :applied? true}))) + +(defn- apply-del-component + [index {:keys [id skip-undelete?]}] + (cond + (not (get-in index [:components id])) + {:index index :statements [] :applied? true} + + skip-undelete? + {:index (index-remove-component! index id) + :statements [(delete-edge-statement {:from-table "Component" + :from-id id + :to-table "Document" + :to-id (:doc-id index)}) + (delete-node-statement "Component" id)] + :applied? true} + + :else + {:index (assoc-in index [:components id :deleted] true) + :statements [(set-node-attr-statement "Component" id :deleted true)] + :applied? true})) + +(defn- apply-restore-component + [index {:keys [id page-id]}] + (let [stmts (cond-> [(set-node-attr-statement "Component" id :deleted false)] + page-id + (conj (set-node-attr-statement "Component" id :main-instance-page page-id))) + index (if (get-in index [:components id]) + (-> index + (assoc-in [:components id :deleted] false) + (cond-> page-id + (assoc-in [:components id :main-instance-page] page-id))) + (assoc-in index [:components id] + {:id id :name nil :deleted false}))] + {:index index :statements stmts :applied? true})) + +(defn- apply-purge-component + [index {:keys [id]}] + (if-not (get-in index [:components id]) + ;; Still attempt delete in case the node exists but was not indexed. + {:index index + :statements [(delete-edge-statement {:from-table "Component" + :from-id id + :to-table "Document" + :to-id (:doc-id index)}) + (delete-node-statement "Component" id)] + :applied? true} + {:index (index-remove-component! index id) + :statements [(delete-edge-statement {:from-table "Component" + :from-id id + :to-table "Document" + :to-id (:doc-id index)}) + (delete-node-statement "Component" id)] + :applied? true})) + +(defn- apply-change + [index change] + (case (:type change) + :add-obj (apply-add-obj index change) + :mod-obj (apply-mod-obj index change) + :del-obj (apply-del-obj index change) + :add-page (apply-add-page index change) + :del-page (apply-del-page index change) + :mod-page (apply-mod-page index change) + :mov-objects (apply-mov-objects index change) + :add-component (apply-add-component index change) + :mod-component (apply-mod-component index change) + :del-component (apply-del-component index change) + :restore-component (apply-restore-component index change) + :purge-component (apply-purge-component index change) + {:index index :statements [] :applied? false :reason :unsupported-type})) + +(defn apply-changes! + "Apply Penpot `changes` to an open Ladybug `conn` and return the updated index. + + Returns `{:index ... :revn ... :applied [...] :skipped [...]}`." + [^Connection conn index changes revn] + (when (> (long revn) (:revn index)) + (l/wrn :hint "graph sync revn gap" + :file-id (str (:file-id index)) + :index-revn (:revn index) + :change-revn revn)) + (loop [index index + applied [] + skipped [] + stmts [] + changes (seq changes)] + (if-let [change (first changes)] + (let [{:keys [index statements applied? reason]} + (apply-change index change)] + (recur index + (cond-> applied applied? (conj (:type change))) + (cond-> skipped (not applied?) (conj {:type (:type change) :reason reason})) + (cond-> stmts applied? (into statements)) + (rest changes))) + (let [final-stmts (cond-> stmts + (and (seq applied) (:doc-id index)) + (conj (set-document-revision-statement (:doc-id index) revn))) + index' (if (seq applied) + (assoc index :revn (long revn)) + index)] + (when (seq final-stmts) + (ladybug/exec-on-connection! conn final-stmts)) + {:index index' + :revn (if (seq applied) (long revn) (:revn index')) + :applied applied + :skipped skipped})))) + +(defn supported-change? + [change] + (contains? supported-change-types (:type change))) diff --git a/backend/src/app/http/debug.clj b/backend/src/app/http/debug.clj index 28687d6ac5..1bbf306b9c 100644 --- a/backend/src/app/http/debug.clj +++ b/backend/src/app/http/debug.clj @@ -16,6 +16,7 @@ [app.common.files.changes :as cfc] [app.common.files.repair :as cfr] [app.common.files.validate :as cfv] + [app.common.json :as json] [app.common.logging :as l] [app.common.pprint :as pp] [app.common.time :as ct] @@ -37,6 +38,7 @@ [app.storage.tmp :as tmp] [app.util.template :as tmpl] [cuerdas.core :as str] + [datoteka.fs :as fs] [datoteka.io :as io] [emoji.core :as emj] [integrant.core :as ig] @@ -61,6 +63,7 @@ ::yres/body (-> (io/resource "app/templates/debug.tmpl") (tmpl/render {:version (:full cf/version) :profile profile + :graph-enabled (contains? cf/flags :graph) :current-clock ct/*clock* :current-offset (if offset (ct/format-duration offset) @@ -334,6 +337,226 @@ "content-disposition" (str "attachmen; filename=" (first file-ids) ".penpot")}})))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; GRAPH (flag: :graph) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; `app.graph.*` resolves at call time, never at the top of this namespace. +;; `app.graph.ladybug` imports `com.ladybugdb.*`, so requiring it links the +;; Ladybug native library into the JVM, and this namespace loads on every +;; backend boot. The routes below are registered only under the `:graph` flag, +;; so with the flag off nothing resolves and no native code loads. + +(defn- graph-export-file + "Path of a freshly projected graph for `file-id`." + [cfg file-id] + (let [ingest-file! (requiring-resolve 'app.graph.ingest/ingest-file!) + {:keys [db-path]} (ingest-file! cfg file-id :skip-stats? true)] + (when-not (fs/exists? db-path) + (ex/raise :type :internal + :code :graph-file-not-found + :hint "graph database file missing after ingest" + :file-id (str file-id) + :db-path db-path)) + db-path)) + +(defn- graph-export-session + "Path of a snapshot of the caller's live in-memory graph for `file-id`." + [profile-id file-id] + (let [session-info (requiring-resolve 'app.graph.debug/session-info) + export-session-database! (requiring-resolve 'app.graph.debug/export-session-database!) + info (session-info profile-id)] + (when-not info + (ex/raise :type :not-found + :code :graph-session-not-loaded + :hint "no in-memory graph is loaded; load one first, or use source=file")) + (when-not (= file-id (:file-id info)) + (ex/raise :type :validation + :code :graph-session-file-mismatch + :hint "the loaded session holds a different file" + :requested (str file-id) + :loaded (str (:file-id info)))) + (export-session-database! profile-id))) + +(defn graph-export-handler + "Stream a Ladybug `.lbug` database for a file. + + `source=file` (default) projects the file afresh from the database — the + reproducible artifact. `source=session` snapshots the caller's live + in-memory console graph instead, which live-sync may have moved away from a + fresh projection; taking that away to query it elsewhere is the whole point + of asking for it. Synchronous on each request." + [cfg {:keys [params] :as request}] + (let [file-id (some-> params :file-id parse-uuid) + source (or (some-> params :source str/lower) "file")] + (when-not file-id + (ex/raise :type :validation + :code :missing-arguments + :hint "missing file-id")) + (when-not (contains? #{"file" "session"} source) + (ex/raise :type :validation + :code :invalid-arguments + :hint "source must be 'file' or 'session'" + :source source)) + + (let [session? (= "session" source) + db-path (if session? + (graph-export-session (::session/profile-id request) file-id) + (graph-export-file cfg file-id))] + {::yres/status 200 + ;; A session export is a temp file this request owns; deleting it on + ;; close would race the streaming body, so it is left for the OS temp + ;; sweep. A file export is the canonical per-file database and is meant + ;; to persist. + ::yres/body (io/input-stream db-path) + ::yres/headers {"content-type" "application/octet-stream" + "content-disposition" + (str "attachment; filename=" file-id + (when session? "-session") ".lbug")}}))) + +(defn- graph-console-response + [data] + {::yres/status 200 + ::yres/headers {"content-type" "text/html; charset=utf-8" + "x-robots-tag" "noindex"} + ::yres/body (-> (io/resource "app/templates/graph-console.tmpl") + (tmpl/render (assoc data :version (:full cf/version))))}) + +(defn graph-console-handler + [_cfg {:keys [::session/profile-id]}] + (let [console-context (requiring-resolve 'app.graph.debug/console-context)] + (graph-console-response (console-context profile-id)))) + +(defn graph-load-handler + [cfg {:keys [params ::session/profile-id]}] + (let [file-id (some-> (:file-id params) parse-uuid) + load-session! (requiring-resolve 'app.graph.debug/load-session!)] + (when-not file-id + (ex/raise :type :validation + :code :missing-arguments + :hint "missing file-id")) + (load-session! cfg profile-id file-id) + {::yres/status 302 + ::yres/headers {"location" "/dbg/graph"}})) + +(defn graph-unload-handler + [_cfg {:keys [::session/profile-id]}] + ((requiring-resolve 'app.graph.debug/unload-session!) profile-id) + {::yres/status 302 + ::yres/headers {"location" "/dbg/graph"}}) + +(defn graph-reload-handler + "Re-ingest the currently loaded file into the in-memory graph session." + [cfg {:keys [::session/profile-id]}] + (let [session-info (requiring-resolve 'app.graph.debug/session-info) + load-session! (requiring-resolve 'app.graph.debug/load-session!)] + (if-let [file-id (some-> (session-info profile-id) :file-id)] + (do + (load-session! cfg profile-id file-id) + {::yres/status 302 + ::yres/headers {"location" "/dbg/graph"}}) + (ex/raise :type :not-found + :code :graph-session-not-loaded + :hint "load a file graph before reloading")))) + +(defn graph-sync-status-handler + [_cfg {:keys [::session/profile-id]}] + (if-let [status ((requiring-resolve 'app.graph.debug/sync-status) profile-id)] + {::yres/status 200 + ::yres/headers {"content-type" "application/json; charset=utf-8"} + ::yres/body (t/encode-str status {:type :json-verbose})} + {::yres/status 404 + ::yres/headers {"content-type" "application/json; charset=utf-8"} + ::yres/body (t/encode-str {:error "no-session"} {:type :json-verbose})})) + +(defn graph-data-handler + "Export the in-memory session graph as plain JSON (not transit) for the + G6 graph view embedded in the console page." + [_cfg {:keys [::session/profile-id]}] + (if-let [data ((requiring-resolve 'app.graph.debug/export-graph-data!) profile-id)] + {::yres/status 200 + ::yres/headers {"content-type" "application/json; charset=utf-8"} + ::yres/body (json/encode data)} + {::yres/status 404 + ::yres/headers {"content-type" "application/json; charset=utf-8"} + ::yres/body (json/encode {:error "no-session"})})) + +(def ^:private sql:graph-files + "select t.id as team_id, t.name as team_name, + p.id as project_id, p.name as project_name, + f.id as file_id, f.name as file_name + from team as t + join team_profile_rel as tpr on (tpr.team_id = t.id) + join project as p on (p.team_id = t.id) + join file as f on (f.project_id = p.id) + where tpr.profile_id = ? + and t.deleted_at is null + and p.deleted_at is null + and f.deleted_at is null + order by t.name, p.name, f.name + limit 500") + +(defn- graph-files-tree + [rows] + (->> (group-by (juxt :team-id :team-name) rows) + (mapv (fn [[[team-id team-name] team-rows]] + {:id (str team-id) + :name team-name + :projects + (->> (group-by (juxt :project-id :project-name) team-rows) + (mapv (fn [[[project-id project-name] project-rows]] + {:id (str project-id) + :name project-name + :files (mapv (fn [{:keys [file-id file-name]}] + {:id (str file-id) :name file-name}) + project-rows)})) + (sort-by :name) + (vec))})) + (sort-by :name) + (vec))) + +(defn graph-files-handler + "List teams -> projects -> files reachable by the current profile, as + plain JSON for the graph console file tree." + [{:keys [::db/pool]} {:keys [::session/profile-id]}] + (let [rows (db/exec! pool [sql:graph-files profile-id])] + {::yres/status 200 + ::yres/headers {"content-type" "application/json; charset=utf-8"} + ::yres/body (json/encode {:teams (graph-files-tree rows)})})) + +(defn- json-request? + [request] + (some-> request + (yreq/get-header "accept") + (str/includes? "application/json"))) + +(defn graph-query-handler + [_cfg {:keys [params ::session/profile-id] :as request}] + (let [query (:query params) + query-session! (requiring-resolve 'app.graph.debug/query-session!) + console-context (requiring-resolve 'app.graph.debug/console-context)] + (try + (let [result (query-session! profile-id query)] + (if (json-request? request) + {::yres/status 200 + ::yres/headers {"content-type" "application/json; charset=utf-8"} + ::yres/body (t/encode-str {:query query + :query-result result} + {:type :json-verbose})} + (graph-console-response (console-context profile-id + :query query + :query-result result)))) + (catch Throwable e + (let [error (or (:hint (ex-data e)) (ex-message e))] + (if (json-request? request) + {::yres/status 200 + ::yres/headers {"content-type" "application/json; charset=utf-8"} + ::yres/body (t/encode-str {:query query :error error} + {:type :json-verbose})} + (graph-console-response (console-context profile-id + :query query + :error error)))))))) + (defn import-handler [{:keys [::db/pool] :as cfg} {:keys [params ::session/profile-id] :as request}] (when-not (contains? params :file) @@ -626,7 +849,12 @@ (letfn [(handle-error [cause] (when-let [data (ex-data cause)] (when (= :validation (:type data)) - (str "Error: " (or (:hint data) (ex-message cause)) "\n"))))] + (let [hint (or (:hint data) (ex-message cause)) + explain (ex/explain data)] + (str "Error: " hint + (when (and explain (not (str/includes? hint explain))) + (str "\n" explain)) + "\n")))))] {:name ::errors :compile (fn [& _params] @@ -646,26 +874,51 @@ (assert (db/pool? (::db/pool params)) "expected a valid database pool") (assert (session/manager? (::session/manager params)) "expected a valid session manager")) +(defn- graph-action-routes + [cfg] + [["/graph-export" {:handler (partial graph-export-handler cfg)}] + ["/graph-load" {:handler (partial graph-load-handler cfg)}] + ["/graph-query" {:handler (partial graph-query-handler cfg)}] + ["/graph-unload" {:handler (partial graph-unload-handler cfg)}] + ["/graph-reload" {:handler (partial graph-reload-handler cfg)}] + ["/graph-sync-status" {:handler (partial graph-sync-status-handler cfg)}] + ["/graph-data" {:handler (partial graph-data-handler cfg)}] + ["/graph-files" {:handler (partial graph-files-handler cfg)}]]) + (defmethod ig/init-key ::routes [_ {:keys [::db/pool] :as cfg}] - [["/readyz" {:handler (partial health-handler cfg)}] - ["/dbg" {:middleware [[session/authz cfg] - [with-authorization pool]]} - ["" {:handler (partial index-handler cfg)}] - ["/health" {:handler (partial health-handler cfg)}] - ["/changelog" {:handler (partial changelog-handler cfg)}] - ["/error/:id" {:handler (partial error-handler cfg)}] - ["/error" {:handler (partial error-list-handler cfg)}] - ["/actions" {:middleware [[errors]]} - ["/set-virtual-clock" - {:handler (partial set-virtual-clock cfg)}] - ["/resend-email-verification" - {:handler (partial resend-email-notification cfg)}] - ["/handle-team-features" - {:handler (partial handle-team-features cfg)}] - ["/file-export" {:handler (partial export-handler cfg)}] - ["/file-import" {:handler (partial import-handler cfg)}] - ["/file-raw-export-import" {:handler (partial raw-export-import-handler cfg)}] - ["/file-validate" {:handler (partial validate-file cfg)}] - ["/file-repair" {:handler (partial repair-file cfg)}]]]]) + ;; The graph routes are registered only under the `:graph` flag. Left + ;; unregistered they 404, and nothing ever resolves `app.graph.*`. The `/dbg` + ;; admin gate is unchanged: it covers the graph routes exactly as before. + (let [graph? (contains? cf/flags :graph) + actions (cond-> ["/actions" {:middleware [[errors]]} + ["/set-virtual-clock" + {:handler (partial set-virtual-clock cfg)}] + ["/resend-email-verification" + {:handler (partial resend-email-notification cfg)}] + ["/handle-team-features" + {:handler (partial handle-team-features cfg)}] + ["/file-export" {:handler (partial export-handler cfg)}] + ["/file-import" {:handler (partial import-handler cfg)}] + ["/file-raw-export-import" {:handler (partial raw-export-import-handler cfg)}] + ["/file-validate" {:handler (partial validate-file cfg)}] + ["/file-repair" {:handler (partial repair-file cfg)}]] + graph? (into (graph-action-routes cfg))) + dbg (cond-> ["/dbg" {:middleware [[session/authz cfg] + [with-authorization pool]]} + ["" {:handler (partial index-handler cfg)}] + ["/health" {:handler (partial health-handler cfg)}] + ["/changelog" {:handler (partial changelog-handler cfg)}] + ["/error/:id" {:handler (partial error-handler cfg)}] + ["/error" {:handler (partial error-list-handler cfg)}] + actions] + graph? (conj ["/graph" {:handler (partial graph-console-handler cfg)}]))] + (when graph? + ;; With the flag on, the Ladybug native library belongs to this process, + ;; so load it here. A missing or unusable library then fails the boot + ;; instead of the first console request. + (require 'app.graph.debug 'app.graph.ingest)) + + [["/readyz" {:handler (partial health-handler cfg)}] + dbg])) diff --git a/backend/src/app/main.clj b/backend/src/app/main.clj index f1aadd0a2d..b75a3ee5b3 100644 --- a/backend/src/app/main.clj +++ b/backend/src/app/main.clj @@ -289,6 +289,7 @@ ::http.debug/routes {::db/pool (ig/ref ::db/pool) ::session/manager (ig/ref ::session/manager) + ::mbus/msgbus (ig/ref ::mbus/msgbus) ::sto/storage (ig/ref ::sto/storage) ::setup/props (ig/ref ::setup/props)} diff --git a/backend/src/app/srepl/main.clj b/backend/src/app/srepl/main.clj index c174f29f7a..4014ad8dec 100644 --- a/backend/src/app/srepl/main.clj +++ b/backend/src/app/srepl/main.clj @@ -398,6 +398,53 @@ (println (sm/humanize-explain explain)) (ex/print-throwable cause)))))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; GRAPH / LADYBUG +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The graph namespaces resolve at call time, never at the top of this +;; namespace. `app.graph.ladybug` imports `com.ladybugdb.*`, and this namespace +;; loads with the REPL server on every boot, so a top-level require would link +;; the Ladybug native library into every backend, graph or not. Calling one of +;; the functions below loads the library at that point: the operator has asked +;; for it explicitly. The `:graph` flag gates the request path +;; (`app.http.debug`), not the REPL. + +(defn graph-smoke-test! + "Execute a basic Ladybug smoke test (CREATE + count). + + Uses the embedded Ladybug Java API. Use :db-path \":memory:\" (default) + or a filesystem path such as /tmp/test.lbug." + [& {:keys [db-path] :or {db-path ":memory:"}}] + ((requiring-resolve 'app.graph.ladybug/smoke-test!) :db-path db-path)) + +(defn graph-query-test! + "Query Document count for a file's graph db (REPL diagnostic)." + [file-id & {:keys [db-path]}] + (let [file-id (h/parse-uuid file-id) + db-path (or db-path ((requiring-resolve 'app.graph.ladybug/db-path-for-file) file-id)) + query-scalar! (requiring-resolve 'app.graph.ladybug/query-scalar!) + stmt "MATCH (n:Document) RETURN count(n) AS Document_c;"] + (query-scalar! db-path stmt))) + +(defn ingest-file-to-graph! + "Project a Penpot file into a per-file Ladybug database. + + Loads and realizes the file from the database, ensures the slice schema, + projects Document/Page/shape nodes, and returns graph stats. + + Options: + - `:db-path` path or `:memory:` + - `:reset-db?` delete any existing db first (default true) + - `:skip-stats?` skip post-ingest MATCH count queries (default false)" + [file-id & opts] + (let [ingest-file! (requiring-resolve 'app.graph.ingest/ingest-file!) + print-ingest! (requiring-resolve 'app.graph.report/print-ingest!) + result (apply ingest-file! sys/system file-id opts)] + (print-ingest! result) + result)) + + (defn repair-file! "Repair the list of errors detected by validation." [file-id & {:keys [rollback?] :or {rollback? true} :as options}] diff --git a/backend/test/backend_tests/graph_binder_gate_test.clj b/backend/test/backend_tests/graph_binder_gate_test.clj new file mode 100644 index 0000000000..508bf9d60d --- /dev/null +++ b/backend/test/backend_tests/graph_binder_gate_test.clj @@ -0,0 +1,165 @@ +;; 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 Sucursal en España SL + +(ns backend-tests.graph-binder-gate-test + "Binder gate for the incremental-sync statement templates. + + Every template `app.graph.sync` emits is *prepared* — parsed and bound by + the engine against the live DDL — and never executed. A parse or bind + failure (a renamed column, a reserved-word label emitted unquoted, a dropped + table) turns the gate red here, before the statement can reach a live + session. + + One instance per template is the gate; per-column type coverage belongs to + beadpot's schema diff, not here. The templates are `defn-`, so they are + reached through their vars." + (:require + [app.graph.ladybug :as ladybug] + [app.graph.schema.nodes :as nodes] + [app.graph.sync] + [clojure.test :as t])) + +(def ^:private create-node-statement #'app.graph.sync/create-node-statement) +(def ^:private delete-node-statement #'app.graph.sync/delete-node-statement) +(def ^:private create-edge-statement #'app.graph.sync/create-edge-statement) +(def ^:private delete-edge-statement #'app.graph.sync/delete-edge-statement) +(def ^:private set-edge-position-statement #'app.graph.sync/set-edge-position-statement) +(def ^:private create-instance-of-statement #'app.graph.sync/create-instance-of-statement) +(def ^:private delete-instance-of-statement #'app.graph.sync/delete-instance-of-statement) +(def ^:private set-node-attr-statement #'app.graph.sync/set-node-attr-statement) +(def ^:private set-page-name-statement #'app.graph.sync/set-page-name-statement) +(def ^:private remove-node-attr-statement #'app.graph.sync/remove-node-attr-statement) +(def ^:private set-document-revision-statement #'app.graph.sync/set-document-revision-statement) + +;; Dummy identities. Fixed rather than generated: a gate failure should read +;; the same on every run. +(def ^:private doc-id #uuid "00000000-0000-0000-0000-0000000000d0") +(def ^:private page-id #uuid "00000000-0000-0000-0000-0000000000a0") +(def ^:private shape-id #uuid "00000000-0000-0000-0000-0000000000b0") +(def ^:private frame-id #uuid "00000000-0000-0000-0000-0000000000c0") +(def ^:private component-id #uuid "00000000-0000-0000-0000-0000000000e0") + +(def ^:private child-edge + {:from-table "Rectangle" :from-id shape-id + :to-table "Page" :to-id page-id + :position 3}) + +(def ^:private ^:dynamic *conn* nil) + +(defn- with-graph-connection + "Open a `:memory:` database, create the live schema, run the tests on it. + + Nothing is executed against it — the gate only prepares — but the DDL has to + be there for the binder to resolve tables and columns against." + [next] + (ladybug/with-connection! ":memory:" + (fn [conn] + (ladybug/exec-on-connection! conn (nodes/ddl-statements)) + (binding [*conn* conn] + (next))))) + +(t/use-fixtures :once with-graph-connection) + +(defn- gate + "Assert `statement` binds, and that the engine agrees on read/write." + [label statement read-only?] + (let [result (ladybug/validate-on-connection! *conn* statement)] + (t/is (:ok? result) + (str label " does not bind: " (:error result) "\n " statement)) + (when (:ok? result) + (t/is (= read-only? (:read-only? result)) + (str label " read-only? " (:read-only? result) ", expected " read-only?))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; the eleven sync templates +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(t/deftest create-node-binds + (gate "create-node-statement" + (create-node-statement "Rectangle" {:id shape-id + :name "a shape" + :opacity 1.0 + :hidden false}) + false)) + +(t/deftest delete-node-binds + (gate "delete-node-statement" + (delete-node-statement "Rectangle" shape-id) + false)) + +(t/deftest create-edge-binds + (gate "create-edge-statement" + (create-edge-statement child-edge) + false)) + +(t/deftest delete-edge-binds + (gate "delete-edge-statement" + (delete-edge-statement (dissoc child-edge :position)) + false)) + +(t/deftest set-edge-position-binds + (gate "set-edge-position-statement" + (set-edge-position-statement child-edge) + false)) + +(t/deftest create-instance-of-binds + (gate "create-instance-of-statement" + (create-instance-of-statement frame-id component-id) + false)) + +(t/deftest delete-instance-of-binds + (gate "delete-instance-of-statement" + (delete-instance-of-statement frame-id) + false)) + +(t/deftest set-node-attr-binds + (gate "set-node-attr-statement" + (set-node-attr-statement "Rectangle" shape-id :name "a shape") + false)) + +(t/deftest set-page-name-binds + (gate "set-page-name-statement" + (set-page-name-statement page-id "a page") + false)) + +(t/deftest remove-node-attr-binds + (gate "remove-node-attr-statement" + (remove-node-attr-statement "Rectangle" shape-id :name) + false)) + +(t/deftest set-document-revision-binds + (gate "set-document-revision-statement" + (set-document-revision-statement doc-id 42) + false)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; label quoting across the registry +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(t/deftest every-node-label-binds + ;; `Group` and `Boolean` are reserved words: unquoted they do not parse. + ;; One MATCH per registered table is the cheapest way to keep `match-label` + ;; honest as tables come and go. + (doseq [table (map :table nodes/node-types)] + (gate (str "delete-node-statement on " table) + (delete-node-statement table shape-id) + false))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; the gate itself +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(t/deftest read-only-discriminates + ;; Without this the `read-only? false` assertions above would hold for a + ;; `validate-on-connection!` that always answered false. + (gate "a read query" "MATCH (n:Rectangle) RETURN count(n);" true)) + +(t/deftest bad-statement-is-reported-not-thrown + (let [result (ladybug/validate-on-connection! + *conn* "MATCH (n:Rectangle) SET n.no_such_column = 1;")] + (t/is (false? (:ok? result))) + (t/is (string? (:error result))) + (t/is (nil? (:read-only? result))))) diff --git a/backend/test/backend_tests/graph_sync_parity_test.clj b/backend/test/backend_tests/graph_sync_parity_test.clj new file mode 100644 index 0000000000..c7eff4c34e --- /dev/null +++ b/backend/test/backend_tests/graph_sync_parity_test.clj @@ -0,0 +1,280 @@ +;; 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 Sucursal en España SL + +(ns backend-tests.graph-sync-parity-test + "Cold projection and incremental sync are two implementations of one mapping, + and this namespace holds them to it. + + `app.graph.projection.document/projection-data` reads a whole file and produces + the whole graph. `app.graph.sync/apply-changes!` takes the change vocabulary + the editor emits and mutates an already open graph. A graph the second one + maintained must equal a graph the first one would build from the same file, + or the console shows a graph no rebuild reproduces. + + The round trip: project a file cold into A, apply a change list to A and the + same list to the file data, project the resulting data cold into B, and diff + A against B. Two `:memory:` databases, no Postgres, no session." + (:require + [app.common.features :as ffeat] + [app.common.files.changes :as cfc] + [app.common.time :as ct] + [app.common.types.file :as ctf] + [app.common.types.shape :as cts] + [app.common.uuid :as uuid] + [app.graph.arrow :as arrow] + [app.graph.ladybug :as ladybug] + [app.graph.projection.document :as projection.document] + [app.graph.projection.transforms :as projection.transforms] + [app.graph.schema.nodes :as nodes] + [app.graph.sync :as sync] + [clojure.test :as t])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; the fixture file +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Fixed ids: a failure should read the same on every run. +(def ^:private file-id #uuid "00000000-0000-0000-0000-00000000f11e") +(def ^:private page-id #uuid "00000000-0000-0000-0000-0000000000a1") +(def ^:private page2-id #uuid "00000000-0000-0000-0000-0000000000a2") +(def ^:private frame-id #uuid "00000000-0000-0000-0000-0000000000f1") +(def ^:private rect-id #uuid "00000000-0000-0000-0000-0000000000b1") +(def ^:private circ-id #uuid "00000000-0000-0000-0000-0000000000b2") +(def ^:private text-id #uuid "00000000-0000-0000-0000-0000000000b3") +(def ^:private rect2-id #uuid "00000000-0000-0000-0000-0000000000b4") + +(def ^:private base-revn 1) + +(defn- file-row + "The `file` map the projection reads, as `bfc/get-file` returns it minus the + data blob." + [revn] + {:id file-id + :name "graph sync parity fixture" + :revn revn + :version 70 + :features #{"components/v2"} + :created-at (ct/inst "2026-01-01T00:00:00Z") + :modified-at (ct/inst "2026-01-02T00:00:00Z")}) + +(defn- base-data + [] + (binding [ffeat/*current* #{"components/v2"}] + (ctf/make-file-data file-id page-id))) + +(defn- shape + [id type attrs] + (cts/setup-shape (merge {:id id + :type type + :frame-id uuid/zero + :parent-id uuid/zero} + attrs))) + +(def ^:private changes + "One change of every kind the sync path claims to support that this fixture + can exercise, in the order an editing session would emit them. + + Four siblings in one container, then a reorder, a reparent, and a delete: + sibling order is where the two paths are easiest to get wrong, because the + stored `:shapes` list and `IsChildOf.position` run opposite ways." + [{:type :add-obj :page-id page-id :id frame-id + :parent-id uuid/zero :frame-id uuid/zero + :obj (shape frame-id :frame {:name "Board" :width 400 :height 300})} + + {:type :add-obj :page-id page-id :id rect-id + :parent-id frame-id :frame-id frame-id + :obj (shape rect-id :rect {:name "Rect" :parent-id frame-id :frame-id frame-id + :width 100 :height 50})} + + {:type :add-obj :page-id page-id :id circ-id + :parent-id frame-id :frame-id frame-id + :obj (shape circ-id :circle {:name "Circle" :parent-id frame-id :frame-id frame-id + :width 40 :height 40})} + + {:type :add-obj :page-id page-id :id text-id + :parent-id frame-id :frame-id frame-id + :obj (shape text-id :text {:name "Label" :parent-id frame-id :frame-id frame-id})} + + {:type :add-obj :page-id page-id :id rect2-id + :parent-id frame-id :frame-id frame-id + :obj (shape rect2-id :rect {:name "Rect two" :parent-id frame-id :frame-id frame-id + :width 20 :height 20})} + + ;; A rename, and two attributes whose values are falsy: `blocked false` and + ;; `opacity 0` are values, not absences, on both paths. + {:type :mod-obj :page-id page-id :id rect-id + :operations [{:type :set :attr :name :val "Renamed rect"} + {:type :set :attr :blocked :val false} + {:type :set :attr :opacity :val 0}]} + + ;; Reorder inside the same container: the edge keeps its endpoints and + ;; every sibling it passes has to move. + {:type :mov-objects :page-id page-id :parent-id frame-id :index 0 :shapes [circ-id]} + + ;; Reparent to the page's root frame: the edge moves, and so do the + ;; shape's own `parent_id` and `frame_id`. + {:type :mov-objects :page-id page-id :parent-id uuid/zero :index 0 :shapes [text-id]} + + ;; Delete with survivors: the gap in the sibling numbering has to close. + {:type :del-obj :page-id page-id :id rect-id} + + {:type :add-page :id page2-id :name "Page two"} + {:type :mod-page :id page-id :name "Page one, renamed"}]) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; projecting and reading back +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- load-graph! + "Create the schema on `conn`, project `data` into it, run the transforms. + + Returns the projection, which is also what the sync index is built from." + [conn data file] + (let [projection (projection.document/projection-data data file)] + (ladybug/exec-on-connection! conn (nodes/ddl-statements)) + (arrow/with-allocator! + (fn [allocator] (arrow/load-projection! conn projection allocator))) + (projection.transforms/apply-transforms! nil conn data file) + projection)) + +(defn- rel-tables + [conn] + (mapv first (:rows (ladybug/query-on-connection! + conn "CALL show_tables() WHERE type = 'REL' RETURN name;" + :max-rows 1000)))) + +(defn- rel-properties + "Property names on rel table `rel`, in catalog order." + [conn rel] + (mapv (comp str second) + (:rows (ladybug/query-on-connection! + conn (str "CALL table_info('" rel "') RETURN *;") + :max-rows 1000)))) + +(defn- node-rows + [conn table] + (:rows (ladybug/query-on-connection! + conn (str "MATCH (n:" (nodes/match-label table) ") RETURN n.* ORDER BY n.id;") + :max-rows 100000))) + +(defn- edge-rows + [conn rel props] + (let [returns (into ["a.id" "b.id"] (map #(str "r.`" % "`")) props)] + (:rows (ladybug/query-on-connection! + conn (str "MATCH (a)-[r:`" rel "`]->(b) " + "RETURN " (clojure.string/join ", " returns) " " + "ORDER BY a.id, b.id;") + :max-rows 100000)))) + +(defn- keyed-rows + "Rows as `{key {column value}}`, so a difference names a row and a column. + + Values are stringified: both connections hand a value back through the same + reader, so any difference in the strings is a difference in the graph." + [columns key-columns rows] + (into {} + (map (fn [row] + (let [cells (zipmap columns (map str row))] + [(mapv cells key-columns) cells]))) + rows)) + +(defn- snapshot + "Every node row and every edge row in the database, keyed by table." + [conn] + {:nodes (into {} + (map (fn [{:keys [table]}] + (let [columns (nodes/columns table)] + [table (keyed-rows columns ["id"] (node-rows conn table))]))) + nodes/node-types) + :edges (into {} + (map (fn [rel] + (let [columns (into ["from" "to"] (rel-properties conn rel))] + [rel (keyed-rows columns ["from" "to"] + (edge-rows conn rel (rel-properties conn rel)))]))) + (rel-tables conn))}) + +(defn- row-diff + [rows-a rows-b] + (into {} + (for [k (sort (into #{} (concat (keys rows-a) (keys rows-b)))) + :let [a (get rows-a k) + b (get rows-b k)] + :when (not= a b)] + [k (cond + (nil? a) {:only-in :rebuilt} + (nil? b) {:only-in :synced} + :else (into {} + (for [c (sort (into #{} (concat (keys a) (keys b)))) + :when (not= (get a c) (get b c))] + [c {:synced (get a c) :rebuilt (get b c)}])))]))) + +(defn- diff + "Where the two snapshots disagree, down to the row and the column." + [a b] + (into {} + (for [kind [:nodes :edges] + table (sort (into #{} (concat (keys (get a kind)) (keys (get b kind))))) + :let [d (row-diff (get-in a [kind table]) (get-in b [kind table]))] + :when (seq d)] + [[kind table] d]))) + +(defn- with-two-connections + [f] + (ladybug/with-connection! ":memory:" + (fn [conn-a] + (ladybug/with-connection! ":memory:" + (fn [conn-b] + (f conn-a conn-b)))))) + +(defn- round-trip + "Sync `change-list` into A, rebuild the same file into B, return the diff." + [change-list] + (let [data0 (base-data) + data1 (cfc/process-changes data0 change-list) + revn1 (inc base-revn)] + (with-two-connections + (fn [conn-a conn-b] + (let [projection (load-graph! conn-a data0 (file-row base-revn)) + index (sync/build-index file-id base-revn projection) + result (sync/apply-changes! conn-a index change-list revn1)] + (load-graph! conn-b data1 (file-row revn1)) + {:diff (diff (snapshot conn-a) (snapshot conn-b)) + :applied (:applied result) + :skipped (:skipped result)}))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; the tests +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(t/deftest every-change-in-the-list-is-supported + (let [{:keys [applied skipped]} (round-trip changes)] + (t/is (empty? skipped) + (str "the fixture must exercise the sync path, not the skip path: " (pr-str skipped))) + (t/is (= (count changes) (count applied))))) + +(t/deftest synced-graph-equals-rebuilt-graph + (let [{:keys [diff]} (round-trip changes)] + (t/is (empty? diff) + (str "cold projection and sync replay disagree on " + (pr-str (keys diff)) "\n" (pr-str diff))))) + +(t/deftest the-diff-catches-an-injected-sync-bug + ;; The round trip is only worth running if it fails when sync is wrong. + ;; `apply-mov-objects` maintains `IsChildOf`; drop the change from the list + ;; sync sees, keep it in the list the file sees, and the edge must differ. + (let [data0 (base-data) + data1 (cfc/process-changes data0 changes) + crippled (remove #(= :mov-objects (:type %)) changes) + revn1 (inc base-revn) + result (with-two-connections + (fn [conn-a conn-b] + (let [projection (load-graph! conn-a data0 (file-row base-revn)) + index (sync/build-index file-id base-revn projection)] + (sync/apply-changes! conn-a index crippled revn1) + (load-graph! conn-b data1 (file-row revn1)) + (diff (snapshot conn-a) (snapshot conn-b)))))] + (t/is (contains? result [:edges "IsChildOf"]) + "a sync that skips a reparent must show up as an IsChildOf difference"))) diff --git a/common/src/app/common/flags.cljc b/common/src/app/common/flags.cljc index 376a26df4f..7ef1c0c6df 100644 --- a/common/src/app/common/flags.cljc +++ b/common/src/app/common/flags.cljc @@ -100,6 +100,10 @@ :backend-svgo ;; If enabled, it makes the Google Fonts available. :google-fonts-provider + ;; Enables the Ladybug graph subsystem: the `/dbg` graph console and its + ;; actions. Off by default. With the flag off, `app.graph.*` never loads, + ;; so the Ladybug native library never enters the JVM. + :graph ;; Only for development. :nrepl-server ;; Interactive repl. Only for development.