wip: Add rxjs-spy library to monitor RX streams

This issue is started to happening because of an unrelated change
on frame-shape react component where shapes are looked up directly
on objects having in supposition that objects will be exists but on
viewer there are two objects: fixed and not-fixed, and in some cases
objects map can be empty or don't contain the object.

For solve the issue, we just filter not existing objects before
progragate the children down to the inner react components, avoiding
the exception when an object appears as `nil`.

.circleci/config.yml

@@ -34,7 +34,7 @@ jobs:
           working_directory: "./frontend"
           command: |
             yarn install
-            yarn run lint-scss
+            yarn run lint:scss
 
       - run:
           name: common lint

.clj-kondo/config.edn

@@ -6,7 +6,6 @@
   rumext.v2/defc clojure.core/defn
   rumext.v2/fnc clojure.core/fn
   app.common.data/export clojure.core/def
-  app.db/with-atomic clojure.core/with-open
   app.common.data.macros/get-in clojure.core/get-in
   app.common.data.macros/with-open clojure.core/with-open
   app.common.data.macros/select-keys clojure.core/select-keys
@@ -17,6 +16,9 @@
   {app.common.data.macros/export hooks.export/export
    potok.core/reify hooks.export/potok-reify
    app.util.services/defmethod hooks.export/service-defmethod
+   app.common.record/defrecord hooks.export/penpot-defrecord
+   app.db/with-atomic hooks.export/penpot-with-atomic
+   rumext.v2/fnc hooks.export/rumext-fnc
    }}
 
  :output

.clj-kondo/hooks/export.clj

@@ -39,6 +39,60 @@
                          other))]
       {:node result})))
 
+(defn penpot-with-atomic
+  [{:keys [node]}]
+  (let [[params & body] (rest (:children node))]
+    (if (api/vector-node? params)
+      (let [[sym val opts] (:children params)]
+        (when-not (and sym val)
+          (throw (ex-info "No sym and val provided" {})))
+        {:node (api/list-node
+                (list*
+                 (api/token-node 'let)
+                 (api/vector-node [sym val])
+                 opts
+                 body))})
+
+      {:node (api/list-node
+              (into [(api/token-node 'let)
+                     (api/vector-node [params params])]
+                    body))})))
+
+(defn rumext-fnc
+  [{:keys [node]}]
+  (let [[cname mdata params & body] (rest (:children node))
+        [params body] (if (api/vector-node? mdata)
+                        [mdata (cons params body)]
+                        [params body])]
+    (let [result (api/list-node
+                  (into [(api/token-node 'fn)
+                         params]
+                        (cons mdata body)))]
+      {:node result})))
+
+
+(defn penpot-defrecord
+  [{:keys [:node]}]
+  (let [[rnode rtype rparams & other] (:children node)
+
+        nodes [(api/token-node (symbol "do"))
+               (api/list-node
+                (into [(api/token-node (symbol (name (:value rnode)))) rtype rparams] other))
+               (api/list-node
+                [(api/token-node (symbol "defn"))
+                 (api/token-node (symbol (str "pos->" (:string-value rtype))))
+                 (api/vector-node
+                  (->> (:children rparams)
+                       (mapv (fn [t]
+                               (api/token-node (symbol (str "_" (:string-value t))))))))
+                 (api/token-node nil)])]
+
+        result (api/list-node nodes)]
+
+    ;; (prn "=====>" (into {} rparams))
+    ;; (prn (api/sexpr result))
+    {:node result}))
+
 (defn clojure-specify
   [{:keys [:node]}]
   (let [[rnode rtype & other] (:children node)
@@ -48,7 +102,6 @@
                        other))]
     {:node result}))
 
-
 (defn service-defmethod
   [{:keys [:node]}]
   (let [[rnode rtype ?meta & other] (:children node)

.editorconfig

@@ -0,0 +1,13 @@
+root = true
+
+[*.{cljs,cljc,clj,js,css,scss,html,yml,yaml,json,mustache}]
+charset = utf-8
+
+indent_size = 2
+indent_style = space
+
+end_of_line = lf
+
+insert_final_newline = true
+
+trim_trailing_whitespace = true

.gitignore

@@ -2,6 +2,7 @@
 *.jar
 *.orig
 *.penpot
+*.css.json
 .calva
 .clj-kondo
 .cpcache

.vscode/settings.json

@@ -0,0 +1,9 @@
+{
+    "files.exclude": {
+        "**/.clj-kondo": true,
+        "**/.cpcache": true,
+        "**/.lsp": true,
+        "**/.shadow-cljs": true,
+        "**/node_modules": true
+    }
+}

CHANGES.md

@@ -1,23 +1,175 @@
 # CHANGELOG
 
-## :rocket: 1.19.0
+## 1.20.0
 
 ### :boom: Breaking changes & Deprecations
 
 ### :sparkles: New features
-- Default naming of text layers [Taiga #2836](https://tree.taiga.io/project/penpot/us/2836)
-- Create typography style from a selected text layer[Taiga #3041](https://tree.taiga.io/project/penpot/us/3041)
-- Board as ruler origin [Taiga #4833](https://tree.taiga.io/project/penpot/us/4833)
-- Access tokens support [Taiga #4460](https://tree.taiga.io/project/penpot/us/4460)
-- Show interactions setting at the view mode [Taiga #1330](https://tree.taiga.io/project/penpot/issue/1330)
+
+- Select through stroke only rectangle [Taiga #5484](https://tree.taiga.io/project/penpot/issue/5484)
 
 ### :bug: Bugs fixed
-- Fix files can be opened from multiple urls [Taiga #5310](https://tree.taiga.io/project/penpot/issue/5310)
-- Fix asset color item was created from the selected layer [Taiga #5180](https://tree.taiga.io/project/penpot/issue/5180)
 
 ### :arrow_up: Deps updates
 
 ### :heart: Community contributions by (Thank you!)
+
+## 1.19.4
+
+### :sparkles: New features
+
+- Improve selected colors [Taiga #5805]( https://tree.taiga.io/project/penpot/us/5805)
+
+### :bug: Bugs fixed
+
+- Fix problem with z-index field in non-absolute items
+
+## 1.19.3
+
+### :sparkles: New features
+
+- Remember last color mode in colorpicker [Taiga #5508](https://tree.taiga.io/project/penpot/issue/5508)
+- Improve layers multiselection behaviour [Github #5741](https://github.com/penpot/penpot/issues/5741)
+- Remember last active team across logouts / sessions [Github #3325](https://github.com/penpot/penpot/issues/3325)
+
+### :bug: Bugs fixed
+
+- List view is discarded on tab change on Workspace Assets Sidebar tab [Github #3547](https://github.com/penpot/penpot/issues/3547)
+- Fix message popup remains open when exiting workspace with browser back button [Taiga #5747](https://tree.taiga.io/project/penpot/issue/5747)
+- When editing text if font is changed, the proportions of the rendered shape are wrong [Taiga #5786](https://tree.taiga.io/project/penpot/issue/5786)
+
+## 1.19.2
+
+### :sparkles: New features
+
+- Navigate up in layer hierarchy with Shift+Enter shortcut [Taiga #5734](https://tree.taiga.io/project/penpot/us/5734)
+- Click on the flow tags open viewer with the selected frame [Taiga #5044](https://tree.taiga.io/project/penpot/us/5044)
+- Add Dutch language & update translation files with weblate
+
+### :bug: Bugs fixed
+
+- Fix unexpected output on get-page rpc method when invalid object-id is provided [Github #3546](https://github.com/penpot/penpot/issues/3546)
+- Fix Invalid files amount after moving file from Project to Drafts [Taiga #5638](https://tree.taiga.io/project/penpot/us/5638)
+- Fix deleted pages comments shown in right sidebar [Taiga #5648](https://tree.taiga.io/project/penpot/us/5648)
+- Fix tooltip on toggle visibility and toggle lock buttons [Taiga #5141](https://tree.taiga.io/project/penpot/issue/5141)
+
+
+## 1.19.1
+
+### :bug: Bugs fixed
+
+- Fix components not registered as updated [Taiga #5725](https://tree.taiga.io/project/penpot/issue/5725)
+
+## 1.19.0
+
+### :boom: Breaking changes & Deprecations
+
+### :sparkles: New features
+
+- Default naming of text layers [Taiga #2836](https://tree.taiga.io/project/penpot/us/2836)
+- Create typography style from a selected text layer [Taiga #3041](https://tree.taiga.io/project/penpot/us/3041)
+- Board as ruler origin [Taiga #4833](https://tree.taiga.io/project/penpot/us/4833)
+- Access tokens support [Taiga #4460](https://tree.taiga.io/project/penpot/us/4460)
+- Show interactions setting at the view mode [Taiga #1330](https://tree.taiga.io/project/penpot/issue/1330)
+- Improve dashboard performance related to thumbnails; now the thumbnails are
+  rendered as bitmap images.
+- Add the ability to disable google fonts provider with the `disable-google-fonts-provider` flag
+- Add the ability to disable dashboard templates section with the `disable-dashboard-templates-section` flag
+- Add the ability to use the registration whitelist with OICD [Github #3348](https://github.com/penpot/penpot/issues/3348)
+- Add support for local caching of google fonts (this avoids exposing the final user IP to
+  goolge and reduces the amount of request sent to google)
+- Set smooth/instant autoscroll depending on distance [GitHub #3377](https://github.com/penpot/penpot/issues/3377)
+- New component icon [Taiga #5290](https://tree.taiga.io/project/penpot/us/5290)
+- Show a confirmation dialog when an user tries to publish an empty library [Taiga #5294](https://tree.taiga.io/project/penpot/us/5294)
+
+### :bug: Bugs fixed
+
+- Fix files can be opened from multiple urls [Taiga #5310](https://tree.taiga.io/project/penpot/issue/5310)
+- Fix asset color item was created from the selected layer [Taiga #5180](https://tree.taiga.io/project/penpot/issue/5180)
+- Fix unpublish more than one library at the same time [Taiga #5532](https://tree.taiga.io/project/penpot/issue/5532)
+- Fix drag projects on dahsboard [Taiga #5531](https://tree.taiga.io/project/penpot/issue/5531)
+- Fix allow team name to be all blank [Taiga #5527](https://tree.taiga.io/project/penpot/issue/5527)
+- Fix search font visualitation [Taiga #5523](https://tree.taiga.io/project/penpot/issue/5523)
+- Fix create and account only with spaces [Taiga #5518](https://tree.taiga.io/project/penpot/issue/5518)
+- Fix context menu outside screen [Taiga #5524](https://tree.taiga.io/project/penpot/issue/5524)
+- Fix graphic item rename on assets pannel [Taiga #5556](https://tree.taiga.io/project/penpot/issue/5556)
+- Fix component and media name validation on assets panel [Taiga #5555](https://tree.taiga.io/project/penpot/issue/5555)
+- Fix problem with selection shortcuts [Taiga #5492](https://tree.taiga.io/project/penpot/issue/5492)
+- Fix issue with paths line to curve and concurrent editing [Taiga #5191](https://tree.taiga.io/project/penpot/issue/5191)
+- Fix problems with locked layers [Taiga #5139](https://tree.taiga.io/project/penpot/issue/5139)
+- Fix export from shared prototype [Taiga #5565](https://tree.taiga.io/project/penpot/issue/5565)
+- Fix email change: validation error displaying even after both fields are identical [Taiga #5514](https://tree.taiga.io/project/penpot/issue/5514)
+- Fix scroll on viewer comment list [Taiga #5563](https://tree.taiga.io/project/penpot/issue/5563)
+- Fix context menu z-index [Taiga #5561](https://tree.taiga.io/project/penpot/issue/5561)
+- Fix select all checkbox on shared link config [Taiga #5566](https://tree.taiga.io/project/penpot/issue/5566)
+- Fix validation on full name input on account creation [Taiga #5516](https://tree.taiga.io/project/penpot/issue/5516)
+- Fix validation on team name input [Taiga #5510](https://tree.taiga.io/project/penpot/issue/5510)
+- Fix incorrect uri generation issues on share-link modal [Taiga #5564](https://tree.taiga.io/project/penpot/issue/5564)
+- Fix cache issues with share-links [Taiga #5559](https://tree.taiga.io/project/penpot/issue/5559)
+- Makes height priority for the rows/columns grids [#2774](https://github.com/penpot/penpot/issues/2774)
+- Fix problem with comments mode not staying [#3363](https://github.com/penpot/penpot/issues/3363)
+- Fix problem with comments when user left the team [Taiga #5562](https://tree.taiga.io/project/penpot/issue/5562)
+- Fix problem with images patterns repeating [#3372](https://github.com/penpot/penpot/issues/3372)
+- Fix grid not being clipped in frames [#3365](https://github.com/penpot/penpot/issues/3365)
+- Fix cut/delete text layer when while creating text [Taiga #5602](https://tree.taiga.io/project/penpot/issue/5602)
+- Fix picking a gradient color in recent colors for a new color in the assets tab [Taiga #5601](https://tree.taiga.io/project/penpot/issue/5601)
+- Fix problem with importation process [Taiga #5597](https://tree.taiga.io/project/penpot/issue/5597)
+- Fix problem with HSV color picker [#3317](https://github.com/penpot/penpot/issues/3317)
+- Fix problem with slashes in layers names for exporter [#3276](https://github.com/penpot/penpot/issues/3276)
+- Fix incorrect modified data on moving files on dashboard [Taiga #5530](https://tree.taiga.io/project/penpot/issue/5530)
+- Fix focus handling on comments edition [Taiga #5560](https://tree.taiga.io/project/penpot/issue/5560)
+- Fix incorrect fullname use on registring user after OIDC authentication [Taiga #5517](https://tree.taiga.io/project/penpot/issue/5517)
+- Fix incorrect modified-at on project after import file [Taiga #5268](https://tree.taiga.io/project/penpot/issue/5268)
+- Fix incorrect message after sending invitation to already member [Taiga 5599](https://tree.taiga.io/project/penpot/issue/5599)
+- Fix text decoration on button [Taiga #5301](https://tree.taiga.io/project/penpot/issue/5301)
+- Fix menu order on design tab [Taiga #5195](https://tree.taiga.io/project/penpot/issue/5195)
+- Fix search bar width on layer tab [Taiga #5445](https://tree.taiga.io/project/penpot/issue/5445)
+- Fix border radius values with decimals [Taiga #5283](https://tree.taiga.io/project/penpot/issue/5283)
+- Fix shortcuts translations not homogenized [Taiga #5141](https://tree.taiga.io/project/penpot/issue/5141)
+- Fix overlay manual position in nested boards [Taiga #5135](https://tree.taiga.io/project/penpot/issue/5135)
+- Fix close overlay from a nested board [Taiga #5587](https://tree.taiga.io/project/penpot/issue/5587)
+- Fix overlay position when it has shadow or blur [Taiga #4752](https://tree.taiga.io/project/penpot/issue/4752)
+- Fix overlay position when there are elements fixed when scrolling [Taiga #4383](https://tree.taiga.io/project/penpot/issue/4383)
+- Fix problem when sliding color picker in selected-colors [#3150](https://github.com/penpot/penpot/issues/3150)
+- Fix error screen on upload image error [Taiga #5608](https://tree.taiga.io/project/penpot/issue/5608)
+- Fix bad frame-id for certain componentes [#3205](https://github.com/penpot/penpot/issues/3205)
+- Fix paste elements at bottom of frame [Taig #5253](https://tree.taiga.io/project/penpot/issue/5253)
+- Fix new-file button on project not redirecting to the new file [Taiga #5610](https://tree.taiga.io/project/penpot/issue/5610)
+- Fix retrieve user comments in dashboard [Taiga #5607](https://tree.taiga.io/project/penpot/issue/5607)
+- Locks shapes when moved inside a locked parent [Taiga #5252](https://tree.taiga.io/project/penpot/issue/5252)
+- Fix rotate several elements in bulk [Taiga #5165](https://tree.taiga.io/project/penpot/issue/5165)
+- Fix onboarding slides height [Taiga #5373](https://tree.taiga.io/project/penpot/issue/5373)
+- Fix create typography with section closed [Taiga #5574](https://tree.taiga.io/project/penpot/issue/5574)
+- Fix exports menu on viewer mode [Taiga #5568](https://tree.taiga.io/project/penpot/issue/5568)
+- Fix create empty comments [Taiga #5536](https://tree.taiga.io/project/penpot/issue/5536)
+- Fix text changes not propagated to copy [Taiga #5364](https://tree.taiga.io/project/penpot/issue/5364)
+- Fix position of text cursor is a bit too high in Invitations section [Taiga #5511](https://tree.taiga.io/project/penpot/issue/5511)
+- Fix undo when updating several texts [Taiga #5197](https://tree.taiga.io/project/penpot/issue/5197)
+- Fix assets right click button for multiple selection [Taiga #5545](https://tree.taiga.io/project/penpot/issue/5545)
+- Fix problem with precision in resizes [Taiga #5623](https://tree.taiga.io/project/penpot/issue/5623)
+- Fix absolute positioned layouts not showing flex properties [Taiga #5630](https://tree.taiga.io/project/penpot/issue/5630)
+- Fix text gradient handlers [Taiga #4047](https://tree.taiga.io/project/penpot/issue/4047)
+- Fix when user deletes one file during import it is impossible to finish importing of second file [Taiga #5656](https://tree.taiga.io/project/penpot/issue/5656)
+- Fix export multiple images when only one of them has export settings [Taiga #5649](https://tree.taiga.io/project/penpot/issue/5649)
+- Fix error when a user different than the thread creator edits a comment [Taiga #5647](https://tree.taiga.io/project/penpot/issue/5647)
+- Fix unnecessary button [Taiga #3312](https://tree.taiga.io/project/penpot/issue/3312)
+- Fix copy color information in several formats [Taiga #4723](https://tree.taiga.io/project/penpot/issue/4723)
+- Fix dropdown width [Taiga #5541](https://tree.taiga.io/project/penpot/issue/5541)
+- Fix enable comment mode and insert image keeps on comment mode [Taiga #5678](https://tree.taiga.io/project/penpot/issue/5678)
+- Fix enable undo just after using pencil [Taiga #5674](https://tree.taiga.io/project/penpot/issue/5674)
+- Fix 400 error when user changes password [Taiga #5643](https://tree.taiga.io/project/penpot/issue/5643)
+- Fix cannot undo layer styles [Taiga #5676](https://tree.taiga.io/project/penpot/issue/5676)
+- Fix unexpected exception on boolean shapes [Taiga #5685](https://tree.taiga.io/project/penpot/issue/5685)
+- Fix ctrl+z on select not working [Taiga #5677](https://tree.taiga.io/project/penpot/issue/5677)
+- Fix thubmnail rendering flashing [Taiga #5675](https://tree.taiga.io/project/penpot/issue/5675)
+
+### :arrow_up: Deps updates
+
+- Update google fonts catalog (at 2023/07/06) [Taiga #5592](https://tree.taiga.io/project/penpot/issue/5592)
+
+
+### :heart: Community contributions by (Thank you!)
+
 - Update Typography palette order (by @akshay-gupta7) [Github #3156](https://github.com/penpot/penpot/pull/3156)
 - Palettes (color, typographies) empty state (by @akshay-gupta7) [Github #3160](https://github.com/penpot/penpot/pull/3160)
 - Duplicate objects via drag + alt (by @akshay-gupta7) [Github #3147](https://github.com/penpot/penpot/pull/3147)
@@ -31,6 +183,7 @@
 - Open project in new tab from workspace (by @akshay-gupta7) [Github #3246](https://github.com/penpot/penpot/pull/3246)
 - Distribute fix enabled when two elements were selected (by @dfelinto) [Github #3266](https://github.com/penpot/penpot/pull/3266)
 - Distribute vertical spacing failing for overlapped text (by @dfelinto) [Github #3267](https://github.com/penpot/penpot/pull/3267)
+- bug Change independent corner radius input tooltips #3332 (by @astudentinearth) [Github #3332](https://github.com/penpot/penpot/pull/3332)
 
 ## 1.18.6
 

README.md

@@ -26,7 +26,7 @@
 
 ![feature-readme](https://user-images.githubusercontent.com/1045247/189871786-0b44f7cf-3a0a-4445-a87b-9919ec398bf7.gif)
 
-**:tada: [Important Notice!] :tada:** Our very first **Penpot Fest** is happening on June 28-30, Barcelona (Spain). **Secure yourself a ticket** to know everything about the present and future of Penpot and be part of the conversation! See details on the amazing venue and speakers lineup at [penpotfest.org](https://penpotfest.org)! :zap:
+🎇 **Penpot Fest exceeded all expectations - it was a complete success!** 🎇 Penpot Fest is our first Design event that brought designers and developers from the Open Source communities and beyond. Watch the replay of the talks on our [Youtube channel](https://www.youtube.com/playlist?list=PLgcCPfOv5v56-fghJo2dHNBqL9zlDTslh) or [Peertube channel](https://peertube.kaleidos.net/w/p/1tWgyJTt8sKbWwCEcBimZW)
 
 Penpot is the first **Open Source** design and prototyping platform meant for cross-domain teams. Non dependent on operating systems, Penpot is web based and works with open standards (SVG). Penpot invites designers all over the world to fall in love with open source while getting developers excited about the design process in return.
 

backend/deps.edn

@@ -4,9 +4,7 @@
  :deps
  {penpot/common {:local/root "../common"}
   org.clojure/clojure {:mvn/version "1.11.1"}
-  org.clojure/core.async {:mvn/version "1.6.673"}
-
-  com.github.luben/zstd-jni {:mvn/version "1.5.2-5"}
+  com.github.luben/zstd-jni {:mvn/version "1.5.5-5"}
 
   io.prometheus/simpleclient {:mvn/version "0.16.0"}
   io.prometheus/simpleclient_hotspot {:mvn/version "0.16.0"}
@@ -17,17 +15,17 @@
 
   io.prometheus/simpleclient_httpserver {:mvn/version "0.16.0"}
 
-  io.lettuce/lettuce-core {:mvn/version "6.2.2.RELEASE"}
+  io.lettuce/lettuce-core {:mvn/version "6.2.6.RELEASE"}
   java-http-clj/java-http-clj {:mvn/version "0.4.3"}
 
   funcool/yetti
-  {:git/tag "v9.15"
-   :git/sha "aa9b967"
+  {:git/tag "v9.16"
+   :git/sha "7df3e08"
    :git/url "https://github.com/funcool/yetti.git"
    :exclusions [org.slf4j/slf4j-api]}
 
-  com.github.seancorfield/next.jdbc {:mvn/version "1.3.847"}
-  metosin/reitit-core {:mvn/version "0.5.18"}
+  com.github.seancorfield/next.jdbc {:mvn/version "1.3.883"}
+  metosin/reitit-core {:mvn/version "0.6.0"}
 
   org.postgresql/postgresql {:mvn/version "42.6.0"}
 
@@ -35,12 +33,12 @@
 
   io.whitfin/siphash {:mvn/version "2.0.0"}
 
-  buddy/buddy-hashers {:mvn/version "1.8.158"}
-  buddy/buddy-sign {:mvn/version "3.4.333"}
+  buddy/buddy-hashers {:mvn/version "2.0.167"}
+  buddy/buddy-sign {:mvn/version "3.5.351"}
 
-  com.github.ben-manes.caffeine/caffeine {:mvn/version "3.1.5"}
+  com.github.ben-manes.caffeine/caffeine {:mvn/version "3.1.8"}
 
-  org.jsoup/jsoup {:mvn/version "1.15.3"}
+  org.jsoup/jsoup {:mvn/version "1.16.1"}
   org.im4java/im4java
   {:git/tag "1.4.0-penpot-2"
    :git/sha "e2b3e16"
@@ -49,14 +47,14 @@
   org.lz4/lz4-java {:mvn/version "1.8.0"}
 
   org.clojars.pntblnk/clj-ldap {:mvn/version "0.0.17"}
-  integrant/integrant {:mvn/version "0.8.0"}
+  integrant/integrant {:mvn/version "0.8.1"}
 
   dawran6/emoji {:mvn/version "0.1.5"}
   markdown-clj/markdown-clj {:mvn/version "1.11.4"}
 
   ;; Pretty Print specs
   pretty-spec/pretty-spec {:mvn/version "0.1.4"}
-  software.amazon.awssdk/s3 {:mvn/version "2.19.29"}
+  software.amazon.awssdk/s3 {:mvn/version "2.20.138"}
   }
 
  :paths ["src" "resources" "target/classes"]
@@ -73,7 +71,7 @@
 
   :build
   {:extra-deps
-   {io.github.clojure/tools.build {:git/tag "v0.9.3" :git/sha "e537cd1"}}
+   {io.github.clojure/tools.build {:git/tag "v0.9.5" :git/sha "24f2894"}}
    :ns-default build}
 
   :test

backend/dev/user.clj

@@ -19,10 +19,11 @@
    [app.common.schema.generators :as sg]
    [app.common.spec :as us]
    [app.common.transit :as t]
+   [app.common.types.file :as ctf]
    [app.common.uuid :as uuid]
    [app.config :as cfg]
    [app.main :as main]
-   [app.srepl.helpers]
+   [app.srepl.helpers :as srepl.helpers]
    [app.srepl.main :as srepl]
    [app.util.blob :as blob]
    [app.util.json :as json]
@@ -48,7 +49,8 @@
    [malli.generator :as mg]
    [malli.registry :as mr]
    [malli.transform :as mt]
-   [malli.util :as mu]))
+   [malli.util :as mu]
+   [promesa.exec :as px]))
 
 (repl/disable-reload! (find-ns 'integrant.core))
 (set! *warn-on-reflection* true)
@@ -176,4 +178,3 @@
         [:map
          [:type [:= :b]]
          [:b :int]]]]]]]])
-

backend/resources/app/onboarding.edn

@@ -1,36 +1,30 @@
 [{:id "material-design-3"
   :name "Material Design 3"
-  :thumbnail-uri "https://penpot.app/images/libraries/cover-md3.jpg"
   :file-uri "https://github.com/penpot/penpot-files/raw/main/Material%20Design%203.penpot"}
  {:id "tutorial-for-beginners"
   :name "Tutorial for beginners"
-  :thumbnail-uri "https://penpot.app/images/libraries/tutorial-for-beginners.jpg"
   :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/tutorial-for-beginners.penpot"}
  {:id "penpot-design-system"
   :name "Penpot Design System"
-  :thumbnail-uri "https://penpot.app/images/libraries/cover-ds-penpot.jpg"
   :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/Penpot-Design-system.penpot"}
+ {:id "flex-layout-playground"
+  :name "Flex Layout Playground"
+  :file-uri "https://github.com/penpot/penpot-files/raw/main/Flex%20Layout%20Playground.penpot"}
  {:id "wireframing-kit"
   :name "Wireframing Kit"
-  :thumbnail-uri "https://penpot.app/images/libraries/cover-wireframes.jpg"
   :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/wireframing-kit.penpot"}
  {:id "ant-design"
   :name "Ant Design UI Kit (lite)"
-  :thumbnail-uri "https://penpot.app/images/libraries/cover-ant-design.jpg"
   :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/Ant-Design-UI-Kit-Lite.penpot"}
  {:id "cocomaterial"
   :name "Cocomaterial"
-  :thumbnail-uri "https://penpot.app/images/libraries/cover-cocomaterial.jpg"
   :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/Cocomaterial.penpot"}
  {:id "circum-icons"
   :name "Circum Icons pack"
-  :thumbnail-uri "https://penpot.app/images/libraries/cover-circum.jpg"
   :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/CircumIcons.penpot"}
  {:id "coreui"
   :name "CoreUI"
-  :thumbnail-uri "https://penpot.app/images/libraries/cover-coreui.jpg"
   :file-uri "https://github.com/penpot/penpot-files/raw/main/CoreUI%20DesignSystem%20(DEMO).penpot"}
  {:id "whiteboarding-kit"
   :name "Whiteboarding Kit"
-  :thumbnail-uri "https://penpot.app/images/libraries/cover-whiteboards.jpg"
   :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/Whiteboarding-mapping-kit.penpot"}]

backend/resources/app/templates/api-doc-entry.tmpl

@@ -22,11 +22,7 @@
       {% endif %}
       {% if item.params-schema-js %}
         <span class="tag">
-          <span>SC</span>
-        </span>
-      {% else %}
-        <span class="tag">
-          <span>SP</span>
+          <span>SCHEMA</span>
         </span>
       {% endif %}
     </div>

backend/resources/app/templates/api-doc.css

@@ -156,7 +156,7 @@ h4 {
 }
 
 .rpc-row-info > .module {
-  width: 120px;
+  width: 150px;
   font-weight: bold;
   border-right: 1px dotted #777;
   text-align: right;

backend/resources/app/templates/api-doc.tmpl

@@ -38,7 +38,7 @@
         <h2>GENERAL NOTES</h2>
 
         <h3>Authentication</h3>
-        <p>The penpot backend right now offerts two way for authenticate the request:
+        <p>The penpot backend right now offers two way for authenticate the request:
         <b>cookies</b> (the same mechanism that we use ourselves on accessing the API from the
         web application) and <b>access tokens</b>.</p>
 

backend/resources/app/templates/error-list.tmpl

@@ -6,13 +6,19 @@ penpot - error list
 
 {% block content %}
 <nav>
-  <h1>Latest error reports:</h1>
+  <div class="title">
+    <h1>Error reports (last 200)</h1>
+  </div>
 </nav>
 <main class="horizontal-list">
   <ul>
     {% for item in items %}
-    <li><a class="date" href="/dbg/error/{{item.id}}">{{item.created-at}}</a> 
-        <span class="title">{{item.hint|abbreviate:150}}</span></li>
+      <li>
+        <a class="date" href="/dbg/error/{{item.id}}">{{item.created-at}}</a>
+        <a class="hint" href="/dbg/error/{{item.id}}">
+          <span class="title">{{item.hint|abbreviate:150}}</span>
+        </a>
+      </li>
     {% endfor %}
   </ul>
 </main>

backend/resources/app/templates/error-report.v3.tmpl

@@ -1,13 +1,13 @@
  {% extends "app/templates/base.tmpl" %}
 
 {% block title %}
-penpot - error report v2 {{id}}
+Report: {{hint|abbreviate:150}} - {{id}} - Penpot Error Report (v3)
 {% endblock %}
 
 {% block content %}
 <nav>
   <div>[<a href="/dbg/error">⮜</a>]</div>
-  <div>[<a href="#message">message</a>]</div>
+  <div>[<a href="#head">head</a>]</div>
   <div>[<a href="#props">props</a>]</div>
   <div>[<a href="#context">context</a>]</div>
   {% if params %}
@@ -29,10 +29,11 @@ penpot - error report v2 {{id}}
 <main>
   <div class="table">
     <div class="table-row multiline">
-      <div id="message" class="table-key">MESSAGE: </div>
-
+      <div id="head" class="table-key">HEAD</div>
       <div class="table-val">
-        <h1>{{hint}}</h1>
+        <h1><span class="not-important">Hint:</span> <br/> {{hint}}</h1>
+        <h2><span class="not-important">Reported at:</span> <br/> {{created-at}}</h2>
+        <h2><span class="not-important">Report ID:</span> <br/> {{id}}</h2>
       </div>
     </div>
 
@@ -71,7 +72,7 @@ penpot - error report v2 {{id}}
 
     {% if value %}
     <div class="table-row multiline">
-      <div id="value" class="table-key">VALIDATION VALUE: </div>
+      <div id="value" class="table-key">VALUE: </div>
       <div class="table-val">
         <pre>{{value}}</pre>
       </div>

backend/resources/app/templates/styles.css

@@ -36,6 +36,11 @@ small {
   color: #888;
 }
 
+.not-important {
+  color: #888;
+  font-weight: 200;
+}
+
 small > strong {
   font-size: 9px;
 }
@@ -50,7 +55,13 @@ nav {
   background: #e3e3e3;
 }
 
-nav > h1 {
+nav > .title {
+  display: flex;
+  justify-content: center;
+  width: 100%;
+}
+
+nav > .title > h1 {
   padding: 0px;
   margin: 0px;
   font-size: 11px;
@@ -151,7 +162,6 @@ nav > div:not(:last-child) {
   line-height: 18px;
   min-width: 210px;
   margin: 0px 20px;
-  cursor: pointer;
   display: flex;
   border-radius: 3px;
 }

backend/resources/log4j2-devenv.xml

@@ -22,8 +22,8 @@
     <Logger name="org.postgresql" level="error" />
 
     <Logger name="app.rpc.commands.binfile" level="debug" />
-    <Logger name="app.storage.tmp" level="debug" />
-    <Logger name="app.worker" level="info" />
+    <Logger name="app.storage.tmp" level="info" />
+    <Logger name="app.worker" level="trace" />
     <Logger name="app.msgbus" level="info" />
     <Logger name="app.http.websocket" level="info" />
     <Logger name="app.util.websocket" level="info" />
@@ -31,6 +31,7 @@
     <Logger name="app.rpc.rlimit" level="info" />
     <Logger name="app.rpc.climit" level="info" />
     <Logger name="app.rpc.mutations.files" level="info" />
+    <Logger name="app.common.files.migrations" level="debug" />
 
     <Logger name="app.loggers" level="debug" additivity="false">
       <AppenderRef ref="main" level="debug" />

backend/scripts/build

@@ -18,6 +18,8 @@ cp scripts/manage.py target/dist/manage.py
 chmod +x target/dist/run.sh;
 chmod +x target/dist/manage.py
 
-# Prefetch
+# Prefetch templates
+rm -rf builtin-templates;
+mkdir builtin-templates;
 bb ./scripts/prefetch-templates.clj resources/app/onboarding.edn builtin-templates/
 cp -r builtin-templates target/dist/

backend/scripts/repl

@@ -41,7 +41,7 @@ export PENPOT_FLAGS="\
 # Initialize MINIO config
 mc alias set penpot-s3/ http://minio:9000 minioadmin minioadmin
 mc admin user add penpot-s3 penpot-devenv penpot-devenv
-mc admin policy set penpot-s3 readwrite user=penpot-devenv
+mc admin policy attach penpot-s3 readwrite --user=penpot-devenv
 mc mb penpot-s3/penpot -p
 
 export AWS_ACCESS_KEY_ID=penpot-devenv

backend/scripts/start-dev

@@ -15,7 +15,7 @@ export PENPOT_FLAGS="\
        enable-fdata-storage-objets-map \
        disable-secure-session-cookies \
        enable-smtp \
-       enable-webhooks";
+       enable-access-tokens";
 
 set -ex
 

backend/src/app/auth.clj

@@ -6,14 +6,15 @@
 
 (ns app.auth
   (:require
+   [app.config :as cf]
    [buddy.hashers :as hashers]
-   [promesa.exec :as px]))
+   [cuerdas.core :as str]))
 
 (def default-params
   {:alg :argon2id
-   :memory (* 32768 2)
-   :iterations 5
-   :parallelism (px/get-available-processors)})
+   :memory 32768 ;; 32 MiB
+   :iterations 3
+   :parallelism 2})
 
 (defn derive-password
   [password]
@@ -27,3 +28,16 @@
       {:update false
        :valid false})))
 
+(defn email-domain-in-whitelist?
+  "Returns true if email's domain is in the given whitelist or if
+  given whitelist is an empty string."
+  ([email]
+   (let [domains (cf/get :registration-domain-whitelist)]
+     (email-domain-in-whitelist? domains email)))
+  ([domains email]
+   (if (or (nil? domains) (empty? domains))
+     true
+     (let [[_ candidate] (-> (str/lower email)
+                             (str/split #"@" 2))]
+       (contains? domains candidate)))))
+

backend/src/app/auth/oidc.clj

@@ -7,6 +7,7 @@
 (ns app.auth.oidc
   "OIDC client implementation."
   (:require
+   [app.auth :as auth]
    [app.auth.oidc.providers :as-alias providers]
    [app.common.data :as d]
    [app.common.data.macros :as dm]
@@ -24,6 +25,8 @@
    [app.tokens :as tokens]
    [app.util.json :as json]
    [app.util.time :as dt]
+   [buddy.sign.jwk :as jwk]
+   [buddy.sign.jwt :as jwt]
    [clojure.set :as set]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
@@ -47,36 +50,29 @@
 
 (defn- discover-oidc-config
   [cfg {:keys [base-uri] :as opts}]
-  (let [discovery-uri (u/join base-uri ".well-known/openid-configuration")
-        response      (ex/try! (http/req! cfg
-                                          {:method :get :uri (str discovery-uri)}
-                                          {:sync? true}))]
-    (cond
-      (ex/exception? response)
-      (do
-        (l/warn :hint "unable to discover oidc configuration"
-                :discover-uri (str discovery-uri)
-                :cause response)
-        nil)
-
-      (= 200 (:status response))
-      (let [data      (json/decode (:body response))
+  (let [uri (dm/str (u/join base-uri ".well-known/openid-configuration"))
+        rsp (http/req! cfg {:method :get :uri uri} {:sync? true})]
+    (if (= 200 (:status rsp))
+      (let [data      (-> rsp :body json/decode)
             token-uri (get data :token_endpoint)
             auth-uri  (get data :authorization_endpoint)
-            user-uri  (get data :userinfo_endpoint)]
+            user-uri  (get data :userinfo_endpoint)
+            jwks-uri  (get data :jwks_uri)]
+
         (l/debug :hint "oidc uris discovered"
                  :token-uri token-uri
                  :auth-uri auth-uri
-                 :user-uri user-uri)
+                 :user-uri user-uri
+                 :jwks-uri jwks-uri)
+
         {:token-uri token-uri
          :auth-uri  auth-uri
-         :user-uri  user-uri})
-
-      :else
+         :user-uri  user-uri
+         :jwks-uri jwks-uri})
       (do
         (l/warn :hint "unable to discover OIDC configuration"
-                :uri (str discovery-uri)
-                :response-status-code (:status response))
+                :discover-uri uri
+                :http-status (:status rsp))
         nil))))
 
 (defn- prepare-oidc-opts
@@ -87,6 +83,7 @@
               :token-uri     (cf/get :oidc-token-uri)
               :auth-uri      (cf/get :oidc-auth-uri)
               :user-uri      (cf/get :oidc-user-uri)
+              :jwks-uri      (cf/get :oidc-jwks-uri)
               :scopes        (cf/get :oidc-scopes #{"openid" "profile" "email"})
               :roles-attr    (cf/get :oidc-roles-attr)
               :roles         (cf/get :oidc-roles)
@@ -101,8 +98,42 @@
                (string? (:user-uri opts))
                (string? (:auth-uri opts)))
         opts
-        (some-> (discover-oidc-config cfg opts)
-                (merge opts {:discover? true}))))))
+        (try
+          (-> (discover-oidc-config cfg opts)
+              (merge opts {:discover? true}))
+          (catch Throwable cause
+            (l/warn :hint "unable to discover OIDC configuration"
+                    :cause cause)))))))
+
+(defn- process-oidc-jwks
+  [keys]
+  (reduce (fn [result {:keys [kid] :as kdata}]
+            (let [pkey (ex/try! (jwk/public-key kdata))]
+              (if (ex/exception? pkey)
+                (do
+                  (l/warn :hint "unable to create public key"
+                          :kid (:kid kdata)
+                          :cause pkey)
+                  result)
+                (assoc result kid pkey))))
+          {}
+          keys))
+
+(defn- fetch-oidc-jwks
+  [cfg {:keys [jwks-uri]}]
+  (when jwks-uri
+    (try
+      (let [{:keys [status body]} (http/req! cfg {:method :get :uri jwks-uri} {:sync? true})]
+        (if (= 200 status)
+          (-> body json/decode :keys process-oidc-jwks)
+          (do
+            (l/warn :hint "unable to retrieve JWKs (unexpected response status code)"
+                    :http-status status
+                    :http-body  body)
+            nil)))
+      (catch Throwable cause
+        (l/warn :hint "unable to retrieve JWKs (unexpected exception)"
+                :cause cause)))))
 
 (defmethod ig/pre-init-spec ::providers/generic [_]
   (s/keys :req [::http/client]))
@@ -111,7 +142,7 @@
   [_ cfg]
   (when (contains? cf/flags :login-with-oidc)
     (if-let [opts (prepare-oidc-opts cfg)]
-      (do
+      (let [jwks (fetch-oidc-jwks cfg opts)]
         (l/info :hint "provider initialized"
                 :provider "oidc"
                 :method (if (:discover? opts) "discover" "manual")
@@ -122,8 +153,9 @@
                 :user-uri   (:user-uri opts)
                 :token-uri  (:token-uri opts)
                 :roles-attr (:roles-attr opts)
-                :roles      (:roles opts))
-        opts)
+                :roles      (:roles opts)
+                :keys       (str/join "," (map str (keys jwks))))
+        (assoc opts :jwks jwks))
       (do
         (l/warn :hint "unable to initialize auth provider, missing configuration" :provider "oidc")
         nil))))
@@ -164,7 +196,7 @@
   [cfg tdata props]
   (or (some-> props :github/email)
       (let [params {:uri "https://api.github.com/user/emails"
-                    :headers {"Authorization" (dm/str (:type tdata) " " (:token tdata))}
+                    :headers {"Authorization" (dm/str (:token/type tdata) " " (:token/access tdata))}
                     :timeout 6000
                     :method :get}
 
@@ -273,7 +305,7 @@
              {}
              props))
 
-(defn retrieve-access-token
+(defn fetch-access-token
   [{:keys [provider] :as cfg} code]
   (let [params {:client_id (:client-id provider)
                 :client_secret (:client-secret provider)
@@ -297,8 +329,9 @@
       (l/trace :hint "access token response" :status status :body body)
       (if (= status 200)
         (let [data (json/decode body)]
-          {:token (get data :access_token)
-           :type (get data :token_type)})
+          {:token/access (get data :access_token)
+           :token/id     (get data :id_token)
+           :token/type   (get data :token_type)})
 
         (ex/raise :type :internal
                   :code :unable-to-retrieve-token
@@ -306,12 +339,11 @@
                   :http-status status
                   :http-body body)))))
 
-(defn- retrieve-user-info
-  [{:keys [provider] :as cfg} tdata]
+(defn- process-user-info
+  [provider tdata info]
   (letfn [(get-email [props]
             ;; Allow providers hook into this for custom email
             ;; retrieval method.
-
             (if-let [get-email-fn (:get-email-fn provider)]
               (get-email-fn tdata props)
               (let [attr-kw (cf/get :oidc-email-attr "email")
@@ -322,48 +354,54 @@
             (let [attr-kw (cf/get :oidc-name-attr "name")
                   attr-ph (parse-attr-path provider attr-kw)]
               (get-in props attr-ph)))
+          ]
 
-          (process-response [response]
-            (let [info  (-> response :body json/decode)
-                  props (qualify-props provider info)
-                  email (get-email props)]
-              {:backend  (:name provider)
-               :fullname (or (get-name props) email)
-               :email    email
-               :props    props}))]
+    (let [props (qualify-props provider info)
+          email (get-email props)]
+      {:backend  (:name provider)
+       :fullname (or (get-name props) email)
+       :email    email
+       :props    props})))
 
-    (l/trace :hint "request user info"
-             :uri (:user-uri provider)
-             :token (obfuscate-string (:token tdata))
-             :token-type (:type tdata))
+(defn- fetch-user-info
+  [{:keys [provider] :as cfg} tdata]
+  (l/trace :hint "fetch user info"
+           :uri (:user-uri provider)
+           :token (obfuscate-string (:token/access tdata)))
 
-    (let [request  {:uri (:user-uri provider)
-                    :headers {"Authorization" (str (:type tdata) " " (:token tdata))}
-                    :timeout 6000
-                    :method :get}
-          response (http/req! cfg request {:sync? true})]
+  (let [params   {:uri (:user-uri provider)
+                  :headers {"Authorization" (str (:token/type tdata) " " (:token/access tdata))}
+                  :timeout 6000
+                  :method :get}
+        response (http/req! cfg params {:sync? true})]
 
-      (l/trace :hint "user info response"
-               :status (:status response)
-               :body   (:body response))
+    (l/trace :hint "user info response"
+             :status (:status response)
+             :body   (:body response))
 
-      (when-not (s/int-in-range? 200 300 (:status response))
-        (ex/raise :type :internal
-                  :code :unable-to-retrieve-user-info
-                  :hint "unable to retrieve user info"
-                  :http-status (:status response)
-                  :http-body (:body response)))
+    (when-not (s/int-in-range? 200 300 (:status response))
+      (ex/raise :type :internal
+                :code :unable-to-retrieve-user-info
+                :hint "unable to retrieve user info"
+                :http-status (:status response)
+                :http-body (:body response)))
 
-      (let [info (process-response response)]
-        (l/trace :hint "authentication info" :info info)
+    (-> response :body json/decode)))
 
-        (when-not (s/valid? ::info info)
-          (l/warn :hint "received incomplete profile info object (please set correct scopes)" :info info)
-          (ex/raise :type :internal
-                    :code :incomplete-user-info
-                    :hint "inconmplete user info"
-                    :info info))
-        info))))
+(defn- get-user-info
+  [{:keys [provider]} tdata]
+  (try
+    (when (:token/id tdata)
+      (let [{:keys [kid alg] :as theader} (jwt/decode-header (:token/id tdata))]
+        (when-let [key (if (str/starts-with? (name alg) "hs")
+                         (:client-secret provider)
+                         (get-in provider [:jwks kid]))]
+
+          (let [claims (jwt/unsign (:token/id tdata) key {:alg alg})]
+            (dissoc claims :exp :iss :iat :sid :aud :sub)))))
+    (catch Throwable cause
+      (l/warn :hint "unable to get user info from JWT token (unexpected exception)"
+              :cause cause))))
 
 (s/def ::backend ::us/not-empty-string)
 (s/def ::email ::us/not-empty-string)
@@ -376,7 +414,7 @@
                    ::props]))
 
 (defn get-info
-  [{:keys [provider] :as cfg} {:keys [params] :as request}]
+  [{:keys [provider ::main/props] :as cfg} {:keys [params] :as request}]
   (when-let [error (get params :error)]
     (ex/raise :type :internal
               :code :error-on-retrieving-code
@@ -385,9 +423,24 @@
 
   (let [state  (get params :state)
         code   (get params :code)
-        state  (tokens/verify (::main/props cfg) {:token state :iss :oauth})
-        token  (retrieve-access-token cfg code)
-        info   (retrieve-user-info cfg token)]
+        state  (tokens/verify props {:token state :iss :oauth})
+        tdata  (fetch-access-token cfg code)
+        info   (case (cf/get :oidc-user-info-source)
+                 :token (get-user-info cfg tdata)
+                 :userinfo (fetch-user-info cfg tdata)
+                 (or (get-user-info cfg tdata)
+                     (fetch-user-info cfg tdata)))
+
+        info   (process-user-info provider tdata info)]
+
+    (l/trace :hint "user info" :info info)
+
+    (when-not (s/valid? ::info info)
+      (l/warn :hint "received incomplete profile info object (please set correct scopes)" :info info)
+      (ex/raise :type :internal
+                :code :incomplete-user-info
+                :hint "inconmplete user info"
+                :info info))
 
     ;; If the provider is OIDC, we can proceed to check
     ;; roles if they are defined.
@@ -430,10 +483,24 @@
    ::yrs/headers {"location" (str uri)}})
 
 (defn- generate-error-redirect
-  [_ error]
-  (let [uri (-> (u/uri (cf/get :public-uri))
-                (assoc :path "/#/auth/login")
-                (assoc :query (u/map->query-string {:error "unable-to-auth" :hint (ex-message error)})))]
+  [_ cause]
+  (let [data   (if (ex/error? cause) (ex-data cause) nil)
+        code   (or (:code data) :unexpected)
+        type   (or (:type data) :internal)
+        hint   (or (:hint data)
+                   (if (ex/exception? cause)
+                     (ex-message cause)
+                     (str cause)))
+
+        params {:error "unable-to-auth"
+                :hint hint
+                :type type
+                :code code}
+
+        uri    (-> (u/uri (cf/get :public-uri))
+                   (assoc :path "/#/auth/login")
+                   (assoc :query (u/map->query-string params)))]
+
     (redirect-response uri)))
 
 (defn- generate-redirect
@@ -463,19 +530,23 @@
       (->> (redirect-response uri)
            (sxf request)))
 
-    (let [info   (assoc info
-                        :iss :prepared-register
-                        :is-active true
-                        :exp (dt/in-future {:hours 48}))
-          token  (tokens/generate (::main/props cfg) info)
-          params (d/without-nils
-                  {:token token
-                   :fullname (:fullname info)})
-          uri    (-> (u/uri (cf/get :public-uri))
-                     (assoc :path "/#/auth/register/validate")
-                     (assoc :query (u/map->query-string params)))]
 
-      (redirect-response uri))))
+    (if (auth/email-domain-in-whitelist? (:email info))
+      (let [info   (assoc info
+                          :iss :prepared-register
+                          :is-active true
+                          :exp (dt/in-future {:hours 48}))
+            token  (tokens/generate (::main/props cfg) info)
+            params (d/without-nils
+                    {:token token
+                     :fullname (:fullname info)})
+            uri    (-> (u/uri (cf/get :public-uri))
+                       (assoc :path "/#/auth/register/validate")
+                       (assoc :query (u/map->query-string params)))]
+
+        (redirect-response uri))
+      (generate-error-redirect cfg "email-domain-not-allowed"))))
+
 
 (defn- auth-handler
   [cfg {:keys [params] :as request}]
@@ -496,7 +567,7 @@
           profile (get-profile cfg info)]
       (generate-redirect cfg request info profile))
     (catch Throwable cause
-      (l/error :hint "error on oauth process" :cause cause)
+      (l/warn :hint "error on oauth process" :cause cause)
       (generate-error-redirect cfg cause))))
 
 (def provider-lookup

backend/src/app/config.clj

@@ -146,11 +146,13 @@
 (s/def ::google-client-id ::us/string)
 (s/def ::google-client-secret ::us/string)
 (s/def ::oidc-client-id ::us/string)
+(s/def ::oidc-user-info-source ::us/keyword)
 (s/def ::oidc-client-secret ::us/string)
 (s/def ::oidc-base-uri ::us/string)
 (s/def ::oidc-token-uri ::us/string)
 (s/def ::oidc-auth-uri ::us/string)
 (s/def ::oidc-user-uri ::us/string)
+(s/def ::oidc-jwks-uri ::us/string)
 (s/def ::oidc-scopes ::us/set-of-strings)
 (s/def ::oidc-roles ::us/set-of-strings)
 (s/def ::oidc-roles-attr ::us/string)
@@ -241,10 +243,12 @@
                    ::google-client-secret
                    ::oidc-client-id
                    ::oidc-client-secret
+                   ::oidc-user-info-source
                    ::oidc-base-uri
                    ::oidc-token-uri
                    ::oidc-auth-uri
                    ::oidc-user-uri
+                   ::oidc-jwks-uri
                    ::oidc-scopes
                    ::oidc-roles-attr
                    ::oidc-email-attr

backend/src/app/db.clj

@@ -5,7 +5,7 @@
 ;; Copyright (c) KALEIDOS INC
 
 (ns app.db
-  (:refer-clojure :exclude [get])
+  (:refer-clojure :exclude [get run!])
   (:require
    [app.common.data :as d]
    [app.common.exceptions :as ex]
@@ -145,6 +145,10 @@
   [v]
   (instance? javax.sql.DataSource v))
 
+(defn connection?
+  [conn]
+  (instance? Connection conn))
+
 (s/def ::conn some?)
 (s/def ::nilable-pool (s/nilable ::pool))
 (s/def ::pool pool?)
@@ -218,52 +222,71 @@
 
 (defmacro with-atomic
   [& args]
-  `(jdbc/with-transaction ~@args))
+  (if (symbol? (first args))
+    (let [cfgs (first args)
+          body (rest args)]
+      `(jdbc/with-transaction [conn# (::pool ~cfgs)]
+         (let [~cfgs (assoc ~cfgs ::conn conn#)]
+           ~@body)))
+    `(jdbc/with-transaction ~@args)))
 
 (defn open
   [pool]
   (jdbc/get-connection pool))
 
+(defn- resolve-connectable
+  [o]
+  (if (connection? o)
+    o
+    (if (pool? o)
+      o
+      (or (::conn o) (::pool o)))))
+
+
 (def ^:private default-opts
   {:builder-fn sql/as-kebab-maps})
 
 (defn exec!
   ([ds sv]
-   (jdbc/execute! ds sv default-opts))
+   (-> (resolve-connectable ds)
+       (jdbc/execute! sv default-opts)))
   ([ds sv opts]
-   (jdbc/execute! ds sv (merge default-opts opts))))
+   (-> (resolve-connectable ds)
+       (jdbc/execute! sv (merge default-opts opts)))))
 
 (defn exec-one!
   ([ds sv]
-   (jdbc/execute-one! ds sv default-opts))
+   (-> (resolve-connectable ds)
+       (jdbc/execute-one! sv default-opts)))
   ([ds sv opts]
-   (jdbc/execute-one! ds sv
-                      (-> (merge default-opts opts)
-                          (assoc :return-keys (::return-keys? opts false))))))
+   (-> (resolve-connectable ds)
+       (jdbc/execute-one! sv
+                          (-> (merge default-opts opts)
+                              (assoc :return-keys (::return-keys? opts false)))))))
 
 (defn insert!
   [ds table params & {:as opts}]
-  (exec-one! ds
-             (sql/insert table params opts)
-             (merge {::return-keys? true} opts)))
+  (-> (resolve-connectable ds)
+      (exec-one! (sql/insert table params opts)
+                 (merge {::return-keys? true} opts))))
 
 (defn insert-multi!
   [ds table cols rows & {:as opts}]
-  (exec! ds
-         (sql/insert-multi table cols rows opts)
-         (merge {::return-keys? true} opts)))
+  (-> (resolve-connectable ds)
+      (exec! (sql/insert-multi table cols rows opts)
+             (merge {::return-keys? true} opts))))
 
 (defn update!
   [ds table params where & {:as opts}]
-  (exec-one! ds
-             (sql/update table params where opts)
-             (merge {::return-keys? true} opts)))
+  (-> (resolve-connectable ds)
+      (exec-one! (sql/update table params where opts)
+                 (merge {::return-keys? true} opts))))
 
 (defn delete!
   [ds table params & {:as opts}]
-  (exec-one! ds
-             (sql/delete table params opts)
-             (merge {::return-keys? true} opts)))
+  (-> (resolve-connectable ds)
+      (exec-one! (sql/delete table params opts)
+                 (merge {::return-keys? true} opts))))
 
 (defn is-row-deleted?
   [{:keys [deleted-at]}]
@@ -293,6 +316,11 @@
                 :hint "database object not found"))
     row))
 
+(defn plan
+  [ds sql]
+  (-> (resolve-connectable ds)
+      (jdbc/plan sql sql/default-opts)))
+
 (defn get-by-id
   [ds table id & {:as opts}]
   (get ds table {:id id} opts))
@@ -361,10 +389,6 @@
   [data]
   (org.postgresql.util.PGInterval. ^String data))
 
-(defn connection?
-  [conn]
-  (instance? Connection conn))
-
 (defn savepoint
   ([^Connection conn]
    (.setSavepoint conn))
@@ -381,6 +405,52 @@
   ([^Connection conn ^Savepoint sp]
    (.rollback conn sp)))
 
+(defn tx-run!
+  [cfg f]
+  (cond
+    (connection? cfg)
+    (tx-run! {::conn cfg} f)
+
+    (pool? cfg)
+    (tx-run! {::pool cfg} f)
+
+    (::conn cfg)
+    (let [conn (::conn cfg)
+          sp   (savepoint conn)]
+      (try
+        (let [result (f cfg)]
+          (release! conn sp)
+          result)
+        (catch Throwable cause
+          (rollback! sp)
+          (throw cause))))
+
+    (::pool cfg)
+    (with-atomic [conn (::pool cfg)]
+      (f (assoc cfg ::conn conn)))
+
+    :else
+    (throw (IllegalArgumentException. "invalid arguments"))))
+
+(defn run!
+  [cfg f]
+  (cond
+    (connection? cfg)
+    (run! {::conn cfg} f)
+
+    (pool? cfg)
+    (run! {::pool cfg} f)
+
+    (::conn cfg)
+    (f cfg)
+
+    (::pool cfg)
+    (with-open [^Connection conn (open (::pool cfg))]
+      (f (assoc cfg ::conn conn)))
+
+    :else
+    (throw (IllegalArgumentException. "invalid arguments"))))
+
 (defn interval
   [o]
   (cond

backend/src/app/email.clj

@@ -305,7 +305,7 @@
   (fn [params]
     (when (contains? cf/flags :smtp)
       (let [session (create-smtp-session cfg)]
-        (with-open [transport (.getTransport session (if (:ssl cfg) "smtps" "smtp"))]
+        (with-open [transport (.getTransport session (if (::ssl cfg) "smtps" "smtp"))]
           (.connect ^Transport transport
                     ^String (::username cfg)
                     ^String (::password cfg))
@@ -341,7 +341,7 @@
                                (map :content)
                                first)))
                (println "******** end email" (:id email) "**********"))]
-    (l/info ::l/raw out)))
+    (l/raw! :info out)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; EMAIL FACTORIES

backend/src/app/http/awsns.clj

@@ -36,10 +36,10 @@
 
 (defmethod ig/init-key ::routes
   [_ {:keys [::wrk/executor] :as cfg}]
-  (letfn [(handler [request respond _]
+  (letfn [(handler [request]
             (let [data (-> request yrq/body slurp)]
               (px/run! executor #(handle-request cfg data)))
-            (respond {::yrs/status 200}))]
+            {::yrs/status 200})]
     ["/sns" {:handler handler
              :allowed-methods #{:post}}]))
 

backend/src/app/http/debug.clj

@@ -111,15 +111,18 @@
 
         (contains? params :clone)
         (let [profile    (profile/get-profile pool profile-id)
-              project-id (:default-project-id profile)
-              data       (blob/decode data)]
-          (create-file pool {:id (uuid/next)
-                             :name (str "Cloned file: " filename)
-                             :project-id project-id
-                             :profile-id profile-id
-                             :data data})
-          {::yrs/status 201
-           ::yrs/body "OK CREATED"})
+              project-id (:default-project-id profile)]
+
+          (db/run! pool (fn [{:keys [::db/conn]}]
+                          (create-file conn {:id file-id
+                                             :name (str "Cloned file: " filename)
+                                             :project-id project-id
+                                             :profile-id profile-id})
+                          (db/update! conn :file
+                                      {:data data}
+                                      {:id file-id})
+                          {::yrs/status 201
+                           ::yrs/body "OK CREATED"})))
 
         :else
         (prepare-response (blob/decode data))))))
@@ -133,31 +136,34 @@
   [{:keys [::db/pool]} {:keys [::session/profile-id params] :as request}]
   (let [profile    (profile/get-profile pool profile-id)
         project-id (:default-project-id profile)
-        data       (some-> params :file :path io/read-as-bytes blob/decode)]
+        data       (some-> params :file :path io/read-as-bytes)]
 
     (if (and data project-id)
-      (let [fname      (str "Imported file *: " (dt/now))
-            overwrite? (contains? params :overwrite?)
-            file-id    (or (and overwrite? (ex/ignoring (-> params :file :filename parse-uuid)))
-                           (uuid/next))]
+      (let [fname     (str "Imported file *: " (dt/now))
+            reuse-id? (contains? params :reuseid)
+            file-id   (or (and reuse-id? (ex/ignoring (-> params :file :filename parse-uuid)))
+                          (uuid/next))]
 
-        (if (and overwrite? file-id
+        (if (and reuse-id? file-id
                  (is-file-exists? pool file-id))
           (do
             (db/update! pool :file
-                        {:data (blob/encode data)}
+                        {:data data
+                         :deleted-at nil}
                         {:id file-id})
             {::yrs/status 200
              ::yrs/body "OK UPDATED"})
 
-          (do
-            (create-file pool {:id file-id
-                               :name fname
-                               :project-id project-id
-                               :profile-id profile-id
-                               :data data})
-            {::yrs/status 201
-             ::yrs/body "OK CREATED"})))
+          (db/run! pool (fn [{:keys [::db/conn]}]
+                          (create-file conn {:id file-id
+                                             :name fname
+                                             :project-id project-id
+                                             :profile-id profile-id})
+                          (db/update! conn :file
+                                      {:data data}
+                                      {:id file-id})
+                          {::yrs/status 201
+                           ::yrs/body "OK CREATED"}))))
 
       {::yrs/status 500
        ::yrs/body "ERROR"})))
@@ -238,9 +244,11 @@
             (-> (io/resource "app/templates/error-report.v2.tmpl")
                 (tmpl/render report)))
 
-          (render-template-v3 [{report :content}]
+          (render-template-v3 [{:keys [content id created-at]}]
             (-> (io/resource "app/templates/error-report.v3.tmpl")
-                (tmpl/render report)))
+                (tmpl/render (-> content
+                                 (assoc :id id)
+                                 (assoc :created-at (dt/format-instant created-at :rfc1123))))))
           ]
 
     (when-not (authorized? pool request)
@@ -264,7 +272,7 @@
           content->>'~:hint' AS hint
      FROM server_error_report
     ORDER BY created_at DESC
-    LIMIT 100")
+    LIMIT 200")
 
 (defn error-list-handler
   [{:keys [::db/pool]} request]

backend/src/app/http/errors.clj

@@ -10,6 +10,7 @@
    [app.common.exceptions :as ex]
    [app.common.logging :as l]
    [app.common.schema :as sm]
+   [app.config :as cf]
    [app.http :as-alias http]
    [app.http.access-token :as-alias actoken]
    [app.http.session :as-alias session]
@@ -30,14 +31,14 @@
   (let [claims (-> {}
                    (into (::session/token-claims request))
                    (into (::actoken/token-claims request)))]
-    {:path       (:path request)
-     :method     (:method request)
-     :params     (:params request)
-     :ip-addr    (parse-client-ip request)
-     :user-agent (yrq/get-header request "user-agent")
-     :profile-id (:uid claims)
-     :version    (or (yrq/get-header request "x-frontend-version")
-                     "unknown")}))
+    {:request/path       (:path request)
+     :request/method     (:method request)
+     :request/params     (:params request)
+     :request/user-agent (yrq/get-header request "user-agent")
+     :request/ip-addr    (parse-client-ip request)
+     :request/profile-id (:uid claims)
+     :version/frontend   (or (yrq/get-header request "x-frontend-version") "unknown")
+     :version/backend    (:full cf/version)}))
 
 (defmulti handle-exception
   (fn [err & _rest]
@@ -73,14 +74,14 @@
      ::yrs/headers headers}))
 
 (defmethod handle-exception :validation
-  [err _]
+  [err request]
   (let [{:keys [code] :as data} (ex-data err)]
     (cond
       (= code :spec-validation)
       (let [explain (ex/explain data)]
         {::yrs/status 400
          ::yrs/body   (-> data
-                          (dissoc ::s/problems ::s/value)
+                          (dissoc ::s/problems ::s/value ::s/spec)
                           (cond-> explain (assoc :explain explain)))})
 
       (= code :params-validation)
@@ -94,6 +95,11 @@
       (= code :request-body-too-large)
       {::yrs/status 413 ::yrs/body data}
 
+      (= code :invalid-image)
+      (binding [l/*context* (request->context request)]
+        (l/error :hint "unexpected error on processing image" :cause err)
+        {::yrs/status 400 ::yrs/body data})
+
       :else
       {::yrs/status 400 ::yrs/body data})))
 

backend/src/app/http/middleware.clj

@@ -22,9 +22,10 @@
   (:import
    com.fasterxml.jackson.core.JsonParseException
    com.fasterxml.jackson.core.io.JsonEOFException
+   com.fasterxml.jackson.databind.exc.MismatchedInputException
    io.undertow.server.RequestTooBigException
-   java.io.OutputStream
-   java.io.InputStream))
+   java.io.InputStream
+   java.io.OutputStream))
 
 (set! *warn-on-reflection* true)
 
@@ -78,11 +79,13 @@
 
 
               (or (instance? JsonEOFException cause)
-                  (instance? JsonParseException cause))
+                  (instance? JsonParseException cause)
+                  (instance? MismatchedInputException cause))
               (raise (ex/error :type :validation
                                :code :malformed-json
                                :hint (ex-message cause)
                                :cause cause))
+
               :else
               (raise cause)))]
 
@@ -118,8 +121,9 @@
                       (t/write! tw data)))
                   (catch java.io.IOException _)
                   (catch Throwable cause
-                    (l/warn :hint "unexpected error on encoding response"
-                            :cause cause))
+                    (binding [l/*context* {:value data}]
+                      (l/error :hint "unexpected error on encoding response"
+                               :cause cause)))
                   (finally
                     (.close ^OutputStream output-stream))))))
 
@@ -132,8 +136,9 @@
 
                   (catch java.io.IOException _)
                   (catch Throwable cause
-                    (l/warn :hint "unexpected error on encoding response"
-                            :cause cause))
+                    (binding [l/*context* {:value data}]
+                      (l/error :hint "unexpected error on encoding response"
+                               :cause cause)))
                   (finally
                     (.close ^OutputStream output-stream))))))
 

backend/src/app/http/websocket.clj

@@ -11,6 +11,7 @@
    [app.common.logging :as l]
    [app.common.pprint :as pp]
    [app.common.spec :as us]
+   [app.common.uuid :as uuid]
    [app.db :as db]
    [app.http.session :as session]
    [app.metrics :as mtx]
@@ -99,7 +100,10 @@
     (sp/pipe ch output-ch false)
 
     ;; Subscribe to the profile topic on msgbus/redis
-    (mbus/sub! msgbus :topic profile-id :chan ch)))
+    (mbus/sub! msgbus :topic profile-id :chan ch)
+
+    ;; Subscribe to the system topic on msgbus/redis
+    (mbus/sub! msgbus :topic (str uuid/zero) :chan ch)))
 
 (defmethod handle-message :close
   [{:keys [::mbus/msgbus]} {:keys [::ws/id ::ws/state ::profile-id ::session-id]} _]

backend/src/app/loggers/database.clj

@@ -40,35 +40,33 @@
   [{:keys [::l/context ::l/message ::l/props ::l/logger ::l/level ::l/cause] :as record}]
   (us/assert! ::l/record record)
 
-  (let [data (ex-data cause)]
+  (let [data (ex-data cause)
+        ctx  (-> context
+                 (assoc :tenant (cf/get :tenant))
+                 (assoc :host (cf/get :host))
+                 (assoc :public-uri (cf/get :public-uri))
+                 (assoc :logger/name logger)
+                 (assoc :logger/level level)
+                 (dissoc :request/params :value :params :data))]
     (merge
-     {:context (-> context
-                   (assoc :tenant (cf/get :tenant))
-                   (assoc :host (cf/get :host))
-                   (assoc :public-uri (cf/get :public-uri))
-                   (assoc :version (:full cf/version))
-                   (assoc :logger-name logger)
-                   (assoc :logger-level level)
-                   (dissoc :params)
-                   (pp/pprint-str :width 200))
-
-      :props   (pp/pprint-str props :width 200)
+     {:context (-> (into (sorted-map) ctx)
+                   (pp/pprint-str :width 200 :length 50 :level 10))
+      :props   (pp/pprint-str props :width 200 :length 50)
       :hint    (or (ex-message cause) @message)
       :trace   (ex/format-throwable cause :data? false :explain? false :header? false :summary? false)}
 
-     (when-let [params (:params context)]
-       {:params (pp/pprint-str params :width 200)})
+     (when-let [params (or (:request/params context) (:params context))]
+       {:params (pp/pprint-str params :width 200 :length 50 :level 10)})
+
+     (when-let [value (:value context)]
+       {:value (pp/pprint-str value :width 200 :length 50 :level 10)})
 
      (when-let [data (some-> data (dissoc ::s/problems ::s/value ::s/spec ::sm/explain :hint))]
        {:data (pp/pprint-str data :width 200)})
 
-     (when-let [value (-> data ::sm/explain :value)]
-       {:value (pp/pprint-str value :width 200)})
-
-     (when-let [explain (ex/explain data)]
+     (when-let [explain (ex/explain data {:level 10 :length 50})]
        {:explain explain}))))
 
-
 (defn error-record?
   [{:keys [::l/level ::l/cause]}]
   (and (= :error level)

backend/src/app/loggers/mattermost.clj

@@ -30,7 +30,9 @@
                   "```\n"
                   "- host: `" (:host report) "`\n"
                   "- tenant: `" (:tenant report) "`\n"
-                  "- version: `" (:version report) "`\n"
+                  "- request-path: `" (:request-path report) "`\n"
+                  "- frontend-version: `" (:frontend-version report) "`\n"
+                  "- backend-version: `" (:backend-version report) "`\n"
                   "\n"
                   "Trace:\n"
                   (:trace report)
@@ -50,13 +52,15 @@
 (defn record->report
   [{:keys [::l/context ::l/id ::l/cause] :as record}]
   (us/assert! ::l/record record)
-  {:id         id
-   :tenant     (cf/get :tenant)
-   :host       (cf/get :host)
-   :public-uri (cf/get :public-uri)
-   :version    (:full cf/version)
-   :profile-id (:profile-id context)
-   :trace      (ex/format-throwable cause :detail? false :header? false)})
+  {:id               id
+   :tenant           (cf/get :tenant)
+   :host             (cf/get :host)
+   :public-uri       (cf/get :public-uri)
+   :backend-version  (or (:version/backend context) (:full cf/version))
+   :frontend-version (:version/frontend context)
+   :profile-id       (:request/profile-id context)
+   :request-path     (:request/path context)
+   :trace            (ex/format-throwable cause :detail? false :header? false)})
 
 (defn handle-event
   [cfg record]

backend/src/app/main.clj

@@ -29,6 +29,7 @@
    [app.redis :as-alias rds]
    [app.rpc :as-alias rpc]
    [app.rpc.doc :as-alias rpc.doc]
+   [app.setup :as-alias setup]
    [app.srepl :as-alias srepl]
    [app.storage :as-alias sto]
    [app.storage.fs :as-alias sto.fs]
@@ -220,7 +221,7 @@
    {::db/pool (ig/ref ::db/pool)}
 
    ::http.awsns/routes
-   {::props              (ig/ref :app.setup/props)
+   {::props              (ig/ref ::setup/props)
     ::db/pool            (ig/ref ::db/pool)
     ::http.client/client (ig/ref ::http.client/client)
     ::wrk/executor       (ig/ref ::wrk/executor)}
@@ -263,7 +264,7 @@
    ::oidc/routes
    {::http.client/client (ig/ref ::http.client/client)
     ::db/pool            (ig/ref ::db/pool)
-    ::props              (ig/ref :app.setup/props)
+    ::props              (ig/ref ::setup/props)
     ::oidc/providers     {:google (ig/ref ::oidc.providers/google)
                           :github (ig/ref ::oidc.providers/github)
                           :gitlab (ig/ref ::oidc.providers/gitlab)
@@ -275,7 +276,7 @@
     ::db/pool            (ig/ref ::db/pool)
     ::rpc/routes         (ig/ref ::rpc/routes)
     ::rpc.doc/routes     (ig/ref ::rpc.doc/routes)
-    ::props              (ig/ref :app.setup/props)
+    ::props              (ig/ref ::setup/props)
     ::mtx/routes         (ig/ref ::mtx/routes)
     ::oidc/routes        (ig/ref ::oidc/routes)
     ::http.debug/routes  (ig/ref ::http.debug/routes)
@@ -322,11 +323,10 @@
 
     ::rpc/climit         (ig/ref ::rpc/climit)
     ::rpc/rlimit         (ig/ref ::rpc/rlimit)
-
-    ::props              (ig/ref :app.setup/props)
+    ::setup/templates    (ig/ref ::setup/templates)
+    ::props              (ig/ref ::setup/props)
 
     :pool                (ig/ref ::db/pool)
-    :templates           (ig/ref :app.setup/builtin-templates)
     }
 
    :app.rpc.doc/routes
@@ -337,7 +337,7 @@
     ::db/pool         (ig/ref ::db/pool)
     ::wrk/executor    (ig/ref ::wrk/executor)
     ::session/manager (ig/ref ::session/manager)
-    ::props           (ig/ref :app.setup/props)}
+    ::props           (ig/ref ::setup/props)}
 
    ::wrk/registry
    {::mtx/metrics (ig/ref ::mtx/metrics)
@@ -390,7 +390,7 @@
    :app.tasks.telemetry/handler
    {::db/pool            (ig/ref ::db/pool)
     ::http.client/client (ig/ref ::http.client/client)
-    ::props              (ig/ref :app.setup/props)}
+    ::props              (ig/ref ::setup/props)}
 
    [::srepl/urepl ::srepl/server]
    {::srepl/port (cf/get :urepl-port 6062)
@@ -400,10 +400,9 @@
    {::srepl/port (cf/get :prepl-port 6063)
     ::srepl/host (cf/get :prepl-host "localhost")}
 
-   :app.setup/builtin-templates
-   {::http.client/client (ig/ref ::http.client/client)}
+   ::setup/templates {}
 
-   :app.setup/props
+   ::setup/props
    {::db/pool    (ig/ref ::db/pool)
     ::key        (cf/get :secret-key)
 
@@ -412,7 +411,7 @@
     ::migrations (ig/ref :app.migrations/migrations)}
 
    ::audit.tasks/archive
-   {::props              (ig/ref :app.setup/props)
+   {::props              (ig/ref ::setup/props)
     ::db/pool            (ig/ref ::db/pool)
     ::http.client/client (ig/ref ::http.client/client)}
 

backend/src/app/migrations.clj

@@ -324,6 +324,12 @@
    {:name "0104-mod-file-thumbnail-table"
     :fn (mg/resource "app/migrations/sql/0104-mod-file-thumbnail-table.sql")}
 
+   {:name "0105-mod-file-change-table"
+    :fn (mg/resource "app/migrations/sql/0105-mod-file-change-table.sql")}
+
+   {:name "0105-mod-server-error-report-table"
+    :fn (mg/resource "app/migrations/sql/0105-mod-server-error-report-table.sql")}
+
    ])
 
 (defn apply-migrations!

backend/src/app/migrations/sql/0105-mod-file-change-table.sql

@@ -0,0 +1,9 @@
+ALTER TABLE file_change
+  ADD COLUMN label text NULL;
+
+ALTER TABLE file_change
+  ALTER COLUMN label SET STORAGE external;
+
+CREATE INDEX file_change__label__idx
+    ON file_change (file_id, label)
+ WHERE label is not null;

backend/src/app/migrations/sql/0105-mod-server-error-report-table.sql

@@ -0,0 +1,2 @@
+CREATE INDEX server_error_report__created_at__idx
+    ON server_error_report ( created_at );

backend/src/app/rpc.clj

@@ -214,6 +214,7 @@
           'app.rpc.commands.files-share
           'app.rpc.commands.files-temp
           'app.rpc.commands.files-update
+          'app.rpc.commands.files-snapshot
           'app.rpc.commands.files-thumbnails
           'app.rpc.commands.ldap
           'app.rpc.commands.management

backend/src/app/rpc/commands/audit.clj

@@ -9,7 +9,7 @@
   (:require
    [app.common.data :as d]
    [app.common.logging :as l]
-   [app.common.spec :as us]
+   [app.common.schema :as sm]
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
@@ -19,9 +19,7 @@
    [app.rpc.climit :as-alias climit]
    [app.rpc.doc :as-alias doc]
    [app.rpc.helpers :as rph]
-   [app.util.services :as sv]
-   [app.util.time :as dt]
-   [clojure.spec.alpha :as s]))
+   [app.util.services :as sv]))
 
 (defn- event->row [event]
   [(uuid/next)
@@ -52,26 +50,25 @@
     (when (seq events)
       (db/insert-multi! pool :audit-log event-columns events))))
 
-(s/def ::name ::us/string)
-(s/def ::type ::us/string)
-(s/def ::props (s/map-of ::us/keyword any?))
-(s/def ::timestamp dt/instant?)
-(s/def ::context (s/map-of ::us/keyword any?))
+(def schema:event
+  [:map {:title "Event"}
+   [:name [:string {:max 250}]]
+   [:type [:string {:max 250}]]
+   [:props
+    [:map-of :keyword :any]]
+   [:context {:optional true}
+    [:map-of :keyword :any]]])
 
-(s/def ::event
-  (s/keys :req-un [::type ::name ::props ::timestamp]
-          :opt-un [::context]))
-
-(s/def ::events (s/every ::event))
-
-(s/def ::push-audit-events
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::events]))
+(def schema:push-audit-events
+  [:map {:title "push-audit-events"}
+   [:events [:vector schema:event]]])
 
 (sv/defmethod ::push-audit-events
   {::climit/id :submit-audit-events-by-profile
    ::climit/key-fn ::rpc/profile-id
+   ::sm/params schema:push-audit-events
    ::audit/skip true
+   ::doc/skip true
    ::doc/added "1.17"}
   [{:keys [::db/pool] :as cfg} params]
   (if (or (db/read-only? pool)

backend/src/app/rpc/commands/auth.clj

@@ -6,10 +6,12 @@
 
 (ns app.rpc.commands.auth
   (:require
+   [app.auth :as auth]
    [app.common.data :as d]
+   [app.common.data.macros :as dm]
    [app.common.exceptions :as ex]
    [app.common.logging :as l]
-   [app.common.spec :as us]
+   [app.common.schema :as sm]
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
@@ -25,31 +27,13 @@
    [app.tokens :as tokens]
    [app.util.services :as sv]
    [app.util.time :as dt]
-   [clojure.spec.alpha :as s]
    [cuerdas.core :as str]))
 
-(s/def ::email ::us/email)
-(s/def ::fullname ::us/not-empty-string)
-(s/def ::lang ::us/string)
-(s/def ::path ::us/string)
-(s/def ::password ::us/not-empty-string)
-(s/def ::old-password ::us/not-empty-string)
-(s/def ::theme ::us/string)
-(s/def ::invitation-token ::us/not-empty-string)
-(s/def ::token ::us/not-empty-string)
+(def schema:password
+  [::sm/word-string {:max 500}])
 
-;; ---- HELPERS
-
-(defn email-domain-in-whitelist?
-  "Returns true if email's domain is in the given whitelist or if
-  given whitelist is an empty string."
-  [domains email]
-  (if (or (empty? domains)
-          (nil? domains))
-    true
-    (let [[_ candidate] (-> (str/lower email)
-                            (str/split #"@" 2))]
-      (contains? domains candidate))))
+(def schema:token
+  [::sm/word-string {:max 6000}])
 
 ;; ---- COMMAND: login with password
 
@@ -113,22 +97,22 @@
             (rph/with-meta {::audit/props (audit/profile->props profile)
                             ::audit/profile-id (:id profile)}))))))
 
-(s/def ::login-with-password
-  (s/keys :req-un [::email ::password]
-          :opt-un [::invitation-token]))
+(def schema:login-with-password
+  [:map {:title "login-with-password"}
+   [:email ::sm/email]
+   [:password schema:password]
+   [:invitation-token {:optional true} schema:token]])
 
 (sv/defmethod ::login-with-password
   "Performs authentication using penpot password."
   {::rpc/auth false
-   ::doc/added "1.15"}
+   ::doc/added "1.15"
+   ::sm/params schema:login-with-password}
   [cfg params]
   (login-with-password cfg params))
 
 ;; ---- COMMAND: Logout
 
-(s/def ::logout
-  (s/keys :opt [::rpc/profile-id]))
-
 (sv/defmethod ::logout
   "Clears the authentication cookie and logout the current session."
   {::rpc/auth false
@@ -153,13 +137,15 @@
            (update-password conn))
       nil)))
 
-(s/def ::token ::us/not-empty-string)
-(s/def ::recover-profile
-  (s/keys :req-un [::token ::password]))
+(def schema:recover-profile
+  [:map {:title "recover-profile"}
+   [:token schema:token]
+   [:password schema:password]])
 
 (sv/defmethod ::recover-profile
   {::rpc/auth false
-   ::doc/added "1.15"}
+   ::doc/added "1.15"
+   ::sm/params schema:recover-profile}
   [cfg params]
   (recover-profile cfg params))
 
@@ -180,10 +166,9 @@
                   :code :email-does-not-match-invitation
                   :hint "email should match the invitation"))))
 
-  (when-let [domains (cf/get :registration-domain-whitelist)]
-    (when-not (email-domain-in-whitelist? domains (:email params))
-      (ex/raise :type :validation
-                :code :email-domain-is-not-allowed)))
+  (when-not (auth/email-domain-in-whitelist? (:email params))
+    (ex/raise :type :validation
+              :code :email-domain-is-not-allowed))
 
   ;; Don't allow proceed in preparing registration if the profile is
   ;; already reported as spammer.
@@ -241,13 +226,16 @@
     (with-meta {:token token}
       {::audit/profile-id uuid/zero})))
 
-(s/def ::prepare-register-profile
-  (s/keys :req-un [::email ::password]
-          :opt-un [::invitation-token]))
+(def schema:prepare-register-profile
+  [:map {:title "prepare-register-profile"}
+   [:email ::sm/email]
+   [:password schema:password]
+   [:invitation-token {:optional true} schema:token]])
 
 (sv/defmethod ::prepare-register-profile
   {::rpc/auth false
-   ::doc/added "1.15"}
+   ::doc/added "1.15"
+   ::sm/params schema:prepare-register-profile}
   [cfg params]
   (prepare-register cfg params))
 
@@ -257,7 +245,7 @@
   "Create the profile entry on the database with limited set of input
   attrs (all the other attrs are filled with default values)."
   [conn {:keys [email] :as params}]
-  (us/assert! ::us/email email)
+  (dm/assert! ::sm/email email)
   (let [id        (or (:id params) (uuid/next))
         props     (-> (audit/extract-utm-params params)
                       (merge (:props params))
@@ -335,9 +323,9 @@
                 :extra-data ptoken})))
 
 (defn register-profile
-  [{:keys [::db/conn] :as cfg} {:keys [token] :as params}]
+  [{:keys [::db/conn] :as cfg} {:keys [token fullname] :as params}]
   (let [claims     (tokens/verify (::main/props cfg) {:token token :iss :prepared-register})
-        params     (merge params claims)
+        params     (assoc claims :fullname fullname)
 
         is-active  (or (:is-active params)
                        (not (contains? cf/flags :email-verification)))
@@ -404,12 +392,16 @@
           {::audit/replace-props (audit/profile->props profile)
            ::audit/profile-id (:id profile)})))))
 
-(s/def ::register-profile
-  (s/keys :req-un [::token ::fullname]))
+
+(def schema:register-profile
+  [:map {:title "register-profile"}
+   [:token schema:token]
+   [:fullname [::sm/word-string {:max 100}]]])
 
 (sv/defmethod ::register-profile
   {::rpc/auth false
-   ::doc/added "1.15"}
+   ::doc/added "1.15"
+   ::sm/params schema:register-profile}
   [{:keys [::db/pool] :as cfg} params]
   (db/with-atomic [conn pool]
     (-> (assoc cfg ::db/conn conn)
@@ -461,12 +453,15 @@
              (create-recovery-token)
              (send-email-notification conn))))))
 
-(s/def ::request-profile-recovery
-  (s/keys :req-un [::email]))
+
+(def schema:request-profile-recovery
+  [:map {:title "request-profile-recovery"}
+   [:email ::sm/email]])
 
 (sv/defmethod ::request-profile-recovery
   {::rpc/auth false
-   ::doc/added "1.15"}
+   ::doc/added "1.15"
+   ::sm/params schema:request-profile-recovery}
   [cfg params]
   (request-profile-recovery cfg params))
 

backend/src/app/rpc/commands/binfile.clj

@@ -11,10 +11,11 @@
    [app.common.data.macros :as dm]
    [app.common.exceptions :as ex]
    [app.common.files.features :as ffeat]
+   [app.common.files.migrations :as pmg]
    [app.common.fressian :as fres]
    [app.common.logging :as l]
-   [app.common.pages.migrations :as pmg]
    [app.common.spec :as us]
+   [app.common.types.file :as ctf]
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
@@ -294,28 +295,40 @@
   [output & {:keys [level] :or {level 0}}]
   (ZstdOutputStream. ^OutputStream output (int level)))
 
-(defn- retrieve-file
-  [pool file-id]
-  (dm/with-open [conn (db/open pool)]
-    (binding [pmap/*load-fn* (partial files/load-pointer conn file-id)]
-      (some-> (db/get* conn :file {:id file-id})
-              (files/decode-row)
-              (files/process-pointers deref)))))
+(defn- get-files
+  [cfg ids]
+  (letfn [(get-files* [{:keys [::db/conn]}]
+            (let [sql (str "SELECT id FROM file "
+                           " WHERE id = ANY(?) ")
+                  ids (db/create-array conn "uuid" ids)]
+              (->> (db/exec! conn [sql ids])
+                   (into [] (map :id))
+                   (not-empty))))]
 
-(def ^:private sql:file-media-objects
-  "SELECT * FROM file_media_object WHERE id = ANY(?)")
+    (db/run! cfg get-files*)))
 
-(defn- retrieve-file-media
-  [pool {:keys [data id] :as file}]
+(defn- get-file
+  [cfg file-id]
+  (letfn [(get-file* [{:keys [::db/conn]}]
+            (binding [pmap/*load-fn* (partial files/load-pointer conn file-id)]
+              (some-> (db/get* conn :file {:id file-id} {::db/remove-deleted? false})
+                      (files/decode-row)
+                      (files/process-pointers deref))))]
+
+    (db/run! cfg get-file*)))
+
+(defn- get-file-media
+  [{:keys [::db/pool]} {:keys [data id] :as file}]
   (dm/with-open [conn (db/open pool)]
     (let [ids (app.tasks.file-gc/collect-used-media data)
-          ids (db/create-array conn "uuid" ids)]
+          ids (db/create-array conn "uuid" ids)
+          sql (str "SELECT * FROM file_media_object WHERE id = ANY(?)")]
 
       ;; We assoc the file-id again to the file-media-object row
       ;; because there are cases that used objects refer to other
       ;; files and we need to ensure in the exportation process that
       ;; all ids matches
-      (->> (db/exec! conn [sql:file-media-objects ids])
+      (->> (db/exec! conn [sql ids])
            (mapv #(assoc % :file-id id))))))
 
 (def ^:private storage-object-id-xf
@@ -325,34 +338,32 @@
 
 (def ^:private sql:file-libraries
   "WITH RECURSIVE libs AS (
-     SELECT fl.id, fl.deleted_at
+     SELECT fl.id
        FROM file AS fl
        JOIN file_library_rel AS flr ON (flr.library_file_id = fl.id)
       WHERE flr.file_id = ANY(?)
     UNION
-     SELECT fl.id, fl.deleted_at
+     SELECT fl.id
        FROM file AS fl
        JOIN file_library_rel AS flr ON (flr.library_file_id = fl.id)
        JOIN libs AS l ON (flr.file_id = l.id)
    )
    SELECT DISTINCT l.id
-     FROM libs AS l
-    WHERE l.deleted_at IS NULL OR l.deleted_at > now();")
+     FROM libs AS l")
 
-(defn- retrieve-libraries
-  [pool ids]
+(defn- get-libraries
+  [{:keys [::db/pool]} ids]
   (dm/with-open [conn (db/open pool)]
     (let [ids (db/create-array conn "uuid" ids)]
       (map :id (db/exec! pool [sql:file-libraries ids])))))
 
-(def ^:private sql:file-library-rels
-  "SELECT * FROM file_library_rel
-    WHERE file_id = ANY(?)")
-
-(defn- retrieve-library-relations
-  [pool ids]
-  (dm/with-open [conn (db/open pool)]
-    (db/exec! conn [sql:file-library-rels (db/create-array conn "uuid" ids)])))
+(defn- get-library-relations
+  [cfg ids]
+  (db/run! cfg (fn [{:keys [::db/conn]}]
+                 (let [ids (db/create-array conn "uuid" ids)
+                       sql (str "SELECT flr.* FROM file_library_rel AS flr "
+                                " WHERE flr.file_id = ANY(?)")]
+                   (db/exec! conn [sql ids])))))
 
 (defn- create-or-update-file
   [conn params]
@@ -372,13 +383,12 @@
 
 ;; --- GENERAL PURPOSE DYNAMIC VARS
 
-(def ^:dynamic *state*)
-(def ^:dynamic *options*)
+(def ^:dynamic *state* nil)
+(def ^:dynamic *options* nil)
 
 ;; --- EXPORT WRITER
-
 (defn- embed-file-assets
-  [data conn file-id]
+  [data cfg file-id]
   (letfn [(walk-map-form [form state]
             (cond
               (uuid? (:fill-color-ref-file form))
@@ -408,7 +418,7 @@
             ;; NOTE: there is a possibility that shape refers to an
             ;; non-existant file because the file was removed. In this
             ;; case we just ignore the asset.
-            (if-let [lib (retrieve-file conn lib-id)]
+            (if-let [lib (get-file cfg lib-id)]
               (reduce (partial process-asset lib) data items)
               data))
 
@@ -476,31 +486,43 @@
               [:v1/metadata :v1/files :v1/rels :v1/sobjects])))))
 
 (defmethod write-section :v1/metadata
-  [{:keys [::db/pool ::output ::file-ids ::include-libraries?]}]
-  (let [libs  (when include-libraries?
-                (retrieve-libraries pool file-ids))
-        files (into file-ids libs)]
-    (write-obj! output {:version cf/version :files files})
-    (vswap! *state* assoc :files files)))
+  [{:keys [::output ::file-ids ::include-libraries?] :as cfg}]
+  (if-let [fids (get-files cfg file-ids)]
+    (let [lids (when include-libraries?
+                 (get-libraries cfg file-ids))
+          ids  (into fids lids)]
+      (write-obj! output {:version cf/version :files ids})
+      (vswap! *state* assoc :files ids))
+    (ex/raise :type :not-found
+              :code :files-not-found
+              :hint "unable to retrieve files for export")))
 
 (defmethod write-section :v1/files
-  [{:keys [::db/pool ::output ::embed-assets?]}]
+  [{:keys [::output ::embed-assets? ::include-libraries?] :as cfg}]
 
   ;; Initialize SIDS with empty vector
   (vswap! *state* assoc :sids [])
 
   (doseq [file-id (-> *state* deref :files)]
-    (let [file  (cond-> (retrieve-file pool file-id)
+    (let [detach? (and (not embed-assets?) (not include-libraries?))
+          file  (cond-> (get-file cfg file-id)
+                  detach?
+                  (-> (ctf/detach-external-references file-id)
+                   (dissoc :libraries))
                   embed-assets?
-                  (update :data embed-file-assets pool file-id))
+                  (update :data embed-file-assets cfg file-id))
 
-          media (retrieve-file-media pool file)]
+          media (get-file-media cfg file)]
 
       (l/debug :hint "write penpot file"
                :id file-id
+               :name (:name file)
                :media (count media)
                ::l/sync? true)
 
+      (doseq [item media]
+        (l/debug :hint "write penpot file media object" :id (:id item) ::l/sync? true))
+
       (doto output
         (write-obj! file)
         (write-obj! media))
@@ -508,9 +530,10 @@
       (vswap! *state* update :sids into storage-object-id-xf media))))
 
 (defmethod write-section :v1/rels
-  [{:keys [::db/pool ::output ::include-libraries?]}]
-  (let [rels  (when include-libraries?
-                (retrieve-library-relations pool (-> *state* deref :files)))]
+  [{:keys [::output ::include-libraries?] :as cfg}]
+  (let [ids  (-> *state* deref :files)
+        rels (when include-libraries?
+               (get-library-relations cfg ids))]
     (l/debug :hint "found rels" :total (count rels) ::l/sync? true)
     (write-obj! output rels)))
 
@@ -518,6 +541,7 @@
   [{:keys [::sto/storage ::output]}]
   (let [sids    (-> *state* deref :sids)
         storage (media/configure-assets-storage storage)]
+
     (l/debug :hint "found sobjects"
              :items (count sids)
              ::l/sync? true)
@@ -592,7 +616,7 @@
                   (let [options (-> options
                                     (assoc ::section section)
                                     (assoc ::input input)
-                                    (assoc :conn conn))]
+                                    (assoc ::db/conn conn))]
                     (binding [*options* options]
                       (read-section options))))
                 [:v1/metadata :v1/files :v1/rels :v1/sobjects])
@@ -620,7 +644,7 @@
         (update :components pmap-wrap))))
 
 (defmethod read-section :v1/files
-  [{:keys [conn ::input ::migrate? ::project-id ::timestamp ::overwrite?]}]
+  [{:keys [::db/conn ::input ::migrate? ::project-id ::timestamp ::overwrite?]}]
   (doseq [expected-file-id (-> *state* deref :files)]
     (let [file     (read-obj! input)
           media'   (read-obj! input)
@@ -630,23 +654,29 @@
       (when (not= file-id expected-file-id)
         (ex/raise :type :validation
                   :code :inconsistent-penpot-file
+                  :found-id file-id
+                  :expected-id expected-file-id
                   :hint "the penpot file seems corrupt, found unexpected uuid (file-id)"))
 
       ;; Update index using with media
-      (l/debug :hint "update index with media" ::l/sync? true)
+      (l/dbg :hint "update index with media" ::l/sync? true)
       (vswap! *state* update :index update-index (map :id media'))
 
       ;; Store file media for later insertion
-      (l/debug :hint "update media references" ::l/sync? true)
+      (l/dbg :hint "update media references" ::l/sync? true)
       (vswap! *state* update :media into (map #(update % :id lookup-index)) media')
 
-      (l/debug :hint "processing file" :file-id file-id ::features features ::l/sync? true)
-
       (binding [ffeat/*current* features
                 ffeat/*wrap-with-objects-map-fn* (if (features "storage/objects-map") omap/wrap identity)
                 ffeat/*wrap-with-pointer-map-fn* (if (features "storage/pointer-map") pmap/wrap identity)
                 pmap/*tracked* (atom {})]
 
+        (l/dbg :hint "processing file"
+               :id file-id
+               :features features
+               :version (-> file :data :version)
+               ::l/sync? true)
+
         (let [file-id' (lookup-index file-id)
               data     (-> (:data file)
                            (assoc :id file-id')
@@ -678,22 +708,31 @@
             (db/delete! conn :file-thumbnail {:file-id file-id'})))))))
 
 (defmethod read-section :v1/rels
-  [{:keys [conn ::input ::timestamp]}]
-  (let [rels (read-obj! input)]
+  [{:keys [::db/conn ::input ::timestamp]}]
+  (let [rels (read-obj! input)
+        ids  (into #{} (-> *state* deref :files))]
     ;; Insert all file relations
-    (doseq [rel rels]
+    (doseq [{:keys [library-file-id] :as rel} rels]
       (let [rel (-> rel
                     (assoc :synced-at timestamp)
                     (update :file-id lookup-index)
                     (update :library-file-id lookup-index))]
-        (l/debug :hint "create file library link"
-                 :file-id (:file-id rel)
-                 :lib-id (:library-file-id rel)
-                 ::l/sync? true)
-        (db/insert! conn :file-library-rel rel)))))
+
+        (if (contains? ids library-file-id)
+          (do
+            (l/debug :hint "create file library link"
+                     :file-id (:file-id rel)
+                     :lib-id (:library-file-id rel)
+                     ::l/sync? true)
+            (db/insert! conn :file-library-rel rel))
+
+          (l/warn :hint "ignoring file library link"
+                  :file-id (:file-id rel)
+                  :lib-id (:library-file-id rel)
+                  ::l/sync? true))))))
 
 (defmethod read-section :v1/sobjects
-  [{:keys [::sto/storage conn ::input ::overwrite?]}]
+  [{:keys [::sto/storage ::db/conn ::input ::overwrite?]}]
   (let [storage (media/configure-assets-storage storage)
         ids     (read-obj! input)]
 
@@ -742,7 +781,7 @@
 (defn- lookup-index
   [id]
   (let [val (get-in @*state* [:index id])]
-    (l/trace :fn "lookup-index" :id id :val val ::l/sync? true)
+    (l/trc :fn "lookup-index" :id id :val val ::l/sync? true)
     (when (and (not (::ignore-index-errors? *options*)) (not val))
       (ex/raise :type :validation
                 :code :incomplete-index
@@ -755,7 +794,7 @@
          index index]
     (if-let [id (first items)]
       (let [new-id (if (::overwrite? *options*) id (uuid/next))]
-        (l/trace :fn "update-index" :id id :new-id new-id ::l/sync? true)
+        (l/trc :fn "update-index" :id id :new-id new-id ::l/sync? true)
         (recur (rest items)
                (assoc index id new-id)))
       index)))
@@ -773,8 +812,7 @@
               (update-in [:metadata :id] lookup-index)
 
               ;; Relink paths with fill image
-              (and (map? (:fill-image form))
-                   (= :path (:type form)))
+              (map? (:fill-image form))
               (update-in [:fill-image :id] lookup-index)
 
               ;; This covers old shapes and the new :fills.
@@ -929,5 +967,10 @@
                               ::input (:path file)
                               ::project-id project-id
                               ::ignore-index-errors? true))]
+
+      (db/update! conn :project
+                  {:modified-at (dt/now)}
+                  {:id project-id})
+
       (rph/with-meta ids
         {::audit/props {:file nil :file-ids ids}}))))

backend/src/app/rpc/commands/comments.clj

@@ -468,8 +468,8 @@
   {::doc/added "1.15"}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id ::rpc/request-at id share-id content] :as params}]
   (db/with-atomic [conn pool]
-    (let [{:keys [thread-id] :as comment} (get-comment conn id ::db/for-update? true)
-          {:keys [file-id page-id owner-id] :as thread} (get-comment-thread conn thread-id ::db/for-update? true)]
+    (let [{:keys [thread-id owner-id] :as comment} (get-comment conn id ::db/for-update? true)
+          {:keys [file-id page-id] :as thread} (get-comment-thread conn thread-id ::db/for-update? true)]
 
       (files/check-comment-permissions! conn profile-id file-id share-id)
 

backend/src/app/rpc/commands/files.clj

@@ -9,8 +9,8 @@
    [app.common.data :as d]
    [app.common.data.macros :as dm]
    [app.common.exceptions :as ex]
+   [app.common.files.migrations :as pmg]
    [app.common.pages.helpers :as cph]
-   [app.common.pages.migrations :as pmg]
    [app.common.schema :as sm]
    [app.common.schema.desc-js-like :as-alias smdj]
    [app.common.schema.generators :as sg]
@@ -38,14 +38,22 @@
 
 ;; --- FEATURES
 
+(defn resolve-public-uri
+  [media-id]
+  (when media-id
+    (str (cf/get :public-uri) "/assets/by-id/" media-id)))
+
 (def supported-features
   #{"storage/objects-map"
     "storage/pointer-map"
+    "internal/shape-record"
+    "internal/geom-record"
     "components/v2"})
 
 (defn get-default-features
   []
-  (cond-> #{}
+  (cond-> #{"internal/shape-record"
+            "internal/geom-record"}
     (contains? cf/flags :fdata-storage-pointer-map)
     (conj "storage/pointer-map")
 
@@ -184,6 +192,8 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defn check-features-compatibility!
+  "Function responsible to check if provided features are supported by
+  the current backend"
   [features]
   (let [not-supported (set/difference features supported-features)]
     (when (seq not-supported)
@@ -243,63 +253,66 @@
        (into #{} (comp (filter pmap/pointer-map?)
                        (map pmap/get-id)))))
 
+;; FIXME: file locking
+(defn- process-components-v2-feature
+  "A special case handling of the components/v2 feature."
+  [{:keys [features data] :as file}]
+  (let [data     (ctf/migrate-to-components-v2 data)
+        features (conj features "components/v2")]
+    (-> file
+        (assoc ::pmg/migrated true)
+        (assoc :features features)
+        (assoc :data data))))
+
+(defn handle-file-features!
+  [{:keys [features] :as file} client-features]
+
+  ;; Check features compatibility between the currently supported features on
+  ;; the current backend instance and the file retrieved from the database
+  (check-features-compatibility! features)
+
+  (cond-> file
+    (and (contains? features "components/v2")
+         (not (contains? client-features "components/v2")))
+    (as-> file (ex/raise :type :restriction
+                         :code :feature-mismatch
+                         :feature "components/v2"
+                         :hint "file has 'components/v2' feature enabled but frontend didn't specifies it"
+                         :file-id (:id file)))
+
+    ;; This operation is needed because the components migration generates a new
+    ;; page with random id which is returned to the client; without persisting
+    ;; the migration this can cause that two simultaneous clients can have a
+    ;; different view of the file data and end persisting two pages with main
+    ;; components and breaking the whole file."
+    (and (contains? client-features "components/v2")
+         (not (contains? features "components/v2")))
+    (as-> file (process-components-v2-feature file))
+
+    ;; This operation is needed for backward comapatibility with frontends that
+    ;; does not support pointer-map resolution mechanism; this just resolves the
+    ;; pointers on backend and return a complete file.
+    (and (contains? features "storage/pointer-map")
+         (not (contains? client-features "storage/pointer-map")))
+    (process-pointers deref)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; QUERY COMMANDS
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defn handle-file-features!
-  [conn {:keys [id features data] :as file} client-features]
-
-  (when (and (contains? features "components/v2")
-             (not (contains? client-features "components/v2")))
-    (ex/raise :type :restriction
-              :code :feature-mismatch
-              :feature "components/v2"
-              :hint "file has 'components/v2' feature enabled but frontend didn't specifies it"))
-
-  ;; NOTE: this operation is needed because the components migration
-  ;; generates a new page with random id which is returned to the
-  ;; client; without persisting the migration this can cause that two
-  ;; simultaneous clients can have a different view of the file data
-  ;; and end persisting two pages with main components and breaking
-  ;; the whole file
-  (let [file (if (and (contains? client-features "components/v2")
-                      (not (contains? features "components/v2")))
-               (binding [pmap/*tracked* (atom {})]
-                 (let [data        (ctf/migrate-to-components-v2 data)
-                       features    (conj features "components/v2")
-                       modified-at (dt/now)
-                       features'   (db/create-array conn "text" features)]
-                   (db/update! conn :file
-                               {:data (blob/encode data)
-                                :modified-at modified-at
-                                :features features'}
-                               {:id id})
-                   (persist-pointers! conn id)
-                   (-> file
-                       (assoc :modified-at modified-at)
-                       (assoc :features features)
-                       (assoc :data data))))
-               file)]
-
-    (cond-> file
-      (and (contains? features "storage/pointer-map")
-           (not (contains? client-features "storage/pointer-map")))
-      (process-pointers deref))))
-
 ;; --- COMMAND QUERY: get-file (by id)
 
-(sm/def! ::features
+(def schema:features
   [:schema
    {:title "FileFeatures"
     ::smdj/inline true
     :gen/gen (sg/subseq supported-features)}
    ::sm/set-of-strings])
 
-(sm/def! ::file
+(def schema:file
   [:map {:title "File"}
    [:id ::sm/uuid]
-   [:features ::features]
+   [:features schema:features]
    [:has-media-trimmed :boolean]
    [:comment-thread-seqn {:min 0} :int]
    [:name :string]
@@ -310,18 +323,18 @@
    [:created-at ::dt/instant]
    [:data {:optional true} :any]])
 
-(sm/def! ::permissions-mixin
+(def schema:permissions-mixin
   [:map {:title "PermissionsMixin"}
    [:permissions ::perms/permissions]])
 
-(sm/def! ::file-with-permissions
+(def schema:file-with-permissions
   [:merge {:title "FileWithPermissions"}
-   ::file
-   ::permissions-mixin])
+   schema:file
+   schema:permissions-mixin])
 
-(sm/def! ::get-file
+(def schema:get-file
   [:map {:title "get-file"}
-   [:features {:optional true} ::features]
+   [:features {:optional true} schema:features]
    [:id ::sm/uuid]
    [:project-id {:optional true} ::sm/uuid]])
 
@@ -329,59 +342,68 @@
   ([conn id client-features]
    (get-file conn id client-features nil))
   ([conn id client-features project-id]
-  ;; here we check if client requested features are supported
+   ;; here we check if client requested features are supported
    (check-features-compatibility! client-features)
-   (binding [pmap/*load-fn* (partial load-pointer conn id)]
+   (binding [pmap/*load-fn* (partial load-pointer conn id)
+             pmap/*tracked* (atom {})]
+
      (let [params (merge {:id id}
-                    (when (some? project-id)
-                      {:project-id project-id}))
+                         (when (some? project-id)
+                           {:project-id project-id}))
+
            file   (-> (db/get conn :file params)
                       (decode-row)
                       (pmg/migrate-file))
 
-           file   (handle-file-features! conn file client-features)]
+           file   (handle-file-features! file client-features)]
 
-      ;; NOTE: if migrations are applied, probably new pointers generated so
-      ;; instead of persiting them on each get-file, we just resolve them until
-      ;; user updates the file and permanently persists the new pointers
-       (cond-> file
-         (pmg/migrated? file)
-         (process-pointers deref))))))
+       ;; NOTE: when file is migrated, we break the rule of no perform
+       ;; mutations on get operations and update the file with all
+       ;; migrations applied
+       (when (pmg/migrated? file)
+         (let [features (db/create-array conn "text" (:features file))]
+           (db/update! conn :file
+                       {:data (blob/encode (:data file))
+                        :features features}
+                       {:id id})
+           (persist-pointers! conn id)))
+
+       file))))
 
 (defn get-minimal-file
   [{:keys [::db/pool] :as cfg} id]
   (db/get pool :file {:id id} {:columns [:id :modified-at :revn]}))
 
 (defn get-file-etag
-  [{:keys [modified-at revn]}]
-  (str (dt/format-instant modified-at :iso) "-" revn))
+  [{:keys [::rpc/profile-id]} {:keys [modified-at revn]}]
+  (str profile-id (dt/format-instant modified-at :iso) revn))
 
 (sv/defmethod ::get-file
   "Retrieve a file by its ID. Only authenticated users."
   {::doc/added "1.17"
    ::cond/get-object #(get-minimal-file %1 (:id %2))
    ::cond/key-fn get-file-etag
-   ::sm/params ::get-file
-   ::sm/result ::file-with-permissions}
+   ::sm/params schema:get-file
+   ::sm/result schema:file-with-permissions}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id features project-id] :as params}]
-  (dm/with-open [conn (db/open pool)]
+  (db/with-atomic [conn pool]
     (let [perms (get-permissions conn profile-id id)]
       (check-read-permissions! perms)
       (let [file (-> (get-file conn id features project-id)
                      (assoc :permissions perms))]
-        (vary-meta file assoc ::cond/key (get-file-etag file))))))
+        (vary-meta file assoc ::cond/key (get-file-etag params file))))))
 
 
 ;; --- COMMAND QUERY: get-file-fragment (by id)
 
-(sm/def! ::file-fragment
+(def schema:file-fragment
   [:map {:title "FileFragment"}
    [:id ::sm/uuid]
    [:file-id ::sm/uuid]
    [:created-at ::dt/instant]
    [:content any?]])
 
-(sm/def! ::get-file-fragment
+(def schema:get-file-fragment
   [:map {:title "get-file-fragment"}
    [:file-id ::sm/uuid]
    [:fragment-id ::sm/uuid]
@@ -395,8 +417,8 @@
 (sv/defmethod ::get-file-fragment
   "Retrieve a file by its ID. Only authenticated users."
   {::doc/added "1.17"
-   ::sm/params ::get-file-fragment
-   ::sm/result ::file-fragment}
+   ::sm/params schema:get-file-fragment
+   ::sm/result schema:file-fragment}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id fragment-id share-id] }]
   (dm/with-open [conn (db/open pool)]
     (let [perms (get-permissions conn profile-id file-id share-id)]
@@ -413,22 +435,36 @@
           f.modified_at,
           f.name,
           f.revn,
-          f.is_shared
+          f.is_shared,
+          ft.media_id
      from file as f
+     left join file_thumbnail as ft on (ft.file_id = f.id and ft.revn = f.revn)
     where f.project_id = ?
       and f.deleted_at is null
     order by f.modified_at desc")
 
 (defn get-project-files
   [conn project-id]
-  (db/exec! conn [sql:project-files project-id]))
+  (->> (db/exec! conn [sql:project-files project-id])
+       (mapv (fn [row]
+               (if-let [media-id (:media-id row)]
+                 (-> row
+                     (dissoc :media-id)
+                     (assoc :thumbnail-uri (resolve-public-uri media-id)))
+                 (dissoc row :media-id))))))
+
+(def schema:get-project-files
+  [:map {:title "get-project-files"}
+   [:project-id ::sm/uuid]])
+
+(def schema:files
+  [:vector schema:file])
 
 (sv/defmethod ::get-project-files
   "Get all files for the specified project."
   {::doc/added "1.17"
-   ::sm/params [:map {:title "get-project-files"}
-                [:project-id ::sm/uuid]]
-   ::sm/result [:vector ::file]}
+   ::sm/params schema:get-project-files
+   ::sm/result schema:files}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id project-id]}]
   (dm/with-open [conn (db/open pool)]
     (projects/check-read-permissions! conn profile-id project-id)
@@ -439,11 +475,14 @@
 
 (declare get-has-file-libraries)
 
+(def schema:has-file-libraries
+  [:map {:title "has-file-libraries"}
+   [:file-id ::sm/uuid]])
+
 (sv/defmethod ::has-file-libraries
   "Checks if the file has libraries. Returns a boolean"
   {::doc/added "1.15.1"
-   ::sm/params [:map {:title "has-file-libraries"}
-                [:file-id ::sm/uuid]]
+   ::sm/params schema:has-file-libraries
    ::sm/result :boolean}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id]}]
   (dm/with-open [conn (db/open pool)]
@@ -471,7 +510,8 @@
   other not needed objects removed from the `:objects` data
   structure."
   [{:keys [objects] :as page} object-id]
-  (let [objects (cph/get-children-with-self objects object-id)]
+  (let [objects (->> (cph/get-children-with-self objects object-id)
+                     (filter some?))]
     (assoc page :objects (d/index-by :id objects))))
 
 (defn- prune-thumbnails
@@ -498,12 +538,13 @@
       (uuid? object-id)
       (prune-objects object-id))))
 
-(sm/def! ::get-page
+(def schema:get-page
   [:map {:title "GetPage"}
    [:file-id ::sm/uuid]
    [:page-id {:optional true} ::sm/uuid]
+   [:share-id {:optional true} ::sm/uuid]
    [:object-id {:optional true} ::sm/uuid]
-   [:features {:optional true} ::features]])
+   [:features {:optional true} schema:features]])
 
 (sv/defmethod ::get-page
   "Retrieves the page data from file and returns it. If no page-id is
@@ -516,15 +557,13 @@
 
   Mainly used for rendering purposes."
   {::doc/added "1.17"
-   ::sm/params ::get-page}
-  [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id] :as params}]
+   ::sm/params schema:get-page}
+  [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id share-id] :as params}]
   (dm/with-open [conn (db/open pool)]
-    (check-read-permissions! conn profile-id file-id)
-
-    (binding [pmap/*load-fn* (partial load-pointer conn file-id)]
-      (get-page conn params))))
-
-
+    (let [perms (get-permissions conn profile-id file-id share-id)]
+      (check-read-permissions! perms)
+      (binding [pmap/*load-fn* (partial load-pointer conn file-id)]
+        (get-page conn params)))))
 
 ;; --- COMMAND QUERY: get-team-shared-files
 
@@ -536,9 +575,11 @@
           f.created_at,
           f.modified_at,
           f.name,
-          f.is_shared
+          f.is_shared,
+          ft.media_id
      from file as f
     inner join project as p on (p.id = f.project_id)
+     left join file_thumbnail as ft on (ft.file_id = f.id and ft.revn = f.revn)
     where f.is_shared = true
       and f.deleted_at is null
       and p.deleted_at is null
@@ -569,6 +610,12 @@
     (->> (db/exec! conn [sql:team-shared-files team-id])
          (into #{} (comp
                     (map decode-row)
+                    (map (fn [row]
+                           (if-let [media-id (:media-id row)]
+                             (-> row
+                                 (dissoc :media-id)
+                                 (assoc :thumbnail-uri (resolve-public-uri media-id)))
+                             (dissoc row :media-id))))
                     (map #(assoc % :library-summary (library-summary %)))
                     (map #(dissoc % :data)))))))
 
@@ -668,9 +715,11 @@
             f.modified_at,
             f.name,
             f.is_shared,
+            ft.media_id,
             row_number() over w as row_num
        from file as f
-       join project as p on (p.id = f.project_id)
+      inner join project as p on (p.id = f.project_id)
+       left join file_thumbnail as ft on (ft.file_id = f.id and ft.revn = f.revn)
       where p.team_id = ?
         and p.deleted_at is null
         and f.deleted_at is null
@@ -681,7 +730,13 @@
 
 (defn get-team-recent-files
   [conn team-id]
-  (db/exec! conn [sql:team-recent-files team-id]))
+  (->> (db/exec! conn [sql:team-recent-files team-id])
+       (mapv (fn [row]
+               (if-let [media-id (:media-id row)]
+                 (-> row
+                     (dissoc :media-id)
+                     (assoc :thumbnail-uri (resolve-public-uri media-id)))
+                 (dissoc row :media-id))))))
 
 (s/def ::get-team-recent-files
   (s/keys :req [::rpc/profile-id]
@@ -694,6 +749,23 @@
     (teams/check-read-permissions! conn profile-id team-id)
     (get-team-recent-files conn team-id)))
 
+
+;; --- COMMAND QUERY: get-file-summary
+
+(sv/defmethod ::get-file-summary
+  "Retrieve a file summary by its ID. Only authenticated users."
+  {::doc/added "1.20"
+   ::sm/params schema:get-file}
+  [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id features project-id] :as params}]
+  (db/with-atomic [conn pool]
+    (check-read-permissions! conn profile-id id)
+    (let [file (get-file conn id features project-id)]
+      {:name             (:name file)
+       :components-count (count (ctkl/components-seq (:data file)))
+       :graphics-count   (count (get-in file [:data :media] []))
+       :colors-count     (count (get-in file [:data :colors] []))
+       :typography-count (count (get-in file [:data :typographies] []))})))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; MUTATION COMMANDS
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -743,11 +815,11 @@
 
 ;; --- MUTATION COMMAND: set-file-shared
 
-(defn unlink-files
-  [conn {:keys [id] :as params}]
+(defn- unlink-files!
+  [conn {:keys [id]}]
   (db/delete! conn :file-library-rel {:library-file-id id}))
 
-(defn set-file-shared
+(defn- set-file-shared!
   [conn {:keys [id is-shared] :as params}]
   (db/update! conn :file
               {:is-shared is-shared}
@@ -758,49 +830,50 @@
      FROM file_library_rel AS flr
     INNER JOIN file AS f ON (f.id = flr.file_id)
     WHERE flr.library_file_id = ?
+      AND (f.deleted_at IS NULL OR f.deleted_at > now())
     ORDER BY f.created_at ASC;")
 
-(defn absorb-library
+(defn- absorb-library!
   "Find all files using a shared library, and absorb all library assets
   into the file local libraries"
-  [conn {:keys [id] :as params}]
-  (let [library (db/get-by-id conn :file id)]
-    (when (:is-shared library)
-      (let [ldata (binding [pmap/*load-fn* (partial load-pointer conn id)]
-                    (-> library decode-row load-all-pointers! pmg/migrate-file :data))
-            rows  (db/exec! conn [sql:get-referenced-files id])]
-        (doseq [file-id (map :id rows)]
-          (binding [pmap/*load-fn* (partial load-pointer conn file-id)
-                    pmap/*tracked* (atom {})]
-            (let [file (-> (db/get-by-id conn :file file-id
-                                         ::db/check-deleted? false
-                                         ::db/remove-deleted? false)
-                           (decode-row)
-                           (load-all-pointers!)
-                           (pmg/migrate-file))
-                  data (ctf/absorb-assets (:data file) ldata)]
-              (db/update! conn :file
-                          {:revn (inc (:revn file))
-                           :data (blob/encode data)
-                           :modified-at (dt/now)}
-                          {:id file-id})
-              (persist-pointers! conn file-id))))))))
+  [conn {:keys [id] :as library}]
+  (let [ldata (binding [pmap/*load-fn* (partial load-pointer conn id)]
+                (-> library decode-row (process-pointers deref) pmg/migrate-file :data))
+        rows  (db/exec! conn [sql:get-referenced-files id])]
+    (doseq [file-id (map :id rows)]
+      (binding [pmap/*load-fn* (partial load-pointer conn file-id)
+                pmap/*tracked* (atom {})]
+        (let [file (-> (db/get-by-id conn :file file-id
+                                     ::db/check-deleted? false
+                                     ::db/remove-deleted? false)
+                       (decode-row)
+                       (load-all-pointers!)
+                       (pmg/migrate-file))
+              data (ctf/absorb-assets (:data file) ldata)]
+          (db/update! conn :file
+                      {:revn (inc (:revn file))
+                       :data (blob/encode data)
+                       :modified-at (dt/now)}
+                      {:id file-id})
+          (persist-pointers! conn file-id))))))
 
-(s/def ::set-file-shared
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::id ::is-shared]))
+(def ^:private schema:set-file-shared
+  [:map {:title "set-file-shared"}
+   [:id ::sm/uuid]
+   [:is-shared :boolean]])
 
 (sv/defmethod ::set-file-shared
   {::doc/added "1.17"
-   ::webhooks/event? true}
+   ::webhooks/event? true
+   ::sm/params schema:set-file-shared}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id is-shared] :as params}]
   (db/with-atomic [conn pool]
     (check-edition-permissions! conn profile-id id)
-    (when-not is-shared
-      (absorb-library conn params)
-      (unlink-files conn params))
+    (let [file (set-file-shared! conn params)]
+      (when-not is-shared
+        (absorb-library! conn file)
+        (unlink-files! conn file))
 
-    (let [file (set-file-shared conn params)]
       (rph/with-meta
         (select-keys file [:id :name :is-shared])
         {::audit/props {:name (:name file)
@@ -809,24 +882,26 @@
 
 ;; --- MUTATION COMMAND: delete-file
 
-(defn mark-file-deleted
-  [conn {:keys [id] :as params}]
+(defn- mark-file-deleted!
+  [conn {:keys [id]}]
   (db/update! conn :file
               {:deleted-at (dt/now)}
               {:id id}))
 
-(s/def ::delete-file
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::id]))
+(def ^:private schema:delete-file
+  [:map {:title "delete-file"}
+   [:id ::sm/uuid]])
 
 (sv/defmethod ::delete-file
   {::doc/added "1.17"
-   ::webhooks/event? true}
+   ::webhooks/event? true
+   ::sm/params schema:delete-file}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id] :as params}]
   (db/with-atomic [conn pool]
     (check-edition-permissions! conn profile-id id)
-    (absorb-library conn params)
-    (let [file (mark-file-deleted conn params)]
+    (let [file (mark-file-deleted! conn params)]
+      (when (:is-shared file)
+        (absorb-library! conn file))
 
       (rph/with-meta (rph/wrap)
         {::audit/props {:project-id (:project-id file)

backend/src/app/rpc/commands/files_snapshot.clj

@@ -0,0 +1,135 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC
+
+(ns app.rpc.commands.files-snapshot
+  (:require
+   [app.common.exceptions :as ex]
+   [app.common.logging :as l]
+   [app.common.schema :as sm]
+   [app.common.uuid :as uuid]
+   [app.config :as cf]
+   [app.db :as db]
+   [app.main :as-alias main]
+   [app.media :as media]
+   [app.rpc :as-alias rpc]
+   [app.rpc.commands.profile :as profile]
+   [app.rpc.doc :as-alias doc]
+   [app.storage :as sto]
+   [app.util.services :as sv]
+   [app.util.time :as dt]))
+
+(defn check-authorized!
+  [{:keys [::db/pool]} profile-id]
+  (when-not (or (= "devenv" (cf/get :host))
+                (let [profile (ex/ignoring (profile/get-profile pool profile-id))
+                      admins  (or (cf/get :admins) #{})]
+                  (contains? admins (:email profile))))
+    (ex/raise :type :authentication
+              :code :authentication-required
+              :hint "only admins allowed")))
+
+(defn get-file-snapshots
+  [{:keys [::db/conn]} {:keys [file-id limit start-at]
+                        :or {limit Long/MAX_VALUE}}]
+  (let [query    (str "select id, label, revn, created_at "
+                      "  from file_change "
+                      " where file_id = ? "
+                      "   and created_at < ? "
+                      "   and data is not null "
+                      " order by created_at desc "
+                      " limit ?")
+        start-at (or start-at (dt/now))
+        limit    (min limit 20)]
+
+    (->> (db/exec! conn [query file-id start-at limit])
+         (mapv (fn [row]
+                 (update row :created-at dt/format-instant :rfc1123))))))
+
+(def ^:private schema:get-file-snapshots
+  [:map [:file-id ::sm/uuid]])
+
+(sv/defmethod ::get-file-snapshots
+  {::doc/added "1.20"
+   ::doc/skip true
+   ::sm/params schema:get-file-snapshots}
+  [cfg {:keys [::rpc/profile-id] :as params}]
+  (check-authorized! cfg profile-id)
+  (db/run! cfg #(get-file-snapshots % params)))
+
+(defn restore-file-snapshot!
+  [{:keys [::db/conn ::sto/storage] :as cfg} {:keys [file-id id]}]
+  (let [storage  (media/configure-assets-storage storage conn)
+        params   {:id id :file-id file-id}
+        options  {:columns [:id :data :revn]}
+        snapshot (db/get* conn :file-change params options)]
+
+    (when (and (some? snapshot)
+               (some? (:data snapshot)))
+
+      (l/debug :hint "snapshot found"
+               :snapshot-id (:id snapshot)
+               :file-id file-id)
+
+      (db/update! conn :file
+                    {:data (:data snapshot)}
+                    {:id file-id})
+
+      ;; clean object thumbnails
+      (let [sql (str "delete from file_object_thumbnail "
+                     " where file_id=? returning media_id")
+            res (db/exec! conn [sql file-id])]
+
+        (doseq [media-id (into #{} (keep :media-id) res)]
+          (sto/del-object! storage media-id)))
+
+      ;; clean object thumbnails
+      (let [sql (str "delete from file_thumbnail "
+                     " where file_id=? returning media_id")
+            res (db/exec! conn [sql file-id])]
+        (doseq [media-id (into #{} (keep :media-id) res)]
+          (sto/del-object! storage media-id)))
+
+      {:id (:id snapshot)})))
+
+(def ^:private schema:restore-file-snapshot
+  [:map
+   [:file-id ::sm/uuid]
+   [:id ::sm/uuid]])
+
+(sv/defmethod ::restore-file-snapshot
+  {::doc/added "1.20"
+   ::doc/skip true
+   ::sm/params schema:restore-file-snapshot}
+  [cfg {:keys [::rpc/profile-id] :as params}]
+  (check-authorized! cfg profile-id)
+  (db/tx-run! cfg #(restore-file-snapshot! % params)))
+
+(defn take-file-snapshot!
+  [{:keys [::db/conn]} {:keys [file-id label]}]
+  (when-let [file (db/get* conn :file {:id file-id})]
+    (let [id    (uuid/next)
+          label (or label (str "Snapshot at " (dt/format-instant (dt/now) :rfc1123)))]
+      (l/debug :hint "persisting file snapshot" :file-id file-id :label label)
+      (db/insert! conn :file-change
+                  {:id id
+                   :revn (:revn file)
+                   :data (:data file)
+                   :features (:features file)
+                   :file-id (:id file)
+                   :label label})
+      {:id id})))
+
+(def ^:private schema:take-file-snapshot
+  [:map [:file-id ::sm/uuid]])
+
+(sv/defmethod ::take-file-snapshot
+  {::doc/added "1.20"
+   ::doc/skip true
+   ::sm/params schema:take-file-snapshot}
+  [cfg {:keys [::rpc/profile-id] :as params}]
+  (check-authorized! cfg profile-id)
+  (db/tx-run! cfg #(take-file-snapshot! % params)))
+

backend/src/app/rpc/commands/files_temp.clj

@@ -86,16 +86,16 @@
       (ex/raise :type :validation
                 :code :cant-persist-already-persisted-file))
 
-    (loop [revs (seq revs)
-           data (blob/decode (:data file))]
-      (if-let [rev (first revs)]
-        (recur (rest revs)
-               (->> rev :changes blob/decode (cp/process-changes data)))
-        (db/update! conn :file
-                    {:deleted-at nil
-                     :revn revn
-                     :data (blob/encode data)}
-                    {:id id})))
+
+    (let [data
+          (->> revs
+               (mapcat #(->> % :changes blob/decode))
+               (cp/process-changes (blob/decode (:data file))))]
+      (db/update! conn :file
+                  {:deleted-at nil
+                   :revn revn
+                   :data (blob/encode data)}
+                  {:id id}))
     nil))
 
 (s/def ::persist-temp-file

backend/src/app/rpc/commands/files_thumbnails.clj

@@ -14,7 +14,6 @@
    [app.common.schema :as sm]
    [app.common.spec :as us]
    [app.common.types.shape-tree :as ctt]
-   [app.config :as cf]
    [app.db :as db]
    [app.db.sql :as sql]
    [app.loggers.audit :as-alias audit]
@@ -39,10 +38,6 @@
 
 ;; --- COMMAND QUERY: get-file-object-thumbnails
 
-(defn- get-public-uri
-  [media-id]
-  (str (cf/get :public-uri) "/assets/by-id/" media-id))
-
 (defn- get-object-thumbnails
   ([conn file-id]
    (let [sql (str/concat
@@ -52,7 +47,7 @@
          res (db/exec! conn [sql file-id])]
      (->> res
           (d/index-by :object-id (fn [row]
-                                   (or (some-> row :media-id get-public-uri)
+                                   (or (some-> row :media-id files/resolve-public-uri)
                                        (:data row))))
           (d/without-nils))))
 
@@ -65,13 +60,14 @@
          res (db/exec! conn [sql file-id ids])]
      (d/index-by :object-id
                  (fn [row]
-                   (or (some-> row :media-id get-public-uri)
+                   (or (some-> row :media-id files/resolve-public-uri)
                        (:data row)))
                  res))))
 
 (sv/defmethod ::get-file-object-thumbnails
   "Retrieve a file object thumbnails."
   {::doc/added "1.17"
+   ::doc/module :files
    ::sm/params [:map {:title "get-file-object-thumbnails"}
                 [:file-id ::sm/uuid]]
    ::sm/result [:map-of :string :string]
@@ -85,8 +81,6 @@
 
 ;; --- COMMAND QUERY: get-file-thumbnail
 
-;; FIXME: refactor to support uploading data to storage
-
 (defn get-file-thumbnail
   [conn file-id revn]
   (let [sql (sql/select :file-thumbnail
@@ -95,10 +89,15 @@
                         {:limit 1
                          :order-by [[:revn :desc]]})
         row (db/exec-one! conn sql)]
+
     (when-not row
       (ex/raise :type :not-found
                 :code :file-thumbnail-not-found))
 
+    (when-not (:data row)
+      (ex/raise :type :not-found
+                :code :file-thumbnail-not-found))
+
     {:data (:data row)
      :props (some-> (:props row) db/decode-transit-pgobject)
      :revn (:revn row)
@@ -113,20 +112,17 @@
           :opt-un [::revn]))
 
 (sv/defmethod ::get-file-thumbnail
-  "Method used in frontend for obtain the file thumbnail (used in the
-  dashboard)."
-  {::doc/added "1.17"}
+  {::doc/added "1.17"
+   ::doc/module :files
+   ::doc/deprecated "1.19"}
   [{:keys [::db/pool]} {:keys [::rpc/profile-id file-id revn]}]
   (dm/with-open [conn (db/open pool)]
     (files/check-read-permissions! conn profile-id file-id)
     (-> (get-file-thumbnail conn file-id revn)
         (rph/with-http-cache long-cache-duration))))
 
-
 ;; --- COMMAND QUERY: get-file-data-for-thumbnail
 
-;; FIXME: performance issue, handle new media_id
-;;
 ;; We need to improve how we set frame for thumbnail in order to avoid
 ;; loading all pages into memory for find the frame set for thumbnail.
 
@@ -148,8 +144,8 @@
                  (run! pmap/load!))
 
             ;; Then proceed to find the frame set for thumbnail
-
-            (d/seek :use-for-thumbnail?
+            (d/seek #(or (:use-for-thumbnail %)
+                         (:use-for-thumbnail? %)) ; NOTE: backward comp (remove on v1.21)
                     (for [page  (-> data :pages-index vals)
                           frame (-> page :objects ctt/get-frames)]
                       (assoc frame :page-id (:id page)))))
@@ -168,18 +164,18 @@
                    frames  (filter cph/frame-shape? (vals objects))]
 
               (if-let [frame  (-> frames first)]
-                (let [frame-id (:id frame)
+                (let [frame-id  (:id frame)
                       object-id (str page-id frame-id)
-                      frame (if-let [thumb (get thumbnails object-id)]
-                              (assoc frame :thumbnail thumb :shapes [])
-                              (dissoc frame :thumbnail))
+                      frame     (if-let [thumb (get thumbnails object-id)]
+                                  (assoc frame :thumbnail thumb :shapes [])
+                                  (dissoc frame :thumbnail))
 
                       children-ids
                       (cph/get-children-ids objects frame-id)
 
                       bounds
                       (when (:show-content frame)
-                        (gsh/selection-rect (concat [frame] (->> children-ids (map (d/getf objects))))))
+                        (gsh/shapes->rect (cons frame (map (d/getf objects) children-ids))))
 
                       frame
                       (cond-> frame
@@ -221,18 +217,24 @@
           :always
           (update :objects assoc-thumbnails page-id thumbs))))))
 
+(def ^:private schema:get-file-data-for-thumbnail
+  [:map {:title "get-file-data-for-thumbnail"}
+   [:file-id ::sm/uuid]
+   [:features {:optional true} files/schema:features]])
+
+(def ^:private schema:partial-file
+  [:map {:title "PartialFile"}
+   [:id ::sm/uuid]
+   [:revn {:min 0} :int]
+   [:page :any]])
+
 (sv/defmethod ::get-file-data-for-thumbnail
   "Retrieves the data for generate the thumbnail of the file. Used
   mainly for render thumbnails on dashboard."
-
   {::doc/added "1.17"
-   ::sm/params [:map {:title "get-file-data-for-thumbnail"}
-                [:file-id ::sm/uuid]
-                [:features {:optional true} ::files/features]]
-   ::sm/result [:map {:title "PartialFile"}
-                [:id ::sm/uuid]
-                [:revn {:min 0} :int]
-                [:page :any]]}
+   ::doc/module :files
+   ::sm/params schema:get-file-data-for-thumbnail
+   ::sm/result schema:partial-file}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id features] :as props}]
   (dm/with-open [conn (db/open pool)]
     (files/check-read-permissions! conn profile-id file-id)
@@ -273,6 +275,7 @@
 
 (sv/defmethod ::upsert-file-object-thumbnail
   {::doc/added "1.17"
+   ::doc/module :files
    ::doc/deprecated "1.19"
    ::audit/skip true}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id] :as params}]
@@ -310,14 +313,18 @@
                         (:id media) (:id media)])))
 
 
-(s/def ::media (s/nilable ::media/upload))
-(s/def ::create-file-object-thumbnail
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::file-id ::object-id ::media]))
+(def schema:create-file-object-thumbnail
+  [:map {:title "create-file-object-thumbnail"}
+   [:file-id ::sm/uuid]
+   [:object-id :string]
+   [:media ::media/upload]])
 
 (sv/defmethod ::create-file-object-thumbnail
   {:doc/added "1.19"
-   ::audit/skip true}
+   ::doc/module :files
+   ::audit/skip true
+   ::sm/params schema:create-file-object-thumbnail}
+
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id object-id media]}]
   (db/with-atomic [conn pool]
     (files/check-edition-permissions! conn profile-id file-id)
@@ -353,6 +360,7 @@
 
 (sv/defmethod ::delete-file-object-thumbnail
   {:doc/added "1.19"
+   ::doc/module :files
    ::audit/skip true}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id object-id]}]
 
@@ -380,7 +388,6 @@
     (db/exec-one! conn [sql:upsert-file-thumbnail
                         file-id revn data props data props])))
 
-
 (s/def ::revn ::us/integer)
 (s/def ::props map?)
 
@@ -392,6 +399,7 @@
   "Creates or updates the file thumbnail. Mainly used for paint the
   grid thumbnails."
   {::doc/added "1.17"
+   ::doc/module :files
    ::doc/deprecated "1.19"
    ::audit/skip true}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id] :as params}]
@@ -427,24 +435,28 @@
                                 :bucket "file-thumbnail"})]
     (db/exec-one! conn [sql:create-file-thumbnail file-id revn
                         (:id media) props
-                        (:id media) props])))
-
-(s/def ::media ::media/upload)
-(s/def ::create-file-thumbnail
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::file-id ::revn ::props ::media]))
+                        (:id media) props])
+    media))
 
 (sv/defmethod ::create-file-thumbnail
   "Creates or updates the file thumbnail. Mainly used for paint the
   grid thumbnails."
   {::doc/added "1.19"
-   ::audit/skip true}
+   ::doc/module :files
+   ::audit/skip true
+   ::sm/params [:map {:title "create-file-thumbnail"}
+                [:file-id ::sm/uuid]
+                [:revn :int]
+                [:media ::media/upload]]
+   }
+
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id] :as params}]
   (db/with-atomic [conn pool]
     (files/check-edition-permissions! conn profile-id file-id)
     (when-not (db/read-only? conn)
-      (-> cfg
-          (update ::sto/storage media/configure-assets-storage)
-          (assoc ::db/conn conn)
-          (create-file-thumbnail! params))
-      nil)))
+      (let [media (-> cfg
+                      (update ::sto/storage media/configure-assets-storage)
+                      (assoc ::db/conn conn)
+                      (create-file-thumbnail! params))]
+
+        {:uri (files/resolve-public-uri (:id media))}))))

backend/src/app/rpc/commands/files_update.clj

@@ -8,13 +8,12 @@
   (:require
    [app.common.exceptions :as ex]
    [app.common.files.features :as ffeat]
+   [app.common.files.migrations :as pmg]
    [app.common.logging :as l]
    [app.common.pages :as cp]
    [app.common.pages.changes :as cpc]
-   [app.common.pages.migrations :as pmg]
    [app.common.schema :as sm]
    [app.common.schema.generators :as smg]
-   [app.common.spec :as us]
    [app.common.types.file :as ctf]
    [app.common.uuid :as uuid]
    [app.config :as cf]
@@ -32,37 +31,7 @@
    [app.util.objects-map :as omap]
    [app.util.pointer-map :as pmap]
    [app.util.services :as sv]
-   [app.util.time :as dt]
-   [clojure.spec.alpha :as s]))
-
-;; --- SPECS
-
-(s/def ::changes
-  (s/coll-of map? :kind vector?))
-
-(s/def ::hint-origin ::us/keyword)
-(s/def ::hint-events
-  (s/every ::us/keyword :kind vector?))
-
-(s/def ::change-with-metadata
-  (s/keys :req-un [::changes]
-          :opt-un [::hint-origin
-                   ::hint-events]))
-
-(s/def ::changes-with-metadata
-  (s/every ::change-with-metadata :kind vector?))
-
-(s/def ::session-id ::us/uuid)
-(s/def ::revn ::us/integer)
-(s/def ::update-file
-  (s/and
-   (s/keys :req [::rpc/profile-id]
-           :req-un [::files/id ::session-id ::revn]
-           :opt-un [::changes ::changes-with-metadata ::features])
-   (fn [o]
-     (or (contains? o :changes)
-         (contains? o :changes-with-metadata)))))
-
+   [app.util.time :as dt]))
 
 ;; --- SCHEMA
 
@@ -155,6 +124,7 @@
 (declare send-notifications!)
 (declare update-file)
 (declare update-file*)
+(declare update-file-data)
 (declare take-snapshot?)
 
 ;; If features are specified from params and the final feature
@@ -177,6 +147,7 @@
   (db/with-atomic [conn pool]
     (files/check-edition-permissions! conn profile-id id)
     (db/xact-lock! conn id)
+
     (let [cfg    (assoc cfg ::db/conn conn)
           params (assoc params :profile-id profile-id)
           tpoint (dt/tpoint)]
@@ -238,26 +209,6 @@
                         :project-id (:project-id file)
                         :team-id    (:team-id file)}))))))
 
-(defn- update-file-data
-  [file changes]
-  (-> file
-      (update :revn inc)
-      (update :data (fn [data]
-                      (cond-> data
-                        :always
-                        (-> (blob/decode)
-                            (assoc :id (:id file))
-                            (pmg/migrate-data))
-
-                        (and (contains? ffeat/*current* "components/v2")
-                             (not (contains? ffeat/*previous* "components/v2")))
-                        (ctf/migrate-to-components-v2)
-
-                        :always
-                        (-> (cp/process-changes changes)
-                            (blob/encode)))))))
-
-
 (defn- update-file*
   [{:keys [::db/conn] :as cfg} {:keys [profile-id file changes session-id ::created-at] :as params}]
   (let [;; Process the file data in the CLIMIT context; scheduling it
@@ -297,6 +248,25 @@
       ;; Retrieve and return lagged data
       (get-lagged-changes conn params))))
 
+(defn- update-file-data
+  [file changes]
+  (-> file
+      (update :revn inc)
+      (update :data (fn [data]
+                      (cond-> data
+                        :always
+                        (-> (blob/decode)
+                            (assoc :id (:id file))
+                            (pmg/migrate-data))
+
+                        (and (contains? ffeat/*current* "components/v2")
+                             (not (contains? ffeat/*previous* "components/v2")))
+                        (ctf/migrate-to-components-v2)
+
+                        :always
+                        (-> (cp/process-changes changes)
+                            (blob/encode)))))))
+
 (defn- take-snapshot?
   "Defines the rule when file `data` snapshot should be saved."
   [{:keys [revn modified-at] :as file}]

backend/src/app/rpc/commands/fonts.clj

@@ -36,6 +36,7 @@
 (s/def ::id ::us/uuid)
 (s/def ::name ::us/not-empty-string)
 (s/def ::project-id ::us/uuid)
+(s/def ::share-id ::us/uuid)
 (s/def ::style valid-style)
 (s/def ::team-id ::us/uuid)
 (s/def ::weight valid-weight)
@@ -47,7 +48,8 @@
    (s/keys :req [::rpc/profile-id]
            :opt-un [::team-id
                     ::file-id
-                    ::project-id])
+                    ::project-id
+                    ::share-id])
    (fn [o]
      (or (contains? o :team-id)
          (contains? o :file-id)
@@ -55,7 +57,7 @@
 
 (sv/defmethod ::get-font-variants
   {::doc/added "1.18"}
-  [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id file-id project-id] :as params}]
+  [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id file-id project-id share-id] :as params}]
   (dm/with-open [conn (db/open pool)]
     (cond
       (uuid? team-id)
@@ -74,11 +76,12 @@
 
       (uuid? file-id)
       (let [file    (db/get-by-id conn :file file-id {:columns [:id :project-id]})
-            project (db/get-by-id conn :project (:project-id file) {:columns [:id :team-id]})]
-        (files/check-read-permissions! conn profile-id file-id)
+            project (db/get-by-id conn :project (:project-id file) {:columns [:id :team-id]})
+            perms   (files/get-permissions conn profile-id file-id share-id)]
+        (files/check-read-permissions! perms)
         (db/query conn :team-font-variant
-                  {:team-id (:team-id project)
-                   :deleted-at nil})))))
+          {:team-id (:team-id project)
+           :deleted-at nil})))))
 
 
 (declare create-font-variant)

backend/src/app/rpc/commands/ldap.clj

@@ -38,7 +38,8 @@
   "Performs the authentication using LDAP backend. Only works if LDAP
   is properly configured and enabled with `login-with-ldap` flag."
   {::rpc/auth false
-   ::doc/added "1.15"}
+   ::doc/added "1.15"
+   ::doc/module :auth}
   [{:keys [::main/props ::ldap/provider] :as cfg} params]
   (when-not provider
     (ex/raise :type :restriction

backend/src/app/rpc/commands/management.clj

@@ -9,7 +9,8 @@
   (:require
    [app.common.data :as d]
    [app.common.exceptions :as ex]
-   [app.common.pages.migrations :as pmg]
+   [app.common.files.migrations :as pmg]
+   [app.common.schema :as sm]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
    [app.db :as db]
@@ -20,12 +21,15 @@
    [app.rpc.commands.projects :as proj]
    [app.rpc.commands.teams :as teams :refer [create-project-role create-project]]
    [app.rpc.doc :as-alias doc]
+   [app.setup :as-alias setup]
+   [app.setup.templates :as tmpl]
    [app.util.blob :as blob]
    [app.util.pointer-map :as pmap]
    [app.util.services :as sv]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
-   [clojure.walk :as walk]))
+   [clojure.walk :as walk]
+   [promesa.exec :as px]))
 
 ;; --- COMMAND: Duplicate File
 
@@ -233,7 +237,7 @@
 
   (let [project (-> (db/get-by-id conn :project project-id)
                     (assoc :is-pinned false))
-        
+
         files   (db/query conn :file
                   {:project-id (:id project)
                    :deleted-at nil}
@@ -319,6 +323,18 @@
     ;; delete possible broken relations on moved files
     (db/exec-one! conn [sql:delete-broken-relations pids])
 
+    ;; Update the modification date of the all affected projects
+    ;; ensuring that the destination project is the most recent one.
+    (doseq [project-id (into (list project-id) source)]
+
+      ;; NOTE: as this is executed on virtual thread, sleeping does
+      ;; not causes major issues, and allows an easy way to set a
+      ;; trully different modification date to each file.
+      (px/sleep 10)
+      (db/update! conn :project
+                  {:modified-at (dt/now)}
+                  {:id project-id}))
+
     nil))
 
 (s/def ::ids (s/every ::us/uuid :kind set?))
@@ -361,7 +377,6 @@
 
     nil))
 
-
 (s/def ::move-project
   (s/keys :req [::rpc/profile-id]
           :req-un [::team-id ::project-id]))
@@ -376,46 +391,54 @@
 
 ;; --- COMMAND: Clone Template
 
-(declare clone-template)
-
-(s/def ::template-id ::us/not-empty-string)
-(s/def ::clone-template
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::project-id ::template-id]))
-
-(sv/defmethod ::clone-template
-  "Clone into the specified project the template by its id."
-  {::doc/added "1.16"
-   ::webhooks/event? true}
-  [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id] :as params}]
-  (db/with-atomic [conn pool]
-    (-> (assoc cfg :conn conn)
-        (clone-template (assoc params :profile-id profile-id)))))
-
-(defn- clone-template
-  [{:keys [conn templates] :as cfg} {:keys [profile-id template-id project-id]}]
-  (let [template (d/seek #(= (:id %) template-id) templates)
+(defn- clone-template!
+  [{:keys [::db/conn] :as cfg} {:keys [profile-id template-id project-id]}]
+  (let [template (tmpl/get-template-stream cfg template-id)
         project  (db/get-by-id conn :project project-id {:columns [:id :team-id]})]
 
-    (teams/check-edition-permissions! conn profile-id (:team-id project))
-
     (when-not template
       (ex/raise :type :not-found
                 :code :template-not-found
                 :hint "template not found"))
 
+    (teams/check-edition-permissions! conn profile-id (:team-id project))
+
     (-> cfg
-        (assoc ::binfile/input (:path template))
+        ;; FIXME: maybe reuse the conn instead of creating more
+        ;; connections in the import process?
+        (dissoc ::db/conn)
+        (assoc ::binfile/input template)
         (assoc ::binfile/project-id (:id project))
         (assoc ::binfile/ignore-index-errors? true)
         (assoc ::binfile/migrate? true)
         (binfile/import!))))
 
+(def schema:clone-template
+  [:map {:title "clone-template"}
+   [:project-id ::sm/uuid]
+   [:template-id ::sm/word-string]])
 
-;; --- COMMAND: Retrieve list of builtin templates
+(sv/defmethod ::clone-template
+  "Clone into the specified project the template by its id."
+  {::doc/added "1.16"
+   ::webhooks/event? true
+   ::sm/params schema:clone-template}
+  [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id] :as params}]
+  (db/with-atomic [conn pool]
+    (-> (assoc cfg ::db/conn conn)
+        (clone-template! (assoc params :profile-id profile-id)))))
+
+;; --- COMMAND: Get list of builtin templates
 
 (s/def ::retrieve-list-of-builtin-templates any?)
 
 (sv/defmethod ::retrieve-list-of-builtin-templates
+  {::doc/added "1.10"
+   ::doc/deprecated "1.19"}
   [cfg _params]
-  (mapv #(select-keys % [:id :name :thumbnail-uri]) (:templates cfg)))
+  (mapv #(select-keys % [:id :name]) (::setup/templates cfg)))
+
+(sv/defmethod ::get-builtin-templates
+  {::doc/added "1.19"}
+  [cfg _params]
+  (mapv #(select-keys % [:id :name]) (::setup/templates cfg)))

backend/src/app/rpc/commands/media.clj

@@ -171,7 +171,8 @@
           :opt-un [::id ::name]))
 
 (sv/defmethod ::create-file-media-object-from-url
-  {::doc/added "1.17"}
+  {::doc/added "1.17"
+   ::doc/deprecated "1.19"}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id] :as params}]
   (let [cfg (update cfg ::sto/storage media/configure-assets-storage)]
     (files/check-edition-permissions! pool profile-id file-id)

backend/src/app/rpc/commands/profile.clj

@@ -27,7 +27,6 @@
    [app.tokens :as tokens]
    [app.util.services :as sv]
    [app.util.time :as dt]
-   [clojure.spec.alpha :as s]
    [cuerdas.core :as str]))
 
 (declare check-profile-existence!)
@@ -41,7 +40,7 @@
 (def schema:profile
   [:map {:title "Profile"}
    [:id ::sm/uuid]
-   [:fullname :string]
+   [:fullname [::sm/word-string {:max 250}]]
    [:email ::sm/email]
    [:is-active {:optional true} :boolean]
    [:is-blocked {:optional true} :boolean]
@@ -82,12 +81,15 @@
 
 ;; --- MUTATION: Update Profile (own)
 
+(def schema:update-profile
+  [:map {:title "update-profile"}
+   [:fullname [::sm/word-string {:max 250}]]
+   [:lang {:optional true} [:string {:max 5}]]
+   [:theme {:optional true} [:string {:max 250}]]])
+
 (sv/defmethod ::update-profile
   {::doc/added "1.0"
-   ::sm/params [:map {:title "UpdateProfileParams"}
-                [:fullname {:min 1} :string]
-                [:lang {:optional true} :string]
-                [:theme {:optional true} :string]]
+   ::sm/params schema:update-profile
    ::sm/result schema:profile}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id fullname lang theme] :as params}]
 
@@ -128,11 +130,15 @@
 (declare update-profile-password!)
 (declare invalidate-profile-session!)
 
+(def schema:update-profile-password
+  [:map {:title "update-profile-password"}
+   [:password [::sm/word-string {:max 500}]]
+   ;; Social registered users don't have old-password
+   [:old-password {:optional true} [:maybe [::sm/word-string {:max 500}]]]])
+
 (sv/defmethod ::update-profile-password
   {:doc/added "1.0"
-   ::sm/params [:map {:title "UpdateProfilePasswordParams"}
-                [:password :string]
-                [:old-password :string]]
+   ::sm/params schema:update-profile-password
    ::sm/result :nil}
 
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id password] :as params}]
@@ -178,10 +184,13 @@
 (declare upload-photo)
 (declare update-profile-photo)
 
+(def schema:update-profile-photo
+  [:map {:title "update-profile-photo"}
+   [:file ::media/upload]])
+
 (sv/defmethod ::update-profile-photo
   {:doc/added "1.1"
-   ::sm/params [:map {:title "UpdateProfilePhotoParams"}
-                [:file ::media/upload]]
+   ::sm/params schema:update-profile-photo
    ::sm/result :nil}
   [cfg {:keys [::rpc/profile-id file] :as params}]
   ;; Validate incoming mime type
@@ -239,11 +248,13 @@
 (declare ^:private request-email-change!)
 (declare ^:private change-email-immediately!)
 
-(s/def ::request-email-change
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::email]))
+(def schema:request-email-change
+  [:map {:title "request-email-change"}
+   [:email ::sm/email]])
 
 (sv/defmethod ::request-email-change
+  {::doc/added "1.0"
+   ::sm/params schema:request-email-change}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id email] :as params}]
   (db/with-atomic [conn pool]
     (let [profile (db/get-by-id conn :profile profile-id)
@@ -304,12 +315,13 @@
 
 ;; --- MUTATION: Update Profile Props
 
-(s/def ::props map?)
-(s/def ::update-profile-props
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::props]))
+(def schema:update-profile-props
+  [:map {:title "update-profile-props"}
+   [:props [:map-of :keyword :any]]])
 
 (sv/defmethod ::update-profile-props
+  {::doc/added "1.0"
+   ::sm/params schema:update-profile-props}
   [{:keys [::db/pool]} {:keys [::rpc/profile-id props]}]
   (db/with-atomic [conn pool]
     (let [profile (get-profile conn profile-id ::db/for-update? true)
@@ -329,15 +341,12 @@
 
       (filter-props props))))
 
-
 ;; --- MUTATION: Delete Profile
 
 (declare ^:private get-owned-teams-with-participants)
 
-(s/def ::delete-profile
-  (s/keys :req [::rpc/profile-id]))
-
 (sv/defmethod ::delete-profile
+  {::doc/added "1.0"}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id] :as params}]
   (db/with-atomic [conn pool]
     (let [teams      (get-owned-teams-with-participants conn profile-id)

backend/src/app/rpc/commands/search.clj

@@ -64,6 +64,7 @@
           :opt-un [::search-term]))
 
 (sv/defmethod ::search-files
-  {::doc/added "1.17"}
+  {::doc/added "1.17"
+   ::doc/module :files}
   [{:keys [::db/pool]} {:keys [::rpc/profile-id team-id search-term]}]
   (some->> search-term (search-files pool profile-id team-id)))

backend/src/app/rpc/commands/teams.clj

@@ -10,6 +10,7 @@
    [app.common.data.macros :as dm]
    [app.common.exceptions :as ex]
    [app.common.logging :as l]
+   [app.common.schema :as sm]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
    [app.config :as cf]
@@ -719,29 +720,22 @@
 
         itoken))))
 
-(s/def ::email ::us/email)
-(s/def ::emails ::us/set-of-valid-emails)
-(s/def ::create-team-invitations
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::team-id ::role]
-          :opt-un [::email ::emails]))
+(def ^:private schema:create-team-invitations
+  [:map {:title "create-team-invitations"}
+   [:team-id ::sm/uuid]
+   [:role [::sm/one-of #{:owner :admin :editor}]]
+   [:emails ::sm/set-of-emails]])
 
 (sv/defmethod ::create-team-invitations
   "A rpc call that allow to send a single or multiple invitations to
   join the team."
-  {::doc/added "1.17"}
-  [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id email emails role] :as params}]
+  {::doc/added "1.17"
+   ::sm/params schema:create-team-invitations}
+  [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id emails role] :as params}]
   (db/with-atomic [conn pool]
     (let [perms    (get-permissions conn profile-id team-id)
           profile  (db/get-by-id conn :profile profile-id)
-          team     (db/get-by-id conn :team team-id)
-
-          ;; Members emails. We don't re-send inviation to already existing members
-          member?  (into #{}
-                         (map :email)
-                         (db/exec! conn [sql:team-members team-id]))
-
-          emails   (cond-> (or emails #{}) (string? email) (conj email))]
+          team     (db/get-by-id conn :team team-id)]
 
       (run! (partial quotes/check-quote! conn)
             (list {::quotes/id ::quotes/invitations-per-team
@@ -764,9 +758,13 @@
                   :hint "looks like the profile has reported repeatedly as spam or has permanent bounces"))
 
       (let [cfg         (assoc cfg ::db/conn conn)
-            invitations (into []
+            members     (->> (db/exec! conn [sql:team-members team-id])
+                             (into #{} (map :email)))
+
+            invitations (into #{}
                               (comp
-                               (remove member?)
+                               ;;  We don't re-send inviation to already existing members
+                               (remove (partial contains? members))
                                (map (fn [email]
                                       {:email (str/lower email)
                                        :team team
@@ -774,7 +772,8 @@
                                        :role role}))
                                (keep (partial create-invitation cfg)))
                               emails)]
-        (with-meta invitations
+        (with-meta {:total (count invitations)
+                    :invitations invitations}
           {::audit/props {:invitations (count invitations)}})))))
 
 

backend/src/app/rpc/commands/verify_token.clj

@@ -34,7 +34,8 @@
 
 (sv/defmethod ::verify-token
   {::rpc/auth false
-   ::doc/added "1.15"}
+   ::doc/added "1.15"
+   ::doc/module :auth}
   [{:keys [::db/pool] :as cfg} {:keys [token] :as params}]
   (db/with-atomic [conn pool]
     (let [claims (tokens/verify (::main/props cfg) {:token token})

backend/src/app/rpc/commands/viewer.clj

@@ -83,13 +83,10 @@
   [:map {:title "get-view-only-bundle"}
    [:file-id ::sm/uuid]
    [:share-id {:optional true} ::sm/uuid]
-   [:features {:optional true} ::files/features]])
+   [:features {:optional true} files/schema:features]])
 
 (sv/defmethod ::get-view-only-bundle
   {::rpc/auth false
-   ::cond/get-object #(files/get-minimal-file %1 (:file-id %2))
-   ::cond/key-fn files/get-file-etag
-   ::cond/reuse-key? true
    ::doc/added "1.17"
    ::sm/params ::get-view-only-bundle}
   [{:keys [::db/pool]} {:keys [::rpc/profile-id] :as params}]

backend/src/app/rpc/cond.clj

@@ -27,6 +27,8 @@
    [app.common.logging :as l]
    [app.rpc.helpers :as rph]
    [app.util.services :as-alias sv]
+   [buddy.core.codecs :as bc]
+   [buddy.core.hash :as bh]
    [yetti.response :as yrs]))
 
 (def
@@ -34,9 +36,16 @@
     :doc "Runtime flag for enable/disable conditional processing of RPC methods."}
   *enabled* false)
 
+(defn- encode
+  [s]
+  (-> s
+      bh/blake2b-256
+      bc/bytes->b64u
+      bc/bytes->str))
+
 (defn- fmt-key
   [s]
-  (str "W/\"" s "\""))
+  (str "W/\"" (encode s) "\""))
 
 (defn wrap
   [_ f {:keys [::get-object ::key-fn ::reuse-key?] :as mdata}]
@@ -46,9 +55,8 @@
       (fn [cfg {:keys [::key] :as params}]
         (if *enabled*
           (let [key' (when (or key reuse-key?)
-                       (some-> (get-object cfg params) key-fn fmt-key))]
-            (if (and (some? key)
-                     (= key key'))
+                       (some->> (get-object cfg params) (key-fn params) (fmt-key)))]
+            (if (and (some? key) (= key key'))
               (fn [_] {::yrs/status 304})
               (let [result (f cfg params)
                     etag   (or (and reuse-key? key')

backend/src/app/rpc/doc.clj

@@ -54,14 +54,14 @@
             {:name (::sv/name mdata)
              :module (or (some-> (::module mdata) d/name)
                          (-> (:ns mdata) (str/split ".") last))
-             :auth (:auth mdata true)
+             :auth (::rpc/auth mdata true)
              :webhook (::webhooks/event? mdata false)
              :docs (::sv/docstring mdata)
              :deprecated (::deprecated mdata)
              :added (::added mdata)
              :changes (some->> (::changes mdata) (partition-all 2) (map vec))
              :spec (fmt-spec mdata)
-             :entrypoint (str (cf/get :public-uri) "/api/rpc/commands/" (::sv/name mdata))
+             :entrypoint (str (cf/get :public-uri) "/api/rpc/command/" (::sv/name mdata))
 
              :params-schema-js   (fmt-schema :js mdata ::sm/params)
              :result-schema-js   (fmt-schema :js mdata ::sm/result)
@@ -75,6 +75,7 @@
      (->> methods
           (map val)
           (map first)
+          (remove ::skip)
           (map get-context)
           (sort-by (juxt :module :name)))}))
 
@@ -155,7 +156,7 @@
                          (map (partial gen-method-doc options))
                          (sort-by (juxt :module :name))
                          (map (fn [doc]
-                                [(str/ffmt "/commands/%" (:name doc)) (:repr doc)]))
+                                [(str/ffmt "/command/%" (:name doc)) (:repr doc)]))
                          (into {})))]
     {:openapi "3.0.0"
      :info {:version (:main cf/version)}

backend/src/app/setup.clj

@@ -12,8 +12,8 @@
    [app.common.uuid :as uuid]
    [app.db :as db]
    [app.main :as-alias main]
-   [app.setup.builtin-templates]
    [app.setup.keys :as keys]
+   [app.setup.templates]
    [buddy.core.codecs :as bc]
    [buddy.core.nonce :as bn]
    [clojure.spec.alpha :as s]

backend/src/app/setup/builtin_templates.clj

@@ -1,72 +0,0 @@
-;; This Source Code Form is subject to the terms of the Mozilla Public
-;; License, v. 2.0. If a copy of the MPL was not distributed with this
-;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
-;;
-;; Copyright (c) KALEIDOS INC
-
-(ns app.setup.builtin-templates
-  "A service/module that is responsible for download, load & internally
-  expose a set of builtin penpot file templates."
-  (:require
-   [app.common.logging :as l]
-   [app.common.spec :as us]
-   [app.http.client :as http]
-   [clojure.edn :as edn]
-   [clojure.java.io :as io]
-   [clojure.spec.alpha :as s]
-   [datoteka.fs :as fs]
-   [integrant.core :as ig]))
-
-(declare download-all!)
-
-(s/def ::id ::us/not-empty-string)
-(s/def ::name ::us/not-empty-string)
-(s/def ::thumbnail-uri ::us/not-empty-string)
-(s/def ::file-uri ::us/not-empty-string)
-(s/def ::path fs/path?)
-
-(s/def ::template
-  (s/keys :req-un [::id ::name ::thumbnail-uri ::file-uri]
-          :opt-un [::path]))
-
-(defmethod ig/pre-init-spec :app.setup/builtin-templates [_]
-  (s/keys :req [::http/client]))
-
-(defmethod ig/init-key :app.setup/builtin-templates
-  [_ cfg]
-  (let [presets (-> "app/onboarding.edn" io/resource slurp edn/read-string)]
-    (l/info :hint "loading template files" :total (count presets))
-    (let [result (download-all! cfg presets)]
-      (us/conform (s/coll-of ::template) result))))
-
-(defn- download-preset!
-  [cfg {:keys [path file-uri] :as preset}]
-  (let [response (http/req! cfg
-                            {:method :get
-                             :uri file-uri}
-                            {:response-type :input-stream
-                             :sync? true})]
-    (us/verify! (= 200 (:status response)) "unexpected response found on fetching preset")
-    (with-open [output (io/output-stream path)]
-      (with-open [input (io/input-stream (:body response))]
-        (io/copy input output)))))
-
-(defn- download-all!
-  "Download presets to the default directory, if preset is already
-  downloaded, no action will be performed."
-  [cfg presets]
-  (let [dest (fs/join fs/*cwd* "builtin-templates")]
-    (when-not (fs/exists? dest)
-      (fs/create-dir dest))
-
-    (doall
-     (map (fn [item]
-            (let [path (fs/join dest (:id item))
-                  item (assoc item :path path)]
-              (if (fs/exists? path)
-                (l/trace :hint "template file already present" :id (:id item))
-                (do
-                  (l/trace :hint "downloading template file" :id (:id item) :dest (str path))
-                  (download-preset! cfg item)))
-              item))
-          presets))))

backend/src/app/setup/templates.clj

@@ -0,0 +1,64 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC
+
+(ns app.setup.templates
+  "A service/module that is responsible for download, load & internally
+  expose a set of builtin penpot file templates."
+  (:require
+   [app.common.data :as d]
+   [app.common.data.macros :as dm]
+   [app.common.logging :as l]
+   [app.common.schema :as sm]
+   [app.http.client :as http]
+   [app.setup :as-alias setup]
+   [clojure.edn :as edn]
+   [clojure.java.io :as io]
+   [datoteka.fs :as fs]
+   [integrant.core :as ig]))
+
+(def ^:private schema:template
+  [:map {:title "Template"}
+   [:id ::sm/word-string]
+   [:name ::sm/word-string]
+   [:file-uri ::sm/word-string]])
+
+(def ^:private schema:templates
+  [:vector schema:template])
+
+(defmethod ig/init-key ::setup/templates
+  [_ _]
+  (let [templates (-> "app/onboarding.edn" io/resource slurp edn/read-string)
+        dest      (fs/join fs/*cwd* "builtin-templates")]
+
+    (dm/verify!
+     "expected a valid templates file"
+     (sm/valid? schema:templates templates))
+
+    (doseq [{:keys [id path] :as template} templates]
+      (let [path (or path (fs/join dest id))]
+        (if (fs/exists? path)
+          (l/debug :hint "template file" :id id :state "present" :path (dm/str path))
+          (l/debug :hint "template file" :id id :state "absent"))))
+
+    templates))
+
+(defn get-template-stream
+  [cfg template-id]
+  (when-let [template (d/seek #(= (:id %) template-id)
+                              (::setup/templates cfg))]
+    (let [dest (fs/join fs/*cwd* "builtin-templates")
+          path (or (:path template) (fs/join dest template-id))]
+      (if (fs/exists? path)
+        (io/input-stream path)
+        (let [resp (http/req! cfg
+                              {:method :get :uri (:file-uri template)}
+                              {:response-type :input-stream :sync? true})]
+
+          (dm/verify!
+           "unexpected response found on fetching template"
+           (= 200 (:status resp)))
+
+          (io/input-stream (:body resp)))))))

backend/src/app/srepl/fixes.clj

@@ -7,9 +7,35 @@
 (ns app.srepl.fixes
   "A collection of adhoc fixes scripts."
   (:require
+   [app.common.data :as d]
+   [app.common.files.validate :as cfv]
+   [app.common.geom.shapes :as gsh]
    [app.common.logging :as l]
+   [app.common.pages.helpers :as cph]
+   [app.common.pprint :refer [pprint]]
+   [app.common.types.component :as ctk]
+   [app.common.types.container :as ctn]
+   [app.common.types.file :as ctf]
    [app.common.uuid :as uuid]
-   [app.srepl.helpers :as h]))
+   [app.db :as db]
+   [app.rpc.commands.files :as files]
+   [app.srepl.helpers :as h]
+   [app.util.blob :as blob]))
+
+(defn validate-file
+  [file]
+  (let [libs (->> (files/get-file-libraries app.srepl.helpers/*conn* (:id file))
+                  (cons file)
+                  (map #(files/get-file app.srepl.helpers/*conn* (:id %) (:features file)))
+                  (d/index-by :id))
+
+        update-page (fn [page]
+                      (let [errors (cfv/validate-shape uuid/zero file page libs)]
+                        (when (seq errors)
+                          (println "******Errors in file " (:id file) " page " (:id page))
+                          (pprint errors {:level 3}))))]
+
+    (update file :data h/update-pages update-page)))
 
 (defn repair-orphaned-shapes
   "There are some shapes whose parent has been deleted. This function
@@ -72,4 +98,303 @@
 
    ([file state]
     (rename-layout-attrs file)
-    (update state :total (fnil inc 0))))
+    (update state :total (fnil inc 0))))
+
+(defn fix-components-shaperefs
+  ([file]
+   (if-not (contains? (:features file) "components/v2")
+     (do
+       (println "   This file is not v2")
+       file)
+     (let [libs (->> (files/get-file-libraries app.srepl.helpers/*conn* (:id file))
+                     (cons file)
+                     (map #(files/get-file app.srepl.helpers/*conn* (:id %) (:features file)))
+                     (d/index-by :id))
+
+           fix-copy-item
+           (fn fix-copy-item [allow-head shapes-copy shapes-base copy-id base-id]
+             (let [copy (first (filter #(= (:id %) copy-id) shapes-copy))
+                  ;; do nothing if it is a copy inside of a copy. It will be treated later
+                   stop? (and (not allow-head) (ctk/instance-head? copy))
+                   base (first (filter #(= (:id %) base-id) shapes-base))
+                   fci (partial fix-copy-item false shapes-copy shapes-base)
+
+                   updates (if (and
+                                (not stop?)
+                                (not= (:shape-ref copy) base-id))
+                             [[(:id copy) base-id]]
+                             [])
+
+                   child-updates (if (and
+                                      (not stop?)
+                                      ;; If the base has the same number of childrens than the copy, we asume
+                                      ;; that the shaperefs can be fixed ad pointed in the same order
+                                      (= (count (:shapes copy)) (count (:shapes base))))
+                                   (apply concat (map fci (:shapes copy) (:shapes base)))
+                                   [])]
+               (concat updates child-updates)))
+
+           fix-copy
+           (fn [objects updates copy]
+             (let [component        (ctf/find-component libs (:component-id copy) {:include-deleted? true})
+                   component-file   (get libs (:component-file copy))
+                   component-shapes (ctf/get-component-shapes (:data component-file) component)
+                   copy-shapes      (cph/get-children-with-self objects (:id copy))
+
+                   copy-updates (fix-copy-item true copy-shapes component-shapes (:id copy) (:main-instance-id component))]
+               (concat updates copy-updates)))
+
+           update-page
+           (fn [page]
+             (let [objects      (:objects page)
+                   fc           (partial fix-copy objects)
+                   copies       (->> objects
+                                     vals
+                                     (filter #(and (ctk/instance-head? %) (not (ctk/main-instance? %)))))
+                   updates      (reduce fc [] copies)
+                   updated-page (reduce (fn [p [id shape-ref]]
+                                          (assoc-in p [:objects id :shape-ref] shape-ref))
+                                        page
+                                        updates)]
+               (println "Page " (:name page) " - Fixing " (count updates))
+               updated-page))]
+
+       (println "Updating " (:name file) (:id file))
+       (-> file
+           (update :data h/update-pages update-page)
+           (assoc ::updated true)))))
+
+  ([file save?]
+   (let [file (-> file
+                  (update :data blob/decode)
+                  (fix-components-shaperefs))]
+     (when (and save? (::updated file))
+       (let [data     (blob/encode (:data file))]
+         (db/update! h/*conn* :file
+                     {:data data
+                      ;; :revn (:revn file)
+                      }
+                     {:id (:id file)})
+
+         (files/persist-pointers! h/*conn* (:id file)))))))
+
+(defn fix-component-root
+  ([file]
+   (let [update-shape (fn [page shape]
+                        (let [parent (get (:objects page) (:parent-id shape))]
+                          (if (and parent
+                                   (:component-root shape)
+                                   (:shape-ref parent))
+                            (do
+                              (println "   Shape " (:name shape) (:id shape))
+                              (dissoc shape :component-root))
+                            shape)))
+
+         update-page (fn [page]
+                       (println "Page " (:name page))
+                       (h/update-shapes page (partial update-shape page)))]
+
+     (println "Updating " (:name file) (:id file))
+     (update file :data h/update-pages update-page)))
+
+  ([file save?]
+   (let [file (-> file
+                  (update :data blob/decode)
+                  (fix-component-root))]
+     (when save?
+       (let [data     (blob/encode (:data file))]
+         (db/update! h/*conn* :file
+                     {:data data
+                      ;; :revn (:revn file)
+                      }
+                     {:id (:id file)})
+
+         (files/persist-pointers! h/*conn* (:id file)))))))
+
+(defn update-near-components
+  ([file]
+   (println "Updating " (:name file) (:id file))
+   (if-not (contains? (:features file) "components/v2")
+     (do
+       (println "   This file is not v2")
+       file)
+     (let [libs (->> (files/get-file-libraries h/*conn* (:id file))
+                     (cons file)
+                     (map #(files/get-file h/*conn* (:id %) (:features file)))
+                     (d/index-by :id))
+
+           update-shape
+           (fn [page shape]
+             (if-not (:shape-ref shape)
+               shape
+               (do
+                 ;; Uncomment println's to debug
+                 ;; (println "  -> Shape " (:name shape) (:id shape) " shape-ref " (:shape-ref shape))
+                 (let [root-shape (ctn/get-copy-root (:objects page) shape)]
+                   (if root-shape
+                     (let [component (ctf/get-component libs (:component-file root-shape) (:component-id root-shape) {:include-deleted? true})
+                           component-file (get libs (:component-file root-shape))
+                           component-shapes (ctf/get-component-shapes (:data component-file) component)
+                           ref-shape (d/seek #(= (:id %) (:shape-ref shape)) component-shapes)]
+                       (if-not (and component component-file component-shapes)
+                         (do
+                           ;; (println "  -> Shape " (:name shape) (:id shape) " shape-ref " (:shape-ref shape))
+                           ;; (when-not component (println "     (component not found)"))
+                           ;; (when-not component-file (println "     (component-file not found)"))
+                           ;; (when-not component-shapes (println "     (component-shapes not found)"))
+                           shape)
+                         (if ref-shape
+                           shape  ; This means that the copy is not nested, or this script already was run
+                           (let [near-shape (d/seek #(= (:shape-ref %) (:shape-ref shape)) component-shapes)]
+                             (if near-shape
+                               (do
+                                 (println "  -> Shape " (:name shape) (:id shape) " shape-ref " (:shape-ref shape))
+                                 (println "     new ref-shape " (:id near-shape))
+                                 (assoc shape :shape-ref (:id near-shape)))
+                               (do
+                                 ;; We assume in this case that this is a fostered sub instance, so we do nothing
+                                 ;; (println "  -> Shape " (:name shape) (:id shape) " shape-ref " (:shape-ref shape))
+                                 ;; (println  (near-shape not found)")
+                                 shape))))))
+                     (do
+                       ;; (println "  -> Shape " (:name shape) (:id shape) " shape-ref " (:shape-ref shape))
+                       ;; (println "     (root shape not found)")
+                       shape))))))
+
+           update-page
+           (fn [page]
+             (println "Page " (:name page))
+             (h/update-shapes page (partial update-shape page)))]
+
+       (-> file
+           (update :data h/update-pages update-page)
+           (assoc ::updated true)))))
+
+  ([file save?]
+   (let [file (-> file
+                  (update :data blob/decode)
+                  (update-near-components))]
+     (when (and save? (::updated file))
+       (let [data     (blob/encode (:data file))]
+         (db/update! h/*conn* :file
+                     {:data data
+                      ;; :revn (:revn file)
+                      }
+                     {:id (:id file)})
+
+         (files/persist-pointers! h/*conn* (:id file)))))))
+
+(defn fix-main-shape-name
+  ([file]
+   (println "Updating " (:name file) (:id file))
+   (if-not (contains? (:features file) "components/v2")
+     (do
+       (println "   This file is not v2")
+       file)
+     (let [libs (->> (files/get-file-libraries h/*conn* (:id file))
+                     (cons file)
+                     (map #(files/get-file h/*conn* (:id %) (:features file)))
+                     (d/index-by :id))
+
+           update-shape
+           (fn [shape]
+             (if-not (ctk/instance-head? shape)
+               shape
+               (let [component (ctf/get-component libs (:component-file shape) (:component-id shape) {:include-deleted? true})
+                     [_path name] (cph/parse-path-name (:name shape))
+                     full-name (cph/clean-path (str (:path component) "/" (:name component)))]
+                 (if (= name (:name component))
+                   (assoc shape :name full-name)
+                   shape))))
+
+
+           update-page
+           (fn [page]
+             (println "Page " (:name page))
+             (h/update-shapes page update-shape))]
+
+       (-> file
+           (update :data h/update-pages update-page)
+           (assoc ::updated true)))))
+
+  ([file save?]
+   (let [file (-> file
+                  (update :data blob/decode)
+                  (fix-main-shape-name))]
+     (when (and save? (::updated file))
+       (let [data     (blob/encode (:data file))]
+         (db/update! h/*conn* :file
+                     {:data data
+                      ;; :revn (:revn file)
+                      }
+                     {:id (:id file)})
+
+         (files/persist-pointers! h/*conn* (:id file)))))))
+
+(defn fix-touched
+  "For all copies, compare all synced attributes with the main, and set the touched attribute if needed."
+  ([file]
+   (let [libraries (->> (files/get-file-libraries app.srepl.helpers/*conn* (:id file))
+                        (map #(files/get-file app.srepl.helpers/*conn* (:id %) (:features file)))
+                        (d/index-by :id))
+
+         update-shape (fn [page shape]
+                        (if (ctk/in-component-copy? shape)
+                          (let [ref-shape (ctf/find-ref-shape file
+                                                              (:objects page)
+                                                              libraries
+                                                              shape
+                                                              :include-deleted? true)
+                                fix-touched-attr
+                                (fn [shape [attr group]]
+                                  (if (nil? ref-shape)
+                                    shape
+                                    (let [equal?
+                                          (if (= group :geometry-group)
+                                            (if (#{:width :height} attr)
+                                              (gsh/close-attrs? attr (get shape attr) (get ref-shape attr) 1)
+                                              true)
+                                            (gsh/close-attrs? attr (get shape attr) (get ref-shape attr)))]
+                                      (when (and (not equal?) (not (cph/touched-group? shape group)))
+                                        (println " -> set touched " (:name shape) (:id shape) attr group))
+                                      (cond-> shape
+                                        (and (not equal?) (not (cph/touched-group? shape group)))
+                                        (update :touched cph/set-touched-group group)))))
+                                
+                                fix-touched-children
+                                (fn [shape]
+                                  (let [matches? (fn [[child-id ref-child-id]]
+                                                   (let [child (ctn/get-shape page child-id)]
+                                                     (= (:shape-ref child) ref-child-id)))
+                                        equal? (every? matches? (d/zip (:shapes shape) (:shapes ref-shape)))]
+                                      (when (and (not equal?) (not (cph/touched-group? shape :shapes)))
+                                        (println " -> set touched " (:name shape) (:id shape) :shapes :shapes-group))
+                                      (cond-> shape
+                                        (and (not equal?) (not (cph/touched-group? shape :shapes-group)))
+                                        (update :touched cph/set-touched-group :shapes-group))))]
+
+                            (as-> shape $
+                              (reduce fix-touched-attr $ ctk/sync-attrs)
+                              (fix-touched-children $)))
+
+                          shape))
+
+         update-page (fn [page]
+                       (println "Page " (:name page))
+                       (h/update-shapes page (partial update-shape page)))]
+
+     (println "Updating " (:name file) (:id file))
+     (update file :data h/update-pages update-page)))
+
+  ([file save?]
+   (let [file (-> file
+                  (update :data blob/decode)
+                  (fix-touched))]
+     (when save?
+       (let [data     (blob/encode (:data file))]
+         (db/update! h/*conn* :file
+                     {:data data
+                      :revn (inc (:revn file))}
+                     {:id (:id file)})
+
+         (files/persist-pointers! h/*conn* (:id file)))))))

backend/src/app/srepl/helpers.clj

@@ -6,15 +6,16 @@
 
 (ns app.srepl.helpers
   "A  main namespace for server repl."
+  (:refer-clojure :exclude [parse-uuid])
   #_:clj-kondo/ignore
   (:require
    [app.auth :refer [derive-password]]
    [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.files.features :as ffeat]
+   [app.common.files.migrations :as pmg]
    [app.common.logging :as l]
    [app.common.pages :as cp]
-   [app.common.pages.migrations :as pmg]
    [app.common.pprint :refer [pprint]]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
@@ -31,9 +32,32 @@
    [clojure.stacktrace :as strace]
    [clojure.walk :as walk]
    [cuerdas.core :as str]
-   [expound.alpha :as expound]))
+   [expound.alpha :as expound]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [promesa.exec.csp :as sp]))
 
-(def ^:dynamic *conn*)
+(def ^:dynamic *conn* nil)
+
+(defn println!
+  [& params]
+  (locking println
+    (apply println params)))
+
+(defn parse-uuid
+  [v]
+  (if (uuid? v)
+    v
+    (d/parse-uuid v)))
+
+(defn resolve-connectable
+  [o]
+  (if (db/connection? o)
+    o
+    (if (db/pool? o)
+      o
+      (or (::db/conn o)
+          (::db/pool o)))))
 
 (defn reset-password!
   "Reset a password to a specific one for a concrete user or all users
@@ -100,7 +124,7 @@
           (dissoc file :data))))))
 
 (def ^:private sql:retrieve-files-chunk
-  "SELECT id, name, created_at, data FROM file
+  "SELECT id, name, features, created_at, revn, data FROM file
     WHERE created_at < ? AND deleted_at is NULL
     ORDER BY created_at desc LIMIT ?")
 
@@ -110,7 +134,7 @@
 
   The `on-file` parameter should be a function that receives the file
   and the previous state and returns the new state."
-  [system & {:keys [chunk-size max-items start-at on-file on-error on-end]
+  [system & {:keys [chunk-size max-items start-at on-file on-error on-end on-init]
              :or {chunk-size 10 max-items Long/MAX_VALUE}}]
   (letfn [(get-chunk [conn cursor]
             (let [rows (db/exec! conn [sql:retrieve-files-chunk cursor chunk-size])]
@@ -122,26 +146,111 @@
                               :kf first
                               :initk (or start-at (dt/now)))
                  (take max-items)
-                 (map #(update % :data blob/decode))))
+                 (map #(-> %
+                           (update :data blob/decode)
+                           (update :features db/decode-pgarray #{})))))
 
-          (on-error* [file cause]
+          (on-error* [cause file]
             (println "unexpected exception happened on processing file: " (:id file))
             (strace/print-stack-trace cause))]
 
-    (db/with-atomic [conn (:app.db/pool system)]
-      (loop [state {}
-             files (get-candidates conn)]
-        (if-let [file (first files)]
-          (let [state' (try
-                         (on-file file state)
-                         (catch Throwable cause
-                           (let [on-error (or on-error on-error*)]
-                             (on-error file cause))))]
-            (recur (or state' state) (rest files)))
+    (when (fn? on-init) (on-init))
 
-          (if (fn? on-end)
-            (on-end state)
-            state))))))
+    (db/with-atomic [conn (:app.db/pool system)]
+      (doseq [file (get-candidates conn)]
+        (binding [*conn* conn
+                  pmap/*tracked* (atom {})
+                  pmap/*load-fn* (partial files/load-pointer conn (:id file))
+                  ffeat/*wrap-with-pointer-map-fn*
+                  (if (contains? (:features file) "storage/pointer-map") pmap/wrap identity)
+                  ffeat/*wrap-with-objects-map-fn*
+                  (if (contains? (:features file) "storage/objects-map") omap/wrap identity)]
+          (try
+            (on-file file)
+            (catch Throwable cause
+              ((or on-error on-error*) cause file))))))
+
+    (when (fn? on-end) (on-end))))
+
+(defn process-files!
+  "Apply a function to all files in the database, reading them in
+  batches."
+
+  [{:keys [::db/pool] :as system} & {:keys [chunk-size
+                                            max-items
+                                            workers
+                                            start-at
+                                            on-file
+                                            on-error
+                                            on-end
+                                            on-init]
+                                     :or {chunk-size 10
+                                          max-items Long/MAX_VALUE
+                                          workers 1}}]
+
+  (letfn [(get-chunk [conn cursor]
+            (let [rows (db/exec! conn [sql:retrieve-files-chunk cursor chunk-size])]
+              [(some->> rows peek :created-at)
+               (map #(update % :features db/decode-pgarray #{}) rows)]))
+
+          (get-candidates [conn]
+            (->> (d/iteration (partial get-chunk conn)
+                              :vf second
+                              :kf first
+                              :initk (or start-at (dt/now)))
+                 (take max-items)))
+
+          (on-error* [cause file]
+            (println! "unexpected exception happened on processing file: " (:id file))
+            (strace/print-stack-trace cause))
+
+          (process-file [conn file]
+            (try
+              (binding [*conn* conn
+                        pmap/*tracked* (atom {})
+                        pmap/*load-fn* (partial files/load-pointer conn (:id file))
+                        ffeat/*wrap-with-pointer-map-fn*
+                        (if (contains? (:features file) "storage/pointer-map") pmap/wrap identity)
+                        ffeat/*wrap-with-objects-map-fn*
+                        (if (contains? (:features file) "storage/objectd-map") omap/wrap identity)]
+                (on-file file))
+              (catch Throwable cause
+                ((or on-error on-error*) cause file))))
+
+          (run-worker [in index]
+            (db/with-atomic [conn pool]
+              (loop [i 0]
+                (when-let [file (sp/take! in)]
+                  (println! "=> worker: index:" index "| loop:" i "| file:" (:id file) "|" (px/get-name))
+                  (process-file conn file)
+                  (recur (inc i))))))
+
+          (run-producer [input]
+            (db/with-atomic [conn pool]
+              (doseq [file (get-candidates conn)]
+                (println! "=> producer:" (:id file) "|" (px/get-name))
+                (sp/put! input file))
+              (sp/close! input)))
+
+          (start-worker [input index]
+            (px/thread
+              {:name (str "penpot/srepl/worker/" index)}
+              (run-worker input index)))
+          ]
+
+    (when (fn? on-init) (on-init))
+
+    (let [input    (sp/chan :buf chunk-size)
+          producer (px/thread
+                     {:name "penpot/srepl/producer"}
+                     (run-producer input))
+          threads  (->> (range workers)
+                        (map (partial start-worker input))
+                        (cons producer)
+                        (doall))]
+
+      (run! p/await! threads)
+      (when (fn? on-end) (on-end)))))
 
 (defn update-pages
   "Apply a function to all pages of one file. The function receives a page and returns an updated page."

backend/src/app/srepl/main.clj

@@ -8,20 +8,27 @@
   "A collection of adhoc fixes scripts."
   #_:clj-kondo/ignore
   (:require
+   [app.common.data :as d]
+   [app.common.data.macros :as dm]
    [app.common.logging :as l]
    [app.common.pprint :as p]
    [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.config :as cf]
    [app.db :as db]
+   [app.msgbus :as mbus]
    [app.rpc.commands.auth :as auth]
    [app.rpc.commands.profile :as profile]
+   [app.rpc.commands.files-snapshot :as fsnap]
    [app.srepl.fixes :as f]
    [app.srepl.helpers :as h]
+   [app.storage :as sto]
    [app.util.blob :as blob]
    [app.util.objects-map :as omap]
    [app.util.pointer-map :as pmap]
    [app.util.time :as dt]
    [app.worker :as wrk]
-   [clojure.pprint :refer [pprint]]
+   [clojure.pprint :refer [pprint print-table]]
    [cuerdas.core :as str]))
 
 (defn print-available-tasks
@@ -101,7 +108,6 @@
         (db/delete! conn :http-session {:profile-id (:id profile)})
         :blocked))))
 
-
 (defn enable-objects-map-feature-on-file!
   [system & {:keys [save? id]}]
   (letfn [(update-file [{:keys [features] :as file}]
@@ -164,3 +170,135 @@
   (alter-var-root var (fn [f]
                         (or (::original (meta f)) f))))
 
+(defn take-file-snapshot!
+  "An internal helper that persist the file snapshot using non-gc
+  collectable file-changes entry."
+  [system & {:keys [file-id label]}]
+  (let [file-id (h/parse-uuid file-id)]
+    (db/tx-run! system
+                (fn [cfg]
+                  (fsnap/take-file-snapshot! cfg {:file-id file-id :label label})))))
+
+(defn restore-file-snapshot!
+  [system & {:keys [file-id id]}]
+  (db/tx-run! system
+              (fn [cfg]
+                (let [file-id (h/parse-uuid file-id)
+                      id      (h/parse-uuid id)]
+
+                  (if (and (uuid? id) (uuid? file-id))
+                    (fsnap/restore-file-snapshot! cfg {:id id :file-id file-id})
+                    (println "=> invalid parameters"))))))
+
+
+(defn list-file-snapshots!
+  [system & {:keys [file-id limit]}]
+  (db/tx-run! system (fn [system]
+                       (let [params {:file-id (h/parse-uuid file-id)
+                                     :limit limit}]
+                         (->> (fsnap/get-file-snapshots system (d/without-nils params))
+                              (print-table [:id :revn :created-at :label]))))))
+
+(defn notify!
+  [{:keys [::mbus/msgbus ::db/pool]} & {:keys [dest code message level]
+                                        :or {code :generic level :info}
+                                        :as params}]
+  (dm/verify!
+   ["invalid level %" level]
+   (contains? #{:success :error :info :warning} level))
+
+  (dm/verify!
+   ["invalid code: %" code]
+   (contains? #{:generic :upgrade-version} code))
+
+  (letfn [(send [dest]
+            (l/inf :hint "sending notification" :dest (str dest))
+            (let [message {:type :notification
+                           :code code
+                           :level level
+                           :version (:full cf/version)
+                           :subs-id dest
+                           :message message}
+                  message (->> (dissoc params :dest :code :message :level)
+                               (merge message))]
+              (mbus/pub! msgbus
+                         :topic (str dest)
+                         :message message)))
+
+          (resolve-profile [email]
+            (some-> (db/get* pool :profile {:email (str/lower email)} {:columns [:id]}) :id vector))
+
+          (resolve-team [team-id]
+            (->> (db/query pool :team-profile-rel
+                           {:team-id team-id}
+                           {:columns [:profile-id]})
+                 (map :profile-id)))
+
+          (parse-uuid [v]
+            (if (uuid? v)
+              v
+              (d/parse-uuid v)))
+
+          (resolve-dest [dest]
+            (cond
+              (uuid? dest)
+              [dest]
+
+              (string? dest)
+              (some-> dest parse-uuid resolve-dest)
+
+              (nil? dest)
+              (resolve-dest uuid/zero)
+
+              (map? dest)
+              (sequence (comp
+                         (map vec)
+                         (mapcat resolve-dest))
+                        dest)
+
+              (and (coll? dest)
+                   (every? coll? dest))
+              (sequence (comp
+                         (map vec)
+                         (mapcat resolve-dest))
+                        dest)
+
+              (vector? dest)
+              (let [[op param] dest]
+                (cond
+                  (= op :email)
+                  (cond
+                    (and (coll? param)
+                         (every? string? param))
+                    (sequence (comp
+                               (keep resolve-profile)
+                               (mapcat identity))
+                              param)
+
+                    (string? param)
+                    (resolve-profile param))
+
+                  (= op :team-id)
+                  (cond
+                    (coll? param)
+                    (sequence (comp
+                               (mapcat resolve-team)
+                               (keep parse-uuid))
+                              param)
+
+                    (uuid? param)
+                    (resolve-team param)
+
+                    (string? param)
+                    (some-> param parse-uuid resolve-team))
+
+                  (= op :profile-id)
+                  (if (coll? param)
+                    (sequence (keep parse-uuid) param)
+                    (resolve-dest param))))))
+          ]
+
+    (->> (resolve-dest dest)
+         (filter some?)
+         (into #{})
+         (run! send))))

backend/src/app/storage.clj

@@ -251,53 +251,59 @@
 
 (defmethod ig/init-key ::gc-deleted-task
   [_ {:keys [::db/pool ::storage ::min-age]}]
-  (letfn [(retrieve-deleted-objects-chunk [conn min-age cursor]
-            (let [min-age (db/interval min-age)
-                  rows    (db/exec! conn [sql:retrieve-deleted-objects-chunk min-age cursor])]
-              [(some-> rows peek :created-at)
+  (letfn [(get-to-delete-chunk [cursor]
+            (let [sql  (str "select s.* "
+                            "  from storage_object as s "
+                            " where s.deleted_at is not null "
+                            "   and s.deleted_at < ? "
+                            " order by s.deleted_at desc "
+                            " limit 25")
+                  rows (db/exec! pool [sql cursor])]
+              [(some-> rows peek :deleted-at)
                (some->> (seq rows) (d/group-by #(-> % :backend keyword) :id #{}) seq)]))
 
-          (retrieve-deleted-objects [conn min-age]
-            (d/iteration (partial retrieve-deleted-objects-chunk conn min-age)
-                         :initk (dt/now)
+          (get-to-delete-chunks [min-age]
+            (d/iteration get-to-delete-chunk
+                         :initk (dt/minus (dt/now) min-age)
                          :vf second
                          :kf first))
 
-          (delete-in-bulk [backend-id ids]
-            (let [backend (impl/resolve-backend storage backend-id)]
+          (delete-in-bulk! [backend-id ids]
+            (try
+              (db/with-atomic [conn pool]
+                (let [sql   "delete from storage_object where id = ANY(?)"
+                      ids'  (db/create-array conn "uuid" ids)
 
-              (doseq [id ids]
-                (l/debug :hint "gc-deleted: permanently delete storage object" :backend backend-id :id id))
+                      total (-> (db/exec-one! conn [sql ids'])
+                                (db/get-update-count))]
 
-              (impl/del-objects-in-bulk backend ids)))]
+                  (-> (impl/resolve-backend storage backend-id)
+                      (impl/del-objects-in-bulk ids))
+
+                  (doseq [id ids]
+                    (l/dbg :hint "gc-deleted: permanently delete storage object" :backend backend-id :id id))
+
+                  total))
+
+              (catch Throwable cause
+                (l/err :hint "gc-deleted: unexpected error on bulk deletion"
+                       :ids (vec ids)
+                       :cause cause)
+                0)))]
 
     (fn [params]
-      (let [min-age (or (:min-age params) min-age)]
-        (db/with-atomic [conn pool]
-          (loop [total  0
-                 groups (retrieve-deleted-objects conn min-age)]
-            (if-let [[backend-id ids] (first groups)]
-              (do
-                (delete-in-bulk backend-id ids)
-                (recur (+ total (count ids))
-                       (rest groups)))
-              (do
-                (l/info :hint "gc-deleted: task finished" :min-age (dt/format-duration min-age) :total total)
-                {:deleted total}))))))))
-
-(def sql:retrieve-deleted-objects-chunk
-  "with items_part as (
-     select s.id
-       from storage_object as s
-      where s.deleted_at is not null
-        and s.deleted_at < (now() - ?::interval)
-        and s.created_at < ?
-      order by s.created_at desc
-      limit 25
-   )
-   delete from storage_object
-    where id in (select id from items_part)
-   returning *;")
+      (let [min-age (or (some-> params :min-age dt/duration) min-age)]
+        (loop [total  0
+               chunks (get-to-delete-chunks min-age)]
+          (if-let [[backend-id ids] (first chunks)]
+            (let [deleted (delete-in-bulk! backend-id ids)]
+              (recur (+ total deleted)
+                     (rest chunks)))
+            (do
+              (l/inf :hint "gc-deleted: task finished"
+                     :min-age (dt/format-duration min-age)
+                     :total total)
+              {:deleted total})))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Garbage Collection: Analyze touched objects

backend/src/app/tasks/file_gc.clj

@@ -11,8 +11,8 @@
   inactivity (the default threshold is 72h)."
   (:require
    [app.common.data :as d]
+   [app.common.files.migrations :as pmg]
    [app.common.logging :as l]
-   [app.common.pages.migrations :as pmg]
    [app.common.types.components-list :as ctkl]
    [app.common.types.file :as ctf]
    [app.common.types.shape-tree :as ctt]
@@ -113,8 +113,15 @@
                (mapcat vals)
                (keep (fn [{:keys [type] :as obj}]
                        (case type
-                         :path (get-in obj [:fill-image :id])
+                         :path  (get-in obj [:fill-image :id])
+                         :bool  (get-in obj [:fill-image :id])
+                         ;; NOTE: because of some bug, we ended with
+                         ;; many shape types having the ability to
+                         ;; have fill-image attribute (which initially
+                         ;; designed for :path shapes).
+                         :group (get-in obj [:fill-image :id])
                          :image (get-in obj [:metadata :id])
+
                          nil))))
         pages (concat
                (vals (:pages-index data))
@@ -184,7 +191,7 @@
     (when (seq res)
       (doseq [media-id (into #{} (keep :media-id) res)]
         ;; Mark as deleted the storage object related with the
-        ;; photo-id field.
+        ;; media-id field.
         (l/trace :hint "mark storage object as deleted" :id media-id)
         (sto/del-object! storage media-id))
 

backend/src/app/tasks/file_xlog_gc.clj

@@ -17,7 +17,8 @@
 (def ^:private
   sql:delete-files-xlog
   "delete from file_change
-    where created_at < now() - ?::interval")
+    where created_at < now() - ?::interval
+      and label is NULL")
 
 (defmethod ig/pre-init-spec ::handler [_]
   (s/keys :req [::db/pool]))

backend/src/app/util/async.clj

@@ -1,113 +0,0 @@
-;; This Source Code Form is subject to the terms of the Mozilla Public
-;; License, v. 2.0. If a copy of the MPL was not distributed with this
-;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
-;;
-;; Copyright (c) KALEIDOS INC
-
-(ns app.util.async
-  (:require
-   [app.common.exceptions :as ex]
-   [clojure.core.async :as a]
-   [clojure.core.async.impl.protocols :as ap]
-   [clojure.spec.alpha :as s])
-  (:import
-   java.util.concurrent.Executor
-   java.util.concurrent.RejectedExecutionException))
-
-(s/def ::executor #(instance? Executor %))
-(s/def ::channel #(satisfies? ap/Channel %))
-
-(defonce processors
-  (delay (.availableProcessors (Runtime/getRuntime))))
-
-(defmacro go-try
-  [& body]
-  `(a/go
-     (try
-       ~@body
-       (catch Exception e# e#))))
-
-(defmacro thread
-  [& body]
-  `(a/thread
-     (try
-       ~@body
-       (catch Exception e#
-         e#))))
-
-(defmacro <?
-  [ch]
-  `(let [r# (a/<! ~ch)]
-     (if (instance? Exception r#)
-       (throw r#)
-       r#)))
-
-(defmacro with-closing
-  [ch & body]
-  `(try
-     ~@body
-     (finally
-       (some-> ~ch a/close!))))
-
-(defn thread-call
-  [^Executor executor f]
-  (let [ch (a/chan 1)
-        f' (fn []
-             (try
-               (let [ret (ex/try* f identity)]
-                 (when (some? ret) (a/>!! ch ret)))
-               (finally
-                 (a/close! ch))))]
-    (try
-      (.execute executor f')
-      (catch RejectedExecutionException _cause
-        (a/close! ch)))
-
-    ch))
-
-(defmacro with-thread
-  [executor & body]
-  (if (= executor ::default)
-    `(a/thread-call (^:once fn* [] (try ~@body (catch Exception e# e#))))
-    `(thread-call ~executor (^:once fn* [] ~@body))))
-
-(defn batch
-  [in {:keys [max-batch-size
-              max-batch-age
-              buffer-size
-              init]
-       :or {max-batch-size 200
-            max-batch-age (* 30 1000)
-            buffer-size 128
-            init #{}}
-       :as opts}]
-  (let [out (a/chan buffer-size)]
-    (a/go-loop [tch (a/timeout max-batch-age) buf init]
-      (let [[val port] (a/alts! [tch in])]
-        (cond
-          (identical? port tch)
-          (if (empty? buf)
-            (recur (a/timeout max-batch-age) buf)
-            (do
-              (a/>! out [:timeout buf])
-              (recur (a/timeout max-batch-age) init)))
-
-          (nil? val)
-          (if (empty? buf)
-            (a/close! out)
-            (do
-              (a/offer! out [:timeout buf])
-              (a/close! out)))
-
-          (identical? port in)
-          (let [buf (conj buf val)]
-            (if (>= (count buf) max-batch-size)
-              (do
-                (a/>! out [:size buf])
-                (recur (a/timeout max-batch-age) init))
-              (recur tch buf))))))
-    out))
-
-(defn thread-sleep
-  [ms]
-  (Thread/sleep (long ms)))

backend/src/app/worker.clj

@@ -87,10 +87,10 @@
 
 (defmethod ig/init-key ::registry
   [_ {:keys [::mtx/metrics ::tasks]}]
-  (l/info :hint "registry initialized" :tasks (count tasks))
+  (l/inf :hint "registry initialized" :tasks (count tasks))
   (reduce-kv (fn [registry k v]
                (let [tname (name k)]
-                 (l/trace :hint "register task" :name tname)
+                 (l/trc :hint "register task" :name tname)
                  (assoc registry tname (wrap-task-handler metrics tname v))))
              {}
              tasks))
@@ -141,18 +141,18 @@
 
     (px/thread
       {:name "penpot/executors-monitor" :virtual true}
-      (l/info :hint "monitor: started" :name name)
+      (l/inf :hint "monitor: started" :name name)
       (try
         (loop [steals 0]
           (when-not (px/shutdown? executor)
             (px/sleep interval)
             (recur (long (monitor! executor steals)))))
         (catch InterruptedException _cause
-          (l/debug :hint "monitor: interrupted" :name name))
+          (l/trc :hint "monitor: interrupted" :name name))
         (catch Throwable cause
-          (l/error :hint "monitor: unexpected error" :name name :cause cause))
+          (l/err :hint "monitor: unexpected error" :name name :cause cause))
         (finally
-          (l/info :hint "monitor: terminated" :name name))))))
+          (l/inf :hint "monitor: terminated" :name name))))))
 
 (defmethod ig/halt-key! ::monitor
   [_ thread]
@@ -207,10 +207,10 @@
                        (db/create-array conn "uuid" ids)]]
 
               (db/exec-one! conn sql)
-              (l/debug :hist "dispatcher: queue tasks"
-                       :queue queue
-                       :tasks (count ids)
-                       :queued res)))
+              (l/trc :hist "dispatcher: queue tasks"
+                     :queue queue
+                     :tasks (count ids)
+                     :queued res)))
 
           (run-batch! [rconn]
             (try
@@ -225,35 +225,35 @@
                 (cond
                   (rds/exception? cause)
                   (do
-                    (l/warn :hint "dispatcher: redis exception (will retry in an instant)" :cause cause)
+                    (l/wrn :hint "dispatcher: redis exception (will retry in an instant)" :cause cause)
                     (px/sleep (::rds/timeout rconn)))
 
                   (db/sql-exception? cause)
                   (do
-                    (l/warn :hint "dispatcher: database exception (will retry in an instant)" :cause cause)
+                    (l/wrn :hint "dispatcher: database exception (will retry in an instant)" :cause cause)
                     (px/sleep (::rds/timeout rconn)))
 
                   :else
                   (do
-                    (l/error :hint "dispatcher: unhandled exception (will retry in an instant)" :cause cause)
+                    (l/err :hint "dispatcher: unhandled exception (will retry in an instant)" :cause cause)
                     (px/sleep (::rds/timeout rconn)))))))
 
           (dispatcher []
-            (l/info :hint "dispatcher: started")
+            (l/inf :hint "dispatcher: started")
             (try
               (dm/with-open [rconn (rds/connect redis)]
                 (loop []
                   (run-batch! rconn)
                   (recur)))
               (catch InterruptedException _
-                (l/trace :hint "dispatcher: interrupted"))
+                (l/trc :hint "dispatcher: interrupted"))
               (catch Throwable cause
-                (l/error :hint "dispatcher: unexpected exception" :cause cause))
+                (l/err :hint "dispatcher: unexpected exception" :cause cause))
               (finally
-                (l/info :hint "dispatcher: terminated"))))]
+                (l/inf :hint "dispatcher: terminated"))))]
 
     (if (db/read-only? pool)
-      (l/warn :hint "dispatcher: not started (db is read-only)")
+      (l/wrn :hint "dispatcher: not started (db is read-only)")
       (px/fn->thread dispatcher :name "penpot/worker/dispatcher" :virtual true))))
 
 (defmethod ig/halt-key! ::dispatcher
@@ -286,7 +286,7 @@
   (let [queue (d/name queue)
         cfg   (assoc cfg ::queue queue)]
     (if (db/read-only? pool)
-      (l/warn :hint "worker: not started (db is read-only)" :queue queue :parallelism parallelism)
+      (l/wrn :hint "worker: not started (db is read-only)" :queue queue :parallelism parallelism)
       (doall
        (->> (range parallelism)
             (map #(assoc cfg ::worker-id %))
@@ -300,7 +300,7 @@
   [{:keys [::rds/redis ::worker-id ::queue] :as cfg}]
   (px/thread
     {:name (format "penpot/worker/runner:%s" worker-id)}
-    (l/info :hint "worker: started" :worker-id worker-id :queue queue)
+    (l/inf :hint "worker: started" :worker-id worker-id :queue queue)
     (try
       (dm/with-open [rconn (rds/connect redis)]
         (let [tenant (cf/get :tenant "main")
@@ -320,14 +320,14 @@
                  :worker-id worker-id
                  :queue queue))
       (catch Throwable cause
-        (l/error :hint "worker: unexpected exception"
-                 :worker-id worker-id
-                 :queue queue
-                 :cause cause))
+        (l/err :hint "worker: unexpected exception"
+               :worker-id worker-id
+               :queue queue
+               :cause cause))
       (finally
-        (l/info :hint "worker: terminated"
-                :worker-id worker-id
-                :queue queue)))))
+        (l/inf :hint "worker: terminated"
+               :worker-id worker-id
+               :queue queue)))))
 
 (defn- run-worker-loop!
   [{:keys [::db/pool ::rds/rconn ::timeout ::queue ::registry ::worker-id]}]
@@ -368,19 +368,19 @@
               (let [task-id (t/decode payload)]
                 (if (uuid? task-id)
                   task-id
-                  (l/error :hint "worker: received unexpected payload (uuid expected)"
-                           :payload task-id)))
+                  (l/err :hint "worker: received unexpected payload (uuid expected)"
+                         :payload task-id)))
               (catch Throwable cause
-                (l/error :hint "worker: unable to decode payload"
-                         :payload payload
-                         :length (alength payload)
-                         :cause cause))))
+                (l/err :hint "worker: unable to decode payload"
+                       :payload payload
+                       :length (alength payload)
+                       :cause cause))))
 
           (handle-task [{:keys [name] :as task}]
             (let [task-fn (get registry name)]
               (if task-fn
                 (task-fn task)
-                (l/warn :hint "no task handler found" :name name))
+                (l/wrn :hint "no task handler found" :name name))
               {:status :completed :task task}))
 
           (handle-task-exception [cause task]
@@ -395,9 +395,9 @@
                   (= ::noop (:strategy edata))
                   (assoc :inc-by 0))
                 (do
-                  (l/error :hint "worker: unhandled exception on task"
-                           ::l/context (get-error-context cause task)
-                           :cause cause)
+                  (l/err :hint "worker: unhandled exception on task"
+                         ::l/context (get-error-context cause task)
+                         :cause cause)
                   (if (>= (:retry-num task) (:max-retries task))
                     {:status :failed :task task :error cause}
                     {:status :retry :task task :error cause})))))
@@ -414,31 +414,31 @@
                 (if (or (db/connection-error? task)
                         (db/serialization-error? task))
                   (do
-                    (l/warn :hint "worker: connection error on retrieving task from database (retrying in some instants)"
-                            :worker-id worker-id
-                            :cause task)
+                    (l/wrn :hint "worker: connection error on retrieving task from database (retrying in some instants)"
+                           :worker-id worker-id
+                           :cause task)
                     (px/sleep (::rds/timeout rconn))
                     (recur (get-task task-id)))
                   (do
-                    (l/error :hint "worker: unhandled exception on retrieving task from database (retrying in some instants)"
-                             :worker-id worker-id
-                             :cause task)
+                    (l/err :hint "worker: unhandled exception on retrieving task from database (retrying in some instants)"
+                           :worker-id worker-id
+                           :cause task)
                     (px/sleep (::rds/timeout rconn))
                     (recur (get-task task-id))))
 
                 (nil? task)
-                (l/warn :hint "worker: no task found on the database"
-                        :worker-id worker-id
-                        :task-id task-id)
+                (l/wrn :hint "worker: no task found on the database"
+                       :worker-id worker-id
+                       :task-id task-id)
 
                 :else
                 (try
-                  (l/debug :hint "worker: executing task"
-                           :name (:name task)
-                           :id (:id task)
-                           :queue queue
-                           :worker-id worker-id
-                           :retry (:retry-num task))
+                  (l/trc :hint "executing task"
+                         :name (:name task)
+                         :id (str (:id task))
+                         :queue queue
+                         :worker-id worker-id
+                         :retry (:retry-num task))
                   (handle-task task)
                   (catch InterruptedException cause
                     (throw cause))
@@ -459,13 +459,13 @@
                 (if (or (db/connection-error? cause)
                         (db/serialization-error? cause))
                   (do
-                    (l/warn :hint "worker: database exeption on processing task result (retrying in some instants)"
-                            :cause cause)
+                    (l/wrn :hint "worker: database exeption on processing task result (retrying in some instants)"
+                           :cause cause)
                     (px/sleep (::rds/timeout rconn))
                     (recur result))
                   (do
-                    (l/error :hint "worker: unhandled exception on processing task result (retrying in some instants)"
-                             :cause cause)
+                    (l/err :hint "worker: unhandled exception on processing task result (retrying in some instants)"
+                           :cause cause)
                     (px/sleep (::rds/timeout rconn))
                     (recur result))))))]
 
@@ -481,24 +481,16 @@
       (catch Exception cause
         (if (rds/timeout-exception? cause)
           (do
-            (l/error :hint "worker: redis pop operation timeout, consider increasing redis timeout (will retry in some instants)"
-                     :timeout timeout
-                     :cause cause)
+            (l/err :hint "worker: redis pop operation timeout, consider increasing redis timeout (will retry in some instants)"
+                   :timeout timeout
+                   :cause cause)
             (px/sleep timeout))
 
-          (l/error :hint "worker: unhandled exception" :cause cause))))))
+          (l/err :hint "worker: unhandled exception" :cause cause))))))
 
 (defn- get-error-context
-  [error item]
-  (let [data (ex-data error)]
-    (merge
-     {:hint          (ex-message error)
-      :spec-problems (some->> data ::s/problems (take 10) seq vec)
-      :spec-value    (some->> data ::s/value)
-      :data          (some-> data (dissoc ::s/problems ::s/value ::s/spec))
-      :params        item}
-     (when-let [explain (ex/explain data)]
-       {:spec-explain explain}))))
+  [_ item]
+  {:params item})
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; CRON
@@ -525,7 +517,7 @@
 (defmethod ig/init-key ::cron
   [_ {:keys [::entries ::registry ::db/pool] :as cfg}]
   (if (db/read-only? pool)
-    (l/warn :hint "cron: not started (db is read-only)")
+    (l/wrn :hint "cron: not started (db is read-only)")
     (let [running (atom #{})
           entries (->> entries
                        (filter some?)
@@ -548,22 +540,22 @@
 
           cfg     (assoc cfg ::entries entries ::running running)]
 
-        (l/info :hint "cron: started" :tasks (count entries))
-        (synchronize-cron-entries! cfg)
+      (l/inf :hint "cron: started" :tasks (count entries))
+      (synchronize-cron-entries! cfg)
 
-        (->> (filter some? entries)
-             (run! (partial schedule-cron-task cfg)))
+      (->> (filter some? entries)
+           (run! (partial schedule-cron-task cfg)))
 
-        (reify
-          clojure.lang.IDeref
-          (deref [_] @running)
+      (reify
+        clojure.lang.IDeref
+        (deref [_] @running)
 
-          java.lang.AutoCloseable
-          (close [_]
-            (l/info :hint "cron: terminated")
-            (doseq [item @running]
-              (when-not (.isDone ^Future item)
-                (.cancel ^Future item true))))))))
+        java.lang.AutoCloseable
+        (close [_]
+          (l/inf :hint "cron: terminated")
+          (doseq [item @running]
+            (when-not (.isDone ^Future item)
+              (.cancel ^Future item true))))))))
 
 (defmethod ig/halt-key! ::cron
   [_ instance]
@@ -579,11 +571,14 @@
   [{:keys [::db/pool ::entries]}]
   (db/with-atomic [conn pool]
     (doseq [{:keys [id cron]} entries]
-      (l/trace :hint "register cron task" :id id :cron (str cron))
+      (l/trc :hint "register cron task" :id id :cron (str cron))
       (db/exec-one! conn [sql:upsert-cron-task id (str cron) (str cron)]))))
 
-(def sql:lock-cron-task
-  "select id from scheduled_task where id=? for update skip locked")
+(defn- lock-scheduled-task!
+  [conn id]
+  (let [sql (str "SELECT id FROM scheduled_task "
+                 " WHERE id=? FOR UPDATE SKIP LOCKED")]
+    (some? (db/exec-one! conn [sql (d/name id)]))))
 
 (defn- execute-cron-task
   [{:keys [::db/pool] :as cfg} {:keys [id] :as task}]
@@ -591,16 +586,21 @@
     {:name (str "penpot/cront-task/" id)}
     (try
       (db/with-atomic [conn pool]
-        (when (db/exec-one! conn [sql:lock-cron-task (d/name id)])
-          (l/trace :hint "cron: execute task" :task-id id)
-          ((:fn task) task)))
+        (db/exec-one! conn ["SET statement_timeout=0;"])
+        (db/exec-one! conn ["SET idle_in_transaction_session_timeout=0;"])
+        (when (lock-scheduled-task! conn id)
+          (l/dbg :hint "cron: execute task" :task-id id)
+          ((:fn task) task))
+        (db/rollback! conn))
+
       (catch InterruptedException _
         (l/debug :hint "cron: task interrupted" :task-id id))
+
       (catch Throwable cause
-        (l/error :hint "cron: unhandled exception on running task"
-                 ::l/context (get-error-context cause task)
+        (binding [l/*context* (get-error-context cause task)]
+          (l/err :hint "cron: unhandled exception on running task"
                  :task-id id
-                 :cause cause))
+                 :cause cause)))
       (finally
         (when-not (px/interrupted? :current)
           (schedule-cron-task cfg task))))))
@@ -610,12 +610,16 @@
   (s/assert dt/cron? cron)
   (let [now  (dt/now)
         next (dt/next-valid-instant-from cron now)]
-    (inst-ms (dt/diff now next))))
+    (dt/diff now next)))
 
 (defn- schedule-cron-task
-  [{:keys [::running] :as cfg} {:keys [cron] :as task}]
-  (let [ft (px/schedule! (ms-until-valid cron)
-                         (partial execute-cron-task cfg task))]
+  [{:keys [::running] :as cfg} {:keys [cron id] :as task}]
+  (let [ts (ms-until-valid cron)
+        ft (px/schedule! ts (partial execute-cron-task cfg task))]
+
+    (l/dbg :hint "cron: schedule task" :task-id id
+           :ts (dt/format-duration ts)
+           :at (dt/format-instant (dt/in-future ts)))
     (swap! running #(into #{ft} (filter p/pending?) %))))
 
 
@@ -678,13 +682,13 @@
                     (-> (db/exec-one! conn [sql:remove-not-started-tasks task queue label])
                         :next.jdbc/update-count))]
 
-    (l/debug :hint "submit task"
-             :name task
-             :queue queue
-             :label label
-             :dedupe (boolean dedupe)
-             :deleted (or deleted 0)
-             :in (dt/format-duration duration))
+    (l/trc :hint "submit task"
+           :name task
+           :queue queue
+           :label label
+           :dedupe (boolean dedupe)
+           :deleted (or deleted 0)
+           :in (dt/format-duration duration))
 
     (db/exec-one! conn [sql:insert-new-task id task props queue
                         label priority max-retries interval])

backend/test/backend_tests/helpers.clj

@@ -14,6 +14,7 @@
    [app.common.pages :as cp]
    [app.common.pprint :as pp]
    [app.common.spec :as us]
+   [app.common.schema :as sm]
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
@@ -127,7 +128,7 @@
                      (assoc-in [::db/pool ::db/uri] (:database-uri config))
                      (assoc-in [::db/pool ::db/username] (:database-username config))
                      (assoc-in [::db/pool ::db/password] (:database-password config))
-                     (assoc-in [:app.rpc/methods :templates] templates)
+                     (assoc-in [:app.rpc/methods :app.setup/templates] templates)
                      (dissoc :app.srepl/server
                              :app.http/server
                              :app.http/router
@@ -135,7 +136,7 @@
                              :app.auth.oidc/gitlab-provider
                              :app.auth.oidc/github-provider
                              :app.auth.oidc/generic-provider
-                             :app.setup/builtin-templates
+                             :app.setup/templates
                              :app.auth.oidc/routes
                              :app.worker/monitor
                              :app.http.oauth/handler
@@ -245,7 +246,7 @@
 (defn mark-file-deleted*
   ([params] (mark-file-deleted* *pool* params))
   ([conn {:keys [id] :as params}]
-   (#'files/mark-file-deleted conn {:id id})))
+   (#'files/mark-file-deleted! conn {:id id})))
 
 (defn create-team*
   ([i params] (create-team* *pool* i params))
@@ -414,6 +415,14 @@
       (println
        (us/pretty-explain data))
 
+      (= :params-validation (:code data))
+      (app.common.pprint/pprint
+       (sm/humanize-data (::sm/explain data)))
+
+      (= :data-validation (:code data))
+      (app.common.pprint/pprint
+       (sm/humanize-data (::sm/explain data)))
+
       (= :service-error (:type data))
       (print-error! (.getCause ^Throwable error))
 

backend/test/backend_tests/rpc_audit_test.clj

@@ -39,8 +39,8 @@
           params  {::th/type :push-audit-events
                    ::rpc/profile-id (:id prof)
                    :events [{:name "navigate"
-                             :props {:project-id proj-id
-                                     :team-id team-id
+                             :props {:project-id (str proj-id)
+                                     :team-id (str team-id)
                                      :route "dashboard-files"}
                              :context {:engine "blink"}
                              :profile-id (:id prof)
@@ -71,8 +71,8 @@
           params  {::th/type :push-audit-events
                    ::rpc/profile-id (:id prof)
                    :events [{:name "navigate"
-                             :props {:project-id proj-id
-                                     :team-id team-id
+                             :props {:project-id (str proj-id)
+                                     :team-id (str team-id)
                                      :route "dashboard-files"}
                              :context {:engine "blink"}
                              :profile-id uuid/zero
@@ -91,6 +91,8 @@
         (t/is (= 1 (count rows)))
         (t/is (= (:id prof) (:profile-id row)))
         (t/is (= "navigate" (:name row)))
-        (t/is (= "frontend" (:source row)))))))
+        (t/is (= "frontend" (:source row))))
+
+      )))
 
 

backend/test/backend_tests/rpc_file_test.clj

@@ -7,6 +7,7 @@
 (ns backend-tests.rpc-file-test
   (:require
    [app.common.uuid :as uuid]
+   [app.common.types.shape :as cts]
    [app.db :as db]
    [app.db.sql :as sql]
    [app.http :as http]
@@ -187,11 +188,12 @@
          :parent-id uuid/zero
          :frame-id uuid/zero
          :components-v2 true
-         :obj {:id shape-id
-               :name "image"
-               :frame-id uuid/zero
-               :parent-id uuid/zero
-               :type :rect}}])
+         :obj (cts/setup-shape
+               {:id shape-id
+                :name "image"
+                :frame-id uuid/zero
+                :parent-id uuid/zero
+                :type :rect})}])
 
       ;; Check the number of fragments
       (let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
@@ -252,6 +254,7 @@
                           :components-v2 true
                           :changes changes}
                   out    (th/command! params)]
+              ;; (th/print-result! out)
               (t/is (nil? (:error out)))
               (:result out)))]
 
@@ -278,15 +281,16 @@
        [{:type :add-obj
          :page-id page-id
          :id shid
-                     :parent-id uuid/zero
+         :parent-id uuid/zero
          :frame-id uuid/zero
          :components-v2 true
-         :obj {:id shid
-               :name "image"
-               :frame-id uuid/zero
-               :parent-id uuid/zero
-               :type :image
-               :metadata {:id (:id fmo1)}}}])
+         :obj (cts/setup-shape
+               {:id shid
+                :name "image"
+                :frame-id uuid/zero
+                :parent-id uuid/zero
+                :type :image
+                :metadata {:id (:id fmo1) :width 100 :height 100 :mtype "image/jpeg"}})}])
 
       ;; Check that reference storage objects on filemediaobjects
       ;; are the same because of deduplication feature.
@@ -546,38 +550,42 @@
         shape2-id (uuid/next)
 
         changes   [{:type :add-obj
-                   :page-id page-id
-                   :id frame1-id
-                   :parent-id uuid/zero
-                   :frame-id uuid/zero
-                   :obj {:id frame1-id
-                         :use-for-thumbnail? true
-                         :name "test-frame1"
-                         :type :frame}}
-                  {:type :add-obj
-                   :page-id page-id
-                   :id shape1-id
-                   :parent-id frame1-id
-                   :frame-id frame1-id
-                   :obj {:id shape1-id
-                         :name "test-shape1"
-                         :type :rect}}
-                  {:type :add-obj
-                   :page-id page-id
-                   :id frame2-id
-                   :parent-id uuid/zero
-                   :frame-id uuid/zero
-                   :obj {:id frame2-id
-                         :name "test-frame2"
-                         :type :frame}}
-                  {:type :add-obj
-                   :page-id page-id
-                   :id shape2-id
-                   :parent-id frame2-id
-                   :frame-id frame2-id
-                   :obj {:id shape2-id
-                         :name "test-shape2"
-                         :type :rect}}]]
+                    :page-id page-id
+                    :id frame1-id
+                    :parent-id uuid/zero
+                    :frame-id uuid/zero
+                    :obj (cts/setup-shape
+                          {:id frame1-id
+                           :use-for-thumbnail? true
+                           :name "test-frame1"
+                           :type :frame})}
+                    {:type :add-obj
+                     :page-id page-id
+                     :id shape1-id
+                     :parent-id frame1-id
+                     :frame-id frame1-id
+                     :obj (cts/setup-shape
+                           {:id shape1-id
+                          :name "test-shape1"
+                            :type :rect})}
+                   {:type :add-obj
+                    :page-id page-id
+                    :id frame2-id
+                    :parent-id uuid/zero
+                    :frame-id uuid/zero
+                    :obj (cts/setup-shape
+                          {:id frame2-id
+                           :name "test-frame2"
+                           :type :frame})}
+                   {:type :add-obj
+                    :page-id page-id
+                    :id shape2-id
+                    :parent-id frame2-id
+                    :frame-id frame2-id
+                    :obj (cts/setup-shape
+                          {:id shape2-id
+                           :name "test-shape2"
+                           :type :rect})}]]
     ;; Update the file
     (th/update-file* {:file-id (:id file)
                       :profile-id (:id prof)

backend/test/backend_tests/rpc_file_thumbnails_test.clj

@@ -7,6 +7,7 @@
 (ns backend-tests.rpc-file-thumbnails-test
   (:require
    [app.common.uuid :as uuid]
+   [app.common.types.shape :as cts]
    [app.config :as cf]
    [app.db :as db]
    [app.rpc :as-alias rpc]
@@ -46,11 +47,12 @@
                    :parent-id uuid/zero
                    :frame-id uuid/zero
                    :components-v2 true
-                   :obj {:id shid
-                         :name "Artboard"
-                         :frame-id uuid/zero
-                         :parent-id uuid/zero
-                         :type :frame}}])
+                   :obj (cts/setup-shape
+                         {:id shid
+                          :name "Artboard"
+                          :frame-id uuid/zero
+                          :parent-id uuid/zero
+                          :type :frame})}])
 
         data1   {::th/type :create-file-object-thumbnail
                  ::rpc/profile-id (:id profile)
@@ -141,7 +143,7 @@
       )))
 
 
-(t/deftest upsert-file-thumbnail
+(t/deftest create-file-thumbnail
   (let [storage (::sto/storage th/*system*)
         profile (th/create-profile* 1)
         file    (th/create-file* 1 {:profile-id (:id profile)
@@ -159,7 +161,6 @@
         data2   {::th/type :create-file-thumbnail
                  ::rpc/profile-id (:id profile)
                  :file-id (:id file)
-                 :props {}
                  :revn 2
                  :media {:filename "sample.jpg"
                          :size 7923
@@ -169,7 +170,6 @@
         data3   {::th/type :create-file-thumbnail
                  ::rpc/profile-id (:id profile)
                  :file-id (:id file)
-                 :props {}
                  :revn 3
                  :media {:filename "sample.jpg"
                          :size 312043
@@ -183,11 +183,11 @@
     (let [out (th/command! data2)]
       ;; (th/print-result! out)
       (t/is (nil? (:error out)))
-      (t/is (nil? (:result out))))
+      (t/is (contains? (:result out) :uri)))
 
     (let [out (th/command! data3)]
       (t/is (nil? (:error out)))
-      (t/is (nil? (:result out))))
+      (t/is (contains? (:result out) :uri)))
 
     (let [[row1 row2 row3 :as rows] (th/db-query :file-thumbnail
                                                  {:file-id (:id file)}

backend/test/backend_tests/rpc_profile_test.clj

@@ -10,7 +10,7 @@
    [app.config :as cf]
    [app.db :as db]
    [app.rpc :as-alias rpc]
-   [app.rpc.commands.auth :as cauth]
+   [app.auth :as auth]
    [app.tokens :as tokens]
    [app.util.time :as dt]
    [backend-tests.helpers :as th]
@@ -226,11 +226,11 @@
 (t/deftest registration-domain-whitelist
   (let [whitelist #{"gmail.com" "hey.com" "ya.ru"}]
     (t/testing "allowed email domain"
-      (t/is (true? (cauth/email-domain-in-whitelist? whitelist "username@ya.ru")))
-      (t/is (true? (cauth/email-domain-in-whitelist? #{} "username@somedomain.com"))))
+      (t/is (true? (auth/email-domain-in-whitelist? whitelist "username@ya.ru")))
+      (t/is (true? (auth/email-domain-in-whitelist? #{} "username@somedomain.com"))))
 
     (t/testing "not allowed email domain"
-      (t/is (false? (cauth/email-domain-in-whitelist? whitelist "username@somedomain.com"))))))
+      (t/is (false? (auth/email-domain-in-whitelist? whitelist "username@somedomain.com"))))))
 
 (t/deftest prepare-register-and-register-profile-1
   (let [data  {::th/type :prepare-register-profile
@@ -278,7 +278,7 @@
       (let [error (:error out)]
         (t/is (th/ex-info? error))
         (t/is (th/ex-of-type? error :validation))
-        (t/is (th/ex-of-code? error :spec-validation))))
+        (t/is (th/ex-of-code? error :params-validation))))
 
     ;; try correct register
     (let [data  {::th/type :register-profile

backend/test/backend_tests/rpc_team_test.clj

@@ -37,7 +37,7 @@
                     :role :editor}]
 
       ;; invite external user without complaints
-      (let [data       (assoc data :email "foo@bar.com")
+      (let [data       (assoc data :emails ["foo@bar.com"])
             out        (th/command! data)
             ;; retrieve the value from the database and check its content
             invitation (db/exec-one!
@@ -52,7 +52,7 @@
 
       ;; invite internal user without complaints
       (th/reset-mock! mock)
-      (let [data (assoc data :email (:email profile2))
+      (let [data (assoc data :emails [(:email profile2)])
             out  (th/command! data)]
         (t/is (th/success? out))
         (t/is (= 1 (:call-count (deref mock)))))
@@ -60,7 +60,7 @@
       ;; invite user with complaint
       (th/create-global-complaint-for pool {:type :complaint :email "foo@bar.com"})
       (th/reset-mock! mock)
-      (let [data (assoc data :email "foo@bar.com")
+      (let [data (assoc data :emails ["foo@bar.com"])
             out  (th/command! data)]
         (t/is (th/success? out))
         (t/is (= 1 (:call-count (deref mock)))))
@@ -79,7 +79,7 @@
       (th/reset-mock! mock)
 
       (th/create-global-complaint-for pool {:type :bounce :email "foo@bar.com"})
-      (let [data  (assoc data :email "foo@bar.com")
+      (let [data  (assoc data :emails ["foo@bar.com"])
             out   (th/command! data)]
 
         (t/is (not (th/success? out)))
@@ -92,7 +92,7 @@
       ;; invite internal user that is muted
       (th/reset-mock! mock)
 
-      (let [data  (assoc data :email (:email profile3))
+      (let [data  (assoc data :emails [(:email profile3)])
             out   (th/command! data)]
 
         (t/is (not (th/success? out)))
@@ -118,7 +118,7 @@
       ;; Try to invite a not existing user
       (let [data {::th/type :create-team-invitations
                   ::rpc/profile-id (:id profile1)
-                  :email "notexisting@example.com"
+                  :emails ["notexisting@example.com"]
                   :team-id (:id team)
                   :role :editor}
             out  (th/command! data)]
@@ -126,15 +126,15 @@
         ;; (th/print-result! out)
         (t/is (th/success? out))
         (t/is (= 1 (:call-count @mock)))
-        (t/is (= 1 (-> out :result count)))
+        (t/is (= 1 (-> out :result :total)))
 
-        (let [token (-> out :result first)
+        (let [token  (-> out :result :invitations first)
               claims (tokens/decode sprops token)]
           (t/is (= :team-invitation (:iss claims)))
           (t/is (= (:id profile1) (:profile-id claims)))
           (t/is (= :editor (:role claims)))
           (t/is (= (:id team) (:team-id claims)))
-          (t/is (= (:email data) (:member-email claims)))
+          (t/is (= (first (:emails data)) (:member-email claims)))
           (t/is (nil? (:member-id claims)))))
 
       (th/reset-mock! mock)
@@ -142,7 +142,7 @@
       ;; Try to invite existing user
       (let [data {::th/type :create-team-invitations
                   ::rpc/profile-id (:id profile1)
-                  :email (:email profile2)
+                  :emails [(:email profile2)]
                   :team-id (:id team)
                   :role :editor}
             out  (th/command! data)]
@@ -150,15 +150,15 @@
         ;; (th/print-result! out)
         (t/is (th/success? out))
         (t/is (= 1 (:call-count @mock)))
-        (t/is (= 1 (-> out :result count)))
+        (t/is (= 1 (-> out :result :total)))
 
-        (let [token (-> out :result first)
+        (let [token (-> out :result :invitations first)
               claims (tokens/decode sprops token)]
           (t/is (= :team-invitation (:iss claims)))
           (t/is (= (:id profile1) (:profile-id claims)))
           (t/is (= :editor (:role claims)))
           (t/is (= (:id team) (:team-id claims)))
-          (t/is (= (:email data) (:member-email claims)))
+          (t/is (= (first (:emails data)) (:member-email claims)))
           (t/is (= (:id profile2) (:member-id claims)))))
 
       )))
@@ -264,7 +264,7 @@
       ;; invite internal user without complaints
       (with-redefs [app.config/flags #{}]
         (th/reset-mock! mock)
-        (let [data (assoc data :email (:email profile2))
+        (let [data (assoc data :emails [(:email profile2)])
               out  (th/command! data)]
           (t/is (th/success? out))
           (t/is (= 0 (:call-count (deref mock)))))

backend/test/backend_tests/storage_test.clj

@@ -100,6 +100,7 @@
                     (configure-storage-backend))
         content1 (sto/content "content1")
         content2 (sto/content "content2")
+        content3 (sto/content "content3")
         object1  (sto/put-object! storage {::sto/content content1
                                            ::sto/expired-at (dt/now)
                                            :content-type "text/plain"
@@ -107,16 +108,20 @@
         object2  (sto/put-object! storage {::sto/content content2
                                            ::sto/expired-at (dt/in-past {:hours 2})
                                            :content-type "text/plain"
+                                           })
+        object3  (sto/put-object! storage {::sto/content content3
+                                           ::sto/expired-at (dt/in-past {:hours 1})
+                                           :content-type "text/plain"
                                            })]
 
+
     (th/sleep 200)
 
-    (let [task (:app.storage/gc-deleted-task th/*system*)
-          res  (task {})]
+    (let [res (th/run-task! :storage-gc-deleted {})]
       (t/is (= 1 (:deleted res))))
 
     (let [res (db/exec-one! th/*pool* ["select count(*) from storage_object;"])]
-      (t/is (= 1 (:count res))))))
+      (t/is (= 2 (:count res))))))
 
 (t/deftest test-touched-gc-task-1
   (let [storage (-> (:app.storage/storage th/*system*)

common/deps.edn

@@ -1,40 +1,37 @@
 {:deps
  {org.clojure/clojure {:mvn/version "1.11.1"}
   org.clojure/data.json {:mvn/version "2.4.0"}
-  org.clojure/tools.cli {:mvn/version "1.0.214"}
+  org.clojure/tools.cli {:mvn/version "1.0.219"}
   org.clojure/clojurescript {:mvn/version "1.11.60"}
   org.clojure/test.check {:mvn/version "1.1.1"}
   org.clojure/data.fressian {:mvn/version "1.0.0"}
 
   ;; Logging
-  org.apache.logging.log4j/log4j-api {:mvn/version "2.19.0"}
-  org.apache.logging.log4j/log4j-core {:mvn/version "2.19.0"}
-  org.apache.logging.log4j/log4j-web {:mvn/version "2.19.0"}
-  org.apache.logging.log4j/log4j-jul {:mvn/version "2.19.0"}
-  org.apache.logging.log4j/log4j-slf4j2-impl {:mvn/version "2.19.0"}
-  org.slf4j/slf4j-api {:mvn/version "2.0.6"}
-  pl.tkowalcz.tjahzi/log4j2-appender {:mvn/version "0.9.26"}
+  org.apache.logging.log4j/log4j-api {:mvn/version "2.20.0"}
+  org.apache.logging.log4j/log4j-core {:mvn/version "2.20.0"}
+  org.apache.logging.log4j/log4j-web {:mvn/version "2.20.0"}
+  org.apache.logging.log4j/log4j-jul {:mvn/version "2.20.0"}
+  org.apache.logging.log4j/log4j-slf4j2-impl {:mvn/version "2.20.0"}
+  org.slf4j/slf4j-api {:mvn/version "2.0.7"}
+  pl.tkowalcz.tjahzi/log4j2-appender {:mvn/version "0.9.30"}
 
-  selmer/selmer {:mvn/version "1.12.55"}
+  selmer/selmer {:mvn/version "1.12.59"}
   criterium/criterium {:mvn/version "0.4.6"}
 
   metosin/jsonista {:mvn/version "0.3.7"}
   metosin/malli {:mvn/version "0.11.0"}
 
   expound/expound {:mvn/version "0.9.0"}
-  com.cognitect/transit-clj {:mvn/version "1.0.329"}
+  com.cognitect/transit-clj {:mvn/version "1.0.333"}
   com.cognitect/transit-cljs {:mvn/version "0.8.280"}
   java-http-clj/java-http-clj {:mvn/version "0.4.3"}
 
   funcool/cuerdas {:mvn/version "2022.06.16-403"}
-  funcool/promesa
-  {:git/tag "11.0-alpha13"
-   :git/sha "f6cab38"
-   :git/url "https://github.com/funcool/promesa.git"}
+  funcool/promesa {:mvn/version "11.0.678"}
   funcool/datoteka {:mvn/version "3.0.66"
                     :exclusions [funcool/promesa]}
 
-  lambdaisland/uri {:mvn/version "1.13.95"
+  lambdaisland/uri {:mvn/version "1.15.125"
                     :exclusions [org.clojure/data.json]}
 
   frankiesardo/linked {:mvn/version "1.3.0"}
@@ -44,14 +41,14 @@
 
   ;; exception printing
   fipp/fipp {:mvn/version "0.6.26"}
-  io.aviso/pretty {:mvn/version "1.3"}
+  io.aviso/pretty {:mvn/version "1.4.4"}
   environ/environ {:mvn/version "1.2.0"}}
  :paths ["src" "target/classes"]
  :aliases
  {:dev
   {:extra-deps
    {org.clojure/tools.namespace {:mvn/version "RELEASE"}
-    thheller/shadow-cljs {:mvn/version "2.20.16"}
+    thheller/shadow-cljs {:mvn/version "2.25.3"}
     com.bhauman/rebel-readline {:mvn/version "RELEASE"}
     criterium/criterium {:mvn/version "RELEASE"}
     mockery/mockery {:mvn/version "RELEASE"}}
@@ -59,7 +56,7 @@
 
   :build
   {:extra-deps
-   {io.github.clojure/tools.build {:git/tag "v0.9.3" :git/sha "e537cd1"}}
+   {io.github.clojure/tools.build {:git/tag "v0.9.5" :git/sha "24f2894"}}
    :ns-default build}
 
   :test

common/dev/user.clj

@@ -6,13 +6,18 @@
 
 (ns user
   (:require
+   [app.common.schema :as sm]
+   [app.common.schema.desc-js-like :as smdj]
+   [app.common.schema.desc-native :as smdn]
+   [app.common.schema.generators :as sg]
+   [app.common.pprint :as pp]
    [clojure.java.io :as io]
    [clojure.pprint :refer [pprint print-table]]
    [clojure.repl :refer :all]
    [clojure.spec.alpha :as s]
    [clojure.spec.gen.alpha :as sgen]
    [clojure.test :as test]
-   [clojure.test.check.generators :as gen]
+   [clojure.test.check.generators :as tgen]
    [clojure.tools.namespace.repl :as repl]
    [clojure.walk :refer [macroexpand-all]]
    [criterium.core  :as crit]))

common/package.json

@@ -4,17 +4,17 @@
   "main": "index.js",
   "license": "MPL-2.0",
   "dependencies": {
-    "luxon": "^3.3.0"
+    "luxon": "^3.4.2"
   },
   "scripts": {
-    "compile-and-watch-test": "clojure -M:dev:shadow-cljs watch test",
-    "compile-test": "clojure -M:dev:shadow-cljs compile test --config-merge '{:autorun false}'",
-    "run-test": "node target/test.js",
-    "test": "yarn run compile-test && yarn run run-test"
+    "test:watch": "clojure -M:dev:shadow-cljs watch test",
+    "test:compile": "clojure -M:dev:shadow-cljs compile test --config-merge '{:autorun false}'",
+    "test:run": "node target/test.js",
+    "test": "yarn run test:compile && yarn run test:run"
   },
   "devDependencies": {
-    "shadow-cljs": "2.20.16",
+    "shadow-cljs": "2.25.3",
     "source-map-support": "^0.5.21",
-    "ws": "^8.11.0"
+    "ws": "^8.13.0"
   }
 }

common/src/app/common/attrs.cljc

@@ -6,7 +6,7 @@
 
 (ns app.common.attrs
   (:require
-    [app.common.geom.shapes.transforms :as gtr]
+    [app.common.geom.shapes :as gsh]
     [app.common.math :as mth]))
 
 (defn- get-attr
@@ -24,7 +24,8 @@
         value
         (if-let [points (:points obj)]
           (if (not= points :multiple)
-            (let [rect (gtr/selection-rect [obj])]
+            ;; FIXME: consider using gsh/shape->rect ??
+            (let [rect (gsh/shapes->rect [obj])]
               (if (= attr :ox) (:x rect) (:y rect)))
             :multiple)
           (get obj attr ::unset)))

common/src/app/common/colors.cljc

@@ -21,3 +21,9 @@
 (def primary "#31EFB8")
 (def danger "#E65244")
 (def warning "#FC8802")
+
+;; new-css-system colors
+(def new-primary "#91fadb")
+(def new-danger "#ff4986")
+(def new-warning "#ff9b49")
+(def canvas-background "#1d1f20")

common/src/app/common/data.cljc

@@ -9,7 +9,7 @@
   data resources."
   (:refer-clojure :exclude [read-string hash-map merge name update-vals
                             parse-double group-by iteration concat mapcat
-                            parse-uuid])
+                            parse-uuid max min])
   #?(:cljs
      (:require-macros [app.common.data]))
 
@@ -18,6 +18,7 @@
       :clj [clojure.edn :as r])
    #?(:cljs [cljs.core :as c]
       :clj [clojure.core :as c])
+   #?(:cljs [goog.array :as garray])
    [app.common.math :as mth]
    [clojure.set :as set]
    [cuerdas.core :as str]
@@ -145,10 +146,6 @@
      (transient-concat c1 more)
      (transient-concat [] (cons c1 more)))))
 
-(defn preconj
-  [coll elem]
-  (into [elem] coll))
-
 (defn enumerate
   ([items] (enumerate items 0))
   ([items start]
@@ -236,12 +233,9 @@
   "Return a map without the keys provided
   in the `keys` parameter."
   [data keys]
-  (persistent!
-   (reduce dissoc!
-           (if (editable-collection? data)
-             (transient data)
-             (transient {}))
-           keys)))
+  (if (editable-collection? data)
+    (persistent! (reduce dissoc! (transient data) keys))
+    (reduce dissoc data keys)))
 
 (defn remove-at-index
   "Takes a vector and returns a vector with an element in the
@@ -590,23 +584,47 @@
   ([a]
    (mth/finite? a))
   ([a b]
-   (and (mth/finite? a)
-        (mth/finite? b)))
+   (and ^boolean (mth/finite? a)
+        ^boolean (mth/finite? b)))
   ([a b c]
-   (and (mth/finite? a)
-        (mth/finite? b)
-        (mth/finite? c)))
+   (and ^boolean (mth/finite? a)
+        ^boolean (mth/finite? b)
+        ^boolean (mth/finite? c)))
   ([a b c d]
-   (and (mth/finite? a)
-        (mth/finite? b)
-        (mth/finite? c)
-        (mth/finite? d)))
+   (and ^boolean (mth/finite? a)
+        ^boolean (mth/finite? b)
+        ^boolean (mth/finite? c)
+        ^boolean (mth/finite? d)))
   ([a b c d & others]
-   (and (mth/finite? a)
-        (mth/finite? b)
-        (mth/finite? c)
-        (mth/finite? d)
-        (every? mth/finite? others))))
+   (and ^boolean (mth/finite? a)
+        ^boolean (mth/finite? b)
+        ^boolean (mth/finite? c)
+        ^boolean (mth/finite? d)
+        ^boolean (every? mth/finite? others))))
+
+(defn safe+
+  [a b]
+  (if (mth/finite? a) (+ a b) a))
+
+(defn max
+  ([a] a)
+  ([a b] (mth/max a b))
+  ([a b c] (mth/max a b c))
+  ([a b c d] (mth/max a b c d))
+  ([a b c d e] (mth/max a b c d e))
+  ([a b c d e f] (mth/max a b c d e f))
+  ([a b c d e f & other]
+   (reduce max (mth/max a b c d e f) other)))
+
+(defn min
+  ([a] a)
+  ([a b] (mth/min a b))
+  ([a b c] (mth/min a b c))
+  ([a b c d] (mth/min a b c d))
+  ([a b c d e] (mth/min a b c d e))
+  ([a b c d e f] (mth/min a b c d e f))
+  ([a b c d e f & other]
+   (reduce min (mth/min a b c d e f) other)))
 
 (defn check-num
   "Function that checks if a number is nil or nan. Will return 0 when not
@@ -752,6 +770,24 @@
                [key (delay (generator-fn key))]))
         keys))
 
+(defn opacity-to-hex [opacity]
+  (let [opacity (* opacity 255)
+        value   (mth/round opacity)]
+    (.. value
+        (toString 16)
+        (padStart 2 "0"))))
+
+(defn unstable-sort
+  ([items]
+   (unstable-sort compare items))
+  ([comp-fn items]
+   #?(:cljs
+      (let [items (to-array items)]
+        (garray/sort items comp-fn)
+        (seq items))
+      :clj
+      (sort comp-fn items))))
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; String Functions

common/src/app/common/data/macros.cljc

@@ -7,7 +7,7 @@
 #_:clj-kondo/ignore
 (ns app.common.data.macros
   "Data retrieval & manipulation specific macros."
-  (:refer-clojure :exclude [get-in select-keys str with-open])
+  (:refer-clojure :exclude [get-in select-keys str with-open min max])
   #?(:cljs (:require-macros [app.common.data.macros]))
   (:require
    #?(:clj [clojure.core :as c]
@@ -120,13 +120,10 @@
   "A macro based, optimized variant of `get` that access the property
   directly on CLJS, on CLJ works as get."
   [obj prop]
-  ;; `(do
-  ;;    (when-not (record? ~obj)
-  ;;      (js/console.trace (pr-str ~obj)))
-  ;;    (c/get ~obj ~prop)))
   (if (:ns &env)
     (list (symbol ".") (with-meta obj {:tag 'js}) (symbol (str "-" (c/name prop))))
-    `(c/get ~obj ~prop)))
+    (list `c/get obj prop)))
+
 
 (def ^:dynamic *assert-context* nil)
 
@@ -154,7 +151,7 @@
 
 (defmacro verify!
   ([expr]
-   `(assert! nil ~expr))
+   `(verify! nil ~expr))
   ([hint expr]
    (let [hint (cond
                 (vector? hint)

common/src/app/common/encoding_impl.js

@@ -0,0 +1,211 @@
+/**
+ * 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
+ */
+"use strict";
+
+goog.require("cljs.core");
+goog.provide("app.common.encoding_impl");
+
+goog.scope(function() {
+  const core = cljs.core;
+  const global = goog.global;
+  const self = app.common.encoding_impl;
+
+  const hexMap = [];
+  for (let i = 0; i < 256; i++) {
+    hexMap[i] = (i + 0x100).toString(16).substr(1);
+  }
+
+  function hexToBuffer(input) {
+    if (typeof input !== "string") {
+      throw new TypeError("Expected input to be a string");
+    }
+
+    // Accept UUID hex format
+    input = input.replace(/-/g, "");
+
+    if ((input.length % 2) !== 0) {
+      throw new RangeError("Expected string to be an even number of characters")
+    }
+
+    const view = new Uint8Array(input.length / 2);
+
+    for (let i = 0; i < input.length; i += 2) {
+      view[i / 2] = parseInt(input.substring(i, i + 2), 16);
+    }
+
+    return view.buffer;
+  }
+
+  function bufferToHex(source, isUuid) {
+    if (source instanceof Uint8Array) {
+    } else if (ArrayBuffer.isView(source)) {
+      source = new Uint8Array(source.buffer, source.byteOffset, source.byteLength);
+    } else if (Array.isArray(source)) {
+      source = Uint8Array.from(source);
+    }
+
+    if (source.length != 16) {
+      throw new RangeError("only 16 bytes array is allowed");
+    }
+
+    const spacer = isUuid ? "-" : "";
+
+    let i = 0;
+    return  (hexMap[source[i++]] +
+             hexMap[source[i++]] +
+             hexMap[source[i++]] +
+             hexMap[source[i++]] + spacer +
+             hexMap[source[i++]] +
+             hexMap[source[i++]] + spacer +
+             hexMap[source[i++]] +
+             hexMap[source[i++]] + spacer +
+             hexMap[source[i++]] +
+             hexMap[source[i++]] + spacer +
+             hexMap[source[i++]] +
+             hexMap[source[i++]] +
+             hexMap[source[i++]] +
+             hexMap[source[i++]] +
+             hexMap[source[i++]] +
+             hexMap[source[i++]]);
+  }
+
+  self.hexToBuffer = hexToBuffer;
+  self.bufferToHex = bufferToHex;
+
+  // base-x encoding / decoding
+  // Copyright (c) 2018 base-x contributors
+  // Copyright (c) 2014-2018 The Bitcoin Core developers (base58.cpp)
+  // Distributed under the MIT software license, see the accompanying
+  // file LICENSE or http://www.opensource.org/licenses/mit-license.php.
+
+  // WARNING: This module is NOT RFC3548 compliant, it cannot be used
+  // for base16 (hex), base32, or base64 encoding in a standards
+  // compliant manner.
+
+  function getBaseCodec (ALPHABET) {
+    if (ALPHABET.length >= 255) { throw new TypeError("Alphabet too long"); }
+    let BASE_MAP = new Uint8Array(256);
+    for (let j = 0; j < BASE_MAP.length; j++) {
+      BASE_MAP[j] = 255;
+    }
+    for (let i = 0; i < ALPHABET.length; i++) {
+      let x = ALPHABET.charAt(i);
+      let xc = x.charCodeAt(0);
+      if (BASE_MAP[xc] !== 255) { throw new TypeError(x + " is ambiguous"); }
+      BASE_MAP[xc] = i;
+    }
+    let BASE = ALPHABET.length;
+    let LEADER = ALPHABET.charAt(0);
+    let FACTOR = Math.log(BASE) / Math.log(256); // log(BASE) / log(256), rounded up
+    let iFACTOR = Math.log(256) / Math.log(BASE); // log(256) / log(BASE), rounded up
+    function encode (source) {
+      if (source instanceof Uint8Array) {
+      } else if (ArrayBuffer.isView(source)) {
+        source = new Uint8Array(source.buffer, source.byteOffset, source.byteLength);
+      } else if (Array.isArray(source)) {
+        source = Uint8Array.from(source);
+      }
+      if (!(source instanceof Uint8Array)) { throw new TypeError("Expected Uint8Array"); }
+      if (source.length === 0) { return ""; }
+      // Skip & count leading zeroes.
+      let zeroes = 0;
+      let length = 0;
+      let pbegin = 0;
+      let pend = source.length;
+      while (pbegin !== pend && source[pbegin] === 0) {
+        pbegin++;
+        zeroes++;
+      }
+      // Allocate enough space in big-endian base58 representation.
+      let size = ((pend - pbegin) * iFACTOR + 1) >>> 0;
+      let b58 = new Uint8Array(size);
+      // Process the bytes.
+      while (pbegin !== pend) {
+        let carry = source[pbegin];
+        // Apply "b58 = b58 * 256 + ch".
+        let i = 0;
+        for (let it1 = size - 1; (carry !== 0 || i < length) && (it1 !== -1); it1--, i++) {
+          carry += (256 * b58[it1]) >>> 0;
+          b58[it1] = (carry % BASE) >>> 0;
+          carry = (carry / BASE) >>> 0;
+        }
+        if (carry !== 0) { throw new Error("Non-zero carry"); }
+        length = i;
+        pbegin++;
+      }
+      // Skip leading zeroes in base58 result.
+      let it2 = size - length;
+      while (it2 !== size && b58[it2] === 0) {
+        it2++;
+      }
+      // Translate the result into a string.
+      let str = LEADER.repeat(zeroes);
+      for (; it2 < size; ++it2) { str += ALPHABET.charAt(b58[it2]); }
+      return str;
+    }
+
+    function decodeUnsafe (source) {
+      if (typeof source !== "string") { throw new TypeError("Expected String"); }
+      if (source.length === 0) { return new Uint8Array(); }
+      let psz = 0;
+      // Skip and count leading '1's.
+      let zeroes = 0;
+      let length = 0;
+      while (source[psz] === LEADER) {
+        zeroes++;
+        psz++;
+      }
+      // Allocate enough space in big-endian base256 representation.
+      let size = (((source.length - psz) * FACTOR) + 1) >>> 0; // log(58) / log(256), rounded up.
+      let b256 = new Uint8Array(size);
+      // Process the characters.
+      while (source[psz]) {
+        // Decode character
+        let carry = BASE_MAP[source.charCodeAt(psz)];
+        // Invalid character
+        if (carry === 255) { return; }
+        let i = 0;
+        for (let it3 = size - 1; (carry !== 0 || i < length) && (it3 !== -1); it3--, i++) {
+          carry += (BASE * b256[it3]) >>> 0;
+          b256[it3] = (carry % 256) >>> 0;
+          carry = (carry / 256) >>> 0;
+        }
+        if (carry !== 0) { throw new Error("Non-zero carry"); }
+        length = i;
+        psz++;
+      }
+      // Skip leading zeroes in b256.
+      let it4 = size - length;
+      while (it4 !== size && b256[it4] === 0) {
+        it4++;
+      }
+      let vch = new Uint8Array(zeroes + (size - it4));
+      let j = zeroes;
+      while (it4 !== size) {
+        vch[j++] = b256[it4++];
+      }
+      return vch;
+    }
+
+    function decode (string) {
+      let buffer = decodeUnsafe(string);
+      if (buffer) { return buffer; }
+      throw new Error("Non-base" + BASE + " character");
+    }
+
+    return {
+      encode: encode,
+      decodeUnsafe: decodeUnsafe,
+      decode: decode
+    };
+  }
+  // MORE bases here: https://github.com/cryptocoinjs/base-x/tree/master
+  const BASE62 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789";
+  self.bufferToBase62 = getBaseCodec(BASE62).encode;
+
+});

common/src/app/common/exceptions.cljc

@@ -32,11 +32,6 @@
   [& params]
   `(throw (error ~@params)))
 
-;; FIXME deprecate
-(defn try*
-  [f on-error]
-  (try (f) (catch #?(:clj Throwable :cljs :default) e (on-error e))))
-
 ;; http://clj-me.cgrand.net/2013/09/11/macros-closures-and-unexpected-object-retention/
 ;; Explains the use of ^:once metadata
 

common/src/app/common/files/builder.cljc

@@ -4,14 +4,13 @@
 ;;
 ;; Copyright (c) KALEIDOS INC
 
-(ns app.common.file-builder
-  "A version parsing helper."
+(ns app.common.files.builder
   (:require
    [app.common.data :as d]
    [app.common.data.macros :as dm]
    [app.common.exceptions :as ex]
-   [app.common.geom.matrix :as gmt]
    [app.common.geom.point :as gpt]
+   [app.common.geom.rect :as grc]
    [app.common.geom.shapes :as gsh]
    [app.common.pages.changes :as ch]
    [app.common.pprint :as pp]
@@ -25,9 +24,9 @@
    [app.common.uuid :as uuid]
    [cuerdas.core :as str]))
 
-(def root-frame uuid/zero)
-(def conjv (fnil conj []))
-(def conjs (fnil conj #{}))
+(def ^:private root-id uuid/zero)
+(def ^:private conjv (fnil conj []))
+(def ^:private conjs (fnil conj #{}))
 
 (defn- commit-change
   ([file change]
@@ -38,35 +37,33 @@
                  :or   {add-container? false
                         fail-on-spec? false}}]
    (let [component-id (:current-component-id file)
-         change (cond-> change
-                  (and add-container? (some? component-id))
-                  (cond->
-                   :always
-                    (assoc :component-id component-id)
+         change       (cond-> change
+                        (and add-container? (some? component-id))
+                        (-> (assoc :component-id component-id)
+                            (cond-> (some? (:current-frame-id file))
+                              (assoc :frame-id (:current-frame-id file))))
 
-                    (some? (:current-frame-id file))
-                    (assoc :frame-id (:current-frame-id file)))
+                        (and add-container? (nil? component-id))
+                        (assoc :page-id  (:current-page-id file)
+                               :frame-id (:current-frame-id file)))
+         valid? (ch/valid-change? change)]
 
-                  (and add-container? (nil? component-id))
-                  (assoc :page-id  (:current-page-id file)
-                         :frame-id (:current-frame-id file)))]
+     (when-not valid?
+       (let [explain (sm/explain ::ch/change change)]
+         (pp/pprint (sm/humanize-data explain))
+         (when fail-on-spec?
+           (ex/raise :type :assertion
+                     :code :data-validation
+                     :hint "invalid change"
+                     ::sm/explain explain))))
 
-     (when fail-on-spec?
-       (dm/verify! (ch/change? change)))
+     (cond-> file
+       valid?
+       (-> (update :changes conjv change)
+           (update :data ch/process-changes [change] false))
 
-     (let [valid? (ch/change? change)]
-       (when-not valid?
-         (pp/pprint change {:level 100})
-         (sm/pretty-explain ::ch/change change))
-
-
-       (cond-> file
-         valid?
-         (-> (update :changes conjv change)
-             (update :data ch/process-changes [change] false))
-
-         (not valid?)
-         (update :errors conjv change))))))
+       (not valid?)
+       (update :errors conjv change)))))
 
 (defn- lookup-objects
   ([file]
@@ -91,50 +88,6 @@
 
     (commit-change file change {:add-container? true :fail-on-spec? fail-on-spec?})))
 
-(defn setup-rect-selrect [{:keys [x y width height transform] :as obj}]
-  (when-not (d/num? x y width height)
-    (ex/raise :type :assertion
-              :code :invalid-condition
-              :hint "Coords not valid for object"))
-
-  (let [rect      (gsh/make-rect x y width height)
-        center    (gsh/center-rect rect)
-        selrect   (gsh/rect->selrect rect)
-
-        points (-> (gsh/rect->points rect)
-                   (gsh/transform-points center transform))]
-
-    (-> obj
-        (assoc :selrect selrect)
-        (assoc :points points))))
-
-(defn- setup-path-selrect
-  [{:keys [content center transform transform-inverse] :as obj}]
-
-  (when (or (empty? content) (nil? center))
-    (ex/raise :type :assertion
-              :code :invalid-condition
-              :hint "Path not valid"))
-
-  (let [transform (gmt/transform-in center transform)
-        transform-inverse (gmt/transform-in center transform-inverse)
-
-        content' (gsh/transform-content content transform-inverse)
-        selrect  (gsh/content->selrect content')
-        points   (-> (gsh/rect->points selrect)
-                     (gsh/transform-points transform))]
-
-    (-> obj
-        (dissoc :center)
-        (assoc :selrect selrect)
-        (assoc :points points))))
-
-(defn- setup-selrect
-  [obj]
-  (if (= (:type obj) :path)
-    (setup-path-selrect obj)
-    (setup-rect-selrect obj)))
-
 (defn- generate-name
   [type data]
   (if (= type :svg-raw)
@@ -203,10 +156,10 @@
         (assoc :current-page-id page-id)
 
         ;; Current frame-id
-        (assoc :current-frame-id root-frame)
+        (assoc :current-frame-id root-id)
 
         ;; Current parent stack we'll be nesting
-        (assoc :parent-stack [root-frame])
+        (assoc :parent-stack [root-id])
 
         ;; Last object id added
         (assoc :last-id nil))))
@@ -220,11 +173,8 @@
       (clear-names)))
 
 (defn add-artboard [file data]
-  (let [obj (-> (cts/make-minimal-shape :frame)
-                (merge data)
-                (check-name file :frame)
-                (setup-selrect)
-                (d/without-nils))]
+  (let [obj (-> (cts/setup-shape (assoc data :type :frame))
+                (check-name file :frame))]
     (-> file
         (commit-shape obj)
         (assoc :current-frame-id (:id obj))
@@ -237,19 +187,15 @@
         parent (lookup-shape file parent-id)
         current-frame-id (or (:frame-id parent)
                              (when (nil? (:current-component-id file))
-                               root-frame))]
+                               root-id))]
     (-> file
         (assoc :current-frame-id current-frame-id)
         (update :parent-stack pop))))
 
 (defn add-group [file data]
   (let [frame-id (:current-frame-id file)
-        selrect cts/empty-selrect
-        name (:name data)
-        obj (-> (cts/make-minimal-group frame-id selrect name)
-                (merge data)
-                (check-name file :group)
-                (d/without-nils))]
+        obj      (-> (cts/setup-shape (assoc data :type :group :frame-id frame-id))
+                     (check-name file :group))]
     (-> file
         (commit-shape obj)
         (assoc :last-id (:id obj))
@@ -271,7 +217,7 @@
             :id group-id}
            {:add-container? true})
 
-          (:masked-group? group)
+          (:masked-group group)
           (let [mask (first children)]
             (commit-change
              file
@@ -309,15 +255,8 @@
 
 (defn add-bool [file data]
   (let [frame-id (:current-frame-id file)
-        name (:name data)
-        obj (-> {:id (uuid/next)
-                 :type :bool
-                 :name name
-                 :shapes []
-                 :frame-id frame-id}
-                (merge data)
-                (check-name file :bool)
-                (d/without-nils))]
+        obj      (-> (cts/setup-shape (assoc data :type :bool :frame-id frame-id))
+                     (check-name file :bool))]
     (-> file
         (commit-shape obj)
         (assoc :last-id (:id obj))
@@ -341,13 +280,15 @@
 
           :else
           (let [objects (lookup-objects file)
+                bool-content (gsh/calc-bool-content bool objects)
                 bool' (gsh/update-bool-selrect bool children objects)]
             (commit-change
              file
              {:type :mod-obj
               :id bool-id
               :operations
-              [{:type :set :attr :selrect :val (:selrect bool') :ignore-touched true}
+              [{:type :set :attr :bool-content :val bool-content :ignore-touched true}
+               {:type :set :attr :selrect :val (:selrect bool') :ignore-touched true}
                {:type :set :attr :points  :val (:points bool') :ignore-touched true}
                {:type :set :attr :x       :val (-> bool' :selrect :x) :ignore-touched true}
                {:type :set :attr :y       :val (-> bool' :selrect :y) :ignore-touched true}
@@ -360,11 +301,8 @@
         (update :parent-stack pop))))
 
 (defn create-shape [file type data]
-  (let [obj (-> (cts/make-minimal-shape type)
-                (merge data)
-                (check-name file :type)
-                (setup-selrect)
-                (d/without-nils))]
+  (let [obj (-> (cts/setup-shape (assoc data :type type))
+                (check-name file :type))]
     (-> file
         (commit-shape obj)
         (assoc :last-id (:id obj))
@@ -556,23 +494,33 @@
          {:type :del-media
           :id id}))))
 
+
 (defn start-component
   ([file data] (start-component file data :group))
   ([file data root-type]
-   (let [selrect (or (gsh/make-selrect (:x data) (:y data) (:width data) (:height data))
-                     cts/empty-selrect)
+   ;; FIXME: data probably can be a shape instance, then we can use gsh/shape->rect
+   (let [selrect (or (grc/make-rect (:x data) (:y data) (:width data) (:height data))
+                     grc/empty-rect)
          name               (:name data)
          path               (:path data)
          main-instance-id   (:main-instance-id data)
          main-instance-page (:main-instance-page data)
-         obj (-> (cts/make-shape root-type selrect data)
-                 (dissoc :path
-                         :main-instance-id
-                         :main-instance-page
-                         :main-instance-x
-                         :main-instance-y)
-                 (check-name file root-type)
-                 (d/without-nils))]
+         attrs (-> data
+                   (assoc :type root-type)
+                   (assoc :x (:x selrect))
+                   (assoc :y (:y selrect))
+                   (assoc :width (:width selrect))
+                   (assoc :height (:height selrect))
+                   (assoc :selrect selrect)
+                   (dissoc :path)
+                   (dissoc :main-instance-id)
+                   (dissoc :main-instance-page)
+                   (dissoc :main-instance-x)
+                   (dissoc :main-instance-y))
+
+         obj   (-> (cts/setup-shape attrs)
+                   (check-name file root-type))]
+
      (-> file
          (commit-change
           {:type :add-component
@@ -604,7 +552,7 @@
             :id component-id
             :skip-undelete? true})
 
-          (:masked-group? component)
+          (:masked-group component)
           (let [mask (first children)]
             (commit-change
              file
@@ -660,7 +608,7 @@
                                      (gpt/point main-instance-x
                                                 main-instance-y)
                                      true
-                                     {:main-instance? true
+                                     {:main-instance true
                                       :force-id main-instance-id})]
     (as-> file $
       (reduce #(commit-change %1
@@ -703,7 +651,7 @@
                                      (gpt/point x
                                                 y)
                                      components-v2
-                                     #_{:main-instance? true
+                                     #_{:main-instance true
                                         :force-id main-instance-id})]
 
     (as-> file $
@@ -734,8 +682,8 @@
 (defn update-object
   [file old-obj new-obj]
   (let [page-id (:current-page-id file)
-        new-obj (setup-selrect new-obj)
-        attrs (d/concat-set (keys old-obj) (keys new-obj))
+        new-obj (cts/setup-shape new-obj)
+        attrs   (d/concat-set (keys old-obj) (keys new-obj))
         generate-operation
         (fn [changes attr]
           (let [old-val (get old-obj attr)

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

@@ -0,0 +1,9 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC
+
+(ns app.common.files.defaults)
+
+(def version 31)

common/src/app/common/files/helpers.cljc

@@ -0,0 +1,46 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC
+
+(ns app.common.files.helpers
+  (:require
+   [app.common.data :as d]
+   [app.common.data.macros :as dm]
+   [app.common.schema :as sm]))
+
+(defn get-used-names
+  "Return a set with the all unique names used in the
+  elements (any entity thas has a :name)"
+  [elements]
+  (let [elements (if (map? elements)
+                   (vals elements)
+                   elements)]
+    (into #{} (keep :name) elements)))
+
+(defn- extract-numeric-suffix
+  [basename]
+  (if-let [[_ p1 p2] (re-find #"(.*) ([0-9]+)$" basename)]
+    [p1 (+ 1 (d/parse-integer p2))]
+    [basename 1]))
+
+(defn generate-unique-name
+  "A unique name generator"
+  [used basename]
+  (dm/assert!
+   "expected a set of strings"
+   (sm/set-of-strings? used))
+
+  (dm/assert!
+   "expected a string for `basename`."
+   (string? basename))
+
+  (if-not (contains? used basename)
+    basename
+    (let [[prefix initial] (extract-numeric-suffix basename)]
+      (loop [counter initial]
+        (let [candidate (str prefix " " counter)]
+          (if (contains? used candidate)
+            (recur (inc counter))
+            candidate))))))

common/src/app/common/files/migrations.cljc

@@ -4,35 +4,36 @@
 ;;
 ;; Copyright (c) KALEIDOS INC
 
-(ns app.common.pages.migrations
+(ns app.common.files.migrations
   (:require
    [app.common.data :as d]
    [app.common.data.macros :as dm]
+   [app.common.files.defaults :refer [version]]
    [app.common.geom.matrix :as gmt]
+   [app.common.geom.rect :as grc]
    [app.common.geom.shapes :as gsh]
    [app.common.geom.shapes.path :as gsp]
    [app.common.geom.shapes.text :as gsht]
-   [app.common.logging :as log]
+   [app.common.logging :as l]
    [app.common.math :as mth]
-   [app.common.pages :as cp]
+   [app.common.pages.changes :as cpc]
    [app.common.pages.helpers :as cph]
+   [app.common.text :as txt]
    [app.common.types.shape :as cts]
    [app.common.uuid :as uuid]
    [cuerdas.core :as str]))
 
-;; TODO: revisit this and rename to file-migrations
+#?(:cljs (l/set-level! :info))
 
 (defmulti migrate :version)
 
-(log/set-level! :info)
-
 (defn migrate-data
-  ([data] (migrate-data data cp/file-version))
+  ([data] (migrate-data data version))
   ([data to-version]
    (if (= (:version data) to-version)
      data
      (let [migrate-fn #(do
-                         (log/trace :hint "migrate file" :id (:id %) :version-from %2 :version-to (inc %2))
+                         (l/dbg :hint "migrate file" :id (:id %) :version-from %2 :version-to (inc %2))
                          (migrate (assoc %1 :version (inc %2))))]
        (reduce migrate-fn data (range (:version data 0) to-version))))))
 
@@ -45,8 +46,9 @@
 
 (defn migrated?
   [{:keys [data] :as file}]
-  (> (:version data)
-     (::orig-version file)))
+  (or (::migrated file)
+      (> (:version data)
+         (::orig-version file))))
 
 ;; Default handler, noop
 (defmethod migrate :default [data] data)
@@ -74,7 +76,7 @@
             (if-not (contains? shape :content)
               (let [content (gsp/segments->content (:segments shape) (:close? shape))
                     selrect (gsh/content->selrect content)
-                    points  (gsh/rect->points selrect)]
+                    points  (grc/rect->points selrect)]
                 (-> shape
                     (dissoc :segments)
                     (dissoc :close?)
@@ -87,17 +89,17 @@
           (fix-frames-selrects [frame]
             (if (= (:id frame) uuid/zero)
               frame
-              (let [frame-rect (select-keys frame [:x :y :width :height])]
+              (let [selrect (gsh/shape->rect frame)]
                 (-> frame
-                    (assoc :selrect (gsh/rect->selrect frame-rect))
-                    (assoc :points (gsh/rect->points frame-rect))))))
+                    (assoc :selrect selrect)
+                    (assoc :points (grc/rect->points selrect))))))
 
           (fix-empty-points [shape]
             (let [shape (cond-> shape
-                          (empty? (:selrect shape)) (cts/setup-rect-selrect))]
+                          (empty? (:selrect shape)) (cts/setup-rect))]
               (cond-> shape
                 (empty? (:points shape))
-                (assoc :points (gsh/rect->points (:selrect shape))))))
+                (assoc :points (grc/rect->points (:selrect shape))))))
 
           (update-object [object]
             (cond-> object
@@ -141,10 +143,10 @@
   ;; Fixes issues with selrect/points for shapes with width/height = 0 (line-like paths)"
   (letfn [(fix-line-paths [shape]
             (if (= (:type shape) :path)
-              (let [{:keys [width height]} (gsh/points->rect (:points shape))]
+              (let [{:keys [width height]} (grc/points->rect (:points shape))]
                 (if (or (mth/almost-zero? width) (mth/almost-zero? height))
                   (let [selrect (gsh/content->selrect (:content shape))
-                        points (gsh/rect->points selrect)
+                        points (grc/rect->points selrect)
                         transform (gmt/matrix)
                         transform-inv (gmt/matrix)]
                     (assoc shape
@@ -242,7 +244,7 @@
     (loop [data data]
       (let [changes (mapcat calculate-changes (:pages-index data))]
         (if (seq changes)
-          (recur (cp/process-changes data changes))
+          (recur (cpc/process-changes data changes))
           data)))))
 
 (defmethod migrate 10
@@ -436,7 +438,67 @@
         (update :pages-index update-vals update-container)
         (update :components update-vals update-container))))
 
-(defmethod migrate 20
+(defmethod migrate 25
+  [data]
+  (letfn [(update-object [object]
+            (-> object
+                (d/update-when :selrect grc/make-rect)
+                (cts/map->Shape)))
+          (update-container [container]
+            (d/update-when container :objects update-vals update-object))]
+    (-> data
+        (update :pages-index update-vals update-container)
+        (update :components update-vals update-container))))
+
+(defmethod migrate 26
+  [data]
+  (letfn [(update-object [object]
+            (cond-> object
+              (nil? (:transform object))
+              (assoc :transform (gmt/matrix))
+
+              (nil? (:transform-inverse object))
+              (assoc :transform-inverse (gmt/matrix))))
+
+          (update-container [container]
+            (d/update-when container :objects update-vals update-object))]
+
+    (-> data
+        (update :pages-index update-vals update-container)
+        (update :components update-vals update-container))))
+
+(defmethod migrate 27
+  [data]
+  (letfn [(update-object [object]
+            (cond-> object
+              (contains? object :main-instance?)
+              (-> (assoc :main-instance (:main-instance? object))
+                  (dissoc :main-instance?))
+
+              (contains? object :component-root?)
+              (-> (assoc :component-root (:component-root? object))
+                  (dissoc :component-root?))
+
+              (contains? object :remote-synced?)
+              (-> (assoc :remote-synced (:remote-synced? object))
+                  (dissoc :remote-synced?))
+
+              (contains? object :masked-group?)
+              (-> (assoc :masked-group (:masked-group? object))
+                  (dissoc :masked-group?))
+
+              (contains? object :saved-component-root?)
+              (-> (assoc :saved-component-root (:saved-component-root? object))
+                  (dissoc :saved-component-root?))))
+
+          (update-container [container]
+            (d/update-when container :objects update-vals update-object))]
+
+    (-> data
+        (update :pages-index update-vals update-container)
+        (update :components update-vals update-container))))
+
+(defmethod migrate 28
   [data]
   (letfn [(update-object [objects object]
             (let [frame-id (:frame-id object)
@@ -448,11 +510,11 @@
                       ;; If we cannot find any we let the frame-id as it was before
                       frame-id)]
               (when (not= frame-id calculated-frame-id)
-                (log/info :hint "Fix wrong frame-id"
-                          :shape (:name object)
-                          :id (:id object)
-                          :current (dm/get-in objects [frame-id :name])
-                          :calculated (get-in objects [calculated-frame-id :name])))
+                (l/trc :hint "Fix wrong frame-id"
+                       :shape (:name object)
+                       :id (:id object)
+                       :current (dm/get-in objects [frame-id :name])
+                       :calculated (get-in objects [calculated-frame-id :name])))
               (assoc object :frame-id calculated-frame-id)))
 
           (update-container [container]
@@ -464,3 +526,68 @@
 
 ;; TODO: pending to do a migration for delete already not used fill
 ;; and stroke props. This should be done for >1.14.x version.
+
+(defmethod migrate 29
+  [data]
+  (letfn [(valid-ref? [ref]
+            (or (uuid? ref)
+                (nil? ref)))
+
+          (valid-node? [node]
+            (and (valid-ref? (:typography-ref-file node))
+                 (valid-ref? (:typography-ref-id node))
+                 (valid-ref? (:fill-color-ref-file node))
+                 (valid-ref? (:fill-color-ref-id node))))
+
+          (fix-ref [ref]
+            (if (valid-ref? ref) ref nil))
+
+          (fix-node [node]
+            (-> node
+                (d/update-when :typography-ref-file fix-ref)
+                (d/update-when :typography-ref-id fix-ref)
+                (d/update-when :fill-color-ref-file fix-ref)
+                (d/update-when :fill-color-ref-id fix-ref)))
+
+          (update-object [object]
+            (let [invalid-node? (complement valid-node?)]
+              (cond-> object
+                (cph/text-shape? object)
+                (update :content #(txt/transform-nodes invalid-node? fix-node %)))))
+
+          (update-container [container]
+            (update container :objects update-vals update-object))]
+
+    (-> data
+        (update :pages-index update-vals update-container)
+        (update :components update-vals update-container))))
+
+(defmethod migrate 30
+  [data]
+  (letfn [(update-object [object]
+            (if (and (cph/frame-shape? object)
+                     (not (:shapes object)))
+              (assoc object :shapes [])
+              object))
+
+          (update-container [container]
+            (update container :objects update-vals update-object))]
+
+    (-> data
+        (update :pages-index update-vals update-container)
+        (update :components update-vals update-container))))
+
+(defmethod migrate 31
+  [data]
+  (letfn [(update-object [object]
+            (cond-> object
+              (contains? object :use-for-thumbnail?)
+              (-> (assoc :use-for-thumbnail (:use-for-thumbnail? object))
+                  (dissoc :use-for-thumbnail?))))
+
+          (update-container [container]
+            (d/update-when container :objects update-vals update-object))]
+
+    (-> data
+        (update :pages-index update-vals update-container)
+        (update :components update-vals update-container))))

common/src/app/common/files/repair.cljc

@@ -0,0 +1,374 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC
+
+(ns app.common.files.repair
+  (:require
+   [app.common.data :as d]
+   [app.common.logging :as log]
+   [app.common.pages.changes-builder :as pcb]
+   [app.common.pages.helpers :as cph]
+   [app.common.types.component :as ctk]
+   [app.common.types.components-list :as ctkl]
+   [app.common.types.container :as ctn]
+   [app.common.types.file :as ctf]
+   [app.common.types.pages-list :as ctpl]
+   [app.common.uuid :as uuid]))
+
+(log/set-level! :debug)
+
+(defmulti repair-error
+  (fn [code _error _file-data _libraries] code))
+
+(defmethod repair-error :parent-not-found
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; Set parent to root frame.
+          (log/debug :hint "  -> Set to " :parent-id uuid/zero)
+          (assoc shape :parent-id uuid/zero))]
+
+    (log/info :hint "Repairing shape :parent-not-found" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :child-not-in-parent
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [parent-shape]
+          ; Add shape to parent's children list
+          (log/debug :hint "  -> Add children to" :parent-id (:id parent-shape))
+          (update parent-shape :shapes conj (:id shape)))]
+ 
+    (log/info :hint "Repairing shape :child-not-in-parent" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:parent-id shape)] repair-shape))))
+
+(defmethod repair-error :child-not-found
+  [_ {:keys [shape page-id args] :as error} file-data _]
+  (let [repair-shape
+        (fn [parent-shape]
+          ; Remove child shape from children list
+          (log/debug :hint "  -> Remove child " :child-id (:child-id args))
+          (update parent-shape :shapes d/removev #(= % (:child-id args))))]
+ 
+    (log/info :hint "Repairing shape :child-not-found" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :frame-not-found
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; Locate the first frame in parents and set frame-id to it.
+          (let [page     (ctpl/get-page file-data page-id)
+                frame    (cph/get-frame (:objects page) (:parent-id shape))
+                frame-id (or (:id frame) uuid/zero)]
+            (log/debug :hint "  -> Set to " :frame-id frame-id)
+            (assoc shape :frame-id frame-id)))]
+ 
+    (log/info :hint "Repairing shape :frame-not-found" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :invalid-frame
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; Locate the first frame in parents and set frame-id to it.
+          (let [page     (ctpl/get-page file-data page-id)
+                frame    (cph/get-frame (:objects page) (:parent-id shape))
+                frame-id (or (:id frame) uuid/zero)]
+            (log/debug :hint "  -> Set to " :frame-id frame-id)
+            (assoc shape :frame-id frame-id)))]
+ 
+    (log/info :hint "Repairing shape :invalid-frame" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :component-not-main
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; Set the :shape as main instance root
+          (log/debug :hint "  -> Set :main-instance")
+          (assoc shape :main-instance true))]
+ 
+    (log/info :hint "Repairing shape :component-not-main" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :component-main-external
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; There is no solution that may recover it with confidence
+          (log/warn :hint "  -> CANNOT REPAIR THIS AUTOMATICALLY.")
+          shape)]
+ 
+    (log/info :hint "Repairing shape :component-main-external" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :component-not-found
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [page      (ctpl/get-page file-data page-id)
+        shape-ids (cph/get-children-ids-with-self (:objects page) (:id shape))
+
+        repair-shape
+        (fn [shape]
+          ;; ; Detach the shape and convert it to non instance.
+          ;; (log/debug :hint "  -> Detach shape" :shape-id (:id shape))
+          ;; (ctk/detach-shape shape))]
+          ; There is no solution that may recover it with confidence
+          (log/warn :hint "  -> CANNOT REPAIR THIS AUTOMATICALLY.")
+          shape)]
+
+    (log/info :hint "Repairing shape :component-not-found" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes shape-ids repair-shape))))
+
+(defmethod repair-error :invalid-main-instance-id
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-component
+        (fn [component]
+          ; Assign main instance in the component to current shape
+          (log/debug :hint "  -> Assign main-instance-id" :component-id (:id component))
+          (assoc component :main-instance-id (:id shape)))]
+    (log/info :hint "Repairing shape :invalid-main-instance-id" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-library-data file-data)
+        (pcb/update-component [(:component-id shape)] repair-component))))
+
+(defmethod repair-error :invalid-main-instance-page
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-component
+        (fn [component]
+          ; Assign main instance in the component to current shape
+          (log/debug :hint "  -> Assign main-instance-page" :component-id (:id component))
+          (assoc component :main-instance-page page-id))]
+    (log/info :hint "Repairing shape :invalid-main-instance-page" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-library-data file-data)
+        (pcb/update-component [(:component-id shape)] repair-component))))
+
+(defmethod repair-error :invalid-main-instance
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; There is no solution that may recover it with confidence
+          (log/warn :hint "  -> CANNOT REPAIR THIS AUTOMATICALLY.")
+          shape)]
+ 
+    (log/info :hint "Repairing shape :invalid-main-instance" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :component-main
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; Unset the :shape as main instance root
+          (log/debug :hint "  -> Unset :main-instance")
+          (dissoc shape :main-instance))]
+ 
+    (log/info :hint "Repairing shape :component-main" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :should-be-component-root
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; Convert the shape in a top copy root.
+          (log/debug :hint "  -> Set :component-root")
+          (assoc shape :component-root true))]
+ 
+    (log/info :hint "Repairing shape :should-be-component-root" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :should-not-be-component-root
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; Convert the shape in a nested copy root.
+          (log/debug :hint "  -> Unset :component-root")
+          (dissoc shape :component-root))]
+ 
+    (log/info :hint "Repairing shape :should-not-be-component-root" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :ref-shape-not-found
+  [_ {:keys [shape page-id] :as error} file-data libraries]
+  (let [matching-shape (let [page           (ctpl/get-page file-data page-id)
+                             root-shape     (ctn/get-component-shape (:objects page) shape)
+                             component-file (if (= (:component-file root-shape) (:id file-data))
+                                              file-data
+                                              (-> (get libraries (:component-file root-shape)) :data))
+                             component      (when component-file
+                                              (ctkl/get-component (:data component-file) (:component-id root-shape) true))
+                             shapes         (ctf/get-component-shapes file-data component)]
+                         (d/seek #(= (:shape-ref %) (:shape-ref shape)) shapes))
+
+        reassign-shape
+        (fn [shape]
+          (log/debug :hint "  -> Reassign shape-ref to" :shape-ref (:id matching-shape))
+          (assoc shape :shape-ref (:id matching-shape)))
+
+        detach-shape
+        (fn [shape]
+          (log/debug :hint "  -> Detach shape" :shape-id (:id shape))
+          (ctk/detach-shape shape))]
+
+    ; If the shape still refers to the remote component, try to find the corresponding near one
+    ; and link to it. If not, detach the shape.
+    (log/info :hint "Repairing shape :ref-shape-not-found" :id (:id shape) :name (:name shape) :page-id page-id)
+    (if (some? matching-shape)
+      (-> (pcb/empty-changes nil page-id)
+          (pcb/with-file-data file-data)
+          (pcb/update-shapes [(:id shape)] reassign-shape))
+      (let [page      (ctpl/get-page file-data page-id)
+            shape-ids (cph/get-children-ids-with-self (:objects page) (:id shape))]
+        (-> (pcb/empty-changes nil page-id)
+            (pcb/with-file-data file-data)
+            (pcb/update-shapes shape-ids detach-shape))))))
+        
+(defmethod repair-error :shape-ref-in-main
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; Remove shape-ref
+          (log/debug :hint "  -> Unset :shape-ref")
+          (dissoc shape :shape-ref))]
+ 
+    (log/info :hint "Repairing shape :shape-ref-in-main" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :root-main-not-allowed
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; Convert the shape in a nested main head.
+          (log/debug :hint "  -> Unset :component-root")
+          (dissoc shape :component-root))]
+ 
+    (log/info :hint "Repairing shape :root-main-not-allowed" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :nested-main-not-allowed
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; Convert the shape in a top main head.
+          (log/debug :hint "  -> Set :component-root")
+          (assoc shape :component-root true))]
+ 
+    (log/info :hint "Repairing shape :nested-main-not-allowed" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :root-copy-not-allowed
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; Convert the shape in a nested copy head.
+          (log/debug :hint "  -> Unset :component-root")
+          (dissoc shape :component-root))]
+ 
+    (log/info :hint "Repairing shape :root-copy-not-allowed" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :nested-copy-not-allowed
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; Convert the shape in a top copy root.
+          (log/debug :hint "  -> Set :component-root")
+          (assoc shape :component-root true))]
+ 
+    (log/info :hint "Repairing shape :nested-copy-not-allowed" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :not-head-main-not-allowed
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ;; ; Detach the shape and convert it to non instance.
+          ;; (log/debug :hint "  -> Detach shape" :shape-id (:id shape))
+          ;; (ctk/detach-shape shape))]
+          ; There is no solution that may recover it with confidence
+          (log/warn :hint "  -> CANNOT REPAIR THIS AUTOMATICALLY.")
+          shape)]
+ 
+    (log/info :hint "Repairing shape :not-head-main-not-allowed" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :not-head-copy-not-allowed
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; Detach the shape and convert it to non instance.
+          (log/debug :hint "  -> Detach shape" :shape-id (:id shape))
+          (ctk/detach-shape shape))]
+ 
+    (log/info :hint "Repairing shape :not-head-copy-not-allowed" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :not-component-not-allowed
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [repair-shape
+        (fn [shape]
+          ; There is no solution that may recover it with confidence
+          (log/warn :hint "  -> CANNOT REPAIR THIS AUTOMATICALLY.")
+          shape)]
+ 
+    (log/info :hint "Repairing shape :not-component-not-allowed" :id (:id shape) :name (:name shape) :page-id page-id)
+    (-> (pcb/empty-changes nil page-id)
+        (pcb/with-file-data file-data)
+        (pcb/update-shapes [(:id shape)] repair-shape))))
+
+(defmethod repair-error :default
+  [_ error file _]
+  (log/error :hint "Unknown error code, don't know how to repair" :code (:code error))
+  file)
+
+(defn repair-file
+  [file-data libraries errors]
+  (log/info :hint "Repairing file" :id (:id file-data) :error-count (count errors))
+  (reduce (fn [changes error]
+            (pcb/concat-changes changes
+                                (repair-error (:code error)
+                                              error
+                                              file-data
+                                              libraries)))
+          (pcb/empty-changes nil)
+          errors))

common/src/app/common/files/validate.cljc

@@ -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
+
+(ns app.common.files.validate
+  (:require
+   [app.common.data.macros :as dm]
+   [app.common.exceptions :as ex]
+   [app.common.pages.helpers :as cph]
+   [app.common.schema :as sm]
+   [app.common.types.component :as ctk]
+   [app.common.types.container :as ctn]
+   [app.common.types.file :as ctf]
+   [app.common.types.pages-list :as ctpl]
+   [app.common.types.shape-tree :as ctst]
+   [app.common.uuid :as uuid]
+   [cuerdas.core :as str]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SCHEMA
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def error-codes
+  #{:parent-not-found
+    :child-not-in-parent
+    :child-not-found
+    :frame-not-found
+    :invalid-frame
+    :component-not-main
+    :component-main-external
+    :component-not-found
+    :invalid-main-instance-id
+    :invalid-main-instance-page
+    :invalid-main-instance
+    :component-main
+    :should-be-component-root
+    :should-not-be-component-root
+    :ref-shape-not-found
+    :shape-ref-in-main
+    :root-main-not-allowed
+    :nested-main-not-allowed
+    :root-copy-not-allowed
+    :nested-copy-not-allowed
+    :not-head-main-not-allowed
+    :not-head-copy-not-allowed
+    :not-component-not-allowed})
+
+(def validation-error
+  [:map {:title "ValidationError"}
+   [:code {:optional false} [::sm/one-of error-codes]]
+   [:hint {:optional false} :string]
+   [:shape {:optional true} :map] ; Cannot validate a shape because here it may be broken
+   [:file-id ::sm/uuid]
+   [:page-id ::sm/uuid]])
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ERROR HANDLING
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^:dynamic *errors* nil)
+(def ^:dynamic *throw-on-error* false)
+
+(defn- report-error
+  [code msg shape file page & args]
+  (when (some? *errors*)
+    (if (true? *throw-on-error*)
+      (ex/raise {:type :validation
+                 :code code
+                 :hint msg
+                 :args args
+                 ::explain (str/format "file %s\npage %s\nshape %s"
+                                       (:id file)
+                                       (:id page)
+                                       (:id shape))})
+      (vswap! *errors* conj {:code code
+                             :hint msg
+                             :shape shape
+                             :file-id (:id file)
+                             :page-id (:id page)
+                             :args args}))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; VALIDATION FUNCTIONS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare validate-shape)
+
+(defn validate-parent-children
+  "Validate parent and children exists, and the link is bidirectional."
+  [shape file page]
+  (let [parent (ctst/get-shape page (:parent-id shape))]
+    (if (nil? parent)
+      (report-error :parent-not-found
+                    (str/format "Parent %s not found" (:parent-id shape))
+                    shape file page)
+      (do
+        (when-not (cph/root? shape)
+          (when-not (some #{(:id shape)} (:shapes parent))
+            (report-error :child-not-in-parent
+                          (str/format "Shape %s not in parent's children list" (:id shape))
+                          shape file page)))
+
+        (doseq [child-id (:shapes shape)]
+          (when (nil? (ctst/get-shape page child-id))
+            (report-error :child-not-found
+                          (str/format "Child %s not found" child-id)
+                          shape file page
+                          :child-id child-id)))))))
+
+(defn validate-frame
+  "Validate that the frame-id shape exists and is indeed a frame."
+  [shape file page]
+  (let [frame (ctst/get-shape page (:frame-id shape))]
+    (if (nil? frame)
+      (report-error :frame-not-found
+                    (str/format "Frame %s not found" (:frame-id shape))
+                    shape file page)
+      (when (not= (:type frame) :frame)
+        (report-error :invalid-frame
+                      (str/format "Frame %s is not actually a frame" (:frame-id shape))
+                      shape file page)))))
+
+(defn validate-component-main-head
+  "Validate shape is a main instance head, component exists and its main-instance points to this shape."
+  [shape file page libraries]
+  (when (nil? (:main-instance shape))
+    (report-error :component-not-main
+                  (str/format "Shape expected to be main instance")
+                  shape file page))
+  (when-not (= (:component-file shape) (:id file))
+    (report-error :component-main-external
+                  (str/format "Main instance should refer to a component in the same file")
+                  shape file page))
+  (let [component (ctf/resolve-component shape file libraries {:include-deleted? true})]
+    (if (nil? component)
+      (report-error :component-not-found
+                    (str/format "Component %s not found in file" (:component-id shape) (:component-file shape))
+                    shape file page)
+      (do
+        (when-not (= (:main-instance-id component) (:id shape))
+          (report-error :invalid-main-instance-id
+                        (str/format "Main instance id of component %s is not valid" (:component-id shape))
+                        shape file page))
+        (when-not (= (:main-instance-page component) (:id page))
+          (report-error :invalid-main-instance-page
+                        (str/format "Main instance page of component %s is not valid" (:component-id shape))
+                        shape file page))))))
+
+(defn validate-component-not-main-head
+  "Validate shape is a not-main instance head, component exists and its main-instance does not point to this shape."
+  [shape file page libraries]
+  (when (some? (:main-instance shape))
+    (report-error :component-not-main
+                  (str/format "Shape not expected to be main instance")
+                  shape file page))
+  (let [component (ctf/resolve-component shape file libraries {:include-deleted? true})]
+    (if (nil? component)
+      (report-error :component-not-found
+                    (str/format "Component %s not found in file" (:component-id shape) (:component-file shape))
+                    shape file page)
+      (do
+        (when (and (= (:main-instance-id component) (:id shape))
+                   (= (:main-instance-page component) (:id page)))
+          (report-error :invalid-main-instance
+                        (str/format "Main instance of component %s should not be this shape" (:id component))
+                        shape file page))))))
+
+(defn validate-component-not-main-not-head
+  "Validate that this shape is not main instance and not head."
+  [shape file page]
+  (when (some? (:main-instance shape))
+    (report-error :component-main
+                  (str/format "Shape not expected to be main instance")
+                  shape file page))
+  (when (or (some? (:component-id shape))
+            (some? (:component-file shape)))
+    (report-error :component-main
+                  (str/format "Shape not expected to be component head")
+                  shape file page)))
+
+(defn validate-component-root
+  "Validate that this shape is an instance root."
+  [shape file page]
+  (when (nil? (:component-root shape))
+    (report-error :should-be-component-root
+                  (str/format "Shape should be component root")
+                  shape file page)))
+
+(defn validate-component-not-root
+  "Validate that this shape is not an instance root."
+  [shape file page]
+  (when (some? (:component-root shape))
+    (report-error :should-not-be-component-root
+                  (str/format "Shape should not be component root")
+                  shape file page)))
+
+(defn validate-component-ref
+  "Validate that the referenced shape exists in the near component."
+  [shape file page libraries]
+  (let [ref-shape (ctf/find-ref-shape file page libraries shape :include-deleted? true)]
+    (when (nil? ref-shape)
+      (report-error :ref-shape-not-found
+                    (str/format "Referenced shape %s not found in near component" (:shape-ref shape))
+                    shape file page))))
+
+(defn validate-component-not-ref
+  "Validate that this shape does not reference other one."
+  [shape file page]
+  (when (some? (:shape-ref shape))
+    (report-error :shape-ref-in-main
+                  (str/format "Shape inside main instance should not have shape-ref")
+                  shape file page)))
+
+(defn validate-shape-main-root-top
+  "Root shape of a top main instance
+     :main-instance
+     :component-id
+     :component-file
+     :component-root"
+  [shape file page libraries]
+  (validate-component-main-head shape file page libraries)
+  (validate-component-root shape file page)
+  (validate-component-not-ref shape file page)
+  (doseq [child-id (:shapes shape)]
+    (validate-shape child-id file page libraries :context :main-top :clear-errors? false)))
+
+(defn validate-shape-main-root-nested
+  "Root shape of a nested main instance
+     :main-instance
+     :component-id
+     :component-file"
+  [shape file page libraries]
+  (validate-component-main-head shape file page libraries)
+  (validate-component-not-root shape file page)
+  (validate-component-not-ref shape file page)
+  (doseq [child-id (:shapes shape)]
+    (validate-shape child-id file page libraries :context :main-nested :clear-errors? false)))
+
+(defn validate-shape-copy-root-top
+  "Root shape of a top copy instance
+     :component-id
+     :component-file
+     :component-root
+     :shape-ref"
+  [shape file page libraries]
+  (validate-component-not-main-head shape file page libraries)
+  (validate-component-root shape file page)
+  (validate-component-ref shape file page libraries)
+  (doseq [child-id (:shapes shape)]
+    (validate-shape child-id file page libraries :context :copy-top :clear-errors? false)))
+
+(defn validate-shape-copy-root-nested
+  "Root shape of a nested copy instance
+     :component-id
+     :component-file
+     :shape-ref"
+  [shape file page libraries]
+  (validate-component-not-main-head shape file page libraries)
+  (validate-component-not-root shape file page)
+  (validate-component-ref shape file page libraries)
+  (doseq [child-id (:shapes shape)]
+    (validate-shape child-id file page libraries :context :copy-nested :clear-errors? false)))
+
+(defn validate-shape-main-not-root
+  "Not-root shape of a main instance
+     (not any attribute)"
+  [shape file page libraries]
+  (validate-component-not-main-not-head shape file page)
+  (validate-component-not-root shape file page)
+  (validate-component-not-ref shape file page)
+  (doseq [child-id (:shapes shape)]
+    (validate-shape child-id file page libraries :context :main-any :clear-errors? false)))
+
+(defn validate-shape-copy-not-root
+  "Not-root shape of a copy instance
+     :shape-ref"
+  [shape file page libraries]
+  (validate-component-not-main-not-head shape file page)
+  (validate-component-not-root shape file page)
+  (validate-component-ref shape file page libraries)
+  (doseq [child-id (:shapes shape)]
+    (validate-shape child-id file page libraries :context :copy-any :clear-errors? false)))
+
+(defn validate-shape-not-component
+  "Shape is not in a component or is a fostered children
+     (not any attribute)"
+  [shape file page libraries]
+  (validate-component-not-main-not-head shape file page)
+  (validate-component-not-root shape file page)
+  (validate-component-not-ref shape file page)
+  (doseq [child-id (:shapes shape)]
+    (validate-shape child-id file page libraries :context :not-component :clear-errors? false)))
+
+(defn validate-shape
+  "Validate referential integrity and semantic coherence of a shape and all its children.
+
+   The context is the situation of the parent in respect to components:
+     :not-component
+     :main-top
+     :main-nested
+     :copy-top
+     :copy-nested
+     :main-any
+     :copy-any"
+  [shape-id file page libraries & {:keys [context throw?]
+                                   :or {context :not-component
+                                        throw? false}}]
+  (binding [*throw-on-error* throw?
+            *errors* (or *errors* (volatile! []))]
+    (let [shape (ctst/get-shape page shape-id)]
+
+                                        ; If this happens it's a bug in this validate functions
+      (dm/verify! (str/format "Shape %s not found" shape-id) (some? shape))
+
+      (validate-parent-children shape file page)
+      (validate-frame shape file page)
+
+    (validate-parent-children shape file page)
+    (validate-frame shape file page)
+
+    (if (ctk/instance-head? shape)
+      
+      (if (ctk/instance-root? shape)
+
+        (if (ctk/main-instance? shape)
+          (if (not= context :not-component)
+            (report-error :root-main-not-allowed
+                          (str/format "Root main component not allowed inside other component")
+                          shape file page)
+            (validate-shape-main-root-top shape file page libraries))
+
+          (if (not= context :not-component)
+            (report-error :root-main-not-allowed
+                          (str/format "Root main component not allowed inside other component")
+                          shape file page)
+            (validate-shape-copy-root-top shape file page libraries)))
+
+        (if (ctk/main-instance? shape)
+          (if (= context :not-component)
+            (report-error :nested-main-not-allowed
+                          (str/format "Nested main component only allowed inside other component")
+                          shape file page)
+            (validate-shape-main-root-nested shape file page libraries))
+
+          (if (= context :not-component)
+            (report-error :nested-main-not-allowed
+                          (str/format "Nested main component only allowed inside other component")
+                          shape file page)
+            (validate-shape-copy-root-nested shape file page libraries))))
+
+      (if (ctk/in-component-copy? shape)
+        (if-not (#{:copy-top :copy-nested :copy-any} context)
+          (report-error :not-head-copy-not-allowed
+                        (str/format "Non-root copy only allowed inside a copy")
+                        shape file page)
+          (validate-shape-copy-not-root shape file page libraries))
+
+        (if (ctn/inside-component-main? (:objects page) shape)
+          (if-not (#{:main-top :main-nested :main-any} context)
+            (report-error :not-head-main-not-allowed
+                          (str/format "Non-root main only allowed inside a main component")
+                          shape file page)
+            (validate-shape-main-not-root shape file page libraries))
+
+          (if (#{:main-top :main-nested :main-any} context)
+            (report-error :not-component-not-allowed
+                          (str/format "Not compoments are not allowed inside a main")
+                          shape file page)
+            (validate-shape-not-component shape file page libraries)))))
+
+          (deref *errors*))))
+
+(defn validate-file
+  "Validate referencial integrity and semantic coherence of all contents of a file."
+  [file libraries & {:keys [throw?] :or {throw? false}}]
+  (binding [*throw-on-error* throw?
+            *errors* (volatile! [])]
+    (->> (ctpl/pages-seq (:data file))
+         (run! #(validate-shape uuid/zero file % libraries :throw? throw?)))
+
+    (deref *errors*)))

common/src/app/common/fressian.clj

@@ -7,12 +7,8 @@
 (ns app.common.fressian
   (:require
    [app.common.data :as d]
-   [app.common.geom.matrix :as gmt]
-   [app.common.geom.point :as gpt]
    [clojure.data.fressian :as fres])
   (:import
-   app.common.geom.matrix.Matrix
-   app.common.geom.point.Point
    clojure.lang.Ratio
    java.io.ByteArrayInputStream
    java.io.ByteArrayOutputStream
@@ -297,29 +293,3 @@
   [data]
   (with-open [^ByteArrayInputStream input (ByteArrayInputStream. ^bytes data)]
     (-> input reader read!)))
-
-;; --- ADDITIONAL
-
-(add-handlers!
- {:name "penpot/point"
-  :class app.common.geom.point.Point
-  :wfn (fn [n w ^Point o]
-         (write-tag! w n 1)
-         (write-list! w (List/of (.-x o) (.-y o))))
-  :rfn (fn [^Reader rdr]
-         (let [^List x (read-object! rdr)]
-           (Point. (.get x 0) (.get x 1))))}
-
- {:name "penpot/matrix"
-  :class app.common.geom.matrix.Matrix
-  :wfn (fn [^String n ^Writer w o]
-         (write-tag! w n 1)
-         (write-list! w (List/of (.-a ^Matrix o)
-                                 (.-b ^Matrix o)
-                                 (.-c ^Matrix o)
-                                 (.-d ^Matrix o)
-                                 (.-e ^Matrix o)
-                                 (.-f ^Matrix o))))
-  :rfn (fn [^Reader rdr]
-         (let [^List x (read-object! rdr)]
-           (Matrix. (.get x 0) (.get x 1) (.get x 2) (.get x 3) (.get x 4) (.get x 5))))})

common/src/app/common/geom/align.cljc

@@ -6,6 +6,8 @@
 
 (ns app.common.geom.align
   (:require
+   [app.common.geom.point :as gpt]
+   [app.common.geom.rect :as grc]
    [app.common.geom.shapes :as gsh]
    [app.common.pages.helpers :refer [get-children]]))
 
@@ -30,10 +32,10 @@
   the shape with the given rectangle. If the shape is a group,
   move also all of its recursive children."
   [shape rect axis objects]
-  (let [wrapper-rect (gsh/selection-rect [shape])
-        align-pos (calc-align-pos wrapper-rect rect axis)
-        delta {:x (- (:x align-pos) (:x wrapper-rect))
-               :y (- (:y align-pos) (:y wrapper-rect))}]
+  (let [wrapper-rect (gsh/shapes->rect [shape])
+        align-pos    (calc-align-pos wrapper-rect rect axis)
+        delta        (gpt/point (- (:x align-pos) (:x wrapper-rect))
+                                (- (:y align-pos) (:y wrapper-rect)))]
     (recursive-move shape delta objects)))
 
 (defn calc-align-pos
@@ -78,11 +80,11 @@
         other-coord (if (= axis :horizontal) :y :x)
         size (if (= axis :horizontal) :width :height)
         ; The rectangle that wraps the whole selection
-        wrapper-rect (gsh/selection-rect shapes)
+        wrapper-rect (gsh/shapes->rect shapes)
         ; Sort shapes by the center point in the given axis
-        sorted-shapes (sort-by #(coord (gsh/center-shape %)) shapes)
+        sorted-shapes (sort-by #(coord (gsh/shape->center %)) shapes)
         ; Each shape wrapped in its own rectangle
-        wrapped-shapes (map #(gsh/selection-rect [%]) sorted-shapes)
+        wrapped-shapes (map #(gsh/shapes->rect [%]) sorted-shapes)
         ; The total space between shapes
         space (reduce - (size wrapper-rect) (map size wrapped-shapes))
         unit-space (/ space (- (count wrapped-shapes) 1))
@@ -111,28 +113,32 @@
 (defn adjust-to-viewport
   ([viewport srect] (adjust-to-viewport viewport srect nil))
   ([viewport srect {:keys [padding] :or {padding 0}}]
-   (let [gprop (/ (:width viewport) (:height viewport))
-         srect (-> srect
-                   (update :x #(- % padding))
-                   (update :y #(- % padding))
-                   (update :width #(+ % padding padding))
-                   (update :height #(+ % padding padding)))
-         width (:width srect)
+   (let [gprop  (/ (:width viewport)
+                   (:height viewport))
+         srect  (-> srect
+                    (update :x #(- % padding))
+                    (update :y #(- % padding))
+                    (update :width #(+ % padding padding))
+                    (update :height #(+ % padding padding)))
+         width  (:width srect)
          height (:height srect)
-         lprop (/ width height)]
+         lprop  (/ width height)]
      (cond
-      (> gprop lprop)
-      (let [width'  (* (/ width lprop) gprop)
-            padding (/ (- width' width) 2)]
-        (-> srect
-            (update :x #(- % padding))
-            (assoc :width width')))
+       (> gprop lprop)
+       (let [width'  (* (/ width lprop) gprop)
+             padding (/ (- width' width) 2)]
+         (-> srect
+             (update :x #(- % padding))
+             (assoc :width width')
+             (grc/update-rect :position)))
 
-      (< gprop lprop)
-      (let [height' (/ (* height lprop) gprop)
-            padding (/ (- height' height) 2)]
-        (-> srect
-            (update :y #(- % padding))
-            (assoc :height height')))
+       (< gprop lprop)
+       (let [height' (/ (* height lprop) gprop)
+             padding (/ (- height' height) 2)]
+         (-> srect
+             (update :y #(- % padding))
+             (assoc :height height')
+             (grc/update-rect :position)))
 
-      :else srect))))
+       :else
+       (grc/update-rect srect :position)))))

common/src/app/common/geom/grid.cljc

@@ -4,7 +4,7 @@
 ;;
 ;; Copyright (c) KALEIDOS INC
 
-(ns app.util.geom.grid
+(ns app.common.geom.grid
   (:require
    [app.common.data :as d]
    [app.common.geom.point :as gpt]
@@ -25,28 +25,31 @@
     (mth/floor (/ frame-length-no-margins (+ item-length gutter)))))
 
 (defn- calculate-generic-grid
-  [v width {:keys [size gutter margin item-length type]}]
+  [v total-length {:keys [size gutter margin item-length type]}]
   (let [size   (if (number? size)
                  size
-                 (calculate-size width item-length margin gutter))
-        parts  (/ width size)
+                 (calculate-size total-length item-length margin gutter))
 
-        width' (min (or item-length ##Inf) (+ parts (- gutter) (/ gutter size) (- (/ (* margin 2) size))))
+        parts  (/ total-length size)
+
+        item-length (if (number? item-length)
+                      item-length
+                      (+ parts (- gutter) (/ gutter size) (- (/ (* margin 2) size))))
 
         offset (case type
-                 :right (- width (* width' size) (* gutter (dec size)) margin)
-                 :center (/ (- width (* width' size) (* gutter (dec size))) 2)
+                 :right (- total-length (* item-length size) (* gutter (dec size)) margin)
+                 :center (/ (- total-length (* item-length size) (* gutter (dec size))) 2)
                  margin)
 
         gutter (if (= :stretch type)
-                 (let [gutter (/ (- width (* width' size) (* margin 2)) (dec size))]
+                 (let [gutter (max 0 gutter (/ (- total-length (* item-length size) (* margin 2)) (dec size)))]
                    (if (d/num? gutter) gutter 0))
                  gutter)
 
         next-v (fn [cur-val]
-                 (+ offset v (* (+ width' gutter) cur-val)))]
+                 (+ offset v (* (+ item-length gutter) cur-val)))]
 
-    [size width' next-v gutter]))
+    [size item-length next-v gutter]))
 
 (defn- calculate-column-grid
   [{:keys [width height x y] :as frame} params]

common/src/app/common/geom/matrix.cljc

@@ -8,34 +8,41 @@
   (:require
    #?(:cljs [cljs.pprint :as pp]
       :clj  [clojure.pprint :as pp])
+   #?(:clj [app.common.fressian :as fres])
    [app.common.data :as d]
    [app.common.data.macros :as dm]
    [app.common.geom.point :as gpt]
    [app.common.math :as mth]
+   [app.common.record :as cr]
    [app.common.schema :as sm]
    [app.common.schema.generators :as sg]
    [app.common.schema.openapi :as-alias oapi]
    [app.common.spec :as us]
-   [clojure.spec.alpha :as s]))
+   [app.common.transit :as t]
+   [clojure.spec.alpha :as s])
+  #?(:clj
+     (:import
+      java.util.List)))
+
 
 (def precision 6)
 
 ;; --- Matrix Impl
-(defrecord Matrix [^double a
-                   ^double b
-                   ^double c
-                   ^double d
-                   ^double e
-                   ^double f]
+(cr/defrecord Matrix [^double a
+                      ^double b
+                      ^double c
+                      ^double d
+                      ^double e
+                      ^double f]
   Object
-  (toString [_]
+  (toString [this]
     (dm/fmt "matrix(%, %, %, %, %, %)"
-      (mth/to-fixed a precision)
-      (mth/to-fixed b precision)
-      (mth/to-fixed c precision)
-      (mth/to-fixed d precision)
-      (mth/to-fixed e precision)
-      (mth/to-fixed f precision))))
+            (mth/to-fixed (.-a this) precision)
+            (mth/to-fixed (.-b this) precision)
+            (mth/to-fixed (.-c this) precision)
+            (mth/to-fixed (.-d this) precision)
+            (mth/to-fixed (.-e this) precision)
+            (mth/to-fixed (.-f this) precision))))
 
 (defn matrix?
   "Return true if `v` is Matrix instance."
@@ -45,9 +52,9 @@
 (defn matrix
   "Create a new matrix instance."
   ([]
-   (Matrix. 1 0 0 1 0 0))
+   (pos->Matrix 1 0 0 1 0 0))
   ([a b c d e f]
-   (Matrix. a b c d e f)))
+   (pos->Matrix a b c d e f)))
 
 (def number-regex #"[+-]?\d*(\.\d+)?(e[+-]?\d+)?")
 
@@ -94,7 +101,7 @@
                               (sg/small-double)
                               (sg/small-double)
                               (sg/small-double) )
-                    (sg/fmap #(apply ->Matrix %)))
+                    (sg/fmap #(apply pos->Matrix %)))
       ::oapi/type "string"
       ::oapi/format "matrix"
       ::oapi/decode decode
@@ -114,24 +121,54 @@
 (s/def ::matrix
   (s/and ::matrix-attrs matrix?))
 
-
 (defn close?
   [^Matrix m1 ^Matrix m2]
-  (and (mth/close? (.-a m1) (.-a m2))
-       (mth/close? (.-b m1) (.-b m2))
-       (mth/close? (.-c m1) (.-c m2))
-       (mth/close? (.-d m1) (.-d m2))
-       (mth/close? (.-e m1) (.-e m2))
-       (mth/close? (.-f m1) (.-f m2))))
+  (and ^boolean (mth/close? (.-a m1) (.-a m2))
+       ^boolean (mth/close? (.-b m1) (.-b m2))
+       ^boolean (mth/close? (.-c m1) (.-c m2))
+       ^boolean (mth/close? (.-d m1) (.-d m2))
+       ^boolean (mth/close? (.-e m1) (.-e m2))
+       ^boolean (mth/close? (.-f m1) (.-f m2))))
 
 (defn unit? [^Matrix m1]
-  (and (some? m1)
-       (mth/close? (.-a m1) 1)
-       (mth/close? (.-b m1) 0)
-       (mth/close? (.-c m1) 0)
-       (mth/close? (.-d m1) 1)
-       (mth/close? (.-e m1) 0)
-       (mth/close? (.-f m1) 0)))
+  (and ^boolean (some? m1)
+       ^boolean (mth/close? (.-a m1) 1)
+       ^boolean (mth/close? (.-b m1) 0)
+       ^boolean (mth/close? (.-c m1) 0)
+       ^boolean (mth/close? (.-d m1) 1)
+       ^boolean (mth/close? (.-e m1) 0)
+       ^boolean (mth/close? (.-f m1) 0)))
+
+(defn multiply!
+  [^Matrix m1 ^Matrix m2]
+  (let [m1a (.-a m1)
+        m1b (.-b m1)
+        m1c (.-c m1)
+        m1d (.-d m1)
+        m1e (.-e m1)
+        m1f (.-f m1)
+        m2a (.-a m2)
+        m2b (.-b m2)
+        m2c (.-c m2)
+        m2d (.-d m2)
+        m2e (.-e m2)
+        m2f (.-f m2)]
+    #?@(:cljs
+        [(set! (.-a m1) (+ (* m1a m2a) (* m1c m2b)))
+         (set! (.-b m1) (+ (* m1b m2a) (* m1d m2b)))
+         (set! (.-c m1) (+ (* m1a m2c) (* m1c m2d)))
+         (set! (.-d m1) (+ (* m1b m2c) (* m1d m2d)))
+         (set! (.-e m1) (+ (* m1a m2e) (* m1c m2f) m1e))
+         (set! (.-f m1) (+ (* m1b m2e) (* m1d m2f) m1f))
+         m1]
+        :clj
+        [(pos->Matrix
+          (+ (* m1a m2a) (* m1c m2b))
+          (+ (* m1b m2a) (* m1d m2b))
+          (+ (* m1a m2c) (* m1c m2d))
+          (+ (* m1b m2c) (* m1d m2d))
+          (+ (* m1a m2e) (* m1c m2f) m1e)
+          (+ (* m1b m2e) (* m1d m2f) m1f))])))
 
 (defn multiply
   ([^Matrix m1 ^Matrix m2]
@@ -156,7 +193,7 @@
            m2e (.-e m2)
            m2f (.-f m2)]
 
-       (Matrix.
+       (pos->Matrix
         (+ (* m1a m2a) (* m1c m2b))
         (+ (* m1b m2a) (* m1d m2b))
         (+ (* m1a m2c) (* m1c m2d))
@@ -165,51 +202,28 @@
         (+ (* m1b m2e) (* m1d m2f) m1f)))))
 
   ([m1 m2 & others]
-   (reduce multiply (multiply m1 m2) others)))
-
-(defn multiply!
-  [^Matrix m1 ^Matrix m2]
-  (let [m1a (.-a m1)
-        m1b (.-b m1)
-        m1c (.-c m1)
-        m1d (.-d m1)
-        m1e (.-e m1)
-        m1f (.-f m1)
-        m2a (.-a m2)
-        m2b (.-b m2)
-        m2c (.-c m2)
-        m2d (.-d m2)
-        m2e (.-e m2)
-        m2f (.-f m2)]
-    #?@(:cljs [(set! (.-a m1) (+ (* m1a m2a) (* m1c m2b)))
-               (set! (.-b m1) (+ (* m1b m2a) (* m1d m2b)))
-               (set! (.-c m1) (+ (* m1a m2c) (* m1c m2d)))
-               (set! (.-d m1) (+ (* m1b m2c) (* m1d m2d)))
-               (set! (.-e m1) (+ (* m1a m2e) (* m1c m2f) m1e))
-               (set! (.-f m1) (+ (* m1b m2e) (* m1d m2f) m1f))
-               m1]
-        :clj  [(Matrix.
-                (+ (* m1a m2a) (* m1c m2b))
-                (+ (* m1b m2a) (* m1d m2b))
-                (+ (* m1a m2c) (* m1c m2d))
-                (+ (* m1b m2c) (* m1d m2d))
-                (+ (* m1a m2e) (* m1c m2f) m1e)
-                (+ (* m1b m2e) (* m1d m2f) m1f))])))
+   (reduce multiply! (multiply m1 m2) others)))
 
 (defn add-translate
   "Given two TRANSLATE matrixes (only e and f have significative
   values), combine them. Quicker than multiplying them, for this
   precise case."
-  ([{m1e :e m1f :f} {m2e :e m2f :f}]
-   (Matrix. 1 0 0 1 (+ m1e m2e) (+ m1f m2f)))
+  ([^Matrix m1 ^Matrix m2]
+   (let [m1e (dm/get-prop m1 :e)
+         m1f (dm/get-prop m1 :f)
+         m2e (dm/get-prop m2 :e)
+         m2f (dm/get-prop m2 :f)]
+     (pos->Matrix 1 0 0 1 (+ m1e m2e) (+ m1f m2f))))
 
   ([m1 m2 & others]
    (reduce add-translate (add-translate m1 m2) others)))
 
+;; FIXME: optimize?
+
 (defn substract
   [{m1a :a m1b :b m1c :c m1d :d m1e :e m1f :f}
    {m2a :a m2b :b m2c :c m2d :d m2e :e m2f :f}]
-  (Matrix.
+  (pos->Matrix
    (- m1a m2a) (- m1b m2b) (- m1c m2c)
    (- m1d m2d) (- m1e m2e) (- m1f m2f)))
 
@@ -221,13 +235,24 @@
 
 (defn translate-matrix
   ([pt]
-   (assert (gpt/point? pt))
-   (Matrix. 1 0 0 1
-            (dm/get-prop pt :x)
-            (dm/get-prop pt :y)))
+   (dm/assert! (gpt/point? pt))
+   (pos->Matrix 1 0 0 1
+                (dm/get-prop pt :x)
+                (dm/get-prop pt :y)))
 
   ([x y]
-   (Matrix. 1 0 0 1 x y)))
+   (pos->Matrix 1 0 0 1 x y)))
+
+
+(defn translate-matrix-neg
+  ([pt]
+   (dm/assert! (gpt/point? pt))
+   (pos->Matrix 1 0 0 1
+            (- (dm/get-prop pt :x))
+            (- (dm/get-prop pt :y))))
+
+  ([x y]
+   (pos->Matrix 1 0 0 1 (- x) (- y))))
 
 (defn scale-matrix
   ([pt center]
@@ -235,10 +260,10 @@
          sy (dm/get-prop pt :y)
          cx (dm/get-prop center :x)
          cy (dm/get-prop center :y)]
-     (Matrix. sx 0 0 sy (- cx (* cx sx)) (- cy (* cy sy)))))
+     (pos->Matrix sx 0 0 sy (- cx (* cx sx)) (- cy (* cy sy)))))
   ([pt]
-   (assert (gpt/point? pt))
-   (Matrix. (dm/get-prop pt :x) 0 0 (dm/get-prop pt :y) 0 0)))
+   (dm/assert! (gpt/point? pt))
+   (pos->Matrix (dm/get-prop pt :x) 0 0 (dm/get-prop pt :y) 0 0)))
 
 (defn rotate-matrix
   ([angle point]
@@ -252,15 +277,15 @@
          ns (- s)
          tx (+ (* c nx) (* ns ny) cx)
          ty (+ (* s nx) (*  c ny) cy)]
-     (Matrix. c s ns c tx ty)))
+     (pos->Matrix c s ns c tx ty)))
   ([angle]
    (let [a (mth/radians angle)]
-     (Matrix. (mth/cos a)
-              (mth/sin a)
-              (- (mth/sin a))
-              (mth/cos a)
-              0
-              0))))
+     (pos->Matrix (mth/cos a)
+                  (mth/sin a)
+                  (- (mth/sin a))
+                  (mth/cos a)
+                  0
+                  0))))
 
 (defn skew-matrix
   ([angle-x angle-y point]
@@ -270,7 +295,7 @@
   ([angle-x angle-y]
    (let [m1 (mth/tan (mth/radians angle-x))
          m2 (mth/tan (mth/radians angle-y))]
-     (Matrix. 1 m2 m1 1 0 0))))
+     (pos->Matrix 1 m2 m1 1 0 0))))
 
 (defn rotate
   "Apply rotation transformation to the matrix."
@@ -331,6 +356,7 @@
         (translate (gpt/negate pt)))
     mtx))
 
+;; FIXME: performance
 (defn determinant
   "Determinant for the affinity transform"
   [{:keys [a b c d _ _]}]
@@ -340,14 +366,14 @@
   "Gets the inverse of the affinity transform `mtx`"
   [{:keys [a b c d e f] :as mtx}]
   (let [det (determinant mtx)]
-    (when-not (mth/almost-zero? det)
+    (when-not ^boolean (mth/almost-zero? det)
       (let [a' (/  d det)
             b' (/ (- b) det)
             c' (/ (- c) det)
             d' (/  a det)
             e' (/ (- (* c f) (* d e)) det)
             f' (/ (- (* b e) (* a f)) det)]
-        (Matrix. a' b' c' d' e' f')))))
+        (pos->Matrix a' b' c' d' e' f')))))
 
 (defn round
   [mtx]
@@ -371,8 +397,41 @@
     point))
 
 (defn move?
-  [{:keys [a b c d _ _]}]
-  (and (mth/almost-zero? (- a 1))
-       (mth/almost-zero? b)
-       (mth/almost-zero? c)
-       (mth/almost-zero? (- d 1))))
+  [m]
+  (and ^boolean (mth/almost-zero? (- (dm/get-prop m :a) 1))
+       ^boolean (mth/almost-zero? (dm/get-prop m :b))
+       ^boolean (mth/almost-zero? (dm/get-prop m :c))
+       ^boolean (mth/almost-zero? (- (dm/get-prop m :d) 1))))
+
+#?(:clj
+   (fres/add-handlers!
+    {:name "penpot/matrix"
+     :class Matrix
+     :wfn (fn [n w o]
+            (fres/write-tag! w n 1)
+            (fres/write-list! w (List/of (.-a ^Matrix o)
+                                         (.-b ^Matrix o)
+                                         (.-c ^Matrix o)
+                                         (.-d ^Matrix o)
+                                         (.-e ^Matrix o)
+                                         (.-f ^Matrix o))))
+     :rfn (fn [rdr]
+            (let [^List x (fres/read-object! rdr)]
+              (pos->Matrix (.get x 0)
+                           (.get x 1)
+                           (.get x 2)
+                           (.get x 3)
+                           (.get x 4)
+                           (.get x 5))))}))
+
+(t/add-handlers!
+ {:id "matrix"
+  :class Matrix
+  :wfn #(into {} %)
+  :rfn (fn [m]
+         (pos->Matrix (get m :a)
+                      (get m :b)
+                      (get m :c)
+                      (get m :d)
+                      (get m :e)
+                      (get m :f)))})

common/src/app/common/geom/point.cljc

@@ -11,20 +11,26 @@
       :clj  [clojure.pprint :as pp])
    #?(:cljs [cljs.core :as c]
       :clj [clojure.core :as c])
+   #?(:clj [app.common.fressian :as fres])
    [app.common.data :as d]
    [app.common.data.macros :as dm]
    [app.common.exceptions :as ex]
    [app.common.math :as mth]
+   [app.common.record :as cr]
    [app.common.schema :as sm]
    [app.common.schema.generators :as sg]
    [app.common.schema.openapi :as-alias oapi]
    [app.common.spec :as us]
+   [app.common.transit :as t]
    [clojure.spec.alpha :as s]
-   [cuerdas.core :as str]))
+   [cuerdas.core :as str])
+  #?(:clj
+     (:import
+      java.util.List)))
 
 ;; --- Point Impl
 
-(defrecord Point [x y])
+(cr/defrecord Point [x y])
 
 (defn s
   [pt]
@@ -57,7 +63,7 @@
               (map->Point p)
               (if (string? p)
                 (let [[x y] (->> (str/split p #",") (mapv parse-double))]
-                  (Point. x y))
+                  (pos->Point x y))
                 p)))
 
           (encode [p]
@@ -71,7 +77,7 @@
       :description "Point"
       :error/message "expected a valid point"
       :gen/gen (->> (sg/tuple (sg/small-int) (sg/small-int))
-                    (sg/fmap #(apply ->Point %)))
+                    (sg/fmap #(apply pos->Point %)))
       ::oapi/type "string"
       ::oapi/format "point"
       ::oapi/decode decode
@@ -85,7 +91,7 @@
 
 (defn point
   "Create a Point instance."
-  ([] (Point. 0 0))
+  ([] (pos->Point 0 0))
   ([v]
    (cond
      (point? v)
@@ -95,12 +101,12 @@
      (point v v)
 
      (point-like? v)
-     (Point. (:x v) (:y v))
+     (pos->Point (:x v) (:y v))
 
      :else
      (ex/raise :hint "invalid arguments (on pointer constructor)" :value v)))
   ([x y]
-   (Point. x y)))
+   (pos->Point x y)))
 
 (defn close?
   [p1 p2]
@@ -119,25 +125,29 @@
   "Returns the addition of the supplied value to both
   coordinates of the point as a new point."
   [p1 p2]
-  (assert (and (point? p1)
-               (point? p2))
-          "arguments should be pointer instance")
-  (Point. (+ (dm/get-prop p1 :x)
-             (dm/get-prop p2 :x))
-          (+ (dm/get-prop p1 :y)
-             (dm/get-prop p2 :y))))
+  (dm/assert!
+   "arguments should be point instance"
+   (and (point? p1)
+        (point? p2)))
+
+  (pos->Point (+ (dm/get-prop p1 :x)
+                 (dm/get-prop p2 :x))
+              (+ (dm/get-prop p1 :y)
+                 (dm/get-prop p2 :y))))
 
 (defn subtract
   "Returns the subtraction of the supplied value to both
   coordinates of the point as a new point."
   [p1 p2]
-  (assert (and (point? p1)
-               (point? p2))
-          "arguments should be pointer instance")
-  (Point. (- (dm/get-prop p1 :x)
-             (dm/get-prop p2 :x))
-          (- (dm/get-prop p1 :y)
-             (dm/get-prop p2 :y))))
+  (dm/assert!
+   "arguments should be pointer instance"
+   (and (point? p1)
+        (point? p2)))
+
+  (pos->Point (- (dm/get-prop p1 :x)
+                 (dm/get-prop p2 :x))
+              (- (dm/get-prop p1 :y)
+                 (dm/get-prop p2 :y))))
 
 (defn multiply
   "Returns the subtraction of the supplied value to both
@@ -146,20 +156,20 @@
   (assert (and (point? p1)
                (point? p2))
           "arguments should be pointer instance")
-  (Point. (* (dm/get-prop p1 :x)
-             (dm/get-prop p2 :x))
-          (* (dm/get-prop p1 :y)
-             (dm/get-prop p2 :y))))
+  (pos->Point (* (dm/get-prop p1 :x)
+                 (dm/get-prop p2 :x))
+              (* (dm/get-prop p1 :y)
+                 (dm/get-prop p2 :y))))
 
 (defn divide
   [p1 p2]
   (assert (and (point? p1)
                (point? p2))
           "arguments should be pointer instance")
-  (Point. (/ (dm/get-prop p1 :x)
-             (dm/get-prop p2 :x))
-          (/ (dm/get-prop p1 :y)
-             (dm/get-prop p2 :y))))
+  (pos->Point (/ (dm/get-prop p1 :x)
+                 (dm/get-prop p2 :x))
+              (/ (dm/get-prop p1 :y)
+                 (dm/get-prop p2 :y))))
 
 (defn min
   ([] nil)
@@ -168,10 +178,10 @@
    (cond
      (nil? p1) p2
      (nil? p2) p1
-     :else (Point. (c/min (dm/get-prop p1 :x)
-                          (dm/get-prop p2 :x))
-                   (c/min (dm/get-prop p1 :y)
-                          (dm/get-prop p2 :y))))))
+     :else (pos->Point (c/min (dm/get-prop p1 :x)
+                              (dm/get-prop p2 :x))
+                       (c/min (dm/get-prop p1 :y)
+                              (dm/get-prop p2 :y))))))
 (defn max
   ([] nil)
   ([p1] p1)
@@ -179,21 +189,21 @@
    (cond
      (nil? p1) p2
      (nil? p2) p1
-     :else (Point. (c/max (dm/get-prop p1 :x)
-                          (dm/get-prop p2 :x))
-                   (c/max (dm/get-prop p1 :y)
-                          (dm/get-prop p2 :y))))))
+     :else (pos->Point (c/max (dm/get-prop p1 :x)
+                              (dm/get-prop p2 :x))
+                       (c/max (dm/get-prop p1 :y)
+                              (dm/get-prop p2 :y))))))
 (defn inverse
   [pt]
   (assert (point? pt) "point instance expected")
-  (Point. (/ 1.0 (dm/get-prop pt :x))
-          (/ 1.0 (dm/get-prop pt :y))))
+  (pos->Point (/ 1.0 (dm/get-prop pt :x))
+              (/ 1.0 (dm/get-prop pt :y))))
 
 (defn negate
   [pt]
   (assert (point? pt) "point instance expected")
-  (Point. (- (dm/get-prop pt :x))
-          (- (dm/get-prop pt :y))))
+  (pos->Point (- (dm/get-prop pt :x))
+              (- (dm/get-prop pt :y))))
 
 (defn distance
   "Calculate the distance between two points."
@@ -217,8 +227,8 @@
               (dm/get-prop p2 :x))
         dy (- (dm/get-prop p1 :y)
               (dm/get-prop p2 :y))]
-    (Point. (mth/abs dx)
-            (mth/abs dy))))
+    (pos->Point (mth/abs dx)
+                (mth/abs dy))))
 
 (defn length
   [pt]
@@ -285,8 +295,8 @@
   (assert (number? angle) "expected number")
   (let [len   (length p)
         angle (mth/radians angle)]
-    (Point. (* (mth/cos angle) len)
-            (* (mth/sin angle) len))))
+    (pos->Point (* (mth/cos angle) len)
+                (* (mth/sin angle) len))))
 
 (defn quadrant
   "Return the quadrant of the angle of the point."
@@ -306,22 +316,21 @@
   ([pt decimals]
    (assert (point? pt) "expected point instance")
    (assert (number? decimals) "expected number instance")
-   (Point. (mth/precision (dm/get-prop pt :x) decimals)
-           (mth/precision (dm/get-prop pt :y) decimals))))
+   (pos->Point (mth/precision (dm/get-prop pt :x) decimals)
+               (mth/precision (dm/get-prop pt :y) decimals))))
 
 (defn round-step
   "Round the coordinates to the closest half-point"
   [pt step]
   (assert (point? pt) "expected point instance")
-  (Point. (mth/round (dm/get-prop pt :x) step)
-          (mth/round (dm/get-prop pt :y) step)))
+  (pos->Point (mth/round (dm/get-prop pt :x) step)
+              (mth/round (dm/get-prop pt :y) step)))
 
 (defn transform
   "Transform a point applying a matrix transformation."
   [p m]
   (when (point? p)
-    (if (nil? m)
-      p
+    (if (some? m)
       (let [x (dm/get-prop p :x)
             y (dm/get-prop p :y)
             a (dm/get-prop m :a)
@@ -330,18 +339,51 @@
             d (dm/get-prop m :d)
             e (dm/get-prop m :e)
             f (dm/get-prop m :f)]
-        (Point. (+ (* x a) (* y c) e)
-                (+ (* x b) (* y d) f))))))
+        (pos->Point (+ (* x a) (* y c) e)
+                    (+ (* x b) (* y d) f)))
+      p)))
 
 
+(defn transform!
+  [p m]
+
+  (dm/assert!
+   "expected valid rect and matrix instances"
+   (and (some? p) (some? m)))
+
+  (let [x (dm/get-prop p :x)
+        y (dm/get-prop p :y)
+        a (dm/get-prop m :a)
+        b (dm/get-prop m :b)
+        c (dm/get-prop m :c)
+        d (dm/get-prop m :d)
+        e (dm/get-prop m :e)
+        f (dm/get-prop m :f)]
+    #?(:clj
+       (pos->Point (+ (* x a) (* y c) e)
+                   (+ (* x b) (* y d) f))
+       :cljs
+       (do
+         (set! (.-x p) (+ (* x a) (* y c) e))
+         (set! (.-y p) (+ (* x b) (* y d) f))
+         p))))
+
+(defn matrix->point
+  "Returns a result of transform an identity point with the provided
+  matrix instance"
+  [m]
+  (let [e (dm/get-prop m :e)
+        f (dm/get-prop m :f)]
+    (pos->Point e f)))
+
 ;; Vector functions
 (defn to-vec [p1 p2]
   (subtract p2 p1))
 
 (defn scale
   [p scalar]
-  (Point. (* (dm/get-prop p :x) scalar)
-          (* (dm/get-prop p :y) scalar)))
+  (pos->Point (* (dm/get-prop p :x) scalar)
+              (* (dm/get-prop p :y) scalar)))
 
 (defn dot
   [p1 p2]
@@ -354,14 +396,14 @@
   [p1]
   (let [p-length (length p1)]
     (if (mth/almost-zero? p-length)
-      (Point. 0 0)
-      (Point. (/ (dm/get-prop p1 :x) p-length)
-              (/ (dm/get-prop p1 :y) p-length)))))
+      (pos->Point 0 0)
+      (pos->Point (/ (dm/get-prop p1 :x) p-length)
+                  (/ (dm/get-prop p1 :y) p-length)))))
 
 (defn perpendicular
   [pt]
-  (Point. (- (dm/get-prop pt :y))
-          (dm/get-prop pt :x)))
+  (pos->Point (- (dm/get-prop pt :y))
+              (dm/get-prop pt :x)))
 
 (defn project
   "V1 perpendicular projection on vector V2"
@@ -412,7 +454,7 @@
   [p1 p2 t]
   (let [x (mth/lerp (dm/get-prop p1 :x) (dm/get-prop p2 :x) t)
         y (mth/lerp (dm/get-prop p1 :y) (dm/get-prop p2 :y) t)]
-    (Point. x y)))
+    (pos->Point x y)))
 
 (defn rotate
   "Rotates the point around center with an angle"
@@ -434,7 +476,7 @@
         y     (+ (* sa (- px cx))
                  (* ca (- py cy))
                  cy)]
-    (Point. x y)))
+    (pos->Point x y)))
 
 (defn scale-from
   "Moves a point in the vector that creates with center with a scale
@@ -450,10 +492,10 @@
   [p]
   (let [x (dm/get-prop p :x)
         y (dm/get-prop p :y)]
-    (Point. (if (mth/almost-zero? x) 0.001 x)
-            (if (mth/almost-zero? y) 0.001 y))))
-
+    (pos->Point (if (mth/almost-zero? x) 0.001 x)
+                (if (mth/almost-zero? y) 0.001 y))))
 
+;; FIXME: perfromance
 (defn abs
   [point]
   (-> point
@@ -464,3 +506,19 @@
 
 (defmethod pp/simple-dispatch Point [obj] (pr obj))
 
+#?(:clj
+   (fres/add-handlers!
+    {:name "penpot/point"
+     :class Point
+     :wfn (fn [n w ^Point o]
+            (fres/write-tag! w n 1)
+            (fres/write-list! w (List/of (.-x o) (.-y o))))
+     :rfn (fn [rdr]
+            (let [^List x (fres/read-object! rdr)]
+              (pos->Point (.get x 0) (.get x 1))))}))
+
+(t/add-handlers!
+ {:id "point"
+  :class Point
+  :wfn #(into {} %)
+  :rfn map->Point})

common/src/app/common/geom/rect.cljc

@@ -0,0 +1,353 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC
+
+(ns app.common.geom.rect
+  (:require
+   #?(:clj [app.common.fressian :as fres])
+   [app.common.data :as d]
+   [app.common.data.macros :as dm]
+   [app.common.geom.point :as gpt]
+   [app.common.math :as mth]
+   [app.common.record :as rc]
+   [app.common.transit :as t]))
+
+(rc/defrecord Rect [x y width height x1 y1 x2 y2])
+
+(defn rect?
+  [o]
+  (instance? Rect o))
+
+#?(:clj
+   (fres/add-handlers!
+    {:name "penpot/geom/rect"
+     :class Rect
+     :wfn fres/write-map-like
+     :rfn (comp map->Rect fres/read-map-like)}))
+
+(t/add-handlers!
+ {:id "rect"
+  :class Rect
+  :wfn #(into {} %)
+  :rfn map->Rect})
+
+(defn make-rect
+  ([] (make-rect 0 0 0.01 0.01))
+  ([data]
+   (if (rect? data)
+     data
+     (let [{:keys [x y width height]} data]
+       (make-rect (d/nilv x 0)
+                  (d/nilv y 0)
+                  (d/nilv width 0.01)
+                  (d/nilv height 0.01)))))
+
+  ([p1 p2]
+   (dm/assert!
+    "expected `p1` and `p2` to be points"
+    (and (gpt/point? p1)
+         (gpt/point? p2)))
+
+   (let [xp1 (dm/get-prop p1 :x)
+         yp1 (dm/get-prop p1 :y)
+         xp2 (dm/get-prop p2 :x)
+         yp2 (dm/get-prop p2 :y)
+         x1  (mth/min xp1 xp2)
+         y1  (mth/min yp1 yp2)
+         x2  (mth/max xp1 xp2)
+         y2  (mth/max yp1 yp2)]
+     (make-rect x1 y1 (- x2 x1) (- y2 y1))))
+
+  ([x y width height]
+   (when (d/num? x y width height)
+     (let [w (mth/max width 0.01)
+           h (mth/max height 0.01)]
+       (pos->Rect x y w h x y (+ x w) (+ y h))))))
+
+(def empty-rect
+  (make-rect 0 0 0.01 0.01))
+
+(defn update-rect
+  [rect type]
+  (case type
+    :size
+    (let [x (dm/get-prop rect :x)
+          y (dm/get-prop rect :y)
+          w (dm/get-prop rect :width)
+          h (dm/get-prop rect :height)]
+      (assoc rect
+             :x2 (+ x w)
+             :y2 (+ y h)))
+
+    :corners
+    (let [x1 (dm/get-prop rect :x1)
+          y1 (dm/get-prop rect :y1)
+          x2 (dm/get-prop rect :x2)
+          y2 (dm/get-prop rect :y2)]
+      (assoc rect
+             :x (mth/min x1 x2)
+             :y (mth/min y1 y2)
+             :width (mth/abs (- x2 x1))
+             :height (mth/abs (- y2 y1))))
+
+    :position
+    (let [x (dm/get-prop rect :x)
+          y (dm/get-prop rect :y)
+          w (dm/get-prop rect :width)
+          h (dm/get-prop rect :height)]
+      (assoc rect
+             :x1 x
+             :y1 y
+             :x2 (+ x w)
+             :y2 (+ y h)))))
+
+(defn update-rect!
+  [rect type]
+  (case type
+    (:size :position)
+    (let [x (dm/get-prop rect :x)
+          y (dm/get-prop rect :y)
+          w (dm/get-prop rect :width)
+          h (dm/get-prop rect :height)]
+      (rc/assoc! rect
+                 :x1 x
+                 :y1 y
+                 :x2 (+ x w)
+                 :y2 (+ y h)))
+
+    :corners
+    (let [x1 (dm/get-prop rect :x1)
+          y1 (dm/get-prop rect :y1)
+          x2 (dm/get-prop rect :x2)
+          y2 (dm/get-prop rect :y2)]
+      (rc/assoc! rect
+                 :x (mth/min x1 x2)
+                 :y (mth/min y1 y2)
+                 :width (mth/abs (- x2 x1))
+                 :height (mth/abs (- y2 y1))))))
+
+(defn close-rect?
+  [rect1 rect2]
+
+  (dm/assert!
+   "expected two rects"
+   (and (rect? rect1)
+        (rect? rect2)))
+
+  (and ^boolean (mth/close? (dm/get-prop rect1 :x)
+                            (dm/get-prop rect2 :x))
+       ^boolean (mth/close? (dm/get-prop rect1 :y)
+                            (dm/get-prop rect2 :y))
+       ^boolean (mth/close? (dm/get-prop rect1 :width)
+                            (dm/get-prop rect2 :width))
+       ^boolean (mth/close? (dm/get-prop rect1 :height)
+                            (dm/get-prop rect2 :height))))
+
+(defn rect->points
+  [rect]
+  (dm/assert!
+   "expected rect instance"
+   (rect? rect))
+
+  (let [x (dm/get-prop rect :x)
+        y (dm/get-prop rect :y)
+        w (dm/get-prop rect :width)
+        h (dm/get-prop rect :height)]
+    (when (d/num? x y)
+      (let [w (mth/max w 0.01)
+            h (mth/max h 0.01)]
+        [(gpt/point x y)
+         (gpt/point (+ x w) y)
+         (gpt/point (+ x w) (+ y h))
+         (gpt/point x (+ y h))]))))
+
+(defn rect->point
+  "Extract the position part of the rect"
+  [rect]
+  (gpt/point (dm/get-prop rect :x)
+             (dm/get-prop rect :y)))
+
+(defn rect->center
+  [rect]
+  (dm/assert! (rect? rect))
+  (let [x (dm/get-prop rect :x)
+        y (dm/get-prop rect :y)
+        w (dm/get-prop rect :width)
+        h (dm/get-prop rect :height)]
+    (when (d/num? x y w h)
+      (gpt/point (+ x (/ w 2.0))
+                 (+ y (/ h 2.0))))))
+
+(defn rect->lines
+  [rect]
+  (dm/assert! (rect? rect))
+
+  (let [x (dm/get-prop rect :x)
+        y (dm/get-prop rect :y)
+        w (dm/get-prop rect :width)
+        h (dm/get-prop rect :height)]
+    (when (d/num? x y)
+      (let [w (mth/max w 0.01)
+            h (mth/max h 0.01)]
+        [[(gpt/point x y) (gpt/point (+ x w) y)]
+         [(gpt/point (+ x w) y) (gpt/point (+ x w) (+ y h))]
+         [(gpt/point (+ x w) (+ y h)) (gpt/point x (+ y h))]
+         [(gpt/point x (+ y h)) (gpt/point x y)]]))))
+
+(defn points->rect
+  [points]
+  (when-let [points (seq points)]
+    (loop [minx ##Inf
+           miny ##Inf
+           maxx ##-Inf
+           maxy ##-Inf
+           pts  points]
+      (if-let [pt (first pts)]
+        (let [x (dm/get-prop pt :x)
+              y (dm/get-prop pt :y)]
+          (recur (mth/min minx x)
+                 (mth/min miny y)
+                 (mth/max maxx x)
+                 (mth/max maxy y)
+                 (rest pts)))
+        (when (d/num? minx miny maxx maxy)
+          (make-rect minx miny (- maxx minx) (- maxy miny)))))))
+
+;; FIXME: measure performance
+(defn bounds->rect
+  [[pa pb pc pd]]
+  (let [ax   (dm/get-prop pa :x)
+        ay   (dm/get-prop pa :y)
+        bx   (dm/get-prop pb :x)
+        by   (dm/get-prop pb :y)
+        cx   (dm/get-prop pc :x)
+        cy   (dm/get-prop pc :y)
+        dx   (dm/get-prop pd :x)
+        dy   (dm/get-prop pd :y)
+        minx (mth/min ax bx cx dx)
+        miny (mth/min ay by cy dy)
+        maxx (mth/max ax bx cx dx)
+        maxy (mth/max ay by cy dy)]
+    (when (d/num? minx miny maxx maxy)
+      (make-rect minx miny (- maxx minx) (- maxy miny)))))
+
+(def ^:private xf-keep-x (keep #(dm/get-prop % :x)))
+(def ^:private xf-keep-y (keep #(dm/get-prop % :y)))
+(def ^:private xf-keep-x2 (keep #(dm/get-prop % :x2)))
+(def ^:private xf-keep-y2 (keep #(dm/get-prop % :y2)))
+
+(defn squared-points
+  [points]
+  (when (d/not-empty? points)
+    (let [minx (transduce xf-keep-x d/min ##Inf points)
+          miny (transduce xf-keep-y d/min ##Inf points)
+          maxx (transduce xf-keep-x2 d/max ##-Inf points)
+          maxy (transduce xf-keep-y2 d/max ##-Inf points)]
+      (when (d/num? minx miny maxx maxy)
+        [(gpt/point minx miny)
+         (gpt/point maxx miny)
+         (gpt/point maxx maxy)
+         (gpt/point minx maxy)]))))
+
+(defn join-rects [rects]
+  (when (seq rects)
+    (let [minx (transduce xf-keep-x d/min ##Inf rects)
+          miny (transduce xf-keep-y d/min ##Inf rects)
+          maxx (transduce xf-keep-x2 d/max ##-Inf rects)
+          maxy (transduce xf-keep-y2 d/max ##-Inf rects)]
+      (when (d/num? minx miny maxx maxy)
+        (make-rect minx miny (- maxx minx) (- maxy miny))))))
+
+(defn center->rect
+  [point w h]
+  (when (some? point)
+    (let [x (dm/get-prop point :x)
+          y (dm/get-prop point :y)]
+      (when (d/num? x y w h)
+        (make-rect (- x (/ w 2))
+                   (- y (/ h 2))
+                   w
+                   h)))))
+
+(defn s=
+  [a b]
+  (mth/almost-zero? (- a b)))
+
+(defn overlaps-rects?
+  "Check for two rects to overlap. Rects won't overlap only if
+   one of them is fully to the left or the top"
+  [rect-a rect-b]
+  (let [x1a (dm/get-prop rect-a :x)
+        y1a (dm/get-prop rect-a :y)
+        x2a (+ x1a (dm/get-prop rect-a :width))
+        y2a (+ y1a (dm/get-prop rect-a :height))
+
+        x1b (dm/get-prop rect-b :x)
+        y1b (dm/get-prop rect-b :y)
+        x2b (+ x1b (dm/get-prop rect-b :width))
+        y2b (+ y1b (dm/get-prop rect-b :height))]
+
+    (and (or (> x2a x1b)  (s= x2a x1b))
+         (or (>= x2b x1a) (s= x2b x1a))
+         (or (<= y1b y2a) (s= y1b y2a))
+         (or (<= y1a y2b) (s= y1a y2b)))))
+
+(defn contains-point?
+  [rect point]
+  (assert (gpt/point? point))
+  (let [x1 (:x rect)
+        y1 (:y rect)
+        x2 (+ (:x rect) (:width rect))
+        y2 (+ (:y rect) (:height rect))
+
+        px (:x point)
+        py (:y point)]
+
+    (and (or (> px x1) (s= px x1))
+         (or (< px x2) (s= px x2))
+         (or (> py y1) (s= py y1))
+         (or (< py y2) (s= py y2)))))
+
+(defn contains-rect?
+  "Check if a rect srb is contained inside sra"
+  [sra srb]
+  (let [ax1 (dm/get-prop sra :x1)
+        ax2 (dm/get-prop sra :x2)
+        ay1 (dm/get-prop sra :y1)
+        ay2 (dm/get-prop sra :y2)
+        bx1 (dm/get-prop srb :x1)
+        bx2 (dm/get-prop srb :x2)
+        by1 (dm/get-prop srb :y1)
+        by2 (dm/get-prop srb :y2)]
+    (and (>= bx1 ax1)
+         (<= bx2 ax2)
+         (>= by1 ay1)
+         (<= by2 ay2))))
+
+(defn corners->rect
+  ([p1 p2]
+   (corners->rect (:x p1) (:y p1) (:x p2) (:y p2)))
+  ([xp1 yp1 xp2 yp2]
+   (make-rect (mth/min xp1 xp2)
+              (mth/min yp1 yp2)
+              (abs (- xp1 xp2))
+              (abs (- yp1 yp2)))))
+
+(defn clip-rect
+  [selrect bounds]
+  (when (rect? selrect)
+    (dm/assert! (rect? bounds))
+    (let [x1  (dm/get-prop selrect :x1)
+          y1  (dm/get-prop selrect :y1)
+          x2  (dm/get-prop selrect :x2)
+          y2  (dm/get-prop selrect :y2)
+          bx1 (dm/get-prop bounds :x1)
+          by1 (dm/get-prop bounds :y1)
+          bx2 (dm/get-prop bounds :x2)
+          by2 (dm/get-prop bounds :y2)]
+      (corners->rect (mth/max bx1 x1)
+                     (mth/max by1 y1)
+                     (mth/min bx2 x2)
+                     (mth/min by2 y2)))))

common/src/app/common/geom/shapes.cljc

@@ -9,6 +9,7 @@
    [app.common.data :as d]
    [app.common.data.macros :as dm]
    [app.common.geom.point :as gpt]
+   [app.common.geom.rect :as grc]
    [app.common.geom.shapes.bool :as gsb]
    [app.common.geom.shapes.common :as gco]
    [app.common.geom.shapes.constraints :as gct]
@@ -16,28 +17,30 @@
    [app.common.geom.shapes.intersect :as gsi]
    [app.common.geom.shapes.modifiers :as gsm]
    [app.common.geom.shapes.path :as gsp]
-   [app.common.geom.shapes.rect :as gpr]
-   [app.common.geom.shapes.text :as gst]
    [app.common.geom.shapes.transforms :as gtr]
    [app.common.math :as mth]))
 
 ;; --- Outer Rect
 
-(defn selection-rect
-  "Returns a rect that contains all the shapes and is aware of the
-  rotation of each shape. Mainly used for multiple selection."
-  [shapes]
-  (->> shapes
-       (map (comp gpr/points->selrect :points))
-       (gpr/join-selrects)))
-
 (defn translate-to-frame
-  [shape {:keys [x y]}]
-  (gtr/move shape (gpt/negate (gpt/point x y)))  )
+  [shape frame]
+  (->> (gpt/point (- (dm/get-prop frame :x))
+                  (- (dm/get-prop frame :y)))
+       (gtr/move shape)))
 
 (defn translate-from-frame
-  [shape {:keys [x y]}]
-  (gtr/move shape (gpt/point x y))  )
+  [shape frame]
+  (gtr/move shape (gpt/point (dm/get-prop frame :x)
+                             (dm/get-prop frame :y))))
+
+(defn shape->rect
+  [shape]
+  (let [x (dm/get-prop shape :x)
+        y (dm/get-prop shape :y)
+        w (dm/get-prop shape :width)
+        h (dm/get-prop shape :height)]
+    (when (d/num? x y w h)
+      (grc/make-rect x y w h))))
 
 ;; --- Helpers
 
@@ -45,7 +48,7 @@
   "Returns a rect that wraps the shape after all transformations applied."
   [shape]
   ;; TODO: perhaps we need to store this calculation in a shape attribute
-  (gpr/points->rect (:points shape)))
+  (grc/points->rect (:points shape)))
 
 (defn left-bound
   "Returns the lowest x coord of the shape BEFORE applying transformations."
@@ -82,21 +85,38 @@
          (update :width (comp inc inc))
          (update :height (comp inc inc))))))
 
-(defn selrect->areas [bounds selrect]
-  (let [{bound-x1 :x1 bound-x2 :x2 bound-y1 :y1 bound-y2 :y2} bounds
-        {sr-x1 :x1 sr-x2 :x2 sr-y1 :y1 sr-y2 :y2} selrect]
-    {:left (gpr/corners->selrect bound-x1 sr-y1 sr-x1 sr-y2)
-     :top    (gpr/corners->selrect sr-x1 bound-y1 sr-x2 sr-y1)
-     :right  (gpr/corners->selrect sr-x2 sr-y1 bound-x2 sr-y2)
-     :bottom (gpr/corners->selrect sr-x1 sr-y2 sr-x2 bound-y2)}))
+(defn get-areas
+  [bounds selrect]
+  (let [bound-x1 (dm/get-prop bounds :x1)
+        bound-x2 (dm/get-prop bounds :x2)
+        bound-y1 (dm/get-prop bounds :y1)
+        bound-y2 (dm/get-prop bounds :y2)
+        sr-x1    (dm/get-prop selrect :x1)
+        sr-x2    (dm/get-prop selrect :x2)
+        sr-y1    (dm/get-prop selrect :y1)
+        sr-y2    (dm/get-prop selrect :y2)]
+    {:left   (grc/corners->rect bound-x1 sr-y1 sr-x1 sr-y2)
+     :top    (grc/corners->rect sr-x1 bound-y1 sr-x2 sr-y1)
+     :right  (grc/corners->rect sr-x2 sr-y1 bound-x2 sr-y2)
+     :bottom (grc/corners->rect sr-x1 sr-y2 sr-x2 bound-y2)}))
 
-(defn distance-selrect [selrect other]
-  (let [{:keys [x1 y1]} other
-        {:keys [x2 y2]} selrect]
+(defn distance-selrect
+  [selrect other]
+
+  (dm/assert!
+   (and (grc/rect? selrect)
+        (grc/rect? other)))
+
+  (let [x1 (dm/get-prop other :x1)
+        y1 (dm/get-prop other :y1)
+        x2 (dm/get-prop selrect :x2)
+        y2 (dm/get-prop selrect :y2)]
     (gpt/point (- x1 x2) (- y1 y2))))
 
 (defn distance-shapes [shape other]
-  (distance-selrect (:selrect shape) (:selrect other)))
+  (distance-selrect
+   (dm/get-prop shape :selrect)
+   (dm/get-prop other :selrect)))
 
 (defn close-attrs?
   "Compares two shapes attributes to see if they are equal or almost
@@ -131,26 +151,11 @@
        (= val1 val2)))))
 
 ;; EXPORTS
-(dm/export gco/center-shape)
-(dm/export gco/center-selrect)
-(dm/export gco/center-rect)
-(dm/export gco/center-points)
+(dm/export gco/shape->center)
+(dm/export gco/shapes->rect)
+(dm/export gco/points->center)
 (dm/export gco/transform-points)
-
-(dm/export gpr/make-rect)
-(dm/export gpr/make-selrect)
-(dm/export gpr/rect->selrect)
-(dm/export gpr/rect->points)
-(dm/export gpr/points->selrect)
-(dm/export gpr/points->rect)
-(dm/export gpr/center->rect)
-(dm/export gpr/center->selrect)
-(dm/export gpr/join-rects)
-(dm/export gpr/join-selrects)
-(dm/export gpr/contains-selrect?)
-(dm/export gpr/contains-point?)
-(dm/export gpr/close-selrect?)
-(dm/export gpr/clip-selrect)
+(dm/export gco/shape->points)
 
 (dm/export gtr/move)
 (dm/export gtr/absolute-move)
@@ -168,17 +173,21 @@
 (dm/export gtr/transform-bounds)
 (dm/export gtr/move-position-data)
 (dm/export gtr/apply-objects-modifiers)
+(dm/export gtr/apply-children-modifiers)
+(dm/export gtr/update-shapes-geometry)
 
 ;; Constratins
 (dm/export gct/calc-child-modifiers)
 
 ;; PATHS
+;; FIXME: rename
 (dm/export gsp/content->selrect)
 (dm/export gsp/transform-content)
 (dm/export gsp/open-path?)
 
 ;; Intersection
 (dm/export gsi/overlaps?)
+(dm/export gsi/overlaps-path?)
 (dm/export gsi/has-point?)
 (dm/export gsi/has-point-rect?)
 (dm/export gsi/rect-contains-shape?)
@@ -196,6 +205,3 @@
 
 ;; Modifiers
 (dm/export gsm/set-objects-modifiers)
-
-;; Text
-(dm/export gst/position-data-selrect)

common/src/app/common/geom/shapes/bounds.cljc

@@ -7,32 +7,29 @@
 (ns app.common.geom.shapes.bounds
   (:require
    [app.common.data :as d]
-   [app.common.geom.shapes.rect :as gsr]
+   [app.common.data.macros :as dm]
+   [app.common.geom.rect :as grc]
    [app.common.math :as mth]
    [app.common.pages.helpers :as cph]))
 
 (defn shape-stroke-margin
   [shape stroke-width]
-  (if (= (:type shape) :path)
+  (if (cph/path-shape? shape)
     ;; TODO: Calculate with the stroke offset (not implemented yet
     (mth/sqrt (* 2 stroke-width stroke-width))
     (- (mth/sqrt (* 2 stroke-width stroke-width)) stroke-width)))
 
-(defn blur-filters [type value]
-  (->> [value]
-       (remove :hidden)
-       (filter #(= (:type %) type))
-       (map #(hash-map :id (str "filter_" (:id %))
-                       :type (:type %)
-                       :params %))))
-
-(defn shadow-filters [type filters]
-  (->> filters
-       (remove :hidden)
-       (filter #(= (:style %) type))
-       (map #(hash-map :id (str "filter_" (:id %))
-                       :type (:style %)
-                       :params %))))
+(defn- apply-filters
+  [type filters]
+  (sequence
+   (comp
+    (remove :hidden)
+    (filter #(= (:style %) type))
+    (map (fn [item]
+           {:id (dm/str "filter_" (:id item))
+            :type type
+            :params item})))
+   filters))
 
 (defn shape->filters
   [shape]
@@ -41,93 +38,112 @@
 
    ;; Background blur won't work in current SVG specification
    ;; We can revisit this in the future
-   #_(->> shape :blur   (blur-filters   :background-blur))
+   #_(->> shape :blur (into []) (blur-filters :background-blur))
 
-   (->> shape :shadow (shadow-filters :drop-shadow))
+   (->> shape :shadow (apply-filters :drop-shadow))
    [{:id "shape" :type :blend-filters}]
-   (->> shape :shadow (shadow-filters :inner-shadow))
-   (->> shape :blur   (blur-filters   :layer-blur))))
+   (->> shape :shadow (apply-filters :inner-shadow))
+   (->> shape :blur   (into []) (apply-filters :layer-blur))))
 
-(defn calculate-filter-bounds [{:keys [x y width height]} filter-entry]
-  (let [{:keys [offset-x offset-y blur spread] :or {offset-x 0 offset-y 0 blur 0 spread 0}} (:params filter-entry)
-        filter-x (min x (+ x offset-x (- spread) (- blur) -5))
-        filter-y (min y (+ y offset-y (- spread) (- blur) -5))
-        filter-width (+ width (mth/abs offset-x) (* spread 2) (* blur 2) 10)
-        filter-height (+ height (mth/abs offset-y) (* spread 2) (* blur 2) 10)]
-    (gsr/make-selrect filter-x filter-y filter-width filter-height)))
+(defn- calculate-filter-bounds
+  [selrect filter-entry]
+  (let [x (dm/get-prop selrect :x)
+        y (dm/get-prop selrect :y)
+        w (dm/get-prop selrect :width)
+        h (dm/get-prop selrect :height)
+
+        {:keys [offset-x offset-y blur spread]
+         :or {offset-x 0 offset-y 0 blur 0 spread 0}}
+        (:params filter-entry)
+
+        filter-x (mth/min x (+ x offset-x (- spread) (- blur) -5))
+        filter-y (mth/min y (+ y offset-y (- spread) (- blur) -5))
+        filter-w (+ w (mth/abs offset-x) (* spread 2) (* blur 2) 10)
+        filter-h (+ h (mth/abs offset-y) (* spread 2) (* blur 2) 10)]
+    (grc/make-rect filter-x filter-y filter-w filter-h)))
 
 (defn get-rect-filter-bounds
   [selrect filters blur-value]
-  (let [filter-bounds (->> filters
-                           (filter #(= :drop-shadow (:type %)))
-                           (map (partial calculate-filter-bounds selrect))
-                           (concat [selrect])
-                           (gsr/join-selrects))
-        delta-blur (* blur-value 2)
-
-        result
-        (-> filter-bounds
-            (update :x - delta-blur)
-            (update :y - delta-blur)
-            (update :x1 - delta-blur)
-            (update :y1 - delta-blur)
-            (update :x2 + delta-blur)
-            (update :y2 + delta-blur)
-            (update :width + (* delta-blur 2))
-            (update :height + (* delta-blur 2)))]
-
-    result))
+  (let [bounds-xf  (comp
+                    (filter #(= :drop-shadow (:type %)))
+                    (map (partial calculate-filter-bounds selrect)))
+        delta-blur (* blur-value 2)]
+    (-> (into [selrect] bounds-xf filters)
+        (grc/join-rects)
+        (update :x - delta-blur)
+        (update :y - delta-blur)
+        (update :x1 - delta-blur)
+        (update :y1 - delta-blur)
+        (update :x2 + delta-blur)
+        (update :y2 + delta-blur)
+        (update :width + (* delta-blur 2))
+        (update :height + (* delta-blur 2)))))
 
 (defn get-shape-filter-bounds
-  ([shape]
-   (let [svg-root? (and (= :svg-raw (:type shape)) (not= :svg (get-in shape [:content :tag])))]
-     (if svg-root?
-       (:selrect shape)
-
-       (let [filters (shape->filters shape)
-             blur-value (or (-> shape :blur :value) 0)]
-         (get-rect-filter-bounds (-> shape :points gsr/points->selrect) filters blur-value))))))
+  [shape]
+  (if (and (cph/svg-raw-shape? shape)
+           (not= :svg (dm/get-in shape [:content :tag])))
+    (dm/get-prop shape :selrect)
+    (let [filters    (shape->filters shape)
+          blur-value (or (-> shape :blur :value) 0)
+          srect      (-> (dm/get-prop shape :points)
+                         (grc/points->rect))]
+      (get-rect-filter-bounds srect filters blur-value))))
 
 (defn calculate-padding
   ([shape]
    (calculate-padding shape false))
-
   ([shape ignore-margin?]
-   (let [stroke-width (apply max 0 (map #(case (:stroke-alignment % :center)
-                                           :center (/ (:stroke-width % 0) 2)
-                                           :outer (:stroke-width % 0)
-                                           0) (:strokes shape)))
+   (let [strokes (:strokes shape)
 
-         margin (if ignore-margin?
-                  0
-                  (apply max 0 (map #(shape-stroke-margin % stroke-width) (:strokes shape))))
+         stroke-width
+         (->> strokes
+              (map #(case (get % :stroke-alignment :center)
+                      :center (/ (:stroke-width % 0) 2)
+                      :outer  (:stroke-width % 0)
+                      0))
+              (reduce d/max 0))
 
-         shadow-width (apply max 0 (map #(case (:style % :drop-shadow)
-                                           :drop-shadow (+ (mth/abs (:offset-x %)) (* (:spread %) 2) (* (:blur %) 2) 10)
-                                           0) (:shadow shape)))
+         margin
+         (if ignore-margin?
+           0
+           (->> strokes
+                (map #(shape-stroke-margin % stroke-width))
+                (reduce d/max 0)))
 
-         shadow-height (apply max 0 (map #(case (:style % :drop-shadow)
-                                            :drop-shadow (+ (mth/abs (:offset-y %)) (* (:spread %) 2) (* (:blur %) 2) 10)
-                                            0) (:shadow shape)))]
+         shadow-width
+         (->> (:shadow shape)
+              (map #(case (:style % :drop-shadow)
+                      :drop-shadow (+ (mth/abs (:offset-x %)) (* (:spread %) 2) (* (:blur %) 2) 10)
+                      0))
+              (reduce d/max 0))
+
+         shadow-height
+         (->> (:shadow shape)
+              (map #(case (:style % :drop-shadow)
+                      :drop-shadow (+ (mth/abs (:offset-y %)) (* (:spread %) 2) (* (:blur %) 2) 10)
+                      0))
+              (reduce d/max 0))]
 
      {:horizontal (+ stroke-width margin shadow-width)
       :vertical (+ stroke-width margin shadow-height)})))
 
 (defn- add-padding
   [bounds padding]
-  (-> bounds
-      (update :x - (:horizontal padding))
-      (update :x1 - (:horizontal padding))
-      (update :x2 + (:horizontal padding))
-      (update :y - (:vertical padding))
-      (update :y1 - (:vertical padding))
-      (update :y2 + (:vertical padding))
-      (update :width + (* 2 (:horizontal padding)))
-      (update :height + (* 2 (:vertical padding)))))
+  (let [h-padding (:horizontal padding)
+        v-padding (:vertical padding)]
+    (-> bounds
+        (update :x - h-padding)
+        (update :x1 - h-padding)
+        (update :x2 + h-padding)
+        (update :y - v-padding)
+        (update :y1 - v-padding)
+        (update :y2 + v-padding)
+        (update :width + (* 2 h-padding))
+        (update :height + (* 2 v-padding)))))
 
 (defn get-object-bounds
   [objects shape]
-
   (let [calculate-base-bounds
         (fn [shape]
           (-> (get-shape-filter-bounds shape)
@@ -138,7 +154,7 @@
           (empty? (:shapes shape))
           [(calculate-base-bounds shape)]
 
-          (:masked-group? shape)
+          (:masked-group shape)
           [(calculate-base-bounds shape)]
 
           (and (cph/frame-shape? shape) (not (:show-content shape)))
@@ -147,23 +163,22 @@
           :else
           (cph/reduce-objects
            objects
+
            (fn [shape]
              (and (d/not-empty? (:shapes shape))
                   (or (not (cph/frame-shape? shape))
                       (:show-content shape))
 
                   (or (not (cph/group-shape? shape))
-                      (not (:masked-group? shape)))))
-
+                      (not (:masked-group shape)))))
            (:id shape)
-
            (fn [result child]
              (conj result (calculate-base-bounds child)))
 
            [(calculate-base-bounds shape)]))
 
         children-bounds
-        (cond->> (gsr/join-selrects bounds)
+        (cond->> (grc/join-rects bounds)
           (not (cph/frame-shape? shape)) (or (:children-bounds shape)))
 
         filters (shape->filters shape)

common/src/app/common/geom/shapes/common.cljc

@@ -7,80 +7,95 @@
 (ns app.common.geom.shapes.common
   (:require
    [app.common.data :as d]
+   [app.common.data.macros :as dm]
    [app.common.geom.matrix :as gmt]
    [app.common.geom.point :as gpt]
-   [app.common.geom.shapes.rect :as gpr]
-   [app.common.math :as mth]))
+   [app.common.geom.rect :as grc]
+   [app.common.math :as mth]
+   [app.common.record :as cr]))
 
-(defn center-rect
-  [{:keys [x y width height]}]
-  (when (d/num? x y width height)
-    (gpt/point (+ x (/ width 2.0))
-               (+ y (/ height 2.0)))))
+(def ^:private xf-keep-x (keep #(dm/get-prop % :x)))
+(def ^:private xf-keep-y (keep #(dm/get-prop % :y)))
 
-(defn center-selrect
-  "Calculate the center of the selrect."
-  [selrect]
-  (center-rect selrect))
+(defn shapes->rect
+  "Returns a rect that contains all the shapes and is aware of the
+  rotation of each shape. Mainly used for multiple selection."
+  [shapes]
+  (->> shapes
+       (keep (fn [shape]
+               (-> (dm/get-prop shape :points)
+                   (grc/points->rect))))
+       (grc/join-rects)))
 
-(defn center-points [points]
-  (let [ptx  (into [] (keep :x) points)
-        pty  (into [] (keep :y) points)
-        minx (reduce min ##Inf ptx)
-        miny (reduce min ##Inf pty)
-        maxx (reduce max ##-Inf ptx)
-        maxy (reduce max ##-Inf pty)]
+(defn points->center
+  [points]
+  (let [ptx  (into [] xf-keep-x points)
+        pty  (into [] xf-keep-y points)
+        minx (reduce d/min ##Inf ptx)
+        miny (reduce d/min ##Inf pty)
+        maxx (reduce d/max ##-Inf ptx)
+        maxy (reduce d/max ##-Inf pty)]
     (gpt/point (/ (+ minx maxx) 2.0)
                (/ (+ miny maxy) 2.0))))
 
-(defn center-bounds [[a b c d]]
-  (let [xa (:x a)
-        ya (:y a)
-        xb (:x b)
-        yb (:y b)
-        xc (:x c)
-        yc (:y c)
-        xd (:x d)
-        yd (:y d)
-        minx (min xa xb xc xd)
-        miny (min ya yb yc yd)
-        maxx (max xa xb xc xd)
-        maxy (max ya yb yc yd)]
-    (gpt/point (/ (+ minx maxx) 2.0)
-               (/ (+ miny maxy) 2.0))))
-
-(defn center-shape
+(defn shape->center
   "Calculate the center of the shape."
   [shape]
-  (center-rect (:selrect shape)))
+  (grc/rect->center (dm/get-prop shape :selrect)))
 
 (defn transform-points
   ([points matrix]
    (transform-points points nil matrix))
 
   ([points center matrix]
-   (if (and (d/not-empty? points) (gmt/matrix? matrix))
-     (let [prev (if center (gmt/translate-matrix center) (gmt/matrix))
-           post (if center (gmt/translate-matrix (gpt/negate center)) (gmt/matrix))
-
-           tr-point (fn [point]
-                      (gpt/transform point (gmt/multiply prev matrix post)))]
-       (mapv tr-point points))
+   (if (and ^boolean (gmt/matrix? matrix)
+            ^boolean (seq points))
+     (let [prev (if (some? center) (gmt/translate-matrix center) (cr/clone gmt/base))
+           post (if (some? center) (gmt/translate-matrix-neg center) gmt/base)
+           mtx  (-> prev
+                    (gmt/multiply! matrix)
+                    (gmt/multiply! post))]
+       (mapv #(gpt/transform % mtx) points))
      points)))
 
 (defn transform-selrect
-  [{:keys [x1 y1 x2 y2] :as sr} matrix]
-  (let [[c1 c2] (transform-points [(gpt/point x1 y1) (gpt/point x2 y2)] matrix)]
-    (gpr/corners->selrect c1 c2)))
+  [selrect matrix]
+
+  (dm/assert!
+   "expected valid rect and matrix instances"
+   (and (grc/rect? selrect)
+        (gmt/matrix? matrix)))
+
+  (let [x1 (dm/get-prop selrect :x1)
+        y1 (dm/get-prop selrect :y1)
+        x2 (dm/get-prop selrect :x2)
+        y2 (dm/get-prop selrect :y2)
+        p1 (gpt/point x1 y1)
+        p2 (gpt/point x2 y2)
+        c1 (gpt/transform! p1 matrix)
+        c2 (gpt/transform! p2 matrix)]
+    (grc/corners->rect c1 c2)))
 
 (defn invalid-geometry?
   [{:keys [points selrect]}]
 
-  (or (mth/nan? (:x selrect))
-      (mth/nan? (:y selrect))
-      (mth/nan? (:width selrect))
-      (mth/nan? (:height selrect))
-      (some (fn [p]
-              (or (mth/nan? (:x p))
-                  (mth/nan? (:y p))))
-            points)))
+  (or ^boolean (mth/nan? (:x selrect))
+      ^boolean (mth/nan? (:y selrect))
+      ^boolean (mth/nan? (:width selrect))
+      ^boolean (mth/nan? (:height selrect))
+      ^boolean (some (fn [p]
+                       (or ^boolean (mth/nan? (:x p))
+                           ^boolean (mth/nan? (:y p))))
+                     points)))
+
+(defn shape->points
+  [{:keys [transform points]}]
+  (if (gmt/unit? transform)
+    ;; Fix problem with precision could skew the shape
+    ;; when there are no transforms the points are the selrect shape
+    (let [p0 (nth points 0) ;; left top
+          p2 (nth points 2) ;; right bottom
+          p1 (gpt/point (:x p2) (:y p0))
+          p3 (gpt/point (:x p0) (:y p2))]
+      [p0 p1 p2 p3])
+    points))