📎 Update version.txt file

🐛 Fix OIDC issues and regressions

.circleci/config.yml

@@ -32,42 +32,42 @@ jobs:
       - run: clj-kondo --version
 
       - run:
-          name: "fmt check backend [clj]"
+          name: "backend fmt check"
           working_directory: "./backend"
           command: |
             yarn install
             yarn run fmt:clj:check
 
       - run:
-          name: "fmt check exporter [clj]"
+          name: "exporter fmt check"
           working_directory: "./exporter"
           command: |
             yarn install
             yarn run fmt:clj:check
 
       - run:
-          name: "fmt check common [clj]"
+          name: "common fmt check"
           working_directory: "./common"
           command: |
             yarn install
             yarn run fmt:clj:check
 
       - run:
-          name: "fmt check frontend [clj]"
+          name: "frontend fmt check"
           working_directory: "./frontend"
           command: |
             yarn install
             yarn run fmt:clj:check
 
       - run:
-          name: common lint
+          name: "common linter check"
           working_directory: "./common"
           command: |
             yarn install
             yarn run lint:clj
 
       - run:
-          name: frontend lint
+          name: "frontend linter check"
           working_directory: "./frontend"
           command: |
             yarn install
@@ -75,14 +75,14 @@ jobs:
             yarn run lint:clj
 
       - run:
-          name: backend lint
+          name: "backend linter check"
           working_directory: "./backend"
           command: |
             yarn install
             yarn run lint:clj
 
       - run:
-          name: exporter lint
+          name: "exporter linter check"
           working_directory: "./exporter"
           command: |
             yarn install
@@ -93,7 +93,7 @@ jobs:
           working_directory: "./common"
           command: |
             yarn test
-            clojure -X:dev:test :patterns '["common-tests.*-test"]'
+            clojure -M:dev:test
 
       - run:
           name: "frontend tests"
@@ -102,11 +102,21 @@ jobs:
             yarn install
             yarn test
 
+      - run:
+          name: "frontend integration tests"
+          working_directory: "./frontend"
+          command: |
+            yarn install
+            yarn run compile
+            clojure -M:dev:shadow-cljs release main
+            yarn playwright install --with-deps chromium
+            yarn e2e:test
+
       - run:
           name: "backend tests"
           working_directory: "./backend"
           command: |
-            clojure -X:dev:test :patterns '["backend-tests.*-test"]'
+            clojure -M:dev:test
 
           environment:
             PENPOT_TEST_DATABASE_URI: "postgresql://localhost/penpot_test"

.clj-kondo/hooks/export.clj

@@ -12,6 +12,7 @@
 
 (def registry (atom {}))
 
+
 (defn potok-reify
   [{:keys [:node :filename] :as params}]
   (let [[rnode rtype & other] (:children node)

.gitignore

@@ -57,6 +57,7 @@
 /frontend/package-lock.json
 /frontend/resources/fonts/experiments
 /frontend/resources/public/*
+/frontend/storybook-static/
 /frontend/target/
 /other/
 /scripts/
@@ -68,3 +69,7 @@
 clj-profiler/
 node_modules
 frontend/.storybook/preview-body.html
+/test-results/
+/playwright-report/
+/blob-report/
+/playwright/.cache/

CHANGES.md

@@ -1,13 +1,89 @@
 # CHANGELOG
 
+## 2.1.2
+
+### :bug: Bugs fixed
+
+- User switch language to "zh_hant" will get 400 [Github #4884](https://github.com/penpot/penpot/issues/4884)
+- Smtp config ignoring port if ssl is set [Github #4872](https://github.com/penpot/penpot/issues/4872)
+- Ability to let users to authenticate with a private oidc provider only [Github #4963](https://github.com/penpot/penpot/issues/4963)
+
+## 2.1.1
+
+### :sparkles: New features
+
+- Consolidate templates new order and naming  [Taiga #8392](https://tree.taiga.io/project/penpot/task/8392)
+
+### :bug: Bugs fixed
+
+- Fix the “search” label in translations [Taiga #8402](https://tree.taiga.io/project/penpot/issue/8402)
+- Fix pencil loader [Taiga #8348](https://tree.taiga.io/project/penpot/issue/8348)
+- Fix several issues on the OIDC.
+- Fix regression on the `email-verification` flag [Taiga #8398](https://tree.taiga.io/project/penpot/issue/8398)
+
+## 2.1.0 - Things can only get better!
+
+### :rocket: Epics and highlights
+
+### :boom: Breaking changes & Deprecations
+
+### :heart: Community contributions (Thank you!)
+
+### :sparkles: New features
+
+- Improve auth process [Taiga #7094](https://tree.taiga.io/project/penpot/us/7094)
+- Add locking degrees increment (hold shift) on path edition [Taiga #7761](https://tree.taiga.io/project/penpot/issue/7761)
+- Persistence & Concurrent Edition Enhancements [Taiga #5657](https://tree.taiga.io/project/penpot/us/5657)
+- Allow library colors as recent colors [Taiga #7640](https://tree.taiga.io/project/penpot/issue/7640)
+- Missing scroll in viewmode comments [Taiga #7427](https://tree.taiga.io/project/penpot/issue/7427)
+- Comments in View mode should mimic the positioning behavior of the Workspace [Taiga #7346](https://tree.taiga.io/project/penpot/issue/7346)
+- Misaligned input on comments [Taiga #7461](https://tree.taiga.io/project/penpot/issue/7461)
+
+### :bug: Bugs fixed
+
+- Fix selection rectangle appears on scroll [Taiga #7525](https://tree.taiga.io/project/penpot/issue/7525)
+- Fix layer tree not expanding to the bottom edge [Taiga #7466](https://tree.taiga.io/project/penpot/issue/7466)
+- Fix guides move when board is moved by inputs [Taiga #8010](https://tree.taiga.io/project/penpot/issue/8010)
+- Fix clickable area of Penptot logo in the viewer [Taiga #7988](https://tree.taiga.io/project/penpot/issue/7988)
+- Fix constraints dropdown when selecting multiple shapes [Taiga #7686](https://tree.taiga.io/project/penpot/issue/7686)
+- Layout and scrollign fixes for the bottom palette [Taiga #7559](https://tree.taiga.io/project/penpot/issue/7559)
+- Fix expand libraries when search results are present [Taiga #7876](https://tree.taiga.io/project/penpot/issue/7876)
+- Fix color palette default library [Taiga #8029](https://tree.taiga.io/project/penpot/issue/8029)
+- Component Library is lost after exporting/importing in .zip format [Github #4672](https://github.com/penpot/penpot/issues/4672)
+- Fix problem with moving+selection not working properly [Taiga #7943](https://tree.taiga.io/project/penpot/issue/7943)
+- Fix problem with flex layout fit to content not positioning correctly children [Taiga #7537](https://tree.taiga.io/project/penpot/issue/7537)
+- Fix black line is displaying after show main [Taiga #7653](https://tree.taiga.io/project/penpot/issue/7653)
+- Fix "Share prototypes" modal remains open [Taiga #7442](https://tree.taiga.io/project/penpot/issue/7442)
+- Fix "Components visibility and opacity" [#4694](https://github.com/penpot/penpot/issues/4694)
+- Fix "Attribute overrides in copies are not exported in zip file" [Taiga #8072](https://tree.taiga.io/project/penpot/issue/8072)
+- Fix group not automatically selected in the Layers panel after creation [Taiga #8078](https://tree.taiga.io/project/penpot/issue/8078)
+- Fix export boards loses opacity [Taiga #7592](https://tree.taiga.io/project/penpot/issue/7592)
+- Fix change color on imported svg also changes the stroke alignment[Taiga #7673](https://github.com/penpot/penpot/pull/7673)
+- Fix show in view mode and interactions workflow [Taiga #4711](https://github.com/penpot/penpot/pull/4711)
+- Fix internal error when I set up a stroke for some objects without and with stroke [Taiga #7558](https://tree.taiga.io/project/penpot/issue/7558)
+- Toolbar keeps toggling on and off on spacebar press [Taiga #7654](https://github.com/penpot/penpot/pull/7654)
+- Fix toolbar keeps hiding when click outside workspace [Taiga #7776](https://tree.taiga.io/project/penpot/issue/7776)
+- Fix open overlay relative to a frame [Taiga #7563](https://tree.taiga.io/project/penpot/issue/7563)
+- Workspace-palette items stay hidden when opening with keyboard-shortcut [Taiga #7489](https://tree.taiga.io/project/penpot/issue/7489)
+- Fix SVG attrs are not handled correctly when exporting/importing in .zip [Taiga #7920](https://tree.taiga.io/project/penpot/issue/7920)
+- Fix validation error when detaching with two nested copies and a swap [Taiga #8095](https://tree.taiga.io/project/penpot/issue/8095)
+- Export shapes that are rotated act a bit strange when reimported [Taiga #7585](https://tree.taiga.io/project/penpot/issue/7585)
+- Penpot crashes when a new colorpicker is created while uploading an image to another instance [Taiga #8119](https://tree.taiga.io/project/penpot/issue/8119)
+- Removing Underline and Strikethrough Affects the Previous Text Object [Taiga #8103](https://tree.taiga.io/project/penpot/issue/8103)
+- Color library loses association with shapes when exporting/importing the document [Taiga #8132](https://tree.taiga.io/project/penpot/issue/8132)
+- Fix can't collapse groups when searching in the assets tab [Taiga #8125](https://tree.taiga.io/project/penpot/issue/8125)
+- Fix 'Detach instance' shortcut is not working [Taiga #8102](https://tree.taiga.io/project/penpot/issue/8102)
+- Fix import file message does not detect 0 as error [Taiga #6824](https://tree.taiga.io/project/penpot/issue/6824)
+- Image Color Library is not persisted when exporting/importing in .zip [Taiga #8131](https://tree.taiga.io/project/penpot/issue/8131)
+- Fix export files including libraries [Taiga #8266](https://tree.taiga.io/project/penpot/issue/8266)
+
 ## 2.0.3
 
 ### :bug: Bugs fixed
 
-- Fix chrome scrollbar styling [Taiga Issue #7852](https://tree.taiga.io/project/penpot/issue/7852)
+- Fix chrome scrollbar styling [Taiga #7852](https://tree.taiga.io/project/penpot/issue/7852)
 - Fix incorrect password encoding on create-profile manage scritp [Github #3651](https://github.com/penpot/penpot/issues/3651)
 
-
 ## 2.0.2
 
 ### :sparkles: Enhancements
@@ -17,7 +93,7 @@
 
 ### :bug: Bugs fixed
 
-- Fix color palette sorting [Taiga Issue #7458](https://tree.taiga.io/project/penpot/issue/7458)
+- Fix color palette sorting [Taiga #7458](https://tree.taiga.io/project/penpot/issue/7458)
 - Fix style scoping problem with imported SVG [Taiga #7671](https://tree.taiga.io/project/penpot/issue/7671)
 
 
@@ -121,7 +197,7 @@
 - [REDESIGN] Panels visual separations [Taiga #6692](https://tree.taiga.io/project/penpot/us/6692)
 - [REDESIGN] Onboarding slides [Taiga #6678](https://tree.taiga.io/project/penpot/us/6678)
 
-### :bug Bugs fixed
+### :bug: Bugs fixed
 - Fix pixelated thumbnails [Github #3681](https://github.com/penpot/penpot/issues/3681), [Github #3661](https://github.com/penpot/penpot/issues/3661)
 - Fix problem with not applying colors to boards [Github #3941](https://github.com/penpot/penpot/issues/3941)
 - Fix problem with path editor undoing changes [Github #3998](https://github.com/penpot/penpot/issues/3998)
@@ -162,7 +238,7 @@
 - Fix problem when changing typography assets [Github #3683](https://github.com/penpot/penpot/issues/3683)
 - Internal error when you copy and paste some main components between files [Taiga #7397](https://tree.taiga.io/project/penpot/issue/7397)
 - Fix toolbar disappearing [Taiga #7411](https://tree.taiga.io/project/penpot/issue/7411)
-- Fix long text on tab breaks UI [Taiga Issue #7421](https://tree.taiga.io/project/penpot/issue/7421)
+- Fix long text on tab breaks UI [Taiga #7421](https://tree.taiga.io/project/penpot/issue/7421)
 
 ## 1.19.5
 

README.md

@@ -2,10 +2,11 @@
 [uri_license]: https://www.mozilla.org/en-US/MPL/2.0
 [uri_license_image]: https://img.shields.io/badge/MPL-2.0-blue.svg
 
-<h1 align="center">
-  <br>
-  <img src="https://penpot.app/images/readme/git-readme-header.png" alt="PENPOT">
-</h1>
+<picture>
+  <source media="(prefers-color-scheme: dark)" srcset="https://penpot.app/images/readme/github-dark-mode.png">
+  <source media="(prefers-color-scheme: light)" srcset="https://penpot.app/images/readme/github-light-mode.png">
+  <img alt="penpot header image" src="https://penpot.app/images/readme/github-light-mode.png">
+</picture>
 
 <p align="center"><a href="https://www.mozilla.org/en-US/MPL/2.0" rel="nofollow"><img src="https://camo.githubusercontent.com/3fcf3d6b678ea15fde3cf7d6af0e242160366282d62a7c182d83a50bfee3f45e/68747470733a2f2f696d672e736869656c64732e696f2f62616467652f4d504c2d322e302d626c75652e737667" alt="License: MPL-2.0" data-canonical-src="https://img.shields.io/badge/MPL-2.0-blue.svg" style="max-width:100%;"></a>
 <a href="https://gitter.im/penpot/community" rel="nofollow"><img src="https://camo.githubusercontent.com/5b0aecb33434f82a7b158eab7247544235ada0cf7eeb9ce8e52562dd67f614b7/68747470733a2f2f6261646765732e6769747465722e696d2f736572656e6f2d78797a2f636f6d6d756e6974792e737667" alt="Gitter" data-canonical-src="https://badges.gitter.im/sereno-xyz/community.svg" style="max-width:100%;"></a>
@@ -13,22 +14,36 @@
 <a href="https://gitpod.io/#https://github.com/penpot/penpot" rel="nofollow"><img src="https://camo.githubusercontent.com/daadb4894128d1e19b72d80236f5959f1f2b47f9fe081373f3246131f0189f6c/68747470733a2f2f696d672e736869656c64732e696f2f62616467652f476974706f642d72656164792d2d746f2d2d636f64652d626c75653f6c6f676f3d676974706f64" alt="Gitpod ready-to-code" data-canonical-src="https://img.shields.io/badge/Gitpod-ready--to--code-blue?logo=gitpod" style="max-width:100%;"></a></p>
 
 <p align="center">
-    <a href="https://penpot.app/"><b>Website</b></a> •
-    <a href="https://help.penpot.app/technical-guide/getting-started/"><b>Getting Started</b></a> •
-    <a href="https://help.penpot.app/user-guide/"><b>User Guide</b></a> •
-    <a href="https://help.penpot.app/user-guide/introduction/info/"><b>Tutorials & Info</b></a> •
-    <a href="https://community.penpot.app/"><b>Community</b></a> •
-    <a href="https://twitter.com/penpotapp"><b>Twitter</b></a> •
-    <a href="https://instagram.com/penpot.app"><b>Instagram</b></a> •
-    <a href="https://fosstodon.org/@penpot/"><b>Mastodon</b></a> •
-    <a href="https://www.youtube.com/channel/UCAqS8G72uv9P5HG1IfgnQ9g"><b>Youtube</b></a>
+    <a href="https://penpot.app/"><b>Website</b></a>  •  
+    <a href="https://help.penpot.app/technical-guide/getting-started/"><b>Getting Started</b></a>  •  
+    <a href="https://help.penpot.app/user-guide/"><b>User Guide</b></a>  •  
+    <a href="https://help.penpot.app/user-guide/introduction/info/"><b>Tutorials & Info</b></a>  •  
+    <a href="https://community.penpot.app/"><b>Community</b></a>
+</p>
+<p align="center">
+    <a href="https://www.youtube.com/@Penpot"><b>Youtube</b></a>  •  
+    <a href="https://peertube.kaleidos.net/a/penpot_app/video-channels"><b>Peertube</b></a>  •  
+    <a href="https://www.linkedin.com/company/penpot/"><b>Linkedin</b></a>  •  
+    <a href="https://instagram.com/penpot.app"><b>Instagram</b></a>  •  
+    <a href="https://fosstodon.org/@penpot/"><b>Mastodon</b></a>  •  
+    <a href="https://twitter.com/penpotapp"><b>X</b></a>
+
 </p>
 
-![feature-readme](https://user-images.githubusercontent.com/1045247/189871786-0b44f7cf-3a0a-4445-a87b-9919ec398bf7.gif)
+<br />
 
-🎇 **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 video](https://github.com/penpot/penpot/assets/5446186/b8ad0764-585e-4ddc-b098-9b4090d337cc)
 
-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.
+<br />
+
+Penpot is the first **open-source** design tool for design and code collaboration. Designers can create stunning designs, interactive prototypes, design systems at scale, while developers enjoy ready-to-use code and make their workflow easy and fast. And all of this with no handoff drama.
+
+Penpot is available on browser and [self host](https://penpot.app/self-host). It’s web-based and works with open standards (SVG, CSS and HTML). And last but not least, it’s free! 
+
+Penpot’s latest [huge release 2.0](https://penpot.app/dev-diaries), takes the platform to a whole new level. This update introduces the ground-breaking [CSS Grid Layout feature](https://penpot.app/penpot-2.0), a complete UI redesign, a new Components system, and much more. Plus, it's faster and more accessible. 
+
+
+🎇 **Penpot Fest** is our design, code & Open Source event. Check out the highlights from [Penpot Fest 2023 edition](https://www.youtube.com/watch?v=sOpLZaK5mDc)!
 
 ## Table of contents ##
 
@@ -40,48 +55,47 @@ Penpot is the first **Open Source** design and prototyping platform meant for cr
 
 ## Why Penpot ##
 
-Penpot makes design and prototyping accessible to every team in the world.
+Penpot expresses designs as code. Designers can do their best work and see it will be beautifully implemented by developers in a two-way collaboration.
 
-### For cross-domain teams ###
-We have a clear focus on design and code teams and our capabilities reflect exactly that. The less hand-off mindset, the more fun for everyone.
+### Designed for developers ###
+Penpot was built to serve both designers and developers and create a fluid design-code process. You have the choice to enjoy real-time collaboration or play "solo".
 
-### Multiplatform ###
-Being web based, Penpot is not dependent on operating systems or local installations, you will only need to run a modern browser.
+### Inspect mode ###
+Work with ready-to-use code and make your workflow easy and fast. The inspect tab gives instant access to SVG, CSS and HTML code.
 
-### Open Standards ###
-Using SVG as no other design and prototyping tool does, Penpot files sport compatibility with most of the vectorial tools, are tech friendly and extremely easy to use on the web. We make sure you will always own your work.
+### Self host your own instance ###
+Provide your team or organization with a completely owned collaborative design tool. Use Penpot's cloud service or deploy your own Penpot server.
+
+### Integrations ###
+Penpot offers integration into the development toolchain, thanks to its support for webhooks and an API accessible through access tokens.
+
+### What’s great for design ###
+With Penpot you can design libraries to share and reuse; turn design elements into components and tokens to allow reusability and scalability; and build realistic user flows and interactions.
+
+<br />
 
 <p align="center">
-  <img src="https://penpot.app/images/readme/git-open.png" alt="Open Source" style="width: 65%;">
+  <img src="https://img.plasmic.app/img-optimizer/v1/img?src=https%3A%2F%2Fimg.plasmic.app%2Fimg-optimizer%2Fv1%2Fimg%2F9dd677c36afb477e9666ccd1d3f009ad.png" alt="Open Source" style="width: 65%;">
 </p>
 
+<br />
 
 ## Getting started ##
 
 ### Install with Elestio ###
-[Elestio](https://elest.io/) offers a fully managed service for on-premise instances of a selection of open-source software! This means you can deploy a dedicated instance of Penpot in just 3 minutes with no technical knowledge needed.
+Penpot is the only design & prototype platform that is deployment agnostic. You can use it or deploy it anywhere.
 
-You don’t need to worry about DNS configuration, SMTP, backups, SSL certificates, OS & Penpot upgrades, and much more.
-
-[Get started with Elestio.](https://help.penpot.app/technical-guide/getting-started/#install-with-elestio)
-
-### Install with Docker ###
-
-You can also get started with Penpot locally or self-host it with **docker** and **docker-compose**.
-
-Here’s a step-by-step guide on [getting started with Docker.](https://help.penpot.app/technical-guide/getting-started/#install-with-docker)
-
-### Penpot cloud app ###
-
-If you prefer not to install Penpot in a local environment, [login or register on our Penpot cloud app](https://design.penpot.app). Create a team to work together on projects and share design assets or jump right away into Penpot and **start designing** on your own.
+Learn how to install it with Elestio and Docker, or other options on [our website](https://penpot.app/self-host).
+<br />
 
 <p align="center">
-  <img src="https://penpot.app/images/readme/git-self-host.png" alt="Getting started" style="width: 65%;">
+  <img src="https://site-assets.plasmic.app/2168cf524dd543caeff32384eb9ea0a1.svg" alt="Open Source" style="width: 65%;">
 </p>
+<br />
 
 ## Community ##
 
-We love the open source software community. Contributing is our passion and if it’s yours too, [participate](https://community.penpot.app/) and [improve](https://community.penpot.app/c/help-us-improve-penpot/7) Penpot. All your ideas and code are welcome!
+We love the Open Source software community. Contributing is our passion and if it’s yours too, participate and [improve](https://community.penpot.app/c/help-us-improve-penpot/7) Penpot. All your designs, code and ideas are welcome!
 
 If you need help or have any questions; if you’d like to share your experience using Penpot or get inspired; if you’d rather meet our community of developers and designers, [join our Community](https://community.penpot.app/)!
 
@@ -93,30 +107,41 @@ You will find the following categories:
 - [Events and Announcements](https://community.penpot.app/c/announcements/5)
 - [Inside Penpot](https://community.penpot.app/c/inside-penpot/21)
 - [Penpot in your language](https://community.penpot.app/c/penpot-in-your-language/12)
+- [Design and Code Essentials](https://community.penpot.app/c/design-and-code-essentials/22)
+
+
+<br />
 
 <p align="center">
-  <img src="https://penpot.app/images/readme/git-collaborate.png" alt="Communnity" style="width: 65%;">
+  <img src="https://github.com/penpot/penpot/assets/5446186/6ac62220-a16c-46c9-ab21-d24ae357ed03" alt="Community" style="width: 65%;">
 </p>
+<br />
 
 ## Contributing ##
 
-Every sort of contribution will be very helpful to enhance Penpot. How you’ll participate? All your ideas, designs and code are welcome:
+Any contribution will make a difference to improve Penpot. How can you get involved? 
 
+Choose your way: 
+
+- Create and [share Libraries & Templates](https://penpot.app/libraries-templates.html) that will be helpful for the community
 - Invite your [team to join](https://design.penpot.app/#/auth/register)
-- Star this repo and follow us on Social Media:  [Twitter](https://twitter.com/penpotapp), [Instagram](https://instagram.com/penpot.app), [Youtube](https://www.youtube.com/c/Penpot) or [Mastodon](https://fosstodon.org/@penpot/).
-- Participate in the [Community](https://community.penpot.app/) asking and answering questions, reacting to others’ articles or opening your own conversations.
+- Star this repo and follow us on Social Media: [Mastodon](https://fosstodon.org/@penpot/), [Youtube](https://www.youtube.com/c/Penpot), [Instagram](https://instagram.com/penpot.app), [Linkedin](https://www.linkedin.com/company/penpotdesign),  [Peertube](https://peertube.kaleidos.net/a/penpot_app) and [X](https://twitter.com/penpotapp).
+- Participate in the [Community](https://community.penpot.app/) space by asking and answering questions; reacting to others’ articles;  opening your own conversations and following along on decisions affecting the project.
 - Report bugs with our easy [guide for bugs hunting](https://help.penpot.app/contributing-guide/reporting-bugs/) or [GitHub issues](https://github.com/penpot/penpot/issues)
-- Create and [share Libraries & templates](https://penpot.app/libraries-templates.html) that will be helpful for the community
 - Become a [translator](https://help.penpot.app/contributing-guide/translations)
-- Give feedback: [Mail us](mailto:support@penpot.app)
+- Give feedback: [Email us](mailto:support@penpot.app)
 - **Contribute to Penpot's code:** [Watch this video](https://www.youtube.com/watch?v=TpN0osiY-8k) by Alejandro Alonso, CIO and developer at Penpot, where he gives us a hands-on demo of how to use Penpot’s repository and make changes in both front and back end
 
-To find (almost) everything you need to know on how to contribute to Penpot, refer to the [contributing-guide](https://help.penpot.app/contributing-guide/).
+To find (almost) everything you need to know on how to contribute to Penpot, refer to the [contributing guide](https://help.penpot.app/contributing-guide/).
+
+<br />
 
 <p align="center">
-  <img src="https://penpot.app/images/readme/git-community.png" alt="Contributing" style="width: 65%;">
+  <img src="https://github.com/penpot/penpot/assets/5446186/fea18923-dc06-49be-86ad-c3496a7956e6" alt="Libraries and templates" style="width: 65%;">
 </p>
 
+<br />
+
 ## Resources ##
 
 You can ask and answer questions, have open-ended conversations, and follow along on decisions affecting the project.
@@ -141,4 +166,4 @@ file, You can obtain one at http://mozilla.org/MPL/2.0/.
 
 Copyright (c) KALEIDOS INC
 ```
-Penpot is a Kaleidos’ [open source project](https://kaleidos.net/products)
+Penpot is a Kaleidos’ [open source project](https://kaleidos.net/)

THANKYOU.md

@@ -2,12 +2,19 @@
 
 We want to thank to the amazing people that help us! Thank you! You're the best!
 
+Feel free you make a PR updating this file if you miss you in the
+list.
+
 ## Security
+
 * Husnain Iqbal (CEO OF ALPHA INFERNO PVT LTD)
 * [Shiraz Ali Khan](https://www.linkedin.com/in/shiraz-ali-khan-1ba508180/)
 * Vaibhav Shukla
+* Hassan Ahmed (Alias Xen Lee)
+* Michal Biesiada (@mbiesiad)
 
 ## Internationalization
+
 * [00ff88](https://hosted.weblate.org/user/00ff88)
 * [AhmadHB](https://hosted.weblate.org/user/AhmadHB)
 * [Aimee](https://hosted.weblate.org/user/Aimee)
@@ -89,6 +96,7 @@ We want to thank to the amazing people that help us! Thank you! You're the best!
 * [zcraber](https://hosted.weblate.org/user/zcraber)
 
 ## Libraries & templates
+
 * systxema
 * plumilla
 * victor crespo

backend/deps.edn

@@ -3,10 +3,10 @@
 
  :deps
  {penpot/common {:local/root "../common"}
-  org.clojure/clojure {:mvn/version "1.12.0-alpha5"}
-  org.clojure/tools.namespace {:mvn/version "1.4.4"}
+  org.clojure/clojure {:mvn/version "1.12.0-alpha12"}
+  org.clojure/tools.namespace {:mvn/version "1.5.0"}
 
-  com.github.luben/zstd-jni {:mvn/version "1.5.5-11"}
+  com.github.luben/zstd-jni {:mvn/version "1.5.6-3"}
 
   io.prometheus/simpleclient {:mvn/version "0.16.0"}
   io.prometheus/simpleclient_hotspot {:mvn/version "0.16.0"}
@@ -17,7 +17,7 @@
 
   io.prometheus/simpleclient_httpserver {:mvn/version "0.16.0"}
 
-  io.lettuce/lettuce-core {:mvn/version "6.3.0.RELEASE"}
+  io.lettuce/lettuce-core {:mvn/version "6.3.2.RELEASE"}
   java-http-clj/java-http-clj {:mvn/version "0.4.3"}
 
   funcool/yetti
@@ -26,13 +26,13 @@
    :git/url "https://github.com/funcool/yetti.git"
    :exclusions [org.slf4j/slf4j-api]}
 
-  com.github.seancorfield/next.jdbc {:mvn/version "1.3.909"}
-  metosin/reitit-core {:mvn/version "0.6.0"}
-  nrepl/nrepl {:mvn/version "1.1.0"}
-  cider/cider-nrepl {:mvn/version "0.44.0"}
+  com.github.seancorfield/next.jdbc {:mvn/version "1.3.939"}
+  metosin/reitit-core {:mvn/version "0.7.0"}
+  nrepl/nrepl {:mvn/version "1.1.2"}
+  cider/cider-nrepl {:mvn/version "0.48.0"}
 
-  org.postgresql/postgresql {:mvn/version "42.7.1"}
-  org.xerial/sqlite-jdbc {:mvn/version "3.44.1.0"}
+  org.postgresql/postgresql {:mvn/version "42.7.3"}
+  org.xerial/sqlite-jdbc {:mvn/version "3.46.0.0"}
 
   com.zaxxer/HikariCP {:mvn/version "5.1.0"}
 
@@ -54,11 +54,11 @@
   org.clojars.pntblnk/clj-ldap {:mvn/version "0.0.17"}
 
   dawran6/emoji {:mvn/version "0.1.5"}
-  markdown-clj/markdown-clj {:mvn/version "1.11.7"}
+  markdown-clj/markdown-clj {:mvn/version "1.12.1"}
 
   ;; Pretty Print specs
   pretty-spec/pretty-spec {:mvn/version "0.1.4"}
-  software.amazon.awssdk/s3 {:mvn/version "2.22.12"}
+  software.amazon.awssdk/s3 {:mvn/version "2.25.63"}
   }
 
  :paths ["src" "resources" "target/classes"]
@@ -74,16 +74,13 @@
 
   :build
   {:extra-deps
-   {io.github.clojure/tools.build {:git/tag "v0.9.5" :git/sha "24f2894"}}
+   {io.github.clojure/tools.build {:git/tag "v0.10.3" :git/sha "15ead66"}}
    :ns-default build}
 
   :test
-  {:extra-paths ["test"]
-   :extra-deps
-   {io.github.cognitect-labs/test-runner
-    {:git/tag "v0.5.1" :git/sha "dfb30dd"}}
-   :main-opts ["-m" "cognitect.test-runner"]
-   :exec-fn cognitect.test-runner.api/test}
+  {:main-opts ["-m" "kaocha.runner"]
+   :jvm-opts ["-Dlog4j2.configurationFile=log4j2-devenv-repl.xml"]
+   :extra-deps {lambdaisland/kaocha {:mvn/version "1.91.1392"}}}
 
   :outdated
   {:extra-deps {com.github.liquidz/antq {:mvn/version "RELEASE"}}

backend/package.json

@@ -4,19 +4,19 @@
   "license": "MPL-2.0",
   "author": "Kaleidos INC",
   "private": true,
-  "packageManager": "yarn@4.0.2",
+  "packageManager": "yarn@4.2.2",
   "repository": {
     "type": "git",
     "url": "https://github.com/penpot/penpot"
   },
   "dependencies": {
-    "luxon": "^3.4.2",
-    "sax": "^1.2.4"
+    "luxon": "^3.4.4",
+    "sax": "^1.4.1"
   },
   "devDependencies": {
-    "nodemon": "^3.0.1",
+    "nodemon": "^3.1.2",
     "source-map-support": "^0.5.21",
-    "ws": "^8.13.0"
+    "ws": "^8.17.0"
   },
   "scripts": {
     "fmt:clj:check": "cljfmt check --parallel=false src/ test/",

backend/resources/app/email/change-email/en.html

@@ -168,7 +168,7 @@
                 <table border="0" cellpadding="0" cellspacing="0" role="presentation" style="vertical-align:top;" width="100%">
                   <tr>
                     <td align="left" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:24px;font-weight:600;line-height:150%;text-align:left;color:#000000;">Hello {{name}}!</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:24px;font-weight:600;line-height:150%;text-align:left;color:#000000;">Hello {{name|abbreviate:25}}!</div>
                     </td>
                   </tr>
                   <tr>
@@ -475,4 +475,4 @@
   </div>
 </body>
 
-</html>
+</html>

backend/resources/app/email/change-email/en.txt

@@ -1,4 +1,4 @@
-Hello {{name}}!
+Hello {{name|abbreviate:25}}!
 
 We received a request to change your current email to {{ pending-email }}.
 

backend/resources/app/email/feedback/en.html

@@ -11,7 +11,7 @@
       {% if profile %}
         <span>
           <span>Name: </span>
-          <span><code>{{profile.fullname}}</code></span>
+          <span><code>{{profile.fullname|abbreviate:25}}</code></span>
         </span>
         <br />
 
@@ -34,7 +34,7 @@
     </p>
     <p>
       <strong>Subject:</strong><br />
-      <span>{{subject}}</span>
+      <span>{{subject|abbreviate:300}}</span>
     </p>
 
     <p>

backend/resources/app/email/invite-to-team/en.html

@@ -173,7 +173,7 @@
                   </tr>
                   <tr>
                     <td align="left" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:16px;line-height:150%;text-align:left;color:#000000;">{{invited-by}} has invited you to join the team “{{ team }}”.</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:16px;line-height:150%;text-align:left;color:#000000;">{{invited-by|abbreviate:25}} has invited you to join the team “{{ team|abbreviate:25 }}”.</div>
                     </td>
                   </tr>
                   <tr>
@@ -465,4 +465,4 @@
   </div>
 </body>
 
-</html>
+</html>

backend/resources/app/email/invite-to-team/en.txt

@@ -1,6 +1,6 @@
 Hello!
 
-{{invited-by}} has invited you to join the team “{{ team }}”.
+{{invited-by|abbreviate:25}} has invited you to join the team “{{ team|abbreviate:25 }}”.
 
 Accept invitation using this link:
 

backend/resources/app/email/password-recovery/en.html

@@ -168,7 +168,7 @@
                 <table border="0" cellpadding="0" cellspacing="0" role="presentation" style="vertical-align:top;" width="100%">
                   <tr>
                     <td align="left" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:24px;font-weight:600;line-height:150%;text-align:left;color:#000000;">Hello {{name}}!</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:24px;font-weight:600;line-height:150%;text-align:left;color:#000000;">Hello {{name|abbreviate:25}}!</div>
                     </td>
                   </tr>
                   <tr>
@@ -470,4 +470,4 @@
   </div>
 </body>
 
-</html>
+</html>

backend/resources/app/email/password-recovery/en.txt

@@ -1,4 +1,4 @@
-Hello {{name}}!
+Hello {{name|abbreviate:25}}!
 
 We received a request to reset your password. Click the link below to choose a
 new one:

backend/resources/app/email/register/en.html

@@ -168,7 +168,7 @@
                 <table border="0" cellpadding="0" cellspacing="0" role="presentation" style="vertical-align:top;" width="100%">
                   <tr>
                     <td align="left" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:24px;font-weight:600;line-height:150%;text-align:left;color:#000000;">Hello {{name}}!</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:24px;font-weight:600;line-height:150%;text-align:left;color:#000000;">Hello {{name|abbreviate:25}}!</div>
                     </td>
                   </tr>
                   <tr>

backend/resources/app/email/register/en.txt

@@ -1,4 +1,4 @@
-Hello {{name}}!
+Hello {{name|abbreviate:25}}!
 
 Thanks for signing up for your Penpot account! Please verify your email using the
 link below and get started building mockups and prototypes today!

backend/resources/app/onboarding.edn

@@ -1,4 +1,16 @@
-[{:id "tutorial-for-beginners"
+[{:id "wireframing-kit"
+  :name "Wireframe library"
+  :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/wireframing-kit.penpot"}
+ {:id "prototype-examples"
+  :name "Prototipe template"
+  :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/prototype-examples.penpot"}
+ {:id "plants-app"
+  :name "UI mockup example"
+  :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/Plants-app.penpot"}
+ {:id "penpot-design-system"
+  :name "Design system example"
+  :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/Penpot-Design-system.penpot"}
+ {:id "tutorial-for-beginners"
   :name "Tutorial for beginners"
   :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/tutorial-for-beginners.penpot"}
  {:id "lucide-icons"
@@ -7,12 +19,6 @@
  {:id "font-awesome"
   :name "Font Awesome"
   :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/Font-Awesome.penpot"}
- {:id "plants-app"
-  :name "Plants app"
-  :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/Plants-app.penpot"}
- {:id "wireframing-kit"
-  :name "Wireframing Kit"
-  :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/wireframing-kit.penpot"}
  {:id "black-white-mobile-templates"
   :name "Black & White Mobile Templates"
   :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/Black-White-Mobile-Templates.penpot"}

backend/src/app/auth.clj

@@ -6,9 +6,7 @@
 
 (ns app.auth
   (:require
-   [app.config :as cf]
-   [buddy.hashers :as hashers]
-   [cuerdas.core :as str]))
+   [buddy.hashers :as hashers]))
 
 (def default-params
   {:alg :argon2id
@@ -27,17 +25,3 @@
     (catch Throwable _
       {: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,7 +7,6 @@
 (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]
@@ -17,13 +16,17 @@
    [app.common.uri :as u]
    [app.config :as cf]
    [app.db :as db]
+   [app.email.blacklist :as email.blacklist]
+   [app.email.whitelist :as email.whitelist]
    [app.http.client :as http]
+   [app.http.errors :as errors]
    [app.http.session :as session]
    [app.loggers.audit :as audit]
-   [app.main :as-alias main]
+   [app.rpc :as rpc]
    [app.rpc.commands.profile :as profile]
    [app.setup :as-alias setup]
    [app.tokens :as tokens]
+   [app.util.inet :as inet]
    [app.util.json :as json]
    [app.util.time :as dt]
    [buddy.sign.jwk :as jwk]
@@ -32,6 +35,7 @@
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [integrant.core :as ig]
+   [ring.request :as rreq]
    [ring.response :as-alias rres]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -129,8 +133,8 @@
           (-> 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)
+                    :response-status status
+                    :response-body  body)
             nil)))
       (catch Throwable cause
         (l/warn :hint "unable to retrieve JWKs (unexpected exception)"
@@ -144,18 +148,18 @@
   (when (contains? cf/flags :login-with-oidc)
     (if-let [opts (prepare-oidc-opts cfg)]
       (let [jwks (fetch-oidc-jwks cfg opts)]
-        (l/info :hint "provider initialized"
-                :provider "oidc"
-                :method (if (:discover? opts) "discover" "manual")
-                :client-id (:client-id opts)
-                :client-secret (obfuscate-string (:client-secret opts))
-                :scopes     (str/join "," (:scopes opts))
-                :auth-uri   (:auth-uri opts)
-                :user-uri   (:user-uri opts)
-                :token-uri  (:token-uri opts)
-                :roles-attr (:roles-attr opts)
-                :roles      (:roles opts)
-                :keys       (str/join "," (map str (keys jwks))))
+        (l/inf :hint "provider initialized"
+               :provider "oidc"
+               :method (if (:discover? opts) "discover" "manual")
+               :client-id (:client-id opts)
+               :client-secret (obfuscate-string (:client-secret opts))
+               :scopes     (str/join "," (:scopes opts))
+               :auth-uri   (:auth-uri opts)
+               :user-uri   (:user-uri opts)
+               :token-uri  (:token-uri opts)
+               :roles-attr (:roles-attr 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")
@@ -179,10 +183,10 @@
       (if (and (string? (:client-id opts))
                (string? (:client-secret opts)))
         (do
-          (l/info :hint "provider initialized"
-                  :provider "google"
-                  :client-id (:client-id opts)
-                  :client-secret (obfuscate-string (:client-secret opts)))
+          (l/inf :hint "provider initialized"
+                 :provider "google"
+                 :client-id (:client-id opts)
+                 :client-secret (obfuscate-string (:client-secret opts)))
           opts)
 
         (do
@@ -207,8 +211,9 @@
           (ex/raise :type :internal
                     :code :unable-to-retrieve-github-emails
                     :hint "unable to retrieve github emails"
-                    :http-status status
-                    :http-body body))
+                    :request-uri (:uri params)
+                    :response-status status
+                    :response-body body))
 
         (->> body json/decode (filter :primary) first :email))))
 
@@ -233,10 +238,10 @@
       (if (and (string? (:client-id opts))
                (string? (:client-secret opts)))
         (do
-          (l/info :hint "provider initialized"
-                  :provider "github"
-                  :client-id (:client-id opts)
-                  :client-secret (obfuscate-string (:client-secret opts)))
+          (l/inf :hint "provider initialized"
+                 :provider "github"
+                 :client-id (:client-id opts)
+                 :client-secret (obfuscate-string (:client-secret opts)))
           opts)
 
         (do
@@ -248,7 +253,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defmethod ig/init-key ::providers/gitlab
-  [_ _]
+  [_ cfg]
   (let [base (cf/get :gitlab-base-uri "https://gitlab.com")
         opts {:base-uri      base
               :client-id     (cf/get :gitlab-client-id)
@@ -257,17 +262,18 @@
               :auth-uri      (str base "/oauth/authorize")
               :token-uri     (str base "/oauth/token")
               :user-uri      (str base "/oauth/userinfo")
+              :jwks-uri      (str base "/oauth/discovery/keys")
               :name          "gitlab"}]
     (when (contains? cf/flags :login-with-gitlab)
       (if (and (string? (:client-id opts))
                (string? (:client-secret opts)))
-        (do
-          (l/info :hint "provider initialized"
-                  :provider "gitlab"
-                  :base-uri base
-                  :client-id (:client-id opts)
-                  :client-secret (obfuscate-string (:client-secret opts)))
-          opts)
+        (let [jwks (fetch-oidc-jwks cfg opts)]
+          (l/inf :hint "provider initialized"
+                 :provider "gitlab"
+                 :base-uri base
+                 :client-id (:client-id opts)
+                 :client-secret (obfuscate-string (:client-secret opts)))
+          (assoc opts :jwks jwks))
 
         (do
           (l/warn :hint "unable to initialize auth provider, missing configuration" :provider "gitlab")
@@ -283,12 +289,12 @@
     (into [(keyword (:name provider) fitem)] (map keyword) items)))
 
 (defn- build-redirect-uri
-  [{:keys [provider] :as cfg}]
+  [{:keys [::provider] :as cfg}]
   (let [public (u/uri (cf/get :public-uri))]
     (str (assoc public :path (str "/api/auth/oauth/" (:name provider) "/callback")))))
 
 (defn- build-auth-uri
-  [{:keys [provider] :as cfg} state]
+  [{:keys [::provider] :as cfg} state]
   (let [params {:client_id (:client-id provider)
                 :redirect_uri (build-redirect-uri cfg)
                 :response_type "code"
@@ -299,15 +305,19 @@
         (assoc :query query)
         (str))))
 
+(defn- qualify-prop-key
+  [provider k]
+  (keyword (:name provider) (name k)))
+
 (defn- qualify-props
   [provider props]
   (reduce-kv (fn [result k v]
-               (assoc result (keyword (:name provider) (name k)) v))
+               (assoc result (qualify-prop-key provider k) v))
              {}
              props))
 
-(defn fetch-access-token
-  [{:keys [provider] :as cfg} code]
+(defn- fetch-access-token
+  [{:keys [::provider] :as cfg} code]
   (let [params {:client_id (:client-id provider)
                 :client_secret (:client-secret provider)
                 :code code
@@ -319,26 +329,31 @@
                 :uri (:token-uri provider)
                 :body (u/map->query-string params)}]
 
-    (l/trace :hint "request access token"
-             :provider (:name provider)
-             :client-id (:client-id provider)
-             :client-secret (obfuscate-string (:client-secret provider))
-             :grant-type (:grant_type params)
-             :redirect-uri (:redirect_uri params))
+    (l/trc :hint "fetch access token"
+           :provider (:name provider)
+           :client-id (:client-id provider)
+           :client-secret (obfuscate-string (:client-secret provider))
+           :grant-type (:grant_type params)
+           :redirect-uri (:redirect_uri params))
 
     (let [{:keys [status body]} (http/req! cfg req {:sync? true})]
-      (l/trace :hint "access token response" :status status :body body)
+      (l/trc :hint "access token fetched" :status status :body body)
       (if (= status 200)
-        (let [data (json/decode body)]
-          {:token/access (get data :access_token)
-           :token/id     (get data :id_token)
-           :token/type   (get data :token_type)})
-
+        (let [data (json/decode body)
+              data {:token/access (get data :access_token)
+                    :token/id     (get data :id_token)
+                    :token/type   (get data :token_type)}]
+          (l/trc :hint "access token fetched"
+                 :token-id (:token/id data)
+                 :token-type (:token/type data)
+                 :token (:token/access data))
+          data)
         (ex/raise :type :internal
-                  :code :unable-to-retrieve-token
-                  :hint "unable to retrieve token"
-                  :http-status status
-                  :http-body body)))))
+                  :code :unable-to-fetch-access-token
+                  :hint "unable to fetch access token"
+                  :request-uri (:uri req)
+                  :response-status status
+                  :response-body body)))))
 
 (defn- process-user-info
   [provider tdata info]
@@ -364,10 +379,10 @@
        :props    props})))
 
 (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)))
+  [{:keys [::provider] :as cfg} tdata]
+  (l/trc :hint "fetch user info"
+         :uri (:user-uri provider)
+         :token (obfuscate-string (:token/access tdata)))
 
   (let [params   {:uri (:user-uri provider)
                   :headers {"Authorization" (str (:token/type tdata) " " (:token/access tdata))}
@@ -375,9 +390,9 @@
                   :method :get}
         response (http/req! cfg params {:sync? true})]
 
-    (l/trace :hint "user info response"
-             :status (:status response)
-             :body   (:body response))
+    (l/trc :hint "user info response"
+           :status (:status response)
+           :body   (:body response))
 
     (when-not (s/int-in-range? 200 300 (:status response))
       (ex/raise :type :internal
@@ -389,7 +404,7 @@
     (-> response :body json/decode)))
 
 (defn- get-user-info
-  [{:keys [provider]} tdata]
+  [{:keys [::provider]} tdata]
   (try
     (when (:token/id tdata)
       (let [{:keys [kid alg] :as theader} (jwt/decode-header (:token/id tdata))]
@@ -413,14 +428,8 @@
                    ::fullname
                    ::props]))
 
-(defn get-info
-  [{:keys [provider ::setup/props] :as cfg} {:keys [params] :as request}]
-  (when-let [error (get params :error)]
-    (ex/raise :type :internal
-              :code :error-on-retrieving-code
-              :error-id error
-              :error-desc (get params :error_description)))
-
+(defn- get-info
+  [{:keys [::provider ::setup/props] :as cfg} {:keys [params] :as request}]
   (let [state  (get params :state)
         code   (get params :code)
         state  (tokens/verify props {:token state :iss :oauth})
@@ -433,7 +442,7 @@
 
         info   (process-user-info provider tdata info)]
 
-    (l/trace :hint "user info" :info info)
+    (l/trc :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)
@@ -466,111 +475,173 @@
       (some? (:invitation-token state))
       (assoc :invitation-token (:invitation-token state))
 
+      (some? (:external-session-id state))
+      (assoc :external-session-id (:external-session-id state))
+
       ;; If state token comes with props, merge them. The state token
       ;; props can contain pm_ and utm_ prefixed query params.
       (map? (:props state))
       (update :props merge (:props state)))))
 
 (defn- get-profile
-  [{:keys [::db/pool] :as cfg} info]
-  (dm/with-open [conn (db/open pool)]
-    (some->> (:email info)
-             (profile/clean-email)
-             (profile/get-profile-by-email conn))))
+  [cfg info]
+  (db/run! cfg (fn [{:keys [::db/conn]}]
+                 (some->> (:email info)
+                          (profile/clean-email)
+                          (profile/get-profile-by-email conn)))))
 
 (defn- redirect-response
   [uri]
   {::rres/status 302
    ::rres/headers {"location" (str uri)}})
 
-(defn- generate-error-redirect
-  [_ 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)))
+(defn- redirect-with-error
+  ([error] (redirect-with-error error nil))
+  ([error hint]
+   (let [params {:error error :hint hint}
+         params (d/without-nils params)
+         uri    (-> (u/uri (cf/get :public-uri))
+                    (assoc :path "/#/auth/login")
+                    (assoc :query (u/map->query-string params)))]
+     (redirect-response uri))))
 
-        params {:error "unable-to-auth"
-                :hint hint
-                :type type
-                :code code}
+(defn- redirect-to-register
+  [cfg info request]
+  (let [info   (assoc info
+                      :iss :prepared-register
+                      :exp (dt/in-future {:hours 48}))
 
+        params {:token (tokens/generate (::setup/props cfg) info)
+                :provider (:provider (:path-params request))
+                :fullname (:fullname info)}
+        params (d/without-nils params)]
+
+    (redirect-response
+     (-> (u/uri (cf/get :public-uri))
+         (assoc :path "/#/auth/register/validate")
+         (assoc :query (u/map->query-string params))))))
+
+(defn- redirect-to-verify-token
+  [token]
+  (let [params {:token token}
         uri    (-> (u/uri (cf/get :public-uri))
-                   (assoc :path "/#/auth/login")
+                   (assoc :path "/#/auth/verify-token")
                    (assoc :query (u/map->query-string params)))]
 
     (redirect-response uri)))
 
-(defn- generate-redirect
+(defn- provider-has-email-verified?
+  [{:keys [::provider] :as cfg} {:keys [props] :as info}]
+  (let [prop (qualify-prop-key provider :email_verified)]
+    (true? (get props prop))))
+
+(defn- profile-has-provider-props?
+  [{:keys [::provider] :as cfg} profile]
+  (let [prop (qualify-prop-key provider :email)]
+    (contains? (:props profile) prop)))
+
+(defn- provider-matches-profile?
+  [{:keys [::provider] :as cfg} profile info]
+  (or (= (:auth-backend profile) (:name provider))
+      (profile-has-provider-props? cfg profile)
+      (provider-has-email-verified? cfg info)))
+
+(defn- process-callback
   [cfg request info profile]
-  (if profile
-    (let [sxf    (session/create-fn cfg (:id profile))
-          token  (or (:invitation-token info)
-                     (tokens/generate (::setup/props cfg)
-                                      {:iss :auth
-                                       :exp (dt/in-future "15m")
-                                       :profile-id (:id profile)}))
-          params {:token token}
-          uri    (-> (u/uri (cf/get :public-uri))
-                     (assoc :path "/#/auth/verify-token")
-                     (assoc :query (u/map->query-string params)))]
+  (cond
+    (some? profile)
+    (cond
+      (:is-blocked profile)
+      (redirect-with-error "profile-blocked")
 
-      (when (:is-blocked profile)
-        (ex/raise :type :restriction
-                  :code :profile-blocked))
+      (not (provider-matches-profile? cfg profile info))
+      (redirect-with-error "auth-provider-not-allowed")
 
-      (audit/submit! cfg {::audit/type "command"
-                          ::audit/name "login-with-oidc"
-                          ::audit/profile-id (:id profile)
-                          ::audit/ip-addr (audit/parse-client-ip request)
-                          ::audit/props (audit/profile->props profile)})
+      (not (:is-active profile))
+      (let [info (assoc info :profile-id (:id profile))]
+        (redirect-to-register cfg info request))
 
-      (->> (redirect-response uri)
-           (sxf request)))
+      :else
+      (let [sxf     (session/create-fn cfg (:id profile))
+            token   (or (:invitation-token info)
+                        (tokens/generate (::setup/props cfg)
+                                         {:iss :auth
+                                          :exp (dt/in-future "15m")
+                                          :props (:props info)
+                                          :profile-id (:id profile)}))
+            props   (audit/profile->props profile)
+            context (d/without-nils {:external-session-id (:external-session-id info)})]
 
+        (audit/submit! cfg {::audit/type "action"
+                            ::audit/name "login-with-oidc"
+                            ::audit/profile-id (:id profile)
+                            ::audit/ip-addr (inet/parse-request request)
+                            ::audit/props props
+                            ::audit/context context})
 
-    (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 (::setup/props cfg) info)
-            params (d/without-nils
-                    {:token token
-                     :provider (:provider (:path-params request))
-                     :fullname (:fullname info)})
-            uri    (-> (u/uri (cf/get :public-uri))
-                       (assoc :path "/#/auth/register/validate")
-                       (assoc :query (u/map->query-string params)))]
+        (->> (redirect-to-verify-token token)
+             (sxf request))))
 
-        (redirect-response uri))
-      (generate-error-redirect cfg "email-domain-not-allowed"))))
+    (and (email.blacklist/enabled? cfg)
+         (email.blacklist/contains? cfg (:email info)))
+    (redirect-with-error "email-domain-not-allowed")
 
+    (and (email.whitelist/enabled? cfg)
+         (not (email.whitelist/contains? cfg (:email info))))
+    (redirect-with-error "email-domain-not-allowed")
+
+    :else
+    (let [info (assoc info :is-active (provider-has-email-verified? cfg info))]
+      (if (or (contains? cf/flags :registration)
+              (contains? cf/flags :oidc-registration))
+        (redirect-to-register cfg info request)
+        (redirect-with-error "registration-disabled")))))
+
+(defn- get-external-session-id
+  [request]
+  (let [session-id (rreq/get-header request "x-external-session-id")]
+    (when (string? session-id)
+      (if (or (> (count session-id) 256)
+              (= session-id "null")
+              (str/blank? session-id))
+        nil
+        session-id))))
 
 (defn- auth-handler
   [cfg {:keys [params] :as request}]
-  (let [props (audit/extract-utm-params params)
-        state (tokens/generate (::setup/props cfg)
-                               {:iss :oauth
-                                :invitation-token (:invitation-token params)
-                                :props props
-                                :exp (dt/in-future "4h")})
-        uri   (build-auth-uri cfg state)]
+  (let [props  (audit/extract-utm-params params)
+        esid   (rpc/get-external-session-id request)
+        params {:iss :oauth
+                :invitation-token (:invitation-token params)
+                :external-session-id esid
+                :props props
+                :exp (dt/in-future "4h")}
+        state  (tokens/generate (::setup/props cfg)
+                                (d/without-nils params))
+        uri    (build-auth-uri cfg state)]
     {::rres/status 200
      ::rres/body {:redirect-uri uri}}))
 
 (defn- callback-handler
-  [cfg request]
+  [{:keys [::provider] :as cfg} request]
   (try
-    (let [info    (get-info cfg request)
-          profile (get-profile cfg info)]
-      (generate-redirect cfg request info profile))
+    (if-let [error (dm/get-in request [:params :error])]
+      (redirect-with-error "unable-to-auth" error)
+      (let [info    (get-info cfg request)
+            profile (get-profile cfg info)]
+        (process-callback cfg request info profile)))
     (catch Throwable cause
-      (l/warn :hint "error on oauth process" :cause cause)
-      (generate-error-redirect cfg cause))))
+      (binding [l/*context* (-> (errors/request->context request)
+                                (assoc :auth/provider (:name provider)))]
+        (let [edata (ex-data cause)]
+          (cond
+            (= :validation (:type edata))
+            (l/wrn :hint "invalid token received" :cause cause)
+
+            :else
+            (l/err :hint "error on oauth process" :cause cause))))
+
+      (redirect-with-error "unable-to-auth" (ex-message cause)))))
 
 (def provider-lookup
   {:compile
@@ -579,13 +650,12 @@
        (fn [request]
          (let [provider (some-> request :path-params :provider keyword)]
            (if-let [provider (get providers provider)]
-             (handler (assoc cfg :provider provider) request)
+             (handler (assoc cfg ::provider provider) request)
              (ex/raise :type :restriction
                        :code :provider-not-configured
                        :provider provider
                        :hint "provider not configured"))))))})
 
-
 (s/def ::client-id ::cf/oidc-client-id)
 (s/def ::client-secret ::cf/oidc-client-secret)
 (s/def ::base-uri ::cf/oidc-base-uri)
@@ -598,7 +668,6 @@
 (s/def ::email-attr ::cf/oidc-email-attr)
 (s/def ::name-attr ::cf/oidc-name-attr)
 
-;; FIXME: migrate to qualified-keywords
 (s/def ::provider
   (s/keys :req-un [::client-id
                    ::client-secret]

backend/src/app/binfile/common.clj

@@ -15,6 +15,7 @@
    [app.common.files.migrations :as fmg]
    [app.common.files.validate :as fval]
    [app.common.logging :as l]
+   [app.common.types.file :as ctf]
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
@@ -331,54 +332,12 @@
 
 (defn embed-assets
   [cfg data file-id]
-  (letfn [(walk-map-form [form state]
-            (cond
-              (uuid? (:fill-color-ref-file form))
-              (do
-                (vswap! state conj [(:fill-color-ref-file form) :colors (:fill-color-ref-id form)])
-                (assoc form :fill-color-ref-file file-id))
-
-              (uuid? (:stroke-color-ref-file form))
-              (do
-                (vswap! state conj [(:stroke-color-ref-file form) :colors (:stroke-color-ref-id form)])
-                (assoc form :stroke-color-ref-file file-id))
-
-              (uuid? (:typography-ref-file form))
-              (do
-                (vswap! state conj [(:typography-ref-file form) :typographies (:typography-ref-id form)])
-                (assoc form :typography-ref-file file-id))
-
-              (uuid? (:component-file form))
-              (do
-                (vswap! state conj [(:component-file form) :components (:component-id form)])
-                (assoc form :component-file file-id))
-
-              :else
-              form))
-
-          (process-group-of-assets [data [lib-id items]]
-            ;; 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 (get-file cfg lib-id)]
-              (reduce (partial process-asset lib) data items)
-              data))
-
-          (process-asset [lib data [bucket asset-id]]
-            (let [asset (get-in lib [:data bucket asset-id])
-                  ;; Add a special case for colors that need to have
-                  ;; correctly set the :file-id prop (pending of the
-                  ;; refactor that will remove it).
-                  asset (cond-> asset
-                          (= bucket :colors) (assoc :file-id file-id))]
-              (update data bucket assoc asset-id asset)))]
-
-    (let [assets (volatile! [])]
-      (walk/postwalk #(cond-> % (map? %) (walk-map-form assets)) data)
-      (->> (deref assets)
-           (filter #(as-> (first %) $ (and (uuid? $) (not= $ file-id))))
-           (d/group-by first rest)
-           (reduce (partial process-group-of-assets) data)))))
+  (let [library-ids (get-libraries cfg [file-id])]
+    (reduce (fn [data library-id]
+              (let [library (get-file cfg library-id)]
+                (ctf/absorb-assets data (:data library))))
+            data
+            library-ids)))
 
 (defn- fix-version
   [file]

backend/src/app/binfile/v1.clj

@@ -130,7 +130,6 @@
   (.writeLong output (long data))
   (swap! *position* + 8))
 
-
 (defn read-long!
   [^DataInputStream input]
   (let [v (.readLong input)]

backend/src/app/config.clj

@@ -87,7 +87,10 @@
    :ldap-attrs-fullname "cn"
 
    ;; a server prop key where initial project is stored.
-   :initial-project-skey "initial-project"})
+   :initial-project-skey "initial-project"
+
+   ;; time to avoid email sending after profile modification
+   :email-verify-threshold "15m"})
 
 (s/def ::default-rpc-rlimit ::us/vector-of-strings)
 (s/def ::rpc-rlimit-config ::fs/path)
@@ -101,6 +104,9 @@
 (s/def ::audit-log-archive-uri ::us/string)
 (s/def ::audit-log-http-handler-concurrency ::us/integer)
 
+(s/def ::email-domain-blacklist ::fs/path)
+(s/def ::email-domain-whitelist ::fs/path)
+
 (s/def ::deletion-delay ::dt/duration)
 
 (s/def ::admins ::us/set-of-valid-emails)
@@ -210,6 +216,7 @@
 (s/def ::telemetry-uri ::us/string)
 (s/def ::telemetry-with-taiga ::us/boolean)
 (s/def ::tenant ::us/string)
+(s/def ::email-verify-threshold ::dt/duration)
 
 (s/def ::config
   (s/keys :opt-un [::secret-key
@@ -230,6 +237,8 @@
                    ::database-max-pool-size
                    ::default-blob-version
                    ::default-rpc-rlimit
+                   ::email-domain-blacklist
+                   ::email-domain-whitelist
                    ::error-report-webhook
                    ::default-executor-parallelism
                    ::scheduled-executor-parallelism
@@ -329,7 +338,8 @@
                    ::telemetry-uri
                    ::telemetry-referer
                    ::telemetry-with-taiga
-                   ::tenant]))
+                   ::tenant
+                   ::email-verify-threshold]))
 
 (def default-flags
   [:enable-backend-api-doc

backend/src/app/email.clj

@@ -262,13 +262,12 @@
   (let [email (if factory
                 (factory context)
                 (dissoc context ::conn))]
-    (wrk/submit! (merge
-                  {::wrk/task :sendmail
-                   ::wrk/delay 0
-                   ::wrk/max-retries 4
-                   ::wrk/priority 200
-                   ::wrk/conn conn}
-                  email))))
+    (wrk/submit! {::wrk/task :sendmail
+                  ::wrk/delay 0
+                  ::wrk/max-retries 4
+                  ::wrk/priority 200
+                  ::db/conn conn
+                  ::wrk/params email})))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; SENDMAIL FN / TASK HANDLER
@@ -307,6 +306,8 @@
       (let [session (create-smtp-session cfg)]
         (with-open [transport (.getTransport session (if (::ssl cfg) "smtps" "smtp"))]
           (.connect ^Transport transport
+                    ^String (::host cfg)
+                    ^String (::port cfg)
                     ^String (::username cfg)
                     ^String (::password cfg))
 
@@ -449,3 +450,11 @@
                                             {:email email :type "bounce"}
                                             {:limit 10}))]
      (>= (count reports) threshold))))
+
+(defn has-reports?
+  ([conn email] (has-reports? conn email nil))
+  ([conn email {:keys [threshold] :or {threshold 1}}]
+   (let [reports (db/exec! conn (sql/select :global-complaint-report
+                                            {:email email}
+                                            {:limit 10}))]
+     (>= (count reports) threshold))))

backend/src/app/email/blacklist.clj

@@ -0,0 +1,47 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC
+
+(ns app.email.blacklist
+  "Email blacklist provider"
+  (:refer-clojure :exclude [contains?])
+  (:require
+   [app.common.logging :as l]
+   [app.config :as cf]
+   [app.email :as-alias email]
+   [clojure.core :as c]
+   [clojure.java.io :as io]
+   [cuerdas.core :as str]
+   [integrant.core :as ig]))
+
+(defmethod ig/init-key ::email/blacklist
+  [_ _]
+  (when (c/contains? cf/flags :email-blacklist)
+    (try
+      (let [path   (cf/get :email-domain-blacklist)
+            result (with-open [reader (io/reader path)]
+                     (reduce (fn [result line]
+                               (if (str/starts-with? line "#")
+                                 result
+                                 (conj result (-> line str/trim str/lower))))
+                             #{}
+                             (line-seq reader)))]
+        (l/inf :hint "initializing email blacklist" :domains (count result))
+        (not-empty result))
+
+      (catch Throwable cause
+        (l/wrn :hint "unexpected exception on initializing email blacklist"
+               :cause cause)))))
+
+(defn contains?
+  "Check if email is in the blacklist."
+  [{:keys [::email/blacklist]} email]
+  (let [[_ domain] (str/split email "@" 2)]
+    (c/contains? blacklist (str/lower domain))))
+
+(defn enabled?
+  "Check if the blacklist is enabled"
+  [{:keys [::email/blacklist]}]
+  (some? blacklist))

backend/src/app/email/whitelist.clj

@@ -0,0 +1,59 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC
+
+(ns app.email.whitelist
+  "Email whitelist provider"
+  (:refer-clojure :exclude [contains?])
+  (:require
+   [app.common.logging :as l]
+   [app.config :as cf]
+   [app.email :as-alias email]
+   [clojure.core :as c]
+   [clojure.java.io :as io]
+   [cuerdas.core :as str]
+   [datoteka.fs :as fs]
+   [integrant.core :as ig]))
+
+(defn- read-whitelist
+  [path]
+  (when (and path (fs/exists? path))
+    (try
+      (with-open [reader (io/reader path)]
+        (reduce (fn [result line]
+                  (if (str/starts-with? line "#")
+                    result
+                    (conj result (-> line str/trim str/lower))))
+                #{}
+                (line-seq reader)))
+
+      (catch Throwable cause
+        (l/wrn :hint "unexpected exception on reading email whitelist"
+               :cause cause)))))
+
+(defmethod ig/init-key ::email/whitelist
+  [_ _]
+  (let [whitelist (or (cf/get :registration-domain-whitelist) #{})
+        whitelist (if (c/contains? cf/flags :email-whitelist)
+                    (into whitelist (read-whitelist (cf/get :email-domain-whitelist)))
+                    whitelist)
+        whitelist (not-empty whitelist)]
+
+
+    (when whitelist
+      (l/inf :hint "initializing email whitelist" :domains (count whitelist)))
+
+    whitelist))
+
+(defn contains?
+  "Check if email is in the whitelist."
+  [{:keys [::email/whitelist]} email]
+  (let [[_ domain] (str/split email "@" 2)]
+    (c/contains? whitelist (str/lower domain))))
+
+(defn enabled?
+  "Check if the whitelist is enabled"
+  [{:keys [::email/whitelist]}]
+  (some? whitelist))

backend/src/app/features/components_v2.clj

@@ -12,7 +12,6 @@
    [app.common.files.changes :as cp]
    [app.common.files.changes-builder :as fcb]
    [app.common.files.helpers :as cfh]
-   [app.common.files.libraries-helpers :as cflh]
    [app.common.files.migrations :as fmg]
    [app.common.files.shapes-helpers :as cfsh]
    [app.common.files.validate :as cfv]
@@ -23,6 +22,7 @@
    [app.common.geom.shapes :as gsh]
    [app.common.geom.shapes.path :as gshp]
    [app.common.logging :as l]
+   [app.common.logic.libraries :as cll]
    [app.common.math :as mth]
    [app.common.schema :as sm]
    [app.common.svg :as csvg]
@@ -1450,16 +1450,15 @@
                 page
                 (cons shape children))
 
-        [_ _ changes2]
-        (cflh/generate-add-component nil
-                                     [shape]
-                                     (:objects page)
-                                     (:id page)
-                                     file-id
-                                     true
-                                     nil
-                                     cfsh/prepare-create-artboard-from-selection)
-        changes (fcb/concat-changes changes changes2)]
+        [_ _ changes]
+        (cll/generate-add-component changes
+                                    [shape]
+                                    (:objects page)
+                                    (:id page)
+                                    file-id
+                                    true
+                                    nil
+                                    cfsh/prepare-create-artboard-from-selection)]
 
     (shape-cb shape)
     (:redo-changes changes)))

backend/src/app/http.clj

@@ -114,7 +114,7 @@
               (partial not-found-handler request)))
 
           (on-error [cause request]
-            (let [{:keys [body] :as response} (errors/handle cause request)]
+            (let [{:keys [::rres/body] :as response} (errors/handle cause request)]
               (cond-> response
                 (map? body)
                 (-> (update ::rres/headers assoc "content-type" "application/transit+json")
@@ -151,9 +151,9 @@
                       [mw/params]
                       [mw/format-response]
                       [mw/parse-request]
+                      [mw/errors errors/handle]
                       [session/soft-auth cfg]
                       [actoken/soft-auth cfg]
-                      [mw/errors errors/handle]
                       [mw/restrict-methods]]}
 
      (::mtx/routes cfg)

backend/src/app/http/awsns.clj

@@ -9,6 +9,7 @@
   (:require
    [app.common.exceptions :as ex]
    [app.common.logging :as l]
+   [app.common.pprint :as pp]
    [app.db :as db]
    [app.db.sql :as sql]
    [app.http.client :as http]
@@ -16,10 +17,10 @@
    [app.setup :as-alias setup]
    [app.tokens :as tokens]
    [app.worker :as-alias wrk]
+   [clojure.data.json :as j]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [integrant.core :as ig]
-   [jsonista.core :as j]
    [promesa.exec :as px]
    [ring.request :as rreq]
    [ring.response :as-alias rres]))
@@ -136,83 +137,110 @@
 
 (defn- parse-json
   [v]
-  (ex/ignoring
-   (j/read-value v)))
+  (try
+    (j/read-str v)
+    (catch Throwable cause
+      (l/wrn :hint "unable to decode request body"
+             :cause cause))))
 
 (defn- register-bounce-for-profile
   [{:keys [::db/pool]} {:keys [type kind profile-id] :as report}]
   (when (= kind "permanent")
-    (db/with-atomic [conn pool]
-      (db/insert! conn :profile-complaint-report
+    (try
+      (db/insert! pool :profile-complaint-report
                   {:profile-id profile-id
                    :type (name type)
                    :content (db/tjson report)})
 
-      ;; TODO: maybe also try to find profiles by mail and if exists
-      ;; register profile reports for them?
-      (doseq [recipient (:recipients report)]
-        (db/insert! conn :global-complaint-report
-                    {:email (:email recipient)
-                     :type (name type)
-                     :content (db/tjson report)}))
+      (catch Throwable cause
+        (l/warn :hint "unable to persist profile complaint"
+                :cause cause)))
 
-      (let [profile (db/exec-one! conn (sql/select :profile {:id profile-id}))]
-        (when (some #(= (:email profile) (:email %)) (:recipients report))
-          ;; If the report matches the profile email, this means that
-          ;; the report is for itself, can be caused when a user
-          ;; registers with an invalid email or the user email is
-          ;; permanently rejecting receiving the email. In this case we
-          ;; have no option to mark the user as muted (and in this case
-          ;; the profile will be also inactive.
-          (db/update! conn :profile
-                      {:is-muted true}
-                      {:id profile-id}))))))
-
-(defn- register-complaint-for-profile
-  [{:keys [::db/pool]} {:keys [type profile-id] :as report}]
-  (db/with-atomic [conn pool]
-    (db/insert! conn :profile-complaint-report
-                {:profile-id profile-id
-                 :type (name type)
-                 :content (db/tjson report)})
-
-    ;; TODO: maybe also try to find profiles by email and if exists
-    ;; register profile reports for them?
-    (doseq [email (:recipients report)]
-      (db/insert! conn :global-complaint-report
-                  {:email email
+    (doseq [recipient (:recipients report)]
+      (db/insert! pool :global-complaint-report
+                  {:email (:email recipient)
                    :type (name type)
                    :content (db/tjson report)}))
 
-    (let [profile (db/exec-one! conn (sql/select :profile {:id profile-id}))]
-      (when (some #(= % (:email profile)) (:recipients report))
+    (let [profile (db/exec-one! pool (sql/select :profile {:id profile-id}))]
+      (when (some #(= (:email profile) (:email %)) (:recipients report))
         ;; If the report matches the profile email, this means that
-        ;; the report is for itself, rare case but can happen; In this
-        ;; case just mark profile as muted (very rare case).
-        (db/update! conn :profile
+        ;; the report is for itself, can be caused when a user
+        ;; registers with an invalid email or the user email is
+        ;; permanently rejecting receiving the email. In this case we
+        ;; have no option to mark the user as muted (and in this case
+        ;; the profile will be also inactive.
+
+        (l/inf :hint "mark profile: muted"
+               :profile-id (str (:id profile))
+               :email (:email profile)
+               :reason "bounce report"
+               :report-id (:feedback-id report))
+
+        (db/update! pool :profile
                     {:is-muted true}
-                    {:id profile-id})))))
+                    {:id profile-id}
+                    {::db/return-keys false})))))
+
+(defn- register-complaint-for-profile
+  [{:keys [::db/pool]} {:keys [type profile-id] :as report}]
+
+  (try
+    (db/insert! pool :profile-complaint-report
+                {:profile-id profile-id
+                 :type (name type)
+                 :content (db/tjson report)})
+    (catch Throwable cause
+      (l/warn :hint "unable to persist profile complaint"
+              :cause cause)))
+
+  ;; TODO: maybe also try to find profiles by email and if exists
+  ;; register profile reports for them?
+  (doseq [email (:recipients report)]
+    (db/insert! pool :global-complaint-report
+                {:email email
+                 :type (name type)
+                 :content (db/tjson report)}))
+
+  (let [profile (db/exec-one! pool (sql/select :profile {:id profile-id}))]
+    (when (some #(= % (:email profile)) (:recipients report))
+      ;; If the report matches the profile email, this means that
+      ;; the report is for itself, rare case but can happen; In this
+      ;; case just mark profile as muted (very rare case).
+      (l/inf :hint "mark profile: muted"
+             :profile-id (str (:id profile))
+             :email (:email profile)
+             :reason "complaint report"
+             :report-id (:feedback-id report))
+
+      (db/update! pool :profile
+                  {:is-muted true}
+                  {:id profile-id}
+                  {::db/return-keys false}))))
 
 (defn- process-report
   [cfg {:keys [type profile-id] :as report}]
-  (l/trace :action "processing report" :report (pr-str report))
   (cond
     ;; In this case we receive a bounce/complaint notification without
     ;; confirmed identity, we just emit a warning but do nothing about
     ;; it because this is not a normal case. All notifications should
     ;; come with profile identity.
     (nil? profile-id)
-    (l/warn :msg "a notification without identity received from AWS"
-            :report (pr-str report))
+    (l/wrn :hint "not-identified report"
+           ::l/body (pp/pprint-str report {:length 40 :level 6}))
 
     (= "bounce" type)
-    (register-bounce-for-profile cfg report)
+    (do
+      (l/trc :hint "bounce report"
+             ::l/body (pp/pprint-str report {:length 40 :level 6}))
+      (register-bounce-for-profile cfg report))
 
     (= "complaint" type)
-    (register-complaint-for-profile cfg report)
+    (do
+      (l/trc :hint "complaint report"
+             ::l/body (pp/pprint-str report {:length 40 :level 6}))
+      (register-complaint-for-profile cfg report))
 
     :else
-    (l/warn :msg "unrecognized report received from AWS"
-            :report (pr-str report))))
-
-
+    (l/wrn :hint "unrecognized report"
+           ::l/body (pp/pprint-str report {:length 20 :level 4}))))

backend/src/app/http/debug.clj

@@ -16,7 +16,6 @@
    [app.config :as cf]
    [app.db :as db]
    [app.http.session :as session]
-   [app.main :as-alias main]
    [app.rpc.commands.auth :as auth]
    [app.rpc.commands.files-create :refer [create-file]]
    [app.rpc.commands.profile :as profile]
@@ -341,57 +340,57 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defn- resend-email-notification
-  [{:keys [::db/pool ::setup/props] :as cfg} {:keys [params] :as request}]
+  [cfg {:keys [params] :as request}]
+  (db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
+                    (when-not (contains? params :force)
+                      (ex/raise :type :validation
+                                :code :missing-force
+                                :hint "missing force checkbox"))
 
-  (when-not (contains? params :force)
-    (ex/raise :type :validation
-              :code :missing-force
-              :hint "missing force checkbox"))
+                    (let [profile (some->> params
+                                           :email
+                                           (profile/clean-email)
+                                           (profile/get-profile-by-email conn))]
 
-  (let [profile (some->> params
-                         :email
-                         (profile/clean-email)
-                         (profile/get-profile-by-email pool))]
+                      (when-not profile
+                        (ex/raise :type :validation
+                                  :code :missing-profile
+                                  :hint "unable to find profile by email"))
 
-    (when-not profile
-      (ex/raise :type :validation
-                :code :missing-profile
-                :hint "unable to find profile by email"))
+                      (cond
+                        (contains? params :block)
+                        (do
+                          (db/update! conn :profile {:is-blocked true} {:id (:id profile)})
+                          (db/delete! conn :http-session {:profile-id (:id profile)})
 
-    (cond
-      (contains? params :block)
-      (do
-        (db/update! pool :profile {:is-blocked true} {:id (:id profile)})
-        (db/delete! pool :http-session {:profile-id (:id profile)})
+                          {::rres/status  200
+                           ::rres/headers {"content-type" "text/plain"}
+                           ::rres/body    (str/ffmt "PROFILE '%' BLOCKED" (:email profile))})
 
-        {::rres/status  200
-         ::rres/headers {"content-type" "text/plain"}
-         ::rres/body    (str/ffmt "PROFILE '%' BLOCKED" (:email profile))})
+                        (contains? params :unblock)
+                        (do
+                          (db/update! conn :profile {:is-blocked false} {:id (:id profile)})
+                          {::rres/status  200
+                           ::rres/headers {"content-type" "text/plain"}
+                           ::rres/body    (str/ffmt "PROFILE '%' UNBLOCKED" (:email profile))})
 
-      (contains? params :unblock)
-      (do
-        (db/update! pool :profile {:is-blocked false} {:id (:id profile)})
-        {::rres/status  200
-         ::rres/headers {"content-type" "text/plain"}
-         ::rres/body    (str/ffmt "PROFILE '%' UNBLOCKED" (:email profile))})
+                        (contains? params :resend)
+                        (if (:is-blocked profile)
+                          {::rres/status  200
+                           ::rres/headers {"content-type" "text/plain"}
+                           ::rres/body    "PROFILE ALREADY BLOCKED"}
+                          (do
+                            (#'auth/send-email-verification! cfg profile)
+                            {::rres/status  200
+                             ::rres/headers {"content-type" "text/plain"}
+                             ::rres/body    (str/ffmt "RESENDED FOR '%'" (:email profile))}))
 
-      (contains? params :resend)
-      (if (:is-blocked profile)
-        {::rres/status  200
-         ::rres/headers {"content-type" "text/plain"}
-         ::rres/body    "PROFILE ALREADY BLOCKED"}
-        (do
-          (auth/send-email-verification! pool props profile)
-          {::rres/status  200
-           ::rres/headers {"content-type" "text/plain"}
-           ::rres/body    (str/ffmt "RESENDED FOR '%'" (:email profile))}))
-
-      :else
-      (do
-        (db/update! pool :profile {:is-active true} {:id (:id profile)})
-        {::rres/status  200
-         ::rres/headers {"content-type" "text/plain"}
-         ::rres/body    (str/ffmt "PROFILE '%' ACTIVATED" (:email profile))}))))
+                        :else
+                        (do
+                          (db/update! conn :profile {:is-active true} {:id (:id profile)})
+                          {::rres/status  200
+                           ::rres/headers {"content-type" "text/plain"}
+                           ::rres/body    (str/ffmt "PROFILE '%' ACTIVATED" (:email profile))}))))))
 
 
 (defn- reset-file-version

backend/src/app/http/errors.clj

@@ -14,32 +14,28 @@
    [app.http :as-alias http]
    [app.http.access-token :as-alias actoken]
    [app.http.session :as-alias session]
+   [app.util.inet :as inet]
    [clojure.spec.alpha :as s]
-   [cuerdas.core :as str]
    [ring.request :as rreq]
    [ring.response :as rres]))
 
-(defn- parse-client-ip
-  [request]
-  (or (some-> (rreq/get-header request "x-forwarded-for") (str/split ",") first)
-      (rreq/get-header request "x-real-ip")
-      (rreq/remote-addr request)))
-
 (defn request->context
   "Extracts error report relevant context data from request."
   [request]
   (let [claims (-> {}
                    (into (::session/token-claims request))
                    (into (::actoken/token-claims request)))]
+
     {:request/path       (:path request)
      :request/method     (:method request)
      :request/params     (:params request)
      :request/user-agent (rreq/get-header request "user-agent")
-     :request/ip-addr    (parse-client-ip request)
+     :request/ip-addr    (inet/parse-request request)
      :request/profile-id (:uid claims)
      :version/frontend   (or (rreq/get-header request "x-frontend-version") "unknown")
      :version/backend    (:full cf/version)}))
 
+
 (defmulti handle-error
   (fn [cause _ _]
     (-> cause ex-data :type)))

backend/src/app/http/middleware.clj

@@ -10,16 +10,14 @@
    [app.common.logging :as l]
    [app.common.transit :as t]
    [app.config :as cf]
-   [app.util.json :as json]
+   [app.http.errors :as errors]
+   [clojure.data.json :as json]
    [cuerdas.core :as str]
    [ring.request :as rreq]
    [ring.response :as rres]
    [yetti.adapter :as yt]
    [yetti.middleware :as ymw])
   (:import
-   com.fasterxml.jackson.core.JsonParseException
-   com.fasterxml.jackson.core.io.JsonEOFException
-   com.fasterxml.jackson.databind.exc.MismatchedInputException
    io.undertow.server.RequestTooBigException
    java.io.InputStream
    java.io.OutputStream))
@@ -34,11 +32,22 @@
   {:name ::params
    :compile (constantly ymw/wrap-params)})
 
-(def ^:private json-mapper
-  (json/mapper
-   {:encode-key-fn str/camel
-    :decode-key-fn (comp keyword str/kebab)
-    :pretty true}))
+(defn- get-reader
+  ^java.io.BufferedReader
+  [request]
+  (let [^InputStream body (rreq/body request)]
+    (java.io.BufferedReader.
+     (java.io.InputStreamReader. body))))
+
+(defn- read-json-key
+  [k]
+  (-> k str/kebab keyword))
+
+(defn- write-json-key
+  [k]
+  (if (or (keyword? k) (symbol? k))
+    (str/camel k)
+    (str k)))
 
 (defn wrap-parse-request
   [handler]
@@ -53,8 +62,8 @@
                         (update :params merge params))))
 
                 (str/starts-with? header "application/json")
-                (with-open [^InputStream is (rreq/body request)]
-                  (let [params (json/decode is json-mapper)]
+                (with-open [reader (get-reader request)]
+                  (let [params (json/read reader :key-fn read-json-key)]
                     (-> request
                         (assoc :body-params params)
                         (update :params merge params))))
@@ -62,35 +71,33 @@
                 :else
                 request)))
 
-          (handle-error [cause]
+          (handle-error [cause request]
             (cond
               (instance? RuntimeException cause)
               (if-let [cause (ex-cause cause)]
-                (handle-error cause)
-                (throw cause))
+                (handle-error cause request)
+                (errors/handle cause request))
 
               (instance? RequestTooBigException cause)
               (ex/raise :type :validation
                         :code :request-body-too-large
                         :hint (ex-message cause))
 
-              (or (instance? JsonEOFException cause)
-                  (instance? JsonParseException cause)
-                  (instance? MismatchedInputException cause))
+              (instance? java.io.EOFException cause)
               (ex/raise :type :validation
                         :code :malformed-json
                         :hint (ex-message cause)
                         :cause cause)
 
               :else
-              (throw cause)))]
+              (errors/handle cause request)))]
 
     (fn [request]
       (if (= (rreq/method request) :post)
-        (let [request (ex/try! (process-request request))]
-          (if (ex/exception? request)
-            (handle-error request)
-            (handler request)))
+        (try
+          (-> request process-request handler)
+          (catch Throwable cause
+            (handle-error cause request)))
         (handler request)))))
 
 (def parse-request
@@ -128,7 +135,8 @@
               (-write-body-to-stream [_ _ output-stream]
                 (try
                   (with-open [^OutputStream bos (buffered-output-stream output-stream buffer-size)]
-                    (json/write! bos data json-mapper))
+                    (with-open [^java.io.OutputStreamWriter writer (java.io.OutputStreamWriter. bos)]
+                      (json/write data writer :key-fn write-json-key)))
 
                   (catch java.io.IOException _)
                   (catch Throwable cause

backend/src/app/http/sse.clj

@@ -61,6 +61,8 @@
                            (let [result (handler)]
                              (events/tap :end result))
                            (catch Throwable cause
+                             (l/err :hint "unexpected error on processing sse response"
+                                    :cause cause)
                              (events/tap :error (errors/handle' cause request)))
                            (finally
                              (sp/close! events/*channel*)

backend/src/app/loggers/audit.clj

@@ -21,24 +21,18 @@
    [app.rpc :as-alias rpc]
    [app.rpc.retry :as rtry]
    [app.setup :as-alias setup]
+   [app.util.inet :as inet]
    [app.util.services :as-alias sv]
    [app.util.time :as dt]
    [app.worker :as wrk]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
-   [integrant.core :as ig]
-   [ring.request :as rreq]))
+   [integrant.core :as ig]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; HELPERS
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defn parse-client-ip
-  [request]
-  (or (some-> (rreq/get-header request "x-forwarded-for") (str/split ",") first)
-      (rreq/get-header request "x-real-ip")
-      (some-> (rreq/remote-addr request) str)))
-
 (defn extract-utm-params
   "Extracts additional data from params and namespace them under
   `penpot` ns."
@@ -53,8 +47,7 @@
                 (assoc (->> sk str/kebab (keyword "penpot")) v))))]
     (reduce-kv process-param {} params)))
 
-(def ^:private
-  profile-props
+(def profile-props
   [:id
    :is-active
    :is-muted
@@ -87,8 +80,19 @@
          (remove #(contains? reserved-props (key %))))
         props))
 
-;; --- SPECS
+(defn event-from-rpc-params
+  "Create a base event skeleton with pre-filled some important
+  data that can be extracted from RPC params object"
+  [params]
+  (let [context {:external-session-id (::rpc/external-session-id params)
+                 :external-event-origin (::rpc/external-event-origin params)
+                 :triggered-by (::rpc/handler-name params)}]
+    {::type "action"
+     ::profile-id (::rpc/profile-id params)
+     ::ip-addr (::rpc/ip-addr params)
+     ::context (d/without-nils context)}))
 
+;; --- SPECS
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; COLLECTOR
@@ -141,24 +145,31 @@
                        (::rpc/profile-id params)
                        uuid/zero)
 
-        props      (-> (or (::replace-props resultm)
-                           (-> params
-                               (merge (::props resultm))
-                               (dissoc :profile-id)
-                               (dissoc :type)))
+        session-id   (get params ::rpc/external-session-id)
+        event-origin (get params ::rpc/external-event-origin)
+        props        (-> (or (::replace-props resultm)
+                             (-> params
+                                 (merge (::props resultm))
+                                 (dissoc :profile-id)
+                                 (dissoc :type)))
 
-                       (clean-props))
+                         (clean-props))
 
         token-id  (::actoken/id request)
-        context   (d/without-nils
-                   {:access-token-id (some-> token-id str)})]
+        context   (-> (::context resultm)
+                      (assoc :external-session-id session-id)
+                      (assoc :external-event-origin event-origin)
+                      (assoc :access-token-id (some-> token-id str))
+                      (d/without-nils))
+
+        ip-addr   (inet/parse-request request)]
 
     {::type (or (::type resultm)
                 (::rpc/type cfg))
      ::name (or (::name resultm)
                 (::sv/name mdata))
      ::profile-id profile-id
-     ::ip-addr (some-> request parse-client-ip)
+     ::ip-addr ip-addr
      ::props props
      ::context context
 
@@ -180,15 +191,33 @@
          (::webhooks/event? resultm)
          false)}))
 
-(defn- handle-event!
-  [cfg event]
+(defn- event->params
+  [event]
   (let [params {:id (uuid/next)
                 :name (::name event)
                 :type (::type event)
                 :profile-id (::profile-id event)
                 :ip-addr (::ip-addr event)
-                :context (::context event)
-                :props (::props event)}
+                :context (::context event {})
+                :props (::props event {})
+                :source "backend"}
+        tnow   (::tracked-at event)]
+
+    (cond-> params
+      (some? tnow)
+      (assoc :tracked-at tnow))))
+
+(defn- append-audit-entry!
+  [cfg params]
+  (let [params (-> params
+                   (update :props db/tjson)
+                   (update :context db/tjson)
+                   (update :ip-addr db/inet))]
+    (db/insert! cfg :audit-log params)))
+
+(defn- handle-event!
+  [cfg event]
+  (let [params (event->params event)
         tnow   (dt/now)]
 
     (when (contains? cf/flags :audit-log)
@@ -197,12 +226,8 @@
       ;; this case we just retry the operation.
       (let [params (-> params
                        (assoc :created-at tnow)
-                       (assoc :tracked-at tnow)
-                       (update :props db/tjson)
-                       (update :context db/tjson)
-                       (update :ip-addr db/inet)
-                       (assoc :source "backend"))]
-        (db/insert! cfg :audit-log params)))
+                       (update :tracked-at #(or % tnow)))]
+        (append-audit-entry! cfg params)))
 
     (when (and (or (contains? cf/flags :telemetry)
                    (cf/get :telemetry-enabled))
@@ -214,12 +239,10 @@
       ;; NOTE: this is only executed when general audit log is disabled
       (let [params (-> params
                        (assoc :created-at tnow)
-                       (assoc :tracked-at tnow)
-                       (assoc :props (db/tjson {}))
-                       (assoc :context (db/tjson {}))
-                       (assoc :ip-addr (db/inet "0.0.0.0"))
-                       (assoc :source "backend"))]
-        (db/insert! cfg :audit-log params)))
+                       (update :tracked-at #(or % tnow))
+                       (assoc :props {})
+                       (assoc :context {}))]
+        (append-audit-entry! cfg params)))
 
     (when (and (contains? cf/flags :webhooks)
                (::webhooks/event? event))
@@ -232,25 +255,23 @@
                             :else               label)
             dedupe?       (boolean (and batch-key batch-timeout))]
 
-        (wrk/submit! ::wrk/conn (::db/conn cfg)
-                     ::wrk/task :process-webhook-event
-                     ::wrk/queue :webhooks
-                     ::wrk/max-retries 0
-                     ::wrk/delay (or batch-timeout 0)
-                     ::wrk/dedupe dedupe?
-                     ::wrk/label label
-
-                     ::webhooks/event
-                     (-> params
-                         (dissoc :ip-addr)
-                         (dissoc :type)))))
+        (wrk/submit! (-> cfg
+                         (assoc ::wrk/task :process-webhook-event)
+                         (assoc ::wrk/queue :webhooks)
+                         (assoc ::wrk/max-retries 0)
+                         (assoc ::wrk/delay (or batch-timeout 0))
+                         (assoc ::wrk/dedupe dedupe?)
+                         (assoc ::wrk/label label)
+                         (assoc ::wrk/params (-> params
+                                                 (dissoc :ip-addr)
+                                                 (dissoc :type)))))))
     params))
 
 (defn submit!
   "Submit audit event to the collector."
-  [cfg params]
+  [cfg event]
   (try
-    (let [event (d/without-nils params)
+    (let [event (d/without-nils event)
           cfg   (-> cfg
                     (assoc ::rtry/when rtry/conflict-exception?)
                     (assoc ::rtry/max-retries 6)
@@ -259,3 +280,18 @@
       (rtry/invoke! cfg db/tx-run! handle-event! event))
     (catch Throwable cause
       (l/error :hint "unexpected error processing event" :cause cause))))
+
+(defn insert!
+  "Submit audit event to the collector, intended to be used only from
+  command line helpers because this skips all webhooks and telemetry
+  logic."
+  [cfg event]
+  (when (contains? cf/flags :audit-log)
+    (let [event (d/without-nils event)]
+      (us/verify! ::event event)
+      (db/run! cfg (fn [cfg]
+                     (let [tnow   (dt/now)
+                           params (-> (event->params event)
+                                      (assoc :created-at tnow)
+                                      (update :tracked-at #(or % tnow)))]
+                       (append-audit-entry! cfg params)))))))

backend/src/app/loggers/webhooks.clj

@@ -64,22 +64,22 @@
   (s/keys :req [::db/pool]))
 
 (defmethod ig/init-key ::process-event-handler
-  [_ {:keys [::db/pool] :as cfg}]
+  [_ cfg]
   (fn [{:keys [props] :as task}]
-    (let [event (::event props)]
+    (let [event (:event props)]
       (l/dbg :hint "process webhook event" :name (:name event))
 
       (when-let [items (lookup-webhooks cfg event)]
         (l/trc :hint "webhooks found for event" :total (count items))
 
-        (db/with-atomic [conn pool]
-          (doseq [item items]
-            (wrk/submit! ::wrk/conn conn
-                         ::wrk/task :run-webhook
-                         ::wrk/queue :webhooks
-                         ::wrk/max-retries 3
-                         ::event event
-                         ::config item)))))))
+        (db/tx-run! cfg (fn [cfg]
+                          (doseq [item items]
+                            (wrk/submit! (-> cfg
+                                             (assoc ::wrk/task :run-webhook)
+                                             (assoc ::wrk/queue :webhooks)
+                                             (assoc ::wrk/max-retries 3)
+                                             (assoc ::wrk/params {:event event
+                                                                  :config item}))))))))))
 
 ;; --- RUN
 
@@ -128,8 +128,8 @@
                          :rsp-data (db/tjson rsp)}))]
 
     (fn [{:keys [props] :as task}]
-      (let [event (::event props)
-            whook (::config props)
+      (let [event (:event props)
+            whook (:config props)
 
             body  (case (:mtype whook)
                     "application/json" (json/write-str event json-write-opts)

backend/src/app/main.clj

@@ -102,13 +102,13 @@
    {::mdef/name "penpot_tasks_timing"
     ::mdef/help "Background tasks timing (milliseconds)."
     ::mdef/labels ["name"]
-    ::mdef/type :summary}
+    ::mdef/type :histogram}
 
    :redis-eval-timing
    {::mdef/name "penpot_redis_eval_timing"
     ::mdef/help "Redis EVAL commands execution timings (ms)"
     ::mdef/labels ["name"]
-    ::mdef/type :summary}
+    ::mdef/type :histogram}
 
    :rpc-climit-queue
    {::mdef/name "penpot_rpc_climit_queue"
@@ -126,7 +126,7 @@
    {::mdef/name "penpot_rpc_climit_timing"
     ::mdef/help "Summary of the time between queuing and executing on the CLIMIT"
     ::mdef/labels ["name"]
-    ::mdef/type :summary}
+    ::mdef/type :histogram}
 
    :audit-http-handler-queue-size
    {::mdef/name "penpot_audit_http_handler_queue_size"
@@ -144,7 +144,7 @@
    {::mdef/name "penpot_audit_http_handler_timing"
     ::mdef/help "Summary of the time between queuing and executing on the audit log http handler"
     ::mdef/labels []
-    ::mdef/type :summary}
+    ::mdef/type :histogram}
 
    :executors-active-threads
    {::mdef/name "penpot_executors_active_threads"
@@ -254,7 +254,7 @@
    {::http.client/client (ig/ref ::http.client/client)}
 
    ::oidc.providers/gitlab
-   {}
+   {::http.client/client (ig/ref ::http.client/client)}
 
    ::oidc.providers/generic
    {::http.client/client (ig/ref ::http.client/client)}
@@ -267,7 +267,9 @@
                           :github (ig/ref ::oidc.providers/github)
                           :gitlab (ig/ref ::oidc.providers/gitlab)
                           :oidc   (ig/ref ::oidc.providers/generic)}
-    ::session/manager    (ig/ref ::session/manager)}
+    ::session/manager    (ig/ref ::session/manager)
+    ::email/blacklist    (ig/ref ::email/blacklist)
+    ::email/whitelist    (ig/ref ::email/whitelist)}
 
    :app.http/router
    {::session/manager    (ig/ref ::session/manager)
@@ -322,7 +324,10 @@
     ::rpc/climit         (ig/ref ::rpc/climit)
     ::rpc/rlimit         (ig/ref ::rpc/rlimit)
     ::setup/templates    (ig/ref ::setup/templates)
-    ::setup/props        (ig/ref ::setup/props)}
+    ::setup/props        (ig/ref ::setup/props)
+
+    ::email/blacklist    (ig/ref ::email/blacklist)
+    ::email/whitelist    (ig/ref ::email/whitelist)}
 
    :app.rpc.doc/routes
    {:methods (ig/ref :app.rpc/methods)}
@@ -338,7 +343,6 @@
     ::wrk/tasks
     {:sendmail           (ig/ref ::email/handler)
      :objects-gc         (ig/ref :app.tasks.objects-gc/handler)
-     :orphan-teams-gc    (ig/ref :app.tasks.orphan-teams-gc/handler)
      :file-gc            (ig/ref :app.tasks.file-gc/handler)
      :file-xlog-gc       (ig/ref :app.tasks.file-xlog-gc/handler)
      :tasks-gc           (ig/ref :app.tasks.tasks-gc/handler)
@@ -349,13 +353,19 @@
      :audit-log-archive  (ig/ref :app.loggers.audit.archive-task/handler)
      :audit-log-gc       (ig/ref :app.loggers.audit.gc-task/handler)
 
-     :object-update
-     (ig/ref :app.tasks.object-update/handler)
+     :delete-object
+     (ig/ref :app.tasks.delete-object/handler)
      :process-webhook-event
      (ig/ref ::webhooks/process-event-handler)
      :run-webhook
      (ig/ref ::webhooks/run-webhook-handler)}}
 
+   ::email/blacklist
+   {}
+
+   ::email/whitelist
+   {}
+
    ::email/sendmail
    {::email/host             (cf/get :smtp-host)
     ::email/port             (cf/get :smtp-port)
@@ -377,10 +387,7 @@
    {::db/pool     (ig/ref ::db/pool)
     ::sto/storage (ig/ref ::sto/storage)}
 
-   :app.tasks.orphan-teams-gc/handler
-   {::db/pool (ig/ref ::db/pool)}
-
-   :app.tasks.object-update/handler
+   :app.tasks.delete-object/handler
    {::db/pool (ig/ref ::db/pool)}
 
    :app.tasks.file-gc/handler
@@ -468,9 +475,6 @@
      {:cron #app/cron "0 0 0 * * ?" ;; daily
       :task :objects-gc}
 
-     {:cron #app/cron "0 0 0 * * ?" ;; daily
-      :task :orphan-teams-gc}
-
      {:cron #app/cron "0 0 0 * * ?" ;; daily
       :task :storage-gc-deleted}
 

backend/src/app/rpc.clj

@@ -29,6 +29,7 @@
    [app.rpc.rlimit :as rlimit]
    [app.setup :as-alias setup]
    [app.storage :as-alias sto]
+   [app.util.inet :as inet]
    [app.util.services :as sv]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
@@ -70,6 +71,22 @@
         (handle-response-transformation request mdata)
         (handle-before-comple-hook mdata))))
 
+(defn get-external-session-id
+  [request]
+  (when-let [session-id (rreq/get-header request "x-external-session-id")]
+    (when-not (or (> (count session-id) 256)
+                  (= session-id "null")
+                  (str/blank? session-id))
+      session-id)))
+
+(defn- get-external-event-origin
+  [request]
+  (when-let [origin (rreq/get-header request "x-event-origin")]
+    (when-not (or (> (count origin) 256)
+                  (= origin "null")
+                  (str/blank? origin))
+      origin)))
+
 (defn- rpc-handler
   "Ring handler that dispatches cmd requests and convert between
   internal async flow into ring async flow."
@@ -79,8 +96,16 @@
         profile-id   (or (::session/profile-id request)
                          (::actoken/profile-id request))
 
+        ip-addr      (inet/parse-request request)
+        session-id   (get-external-session-id request)
+        event-origin (get-external-event-origin request)
+
         data         (-> params
+                         (assoc ::handler-name handler-name)
+                         (assoc ::ip-addr ip-addr)
                          (assoc ::request-at (dt/now))
+                         (assoc ::external-session-id session-id)
+                         (assoc ::external-event-origin event-origin)
                          (assoc ::session/id (::session/id request))
                          (assoc ::cond/key etag)
                          (cond-> (uuid? profile-id)
@@ -188,10 +213,10 @@
 (defn- wrap-all
   [cfg f mdata]
   (as-> f $
-    (wrap-metrics cfg $ mdata)
     (cond/wrap cfg $ mdata)
     (retry/wrap-retry cfg $ mdata)
     (climit/wrap cfg $ mdata)
+    (wrap-metrics cfg $ mdata)
     (rlimit/wrap cfg $ mdata)
     (wrap-audit cfg $ mdata)
     (wrap-spec-conform cfg $ mdata)

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

@@ -14,11 +14,12 @@
    [app.config :as cf]
    [app.db :as db]
    [app.http :as-alias http]
-   [app.loggers.audit :as audit]
+   [app.loggers.audit :as-alias audit]
    [app.rpc :as-alias rpc]
    [app.rpc.climit :as-alias climit]
    [app.rpc.doc :as-alias doc]
    [app.rpc.helpers :as rph]
+   [app.util.inet :as inet]
    [app.util.services :as sv]
    [app.util.time :as dt]))
 
@@ -61,7 +62,7 @@
 (defn- handle-events
   [{:keys [::db/pool]} {:keys [::rpc/profile-id events] :as params}]
   (let [request (-> params meta ::http/request)
-        ip-addr (audit/parse-client-ip request)
+        ip-addr (inet/parse-request request)
         tnow    (dt/now)
         xform   (comp
                  (map (fn [event]

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

@@ -6,7 +6,6 @@
 
 (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]
@@ -17,9 +16,10 @@
    [app.config :as cf]
    [app.db :as db]
    [app.email :as eml]
+   [app.email.blacklist :as email.blacklist]
+   [app.email.whitelist :as email.whitelist]
    [app.http.session :as session]
    [app.loggers.audit :as audit]
-   [app.main :as-alias main]
    [app.rpc :as-alias rpc]
    [app.rpc.climit :as-alias climit]
    [app.rpc.commands.profile :as profile]
@@ -38,6 +38,12 @@
 (def schema:token
   [::sm/word-string {:max 6000}])
 
+(defn- elapsed-verify-threshold?
+  [profile]
+  (let [elapsed (dt/diff (:modified-at profile) (dt/now))
+        verify-threshold (cf/get :email-verify-threshold)]
+    (pos? (compare elapsed verify-threshold))))
+
 ;; ---- COMMAND: login with password
 
 (defn login-with-password
@@ -122,12 +128,21 @@
 
 ;; ---- COMMAND: Logout
 
+(def ^:private schema:logout
+  [:map {:title "logoug"}
+   [:profile-id {:optional true} ::sm/uuid]])
+
 (sv/defmethod ::logout
   "Clears the authentication cookie and logout the current session."
   {::rpc/auth false
-   ::doc/added "1.15"}
-  [cfg _]
-  (rph/with-transform {} (session/delete-fn cfg)))
+   ::doc/changes [["2.1" "Now requires profile-id passed in the body"]]
+   ::doc/added "1.0"
+   ::sm/params schema:logout}
+  [cfg params]
+  (if (= (:profile-id params)
+         (::rpc/profile-id params))
+    (rph/with-transform {} (session/delete-fn cfg))
+    {}))
 
 ;; ---- COMMAND: Recover Profile
 
@@ -139,7 +154,7 @@
 
           (update-password [conn profile-id]
             (let [pwd (profile/derive-password cfg password)]
-              (db/update! conn :profile {:password pwd} {:id profile-id})
+              (db/update! conn :profile {:password pwd :is-active true} {:id profile-id})
               nil))]
 
     (db/with-atomic [conn pool]
@@ -162,8 +177,8 @@
 
 ;; ---- COMMAND: Prepare Register
 
-(defn validate-register-attempt!
-  [{:keys [::db/pool] :as cfg} params]
+(defn- validate-register-attempt!
+  [cfg params]
 
   (when-not (contains? cf/flags :registration)
     (when-not (contains? params :invitation-token)
@@ -171,37 +186,42 @@
                 :code :registration-disabled)))
 
   (when (contains? params :invitation-token)
-    (let [invitation (tokens/verify (::setup/props cfg) {:token (:invitation-token params) :iss :team-invitation})]
+    (let [invitation (tokens/verify (::setup/props cfg)
+                                    {:token (:invitation-token params)
+                                     :iss :team-invitation})]
       (when-not (= (:email params) (:member-email invitation))
         (ex/raise :type :restriction
                   :code :email-does-not-match-invitation
                   :hint "email should match the invitation"))))
 
-  (when-not (auth/email-domain-in-whitelist? (:email params))
-    (ex/raise :type :validation
+  (when (and (email.blacklist/enabled? cfg)
+             (email.blacklist/contains? cfg (:email params)))
+    (ex/raise :type :restriction
               :code :email-domain-is-not-allowed))
 
-  ;; Don't allow proceed in preparing registration if the profile is
-  ;; already reported as spammer.
-  (when (eml/has-bounce-reports? pool (:email params))
-    (ex/raise :type :validation
-              :code :email-has-permanent-bounces
-              :hint "looks like the email has one or many bounces reported"))
+  (when (and (email.whitelist/enabled? cfg)
+             (not (email.whitelist/contains? cfg (:email params))))
+    (ex/raise :type :restriction
+              :code :email-domain-is-not-allowed))
 
   ;; Perform a basic validation of email & password
   (when (= (str/lower (:email params))
            (str/lower (:password params)))
     (ex/raise :type :validation
               :code :email-as-password
-              :hint "you can't use your email as password")))
+              :hint "you can't use your email as password"))
 
-(def register-retry-threshold
-  (dt/duration "15m"))
+  (when (eml/has-bounce-reports? cfg (:email params))
+    (ex/raise :type :restriction
+              :code :email-has-permanent-bounces
+              :email (:email params)
+              :hint "looks like the email has bounce reports"))
 
-(defn- elapsed-register-retry-threshold?
-  [profile]
-  (let [elapsed (dt/diff (:modified-at profile) (dt/now))]
-    (pos? (compare elapsed register-retry-threshold))))
+  (when (eml/has-complaint-reports? cfg (:email params))
+    (ex/raise :type :restriction
+              :code :email-has-complaints
+              :email (:email params)
+              :hint "looks like the email has complaint reports")))
 
 (defn prepare-register
   [{:keys [::db/pool] :as cfg} {:keys [email] :as params}]
@@ -209,21 +229,7 @@
   (validate-register-attempt! cfg params)
 
   (let [email   (profile/clean-email email)
-        profile (when-let [profile (profile/get-profile-by-email pool email)]
-                  (cond
-                    (:is-blocked profile)
-                    (ex/raise :type :restriction
-                              :code :profile-blocked)
-
-                    (and (not (:is-active profile))
-                         (elapsed-register-retry-threshold? profile))
-                    profile
-
-                    :else
-                    (ex/raise :type :validation
-                              :code :email-already-exists
-                              :hint "profile already exists")))
-
+        profile (profile/get-profile-by-email pool email)
         params  {:email email
                  :password (:password params)
                  :invitation-token (:invitation-token params)
@@ -233,7 +239,6 @@
                  :exp (dt/in-future {:days 7})}
 
         params (d/without-nils params)
-
         token  (tokens/generate (::setup/props cfg) params)]
     (with-meta {:token token}
       {::audit/profile-id uuid/zero})))
@@ -293,14 +298,17 @@
     (try
       (-> (db/insert! conn :profile params)
           (profile/decode-row))
-      (catch org.postgresql.util.PSQLException e
-        (let [state (.getSQLState e)]
+      (catch org.postgresql.util.PSQLException cause
+        (let [state (.getSQLState cause)]
           (if (not= state "23505")
-            (throw e)
-            (ex/raise :type :validation
-                      :code :email-already-exists
-                      :hint "email already exists"
-                      :cause e)))))))
+            (throw cause)
+
+            (do
+              (l/error :hint "not an error" :cause cause)
+              (ex/raise :type :validation
+                        :code :email-already-exists
+                        :hint "email already exists"
+                        :cause cause))))))))
 
 (defn create-profile-rels!
   [conn {:keys [id] :as profile}]
@@ -317,17 +325,16 @@
                     {::db/return-keys true})
         (profile/decode-row))))
 
-
 (defn send-email-verification!
-  [conn props profile]
-  (let [vtoken (tokens/generate props
+  [{:keys [::db/conn] :as cfg} profile]
+  (let [vtoken (tokens/generate (::setup/props cfg)
                                 {:iss :verify-email
                                  :exp (dt/in-future "72h")
                                  :profile-id (:id profile)
                                  :email (:email profile)})
         ;; NOTE: this token is mainly used for possible complains
         ;; identification on the sns webhook
-        ptoken (tokens/generate props
+        ptoken (tokens/generate (::setup/props cfg)
                                 {:iss :profile-identity
                                  :profile-id (:id profile)
                                  :exp (dt/in-future {:days 30})})]
@@ -346,69 +353,99 @@
                        (into params)
                        (assoc :fullname fullname))
 
-        is-active  (or (:is-active params)
-                       (not (contains? cf/flags :email-verification)))
-
         profile    (if-let [profile-id (:profile-id claims)]
                      (profile/get-profile conn profile-id)
-                     (let [params (-> params
-                                      (assoc :is-active is-active)
-                                      (update :password #(profile/derive-password cfg %)))]
+                     (let [is-active (or (boolean (:is-active claims))
+                                         (not (contains? cf/flags :email-verification)))
+                           params    (-> params
+                                         (assoc :is-active is-active)
+                                         (update :password #(profile/derive-password cfg %)))]
                        (->> (create-profile! conn params)
                             (create-profile-rels! conn))))
 
-        invitation (when-let [token (:invitation-token params)]
-                     (tokens/verify (::setup/props cfg) {:token token :iss :team-invitation}))]
+        ;; When no profile-id comes on claims means a new register
+        created?   (not (:profile-id claims))
+
+        invitation (when-let [token (:invitation-token params)]
+                     (tokens/verify (::setup/props cfg) {:token token :iss :team-invitation}))
+
+        props      (audit/profile->props profile)]
 
-    ;; If profile is filled in claims, means it tries to register
-    ;; again, so we proceed to update the modified-at attr
-    ;; accordingly.
-    (when-let [id (:profile-id claims)]
-      (db/update! conn :profile {:modified-at (dt/now)} {:id id})
-      (audit/submit! cfg
-                     {::audit/type "fact"
-                      ::audit/name "register-profile-retry"
-                      ::audit/profile-id id}))
     (cond
-      ;; If invitation token comes in params, this is because the
-      ;; user comes from team-invitation process; in this case,
-      ;; regenerate token and send back to the user a new invitation
-      ;; token (and mark current session as logged). This happens
-      ;; only if the invitation email matches with the register
-      ;; email.
-      (and (some? invitation) (= (:email profile) (:member-email invitation)))
+      ;; When profile is blocked, we just ignore it and return plain data
+      (:is-blocked profile)
+      (do
+        (l/wrn :hint "register attempt for already blocked profile"
+               :profile-id (str  (:id profile))
+               :profile-email (:email profile))
+        (rph/with-meta {:email (:email profile)}
+          {::audit/replace-props props
+           ::audit/context {:action "ignore-because-blocked"}
+           ::audit/profile-id (:id profile)
+           ::audit/name "register-profile-retry"}))
+
+      ;; If invitation token comes in params, this is because the user
+      ;; comes from team-invitation process; in this case, regenerate
+      ;; token and send back to the user a new invitation token (and
+      ;; mark current session as logged). This happens only if the
+      ;; invitation email matches with the register email.
+      (and (some? invitation)
+           (= (:email profile)
+              (:member-email invitation)))
       (let [claims (assoc invitation :member-id  (:id profile))
-            token  (tokens/generate (::setup/props cfg) claims)
-            resp   {:invitation-token token}]
-        (-> resp
+            token  (tokens/generate (::setup/props cfg) claims)]
+        (-> {:invitation-token token}
             (rph/with-transform (session/create-fn cfg (:id profile)))
-            (rph/with-meta {::audit/replace-props (audit/profile->props profile)
+            (rph/with-meta {::audit/replace-props props
+                            ::audit/context {:action "accept-invitation"}
                             ::audit/profile-id (:id profile)})))
 
-      ;; If auth backend is different from "penpot" means user is
-      ;; registering using third party auth mechanism; in this case
-      ;; we need to mark this session as logged.
-      (not= "penpot" (:auth-backend profile))
-      (-> (profile/strip-private-attrs profile)
-          (rph/with-transform (session/create-fn cfg (:id profile)))
-          (rph/with-meta {::audit/replace-props (audit/profile->props profile)
-                          ::audit/profile-id (:id profile)}))
+      ;; When a new user is created and it is already activated by
+      ;; configuration or specified by OIDC, we just mark the profile
+      ;; as logged-in
+      created?
+      (if (:is-active profile)
+        (-> (profile/strip-private-attrs profile)
+            (rph/with-transform (session/create-fn cfg (:id profile)))
+            (rph/with-meta
+              {::audit/replace-props props
+               ::audit/context {:action "login"}
+               ::audit/profile-id (:id profile)}))
 
-      ;; If the `:enable-insecure-register` flag is set, we proceed
-      ;; to sign in the user directly, without email verification.
-      (true? is-active)
-      (-> (profile/strip-private-attrs profile)
-          (rph/with-transform (session/create-fn cfg (:id profile)))
-          (rph/with-meta {::audit/replace-props (audit/profile->props profile)
-                          ::audit/profile-id (:id profile)}))
+        (do
+          (when-not (eml/has-reports? conn (:email profile))
+            (send-email-verification! cfg profile))
+
+          (rph/with-meta {:email (:email profile)}
+            {::audit/replace-props props
+             ::audit/context {:action "email-verification"}
+             ::audit/profile-id (:id profile)})))
 
-      ;; In all other cases, send a verification email.
       :else
-      (do
-        (send-email-verification! conn (::setup/props cfg) profile)
-        (rph/with-meta profile
+      (let [elapsed?    (elapsed-verify-threshold? profile)
+            complaints? (eml/has-reports? conn (:email profile))
+            action      (if complaints?
+                          "ignore-because-complaints"
+                          (if elapsed?
+                            "resend-email-verification"
+                            "ignore"))]
+
+        (l/wrn :hint "repeated registry detected"
+               :profile-id (str (:id profile))
+               :profile-email (:email profile)
+               :context-action action)
+
+        (when (= action "resend-email-verification")
+          (db/update! conn :profile
+                      {:modified-at (dt/now)}
+                      {:id (:id profile)})
+          (send-email-verification! cfg profile))
+
+        (rph/with-meta {:email (:email profile)}
           {::audit/replace-props (audit/profile->props profile)
-           ::audit/profile-id (:id profile)})))))
+           ::audit/context {:action action}
+           ::audit/profile-id (:id profile)
+           ::audit/name "register-profile-retry"})))))
 
 (def schema:register-profile
   [:map {:title "register-profile"}
@@ -420,15 +457,13 @@
    ::doc/added "1.15"
    ::sm/params schema:register-profile
    ::climit/id :auth/global}
-  [{:keys [::db/pool] :as cfg} params]
-  (db/with-atomic [conn pool]
-    (-> (assoc cfg ::db/conn conn)
-        (register-profile params))))
+  [cfg params]
+  (db/tx-run! cfg register-profile params))
 
 ;; ---- COMMAND: Request Profile Recovery
 
-(defn request-profile-recovery
-  [{:keys [::db/pool] :as cfg} {:keys [email] :as params}]
+(defn- request-profile-recovery
+  [{:keys [::db/conn] :as cfg} {:keys [email] :as params}]
   (letfn [(create-recovery-token [{:keys [id] :as profile}]
             (let [token (tokens/generate (::setup/props cfg)
                                          {:iss :password-recovery
@@ -450,27 +485,42 @@
                           :extra-data ptoken})
               nil))]
 
-    (db/with-atomic [conn pool]
-      (when-let [profile (->> (profile/clean-email email)
-                              (profile/get-profile-by-email conn))]
-        (when-not (eml/allow-send-emails? conn profile)
-          (ex/raise :type :validation
-                    :code :profile-is-muted
-                    :hint "looks like the profile has reported repeatedly as spam or has permanent bounces."))
+    (let [profile (->> (profile/clean-email email)
+                       (profile/get-profile-by-email conn))]
 
-        (when-not (:is-active profile)
-          (ex/raise :type :validation
-                    :code :profile-not-verified
-                    :hint "the user need to validate profile before recover password"))
+      (cond
+        (not profile)
+        (l/wrn :hint "attempt of profile recovery: no profile found"
+               :profile-email email)
 
-        (when (eml/has-bounce-reports? conn (:email profile))
-          (ex/raise :type :validation
-                    :code :email-has-permanent-bounces
-                    :hint "looks like the email you invite has been repeatedly reported as spam or permanent bounce"))
+        (not (eml/allow-send-emails? conn profile))
+        (l/wrn :hint "attempt of profile recovery: profile is muted"
+               :profile-id (str (:id profile))
+               :profile-email (:email profile))
 
-        (->> profile
-             (create-recovery-token)
-             (send-email-notification conn))))))
+        (eml/has-bounce-reports? conn (:email profile))
+        (l/wrn :hint "attempt of profile recovery: email has bounces"
+               :profile-id (str (:id profile))
+               :profile-email (:email profile))
+
+        (eml/has-complaint-reports? conn (:email profile))
+        (l/wrn :hint "attempt of profile recovery: email has complaints"
+               :profile-id (str (:id profile))
+               :profile-email (:email profile))
+
+        (not (elapsed-verify-threshold? profile))
+        (l/wrn :hint "attempt of profile recovery: retry attempt threshold not elapsed"
+               :profile-id (str (:id profile))
+               :profile-email (:email profile))
+
+        :else
+        (do
+          (db/update! conn :profile
+                      {:modified-at (dt/now)}
+                      {:id (:id profile)})
+          (->> profile
+               (create-recovery-token)
+               (send-email-notification conn)))))))
 
 
 (def schema:request-profile-recovery
@@ -482,6 +532,6 @@
    ::doc/added "1.15"
    ::sm/params schema:request-profile-recovery}
   [cfg params]
-  (request-profile-recovery cfg params))
+  (db/tx-run! cfg request-profile-recovery params))
 
 

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

@@ -30,14 +30,12 @@
 
 ;; --- Command: export-binfile
 
-(def ^:private
-  schema:export-binfile
-  (sm/define
-    [:map {:title "export-binfile"}
-     [:name :string]
-     [:file-id ::sm/uuid]
-     [:include-libraries :boolean]
-     [:embed-assets :boolean]]))
+(def ^:private schema:export-binfile
+  [:map {:title "export-binfile"}
+   [:name :string]
+   [:file-id ::sm/uuid]
+   [:include-libraries :boolean]
+   [:embed-assets :boolean]])
 
 (sv/defmethod ::export-binfile
   "Export a penpot file in a binary format."
@@ -76,13 +74,11 @@
                 {:id project-id})
     result))
 
-(def ^:private
-  schema:import-binfile
-  (sm/define
-    [:map {:title "import-binfile"}
-     [:name :string]
-     [:project-id ::sm/uuid]
-     [:file ::media/upload]]))
+(def ^:private schema:import-binfile
+  [:map {:title "import-binfile"}
+   [:name :string]
+   [:project-id ::sm/uuid]
+   [:file ::media/upload]])
 
 (sv/defmethod ::import-binfile
   "Import a penpot file in a binary format."

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

@@ -35,6 +35,7 @@
    [app.util.pointer-map :as pmap]
    [app.util.services :as sv]
    [app.util.time :as dt]
+   [app.worker :as wrk]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]))
 
@@ -670,7 +671,7 @@
             f.modified_at,
             f.name,
             f.is_shared,
-            ft.media_id,
+            ft.media_id AS thumbnail_id,
             row_number() over w as row_num
        from file as f
       inner join project as p on (p.id = f.project_id)
@@ -689,10 +690,8 @@
   [conn 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)))
+               (if-let [media-id (:thumbnail-id row)]
+                 (assoc row :thumbnail-uri (resolve-public-uri media-id))
                  (dissoc row :media-id))))))
 
 (def ^:private schema:get-team-recent-files
@@ -822,7 +821,7 @@
 
       (feat.fdata/persist-pointers! cfg file-id))))
 
-(defn- absorb-library!
+(defn- absorb-library
   "Find all files using a shared library, and absorb all library assets
   into the file local libraries"
   [cfg {:keys [id] :as library}]
@@ -840,7 +839,26 @@
            :library-id (str id)
            :files (str/join "," (map str ids)))
 
-    (run! (partial absorb-library-by-file! cfg ldata) ids)))
+    (run! (partial absorb-library-by-file! cfg ldata) ids)
+    library))
+
+(defn absorb-library!
+  [{:keys [::db/conn] :as cfg} id]
+  (let [file (-> (get-file cfg id
+                           :lock-for-update? true
+                           :include-deleted? true)
+                 (check-version!))
+
+        proj (db/get* conn :project {:id (:project-id file)}
+                      {::db/remove-deleted false})
+        team (-> (db/get* conn :team {:id (:team-id proj)}
+                          {::db/remove-deleted false})
+                 (teams/decode-row))]
+
+    (-> (cfeat/get-team-enabled-features cf/flags team)
+        (cfeat/check-file-features! (:features file)))
+
+    (absorb-library cfg file)))
 
 (defn- set-file-shared
   [{:keys [::db/conn] :as cfg} {:keys [profile-id id] :as params}]
@@ -853,25 +871,14 @@
                ;; file, we need to perform more complex operation,
                ;; so in this case we retrieve the complete file and
                ;; perform all required validations.
-               (let [file (-> (get-file cfg id :lock-for-update? true)
-                              (check-version!)
-                              (assoc :is-shared false))
-                     team (teams/get-team conn
-                                          :profile-id profile-id
-                                          :project-id (:project-id file))]
-
-                 (-> (cfeat/get-team-enabled-features cf/flags team)
-                     (cfeat/check-client-features! (:features params))
-                     (cfeat/check-file-features! (:features file)))
-
-                 (absorb-library! cfg file)
-
+               (let [file (-> (absorb-library! cfg id)
+                              (assoc :is-shared false))]
                  (db/delete! conn :file-library-rel {:library-file-id id})
                  (db/update! conn :file
                              {:is-shared false
                               :modified-at (dt/now)}
                              {:id id})
-                 file)
+                 (select-keys file [:id :name :is-shared]))
 
                (and (false? (:is-shared file))
                     (true? (:is-shared params)))
@@ -911,12 +918,19 @@
 
 ;; --- MUTATION COMMAND: delete-file
 
-(defn- mark-file-deleted!
+(defn- mark-file-deleted
   [conn file-id]
-  (db/update! conn :file
-              {:deleted-at (dt/now)}
-              {:id file-id}
-              {::db/return-keys [:id :name :is-shared :project-id :created-at :modified-at]}))
+  (let [file (db/update! conn :file
+                         {:deleted-at (dt/now)}
+                         {:id file-id}
+                         {::db/return-keys [:id :name :is-shared :deleted-at
+                                            :project-id :created-at :modified-at]})]
+    (wrk/submit! {::db/conn conn
+                  ::wrk/task :delete-object
+                  ::wrk/params {:object :file
+                                :deleted-at (:deleted-at file)
+                                :id file-id}})
+    file))
 
 (def ^:private
   schema:delete-file
@@ -927,29 +941,7 @@
 (defn- delete-file
   [{:keys [::db/conn] :as cfg} {:keys [profile-id id] :as params}]
   (check-edition-permissions! conn profile-id id)
-  (let [file (mark-file-deleted! conn id)]
-
-    ;; NOTE: when a file is a shared library, then we proceed to load
-    ;; the whole file, proceed with feature checking and properly execute
-    ;; the absorb-library procedure
-    (when (:is-shared file)
-      (let [file (-> (get-file cfg id
-                               :lock-for-update? true
-                               :include-deleted? true)
-                     (check-version!))
-
-            team (teams/get-team conn
-                                 :profile-id profile-id
-                                 :project-id (:project-id file))]
-
-
-
-        (-> (cfeat/get-team-enabled-features cf/flags team)
-            (cfeat/check-client-features! (:features params))
-            (cfeat/check-file-features! (:features file)))
-
-        (absorb-library! cfg file)))
-
+  (let [file (mark-file-deleted conn id)]
     (rph/with-meta (rph/wrap)
       {::audit/props {:project-id (:project-id file)
                       :name (:name file)

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

@@ -6,13 +6,10 @@
 
 (ns app.rpc.commands.files-create
   (:require
-   [app.common.data :as d]
    [app.common.data.macros :as dm]
    [app.common.features :as cfeat]
-   [app.common.files.defaults :refer [version]]
    [app.common.schema :as sm]
    [app.common.types.file :as ctf]
-   [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
    [app.features.fdata :as feat.fdata]
@@ -40,7 +37,7 @@
 (defn create-file
   [{:keys [::db/conn] :as cfg}
    {:keys [id name project-id is-shared revn
-           modified-at deleted-at create-page
+           modified-at deleted-at create-page page-id
            ignore-sync-until features]
     :or {is-shared false revn 0 create-page true}
     :as params}]
@@ -51,23 +48,17 @@
 
   (binding [pmap/*tracked* (pmap/create-tracked)
             cfeat/*current* features]
-    (let [id       (or id (uuid/next))
-
-          data     (if create-page
-                     (ctf/make-file-data id)
-                     (ctf/make-file-data id nil))
-
-          file     {:id id
-                    :project-id project-id
-                    :name name
-                    :revn revn
-                    :is-shared is-shared
-                    :version version
-                    :data data
-                    :features features
-                    :ignore-sync-until ignore-sync-until
-                    :modified-at modified-at
-                    :deleted-at deleted-at}
+    (let [file     (ctf/make-file {:id id
+                                   :project-id project-id
+                                   :name name
+                                   :revn revn
+                                   :is-shared is-shared
+                                   :features features
+                                   :ignore-sync-until ignore-sync-until
+                                   :modified-at modified-at
+                                   :deleted-at deleted-at
+                                   :create-page create-page
+                                   :page-id page-id})
 
           file     (if (contains? features "fdata/objects-map")
                      (feat.fdata/enable-objects-map file)
@@ -75,9 +66,7 @@
 
           file     (if (contains? features "fdata/pointer-map")
                      (feat.fdata/enable-pointer-map file)
-                     file)
-
-          file     (d/without-nils file)]
+                     file)]
 
       (db/insert! conn :file
                   (-> file
@@ -86,9 +75,9 @@
                   {::db/return-keys false})
 
       (when (contains? features "fdata/pointer-map")
-        (feat.fdata/persist-pointers! cfg id))
+        (feat.fdata/persist-pointers! cfg (:id file)))
 
-      (->> (assoc params :file-id id :role :owner)
+      (->> (assoc params :file-id (:id file) :role :owner)
            (create-file-role! conn))
 
       (db/update! conn :project

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

@@ -87,10 +87,7 @@
    ::sm/params [:map {:title "get-file-object-thumbnails"}
                 [:file-id ::sm/uuid]
                 [:tag {:optional true} :string]]
-   ::sm/result [:map-of :string :string]
-   ::cond/get-object #(files/get-minimal-file %1 (:file-id %2))
-   ::cond/reuse-key? true
-   ::cond/key-fn files/get-file-etag}
+   ::sm/result [:map-of :string :string]}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id tag] :as params}]
   (dm/with-open [conn (db/open pool)]
     (files/check-read-permissions! conn profile-id file-id)
@@ -271,7 +268,7 @@
     (when (and (some? th1)
                (not= (:media-id th1)
                      (:media-id th2)))
-      (sto/touch-object! storage (:media-id th1) :async true))
+      (sto/touch-object! storage (:media-id th1)))
 
     th2))
 
@@ -324,18 +321,14 @@
 (sv/defmethod ::delete-file-object-thumbnail
   {::doc/added "1.19"
    ::doc/module :files
-   ::doc/deprecated "1.20"
-   ::climit/id [[:file-thumbnail-ops/by-profile ::rpc/profile-id]
-                [:file-thumbnail-ops/global]]
    ::audit/skip true}
   [cfg {:keys [::rpc/profile-id file-id object-id]}]
+  (files/check-edition-permissions! cfg profile-id file-id)
   (db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
-                    (files/check-edition-permissions! conn profile-id file-id)
-                    (when-not (db/read-only? conn)
-                      (-> cfg
-                          (update ::sto/storage media/configure-assets-storage conn)
-                          (delete-file-object-thumbnail! file-id object-id))
-                      nil))))
+                    (-> cfg
+                        (update ::sto/storage media/configure-assets-storage conn)
+                        (delete-file-object-thumbnail! file-id object-id))
+                    nil)))
 
 ;; --- MUTATION COMMAND: create-file-thumbnail
 
@@ -413,4 +406,5 @@
                     (when-not (db/read-only? conn)
                       (let [cfg   (update cfg ::sto/storage media/configure-assets-storage)
                             media (create-file-thumbnail! cfg params)]
-                        {:uri (files/resolve-public-uri (:id media))})))))
+                        {:uri (files/resolve-public-uri (:id media))
+                         :id (:id media)})))))

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

@@ -262,8 +262,8 @@
       ;; Send asynchronous notifications
       (send-notifications! cfg params)
 
-      ;; Retrieve and return lagged data
-      (get-lagged-changes conn params))))
+      {:revn (:revn file)
+       :lagged (get-lagged-changes conn params)})))
 
 (defn- soft-validate-file-schema!
   [file]
@@ -324,19 +324,21 @@
                  (update :data cpc/process-changes changes)
                  (update :data d/without-nils))]
 
-    (when (contains? cf/flags :soft-file-validation)
-      (soft-validate-file! file libs))
 
-    (when (contains? cf/flags :soft-file-schema-validation)
-      (soft-validate-file-schema! file))
+    (binding [pmap/*tracked* nil]
+      (when (contains? cf/flags :soft-file-validation)
+        (soft-validate-file! file libs))
 
-    (when (and (contains? cf/flags :file-validation)
-               (not skip-validate))
-      (val/validate-file! file libs))
+      (when (contains? cf/flags :soft-file-schema-validation)
+        (soft-validate-file-schema! file))
 
-    (when (and (contains? cf/flags :file-schema-validation)
-               (not skip-validate))
-      (val/validate-file-schema! file))
+      (when (and (contains? cf/flags :file-validation)
+                 (not skip-validate))
+        (val/validate-file! file libs))
+
+      (when (and (contains? cf/flags :file-schema-validation)
+                 (not skip-validate))
+        (val/validate-file-schema! file)))
 
     (cond-> file
       (contains? cfeat/*current* "fdata/objects-map")

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

@@ -12,7 +12,6 @@
    [app.db :as db]
    [app.http.session :as session]
    [app.loggers.audit :as-alias audit]
-   [app.main :as-alias main]
    [app.rpc :as-alias rpc]
    [app.rpc.commands.auth :as auth]
    [app.rpc.commands.profile :as profile]
@@ -73,7 +72,7 @@
               (rph/with-meta {::audit/props (:props profile)
                               ::audit/profile-id (:id profile)})))
 
-        (-> profile
+        (-> (profile/strip-private-attrs profile)
             (rph/with-transform (session/create-fn cfg (:id profile)))
             (rph/with-meta {::audit/props (:props profile)
                             ::audit/profile-id (:id profile)}))))))

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

@@ -16,6 +16,7 @@
    [app.config :as cf]
    [app.db :as db]
    [app.http.sse :as sse]
+   [app.loggers.audit :as audit]
    [app.loggers.webhooks :as-alias webhooks]
    [app.rpc :as-alias rpc]
    [app.rpc.commands.files :as files]
@@ -397,17 +398,30 @@
 ;; --- COMMAND: Clone Template
 
 (defn- clone-template
-  [{:keys [::wrk/executor ::bf.v1/project-id] :as cfg} template]
-  (db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
+  [cfg {:keys [project-id ::rpc/profile-id] :as params} template]
+  (db/tx-run! cfg (fn [{:keys [::db/conn ::wrk/executor] :as cfg}]
                     ;; NOTE: the importation process performs some operations that
                     ;; are not very friendly with virtual threads, and for avoid
                     ;; unexpected blocking of other concurrent operations we
                     ;; dispatch that operation to a dedicated executor.
-                    (let [result (px/submit! executor (partial bf.v1/import-files! cfg template))]
+                    (let [cfg    (-> cfg
+                                     (assoc ::bf.v1/project-id project-id)
+                                     (assoc ::bf.v1/profile-id profile-id))
+                          result (px/invoke! executor (partial bf.v1/import-files! cfg template))]
+
                       (db/update! conn :project
                                   {:modified-at (dt/now)}
                                   {:id project-id})
-                      (deref result)))))
+
+                      (let [props (audit/clean-props params)]
+                        (doseq [file-id result]
+                          (let [props (assoc props :id file-id)
+                                event (-> (audit/event-from-rpc-params params)
+                                          (assoc ::audit/name "create-file")
+                                          (assoc ::audit/props props))]
+                            (audit/submit! cfg event))))
+
+                      result))))
 
 (def ^:private
   schema:clone-template
@@ -425,16 +439,14 @@
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id project-id template-id] :as params}]
   (let [project   (db/get-by-id pool :project project-id {:columns [:id :team-id]})
         _         (teams/check-edition-permissions! pool profile-id (:team-id project))
-        template  (tmpl/get-template-stream cfg template-id)
-        params    (-> cfg
-                      (assoc ::bf.v1/project-id (:id project))
-                      (assoc ::bf.v1/profile-id profile-id))]
+        template  (tmpl/get-template-stream cfg template-id)]
+
     (when-not template
       (ex/raise :type :not-found
                 :code :template-not-found
                 :hint "template not found"))
 
-    (sse/response #(clone-template params template))))
+    (sse/response #(clone-template cfg params template))))
 
 ;; --- COMMAND: Get list of builtin templates
 

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

@@ -28,7 +28,7 @@
    [app.tokens :as tokens]
    [app.util.services :as sv]
    [app.util.time :as dt]
-   [app.worker :as-alias wrk]
+   [app.worker :as wrk]
    [cuerdas.core :as str]
    [promesa.exec :as px]))
 
@@ -91,8 +91,8 @@
 
 (defn get-profile
   "Get profile by id. Throws not-found exception if no profile found."
-  [conn id & {:as attrs}]
-  (-> (db/get-by-id conn :profile id attrs)
+  [conn id & {:as opts}]
+  (-> (db/get-by-id conn :profile id opts)
       (decode-row)))
 
 ;; --- MUTATION: Update Profile (own)
@@ -102,7 +102,7 @@
   (sm/define
     [:map {:title "update-profile"}
      [:fullname [::sm/word-string {:max 250}]]
-     [:lang {:optional true} [:string {:max 5}]]
+     [:lang {:optional true} [:string {:max 8}]]
      [:theme {:optional true} [:string {:max 250}]]]))
 
 (sv/defmethod ::update-profile
@@ -110,7 +110,6 @@
    ::sm/params schema:update-profile
    ::sm/result schema:profile}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id fullname lang theme] :as params}]
-
   (db/with-atomic [conn pool]
     ;; NOTE: we need to retrieve the profile independently if we use
     ;; it or not for explicit locking and avoid concurrent updates of
@@ -277,19 +276,19 @@
 (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)
-          cfg     (assoc cfg ::conn conn)
-          params  (assoc params
-                         :profile profile
-                         :email (clean-email email))]
-      (if (contains? cf/flags :smtp)
-        (request-email-change! cfg params)
-        (change-email-immediately! cfg params)))))
+  [cfg {:keys [::rpc/profile-id email] :as params}]
+  (db/tx-run! cfg
+              (fn [cfg]
+                (let [profile (db/get-by-id cfg :profile profile-id)
+                      params  (assoc params
+                                     :profile profile
+                                     :email (clean-email email))]
+                  (if (contains? cf/flags :smtp)
+                    (request-email-change! cfg params)
+                    (change-email-immediately! cfg params))))))
 
 (defn- change-email-immediately!
-  [{:keys [::conn]} {:keys [profile email] :as params}]
+  [{:keys [::db/conn]} {:keys [profile email] :as params}]
   (when (not= email (:email profile))
     (check-profile-existence! conn params))
 
@@ -300,7 +299,7 @@
   {:changed true})
 
 (defn- request-email-change!
-  [{:keys [::conn] :as cfg} {:keys [profile email] :as params}]
+  [{:keys [::db/conn] :as cfg} {:keys [profile email] :as params}]
   (let [token   (tokens/generate (::setup/props cfg)
                                  {:iss :change-email
                                   :exp (dt/in-future "15m")
@@ -320,9 +319,28 @@
                 :hint "looks like the profile has reported repeatedly as spam or has permanent bounces."))
 
     (when (eml/has-bounce-reports? conn email)
-      (ex/raise :type :validation
+      (ex/raise :type :restriction
                 :code :email-has-permanent-bounces
-                :hint "looks like the email you invite has been repeatedly reported as spam or permanent bounce"))
+                :email email
+                :hint "looks like the email has bounce reports"))
+
+    (when (eml/has-complaint-reports? conn email)
+      (ex/raise :type :restriction
+                :code :email-has-complaints
+                :email email
+                :hint "looks like the email has spam complaint reports"))
+
+    (when (eml/has-bounce-reports? conn (:email profile))
+      (ex/raise :type :restriction
+                :code :email-has-permanent-bounces
+                :email (:email profile)
+                :hint "looks like the email has bounce reports"))
+
+    (when (eml/has-complaint-reports? conn (:email profile))
+      (ex/raise :type :restriction
+                :code :email-has-complaints
+                :email (:email profile)
+                :hint "looks like the email has spam complaint reports"))
 
     (eml/send! {::eml/conn conn
                 ::eml/factory eml/change-email
@@ -367,13 +385,13 @@
 
 ;; --- MUTATION: Delete Profile
 
-(declare ^:private get-owned-teams-with-participants)
+(declare ^:private get-owned-teams)
 
 (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)
+    (let [teams      (get-owned-teams conn profile-id)
           deleted-at (dt/now)]
 
       ;; If we found owned teams with participants, we don't allow
@@ -385,37 +403,39 @@
                   :hint "The user need to transfer ownership of owned teams."
                   :context {:teams (mapv :id teams)}))
 
-      (doseq [{:keys [id]} teams]
-        (db/update! conn :team
-                    {:deleted-at deleted-at}
-                    {:id id}))
-
+      ;; Mark profile deleted immediatelly
       (db/update! conn :profile
                   {:deleted-at deleted-at}
                   {:id profile-id})
 
+      ;; Schedule cascade deletion to a worker
+      (wrk/submit! {::db/conn conn
+                    ::wrk/task :delete-object
+                    ::wrk/params {:object :profile
+                                  :deleted-at deleted-at
+                                  :id profile-id}})
+
       (rph/with-transform {} (session/delete-fn cfg)))))
 
 
 ;; --- HELPERS
 
 (def sql:owned-teams
-  "with owner_teams as (
-      select tpr.team_id as id
-        from team_profile_rel as tpr
-       where tpr.is_owner is true
-         and tpr.profile_id = ?
+  "WITH owner_teams AS (
+      SELECT tpr.team_id AS id
+        FROM team_profile_rel AS tpr
+       WHERE tpr.is_owner IS TRUE
+         AND tpr.profile_id = ?
    )
-   select tpr.team_id as id,
-          count(tpr.profile_id) - 1 as participants
-     from team_profile_rel as tpr
-    where tpr.team_id in (select id from owner_teams)
-      and tpr.profile_id != ?
-    group by 1")
+   SELECT tpr.team_id AS id,
+          count(tpr.profile_id) - 1 AS participants
+     FROM team_profile_rel AS tpr
+    WHERE tpr.team_id IN (SELECT id from owner_teams)
+    GROUP BY 1")
 
-(defn- get-owned-teams-with-participants
+(defn get-owned-teams
   [conn profile-id]
-  (db/exec! conn [sql:owned-teams profile-id profile-id]))
+  (db/exec! conn [sql:owned-teams profile-id]))
 
 (def ^:private sql:profile-existence
   "select exists (select * from profile

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

@@ -7,6 +7,7 @@
 (ns app.rpc.commands.projects
   (:require
    [app.common.data.macros :as dm]
+   [app.common.exceptions :as ex]
    [app.common.spec :as us]
    [app.db :as db]
    [app.db.sql :as-alias sql]
@@ -20,6 +21,7 @@
    [app.rpc.quotes :as quotes]
    [app.util.services :as sv]
    [app.util.time :as dt]
+   [app.worker :as wrk]
    [clojure.spec.alpha :as s]))
 
 (s/def ::id ::us/uuid)
@@ -244,28 +246,39 @@
 
 ;; --- MUTATION: Delete Project
 
+(defn- delete-project
+  [conn project-id]
+  (let [project (db/update! conn :project
+                            {:deleted-at (dt/now)}
+                            {:id project-id}
+                            {::db/return-keys true})]
+
+    (when (:is-default project)
+      (ex/raise :type :validation
+                :code :non-deletable-project
+                :hint "impossible to delete default project"))
+
+    (wrk/submit! {::db/conn conn
+                  ::wrk/task :delete-object
+                  ::wrk/params {:object :project
+                                :deleted-at (:deleted-at project)
+                                :id project-id}})
+
+    project))
+
 (s/def ::delete-project
   (s/keys :req [::rpc/profile-id]
           :req-un [::id]))
 
-;; TODO: right now, we just don't allow delete default projects, in a
-;; future we need to ensure raise a correct exception signaling that
-;; this is not allowed.
-
 (sv/defmethod ::delete-project
   {::doc/added "1.18"
    ::webhooks/event? true}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id] :as params}]
   (db/with-atomic [conn pool]
     (check-edition-permissions! conn profile-id id)
-    (let [project (db/update! conn :project
-                              {:deleted-at (dt/now)}
-                              {:id id :is-default false}
-                              {::db/return-keys true})]
+    (let [project (delete-project conn id)]
       (rph/with-meta (rph/wrap)
         {::audit/props {:team-id (:team-id project)
                         :name (:name project)
                         :created-at (:created-at project)
                         :modified-at (:modified-at project)}}))))
-
-

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

@@ -12,7 +12,6 @@
    [app.common.features :as cfeat]
    [app.common.logging :as l]
    [app.common.schema :as sm]
-   [app.common.spec :as us]
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
@@ -31,16 +30,11 @@
    [app.tokens :as tokens]
    [app.util.services :as sv]
    [app.util.time :as dt]
-   [clojure.spec.alpha :as s]
+   [app.worker :as wrk]
    [cuerdas.core :as str]))
 
 ;; --- Helpers & Specs
 
-(s/def ::id ::us/uuid)
-(s/def ::name ::us/string)
-(s/def ::file-id ::us/uuid)
-(s/def ::team-id ::us/uuid)
-
 (def ^:private sql:team-permissions
   "select tpr.is_owner,
           tpr.is_admin,
@@ -350,7 +344,7 @@
 
 (def ^:private schema:create-team
   [:map {:title "create-team"}
-   [:name :string]
+   [:name [:string {:max 250}]]
    [:features {:optional true} ::cfeat/features]
    [:id {:optional true} ::sm/uuid]])
 
@@ -363,10 +357,12 @@
                                                ::quotes/profile-id profile-id})
 
                     (let [features (-> (cfeat/get-enabled-features cf/flags)
-                                       (cfeat/check-client-features! (:features params)))]
-                      (create-team cfg (assoc params
-                                              :profile-id profile-id
-                                              :features features))))))
+                                       (cfeat/check-client-features! (:features params)))
+                          team (create-team cfg (assoc params
+                                                       :profile-id profile-id
+                                                       :features features))]
+                      (with-meta team
+                        {::audit/props {:id (:id team)}})))))
 
 (defn create-team
   "This is a complete team creation process, it creates the team
@@ -437,12 +433,14 @@
 
 ;; --- Mutation: Update Team
 
-(s/def ::update-team
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::name ::id]))
+(def ^:private schema:update-team
+  [:map {:title "update-team"}
+   [:name [:string {:max 250}]]
+   [:id ::sm/uuid]])
 
 (sv/defmethod ::update-team
-  {::doc/added "1.17"}
+  {::doc/added "1.17"
+   ::sm/params schema:update-team}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id name] :as params}]
   (db/with-atomic [conn pool]
     (check-edition-permissions! conn profile-id id)
@@ -502,30 +500,49 @@
 
     nil))
 
-(s/def ::reassign-to ::us/uuid)
-(s/def ::leave-team
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::id]
-          :opt-un [::reassign-to]))
+(def ^:private schema:leave-team
+  [:map {:title "leave-team"}
+   [:id ::sm/uuid]
+   [:reassign-to {:optional true} ::sm/uuid]])
 
 (sv/defmethod ::leave-team
-  {::doc/added "1.17"}
+  {::doc/added "1.17"
+   ::sm/params schema:leave-team}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id] :as params}]
   (db/with-atomic [conn pool]
     (leave-team conn (assoc params :profile-id profile-id))))
 
 ;; --- Mutation: Delete Team
 
-(s/def ::delete-team
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::id]))
+(defn- delete-team
+  "Mark a team for deletion"
+  [conn team-id]
 
-;; TODO: right now just don't allow delete default team, in future it
-;; should raise a specific exception for signal that this action is
-;; not allowed.
+  (let [deleted-at (dt/now)
+        team       (db/update! conn :team
+                               {:deleted-at deleted-at}
+                               {:id team-id}
+                               {::db/return-keys true})]
+
+    (when (:is-default team)
+      (ex/raise :type :validation
+                :code :non-deletable-team
+                :hint "impossible to delete default team"))
+
+    (wrk/submit! {::db/conn conn
+                  ::wrk/task :delete-object
+                  ::wrk/params {:object :team
+                                :deleted-at deleted-at
+                                :id team-id}})
+    team))
+
+(def ^:private schema:delete-team
+  [:map {:title "delete-team"}
+   [:id ::sm/uuid]])
 
 (sv/defmethod ::delete-team
-  {::doc/added "1.17"}
+  {::doc/added "1.17"
+   ::sm/params schema:delete-team}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id] :as params}]
   (db/with-atomic [conn pool]
     (let [perms (get-permissions conn profile-id id)]
@@ -533,18 +550,11 @@
         (ex/raise :type :validation
                   :code :only-owner-can-delete-team))
 
-      (db/update! conn :team
-                  {:deleted-at (dt/now)}
-                  {:id id :is-default false})
+      (delete-team conn id)
       nil)))
 
-
 ;; --- Mutation: Team Update Role
 
-(s/def ::team-id ::us/uuid)
-(s/def ::member-id ::us/uuid)
-(s/def ::role #{:owner :admin :editor})
-
 ;; Temporarily disabled viewer role
 ;; https://tree.taiga.io/project/penpot/issue/1083
 (def valid-roles
@@ -608,25 +618,29 @@
                    :profile-id member-id})
       nil)))
 
-(s/def ::update-team-member-role
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::team-id ::member-id ::role]))
+(def ^:private schema:update-team-member-role
+  [:map {:title "update-team-member-role"}
+   [:team-id ::sm/uuid]
+   [:member-id ::sm/uuid]
+   [:role schema:role]])
 
 (sv/defmethod ::update-team-member-role
-  {::doc/added "1.17"}
+  {::doc/added "1.17"
+   ::sm/params schema:update-team-member-role}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id] :as params}]
   (db/with-atomic [conn pool]
     (update-team-member-role conn (assoc params :profile-id profile-id))))
 
-
 ;; --- Mutation: Delete Team Member
 
-(s/def ::delete-team-member
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::team-id ::member-id]))
+(def ^:private schema:delete-team-member
+  [:map {:title "delete-team-member"}
+   [:team-id ::sm/uuid]
+   [:member-id ::sm/uuid]])
 
 (sv/defmethod ::delete-team-member
-  {::doc/added "1.17"}
+  {::doc/added "1.17"
+   ::sm/params schema:delete-team-member}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id member-id] :as params}]
   (db/with-atomic [conn pool]
     (let [perms (get-permissions conn profile-id team-id)]
@@ -649,13 +663,14 @@
 (declare upload-photo)
 (declare ^:private update-team-photo)
 
-(s/def ::file ::media/upload)
-(s/def ::update-team-photo
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::team-id ::file]))
+(def ^:private schema:update-team-photo
+  [:map {:title "update-team-photo"}
+   [:team-id ::sm/uuid]
+   [:file ::media/upload]])
 
 (sv/defmethod ::update-team-photo
-  {::doc/added "1.17"}
+  {::doc/added "1.17"
+   ::sm/params schema:update-team-photo}
   [cfg {:keys [::rpc/profile-id file] :as params}]
   ;; Validate incoming mime type
   (media/validate-media-type! file #{"image/jpeg" "image/png" "image/webp"})
@@ -719,12 +734,19 @@
                 :email email
                 :hint "the profile has reported repeatedly as spam or has bounces"))
 
-    ;; Secondly check if the invited member email is part of the global spam/bounce report.
+    ;; Secondly check if the invited member email is part of the global bounce report.
     (when (eml/has-bounce-reports? conn email)
-      (ex/raise :type :validation
+      (ex/raise :type :restriction
                 :code :email-has-permanent-bounces
                 :email email
-                :hint "the email you invite has been repeatedly reported as spam or bounce"))
+                :hint "the email you invite has been repeatedly reported as bounce"))
+
+    ;; Secondly check if the invited member email is part of the global complain report.
+    (when (eml/has-complaint-reports? conn email)
+      (ex/raise :type :restriction
+                :code :email-has-complaints
+                :email email
+                :hint "the email you invite has been repeatedly reported as spam"))
 
     ;; When we have email verification disabled and invitation user is
     ;; already present in the database, we proceed to add it to the
@@ -750,6 +772,7 @@
                       {:id (:id member)}))
 
         nil)
+
       (let [id         (uuid/next)
             expire     (dt/in-future "168h") ;; 7 days
             invitation (db/exec-one! conn [sql:upsert-team-invitation id
@@ -770,14 +793,16 @@
         (when (contains? cf/flags :log-invitation-tokens)
           (l/info :hint "invitation token" :token itoken))
 
-        (audit/submit! cfg
-                       {::audit/type "action"
-                        ::audit/name (if updated?
-                                       "update-team-invitation"
-                                       "create-team-invitation")
-                        ::audit/profile-id (:id profile)
-                        ::audit/props (-> (dissoc tprops :profile-id)
-                                          (d/without-nils))})
+
+        (let [props  (-> (dissoc tprops :profile-id)
+                         (audit/clean-props))
+              evname (if updated?
+                       "update-team-invitation"
+                       "create-team-invitation")
+              event (-> (audit/event-from-rpc-params params)
+                        (assoc ::audit/name evname)
+                        (assoc ::audit/props props))]
+          (audit/submit! cfg event))
 
         (eml/send! {::eml/conn conn
                     ::eml/factory eml/invite-to-team
@@ -793,7 +818,7 @@
 (def ^:private schema:create-team-invitations
   [:map {:title "create-team-invitations"}
    [:team-id ::sm/uuid]
-   [:role [::sm/one-of #{:owner :admin :editor}]]
+   [:role schema:role]
    [:emails ::sm/set-of-emails]])
 
 (sv/defmethod ::create-team-invitations
@@ -837,25 +862,19 @@
                                ;;  We don't re-send inviation to already existing members
                                (remove (partial contains? members))
                                (map (fn [email]
-                                      {:email email
-                                       :team team
-                                       :profile profile
-                                       :role role}))
+                                      (-> params
+                                          (assoc :email email)
+                                          (assoc :team team)
+                                          (assoc :profile profile)
+                                          (assoc :role role))))
                                (keep (partial create-invitation cfg)))
                               emails)]
         (with-meta {:total (count invitations)
                     :invitations invitations}
           {::audit/props {:invitations (count invitations)}})))))
 
-
 ;; --- Mutation: Create Team & Invite Members
 
-(s/def ::emails ::us/set-of-valid-emails)
-(s/def ::create-team-with-invitations
-  (s/merge ::create-team
-           (s/keys :req-un [::emails ::role])))
-
-
 (def ^:private schema:create-team-with-invitations
   [:map {:title "create-team-with-invitations"}
    [:name :string]
@@ -867,59 +886,62 @@
 (sv/defmethod ::create-team-with-invitations
   {::doc/added "1.17"
    ::sm/params schema:create-team-with-invitations}
-  [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id emails role] :as params}]
-  (db/with-atomic [conn pool]
+  [cfg {:keys [::rpc/profile-id emails role name] :as params}]
 
-    (let [features (-> (cfeat/get-enabled-features cf/flags)
-                       (cfeat/check-client-features! (:features params)))
-          params   (assoc params
-                          :profile-id profile-id
-                          :features features)
-          cfg      (assoc cfg ::db/conn conn)
-          team     (create-team cfg params)
-          profile  (db/get-by-id conn :profile profile-id)
-          emails   (into #{} (map profile/clean-email) emails)]
+  (db/tx-run! cfg
+              (fn [{:keys [::db/conn] :as cfg}]
+                (let [features (-> (cfeat/get-enabled-features cf/flags)
+                                   (cfeat/check-client-features! (:features params)))
 
-      ;; Create invitations for all provided emails.
-      (->> emails
-           (map (fn [email]
-                  {:team team
-                   :profile profile
-                   :email email
-                   :role role}))
-           (run! (partial create-invitation cfg)))
+                      params   (-> params
+                                   (assoc :profile-id profile-id)
+                                   (assoc :features features))
 
-      (run! (partial quotes/check-quote! conn)
-            (list {::quotes/id ::quotes/teams-per-profile
-                   ::quotes/profile-id profile-id}
-                  {::quotes/id ::quotes/invitations-per-team
-                   ::quotes/profile-id profile-id
-                   ::quotes/team-id (:id team)
-                   ::quotes/incr (count emails)}
-                  {::quotes/id ::quotes/profiles-per-team
-                   ::quotes/profile-id profile-id
-                   ::quotes/team-id (:id team)
-                   ::quotes/incr (count emails)}))
+                      cfg      (assoc cfg ::db/conn conn)
+                      team     (create-team cfg params)
+                      profile  (db/get-by-id conn :profile profile-id)
+                      emails   (into #{} (map profile/clean-email) emails)]
 
-      (audit/submit! cfg
-                     {::audit/type "command"
-                      ::audit/name "create-team-invitations"
-                      ::audit/profile-id profile-id
-                      ::audit/props {:emails emails
-                                     :role role
-                                     :profile-id profile-id
-                                     :invitations (count emails)}})
+                  (let [props {:name name :features features}
+                        event (-> (audit/event-from-rpc-params params)
+                                  (assoc ::audit/name "create-team")
+                                  (assoc ::audit/props props))]
+                    (audit/submit! cfg event))
 
-      (vary-meta team assoc ::audit/props {:invitations (count emails)}))))
+                  ;; Create invitations for all provided emails.
+                  (->> emails
+                       (map (fn [email]
+                              (-> params
+                                  (assoc :team team)
+                                  (assoc :profile profile)
+                                  (assoc :email email)
+                                  (assoc :role role))))
+                       (run! (partial create-invitation cfg)))
+
+                  (run! (partial quotes/check-quote! conn)
+                        (list {::quotes/id ::quotes/teams-per-profile
+                               ::quotes/profile-id profile-id}
+                              {::quotes/id ::quotes/invitations-per-team
+                               ::quotes/profile-id profile-id
+                               ::quotes/team-id (:id team)
+                               ::quotes/incr (count emails)}
+                              {::quotes/id ::quotes/profiles-per-team
+                               ::quotes/profile-id profile-id
+                               ::quotes/team-id (:id team)
+                               ::quotes/incr (count emails)}))
+
+                  (vary-meta team assoc ::audit/props {:invitations (count emails)})))))
 
 ;; --- Query: get-team-invitation-token
 
-(s/def ::get-team-invitation-token
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::team-id ::email]))
+(def ^:private schema:get-team-invitation-token
+  [:map {:title "get-team-invitation-token"}
+   [:team-id ::sm/uuid]
+   [:email ::sm/email]])
 
 (sv/defmethod ::get-team-invitation-token
-  {::doc/added "1.17"}
+  {::doc/added "1.17"
+   ::sm/params schema:get-team-invitation-token}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id email] :as params}]
   (check-read-permissions! pool profile-id team-id)
   (let [email (profile/clean-email email)
@@ -940,12 +962,15 @@
 
 ;; --- Mutation: Update invitation role
 
-(s/def ::update-team-invitation-role
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::team-id ::email ::role]))
+(def ^:private schema:update-team-invitation-role
+  [:map {:title "update-team-invitation-role"}
+   [:team-id ::sm/uuid]
+   [:email ::sm/email]
+   [:role schema:role]])
 
 (sv/defmethod ::update-team-invitation-role
-  {::doc/added "1.17"}
+  {::doc/added "1.17"
+   ::sm/params schema:update-team-invitation-role}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id email role] :as params}]
   (db/with-atomic [conn pool]
     (let [perms    (get-permissions conn profile-id team-id)]
@@ -961,12 +986,14 @@
 
 ;; --- Mutation: Delete invitation
 
-(s/def ::delete-team-invitation
-  (s/keys :req [::rpc/profile-id]
-          :req-un [::team-id ::email]))
+(def ^:private schema:delete-team-invition
+  [:map {:title "delete-team-invitation"}
+   [:team-id ::sm/uuid]
+   [:email ::sm/email]])
 
 (sv/defmethod ::delete-team-invitation
-  {::doc/added "1.17"}
+  {::doc/added "1.17"
+   ::sm/params schema:delete-team-invition}
   [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id email] :as params}]
   (db/with-atomic [conn pool]
     (let [perms (get-permissions conn profile-id team-id)]

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

@@ -9,6 +9,7 @@
    [app.common.exceptions :as ex]
    [app.common.spec :as us]
    [app.db :as db]
+   [app.db.sql :as-alias sql]
    [app.http.session :as session]
    [app.loggers.audit :as audit]
    [app.main :as-alias main]
@@ -82,8 +83,16 @@
 
 (defmethod process-token :auth
   [{:keys [conn] :as cfg} _params {:keys [profile-id] :as claims}]
-  (let [profile (profile/get-profile conn profile-id)]
-    (assoc claims :profile profile)))
+  (let [profile  (profile/get-profile conn profile-id {::sql/for-update true})
+        props    (merge (:props profile)
+                        (:props claims))]
+    (when (not= props (:props profile))
+      (db/update! conn :profile
+                  {:props (db/tjson props)}
+                  {:id profile-id}))
+
+    (let [profile (assoc profile :props props)]
+      (assoc claims :profile profile))))
 
 ;; --- Team Invitation
 
@@ -138,7 +147,7 @@
 
 (defmethod process-token :team-invitation
   [{:keys [conn] :as cfg}
-   {:keys [::rpc/profile-id token]}
+   {:keys [::rpc/profile-id token] :as params}
    {:keys [member-id team-id member-email] :as claims}]
 
   (us/verify! ::team-invitation-claims claims)
@@ -160,13 +169,16 @@
         ;; if we have logged-in user and it matches the invitation we proceed
         ;; with accepting the invitation and joining the current profile to the
         ;; invited team.
-        (let [profile (accept-invitation cfg claims invitation profile)]
-          (-> (assoc claims :state :created)
-              (rph/with-meta {::audit/name "accept-team-invitation"
-                              ::audit/profile-id (:id profile)
-                              ::audit/props {:team-id (:team-id claims)
-                                             :role (:role claims)
-                                             :invitation-id (:id invitation)}})))
+        (let [props {:team-id (:team-id claims)
+                     :role (:role claims)
+                     :invitation-id (:id invitation)}
+              event (-> (audit/event-from-rpc-params params)
+                        (assoc ::audit/name "accept-team-invitation")
+                        (assoc ::audit/props props))]
+
+          (accept-invitation cfg claims invitation profile)
+          (audit/submit! cfg event)
+          (assoc claims :state :created))
 
         (ex/raise :type :validation
                   :code :invalid-token

backend/src/app/rpc/quotes.clj

@@ -83,17 +83,17 @@
                             "- Quote ID: '~(::target params)'\n"
                             "- Max: ~(::quote params)\n"
                             "- Total: ~(::total params) (INCR ~(::incr params 1))\n")]
-      (wrk/submit! {::wrk/task :sendmail
+      (wrk/submit! {::db/conn conn
+                    ::wrk/task :sendmail
                     ::wrk/delay (dt/duration "30s")
                     ::wrk/max-retries 4
                     ::wrk/priority 200
-                    ::wrk/conn conn
                     ::wrk/dedupe true
                     ::wrk/label "quotes-notification"
-                    :to (vec admins)
-                    :subject subject
-                    :body [{:type "text/plain"
-                            :content content}]}))))
+                    ::wrk/params {:to (vec admins)
+                                  :subject subject
+                                  :body [{:type "text/plain"
+                                          :content content}]}}))))
 
 (defn- generic-check!
   [{:keys [::db/conn ::incr ::quote-sql ::count-sql ::default ::target] :or {incr 1} :as params}]

backend/src/app/rpc/rlimit.clj

@@ -51,12 +51,12 @@
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.http :as-alias http]
-   [app.loggers.audit :refer [parse-client-ip]]
    [app.redis :as rds]
    [app.redis.script :as-alias rscript]
    [app.rpc :as-alias rpc]
    [app.rpc.helpers :as rph]
    [app.rpc.rlimit.result :as-alias lresult]
+   [app.util.inet :as inet]
    [app.util.services :as-alias sv]
    [app.util.time :as dt]
    [app.worker :as wrk]
@@ -215,7 +215,7 @@
   [{:keys [::rpc/profile-id] :as params}]
   (let [request (-> params meta ::http/request)]
     (or profile-id
-        (some-> request parse-client-ip)
+        (some-> request inet/parse-request)
         uuid/zero)))
 
 (defn process-request!

backend/src/app/srepl/fixes.clj

@@ -184,10 +184,7 @@
                                              (ctk/instance-head? child))
                                       (let [slot (guess-swap-slot component-child component-container)]
                                         (l/dbg :hint "child" :id (:id child) :name (:name child) :slot slot)
-                                        (ctn/update-shape container (:id child)
-                                                          #(update % :touched
-                                                                   cfh/set-touched-group
-                                                                   (ctk/build-swap-slot-group slot))))
+                                        (ctn/update-shape container (:id child) #(ctk/set-swap-slot % slot)))
                                       container)]
                       (recur (process-copy-head container child)
                              (rest children)
@@ -237,3 +234,44 @@
 
     file  (-> file
               (update :data process-fdata))))
+
+
+
+(defn fix-find-duplicated-slots
+  [file _]
+  ;; Find the shapes whose children have duplicated slots
+  (let [check-duplicate-swap-slot
+        (fn [shape page]
+          (let [shapes   (map #(get (:objects page) %) (:shapes shape))
+                slots    (->> (map #(ctk/get-swap-slot %) shapes)
+                              (remove nil?))
+                counts   (frequencies slots)]
+            #_(when (some (fn [[_ count]] (> count 1)) counts)
+                (l/trc :info "This shape has children with the same swap slot" :id (:id shape) :file-id (str (:id file))))
+            (some (fn [[_ count]] (> count 1)) counts)))
+
+        count-slots-shape
+        (fn [page shape]
+          (if (ctk/instance-root? shape)
+            (check-duplicate-swap-slot shape page)
+            false))
+
+        count-slots-page
+        (fn [page]
+          (->> (:objects page)
+               (vals)
+               (mapv #(count-slots-shape page %))
+               (filter true?)
+               count))
+
+        count-slots-data
+        (fn [data]
+          (->> (:pages-index data)
+               (vals)
+               (mapv count-slots-page)
+               (reduce +)))
+
+        num-missing-slots (count-slots-data (:data file))]
+    (when (pos? num-missing-slots)
+      (l/trc :info (str "Shapes with children with the same swap slot: " num-missing-slots) :file-id (str (:id file))))
+    file))

backend/src/app/srepl/main.clj

@@ -21,8 +21,10 @@
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
+   [app.db.sql :as-alias sql]
    [app.features.components-v2 :as feat.comp-v2]
    [app.features.fdata :as feat.fdata]
+   [app.loggers.audit :as audit]
    [app.main :as main]
    [app.msgbus :as mbus]
    [app.rpc.commands.auth :as auth]
@@ -30,16 +32,20 @@
    [app.rpc.commands.files-snapshot :as fsnap]
    [app.rpc.commands.management :as mgmt]
    [app.rpc.commands.profile :as profile]
+   [app.rpc.commands.projects :as projects]
+   [app.rpc.commands.teams :as teams]
    [app.srepl.fixes :as fixes]
    [app.srepl.helpers :as h]
    [app.util.blob :as blob]
    [app.util.pointer-map :as pmap]
    [app.util.time :as dt]
    [app.worker :as wrk]
+   [clojure.java.io :as io]
    [clojure.pprint :refer [print-table]]
    [clojure.stacktrace :as strace]
    [clojure.tools.namespace.repl :as repl]
    [cuerdas.core :as str]
+   [datoteka.fs :as fs]
    [promesa.exec :as px]
    [promesa.exec.semaphore :as ps]
    [promesa.util :as pu]))
@@ -57,42 +63,35 @@
   ([tname]
    (run-task! tname {}))
   ([tname params]
-   (let [tasks (:app.worker/registry main/system)
-         tname (if (keyword? tname) (name tname) name)]
-     (if-let [task-fn (get tasks tname)]
-       (task-fn params)
-       (println (format "no task '%s' found" tname))))))
+   (wrk/invoke! (-> main/system
+                    (assoc ::wrk/task tname)
+                    (assoc ::wrk/params params)))))
 
 (defn schedule-task!
   ([name]
    (schedule-task! name {}))
-  ([name props]
-   (let [pool (:app.db/pool main/system)]
-     (wrk/submit!
-      ::wrk/conn pool
-      ::wrk/task name
-      ::wrk/props props))))
+  ([name params]
+   (wrk/submit! (-> main/system
+                    (assoc ::wrk/task name)
+                    (assoc ::wrk/params params)))))
 
 (defn send-test-email!
   [destination]
-  (us/verify!
-   :expr (string? destination)
-   :hint "destination should be provided")
-
-  (let [handler (:app.email/sendmail main/system)]
-    (handler {:body "test email"
-              :subject "test email"
-              :to [destination]})))
+  (assert (string? destination) "destination should be provided")
+  (-> main/system
+      (assoc ::wrk/task :sendmail)
+      (assoc ::wrk/params {:body "test email"
+                           :subject "test email"
+                           :to [destination]})
+      (wrk/invoke!)))
 
 (defn resend-email-verification-email!
   [email]
-  (let [sprops  (:app.setup/props main/system)
-        pool    (:app.db/pool main/system)
-        email   (profile/clean-email email)
-        profile (profile/get-profile-by-email pool email)]
-
-    (auth/send-email-verification! pool sprops profile)
-    :email-sent))
+  (db/tx-run! main/system
+              (fn [{:keys [::db/conn] :as cfg}]
+                (let [email   (profile/clean-email email)
+                      profile (profile/get-profile-by-email conn email)]
+                  (#'auth/send-email-verification! cfg profile)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; PROFILES MANAGEMENT
@@ -194,8 +193,13 @@
 ;; NOTIFICATIONS
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-
 (defn notify!
+  "Send flash notifications.
+
+  This method allows send flash notifications to specified target destinations.
+  The message can be a free text or a preconfigured one.
+
+  The destination can be: all, profile-id, team-id, or a coll of them."
   [{:keys [::mbus/msgbus ::db/pool]} & {:keys [dest code message level]
                                         :or {code :generic level :info}
                                         :as params}]
@@ -203,10 +207,6 @@
    ["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
@@ -232,6 +232,9 @@
 
           (resolve-dest [dest]
             (cond
+              (= :all dest)
+              [uuid/zero]
+
               (uuid? dest)
               [dest]
 
@@ -247,14 +250,15 @@
                          (mapcat resolve-dest))
                         dest)
 
-              (and (coll? dest)
-                   (every? coll? dest))
+              (and (vector? dest)
+                   (every? vector? dest))
               (sequence (comp
                          (map vec)
                          (mapcat resolve-dest))
                         dest)
 
-              (vector? dest)
+              (and (vector? dest)
+                   (keyword? (first dest)))
               (let [[op param] dest]
                 (cond
                   (= op :email)
@@ -476,6 +480,332 @@
                  :rollback rollback?
                  :elapsed elapsed))))))
 
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; DELETE/RESTORE OBJECTS (WITH CASCADE, SOFT)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn delete-file!
+  "Mark a project for deletion"
+  [file-id]
+  (let [file-id (h/parse-uuid file-id)
+        tnow    (dt/now)]
+
+    (audit/insert! main/system
+                   {::audit/name "delete-file"
+                    ::audit/type "action"
+                    ::audit/profile-id uuid/zero
+                    ::audit/props {:id file-id}
+                    ::audit/context {:triggered-by "srepl"
+                                     :cause "explicit call to delete-file!"}
+                    ::audit/tracked-at tnow})
+    (wrk/invoke! (-> main/system
+                     (assoc ::wrk/task :delete-object)
+                     (assoc ::wrk/params {:object :file
+                                          :deleted-at tnow
+                                          :id file-id})))
+    :deleted))
+
+(defn- restore-file*
+  [{:keys [::db/conn]} file-id]
+  (db/update! conn :file
+              {:deleted-at nil
+               :has-media-trimmed false}
+              {:id file-id})
+
+  ;; Fragments are not handled here because they
+  ;; use the database cascade operation and they
+  ;; are not marked for deletion with objects-gc
+  ;; task
+
+  (db/update! conn :file-media-object
+              {:deleted-at nil}
+              {:file-id file-id})
+
+  ;; Mark thumbnails to be deleted
+  (db/update! conn :file-thumbnail
+              {:deleted-at nil}
+              {:file-id file-id})
+
+  (db/update! conn :file-tagged-object-thumbnail
+              {:deleted-at nil}
+              {:file-id file-id})
+
+  :restored)
+
+(defn restore-file!
+  "Mark a file and all related objects as not deleted"
+  [file-id]
+  (let [file-id (h/parse-uuid file-id)]
+    (db/tx-run! main/system
+                (fn [system]
+                  (when-let [file (some-> (db/get* system :file
+                                                   {:id file-id}
+                                                   {::db/remove-deleted false
+                                                    ::sql/columns [:id :name]})
+                                          (files/decode-row))]
+                    (audit/insert! system
+                                   {::audit/name "restore-file"
+                                    ::audit/type "action"
+                                    ::audit/profile-id uuid/zero
+                                    ::audit/props file
+                                    ::audit/context {:triggered-by "srepl"
+                                                     :cause "explicit call to restore-file!"}
+                                    ::audit/tracked-at (dt/now)})
+
+                    (restore-file* system file-id))))))
+
+(defn delete-project!
+  "Mark a project for deletion"
+  [project-id]
+  (let [project-id (h/parse-uuid project-id)
+        tnow       (dt/now)]
+
+    (audit/insert! main/system
+                   {::audit/name "delete-project"
+                    ::audit/type "action"
+                    ::audit/profile-id uuid/zero
+                    ::audit/props {:id project-id}
+                    ::audit/context {:triggered-by "srepl"
+                                     :cause "explicit call to delete-project!"}
+                    ::audit/tracked-at tnow})
+
+    (wrk/invoke! (-> main/system
+                     (assoc ::wrk/task :delete-object)
+                     (assoc ::wrk/params {:object :project
+                                          :deleted-at tnow
+                                          :id project-id})))
+    :deleted))
+
+(defn- restore-project*
+  [{:keys [::db/conn] :as cfg} project-id]
+  (db/update! conn :project
+              {:deleted-at nil}
+              {:id project-id})
+
+  (doseq [{:keys [id]} (db/query conn :file
+                                 {:project-id project-id}
+                                 {::sql/columns [:id]})]
+    (restore-file* cfg id))
+
+  :restored)
+
+(defn restore-project!
+  "Mark a project and all related objects as not deleted"
+  [project-id]
+  (let [project-id (h/parse-uuid project-id)]
+    (db/tx-run! main/system
+                (fn [system]
+                  (when-let [project (db/get* system :project
+                                              {:id project-id}
+                                              {::db/remove-deleted false})]
+                    (audit/insert! system
+                                   {::audit/name "restore-project"
+                                    ::audit/type "action"
+                                    ::audit/profile-id uuid/zero
+                                    ::audit/props project
+                                    ::audit/context {:triggered-by "srepl"
+                                                     :cause "explicit call to restore-team!"}
+                                    ::audit/tracked-at (dt/now)})
+
+                    (restore-project* system project-id))))))
+
+(defn delete-team!
+  "Mark a team for deletion"
+  [team-id]
+  (let [team-id (h/parse-uuid team-id)
+        tnow    (dt/now)]
+
+    (audit/insert! main/system
+                   {::audit/name "delete-team"
+                    ::audit/type "action"
+                    ::audit/profile-id uuid/zero
+                    ::audit/props {:id team-id}
+                    ::audit/context {:triggered-by "srepl"
+                                     :cause "explicit call to delete-profile!"}
+                    ::audit/tracked-at tnow})
+
+    (wrk/invoke! (-> main/system
+                     (assoc ::wrk/task :delete-object)
+                     (assoc ::wrk/params {:object :team
+                                          :deleted-at tnow
+                                          :id team-id})))
+    :deleted))
+
+(defn- restore-team*
+  [{:keys [::db/conn] :as cfg} team-id]
+  (db/update! conn :team
+              {:deleted-at nil}
+              {:id team-id})
+
+  (db/update! conn :team-font-variant
+              {:deleted-at nil}
+              {:team-id team-id})
+
+  (doseq [{:keys [id]} (db/query conn :project
+                                 {:team-id team-id}
+                                 {::sql/columns [:id]})]
+    (restore-project* cfg id))
+
+  :restored)
+
+(defn restore-team!
+  "Mark a team and all related objects as not deleted"
+  [team-id]
+  (let [team-id (h/parse-uuid team-id)]
+    (db/tx-run! main/system
+                (fn [system]
+                  (when-let [team (some-> (db/get* system :team
+                                                   {:id team-id}
+                                                   {::db/remove-deleted false})
+                                          (teams/decode-row))]
+                    (audit/insert! system
+                                   {::audit/name "restore-team"
+                                    ::audit/type "action"
+                                    ::audit/profile-id uuid/zero
+                                    ::audit/props team
+                                    ::audit/context {:triggered-by "srepl"
+                                                     :cause "explicit call to restore-team!"}
+                                    ::audit/tracked-at (dt/now)})
+
+                    (restore-team* system team-id))))))
+
+(defn delete-profile!
+  "Mark a profile for deletion."
+  [profile-id]
+  (let [profile-id (h/parse-uuid profile-id)
+        tnow       (dt/now)]
+
+    (audit/insert! main/system
+                   {::audit/name "delete-profile"
+                    ::audit/type "action"
+                    ::audit/profile-id uuid/zero
+                    ::audit/context {:triggered-by "srepl"
+                                     :cause "explicit call to delete-profile!"}
+                    ::audit/tracked-at tnow})
+
+    (wrk/invoke! (-> main/system
+                     (assoc ::wrk/task :delete-object)
+                     (assoc ::wrk/params {:object :profile
+                                          :deleted-at tnow
+                                          :id profile-id})))
+    :deleted))
+
+(defn restore-profile!
+  "Mark a team and all related objects as not deleted"
+  [profile-id]
+  (let [profile-id (h/parse-uuid profile-id)]
+    (db/tx-run! main/system
+                (fn [system]
+                  (when-let [profile (some-> (db/get* system :profile
+                                                      {:id profile-id}
+                                                      {::db/remove-deleted false})
+                                             (profile/decode-row))]
+                    (audit/insert! system
+                                   {::audit/name "restore-profile"
+                                    ::audit/type "action"
+                                    ::audit/profile-id uuid/zero
+                                    ::audit/props (audit/profile->props profile)
+                                    ::audit/context {:triggered-by "srepl"
+                                                     :cause "explicit call to restore-profile!"}
+                                    ::audit/tracked-at (dt/now)})
+
+                    (db/update! system :profile
+                                {:deleted-at nil}
+                                {:id profile-id}
+                                {::db/return-keys false})
+
+                    (doseq [{:keys [id]} (profile/get-owned-teams system profile-id)]
+                      (restore-team* system id))
+
+                    :restored)))))
+
+(defn delete-profiles-in-bulk!
+  [system path]
+  (letfn [(process-data! [system deleted-at emails]
+            (loop [emails  emails
+                   deleted 0
+                   total   0]
+              (if-let [email (first emails)]
+                (if-let [profile (db/get* system :profile
+                                          {:email (str/lower email)}
+                                          {::db/remove-deleted false})]
+                  (do
+                    (audit/insert! system
+                                   {::audit/name "delete-profile"
+                                    ::audit/type "action"
+                                    ::audit/tracked-at deleted-at
+                                    ::audit/props (audit/profile->props profile)
+                                    ::audit/context {:triggered-by "srepl"
+                                                     :cause "explicit call to delete-profiles-in-bulk!"}})
+                    (wrk/invoke! (-> system
+                                     (assoc ::wrk/task :delete-object)
+                                     (assoc ::wrk/params {:object :profile
+                                                          :deleted-at deleted-at
+                                                          :id (:id profile)})))
+                    (recur (rest emails)
+                           (inc deleted)
+                           (inc total)))
+                  (recur (rest emails)
+                         deleted
+                         (inc total)))
+                {:deleted deleted :total total})))]
+
+    (let [path       (fs/path path)
+          deleted-at (dt/minus (dt/now) cf/deletion-delay)]
+
+      (when-not (fs/exists? path)
+        (throw (ex-info "path does not exists" {:path path})))
+
+      (db/tx-run! system
+                  (fn [system]
+                    (with-open [reader (io/reader path)]
+                      (process-data! system deleted-at (line-seq reader))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; CASCADE FIXING
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn process-deleted-profiles-cascade
+  []
+  (->> (db/exec! main/system ["select id, deleted_at from profile where deleted_at is not null"])
+       (run! (fn [{:keys [id deleted-at]}]
+               (wrk/invoke! (-> main/system
+                                (assoc ::wrk/task :delete-object)
+                                (assoc ::wrk/params {:object :profile
+                                                     :deleted-at deleted-at
+                                                     :id id})))))))
+
+(defn process-deleted-teams-cascade
+  []
+  (->> (db/exec! main/system ["select id, deleted_at from team where deleted_at is not null"])
+       (run! (fn [{:keys [id deleted-at]}]
+               (wrk/invoke! (-> main/system
+                                (assoc ::wrk/task :delete-object)
+                                (assoc ::wrk/params {:object :team
+                                                     :deleted-at deleted-at
+                                                     :id id})))))))
+
+(defn process-deleted-projects-cascade
+  []
+  (->> (db/exec! main/system ["select id, deleted_at from project where deleted_at is not null"])
+       (run! (fn [{:keys [id deleted-at]}]
+               (wrk/invoke! (-> main/system
+                                (assoc ::wrk/task :delete-object)
+                                (assoc ::wrk/params {:object :project
+                                                     :deleted-at deleted-at
+                                                     :id id})))))))
+
+(defn process-deleted-files-cascade
+  []
+  (->> (db/exec! main/system ["select id, deleted_at from file where deleted_at is not null"])
+       (run! (fn [{:keys [id deleted-at]}]
+               (wrk/invoke! (-> main/system
+                                (assoc ::wrk/task :delete-object)
+                                (assoc ::wrk/params {:object :file
+                                                     :deleted-at deleted-at
+                                                     :id id})))))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; MISC
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

backend/src/app/storage.clj

@@ -16,7 +16,6 @@
    [app.storage.impl :as impl]
    [app.storage.s3 :as ss3]
    [app.util.time :as dt]
-   [app.worker :as wrk]
    [clojure.spec.alpha :as s]
    [datoteka.fs :as fs]
    [integrant.core :as ig]
@@ -171,28 +170,16 @@
           (impl/put-object object content))
       object)))
 
-(def ^:private default-touch-delay
-  "A default delay for the asynchronous touch operation"
-  (dt/duration "5m"))
-
 (defn touch-object!
   "Mark object as touched."
-  [{:keys [::db/pool-or-conn] :as storage} object-or-id & {:keys [async]}]
+  [{:keys [::db/pool-or-conn] :as storage} object-or-id]
   (us/assert! ::storage storage)
   (let [id (if (impl/object? object-or-id) (:id object-or-id) object-or-id)]
-    (if async
-      (wrk/submit! ::wrk/conn pool-or-conn
-                   ::wrk/task :object-update
-                   ::wrk/delay default-touch-delay
-                   :object :storage-object
-                   :id id
-                   :key :touched-at
-                   :val (dt/now))
-      (-> (db/update! pool-or-conn :storage-object
-                      {:touched-at (dt/now)}
-                      {:id id})
-          (db/get-update-count)
-          (pos?)))))
+    (-> (db/update! pool-or-conn :storage-object
+                    {:touched-at (dt/now)}
+                    {:id id})
+        (db/get-update-count)
+        (pos?))))
 
 (defn get-object-data
   "Return an input stream instance of the object content."

backend/src/app/storage/gc_deleted.clj

@@ -110,8 +110,8 @@
 
 (defmethod ig/init-key ::handler
   [_ {:keys [::min-age] :as cfg}]
-  (fn [params]
-    (let [min-age (dt/duration (or (:min-age params) min-age))]
+  (fn [{:keys [props] :as task}]
+    (let [min-age (dt/duration (or (:min-age props) min-age))]
       (db/tx-run! cfg (fn [cfg]
                         (let [cfg   (assoc cfg ::min-age min-age)
                               total (clean-deleted! cfg)]

backend/src/app/tasks/delete_object.clj

@@ -0,0 +1,122 @@
+;; 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.tasks.delete-object
+  "A generic task for object deletion cascade handling"
+  (:require
+   [app.common.logging :as l]
+   [app.db :as db]
+   [app.rpc.commands.files :as files]
+   [app.rpc.commands.profile :as profile]
+   [app.util.time :as dt]
+   [clojure.spec.alpha :as s]
+   [integrant.core :as ig]))
+
+(def ^:dynamic *team-deletion* false)
+
+(defmulti delete-object
+  (fn [_ props] (:object props)))
+
+(defmethod delete-object :file
+  [{:keys [::db/conn] :as cfg} {:keys [id deleted-at]}]
+  (when-let [file (db/get* conn :file {:id id} {::db/remove-deleted false})]
+    (l/trc :hint "marking for deletion" :rel "file" :id (str id)
+           :deleted-at (dt/format-instant deleted-at))
+
+    (db/update! conn :file
+                {:deleted-at deleted-at}
+                {:id id}
+                {::db/return-keys false})
+
+    (when (and (:is-shared file)
+               (not *team-deletion*))
+      ;; NOTE: we don't prevent file deletion on absorb operation failure
+      (try
+        (db/tx-run! cfg files/absorb-library! id)
+        (catch Throwable cause
+          (l/warn :hint "error on absorbing library"
+                  :file-id id
+                  :cause cause))))
+
+    ;; Mark file media objects to be deleted
+    (db/update! conn :file-media-object
+                {:deleted-at deleted-at}
+                {:file-id id})
+
+    ;; Mark thumbnails to be deleted
+    (db/update! conn :file-thumbnail
+                {:deleted-at deleted-at}
+                {:file-id id})
+
+    (db/update! conn :file-tagged-object-thumbnail
+                {:deleted-at deleted-at}
+                {:file-id id})))
+
+(defmethod delete-object :project
+  [{:keys [::db/conn] :as cfg} {:keys [id deleted-at]}]
+  (l/trc :hint "marking for deletion" :rel "project" :id (str id)
+         :deleted-at (dt/format-instant deleted-at))
+
+  (db/update! conn :project
+              {:deleted-at deleted-at}
+              {:id id}
+              {::db/return-keys false})
+
+  (doseq [file (db/query conn :file
+                         {:project-id id}
+                         {::db/columns [:id :deleted-at]})]
+    (delete-object cfg (assoc file
+                              :object :file
+                              :deleted-at deleted-at))))
+
+(defmethod delete-object :team
+  [{:keys [::db/conn] :as cfg} {:keys [id deleted-at]}]
+  (l/trc :hint "marking for deletion" :rel "team" :id (str id)
+         :deleted-at (dt/format-instant deleted-at))
+  (db/update! conn :team
+              {:deleted-at deleted-at}
+              {:id id}
+              {::db/return-keys false})
+
+  (db/update! conn :team-font-variant
+              {:deleted-at deleted-at}
+              {:team-id id}
+              {::db/return-keys false})
+
+  (binding [*team-deletion* true]
+    (doseq [project (db/query conn :project
+                              {:team-id id}
+                              {::db/columns [:id :deleted-at]})]
+      (delete-object cfg (assoc project
+                                :object :project
+                                :deleted-at deleted-at)))))
+
+(defmethod delete-object :profile
+  [{:keys [::db/conn] :as cfg} {:keys [id deleted-at]}]
+  (l/trc :hint "marking for deletion" :rel "profile" :id (str id)
+         :deleted-at (dt/format-instant deleted-at))
+
+  (db/update! conn :profile
+              {:deleted-at deleted-at}
+              {:id id}
+              {::db/return-keys false})
+
+  (doseq [team (profile/get-owned-teams conn id)]
+    (delete-object cfg (assoc team
+                              :object :team
+                              :deleted-at deleted-at))))
+
+(defmethod delete-object :default
+  [_cfg props]
+  (l/wrn :hint "not implementation found" :rel (:object props)))
+
+(defmethod ig/pre-init-spec ::handler [_]
+  (s/keys :req [::db/pool]))
+
+(defmethod ig/init-key ::handler
+  [_ cfg]
+  (fn [{:keys [props] :as task}]
+    (db/tx-run! cfg delete-object props)))

backend/src/app/tasks/file_gc.clj

@@ -299,13 +299,13 @@
 
 (defmethod ig/init-key ::handler
   [_ cfg]
-  (fn [{:keys [file-id] :as params}]
+  (fn [{:keys [props] :as task}]
     (db/tx-run! cfg
                 (fn [{:keys [::db/conn] :as cfg}]
-                  (let [min-age (dt/duration (or (:min-age params) (::min-age cfg)))
+                  (let [min-age (dt/duration (or (:min-age props) (::min-age cfg)))
                         cfg     (-> cfg
                                     (update ::sto/storage media/configure-assets-storage conn)
-                                    (assoc ::file-id file-id)
+                                    (assoc ::file-id (:file-id props))
                                     (assoc ::min-age min-age))
 
                         total   (reduce (fn [total file]
@@ -319,7 +319,7 @@
                            :processed total)
 
                     ;; Allow optional rollback passed by params
-                    (when (:rollback? params)
+                    (when (:rollback? props)
                       (db/rollback! conn))
 
                     {:processed total})))))

backend/src/app/tasks/file_xlog_gc.clj

@@ -29,8 +29,8 @@
 
 (defmethod ig/init-key ::handler
   [_ {:keys [::db/pool] :as cfg}]
-  (fn [params]
-    (let [min-age (or (:min-age params) (::min-age cfg))]
+  (fn [{:keys [props] :as task}]
+    (let [min-age (or (:min-age props) (::min-age cfg))]
       (db/with-atomic [conn pool]
         (let [interval (db/interval min-age)
               result   (db/exec-one! conn [sql:delete-files-xlog interval])
@@ -38,7 +38,7 @@
 
           (l/info :hint "task finished" :min-age (dt/format-duration min-age) :total result)
 
-          (when (:rollback? params)
+          (when (:rollback? props)
             (db/rollback! conn))
 
           result)))))

backend/src/app/tasks/object_update.clj

@@ -1,32 +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.tasks.object-update
-  "A task used for perform simple object properties update
-  in an asynchronous flow."
-  (:require
-   [app.common.data :as d]
-   [app.common.logging :as l]
-   [app.db :as db]
-   [clojure.spec.alpha :as s]
-   [integrant.core :as ig]))
-
-(defn- update-object
-  [{:keys [::db/conn] :as cfg} {:keys [id object key val] :as props}]
-  (l/trc :hint "update object prop"
-         :id (str id)
-         :object (d/name object)
-         :key (d/name key)
-         :val val)
-  (db/update! conn object {key val} {:id id} {::db/return-keys false}))
-
-(defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req [::db/pool]))
-
-(defmethod ig/init-key ::handler
-  [_ cfg]
-  (fn [{:keys [props] :as params}]
-    (db/tx-run! cfg update-object props)))

backend/src/app/tasks/objects_gc.clj

@@ -17,78 +17,24 @@
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]))
 
-(declare ^:private delete-file-data-fragments!)
-(declare ^:private delete-file-media-objects!)
-(declare ^:private delete-file-object-thumbnails!)
-(declare ^:private delete-file-thumbnails!)
-(declare ^:private delete-files!)
-(declare ^:private delete-fonts!)
-(declare ^:private delete-profiles!)
-(declare ^:private delete-projects!)
-(declare ^:private delete-teams!)
-
-(defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req [::db/pool ::sto/storage]))
-
-(defmethod ig/prep-key ::handler
-  [_ cfg]
-  (assoc cfg ::min-age cf/deletion-delay))
-
-(defmethod ig/init-key ::handler
-  [_ cfg]
-  (fn [params]
-    (db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
-                      ;; Disable deletion protection for the current transaction
-                      (db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
-                      (db/exec-one! conn ["SET CONSTRAINTS ALL DEFERRED"])
-
-                      (let [min-age (dt/duration (or (:min-age params) (::min-age cfg)))
-                            cfg     (-> cfg
-                                        (assoc ::min-age (db/interval min-age))
-                                        (update ::sto/storage media/configure-assets-storage conn))
-
-                            total   (reduce + 0
-                                            [(delete-profiles! cfg)
-                                             (delete-teams! cfg)
-                                             (delete-fonts! cfg)
-                                             (delete-projects! cfg)
-                                             (delete-files! cfg)
-                                             (delete-file-thumbnails! cfg)
-                                             (delete-file-object-thumbnails! cfg)
-                                             (delete-file-data-fragments! cfg)
-                                             (delete-file-media-objects! cfg)])]
-
-                        (l/info :hint "task finished"
-                                :deleted total
-                                :rollback? (boolean (:rollback? params)))
-
-                        (when (:rollback? params)
-                          (db/rollback! conn))
-
-                        {:processed total})))))
-
 (def ^:private sql:get-profiles
   "SELECT id, photo_id FROM profile
     WHERE deleted_at IS NOT NULL
       AND deleted_at < now() - ?::interval
     ORDER BY deleted_at ASC
+    LIMIT ?
       FOR UPDATE
      SKIP LOCKED")
 
 (defn- delete-profiles!
-  [{:keys [::db/conn ::min-age ::sto/storage] :as cfg}]
-  (->> (db/cursor conn [sql:get-profiles min-age])
+  [{:keys [::db/conn ::min-age ::chunk-size ::sto/storage] :as cfg}]
+  (->> (db/cursor conn [sql:get-profiles min-age chunk-size] {:chunk-size 1})
        (reduce (fn [total {:keys [id photo-id]}]
                  (l/trc :hint "permanently delete" :rel "profile" :id (str id))
 
                  ;; Mark as deleted the storage object
                  (some->> photo-id (sto/touch-object! storage))
 
-                 ;; And finally, permanently delete the profile. The
-                 ;; relevant objects will be deleted using DELETE
-                 ;; CASCADE database triggers. This may leave orphan
-                 ;; teams, but there is a special task for deleting
-                 ;; orphaned teams.
                  (db/delete! conn :profile {:id id})
 
                  (inc total))
@@ -99,13 +45,13 @@
     WHERE deleted_at IS NOT NULL
       AND deleted_at < now() - ?::interval
     ORDER BY deleted_at ASC
+    LIMIT ?
       FOR UPDATE
      SKIP LOCKED")
 
 (defn- delete-teams!
-  [{:keys [::db/conn ::min-age ::sto/storage] :as cfg}]
-
-  (->> (db/cursor conn [sql:get-teams min-age])
+  [{:keys [::db/conn ::min-age ::chunk-size ::sto/storage] :as cfg}]
+  (->> (db/cursor conn [sql:get-teams min-age chunk-size] {:chunk-size 1})
        (reduce (fn [total {:keys [id photo-id deleted-at]}]
                  (l/trc :hint "permanently delete"
                         :rel "team"
@@ -118,15 +64,6 @@
                  ;; And finally, permanently delete the team.
                  (db/delete! conn :team {:id id})
 
-                 ;; Mark for deletion in cascade
-                 (db/update! conn :team-font-variant
-                             {:deleted-at deleted-at}
-                             {:team-id id})
-
-                 (db/update! conn :project
-                             {:deleted-at deleted-at}
-                             {:team-id id})
-
                  (inc total))
                0)))
 
@@ -136,12 +73,13 @@
     WHERE deleted_at IS NOT NULL
       AND deleted_at < now() - ?::interval
     ORDER BY deleted_at ASC
+    LIMIT ?
       FOR UPDATE
      SKIP LOCKED")
 
 (defn- delete-fonts!
-  [{:keys [::db/conn ::min-age ::sto/storage] :as cfg}]
-  (->> (db/cursor conn [sql:get-fonts min-age])
+  [{:keys [::db/conn ::min-age ::chunk-size ::sto/storage] :as cfg}]
+  (->> (db/cursor conn [sql:get-fonts min-age chunk-size] {:chunk-size 1})
        (reduce (fn [total {:keys [id team-id deleted-at] :as font}]
                  (l/trc :hint "permanently delete"
                         :rel "team-font-variant"
@@ -167,12 +105,13 @@
     WHERE deleted_at IS NOT NULL
       AND deleted_at < now() - ?::interval
     ORDER BY deleted_at ASC
+    LIMIT ?
       FOR UPDATE
      SKIP LOCKED")
 
 (defn- delete-projects!
-  [{:keys [::db/conn ::min-age] :as cfg}]
-  (->> (db/cursor conn [sql:get-projects min-age])
+  [{:keys [::db/conn ::min-age ::chunk-size] :as cfg}]
+  (->> (db/cursor conn [sql:get-projects min-age chunk-size] {:chunk-size 1})
        (reduce (fn [total {:keys [id team-id deleted-at]}]
                  (l/trc :hint "permanently delete"
                         :rel "project"
@@ -183,11 +122,6 @@
                  ;; And finally, permanently delete the project.
                  (db/delete! conn :project {:id id})
 
-                 ;; Mark files to be deleted
-                 (db/update! conn :file
-                             {:deleted-at deleted-at}
-                             {:project-id id})
-
                  (inc total))
                0)))
 
@@ -197,12 +131,13 @@
     WHERE deleted_at IS NOT NULL
       AND deleted_at < now() - ?::interval
     ORDER BY deleted_at ASC
+    LIMIT ?
       FOR UPDATE
      SKIP LOCKED")
 
 (defn- delete-files!
-  [{:keys [::db/conn ::min-age] :as cfg}]
-  (->> (db/cursor conn [sql:get-files min-age])
+  [{:keys [::db/conn ::min-age ::chunk-size] :as cfg}]
+  (->> (db/cursor conn [sql:get-files min-age chunk-size] {:chunk-size 1})
        (reduce (fn [total {:keys [id deleted-at project-id]}]
                  (l/trc :hint "permanently delete"
                         :rel "file"
@@ -210,26 +145,9 @@
                         :project-id (str project-id)
                         :deleted-at (dt/format-instant deleted-at))
 
-                 ;; NOTE: fragments not handled here because they have
-                 ;; cascade.
-
                  ;; And finally, permanently delete the file.
                  (db/delete! conn :file {:id id})
 
-                 ;; Mark file media objects to be deleted
-                 (db/update! conn :file-media-object
-                             {:deleted-at deleted-at}
-                             {:file-id id})
-
-                 ;; Mark thumbnails to be deleted
-                 (db/update! conn :file-thumbnail
-                             {:deleted-at deleted-at}
-                             {:file-id id})
-
-                 (db/update! conn :file-tagged-object-thumbnail
-                             {:deleted-at deleted-at}
-                             {:file-id id})
-
                  (inc total))
                0)))
 
@@ -239,12 +157,13 @@
     WHERE deleted_at IS NOT NULL
       AND deleted_at < now() - ?::interval
     ORDER BY deleted_at ASC
+    LIMIT ?
       FOR UPDATE
      SKIP LOCKED")
 
 (defn delete-file-thumbnails!
-  [{:keys [::db/conn ::min-age ::sto/storage] :as cfg}]
-  (->> (db/cursor conn [sql:get-file-thumbnails min-age])
+  [{:keys [::db/conn ::min-age ::chunk-size ::sto/storage] :as cfg}]
+  (->> (db/cursor conn [sql:get-file-thumbnails min-age chunk-size] {:chunk-size 1})
        (reduce (fn [total {:keys [file-id revn media-id deleted-at]}]
                  (l/trc :hint "permanently delete"
                         :rel "file-thumbnail"
@@ -267,12 +186,13 @@
     WHERE deleted_at IS NOT NULL
       AND deleted_at < now() - ?::interval
     ORDER BY deleted_at ASC
+    LIMIT ?
       FOR UPDATE
      SKIP LOCKED")
 
 (defn delete-file-object-thumbnails!
-  [{:keys [::db/conn ::min-age ::sto/storage] :as cfg}]
-  (->> (db/cursor conn [sql:get-file-object-thumbnails min-age])
+  [{:keys [::db/conn ::min-age ::chunk-size ::sto/storage] :as cfg}]
+  (->> (db/cursor conn [sql:get-file-object-thumbnails min-age chunk-size] {:chunk-size 1})
        (reduce (fn [total {:keys [file-id object-id media-id deleted-at]}]
                  (l/trc :hint "permanently delete"
                         :rel "file-tagged-object-thumbnail"
@@ -295,12 +215,13 @@
     WHERE deleted_at IS NOT NULL
       AND deleted_at < now() - ?::interval
     ORDER BY deleted_at ASC
+    LIMIT ?
       FOR UPDATE
      SKIP LOCKED")
 
 (defn- delete-file-data-fragments!
-  [{:keys [::db/conn ::min-age] :as cfg}]
-  (->> (db/cursor conn [sql:get-file-data-fragments min-age])
+  [{:keys [::db/conn ::min-age ::chunk-size] :as cfg}]
+  (->> (db/cursor conn [sql:get-file-data-fragments min-age chunk-size] {:chunk-size 1})
        (reduce (fn [total {:keys [file-id id deleted-at]}]
                  (l/trc :hint "permanently delete"
                         :rel "file-data-fragment"
@@ -319,12 +240,13 @@
     WHERE deleted_at IS NOT NULL
       AND deleted_at < now() - ?::interval
     ORDER BY deleted_at ASC
+    LIMIT ?
       FOR UPDATE
      SKIP LOCKED")
 
 (defn- delete-file-media-objects!
-  [{:keys [::db/conn ::min-age ::sto/storage] :as cfg}]
-  (->> (db/cursor conn [sql:get-file-media-objects min-age])
+  [{:keys [::db/conn ::min-age ::chunk-size ::sto/storage] :as cfg}]
+  (->> (db/cursor conn [sql:get-file-media-objects min-age chunk-size] {:chunk-size 1})
        (reduce (fn [total {:keys [id file-id deleted-at] :as fmo}]
                  (l/trc :hint "permanently delete"
                         :rel "file-media-object"
@@ -340,3 +262,53 @@
 
                  (inc total))
                0)))
+
+(def ^:private deletion-proc-vars
+  [#'delete-profiles!
+   #'delete-file-media-objects!
+   #'delete-file-data-fragments!
+   #'delete-file-object-thumbnails!
+   #'delete-file-thumbnails!
+   #'delete-files!
+   #'delete-projects!
+   #'delete-fonts!
+   #'delete-teams!])
+
+(defn- execute-proc!
+  "A generic function that executes the specified proc iterativelly
+  until 0 results is returned"
+  [cfg proc-fn]
+  (loop [total 0]
+    (let [result (db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
+                                   (db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
+                                   (proc-fn cfg)))]
+      (if (pos? result)
+        (recur (+ total result))
+        total))))
+
+(defmethod ig/pre-init-spec ::handler [_]
+  (s/keys :req [::db/pool ::sto/storage]))
+
+(defmethod ig/prep-key ::handler
+  [_ cfg]
+  (assoc cfg
+         ::min-age cf/deletion-delay
+         ::chunk-size 10))
+
+(defmethod ig/init-key ::handler
+  [_ cfg]
+  (fn [{:keys [props] :as task}]
+    (let [min-age (dt/duration (or (:min-age props) (::min-age cfg)))
+          cfg     (-> cfg
+                      (assoc ::min-age (db/interval min-age))
+                      (update ::sto/storage media/configure-assets-storage))]
+
+      (loop [procs (map deref deletion-proc-vars)
+             total 0]
+        (if-let [proc-fn (first procs)]
+          (let [result (execute-proc! cfg proc-fn)]
+            (recur (rest procs)
+                   (+ total result)))
+          (do
+            (l/inf :hint "task finished" :deleted total)
+            {:processed total}))))))

backend/src/app/tasks/orphan_teams_gc.clj

@@ -1,59 +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.tasks.orphan-teams-gc
-  "A maintenance task that performs orphan teams GC."
-  (:require
-   [app.common.logging :as l]
-   [app.db :as db]
-   [app.util.time :as dt]
-   [clojure.spec.alpha :as s]
-   [integrant.core :as ig]))
-
-(declare ^:private delete-orphan-teams!)
-
-(defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req [::db/pool]))
-
-(defmethod ig/init-key ::handler
-  [_ cfg]
-  (fn [params]
-    (db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
-                      (l/inf :hint "gc started" :rollback? (boolean (:rollback? params)))
-                      (let [total (delete-orphan-teams! cfg)]
-                        (l/inf :hint "task finished"
-                               :teams total
-                               :rollback? (boolean (:rollback? params)))
-
-                        (when (:rollback? params)
-                          (db/rollback! conn))
-
-                        {:processed total})))))
-
-(def ^:private sql:get-orphan-teams
-  "SELECT t.id
-     FROM team AS t
-     LEFT JOIN team_profile_rel AS tpr
-            ON (t.id = tpr.team_id)
-    WHERE tpr.profile_id IS NULL
-      AND t.deleted_at IS NULL
-    ORDER BY t.created_at ASC
-      FOR UPDATE OF t
-     SKIP LOCKED")
-
-(defn- delete-orphan-teams!
-  "Find all orphan teams (with no members) and mark them for
-  deletion (soft delete)."
-  [{:keys [::db/conn] :as cfg}]
-  (->> (db/cursor conn sql:get-orphan-teams)
-       (map :id)
-       (reduce (fn [total team-id]
-                 (l/trc :hint "mark orphan team for deletion" :id (str team-id))
-                 (db/update! conn :team
-                             {:deleted-at (dt/now)}
-                             {:id team-id})
-                 (inc total))
-               0)))

backend/src/app/tasks/tasks_gc.clj

@@ -27,8 +27,8 @@
 
 (defmethod ig/init-key ::handler
   [_ {:keys [::db/pool ::min-age] :as cfg}]
-  (fn [params]
-    (let [min-age (or (:min-age params) min-age)]
+  (fn [{:keys [props] :as task}]
+    (let [min-age (or (:min-age props) min-age)]
       (db/with-atomic [conn pool]
         (let [interval (db/interval min-age)
               result   (db/exec-one! conn [sql:delete-completed-tasks interval])
@@ -36,7 +36,7 @@
 
           (l/debug :hint "task finished" :total result)
 
-          (when (:rollback? params)
+          (when (:rollback? props)
             (db/rollback! conn))
 
           result)))))

backend/src/app/tasks/telemetry.clj

@@ -206,14 +206,16 @@
 
 (defmethod ig/init-key ::handler
   [_ {:keys [::db/pool ::setup/props] :as cfg}]
-  (fn [{:keys [send? enabled?] :or {send? true enabled? false}}]
-    (let [subs     {:newsletter-updates (get-subscriptions-newsletter-updates pool)
-                    :newsletter-news (get-subscriptions-newsletter-news pool)}
-
-          enabled? (or enabled?
+  (fn [task]
+    (let [params   (:props task)
+          send?    (get params :send? true)
+          enabled? (or (get params :enabled? false)
                        (contains? cf/flags :telemetry)
                        (cf/get :telemetry-enabled))
 
+          subs     {:newsletter-updates (get-subscriptions-newsletter-updates pool)
+                    :newsletter-news (get-subscriptions-newsletter-news pool)}
+
           data     {:subscriptions subs
                     :version (:full cf/version)
                     :instance-id (:instance-id props)}]

backend/src/app/tokens.clj

@@ -8,18 +8,19 @@
   "Tokens generation API."
   (:require
    [app.common.data :as d]
+   [app.common.data.macros :as dm]
    [app.common.exceptions :as ex]
-   [app.common.spec :as us]
    [app.common.transit :as t]
    [app.util.time :as dt]
-   [buddy.sign.jwe :as jwe]
-   [clojure.spec.alpha :as s]))
-
-(s/def ::tokens-key bytes?)
+   [buddy.sign.jwe :as jwe]))
 
 (defn generate
   [{:keys [tokens-key]} claims]
-  (us/assert! ::tokens-key tokens-key)
+
+  (dm/assert!
+   "expexted token-key to be bytes instance"
+   (bytes? tokens-key))
+
   (let [payload (-> claims
                     (assoc :iat (dt/now))
                     (d/without-nils)
@@ -39,15 +40,13 @@
       (ex/raise :type :validation
                 :code :invalid-token
                 :reason :token-expired
-                :params params
-                :claims claims))
+                :params params))
     (when (and (contains? params :iss)
                (not= (:iss claims)
                      (:iss params)))
       (ex/raise :type :validation
                 :code :invalid-token
                 :reason :invalid-issuer
-                :claims claims
                 :params params))
     claims))
 

backend/src/app/util/inet.clj

@@ -0,0 +1,37 @@
+;; 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.inet
+  "INET addr parsing and validation helpers"
+  (:require
+   [cuerdas.core :as str]
+   [ring.request :as rreq])
+  (:import
+   com.google.common.net.InetAddresses
+   java.net.InetAddress))
+
+(defn valid?
+  [s]
+  (InetAddresses/isInetAddress s))
+
+(defn normalize
+  [s]
+  (try
+    (let [addr (InetAddresses/forString s)]
+      (.getHostAddress ^InetAddress addr))
+    (catch Throwable _cause
+      nil)))
+
+(defn parse-request
+  [request]
+  (or (some-> (rreq/get-header request "x-real-ip")
+              (normalize))
+      (some-> (rreq/get-header request "x-forwarded-for")
+              (str/split #"\s*,\s*")
+              (first)
+              (normalize))
+      (some-> (rreq/remote-addr request)
+              (normalize))))

backend/src/app/util/objects_map.clj

@@ -19,7 +19,8 @@
    [app.common.fressian :as fres]
    [app.common.transit :as t]
    [app.common.uuid :as uuid]
-   [clojure.core :as c])
+   [clojure.core :as c]
+   [clojure.data.json :as json])
   (:import
    clojure.lang.Counted
    clojure.lang.IHashEq
@@ -83,6 +84,10 @@
                      ^:unsynchronized-mutable loaded?
                      ^:unsynchronized-mutable modified?]
 
+  json/JSONWriter
+  (-write [this writter options]
+    (json/-write (into {} this) writter options))
+
   IHashEq
   (hasheq [this]
     (when-not hash

backend/src/app/util/pointer_map.clj

@@ -40,7 +40,8 @@
    [app.common.transit :as t]
    [app.common.uuid :as uuid]
    [app.util.time :as dt]
-   [clojure.core :as c])
+   [clojure.core :as c]
+   [clojure.data.json :as json])
   (:import
    clojure.lang.Counted
    clojure.lang.IDeref
@@ -75,6 +76,14 @@
                      ^:unsynchronized-mutable modified?
                      ^:unsynchronized-mutable loaded?]
 
+  json/JSONWriter
+  (-write [this writter options]
+    (json/-write {:type "pointer"
+                  :id (get-id this)
+                  :meta (meta this)}
+                 writter
+                 options))
+
   IPointerMap
   (load! [_]
     (when-not *load-fn*

backend/src/app/util/websocket.clj

@@ -11,7 +11,7 @@
    [app.common.logging :as l]
    [app.common.transit :as t]
    [app.common.uuid :as uuid]
-   [app.loggers.audit :refer [parse-client-ip]]
+   [app.util.inet :as inet]
    [app.util.time :as dt]
    [promesa.exec :as px]
    [promesa.exec.csp :as sp]
@@ -84,7 +84,7 @@
         output-ch  (sp/chan :buf output-buff-size)
         hbeat-ch   (sp/chan :buf (sp/sliding-buffer 6))
         close-ch   (sp/chan)
-        ip-addr    (parse-client-ip request)
+        ip-addr    (inet/parse-request request)
         uagent     (rreq/get-header request "user-agent")
         id         (uuid/next)
         state      (atom {})

backend/src/app/worker.clj

@@ -8,6 +8,7 @@
   "Async tasks abstraction (impl)."
   (:require
    [app.common.data :as d]
+   [app.common.data.macros :as dm]
    [app.common.logging :as l]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
@@ -58,17 +59,6 @@
 ;; SUBMIT API
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defn- extract-props
-  [options]
-  (let [cns (namespace ::sample)]
-    (persistent!
-     (reduce-kv (fn [res k v]
-                  (cond-> res
-                    (not= (namespace k) cns)
-                    (assoc! k v)))
-                (transient {})
-                options))))
-
 (def ^:private sql:insert-new-task
   "insert into task (id, name, props, queue, label, priority, max_retries, scheduled_at)
    values (?, ?, ?, ?, ?, ?, ?, now() + ?)
@@ -87,14 +77,13 @@
 (s/def ::task (s/or :kw keyword? :str string?))
 (s/def ::queue (s/or :kw keyword? :str string?))
 (s/def ::delay (s/or :int integer? :duration dt/duration?))
-(s/def ::conn (s/or :pool ::db/pool :connection some?))
 (s/def ::priority integer?)
 (s/def ::max-retries integer?)
 (s/def ::dedupe boolean?)
 
 (s/def ::submit-options
   (s/and
-   (s/keys :req [::task ::conn]
+   (s/keys :req [::task]
            :opt [::label ::delay ::queue ::priority ::max-retries ::dedupe])
    (fn [{:keys [::dedupe ::label] :or {label ""}}]
      (if dedupe
@@ -102,21 +91,23 @@
        true))))
 
 (defn submit!
-  [& {:keys [::task ::delay ::queue ::priority ::max-retries ::conn ::dedupe ::label]
+  [& {:keys [::params ::task ::delay ::queue ::priority ::max-retries ::dedupe ::label]
       :or {delay 0 queue :default priority 100 max-retries 3 label ""}
       :as options}]
 
   (us/verify! ::submit-options options)
   (let [duration  (dt/duration delay)
         interval  (db/interval duration)
-        props     (-> options extract-props db/tjson)
+        props     (db/tjson params)
         id        (uuid/next)
         tenant    (cf/get :tenant)
         task      (d/name task)
         queue     (str/ffmt "%:%" tenant (d/name queue))
+        conn      (db/get-connectable options)
         deleted   (when dedupe
                     (-> (db/exec-one! conn [sql:remove-not-started-tasks task queue label])
                         :next.jdbc/update-count))]
+
     (l/trc :hint "submit task"
            :name task
            :task-id (str id)
@@ -126,7 +117,13 @@
            :delay (dt/format-duration duration)
            :replace (or deleted 0))
 
-
     (db/exec-one! conn [sql:insert-new-task id task props queue
                         label priority max-retries interval])
     id))
+
+(defn invoke!
+  [{:keys [::task ::params] :as cfg}]
+  (assert (contains? cfg :app.worker/registry)
+          "missing worker registry on `cfg`")
+  (let [task-fn (dm/get-in cfg [:app.worker/registry (name task)])]
+    (task-fn {:props params})))

backend/src/app/worker/runner.clj

@@ -35,8 +35,92 @@
   [_ item]
   {:params item})
 
+(defn- get-task
+  [{:keys [::db/pool]} task-id]
+  (ex/try!
+   (some-> (db/get* pool :task {:id task-id})
+           (decode-task-row))))
+
+(defn- run-task
+  [{:keys [::wrk/registry ::id ::queue] :as cfg} task]
+  (try
+    (l/dbg :hint "start"
+           :name (:name task)
+           :task-id (str (:id task))
+           :queue queue
+           :runner-id id
+           :retry (:retry-num task))
+    (let [tpoint  (dt/tpoint)
+          task-fn (get registry (:name task))
+          result  (if task-fn
+                    (task-fn task)
+                    {:status :completed :task task})
+          elapsed (dt/format-duration (tpoint))]
+
+      (when-not task-fn
+        (l/wrn :hint "no task handler found" :name (:name task)))
+
+      (l/dbg :hint "end"
+             :name (:name task)
+             :task-id (str (:id task))
+             :queue queue
+             :runner-id id
+             :retry (:retry-num task)
+             :elapsed elapsed)
+
+      result)
+
+    (catch InterruptedException cause
+      (throw cause))
+    (catch Throwable cause
+      (let [edata (ex-data cause)]
+        (if (and (< (:retry-num task)
+                    (:max-retries task))
+                 (= ::retry (:type edata)))
+          (cond-> {:status :retry :task task :error cause}
+            (dt/duration? (:delay edata))
+            (assoc :delay (:delay edata))
+
+            (= ::noop (:strategy edata))
+            (assoc :inc-by 0))
+          (do
+            (l/err :hint "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})))))))
+
+(defn- run-task!
+  [{:keys [::rds/rconn ::id] :as cfg} task-id]
+  (loop [task (get-task cfg task-id)]
+    (cond
+      (ex/exception? task)
+      (if (or (db/connection-error? task)
+              (db/serialization-error? task))
+        (do
+          (l/wrn :hint "connection error on retrieving task from database (retrying in some instants)"
+                 :id id
+                 :cause task)
+          (px/sleep (::rds/timeout rconn))
+          (recur (get-task cfg task-id)))
+        (do
+          (l/err :hint "unhandled exception on retrieving task from database (retrying in some instants)"
+                 :id id
+                 :cause task)
+          (px/sleep (::rds/timeout rconn))
+          (recur (get-task cfg task-id))))
+
+      (nil? task)
+      (l/wrn :hint "no task found on the database"
+             :id id
+             :task-id task-id)
+
+      :else
+      (run-task cfg task))))
+
 (defn- run-worker-loop!
-  [{:keys [::db/pool ::rds/rconn ::wrk/registry ::timeout ::queue ::id]}]
+  [{:keys [::db/pool ::rds/rconn ::timeout ::queue] :as cfg}]
   (letfn [(handle-task-retry [{:keys [task error inc-by delay] :or {inc-by 1 delay 1000}}]
             (let [explain (ex-message error)
                   nretry  (+ (:retry-num task) inc-by)
@@ -82,88 +166,6 @@
                        :length (alength payload)
                        :cause cause))))
 
-          (handle-task [{:keys [name] :as task}]
-            (let [task-fn (get registry name)]
-              (if task-fn
-                (task-fn task)
-                (l/wrn :hint "no task handler found" :name name))
-              {:status :completed :task task}))
-
-          (handle-task-exception [cause task]
-            (let [edata (ex-data cause)]
-              (if (and (< (:retry-num task)
-                          (:max-retries task))
-                       (= ::retry (:type edata)))
-                (cond-> {:status :retry :task task :error cause}
-                  (dt/duration? (:delay edata))
-                  (assoc :delay (:delay edata))
-
-                  (= ::noop (:strategy edata))
-                  (assoc :inc-by 0))
-                (do
-                  (l/err :hint "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})))))
-
-          (get-task [task-id]
-            (ex/try!
-             (some-> (db/get* pool :task {:id task-id})
-                     (decode-task-row))))
-
-          (run-task [task-id]
-            (loop [task (get-task task-id)]
-              (cond
-                (ex/exception? task)
-                (if (or (db/connection-error? task)
-                        (db/serialization-error? task))
-                  (do
-                    (l/wrn :hint "connection error on retrieving task from database (retrying in some instants)"
-                           :id id
-                           :cause task)
-                    (px/sleep (::rds/timeout rconn))
-                    (recur (get-task task-id)))
-                  (do
-                    (l/err :hint "unhandled exception on retrieving task from database (retrying in some instants)"
-                           :id id
-                           :cause task)
-                    (px/sleep (::rds/timeout rconn))
-                    (recur (get-task task-id))))
-
-                (nil? task)
-                (l/wrn :hint "no task found on the database"
-                       :id id
-                       :task-id task-id)
-
-                :else
-                (try
-                  (l/dbg :hint "start"
-                         :name (:name task)
-                         :task-id (str task-id)
-                         :queue queue
-                         :runner-id id
-                         :retry (:retry-num task))
-                  (let [tpoint  (dt/tpoint)
-                        result  (handle-task task)
-                        elapsed (dt/format-duration (tpoint))]
-
-                    (l/dbg :hint "end"
-                           :name (:name task)
-                           :task-id (str task-id)
-                           :queue queue
-                           :runner-id id
-                           :retry (:retry-num task)
-                           :elapsed elapsed)
-
-                    result)
-
-                  (catch InterruptedException cause
-                    (throw cause))
-                  (catch Throwable cause
-                    (handle-task-exception cause task))))))
-
           (process-result [{:keys [status] :as result}]
             (ex/try!
              (case status
@@ -173,7 +175,7 @@
                nil)))
 
           (run-task-loop [task-id]
-            (loop [result (run-task task-id)]
+            (loop [result (run-task! cfg task-id)]
               (when-let [cause (process-result result)]
                 (if (or (db/connection-error? cause)
                         (db/serialization-error? cause))

backend/test/backend_tests/helpers.clj

@@ -34,6 +34,8 @@
    [app.util.blob :as blob]
    [app.util.services :as sv]
    [app.util.time :as dt]
+   [app.worker :as wrk]
+   [app.worker.runner]
    [clojure.java.io :as io]
    [clojure.spec.alpha :as s]
    [clojure.test :as t]
@@ -77,47 +79,6 @@
    :enable-feature-components-v2
    :disable-file-validation])
 
-(def test-init-sql
-  ["alter table project_profile_rel set unlogged;\n"
-   "alter table file_profile_rel set unlogged;\n"
-   "alter table presence set unlogged;\n"
-   "alter table presence set unlogged;\n"
-   "alter table http_session set unlogged;\n"
-   "alter table team_profile_rel set unlogged;\n"
-   "alter table team_project_profile_rel set unlogged;\n"
-   "alter table comment_thread_status set unlogged;\n"
-   "alter table comment set unlogged;\n"
-   "alter table comment_thread set unlogged;\n"
-   "alter table profile_complaint_report set unlogged;\n"
-   "alter table file_change set unlogged;\n"
-   "alter table team_font_variant set unlogged;\n"
-   "alter table share_link set unlogged;\n"
-   "alter table usage_quote set unlogged;\n"
-   "alter table access_token set unlogged;\n"
-   "alter table profile set unlogged;\n"
-   "alter table file_library_rel set unlogged;\n"
-   "alter table file_thumbnail set unlogged;\n"
-   "alter table file_object_thumbnail set unlogged;\n"
-   "alter table file_tagged_object_thumbnail set unlogged;\n"
-   "alter table file_media_object set unlogged;\n"
-   "alter table file_data_fragment set unlogged;\n"
-   "alter table file set unlogged;\n"
-   "alter table project set unlogged;\n"
-   "alter table team_invitation set unlogged;\n"
-   "alter table webhook_delivery set unlogged;\n"
-   "alter table webhook set unlogged;\n"
-   "alter table team set unlogged;\n"
-   ;; For some reason, modifying the task realted tables is very very
-   ;; slow (5s); so we just don't alter them
-   ;; "alter table task set unlogged;\n"
-   ;; "alter table task_default set unlogged;\n"
-   ;; "alter table task_completed set unlogged;\n"
-   "alter table audit_log set unlogged ;\n"
-   "alter table storage_object set unlogged;\n"
-   "alter table server_error_report set unlogged;\n"
-   "alter table server_prop set unlogged;\n"
-   "alter table global_complaint_report set unlogged;\n"])
-
 (defn state-init
   [next]
   (with-redefs [app.config/flags (flags/parse flags/default default-flags)
@@ -164,9 +125,6 @@
       (try
         (binding [*system* system
                   *pool*   (:app.db/pool system)]
-          (db/with-atomic [conn *pool*]
-            (doseq [sql test-init-sql]
-              (db/exec! conn [sql])))
           (next))
         (finally
           (ig/halt! system))))))
@@ -181,8 +139,7 @@
       (db/exec-one! conn ["SET CONSTRAINTS ALL DEFERRED"])
       (db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
       (let [result (->> (db/exec! conn [sql])
-                        (map :table-name)
-                        (remove #(= "task" %)))]
+                        (map :table-name))]
         (doseq [table result]
           (db/exec! conn [(str "delete from " table ";")]))))
 
@@ -263,7 +220,7 @@
   ([params]
    (mark-file-deleted* *system* params))
   ([conn {:keys [id] :as params}]
-   (#'files/mark-file-deleted! conn id)))
+   (#'files/mark-file-deleted conn id)))
 
 (defn create-team*
   ([i params] (create-team* *system* i params))
@@ -421,9 +378,21 @@
   ([name]
    (run-task! name {}))
   ([name params]
-   (let [tasks (:app.worker/registry *system*)]
-     (let [task-fn (get tasks (d/name name))]
-       (task-fn params)))))
+   (wrk/invoke! (-> *system*
+                    (assoc ::wrk/task name)
+                    (assoc ::wrk/params params)))))
+
+(def sql:pending-tasks
+  "select t.* from task as t
+    where t.status = 'new'
+    order by t.priority desc, t.scheduled_at")
+
+(defn run-pending-tasks!
+  []
+  (db/tx-run! *system* (fn [{:keys [::db/conn] :as cfg}]
+                         (let [tasks (->> (db/exec! conn [sql:pending-tasks])
+                                          (map #'app.worker.runner/decode-task-row))]
+                           (run! (partial #'app.worker.runner/run-task cfg) tasks)))))
 
 ;; --- UTILS
 

backend/test/backend_tests/loggers_webhooks_test.clj

@@ -21,11 +21,10 @@
   (with-mocks [submit-mock {:target 'app.worker/submit! :return nil}]
     (let [prof (th/create-profile* 1 {:is-active true})
           res  (th/run-task! :process-webhook-event
-                             {:props
-                              {:app.loggers.webhooks/event
-                               {:type "command"
-                                :name "create-project"
-                                :props {:team-id (:default-team-id prof)}}}})]
+                             {:event
+                              {:type "command"
+                               :name "create-project"
+                               :props {:team-id (:default-team-id prof)}}})]
 
       (t/is (= 0 (:call-count @submit-mock)))
       (t/is (nil? res)))))
@@ -35,11 +34,10 @@
     (let [prof (th/create-profile* 1 {:is-active true})
           whk  (th/create-webhook* {:team-id (:default-team-id prof)})
           res  (th/run-task! :process-webhook-event
-                             {:props
-                              {:app.loggers.webhooks/event
-                               {:type "command"
-                                :name "create-project"
-                                :props {:team-id (:default-team-id prof)}}}})]
+                             {:event
+                              {:type "command"
+                               :name "create-project"
+                               :props {:team-id (:default-team-id prof)}}})]
 
       (t/is (= 1 (:call-count @submit-mock)))
       (t/is (nil? res)))))
@@ -52,9 +50,8 @@
                 :name "create-project"
                 :props {:team-id (:default-team-id prof)}}
           res  (th/run-task! :run-webhook
-                             {:props
-                              {:app.loggers.webhooks/event evt
-                               :app.loggers.webhooks/config whk}})]
+                             {:event evt
+                              :config whk})]
 
       (t/is (= 1 (:call-count @http-mock)))
 
@@ -75,9 +72,8 @@
                 :name "create-project"
                 :props {:team-id (:default-team-id prof)}}
           res  (th/run-task! :run-webhook
-                             {:props
-                              {:app.loggers.webhooks/event evt
-                               :app.loggers.webhooks/config whk}})]
+                             {:event evt
+                              :config whk})]
 
       (t/is (= 1 (:call-count @http-mock)))
 
@@ -94,14 +90,12 @@
       ;; RUN 2 times more
 
       (th/run-task! :run-webhook
-                    {:props
-                     {:app.loggers.webhooks/event evt
-                      :app.loggers.webhooks/config whk}})
+                    {:event evt
+                     :config whk})
 
       (th/run-task! :run-webhook
-                    {:props
-                     {:app.loggers.webhooks/event evt
-                      :app.loggers.webhooks/config whk}})
+                    {:event evt
+                     :config whk})
 
 
       (let [rows (th/db-query :webhook-delivery {:webhook-id (:id whk)})]

backend/test/backend_tests/rpc_audit_test.clj

@@ -28,7 +28,8 @@
     ring.request/Request
     (get-header [_ name]
       (case name
-        "x-forwarded-for" "127.0.0.44"))))
+        "x-forwarded-for" "127.0.0.44"
+        "x-real-ip" "127.0.0.43"))))
 
 (t/deftest push-events-1
   (with-redefs [app.config/flags #{:audit-log}]
@@ -46,6 +47,7 @@
                              :profile-id (:id prof)
                              :timestamp (dt/now)
                              :type "action"}]}
+
           params  (with-meta params
                     {:app.http/request http-request})
 

backend/test/backend_tests/rpc_file_test.clj

@@ -1189,6 +1189,7 @@
         (t/is (nil? error))
         (t/is (map? result)))
 
+      ;; insert another thumbnail with different revn
       (let [data {::th/type :create-file-thumbnail
                   ::rpc/profile-id (:id prof)
                   :file-id (:id file)
@@ -1207,8 +1208,6 @@
         (t/is (= 2 (count rows)))))
 
     (t/testing "gc task"
-      ;; make the file eligible for GC waiting 300ms (configured
-      ;; timeout for testing)
       (let [res (th/run-task! :file-gc {:min-age 0})]
         (t/is (= 1 (:processed res))))
 

backend/test/backend_tests/rpc_file_thumbnails_test.clj

@@ -346,13 +346,5 @@
                              (assoc :size 312043))))
           out  (th/command! data)]
       (t/is (nil? (:error out)))
-      (t/is (map? (:result out))))
+      (t/is (map? (:result out))))))
 
-    (let [[row1 :as rows]
-          (->> (th/db-query :task {:name "object-update"})
-               (map #(update % :props db/decode-transit-pgobject)))]
-
-      ;; (app.common.pprint/pprint rows)
-      (t/is (= 1 (count rows)))
-      (t/is (> (inst-ms (dt/diff (:created-at row1) (:scheduled-at row1)))
-               (inst-ms (dt/duration "4m")))))))

backend/test/backend_tests/rpc_profile_test.clj

@@ -6,10 +6,11 @@
 
 (ns backend-tests.rpc-profile-test
   (:require
-   [app.auth :as auth]
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
+   [app.email.blacklist :as email.blacklist]
+   [app.email.whitelist :as email.whitelist]
    [app.rpc :as-alias rpc]
    [app.rpc.commands.profile :as profile]
    [app.tokens :as tokens]
@@ -126,7 +127,7 @@
         ;; (th/print-result! out)
         (t/is (nil? (:error out)))))))
 
-(t/deftest profile-deletion-simple
+(t/deftest profile-deletion-1
   (let [prof (th/create-profile* 1)
         file (th/create-file* 1 {:profile-id (:id prof)
                                  :project-id (:default-project-id prof)
@@ -152,23 +153,22 @@
       (t/is (nil? (:error out)))
       (t/is (= 1 (count (:result out)))))
 
-    ;; execute permanent deletion task
-    (let [result (th/run-task! :objects-gc {:min-age 0})]
-      (t/is (= 1 (:processed result))))
-
-    (let [row (th/db-get :team
-                         {:id (:default-team-id prof)}
-                         {::db/remove-deleted false})]
-      (t/is (nil? (:deleted-at row))))
-
-    (let [result (th/run-task! :orphan-teams-gc {:min-age 0})]
-      (t/is (= 1 (:processed result))))
+    (th/run-pending-tasks!)
 
     (let [row (th/db-get :team
                          {:id (:default-team-id prof)}
                          {::db/remove-deleted false})]
       (t/is (dt/instant? (:deleted-at row))))
 
+    ;; execute permanent deletion task
+    (let [result (th/run-task! :objects-gc {:min-age 0})]
+      (t/is (= 4 (:processed result))))
+
+    (let [row (th/db-get :team
+                         {:id (:default-team-id prof)}
+                         {::db/remove-deleted false})]
+      (t/is (nil? row)))
+
     ;; query profile after delete
     (let [params {::th/type :get-profile
                   ::rpc/profile-id (:id prof)}
@@ -177,14 +177,187 @@
       (let [result (:result out)]
         (t/is (= uuid/zero (:id result)))))))
 
-(t/deftest registration-domain-whitelist
-  (let [whitelist #{"gmail.com" "hey.com" "ya.ru"}]
-    (t/testing "allowed email domain"
-      (t/is (true? (auth/email-domain-in-whitelist? whitelist "username@ya.ru")))
-      (t/is (true? (auth/email-domain-in-whitelist? #{} "username@somedomain.com"))))
+(t/deftest profile-deletion-2
+  (let [prof1 (th/create-profile* 1)
+        prof2 (th/create-profile* 2)
+        file1 (th/create-file* 1 {:profile-id (:id prof1)
+                                  :project-id (:default-project-id prof1)
+                                  :is-shared false})
+        team1 (th/create-team* 1 {:profile-id (:id prof1)})
 
-    (t/testing "not allowed email domain"
-      (t/is (false? (auth/email-domain-in-whitelist? whitelist "username@somedomain.com"))))))
+        role1 (th/create-team-role* {:team-id (:id team1)
+                                     :profile-id (:id prof2)
+
+                                     :role :editor})]
+    ;; Assert all roles for team
+    (let [roles (th/db-query :team-profile-rel {:team-id (:id team1)})]
+      (t/is (= 2 (count roles))))
+
+    ;; Request profile to be deleted
+    (let [params {::th/type :delete-profile
+                  ::rpc/profile-id (:id prof1)}
+          out    (th/command! params)]
+      ;; (th/print-result! out)
+
+      (let [error (:error out)
+            edata (ex-data error)]
+        (t/is (th/ex-info? error))
+        (t/is (= (:type edata) :validation))
+        (t/is (= (:code edata) :owner-teams-with-people))))))
+
+(t/deftest profile-deletion-3
+  (let [prof1 (th/create-profile* 1)
+        prof2 (th/create-profile* 2)
+        prof3 (th/create-profile* 3)
+        file1 (th/create-file* 1 {:profile-id (:id prof1)
+                                  :project-id (:default-project-id prof1)
+                                  :is-shared false})
+        team1 (th/create-team* 1 {:profile-id (:id prof1)})
+
+        role1 (th/create-team-role* {:team-id (:id team1)
+                                     :profile-id (:id prof2)
+                                     :role :editor})
+        role2 (th/create-team-role* {:team-id (:id team1)
+                                     :profile-id (:id prof3)
+                                     :role :editor})]
+
+    ;; Assert all roles for team
+    (let [roles (th/db-query :team-profile-rel {:team-id (:id team1)})]
+      (t/is (= 3 (count roles))))
+
+    ;; Request profile to be deleted (it should fail)
+    (let [params {::th/type :delete-profile
+                  ::rpc/profile-id (:id prof1)}
+          out    (th/command! params)]
+      ;; (th/print-result! out)
+
+      (let [error (:error out)
+            edata (ex-data error)]
+        (t/is (th/ex-info? error))
+        (t/is (= (:type edata) :validation))
+        (t/is (= (:code edata) :owner-teams-with-people))))
+
+    ;; Leave team by role 1
+    (let [params {::th/type :leave-team
+                  ::rpc/profile-id (:id prof2)
+                  :id (:id team1)}
+          out    (th/command! params)]
+
+      ;; (th/print-result! out)
+      (t/is (nil? (:result out)))
+      (t/is (nil? (:error out))))
+
+    ;; Request profile to be deleted (it should fail)
+    (let [params {::th/type :delete-profile
+                  ::rpc/profile-id (:id prof1)}
+          out    (th/command! params)]
+      ;; (th/print-result! out)
+      (let [error (:error out)
+            edata (ex-data error)]
+        (t/is (th/ex-info? error))
+        (t/is (= (:type edata) :validation))
+        (t/is (= (:code edata) :owner-teams-with-people))))
+
+    ;; Leave team by role 0 (the default) and reassing owner to role 3
+    ;; without reassinging it (should fail)
+    (let [params {::th/type :leave-team
+                  ::rpc/profile-id (:id prof1)
+                  ;; :reassign-to (:id prof3)
+                  :id (:id team1)}
+          out    (th/command! params)]
+
+      ;; (th/print-result! out)
+
+      (let [error (:error out)
+            edata (ex-data error)]
+        (t/is (th/ex-info? error))
+        (t/is (= (:type edata) :validation))
+        (t/is (= (:code edata) :owner-cant-leave-team))))
+
+    ;; Leave team by role 0 (the default) and reassing owner to role 3
+    (let [params {::th/type :leave-team
+                  ::rpc/profile-id (:id prof1)
+                  :reassign-to (:id prof3)
+                  :id (:id team1)}
+          out    (th/command! params)]
+
+      ;; (th/print-result! out)
+      (t/is (nil? (:result out)))
+      (t/is (nil? (:error out))))
+
+    ;; Request profile to be deleted
+    (let [params {::th/type :delete-profile
+                  ::rpc/profile-id (:id prof1)}
+          out    (th/command! params)]
+      ;; (th/print-result! out)
+
+      (t/is (= {} (:result out)))
+      (t/is (nil? (:error out))))
+
+    ;; query files after profile soft deletion
+    (let [params {::th/type :get-project-files
+                  ::rpc/profile-id (:id prof1)
+                  :project-id (:default-project-id prof1)}
+          out    (th/command! params)]
+      ;; (th/print-result! out)
+      (t/is (nil? (:error out)))
+      (t/is (= 1 (count (:result out)))))
+
+    (th/run-pending-tasks!)
+
+    ;; execute permanent deletion task
+    (let [result (th/run-task! :objects-gc {:min-age 0})]
+      (t/is (= 4 (:processed result))))
+
+    (let [row (th/db-get :team
+                         {:id (:default-team-id prof1)}
+                         {::db/remove-deleted false})]
+      (t/is (nil? row)))
+
+    ;; query profile after delete
+    (let [params {::th/type :get-profile
+                  ::rpc/profile-id (:id prof1)}
+          out    (th/command! params)]
+      ;; (th/print-result! out)
+      (let [result (:result out)]
+        (t/is (= uuid/zero (:id result)))))))
+
+
+(t/deftest profile-deletion-4
+  (let [prof1 (th/create-profile* 1)
+        file1 (th/create-file* 1 {:profile-id (:id prof1)
+                                  :project-id (:default-project-id prof1)
+                                  :is-shared false})
+        team1 (th/create-team* 1 {:profile-id (:id prof1)})
+        team2 (th/create-team* 2 {:profile-id (:id prof1)})]
+
+    ;; Request profile to be deleted
+    (let [params {::th/type :delete-profile
+                  ::rpc/profile-id (:id prof1)}
+          out    (th/command! params)]
+      ;; (th/print-result! out)
+      (t/is (= {} (:result out)))
+      (t/is (nil? (:error out))))
+
+    (th/run-pending-tasks!)
+
+    (let [rows (th/db-exec! ["select id,name,deleted_at from team where deleted_at is not null"])]
+      (t/is (= 3 (count rows))))
+
+    ;; execute permanent deletion task
+    (let [result (th/run-task! :objects-gc {:min-age 0})]
+      (t/is (= 8 (:processed result))))))
+
+
+(t/deftest email-blacklist-1
+  (t/is (false? (email.blacklist/enabled? th/*system*)))
+  (t/is (true? (email.blacklist/enabled? (assoc th/*system* :app.email/blacklist []))))
+  (t/is (true? (email.blacklist/contains? (assoc th/*system* :app.email/blacklist #{"foo.com"}) "AA@FOO.COM"))))
+
+(t/deftest email-whitelist-1
+  (t/is (false? (email.whitelist/enabled? th/*system*)))
+  (t/is (true? (email.whitelist/enabled? (assoc th/*system* :app.email/whitelist []))))
+  (t/is (true? (email.whitelist/contains? (assoc th/*system* :app.email/whitelist #{"foo.com"}) "AA@FOO.COM"))))
 
 (t/deftest prepare-register-and-register-profile-1
   (let [data  {::th/type :prepare-register-profile
@@ -229,20 +402,51 @@
         (t/is (= "mtma" (:penpot/mtm-campaign props)))))))
 
 (t/deftest prepare-register-and-register-profile-2
-  (with-redefs [app.rpc.commands.auth/register-retry-threshold (dt/duration 500)]
-    (with-mocks [mock {:target 'app.email/send! :return nil}]
-      (let [current-token (atom nil)]
+  (with-mocks [mock {:target 'app.email/send! :return nil}]
+    (let [current-token (atom nil)]
+      ;; PREPARE REGISTER
+      (let [data  {::th/type :prepare-register-profile
+                   :email "hello@example.com"
+                   :password "foobar"}
+            out   (th/command! data)
+            token (get-in out [:result :token])]
+        (t/is (th/success? out))
+        (reset! current-token token))
 
-        ;; PREPARE REGISTER
-        (let [data  {::th/type :prepare-register-profile
-                     :email "hello@example.com"
-                     :password "foobar"}
-              out   (th/command! data)
-              token (get-in out [:result :token])]
-          (t/is (string? token))
-          (reset! current-token token))
+      ;; DO REGISTRATION
+      (let [data  {::th/type :register-profile
+                   :token @current-token
+                   :fullname "foobar"
+                   :accept-terms-and-privacy true
+                   :accept-newsletter-subscription true}
+            out   (th/command! data)]
+        (t/is (nil? (:error out)))
+        (t/is (= 1 (:call-count @mock))))
 
-        ;; DO REGISTRATION: try correct register attempt 1
+      (th/reset-mock! mock)
+
+      ;; PREPARE REGISTER: second attempt
+      (let [data  {::th/type :prepare-register-profile
+                   :email "hello@example.com"
+                   :password "foobar"}
+            out   (th/command! data)
+            token (get-in out [:result :token])]
+        (t/is (th/success? out))
+        (reset! current-token token))
+
+      ;; DO REGISTRATION: second attempt
+      (let [data  {::th/type :register-profile
+                   :token @current-token
+                   :fullname "foobar"
+                   :accept-terms-and-privacy true
+                   :accept-newsletter-subscription true}
+            out   (th/command! data)]
+        (t/is (nil? (:error out)))
+        (t/is (= 0 (:call-count @mock))))
+
+      (with-mocks [_ {:target 'app.rpc.commands.auth/elapsed-verify-threshold?
+                      :return true}]
+        ;; DO REGISTRATION: third attempt
         (let [data  {::th/type :register-profile
                      :token @current-token
                      :fullname "foobar"
@@ -250,44 +454,56 @@
                      :accept-newsletter-subscription true}
               out   (th/command! data)]
           (t/is (nil? (:error out)))
-          (t/is (= 1 (:call-count @mock))))
+          (t/is (= 1 (:call-count @mock))))))))
 
-        (th/reset-mock! mock)
+(t/deftest prepare-register-and-register-profile-3
+  (with-mocks [mock {:target 'app.email/send! :return nil}]
+    (let [current-token (atom nil)]
+      ;; PREPARE REGISTER
+      (let [data  {::th/type :prepare-register-profile
+                   :email "hello@example.com"
+                   :password "foobar"}
+            out   (th/command! data)
+            token (get-in out [:result :token])]
+        (t/is (th/success? out))
+        (reset! current-token token))
 
-        ;; PREPARE REGISTER without waiting for threshold
-        (let [data  {::th/type :prepare-register-profile
-                     :email "hello@example.com"
-                     :password "foobar"}
-              out   (th/command! data)]
-          (t/is (not (th/success? out)))
-          (t/is (= :validation (-> out :error th/ex-type)))
-          (t/is (= :email-already-exists (-> out :error th/ex-code))))
+      ;; DO REGISTRATION
+      (let [data  {::th/type :register-profile
+                   :token @current-token
+                   :fullname "foobar"
+                   :accept-terms-and-privacy true
+                   :accept-newsletter-subscription true}
+            out   (th/command! data)]
+        (t/is (nil? (:error out)))
+        (t/is (= 1 (:call-count @mock))))
 
-        (th/sleep {:millis 500})
-        (th/reset-mock! mock)
+      (th/reset-mock! mock)
 
-        ;; PREPARE REGISTER waiting the threshold
-        (let [data  {::th/type :prepare-register-profile
-                     :email "hello@example.com"
-                     :password "foobar"}
-              out   (th/command! data)]
+      (th/db-update! :profile
+                     {:is-blocked true}
+                     {:email "hello@example.com"})
 
-          (t/is (th/success? out))
-          (t/is (= 0 (:call-count @mock)))
+      ;; PREPARE REGISTER: second attempt
+      (let [data  {::th/type :prepare-register-profile
+                   :email "hello@example.com"
+                   :password "foobar"}
+            out   (th/command! data)
+            token (get-in out [:result :token])]
+        (t/is (th/success? out))
+        (reset! current-token token))
 
-          (let [result (:result out)]
-            (t/is (contains? result :token))
-            (reset! current-token (:token result))))
-
-        ;; DO REGISTRATION: try correct register attempt 1
+      (with-mocks [_ {:target 'app.rpc.commands.auth/elapsed-verify-threshold?
+                      :return true}]
+        ;; DO REGISTRATION: second attempt
         (let [data  {::th/type :register-profile
                      :token @current-token
                      :fullname "foobar"
                      :accept-terms-and-privacy true
                      :accept-newsletter-subscription true}
               out   (th/command! data)]
-          (t/is (th/success? out))
-          (t/is (= 1 (:call-count @mock))))))))
+          (t/is (nil? (:error out)))
+          (t/is (= 0 (:call-count @mock))))))))
 
 
 (t/deftest prepare-and-register-with-invitation-and-disabled-registration-1
@@ -359,13 +575,13 @@
                  :email (:email profile)
                  :password "foobar"}
         out     (th/command! data)]
+    ;; (th/print-result! out)
+    (t/is (th/success? out))
+    (let [result (:result out)]
+      (t/is (contains? result :token)))))
 
-    (t/is (not (th/success? out)))
-    (let [edata (-> out :error ex-data)]
-      (t/is (= :validation (:type edata)))
-      (t/is (= :email-already-exists (:code edata))))))
+(t/deftest prepare-register-profile-with-bounced-email
 
-(t/deftest register-profile-with-bounced-email
   (let [pool  (:app.db/pool th/*system*)
         data  {::th/type :prepare-register-profile
                :email "user@example.com"
@@ -376,7 +592,7 @@
     (let [out (th/command! data)]
       (t/is (not (th/success? out)))
       (let [edata (-> out :error ex-data)]
-        (t/is (= :validation (:type edata)))
+        (t/is (= :restriction (:type edata)))
         (t/is (= :email-has-permanent-bounces (:code edata)))))))
 
 (t/deftest register-profile-with-complained-email
@@ -388,9 +604,11 @@
     (th/create-global-complaint-for pool {:type :complaint :email "user@example.com"})
 
     (let [out (th/command! data)]
-      (t/is (th/success? out))
-      (let [result (:result out)]
-        (t/is (contains? result :token))))))
+      (t/is (not (th/success? out)))
+
+      (let [edata (-> out :error ex-data)]
+        (t/is (= :restriction (:type edata)))
+        (t/is (= :email-has-complaints (:code edata)))))))
 
 (t/deftest register-profile-with-email-as-password
   (let [data {::th/type :prepare-register-profile
@@ -421,20 +639,26 @@
 
       ;; with complaints
       (th/create-global-complaint-for pool {:type :complaint :email (:email data)})
-      (let [out (th/command! data)]
+      (let [out   (th/command! data)]
         ;; (th/print-result! out)
         (t/is (nil? (:result out)))
-        (t/is (= 2 (:call-count @mock))))
+
+        (let [edata (-> out :error ex-data)]
+          (t/is (= :restriction (:type edata)))
+          (t/is (= :email-has-complaints (:code edata))))
+
+        (t/is (= 1 (:call-count @mock))))
 
       ;; with bounces
       (th/create-global-complaint-for pool {:type :bounce :email (:email data)})
-      (let [out   (th/command! data)
-            error (:error out)]
+      (let [out   (th/command! data)]
         ;; (th/print-result! out)
-        (t/is (th/ex-info? error))
-        (t/is (th/ex-of-type? error :validation))
-        (t/is (th/ex-of-code? error :email-has-permanent-bounces))
-        (t/is (= 2 (:call-count @mock)))))))
+
+        (let [edata (-> out :error ex-data)]
+          (t/is (= :restriction (:type edata)))
+          (t/is (= :email-has-permanent-bounces (:code edata))))
+
+        (t/is (= 1 (:call-count @mock)))))))
 
 
 (t/deftest email-change-request-without-smtp
@@ -455,7 +679,7 @@
 
 (t/deftest request-profile-recovery
   (with-mocks [mock {:target 'app.email/send! :return nil}]
-    (let [profile1 (th/create-profile* 1)
+    (let [profile1 (th/create-profile* 1 {:is-active false})
           profile2 (th/create-profile* 2 {:is-active true})
           pool  (:app.db/pool th/*system*)
           data  {::th/type :request-profile-recovery}]
@@ -468,38 +692,47 @@
 
       ;; with valid email inactive user
       (let [data  (assoc data :email (:email profile1))
-            out   (th/command! data)
-            error (:error out)]
+            out   (th/command! data)]
         (t/is (= 0 (:call-count @mock)))
-        (t/is (th/ex-info? error))
-        (t/is (th/ex-of-type? error :validation))
-        (t/is (th/ex-of-code? error :profile-not-verified)))
+        (t/is (nil? (:result out)))
+        (t/is (nil? (:error out))))
+
+      (with-mocks [_ {:target 'app.rpc.commands.auth/elapsed-verify-threshold?
+                      :return true}]
+        ;; with valid email inactive user
+        (let [data  (assoc data :email (:email profile1))
+              out   (th/command! data)]
+          (t/is (= 1 (:call-count @mock)))
+          (t/is (nil? (:result out)))
+          (t/is (nil? (:error out)))))
+
+      (th/reset-mock! mock)
 
       ;; with valid email and active user
-      (let [data  (assoc data :email (:email profile2))
-            out   (th/command! data)]
-        ;; (th/print-result! out)
-        (t/is (nil? (:result out)))
-        (t/is (= 1 (:call-count @mock))))
+      (with-mocks [_ {:target 'app.rpc.commands.auth/elapsed-verify-threshold?
+                      :return true}]
+        (let [data  (assoc data :email (:email profile2))
+              out   (th/command! data)]
+          ;; (th/print-result! out)
+          (t/is (nil? (:result out)))
+          (t/is (= 1 (:call-count @mock))))
 
-      ;; with valid email and active user with global complaints
-      (th/create-global-complaint-for pool {:type :complaint :email (:email profile2)})
-      (let [data  (assoc data :email (:email profile2))
-            out   (th/command! data)]
-        ;; (th/print-result! out)
-        (t/is (nil? (:result out)))
-        (t/is (= 2 (:call-count @mock))))
+        ;; with valid email and active user with global complaints
+        (th/create-global-complaint-for pool {:type :complaint :email (:email profile2)})
+        (let [data  (assoc data :email (:email profile2))
+              out   (th/command! data)]
+          ;; (th/print-result! out)
+          (t/is (nil? (:result out)))
+          (t/is (= 1 (:call-count @mock))))
 
-      ;; with valid email and active user with global bounce
-      (th/create-global-complaint-for pool {:type :bounce :email (:email profile2)})
-      (let [data  (assoc data :email (:email profile2))
-            out   (th/command! data)
-            error (:error out)]
-        ;; (th/print-result! out)
-        (t/is (= 2 (:call-count @mock)))
-        (t/is (th/ex-info? error))
-        (t/is (th/ex-of-type? error :validation))
-        (t/is (th/ex-of-code? error :email-has-permanent-bounces))))))
+        ;; with valid email and active user with global bounce
+        (th/create-global-complaint-for pool {:type :bounce :email (:email profile2)})
+        (let [data  (assoc data :email (:email profile2))
+              out   (th/command! data)]
+          (t/is (nil? (:result out)))
+          (t/is (nil? (:error out)))
+          ;; (th/print-result! out)
+          (t/is (= 1 (:call-count @mock))))))))
 
 
 (t/deftest update-profile-password

backend/test/backend_tests/rpc_team_test.clj

@@ -62,8 +62,8 @@
       (th/reset-mock! mock)
       (let [data (assoc data :emails ["foo@bar.com"])
             out  (th/command! data)]
-        (t/is (th/success? out))
-        (t/is (= 1 (:call-count (deref mock)))))
+        (t/is (not (th/success? out)))
+        (t/is (= 0 (:call-count (deref mock)))))
 
       ;; get invitation token
       (let [params {::th/type :get-team-invitation-token
@@ -86,7 +86,7 @@
         (t/is (= 0 (:call-count @mock)))
 
         (let [edata (-> out :error ex-data)]
-          (t/is (= :validation (:type edata)))
+          (t/is (= :restriction (:type edata)))
           (t/is (= :email-has-permanent-bounces (:code edata)))))
 
       ;; invite internal user that is muted
@@ -391,6 +391,8 @@
         (t/is (= 1 (count result)))
         (t/is (= (:default-team-id profile1) (get-in result [0 :id])))))
 
+    (th/run-pending-tasks!)
+
     ;; run permanent deletion (should be noop)
     (let [result (th/run-task! :objects-gc {:min-age (dt/duration {:minutes 1})})]
       (t/is (= 0 (:processed result))))
@@ -457,6 +459,8 @@
       #_(th/print-result! out)
       (t/is (nil? (:error out))))
 
+    (th/run-pending-tasks!)
+
     (let [rows (th/db-exec! ["select * from team where id = ?" (:id team)])]
       (t/is (= 1 (count rows)))
       (t/is (dt/instant? (:deleted-at (first rows)))))

backend/tests.edn

@@ -2,4 +2,5 @@
 {:tests
  [{:id          :unit
    :test-paths  ["test" "src"]
-   :ns-patterns [".*-test$"]}]}
+   :ns-patterns [".*-test$"]
+   :kaocha/reporter [kaocha.report/dots]}]}

common/deps.edn

@@ -1,25 +1,25 @@
 {:deps
- {org.clojure/clojure {:mvn/version "1.11.1"}
+ {org.clojure/clojure {:mvn/version "1.11.2"}
   org.clojure/data.json {:mvn/version "2.5.0"}
-  org.clojure/tools.cli {:mvn/version "1.0.219"}
+  org.clojure/tools.cli {:mvn/version "1.1.230"}
   org.clojure/clojurescript {:mvn/version "1.11.132"}
   org.clojure/test.check {:mvn/version "1.1.1"}
-  org.clojure/data.fressian {:mvn/version "1.0.0"}
+  org.clojure/data.fressian {:mvn/version "1.1.0"}
 
   ;; Logging
-  org.apache.logging.log4j/log4j-api {:mvn/version "2.22.1"}
-  org.apache.logging.log4j/log4j-core {:mvn/version "2.22.1"}
-  org.apache.logging.log4j/log4j-web {:mvn/version "2.22.1"}
-  org.apache.logging.log4j/log4j-jul {:mvn/version "2.22.1"}
-  org.apache.logging.log4j/log4j-slf4j2-impl {:mvn/version "2.22.1"}
-  org.slf4j/slf4j-api {:mvn/version "2.0.10"}
+  org.apache.logging.log4j/log4j-api {:mvn/version "2.23.1"}
+  org.apache.logging.log4j/log4j-core {:mvn/version "2.23.1"}
+  org.apache.logging.log4j/log4j-web {:mvn/version "2.23.1"}
+  org.apache.logging.log4j/log4j-jul {:mvn/version "2.23.1"}
+  org.apache.logging.log4j/log4j-slf4j2-impl {:mvn/version "2.23.1"}
+  org.slf4j/slf4j-api {:mvn/version "2.0.13"}
   pl.tkowalcz.tjahzi/log4j2-appender {:mvn/version "0.9.32"}
 
-  selmer/selmer {:mvn/version "1.12.59"}
+  selmer/selmer {:mvn/version "1.12.61"}
   criterium/criterium {:mvn/version "0.4.6"}
 
   metosin/jsonista {:mvn/version "0.3.8"}
-  metosin/malli {:mvn/version "0.14.0"}
+  metosin/malli {:mvn/version "0.16.1"}
 
   expound/expound {:mvn/version "0.9.0"}
   com.cognitect/transit-clj {:mvn/version "1.0.333"}
@@ -28,7 +28,7 @@
   integrant/integrant {:mvn/version "0.8.1"}
 
   org.apache.commons/commons-pool2 {:mvn/version "2.12.0"}
-  org.graalvm.js/js {:mvn/version "23.0.2"}
+  org.graalvm.js/js {:mvn/version "23.0.4"}
 
   funcool/tubax {:mvn/version "2021.05.20-0"}
   funcool/cuerdas {:mvn/version "2023.11.09-407"}
@@ -41,7 +41,7 @@
    :git/tag "3.0.0"
    :git/url "https://github.com/funcool/datoteka"}
 
-  lambdaisland/uri {:mvn/version "1.16.134"
+  lambdaisland/uri {:mvn/version "1.19.155"
                     :exclusions [org.clojure/data.json]}
 
   frankiesardo/linked {:mvn/version "1.3.0"}
@@ -63,7 +63,7 @@
  {:dev
   {:extra-deps
    {org.clojure/tools.namespace {:mvn/version "RELEASE"}
-    thheller/shadow-cljs {:mvn/version "2.27.4"}
+    thheller/shadow-cljs {:mvn/version "2.28.8"}
     com.clojure-goes-fast/clj-async-profiler {:mvn/version "RELEASE"}
     com.bhauman/rebel-readline {:mvn/version "RELEASE"}
     criterium/criterium {:mvn/version "RELEASE"}
@@ -72,16 +72,12 @@
 
   :build
   {:extra-deps
-   {io.github.clojure/tools.build {:git/tag "v0.9.5" :git/sha "24f2894"}}
+   {io.github.clojure/tools.build {:git/tag "v0.10.3" :git/sha "15ead66"}}
    :ns-default build}
 
   :test
-  {:extra-paths ["test"]
-   :extra-deps
-   {io.github.cognitect-labs/test-runner
-    {:git/tag "v0.5.1" :git/sha "dfb30dd"}}
-   :main-opts ["-m" "cognitect.test-runner"]
-   :exec-fn cognitect.test-runner.api/test}
+  {:main-opts ["-m" "kaocha.runner"]
+   :extra-deps {lambdaisland/kaocha {:mvn/version "1.91.1392"}}}
 
   :shadow-cljs
   {:main-opts ["-m" "shadow.cljs.devtools.cli"]}

common/package.json

@@ -5,19 +5,19 @@
   "license": "MPL-2.0",
   "author": "Kaleidos INC",
   "private": true,
-  "packageManager": "yarn@4.0.2",
+  "packageManager": "yarn@4.2.2",
   "repository": {
     "type": "git",
     "url": "https://github.com/penpot/penpot"
   },
   "dependencies": {
-    "luxon": "^3.4.2",
-    "sax": "^1.2.4"
+    "luxon": "^3.4.4",
+    "sax": "^1.4.1"
   },
   "devDependencies": {
-    "shadow-cljs": "2.27.4",
+    "shadow-cljs": "2.28.8",
     "source-map-support": "^0.5.21",
-    "ws": "^8.13.0"
+    "ws": "^8.17.0"
   },
   "scripts": {
     "fmt:clj:check": "cljfmt check --parallel=false src/ test/",

common/src/app/common/data.cljc

@@ -224,7 +224,6 @@
   [coll]
   (into [] (remove nil?) coll))
 
-
 (defn without-nils
   "Given a map, return a map removing key-value
   pairs when value is `nil`."

common/src/app/common/features.cljc

@@ -48,7 +48,8 @@
     "fdata/shape-data-type"
     "components/v2"
     "styles/v2"
-    "layout/grid"})
+    "layout/grid"
+    "plugins/runtime"})
 
 ;; A set of features enabled by default
 (def default-features
@@ -62,7 +63,8 @@
 ;; persist on file features field but can be permanently enabled on
 ;; team feature field
 (def frontend-only-features
-  #{"styles/v2"})
+  #{"styles/v2"
+    "plugins/runtime"})
 
 ;; Features that are mainly backend only or there are a proper
 ;; fallback when frontend reports no support for it
@@ -78,7 +80,8 @@
   (-> #{"fdata/objects-map"
         "fdata/pointer-map"
         "layout/grid"
-        "fdata/shape-data-type"}
+        "fdata/shape-data-type"
+        "plugins/runtime"}
       (into frontend-only-features)))
 
 (sm/def! ::features
@@ -97,6 +100,7 @@
     :feature-grid-layout "layout/grid"
     :feature-fdata-objects-map "fdata/objects-map"
     :feature-fdata-pointer-map "fdata/pointer-map"
+    :feature-plugins "plugins/runtime"
     nil))
 
 (defn migrate-legacy-features

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

@@ -38,17 +38,22 @@
                         fail-on-spec?]
                  :or   {add-container? false
                         fail-on-spec? false}}]
-   (let [component-id (:current-component-id file)
-         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))))
+   (let [components-v2 (dm/get-in file [:data :options :components-v2])
+         component-id  (:current-component-id file)
+         change        (cond-> change
+                         (and add-container? (some? component-id) (not components-v2))
+                         (-> (assoc :component-id component-id)
+                             (cond-> (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/check-change! change)]
+                         (and add-container? (or (nil? component-id) components-v2))
+                         (assoc :page-id  (:current-page-id file)
+                                :frame-id (:current-frame-id file)))
+
+         valid? (or (and components-v2
+                         (nil? (:component-id change))
+                         (nil? (:page-id change)))
+                    (ch/check-change! change))]
 
      (when-not valid?
        (let [explain (sm/explain ::ch/change change)]
@@ -60,12 +65,12 @@
                      ::sm/explain explain))))
 
      (cond-> file
-       valid?
-       (-> (update :changes conjv change)
-           (update :data ch/process-changes [change] false))
+       (and valid? (or (not add-container?) (some? (:component-id change)) (some? (:page-id change))))
+       (-> (update :changes conjv change)                      ;; In components-v2 we do not add shapes
+           (update :data ch/process-changes [change] false))   ;; inside a component
 
        (not valid?)
-       (update :errors conjv change)))))
+       (update :errors conjv change)))));)
 
 (defn- lookup-objects
   ([file]
@@ -135,19 +140,14 @@
    (create-file (uuid/next) name))
 
   ([id name]
-   {:id id
-    :name name
-    :data (-> ctf/empty-file-data
-              (assoc :id id))
-
-    ;; We keep the changes so we can send them to the backend
-    :changes []}))
+   (-> (ctf/make-file {:id id :name name :create-page false})
+       (assoc :changes [])))) ;; We keep the changes so we can send them to the backend
 
 (defn add-page
   [file data]
   (dm/assert! (nil? (:current-component-id file)))
   (let [page-id (or (:id data) (uuid/next))
-        page (-> (ctp/make-empty-page page-id "Page 1")
+        page (-> (ctp/make-empty-page {:id page-id :name "Page 1"})
                  (d/deep-merge data))]
     (-> file
         (commit-change
@@ -185,10 +185,11 @@
         (update :parent-stack conjv (:id obj)))))
 
 (defn close-artboard [file]
-  (let [parent-id (-> file :parent-stack peek)
+  (let [components-v2 (dm/get-in file [:data :options :components-v2])
+        parent-id (-> file :parent-stack peek)
         parent (lookup-shape file parent-id)
         current-frame-id (or (:frame-id parent)
-                             (when (nil? (:current-component-id file))
+                             (when (or (nil? (:current-component-id file)) components-v2)
                                root-id))]
     (-> file
         (assoc :current-frame-id current-frame-id)
@@ -511,17 +512,26 @@
          {:type :del-media
           :id id}))))
 
-
 (defn start-component
-  ([file data] (start-component file data :group))
+  ([file data]
+   (let [components-v2 (dm/get-in file [:data :options :components-v2])
+         root-type     (if components-v2 :frame :group)]
+     (start-component file data root-type)))
+
   ([file data root-type]
    ;; 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))
+   (let [components-v2 (dm/get-in file [:data :options :components-v2])
+         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)
+
+         ;; In components v1 we must create the root shape and set it inside
+         ;; the :objects attribute of the component. When in components-v2,
+         ;; this will be ignored as the root shape has already been created
+         ;; in its page, by the normal page import.
          attrs (-> data
                    (assoc :type root-type)
                    (assoc :x (:x selrect))
@@ -543,19 +553,43 @@
 
      (-> file
          (commit-change
-          {:type :add-component
-           :id (:id obj)
-           :name name
-           :path path
-           :main-instance-id main-instance-id
-           :main-instance-page main-instance-page
-           :shapes [obj]})
+          (cond-> {:type :add-component
+                   :id (:id obj)
+                   :name name
+                   :path path
+                   :main-instance-id main-instance-id
+                   :main-instance-page main-instance-page}
+            (not components-v2)
+            (assoc :shapes [obj])))
 
          (assoc :last-id (:id obj))
          (assoc :parent-stack [(:id obj)])
          (assoc :current-component-id (:id obj))
          (assoc :current-frame-id (if (= (:type obj) :frame) (:id obj) uuid/zero))))))
 
+(defn start-deleted-component
+  [file data]
+  (let [attrs (-> data
+                  (assoc :id (:main-instance-id data))
+                  (assoc :component-file (:id file))
+                  (assoc :component-id (:id data))
+                  (assoc :x (:main-instance-x data))
+                  (assoc :y (:main-instance-y data))
+                  (dissoc :path)
+                  (dissoc :main-instance-id)
+                  (dissoc :main-instance-page)
+                  (dissoc :main-instance-x)
+                  (dissoc :main-instance-y)
+                  (dissoc :main-instance-parent)
+                  (dissoc :main-instance-frame))]
+    ;; To create a deleted component, first we add all shapes of the main instance
+    ;; in the main instance page, and in the finish event we delete it.
+    (-> file
+        (update :parent-stack conjv (:main-instance-parent data))
+        (assoc :current-page-id (:main-instance-page data))
+        (assoc :current-frame-id (:main-instance-frame data))
+        (add-artboard attrs))))
+
 (defn finish-component
   [file]
   (let [component-id (:current-component-id file)
@@ -566,9 +600,11 @@
 
         file
         (cond
-          ;; Components-v2 component we skip this step
+          ;; In components-v2 components haven't any shape inside them.
           (and component-data (:main-instance-id component-data))
-          file
+          (update file :data
+                  (fn [data]
+                    (ctkl/update-component data component-id dissoc :objects)))
 
           (empty? children)
           (commit-change
@@ -618,43 +654,18 @@
         (update :parent-stack pop))))
 
 (defn finish-deleted-component
-  [component-id page-id main-instance-x main-instance-y file]
+  [component-id file]
   (let [file             (assoc file :current-component-id component-id)
-        page             (ctpl/get-page (:data file) page-id)
-        component        (ctkl/get-component (:data file) component-id)
-        main-instance-id (:main-instance-id component)
-
-        ; To obtain a deleted component, we first create the component
-        ; and the main instance in the workspace, and then delete them.
-        [_ shapes]
-        (ctn/make-component-instance page
-                                     component
-                                     (:data file)
-                                     (gpt/point main-instance-x
-                                                main-instance-y)
-                                     true
-                                     {:main-instance true
-                                      :force-id main-instance-id})]
-    (as-> file $
-      (reduce #(commit-change %1
-                              {:type :add-obj
-                               :id (:id %2)
-                               :page-id (:id page)
-                               :parent-id (:parent-id %2)
-                               :frame-id (:frame-id %2)
-                               :ignore-touched true
-                               :obj %2})
-              $
-              shapes)
-      (commit-change $ {:type :del-component
+        component        (ctkl/get-component (:data file) component-id)]
+    (-> file
+        (close-artboard)
+        (commit-change {:type :del-component
                         :id component-id})
-      (reduce #(commit-change %1 {:type :del-obj
-                                  :page-id page-id
-                                  :ignore-touched true
-                                  :id (:id %2)})
-              $
-              shapes)
-      (dissoc $ :current-component-id))))
+        (commit-change {:type :del-obj
+                        :page-id (:main-instance-page component)
+                        :id (:main-instance-id component)
+                        :ignore-touched true})
+        (dissoc :current-page-id))))
 
 (defn create-component-instance
   [file data]
@@ -665,7 +676,6 @@
         page-id          (:current-page-id file)
         page             (ctpl/get-page (:data file) page-id)
         component        (ctkl/get-component (:data file) component-id)
-        ;; main-instance-id (:main-instance-id component)
 
         components-v2    (dm/get-in file [:options :components-v2])
 

common/src/app/common/files/changes.cljc

@@ -578,7 +578,7 @@
     (ex/raise :type :conflict
               :hint "id+name or page should be provided, never both"))
   (let [page (if (and (string? name) (uuid? id))
-               (ctp/make-empty-page id name)
+               (ctp/make-empty-page {:id id :name name})
                page)]
     (ctpl/add-page data page)))
 
@@ -670,52 +670,14 @@
   (ctyl/delete-typography data id))
 
 ;; === Operations
-
 (defmethod process-operation :set
   [on-changed shape op]
-  (let [attr            (:attr op)
-        group           (get ctk/sync-attrs attr)
-        val             (:val op)
-        shape-val       (get shape attr)
-        ignore          (or (:ignore-touched op) (= attr :position-data)) ;; position-data is a derived attribute and
-        ignore-geometry (:ignore-geometry op)                             ;; never triggers touched by itself
-        is-geometry?    (and (or (= group :geometry-group)
-                                 (and (= group :content-group) (= (:type shape) :path)))
-                             (not (#{:width :height} attr))) ;; :content in paths are also considered geometric
-                        ;; TODO: the check of :width and :height probably may be removed
-                        ;;       after the check added in data/workspace/modifiers/check-delta
-                        ;;       function. Better check it and test toroughly when activating
-                        ;;       components-v2 mode.
-        in-copy?        (ctk/in-component-copy? shape)
-
-        ;; For geometric attributes, there are cases in that the value changes
-        ;; slightly (e.g. when rounding to pixel, or when recalculating text
-        ;; positions in different zoom levels). To take this into account, we
-        ;; ignore geometric changes smaller than 1 pixel.
-        equal? (if is-geometry?
-                 (gsh/close-attrs? attr val shape-val 1)
-                 (gsh/close-attrs? attr val shape-val))]
-
-    ;; Notify when value has changed, except when it has not moved relative to the
-    ;; component head.
-    (when (and group (not equal?) (not (and ignore-geometry is-geometry?)))
-      (on-changed shape))
-
-    (cond-> shape
-      ;; Depending on the origin of the attribute change, we need or not to
-      ;; set the "touched" flag for the group the attribute belongs to.
-      ;; In some cases we need to ignore touched only if the attribute is
-      ;; geometric (position, width or transformation).
-      (and in-copy? group (not ignore) (not equal?)
-           (not (and ignore-geometry is-geometry?)))
-      (-> (update :touched cfh/set-touched-group group)
-          (dissoc :remote-synced))
-
-      (nil? val)
-      (dissoc attr)
-
-      (some? val)
-      (assoc attr val))))
+  (ctn/set-shape-attr shape
+                      (:attr op)
+                      (:val op)
+                      :on-changed on-changed
+                      :ignore-touched (:ignore-touched op)
+                      :ignore-geometry (:ignore-geometry op)))
 
 (defmethod process-operation :set-touched
   [_ shape op]

common/src/app/common/files/changes_builder.cljc

@@ -69,6 +69,11 @@
              ::page page
              ::page-id (:id page)))
 
+(defn with-page-id
+  [changes page-id]
+  (vary-meta changes assoc
+             ::page-id page-id))
+
 (defn with-container
   [changes container]
   (if (cfh/page? container)
@@ -715,6 +720,7 @@
                                    (map lookupf)
                                    (map mk-change))
                              updated-shapes))))
+
          (apply-changes-local)))))
 
 (defn update-component
@@ -764,15 +770,6 @@
       (update :undo-changes conj {:type :del-component
                                   :id id
                                   :main-instance main-instance})))
-(defn ignore-remote
-  [changes]
-  (letfn [(add-ignore-remote
-            [change-list]
-            (->> change-list
-                 (mapv #(assoc % :ignore-remote? true))))]
-    (-> changes
-        (update :redo-changes add-ignore-remote)
-        (update :undo-changes add-ignore-remote))))
 
 (defn reorder-grid-children
   [changes ids]

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

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

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

@@ -357,15 +357,6 @@
 ;; COMPONENTS HELPERS
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defn set-touched-group
-  [touched group]
-  (when group
-    (conj (or touched #{}) group)))
-
-(defn touched-group?
-  [shape group]
-  ((or (:touched shape) #{}) group))
-
 (defn make-container
   [page-or-component type]
   (assoc page-or-component :type type))

common/src/app/common/files/libraries_helpers.cljc

@@ -1,103 +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.common.files.libraries-helpers
-  (:require
-   [app.common.data :as d]
-   [app.common.files.changes-builder :as pcb]
-   [app.common.files.helpers :as cfh]
-   [app.common.types.component :as ctk]
-   [app.common.types.container :as ctn]
-   [app.common.uuid :as uuid]))
-
-(defn generate-add-component-changes
-  [changes root objects file-id page-id components-v2]
-  (let [name (:name root)
-        [path name] (cfh/parse-path-name name)
-
-        [root-shape new-shapes updated-shapes]
-        (if-not components-v2
-          (ctn/make-component-shape root objects file-id components-v2)
-          (ctn/convert-shape-in-component root objects file-id))
-
-        changes (-> changes
-                    (pcb/add-component (:id root-shape)
-                                       path
-                                       name
-                                       new-shapes
-                                       updated-shapes
-                                       (:id root)
-                                       page-id))]
-    [root-shape changes]))
-
-(defn generate-add-component
-  "If there is exactly one id, and it's a frame (or a group in v1), and not already a component,
-  use it as root. Otherwise, create a frame (v2) or group (v1) that contains all ids. Then, make a
-  component with it, and link all shapes to their corresponding one in the component."
-  [it shapes objects page-id file-id components-v2 prepare-create-group prepare-create-board]
-
-  (let [changes      (pcb/empty-changes it page-id)
-        shapes-count (count shapes)
-        first-shape  (first shapes)
-
-        from-singe-frame?
-        (and (= 1 shapes-count)
-             (cfh/frame-shape? first-shape))
-
-        [root changes old-root-ids]
-        (if (and (= shapes-count 1)
-                 (or (and (cfh/group-shape? first-shape)
-                          (not components-v2))
-                     (cfh/frame-shape? first-shape))
-                 (not (ctk/instance-head? first-shape)))
-          [first-shape
-           (-> (pcb/empty-changes it page-id)
-               (pcb/with-objects objects))
-           (:shapes first-shape)]
-
-          (let [root-name (if (= 1 shapes-count)
-                            (:name first-shape)
-                            "Component 1")
-
-                shape-ids (into (d/ordered-set) (map :id) shapes)
-
-                [root changes]
-                (if-not components-v2
-                  (prepare-create-group it            ; These functions needs to be passed as argument
-                                        objects       ; to avoid a circular dependence
-                                        page-id
-                                        shapes
-                                        root-name
-                                        (not (ctk/instance-head? first-shape)))
-                  (prepare-create-board changes
-                                        (uuid/next)
-                                        (:parent-id first-shape)
-                                        objects
-                                        shape-ids
-                                        nil
-                                        root-name
-                                        true))]
-
-            [root changes shape-ids]))
-
-        changes
-        (cond-> changes
-          (not from-singe-frame?)
-          (pcb/update-shapes
-           (:shapes root)
-           (fn [shape]
-             (assoc shape :constraints-h :scale :constraints-v :scale))))
-
-        objects' (assoc objects (:id root) root)
-
-        [root-shape changes] (generate-add-component-changes changes root objects' file-id page-id components-v2)
-
-        changes  (pcb/update-shapes changes
-                                    old-root-ids
-                                    #(dissoc % :component-root)
-                                    [:component-root])]
-
-    [root (:id root-shape) changes]))

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

@@ -22,6 +22,7 @@
    [app.common.schema :as sm]
    [app.common.svg :as csvg]
    [app.common.text :as txt]
+   [app.common.types.color :as ctc]
    [app.common.types.component :as ctk]
    [app.common.types.file :as ctf]
    [app.common.types.shape :as cts]
@@ -937,6 +938,85 @@
     (-> data
         (update :pages-index update-vals update-page))))
 
+(defn migrate-up-49
+  "Remove hide-in-viewer for shapes that are origin or destination of an interaction"
+  [data]
+  (letfn [(update-object [destinations object]
+            (cond-> object
+              (or (:interactions object)
+                  (contains? destinations (:id object)))
+              (dissoc object :hide-in-viewer)))
+
+          (update-page [page]
+            (let [destinations (->> page
+                                    :objects
+                                    (vals)
+                                    (mapcat :interactions)
+                                    (map :destination)
+                                    (set))]
+              (update page :objects update-vals (partial update-object destinations))))]
+
+    (update data :pages-index update-vals update-page)))
+
+(defn migrate-up-50
+  "This migration mainly fixes paths with curve-to segments
+  without :c1x :c1y :c2x :c2y properties. Additionally, we found a
+  case where the params instead to be plain hash-map, is a points
+  instance. This migration normalizes all params to plain map."
+
+  [data]
+  (let [update-segment
+        (fn [{:keys [command params] :as segment}]
+          (let [params (into {} params)
+                params (cond
+                         (= :curve-to command)
+                         (let [x (get params :x)
+                               y (get params :y)]
+
+                           (cond-> params
+                             (nil? (:c1x params))
+                             (assoc :c1x x)
+
+                             (nil? (:c1y params))
+                             (assoc :c1y y)
+
+                             (nil? (:c2x params))
+                             (assoc :c2x x)
+
+                             (nil? (:c2y params))
+                             (assoc :c2y y)))
+
+                         :else
+                         params)]
+
+            (assoc segment :params params)))
+
+        update-shape
+        (fn [shape]
+          (if (cfh/path-shape? shape)
+            (d/update-when shape :content (fn [content] (mapv update-segment content)))
+            shape))
+
+        update-container
+        (fn [page]
+          (d/update-when page :objects update-vals update-shape))]
+
+    (-> data
+        (update :pages-index update-vals update-container)
+        (update :components update-vals update-container))))
+
+(def ^:private valid-color?
+  (sm/lazy-validator ::ctc/color))
+
+(defn migrate-up-51
+  "This migration fixes library invalid colors"
+
+  [data]
+  (let [update-colors
+        (fn [colors]
+          (into {} (filter #(-> % val valid-color?) colors)))]
+    (update data :colors update-colors)))
+
 (def migrations
   "A vector of all applicable migrations"
   [{:id 2 :migrate-up migrate-up-2}
@@ -976,4 +1056,7 @@
    {:id 45 :migrate-up migrate-up-45}
    {:id 46 :migrate-up migrate-up-46}
    {:id 47 :migrate-up migrate-up-47}
-   {:id 48 :migrate-up migrate-up-48}])
+   {:id 48 :migrate-up migrate-up-48}
+   {:id 49 :migrate-up migrate-up-49}
+   {:id 50 :migrate-up migrate-up-50}
+   {:id 51 :migrate-up migrate-up-51}])

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

@@ -473,6 +473,59 @@
         (pcb/with-file-data file-data)
         (pcb/update-shapes [(:id shape)] repair-shape))))
 
+(defmethod repair-error :duplicate-slot
+  [_ {:keys [shape page-id] :as error} file-data _]
+  (let [page      (ctpl/get-page file-data page-id)
+        childs    (map #(get (:objects page) %) (:shapes shape))
+        child-with-duplicate (let [result (reduce (fn [[seen duplicates] item]
+                                                    (let [swap-slot (ctk/get-swap-slot item)]
+                                                      (if (contains? seen swap-slot)
+                                                        [seen (conj duplicates item)]
+                                                        [(conj seen swap-slot) duplicates])))
+                                                  [#{} []]
+                                                  childs)]
+                               (second result))
+        repair-shape
+        (fn [shape]
+          ;; Remove the swap slot
+          (log/debug :hint "  -> remove swap-slot" :child-id (:id shape))
+          (ctk/remove-swap-slot shape))]
+
+    (log/dbg :hint "repairing shape :duplicated-slot" :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 (map :id child-with-duplicate) repair-shape))))
+
+
+
+(defmethod repair-error :component-duplicate-slot
+  [_ {:keys [shape] :as error} file-data _]
+  (let [main-shape            (get-in shape [:objects (:main-instance-id shape)])
+        childs                (map #(get (:objects shape) %) (:shapes main-shape))
+        childs-with-duplicate (let [result (reduce (fn [[seen duplicates] item]
+                                                     (let [swap-slot (ctk/get-swap-slot item)]
+                                                       (if (contains? seen swap-slot)
+                                                         [seen (conj duplicates item)]
+                                                         [(conj seen swap-slot) duplicates])))
+                                                   [#{} []]
+                                                   childs)]
+                                (second result))
+        duplicated-ids        (set (mapv :id childs-with-duplicate))
+        repair-component
+        (fn [component]
+          (let [objects (reduce-kv (fn [acc k v]
+                                     (if (contains? duplicated-ids k)
+                                       (assoc acc k (ctk/remove-swap-slot v))
+                                       (assoc acc k v)))
+                                   {}
+                                   (:objects component))]
+            (assoc component :objects objects)))]
+
+    (log/dbg :hint "repairing component :component-duplicated-slot" :id (:id shape) :name (:name shape))
+    (-> (pcb/empty-changes nil)
+        (pcb/with-library-data file-data)
+        (pcb/update-component (:id shape) repair-component))))
+
 (defmethod repair-error :missing-slot
   [_ {:keys [shape page-id args] :as error} file-data _]
   (let [repair-shape
@@ -481,7 +534,7 @@
           (let [slot (:swap-slot args)]
             (when (some? slot)
               (log/debug :hint (str "  -> set swap-slot to " slot))
-              (update shape :touched cfh/set-touched-group (ctk/build-swap-slot-group slot)))))]
+              (ctk/set-swap-slot shape slot))))]
 
     (log/dbg :hint "repairing shape :missing-slot" :id (:id shape) :name (:name shape) :page-id page-id)
     (-> (pcb/empty-changes nil page-id)

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

@@ -31,9 +31,11 @@
     :child-not-found
     :frame-not-found
     :invalid-frame
+    :component-duplicate-slot
     :component-not-main
     :component-main-external
     :component-not-found
+    :duplicate-slot
     :invalid-main-instance-id
     :invalid-main-instance-page
     :invalid-main-instance
@@ -64,7 +66,7 @@
      [:shape {:optional true} :map] ; Cannot validate a shape because here it may be broken
      [:shape-id {:optional true} ::sm/uuid]
      [:file-id ::sm/uuid]
-     [:page-id ::sm/uuid]]))
+     [:page-id {:optional true} [:maybe ::sm/uuid]]]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; ERROR HANDLING
@@ -296,6 +298,22 @@
                   "This shape should not have swap slot"
                   shape file page)))
 
+(defn- has-duplicate-swap-slot?
+  [shape container]
+  (let [shapes   (map #(get (:objects container) %) (:shapes shape))
+        slots    (->> (map #(ctk/get-swap-slot %) shapes)
+                      (remove nil?))
+        counts   (frequencies slots)]
+    (some (fn [[_ count]] (> count 1)) counts)))
+
+(defn- check-duplicate-swap-slot
+  "Validate that the children of this shape does not have duplicated slots."
+  [shape file page]
+  (when (has-duplicate-swap-slot? shape page)
+    (report-error :duplicate-slot
+                  "This shape has children with the same swap slot"
+                  shape file page)))
+
 (defn- check-shape-main-root-top
   "Root shape of a top main instance:
 
@@ -308,6 +326,7 @@
   (check-component-root shape file page)
   (check-component-not-ref shape file page)
   (check-empty-swap-slot shape file page)
+  (check-duplicate-swap-slot shape file page)
   (run! #(check-shape % file page libraries :context :main-top) (:shapes shape)))
 
 (defn- check-shape-main-root-nested
@@ -335,6 +354,7 @@
     (check-component-root shape file page)
     (check-component-ref shape file page libraries)
     (check-empty-swap-slot shape file page)
+    (check-duplicate-swap-slot shape file page)
     (run! #(check-shape % file page libraries :context :copy-top :library-exists library-exists) (:shapes shape))))
 
 (defn- check-shape-copy-root-nested
@@ -453,13 +473,24 @@
                             shape file page)
               (check-shape-not-component shape file page libraries))))))))
 
+(defn check-component-duplicate-swap-slot
+  [component file]
+  (let [shape (get-in component [:objects (:main-instance-id component)])]
+    (when (has-duplicate-swap-slot? shape component)
+      (report-error :component-duplicate-slot
+                    "This deleted component has children with the same swap slot"
+                    component file nil))))
+
+
 (defn- check-component
   "Validate semantic coherence of a component. Report all errors found."
   [component file]
   (when (and (contains? component :objects) (nil? (:objects component)))
     (report-error :component-nil-objects-not-allowed
                   "Objects list cannot be nil"
-                  component file nil)))
+                  component file nil))
+  (when (:deleted component)
+    (check-component-duplicate-swap-slot component file)))
 
 (defn- get-orphan-shapes
   [{:keys [objects] :as page}]

common/src/app/common/geom/modifiers.cljc

@@ -269,6 +269,13 @@
           (keep (mk-check-auto-layout objects))
           shapes)))
 
+(defn full-tree?
+  "Checks if we need to calculate the full tree or we can calculate just a partial tree. Partial
+  trees are more efficient but cannot be done when the layout is centered."
+  [objects layout-id]
+  (let [layout-justify-content (get-in objects [layout-id :layout-justify-content])]
+    (contains? #{:center :end :space-around :space-evenly :stretch} layout-justify-content)))
+
 (defn sizing-auto-modifiers
   "Recalculates the layouts to adjust the sizing: auto new sizes"
   [modif-tree sizing-auto-layouts objects bounds ignore-constraints]
@@ -286,7 +293,7 @@
                          (d/seek sizing-auto-layouts))
 
                     shapes
-                    (if from-layout
+                    (if (and from-layout (not (full-tree? objects from-layout)))
                       (cgst/resolve-subtree from-layout layout-id objects)
                       (cgst/resolve-tree #{layout-id} objects))
 

common/src/app/common/logging.cljc

@@ -153,14 +153,29 @@
 (defn build-message
   [props]
   (loop [props  (seq props)
-         result []]
+         result []
+         body   nil]
     (if-let [[k v] (first props)]
-      (if (simple-ident? k)
+      (cond
+        (simple-ident? k)
         (recur (next props)
-               (conj result (str (name k) "=" (pr-str v))))
+               (conj result (str (name k) "=" (pr-str v)))
+               body)
+
+        (= ::body k)
         (recur (next props)
-               result))
-      (str/join ", " result))))
+               result
+               v)
+
+        :else
+        (recur (next props)
+               result
+               body))
+
+      (let [message (str/join ", " result)]
+        (if (string? body)
+          (str message "\n" body)
+          message)))))
 
 (defn build-stack-trace
   [cause]

common/src/app/common/logic/libraries.cljc

@@ -4,7 +4,7 @@
 ;;
 ;; Copyright (c) KALEIDOS INC
 
-(ns app.main.data.workspace.libraries-helpers
+(ns app.common.logic.libraries
   (:require
    [app.common.data :as d]
    [app.common.data.macros :as dm]
@@ -14,6 +14,7 @@
    [app.common.geom.shapes :as gsh]
    [app.common.geom.shapes.grid-layout :as gslg]
    [app.common.logging :as log]
+   [app.common.logic.shapes :as cls]
    [app.common.spec :as us]
    [app.common.text :as txt]
    [app.common.types.color :as ctc]
@@ -21,13 +22,15 @@
    [app.common.types.components-list :as ctkl]
    [app.common.types.container :as ctn]
    [app.common.types.file :as ctf]
+   [app.common.types.page :as ctp]
    [app.common.types.pages-list :as ctpl]
    [app.common.types.shape-tree :as ctst]
+   [app.common.types.shape.interactions :as ctsi]
    [app.common.types.shape.layout :as ctl]
    [app.common.types.typography :as cty]
-   [app.main.data.workspace.state-helpers :as wsh]
-   [cljs.spec.alpha :as s]
-   [clojure.set :as set]))
+   [app.common.uuid :as uuid]
+   [clojure.set :as set]
+   [clojure.spec.alpha :as s]))
 
 ;; Change this to :info :debug or :trace to debug this module, or :warn to reset to default
 (log/set-level! :warn)
@@ -37,10 +40,8 @@
 (declare generate-sync-text-shape)
 (declare uses-assets?)
 
-(declare get-assets)
 (declare generate-sync-shape-direct)
 (declare generate-sync-shape-direct-recursive)
-(declare generate-sync-shape-inverse)
 (declare generate-sync-shape-inverse-recursive)
 
 (declare compare-children)
@@ -59,10 +60,10 @@
 (declare make-change)
 
 (defn pretty-file
-  [file-id state]
-  (if (= file-id (:current-file-id state))
+  [file-id libraries current-file-id]
+  (if (= file-id current-file-id)
     "<local>"
-    (str "<" (get-in state [:workspace-libraries file-id :name]) ">")))
+    (str "<" (get-in libraries [file-id :name]) ">")))
 
 (defn pretty-uuid
   [uuid]
@@ -149,6 +150,37 @@
 
         [new-component-shape new-component-shapes nil nil]))))
 
+(defn generate-duplicate-component
+  "Create a new component copied from the one with the given id."
+  [changes library component-id components-v2]
+  (let [component          (ctkl/get-component (:data library) component-id)
+        new-name           (:name component)
+
+        main-instance-page (when components-v2
+                             (ctf/get-component-page (:data library) component))
+
+        new-component-id   (when components-v2
+                             (uuid/next))
+
+        [new-component-shape new-component-shapes  ; <- null in components-v2
+         new-main-instance-shape new-main-instance-shapes]
+        (duplicate-component component new-component-id (:data library))]
+
+    (-> changes
+        (pcb/with-page main-instance-page)
+        (pcb/with-objects (:objects main-instance-page))
+        (pcb/add-objects new-main-instance-shapes {:ignore-touched true})
+        (pcb/add-component (if components-v2
+                             new-component-id
+                             (:id new-component-shape))
+                           (:path component)
+                           new-name
+                           new-component-shapes
+                           []
+                           (:id new-main-instance-shape)
+                           (:id main-instance-page)
+                           (:annotation component)))))
+
 (defn generate-instantiate-component
   "Generate changes to create a new instance from a component."
   ([changes objects file-id component-id position page libraries]
@@ -237,8 +269,8 @@
         ; First level subinstances of a detached component can't have swap-slot
         (pcb/update-shapes [shape-id] ctk/remove-swap-slot)
 
-        :always
-        ; Near shape-refs need to be advanced one level
+        (nil? (ctk/get-swap-slot shape))
+        ; Near shape-refs need to be advanced one level (except if the head is already swapped)
         (generate-advance-nesting-level nil container libraries (:id shape)))
 
       ;; Otherwise, detach the shape and all children
@@ -252,21 +284,39 @@
   (let [children (cfh/get-children-with-self (:objects container) shape-id)
         skip-near (fn [changes shape]
                     (let [ref-shape (ctf/find-ref-shape file container libraries shape {:include-deleted? true})]
-                      (if (some? (:shape-ref ref-shape))
-                        (pcb/update-shapes changes [(:id shape)] #(assoc % :shape-ref (:shape-ref ref-shape)))
-                        changes)))]
+                      (cond-> changes
+                        (some? (:shape-ref ref-shape))
+                        (pcb/update-shapes [(:id shape)] #(assoc % :shape-ref (:shape-ref ref-shape)))
+
+                        ;; When advancing level, the normal touched groups (not swap slots) of the
+                        ;; ref-shape must be merged into the current shape, because they refer to
+                        ;; the new referenced shape.
+                        (some? ref-shape)
+                        (pcb/update-shapes
+                         [(:id shape)]
+                         #(assoc % :touched
+                                 (clojure.set/union (:touched shape)
+                                                    (ctk/normal-touched-groups ref-shape))))
+
+                        ;; Swap slot must also be copied if the current shape has not any,
+                        ;; except if this is the first level subcopy.
+                        (and (some? (ctk/get-swap-slot ref-shape))
+                             (nil? (ctk/get-swap-slot shape))
+                             (not= (:id shape) shape-id))
+                        (pcb/update-shapes [(:id shape)] #(ctk/set-swap-slot % (ctk/get-swap-slot ref-shape))))))]
+
     (reduce skip-near changes children)))
 
 (defn prepare-restore-component
-  ([library-data component-id current-page it]
+  ([changes library-data component-id current-page]
    (let [component    (ctkl/get-deleted-component library-data component-id)
          page         (or (ctf/get-component-page library-data component)
                           (when (some #(= (:id current-page) %) (:pages library-data)) ;; If the page doesn't belong to the library, it's not valid
                             current-page)
                           (ctpl/get-last-page library-data))]
-     (prepare-restore-component nil library-data component-id it page (gpt/point 0 0) nil nil nil)))
+     (prepare-restore-component changes library-data component-id page (gpt/point 0 0) nil nil nil)))
 
-  ([changes library-data component-id it page delta old-id parent-id frame-id]
+  ([changes library-data component-id page delta old-id parent-id frame-id]
    (let [component         (ctkl/get-deleted-component library-data component-id)
          parent            (get-in page [:objects parent-id])
          main-inst         (get-in component [:objects (:main-instance-id component)])
@@ -288,7 +338,7 @@
                              (not inside-component?)
                              (assoc :component-root true))
 
-         changes           (-> (or changes (pcb/empty-changes it))
+         changes           (-> changes
                                (pcb/with-page page)
                                (pcb/with-objects (:objects page))
                                (pcb/with-library-data library-data))
@@ -308,7 +358,7 @@
 
   If an asset id is given, only shapes linked to this particular asset will
   be synchronized."
-  [it file-id asset-type asset-id library-id state]
+  [changes file-id asset-type asset-id library-id libraries current-file-id]
   (s/assert #{:colors :components :typographies} asset-type)
   (s/assert (s/nilable ::us/uuid) asset-id)
   (s/assert ::us/uuid file-id)
@@ -317,25 +367,26 @@
   (log/info :msg "Sync file with library"
             :asset-type asset-type
             :asset-id asset-id
-            :file (pretty-file file-id state)
-            :library (pretty-file library-id state))
+            :file (pretty-file file-id libraries current-file-id)
+            :library (pretty-file library-id libraries current-file-id))
 
-  (let [file          (wsh/get-file state file-id)
+  (let [file          (get-in libraries [file-id :data])
         components-v2 (get-in file [:options :components-v2])]
     (loop [containers (ctf/object-containers-seq file)
-           changes (pcb/empty-changes it)]
+           changes    changes]
       (if-let [container (first containers)]
         (do
           (recur (next containers)
-                 (pcb/concat-changes
+                 (pcb/concat-changes ;;TODO Remove concat changes
                   changes
-                  (generate-sync-container it
+                  (generate-sync-container (pcb/empty-changes nil)
                                            asset-type
                                            asset-id
                                            library-id
-                                           state
                                            container
-                                           components-v2))))
+                                           components-v2
+                                           libraries
+                                           current-file-id))))
         changes))))
 
 (defn generate-sync-library
@@ -345,7 +396,7 @@
 
   If an asset id is given, only shapes linked to this particular asset will
   be synchronized."
-  [it file-id asset-type asset-id library-id state]
+  [changes file-id asset-type asset-id library-id libraries current-file-id]
   (s/assert #{:colors :components :typographies} asset-type)
   (s/assert (s/nilable ::us/uuid) asset-id)
   (s/assert ::us/uuid file-id)
@@ -354,30 +405,31 @@
   (log/info :msg "Sync local components with library"
             :asset-type asset-type
             :asset-id asset-id
-            :file (pretty-file file-id state)
-            :library (pretty-file library-id state))
+            :file (pretty-file file-id libraries current-file-id)
+            :library (pretty-file library-id libraries current-file-id))
 
-  (let [file          (wsh/get-file state file-id)
+  (let [file          (get-in libraries [file-id :data])
         components-v2 (get-in file [:options :components-v2])]
     (loop [local-components (ctkl/components-seq file)
-           changes (pcb/empty-changes it)]
+           changes changes]
       (if-let [local-component (first local-components)]
         (recur (next local-components)
-               (pcb/concat-changes
+               (pcb/concat-changes ;;TODO Remove concat changes
                 changes
-                (generate-sync-container it
-                                         asset-type
-                                         asset-id
-                                         library-id
-                                         state
-                                         (cfh/make-container local-component :component)
-                                         components-v2)))
+                (generate-sync-container  (pcb/empty-changes nil)
+                                          asset-type
+                                          asset-id
+                                          library-id
+                                          (cfh/make-container local-component :component)
+                                          components-v2
+                                          libraries
+                                          current-file-id)))
         changes))))
 
 (defn- generate-sync-container
   "Generate changes to synchronize all shapes in a particular container (a page
   or a component) that use assets of the given type in the given library."
-  [it asset-type asset-id library-id state container components-v2]
+  [changes asset-type asset-id library-id container components-v2 libraries current-file-id]
 
   (if (cfh/page? container)
     (log/debug :msg "Sync page in local file" :page-id (:id container))
@@ -386,7 +438,7 @@
   (let [linked-shapes (->> (vals (:objects container))
                            (filter #(uses-assets? asset-type asset-id % library-id)))]
     (loop [shapes (seq linked-shapes)
-           changes (-> (pcb/empty-changes it)
+           changes (-> changes
                        (pcb/with-container container)
                        (pcb/with-objects (:objects container)))]
       (if-let [shape (first shapes)]
@@ -394,10 +446,11 @@
                (generate-sync-shape asset-type
                                     changes
                                     library-id
-                                    state
                                     container
                                     shape
-                                    components-v2))
+                                    components-v2
+                                    libraries
+                                    current-file-id))
         changes))))
 
 (defmulti uses-assets?
@@ -425,33 +478,32 @@
 (defmulti generate-sync-shape
   "Generate changes to synchronize one shape from all assets of the given type
   that is using, in the given library."
-  (fn [asset-type _changes _library-id _state _container _shape _components-v2] asset-type))
+  (fn [asset-type _changes _library-id _container _shape _components-v2 _libraries _current-file-id] asset-type))
 
 (defmethod generate-sync-shape :components
-  [_ changes _library-id state container shape components-v2]
+  [_ changes _library-id container shape components-v2 libraries current-file-id]
   (let [shape-id  (:id shape)
-        file      (wsh/get-local-file-full state)
-        libraries (wsh/get-libraries state)]
+        file      (get current-file-id libraries)]
     (generate-sync-shape-direct changes file libraries container shape-id false components-v2)))
 
 (defmethod generate-sync-shape :colors
-  [_ changes library-id state _ shape _]
+  [_ changes library-id _ shape _ libraries _]
   (log/debug :msg "Sync colors of shape" :shape (:name shape))
 
   ;; Synchronize a shape that uses some colors of the library. The value of the
   ;; color in the library is copied to the shape.
-  (let [library-colors (get-assets library-id :colors state)]
+  (let [library-colors (get-in libraries [library-id :data :colors])]
     (pcb/update-shapes changes
                        [(:id shape)]
                        #(ctc/sync-shape-colors % library-id library-colors))))
 
 (defmethod generate-sync-shape :typographies
-  [_ changes library-id state container shape _]
+  [_ changes library-id container shape _ libraries _]
   (log/debug :msg "Sync typographies of shape" :shape (:name shape))
 
   ;; Synchronize a shape that uses some typographies of the library. The attributes
   ;; of the typography are copied to the shape."
-  (let [typographies (get-assets library-id :typographies state)
+  (let [typographies  (get-in libraries [library-id :data :typographies])
         update-node (fn [node]
                       (if-let [typography (get typographies (:typography-ref-id node))]
                         (merge node (dissoc typography :name :id))
@@ -459,12 +511,6 @@
                                 :typography-ref-file)))]
     (generate-sync-text-shape changes shape container update-node)))
 
-(defn- get-assets
-  [library-id asset-type state]
-  (if (= library-id (:current-file-id state))
-    (get-in state [:workspace-data asset-type])
-    (get-in state [:workspace-libraries library-id :data asset-type])))
-
 (defn- generate-sync-text-shape
   [changes shape container update-node]
   (let [old-content (:content shape)
@@ -821,8 +867,8 @@
                         reset?
                         components-v2))))
 
-
-(defn- generate-rename-component
+(defn generate-rename-component
+  "Generate the changes for rename the component with the given id, in the current file library."
   [changes id new-name library-data components-v2]
   (let [[path name]   (cfh/parse-path-name new-name)
         update-fn
@@ -1166,7 +1212,7 @@
                                                        :shapes all-parents}))
         changes' (reduce del-obj-change changes' new-shapes)]
 
-    (if (and (cfh/touched-group? parent-shape :shapes-group) omit-touched?)
+    (if (and (ctk/touched-group? parent-shape :shapes-group) omit-touched?)
       changes
       changes')))
 
@@ -1321,7 +1367,7 @@
                          changes'
                          ids)]
 
-    (if (and (cfh/touched-group? parent :shapes-group) omit-touched?)
+    (if (and (ctk/touched-group? parent :shapes-group) omit-touched?)
       changes
       changes')))
 
@@ -1357,7 +1403,7 @@
                                                   :ignore-touched true
                                                   :syncing true})))]
 
-    (if (and (cfh/touched-group? parent :shapes-group) omit-touched?)
+    (if (and (ctk/touched-group? parent :shapes-group) omit-touched?)
       changes
       changes')))
 
@@ -1672,3 +1718,521 @@
   (if (cfh/page? container)
     (assoc change :page-id (:id container))
     (assoc change :component-id (:id container))))
+
+(defn generate-add-component-changes
+  [changes root objects file-id page-id components-v2]
+  (let [name (:name root)
+        [path name] (cfh/parse-path-name name)
+
+        [root-shape new-shapes updated-shapes]
+        (if-not components-v2
+          (ctn/make-component-shape root objects file-id components-v2)
+          (ctn/convert-shape-in-component root objects file-id))
+
+        changes (-> changes
+                    (pcb/add-component (:id root-shape)
+                                       path
+                                       name
+                                       new-shapes
+                                       updated-shapes
+                                       (:id root)
+                                       page-id))]
+    [root-shape changes]))
+
+(defn generate-add-component
+  "If there is exactly one id, and it's a frame (or a group in v1), and not already a component,
+  use it as root. Otherwise, create a frame (v2) or group (v1) that contains all ids. Then, make a
+  component with it, and link all shapes to their corresponding one in the component."
+  [changes shapes objects page-id file-id components-v2 prepare-create-group prepare-create-board]
+
+  (let [changes      (pcb/with-page-id changes page-id)
+        shapes-count (count shapes)
+        first-shape  (first shapes)
+
+        from-singe-frame?
+        (and (= 1 shapes-count)
+             (cfh/frame-shape? first-shape))
+
+        [root changes old-root-ids]
+        (if (and (= shapes-count 1)
+                 (or (and (cfh/group-shape? first-shape)
+                          (not components-v2))
+                     (cfh/frame-shape? first-shape))
+                 (not (ctk/instance-head? first-shape)))
+          [first-shape
+           (-> changes
+               (pcb/with-page-id page-id)
+               (pcb/with-objects objects))
+           (:shapes first-shape)]
+
+          (let [root-name (if (= 1 shapes-count)
+                            (:name first-shape)
+                            "Component 1")
+
+                shape-ids (into (d/ordered-set) (map :id) shapes)
+
+                [root changes]
+                (if-not components-v2
+                  (prepare-create-group changes       ; These functions needs to be passed as argument
+                                        objects       ; to avoid a circular dependence
+                                        page-id
+                                        shapes
+                                        root-name
+                                        (not (ctk/instance-head? first-shape)))
+                  (prepare-create-board changes
+                                        (uuid/next)
+                                        (:parent-id first-shape)
+                                        objects
+                                        shape-ids
+                                        nil
+                                        root-name
+                                        true))]
+
+            [root changes shape-ids]))
+
+        changes
+        (cond-> changes
+          (not from-singe-frame?)
+          (pcb/update-shapes
+           (:shapes root)
+           (fn [shape]
+             (assoc shape :constraints-h :scale :constraints-v :scale))))
+
+        objects' (assoc objects (:id root) root)
+
+        [root-shape changes] (generate-add-component-changes changes root objects' file-id page-id components-v2)
+
+        changes  (pcb/update-shapes changes
+                                    old-root-ids
+                                    #(dissoc % :component-root)
+                                    [:component-root])]
+
+    [root (:id root-shape) changes]))
+
+(defn generate-restore-component
+  "Restore a deleted component, with the given id, in the given file library."
+  [changes library-data component-id library-id current-page objects]
+  (let [{:keys [changes shape]} (prepare-restore-component changes library-data component-id current-page)
+        parent-id (:parent-id shape)
+        objects (cond-> (assoc objects (:id shape) shape)
+                  (not (nil? parent-id))
+                  (update-in [parent-id :shapes]
+                             #(conj % (:id shape))))
+
+        ;; Adds a resize-parents operation so the groups are updated. We add all the new objects
+        new-objects-ids (->> changes :redo-changes (filter #(= (:type %) :add-obj)) (mapv :id))
+        changes (-> changes
+                    (pcb/with-objects objects)
+                    (pcb/resize-parents new-objects-ids))]
+
+    (assoc changes :file-id library-id)))
+
+(defn generate-detach-component
+  "Generate changes for remove all references to components in the shape,
+  with the given id and all its children, at the current page."
+  [changes id file page-id libraries]
+  (let [container (cfh/get-container file :page page-id)]
+    (-> changes
+        (pcb/with-container container)
+        (pcb/with-objects (:objects container))
+        (generate-detach-instance container libraries id))))
+
+(defn generate-new-shape-for-swap
+  [changes shape file page libraries id-new-component index target-cell keep-props-values]
+  (let [objects      (:objects page)
+        position     (gpt/point (:x shape) (:y shape))
+        changes      (-> changes
+                         (pcb/with-objects objects))
+        position     (-> position (with-meta {:cell target-cell}))
+        parent       (get objects (:parent-id shape))
+        inside-comp? (ctn/in-any-component? objects parent)
+
+        [new-shape changes]
+        (generate-instantiate-component changes
+                                        objects
+                                        (:id file)
+                                        id-new-component
+                                        position
+                                        page
+                                        libraries
+                                        nil
+                                        (:parent-id shape)
+                                        (:frame-id shape)
+                                        {:force-frame? true})
+
+        new-shape (cond-> new-shape
+                    ;; if the shape isn't inside a main component, it shouldn't have a swap slot
+                    (and (nil? (ctk/get-swap-slot new-shape))
+                         inside-comp?)
+                    (ctk/set-swap-slot (ctf/find-swap-slot shape
+                                                           page
+                                                           {:id (:id file)
+                                                            :data file}
+                                                           libraries)))]
+
+    [new-shape (-> changes
+                   ;; Restore the properties
+                   (pcb/update-shapes [(:id new-shape)] #(d/patch-object % keep-props-values))
+
+                   ;; We need to set the same index as the original shape
+                   (pcb/change-parent (:parent-id shape) [new-shape] index {:component-swap true
+                                                                            :ignore-touched true})
+                   (change-touched new-shape
+                                   shape
+                                   (ctn/make-container page :page)
+                                   {}))]))
+
+(defn generate-component-swap
+  [changes objects shape file page libraries id-new-component index target-cell keep-props-values]
+  (let [[all-parents changes]
+        (-> changes
+            (cls/generate-delete-shapes file page objects (d/ordered-set (:id shape)) {:components-v2 true
+                                                                                       :component-swap true}))
+        [new-shape changes]
+        (-> changes
+            (generate-new-shape-for-swap shape file page libraries id-new-component index target-cell keep-props-values))]
+    [new-shape all-parents changes]))
+
+(defn generate-sync-file-changes
+  [changes undo-group asset-type file-id asset-id library-id libraries current-file-id]
+  (let [sync-components?   (or (nil? asset-type) (= asset-type :components))
+        sync-colors?       (or (nil? asset-type) (= asset-type :colors))
+        sync-typographies? (or (nil? asset-type) (= asset-type :typographies))]
+    (cond-> changes
+      :always
+      (pcb/set-undo-group undo-group)
+      ;; library-changes
+      sync-components?
+      (generate-sync-library file-id :components asset-id library-id libraries current-file-id)
+      sync-colors?
+      (generate-sync-library file-id :colors asset-id library-id libraries current-file-id)
+      sync-typographies?
+      (generate-sync-library file-id :typographies asset-id library-id libraries current-file-id)
+
+      ;; file-changes
+      sync-components?
+      (generate-sync-file file-id :components asset-id library-id libraries current-file-id)
+      sync-colors?
+      (generate-sync-file file-id :colors asset-id library-id libraries current-file-id)
+      sync-typographies?
+      (generate-sync-file file-id :typographies asset-id library-id libraries current-file-id))))
+
+(defn generate-sync-head
+  [changes file-full libraries container id components-v2 reset?]
+  (let [shape-inst (ctn/get-shape container id)
+        objects    (:objects container)
+        parent     (get objects (:parent-id shape-inst))
+        head       (ctn/get-component-shape container parent)
+        changes
+        (-> changes
+            (pcb/with-container container)
+            (pcb/with-objects (:objects container))
+            (generate-sync-shape-direct file-full libraries container (:id head) reset? components-v2))]
+    changes))
+
+(defn generate-reset-component
+  [changes file-full libraries container id components-v2]
+  (let [objects    (:objects container)
+        swap-slot  (-> (ctn/get-shape container id)
+                       (ctk/get-swap-slot))
+        changes
+        (-> changes
+            (pcb/with-container container)
+            (pcb/with-objects objects)
+            (generate-sync-shape-direct file-full libraries container id true components-v2))]
+
+    (cond-> changes
+      (some? swap-slot)
+      (generate-sync-head file-full libraries container id components-v2 true))))
+
+(defn generate-duplicate-flows
+  [changes shapes page ids-map]
+  (let [flows            (-> page :options :flows)
+        unames           (volatile! (into #{} (map :name flows)))
+        frames-with-flow (->> shapes
+                              (filter #(= (:type %) :frame))
+                              (filter #(some? (ctp/get-frame-flow flows (:id %)))))]
+    (if-not (empty? frames-with-flow)
+      (let [update-flows (fn [flows]
+                           (reduce
+                            (fn [flows frame]
+                              (let [name     (cfh/generate-unique-name @unames "Flow 1")
+                                    _        (vswap! unames conj name)
+                                    new-flow {:id (uuid/next)
+                                              :name name
+                                              :starting-frame (get ids-map (:id frame))}]
+                                (ctp/add-flow flows new-flow)))
+                            flows
+                            frames-with-flow))]
+        (pcb/update-page-option changes :flows update-flows))
+      changes)))
+
+(defn generate-duplicate-guides
+  [changes shapes page ids-map delta]
+  (let [guides (get-in page [:options :guides])
+        frames (->> shapes (filter cfh/frame-shape?))
+
+        new-guides
+        (reduce
+         (fn [g frame]
+           (let [new-id     (ids-map (:id frame))
+                 new-frame  (-> frame (gsh/move delta))
+
+                 new-guides
+                 (->> guides
+                      (vals)
+                      (filter #(= (:frame-id %) (:id frame)))
+                      (map #(-> %
+                                (assoc :id (uuid/next))
+                                (assoc :frame-id new-id)
+                                (assoc :position (if (= (:axis %) :x)
+                                                   (+ (:position %) (- (:x new-frame) (:x frame)))
+                                                   (+ (:position %) (- (:y new-frame) (:y frame))))))))]
+             (cond-> g
+               (not-empty new-guides)
+               (conj (into {} (map (juxt :id identity) new-guides))))))
+         guides
+         frames)]
+    (-> (pcb/with-page changes page)
+        (pcb/set-page-option :guides new-guides))))
+
+(defn generate-duplicate-component-change
+  [changes objects page component-root parent-id frame-id delta libraries library-data]
+  (let [component-id (:component-id component-root)
+        file-id (:component-file component-root)
+        main-component    (ctf/get-component libraries file-id component-id)
+        moved-component   (gsh/move component-root delta)
+        pos               (gpt/point (:x moved-component) (:y moved-component))
+        origin-frame      (get-in page [:objects frame-id])
+        delta             (cond-> delta
+                            (some? origin-frame)
+                            (gpt/subtract (-> origin-frame :selrect gpt/point)))
+
+        instantiate-component
+        #(generate-instantiate-component changes
+                                         objects
+                                         file-id
+                                         (:component-id component-root)
+                                         pos
+                                         page
+                                         libraries
+                                         (:id component-root)
+                                         parent-id
+                                         frame-id
+                                         {})
+
+        restore-component
+        #(let [restore (prepare-restore-component changes library-data (:component-id component-root) page delta (:id component-root) parent-id frame-id)]
+           [(:shape restore) (:changes restore)])
+
+        [_shape changes]
+        (if (nil? main-component)
+          (restore-component)
+          (instantiate-component))]
+    changes))
+
+(defn generate-duplicate-shape-change
+  ([changes objects page unames update-unames! ids-map obj delta level-delta libraries library-data file-id]
+   (generate-duplicate-shape-change changes objects page unames update-unames! ids-map obj delta level-delta libraries library-data file-id (:frame-id obj) (:parent-id obj) false false true))
+
+  ([changes objects page unames update-unames! ids-map obj delta level-delta libraries library-data file-id frame-id parent-id duplicating-component? child? remove-swap-slot?]
+   (cond
+     (nil? obj)
+     changes
+
+     (ctf/is-main-of-known-component? obj libraries)
+     (generate-duplicate-component-change changes objects page obj parent-id frame-id delta libraries library-data)
+
+     :else
+     (let [frame?      (cfh/frame-shape? obj)
+           group?      (cfh/group-shape? obj)
+           bool?       (cfh/bool-shape? obj)
+           new-id      (ids-map (:id obj))
+           parent-id   (or parent-id frame-id)
+           parent      (get objects parent-id)
+           name        (:name obj)
+
+           is-component-root?     (or (:saved-component-root obj)
+                                      ;; Backward compatibility
+                                      (:saved-component-root? obj)
+                                      (ctk/instance-root? obj))
+           duplicating-component? (or duplicating-component? (ctk/instance-head? obj))
+           is-component-main?     (ctk/main-instance? obj)
+           subinstance-head?      (ctk/subinstance-head? obj)
+           instance-root?         (ctk/instance-root? obj)
+
+           into-component?        (and duplicating-component?
+                                       (ctn/in-any-component? objects parent))
+
+           level-delta            (if (some? level-delta)
+                                    level-delta
+                                    (ctn/get-nesting-level-delta objects obj parent))
+           new-shape-ref          (ctf/advance-shape-ref nil page libraries obj level-delta {:include-deleted? true})
+
+           regenerate-component
+           (fn [changes shape]
+             (let [components-v2 (dm/get-in library-data [:options :components-v2])
+                   [_ changes] (generate-add-component-changes changes shape objects file-id (:id page) components-v2)]
+               changes))
+
+           new-obj
+           (-> obj
+               (assoc :id new-id
+                      :name name
+                      :parent-id parent-id
+                      :frame-id frame-id)
+
+               (cond-> (and (not instance-root?)
+                            subinstance-head?
+                            remove-swap-slot?)
+                 (ctk/remove-swap-slot))
+
+               (dissoc :shapes
+                       :use-for-thumbnail)
+
+               (cond-> (not is-component-root?)
+                 (dissoc :main-instance))
+
+               (cond-> into-component?
+                 (dissoc :component-root))
+
+               (cond-> (and (ctk/instance-head? obj)
+                            (not into-component?))
+                 (assoc :component-root true))
+
+               (cond-> (or frame? group? bool?)
+                 (assoc :shapes []))
+
+               (cond-> (and (some? new-shape-ref)
+                            (not= new-shape-ref (:shape-ref obj)))
+                 (assoc :shape-ref new-shape-ref))
+
+               (gsh/move delta)
+               (d/update-when :interactions #(ctsi/remap-interactions % ids-map objects))
+
+               (cond-> (ctl/grid-layout? obj)
+                 (ctl/remap-grid-cells ids-map)))
+
+           new-obj (cond-> new-obj
+                     (not duplicating-component?)
+                     (ctk/detach-shape))
+
+           ;; We want the first added object to touch it's parent, but not subsequent children
+           changes (-> (pcb/add-object changes new-obj {:ignore-touched (and duplicating-component? child?)})
+                       (pcb/amend-last-change #(assoc % :old-id (:id obj)))
+                       (cond-> (ctl/grid-layout? objects (:parent-id obj))
+                         (-> (pcb/update-shapes [(:parent-id obj)] ctl/assign-cells {:with-objects? true})
+                             (pcb/reorder-grid-children [(:parent-id obj)]))))
+
+           changes (cond-> changes
+                     (and is-component-root? is-component-main?)
+                     (regenerate-component new-obj))
+
+           ;; This is needed for the recursive call to find the new object as parent
+           page' (ctst/add-shape (:id new-obj)
+                                 new-obj
+                                 {:objects objects}
+                                 (:frame-id new-obj)
+                                 (:parent-id new-obj)
+                                 nil
+                                 true)]
+
+       (reduce (fn [changes child]
+                 (generate-duplicate-shape-change changes
+                                                  (:objects page')
+                                                  page
+                                                  unames
+                                                  update-unames!
+                                                  ids-map
+                                                  child
+                                                  delta
+                                                  level-delta
+                                                  libraries
+                                                  library-data
+                                                  file-id
+                                                  (if frame? new-id frame-id)
+                                                  new-id
+                                                  duplicating-component?
+                                                  true
+                                                  (and remove-swap-slot?
+                                                               ;; only remove swap slot of children when the current shape
+                                                               ;; is not a subinstance head nor a instance root
+                                                       (not subinstance-head?)
+                                                       (not instance-root?))))
+               changes
+               (map (d/getf objects) (:shapes obj)))))))
+
+(defn generate-duplicate-changes
+  "Prepare objects to duplicate: generate new id, give them unique names,
+  move to the desired position, and recalculate parents and frames as needed."
+  [changes all-objects page ids delta libraries library-data file-id]
+  (let [shapes         (map (d/getf all-objects) ids)
+        unames         (volatile! (cfh/get-used-names (:objects page)))
+        update-unames! (fn [new-name] (vswap! unames conj new-name))
+        all-ids        (reduce #(into %1 (cons %2 (cfh/get-children-ids all-objects %2))) (d/ordered-set) ids)
+
+         ;; We need ids-map for remapping the grid layout. But when duplicating the guides
+         ;; we calculate a new one because the components will have created new shapes.
+        ids-map        (into {} (map #(vector % (uuid/next))) all-ids)
+
+        changes (-> changes
+                    (pcb/with-page page)
+                    (pcb/with-objects all-objects))
+        changes
+        (->> shapes
+             (reduce #(generate-duplicate-shape-change %1
+                                                       all-objects
+                                                       page
+                                                       unames
+                                                       update-unames!
+                                                       ids-map
+                                                       %2
+                                                       delta
+                                                       nil
+                                                       libraries
+                                                       library-data
+                                                       file-id)
+                     changes))
+
+         ;; We need to check the changes to get the ids-map
+        ids-map
+        (into {}
+              (comp
+               (filter #(= :add-obj (:type %)))
+               (map #(vector (:old-id %) (-> % :obj :id))))
+              (:redo-changes changes))]
+
+    (-> changes
+        (generate-duplicate-flows shapes page ids-map)
+        (generate-duplicate-guides shapes page ids-map delta))))
+
+(defn generate-duplicate-changes-update-indices
+  "Updates the changes to correctly set the indexes of the duplicated objects,
+  depending on the index of the original object respect their parent."
+  [changes objects ids]
+  (let [;; index-map is a map that goes from parent-id => vector([id index-in-parent])
+        index-map (reduce (fn [index-map id]
+                            (let [parent-id    (get-in objects [id :parent-id])
+                                  parent-index (cfh/get-position-on-parent objects id)]
+                              (update index-map parent-id (fnil conj []) [id parent-index])))
+                          {}
+                          ids)
+
+        inc-indices
+        (fn [[offset result] [id index]]
+          [(inc offset) (conj result [id (+ index offset)])])
+
+        fix-indices
+        (fn [_ entry]
+          (->> entry
+               (sort-by second)
+               (reduce inc-indices [1 []])
+               (second)
+               (into {})))
+
+        objects-indices (->> index-map (d/mapm fix-indices) (vals) (reduce merge))]
+
+    (pcb/amend-changes
+     changes
+     (fn [change]
+       (assoc change :index (get objects-indices (:old-id change)))))))

common/src/app/common/logic/shapes.cljc

@@ -0,0 +1,532 @@
+;; 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.logic.shapes
+  (:require
+   [app.common.data :as d]
+   [app.common.data.macros :as dm]
+   [app.common.files.changes-builder :as pcb]
+   [app.common.files.helpers :as cfh]
+   [app.common.geom.shapes :as gsh]
+   [app.common.types.component :as ctk]
+   [app.common.types.container :as ctn]
+   [app.common.types.page :as ctp]
+   [app.common.types.shape.interactions :as ctsi]
+   [app.common.types.shape.layout :as ctl]
+   [app.common.uuid :as uuid]))
+
+(defn generate-update-shapes
+  [changes ids update-fn objects {:keys [attrs ignore-tree ignore-touched with-objects?]}]
+  (let [changes   (reduce
+                   (fn [changes id]
+                     (let [opts {:attrs attrs
+                                 :ignore-geometry? (get ignore-tree id)
+                                 :ignore-touched ignore-touched
+                                 :with-objects? with-objects?}]
+                       (pcb/update-shapes changes [id] update-fn (d/without-nils opts))))
+                   (-> changes
+                       (pcb/with-objects objects))
+                   ids)
+        grid-ids (->> ids (filter (partial ctl/grid-layout? objects)))
+        changes (pcb/update-shapes changes grid-ids ctl/assign-cell-positions {:with-objects? true})
+        changes (pcb/reorder-grid-children changes ids)]
+    changes))
+
+(defn- generate-update-shape-flags
+  [changes ids objects {:keys [blocked hidden] :as flags}]
+  (let [update-fn
+        (fn [obj]
+          (cond-> obj
+            (boolean? blocked) (assoc :blocked blocked)
+            (boolean? hidden) (assoc :hidden hidden)))
+
+        ids     (if (boolean? blocked)
+                  (into ids (->> ids (mapcat #(cfh/get-children-ids objects %))))
+                  ids)]
+    (-> changes
+        (pcb/update-shapes ids update-fn {:attrs #{:blocked :hidden}}))))
+
+(defn generate-delete-shapes
+  [changes file page objects ids {:keys [components-v2 ignore-touched component-swap]}]
+  (let [ids           (cfh/clean-loops objects ids)
+
+        in-component-copy?
+        (fn [shape-id]
+          ;; Look for shapes that are inside a component copy, but are
+          ;; not the root. In this case, they must not be deleted,
+          ;; but hidden (to be able to recover them more easily).
+          ;; Unless we are doing a component swap, in which case we want
+          ;; to delete the old shape
+          (let [shape           (get objects shape-id)]
+            (and (ctn/has-any-copy-parent? objects shape)
+                 (not component-swap))))
+
+        [ids-to-delete ids-to-hide]
+        (if components-v2
+          (loop [ids-seq       (seq ids)
+                 ids-to-delete []
+                 ids-to-hide   []]
+            (let [id (first ids-seq)]
+              (if (nil? id)
+                [ids-to-delete ids-to-hide]
+                (if (in-component-copy? id)
+                  (recur (rest ids-seq)
+                         ids-to-delete
+                         (conj ids-to-hide id))
+                  (recur (rest ids-seq)
+                         (conj ids-to-delete id)
+                         ids-to-hide)))))
+          [ids []])
+
+        changes (-> changes
+                    (pcb/with-page page)
+                    (pcb/with-objects objects)
+                    (pcb/with-library-data file))
+        lookup  (d/getf objects)
+        groups-to-unmask
+        (reduce (fn [group-ids id]
+                  ;; When the shape to delete is the mask of a masked group,
+                  ;; the mask condition must be removed, and it must be
+                  ;; converted to a normal group.
+                  (let [obj    (lookup id)
+                        parent (lookup (:parent-id obj))]
+                    (if (and (:masked-group parent)
+                             (= id (first (:shapes parent))))
+                      (conj group-ids (:id parent))
+                      group-ids)))
+                #{}
+                ids-to-delete)
+
+        interacting-shapes
+        (filter (fn [shape]
+                  ;; If any of the deleted shapes is the destination of
+                  ;; some interaction, this must be deleted, too.
+                  (let [interactions (:interactions shape)]
+                    (some #(and (ctsi/has-destination %)
+                                (contains? ids-to-delete (:destination %)))
+                          interactions)))
+                (vals objects))
+
+        ids-set (set ids-to-delete)
+        guides-to-remove
+        (->> (dm/get-in page [:options :guides])
+             (vals)
+             (filter #(contains? ids-set (:frame-id %)))
+             (map :id))
+
+        guides
+        (->> guides-to-remove
+             (reduce dissoc (dm/get-in page [:options :guides])))
+
+        starting-flows
+        (filter (fn [flow]
+                  ;; If any of the deleted is a frame that starts a flow,
+                  ;; this must be deleted, too.
+                  (contains? ids-to-delete (:starting-frame flow)))
+                (-> page :options :flows))
+
+        all-parents
+        (reduce (fn [res id]
+                  ;; All parents of any deleted shape must be resized.
+                  (into res (cfh/get-parent-ids objects id)))
+                (d/ordered-set)
+                ids-to-delete)
+
+        all-children
+        (->> ids-to-delete ;; Children of deleted shapes must be also deleted.
+             (reduce (fn [res id]
+                       (into res (cfh/get-children-ids objects id)))
+                     [])
+             (reverse)
+             (into (d/ordered-set)))
+
+        find-all-empty-parents
+        (fn recursive-find-empty-parents [empty-parents]
+          (let [all-ids   (into empty-parents ids-to-delete)
+                contains? (partial contains? all-ids)
+                xform     (comp (map lookup)
+                                (filter #(or (cfh/group-shape? %) (cfh/bool-shape? %)))
+                                (remove #(->> (:shapes %) (remove contains?) seq))
+                                (map :id))
+                parents   (into #{} xform all-parents)]
+            (if (= empty-parents parents)
+              empty-parents
+              (recursive-find-empty-parents parents))))
+
+        empty-parents
+        ;; Any parent whose children are all deleted, must be deleted too.
+        (into (d/ordered-set) (find-all-empty-parents #{}))
+
+        components-to-delete
+        (if components-v2
+          (reduce (fn [components id]
+                    (let [shape (get objects id)]
+                      (if (and (= (:component-file shape) (:id file)) ;; Main instances should exist only in local file
+                               (:main-instance shape))                ;; but check anyway
+                        (conj components (:component-id shape))
+                        components)))
+                  []
+                  (into ids-to-delete all-children))
+          [])
+
+        changes (-> changes
+                    (pcb/set-page-option :guides guides))
+
+        changes (reduce (fn [changes component-id]
+                          ;; It's important to delete the component before the main instance, because we
+                          ;; need to store the instance position if we want to restore it later.
+                          (pcb/delete-component changes component-id (:id page)))
+                        changes
+                        components-to-delete)
+        changes (-> changes
+                    (generate-update-shape-flags ids-to-hide objects {:hidden true})
+                    (pcb/remove-objects all-children {:ignore-touched true})
+                    (pcb/remove-objects ids-to-delete {:ignore-touched ignore-touched})
+                    (pcb/remove-objects empty-parents)
+                    (pcb/resize-parents all-parents)
+                    (pcb/update-shapes groups-to-unmask
+                                       (fn [shape]
+                                         (assoc shape :masked-group false)))
+                    (pcb/update-shapes (map :id interacting-shapes)
+                                       (fn [shape]
+                                         (d/update-when shape :interactions
+                                                        (fn [interactions]
+                                                          (into []
+                                                                (remove #(and (ctsi/has-destination %)
+                                                                              (contains? ids-to-delete (:destination %))))
+                                                                interactions)))))
+                    (cond-> (seq starting-flows)
+                      (pcb/update-page-option :flows (fn [flows]
+                                                       (->> (map :id starting-flows)
+                                                            (reduce ctp/remove-flow flows))))))]
+    [all-parents changes]))
+
+(defn generate-relocate-shapes [changes objects parents parent-id page-id to-index ids]
+  (let [groups-to-delete
+        (loop [current-id  (first parents)
+               to-check    (rest parents)
+               removed-id? (set ids)
+               result #{}]
+
+          (if-not current-id
+            ;; Base case, no next element
+            result
+
+            (let [group (get objects current-id)]
+              (if (and (not= :frame (:type group))
+                       (not= current-id parent-id)
+                       (empty? (remove removed-id? (:shapes group))))
+
+                ;; Adds group to the remove and check its parent
+                (let [to-check (concat to-check [(cfh/get-parent-id objects current-id)])]
+                  (recur (first to-check)
+                         (rest to-check)
+                         (conj removed-id? current-id)
+                         (conj result current-id)))
+
+                ;; otherwise recur
+                (recur (first to-check)
+                       (rest to-check)
+                       removed-id?
+                       result)))))
+
+        groups-to-unmask
+        (reduce (fn [group-ids id]
+                  ;; When a masked group loses its mask shape, because it's
+                  ;; moved outside the group, the mask condition must be
+                  ;; removed, and it must be converted to a normal group.
+                  (let [obj (get objects id)
+                        parent (get objects (:parent-id obj))]
+                    (if (and (:masked-group parent)
+                             (= id (first (:shapes parent)))
+                             (not= (:id parent) parent-id))
+                      (conj group-ids (:id parent))
+                      group-ids)))
+                #{}
+                ids)
+
+
+        ;; TODO: Probably implementing this using loop/recur will
+        ;; be more efficient than using reduce and continuous data
+        ;; desturcturing.
+
+        ;; Sets the correct components metadata for the moved shapes
+        ;; `shapes-to-detach` Detach from a component instance a shape that was inside a component and is moved outside
+        ;; `shapes-to-deroot` Removes the root flag from a component instance moved inside another component
+        ;; `shapes-to-reroot` Adds a root flag when a nested component instance is moved outside
+        [shapes-to-detach shapes-to-deroot shapes-to-reroot]
+        (reduce (fn [[shapes-to-detach shapes-to-deroot shapes-to-reroot] id]
+                  (let [shape                  (get objects id)
+                        parent                 (get objects parent-id)
+                        component-shape        (ctn/get-component-shape objects shape)
+                        component-shape-parent (ctn/get-component-shape objects parent {:allow-main? true})
+                        root-parent            (ctn/get-instance-root objects parent)
+
+                        detach? (and (ctk/in-component-copy-not-head? shape)
+                                     (not= (:id component-shape)
+                                           (:id component-shape-parent)))
+                        deroot? (and (ctk/instance-root? shape)
+                                     root-parent)
+                        reroot? (and (ctk/subinstance-head? shape)
+                                     (not component-shape-parent))
+
+                        ids-to-detach (when detach?
+                                        (cons id (cfh/get-children-ids objects id)))]
+
+                    [(cond-> shapes-to-detach detach? (into ids-to-detach))
+                     (cond-> shapes-to-deroot deroot? (conj id))
+                     (cond-> shapes-to-reroot reroot? (conj id))]))
+                [[] [] []]
+                (->> ids
+                     (mapcat #(ctn/get-child-heads objects %))
+                     (map :id)))
+
+        shapes-to-unconstraint ids
+
+        ordered-indexes       (cfh/order-by-indexed-shapes objects ids)
+        shapes                (map (d/getf objects) ordered-indexes)
+        parent                (get objects parent-id)
+        component-main-parent (ctn/find-component-main objects parent false)
+        child-heads
+        (->> ordered-indexes
+             (mapcat #(ctn/get-child-heads objects %))
+             (map :id))]
+
+    (-> changes
+        (pcb/with-page-id page-id)
+        (pcb/with-objects objects)
+
+        ;; Remove layout-item properties when moving a shape outside a layout
+        (cond-> (not (ctl/any-layout? parent))
+          (pcb/update-shapes ordered-indexes ctl/remove-layout-item-data))
+
+        ;; Remove the hide in viewer flag
+        (cond-> (and (not= uuid/zero parent-id) (cfh/frame-shape? parent))
+          (pcb/update-shapes ordered-indexes #(cond-> % (cfh/frame-shape? %) (assoc :hide-in-viewer true))))
+
+        ;; Remove the swap slots if it is moving to a different component
+        (pcb/update-shapes child-heads
+                           (fn [shape]
+                             (cond-> shape
+                               (not= component-main-parent (ctn/find-component-main objects shape false))
+                               (ctk/remove-swap-slot))))
+
+        ;; Add component-root property when moving a component outside a component
+        (cond-> (not (ctn/get-instance-root objects parent))
+          (pcb/update-shapes child-heads #(assoc % :component-root true)))
+
+        ;; Move the shapes
+        (pcb/change-parent parent-id
+                           shapes
+                           to-index)
+
+        ;; Remove empty groups
+        (pcb/remove-objects groups-to-delete)
+
+        ;; Unmask groups whose mask have moved outside
+        (pcb/update-shapes groups-to-unmask
+                           (fn [shape]
+                             (assoc shape :masked-group false)))
+
+        ;; Detach shapes moved out of their component
+        (pcb/update-shapes shapes-to-detach ctk/detach-shape)
+
+        ;; Make non root a component moved inside another one
+        (pcb/update-shapes shapes-to-deroot
+                           (fn [shape]
+                             (assoc shape :component-root nil)))
+
+        ;; Make root a subcomponent moved outside its parent component
+        (pcb/update-shapes shapes-to-reroot
+                           (fn [shape]
+                             (assoc shape :component-root true)))
+
+        ;; Reset constraints depending on the new parent
+        (pcb/update-shapes shapes-to-unconstraint
+                           (fn [shape]
+                             (let [frame-id    (if (= (:type parent) :frame)
+                                                 (:id parent)
+                                                 (:frame-id parent))
+                                   moved-shape (assoc shape
+                                                      :parent-id parent-id
+                                                      :frame-id frame-id)]
+                               (assoc shape
+                                      :constraints-h (gsh/default-constraints-h moved-shape)
+                                      :constraints-v (gsh/default-constraints-v moved-shape))))
+                           {:ignore-touched true})
+
+        ;; Fix the sizing when moving a shape
+        (pcb/update-shapes parents
+                           (fn [parent]
+                             (if (ctl/flex-layout? parent)
+                               (cond-> parent
+                                 (ctl/change-h-sizing? (:id parent) objects (:shapes parent))
+                                 (assoc :layout-item-h-sizing :fix)
+
+                                 (ctl/change-v-sizing? (:id parent) objects (:shapes parent))
+                                 (assoc :layout-item-v-sizing :fix))
+                               parent)))
+
+        ;; Update grid layout
+        (cond-> (ctl/grid-layout? objects parent-id)
+          (pcb/update-shapes [parent-id] #(ctl/add-children-to-index % ids objects to-index)))
+
+        (pcb/update-shapes parents
+                           (fn [parent objects]
+                             (cond-> parent
+                               (ctl/grid-layout? parent)
+                               (ctl/assign-cells objects)))
+                           {:with-objects? true})
+
+        (pcb/reorder-grid-children parents)
+
+        ;; If parent locked, lock the added shapes
+        (cond-> (:blocked parent)
+          (pcb/update-shapes ordered-indexes #(assoc % :blocked true)))
+
+        ;; Resize parent containers that need to
+        (pcb/resize-parents parents))))
+
+
+(defn generate-move-shapes-to-frame
+  [changes ids frame-id page-id objects drop-index [row column :as cell]]
+  (let [lookup   (d/getf objects)
+        frame    (get objects frame-id)
+        layout?  (:layout frame)
+
+        component-main-frame (ctn/find-component-main objects frame false)
+
+        shapes (->> ids
+                    (cfh/clean-loops objects)
+                    (keep lookup)
+                    ;;remove shapes inside copies, because we can't change the structure of copies
+                    (remove #(ctk/in-component-copy? (get objects (:parent-id %)))))
+
+        moving-shapes
+        (cond->> shapes
+          (not layout?)
+          (remove #(= (:frame-id %) frame-id))
+
+          layout?
+          (remove #(and (= (:frame-id %) frame-id)
+                        (not= (:parent-id %) frame-id))))
+
+        ordered-indexes (cfh/order-by-indexed-shapes objects (map :id moving-shapes))
+        moving-shapes (map (d/getf objects) ordered-indexes)
+
+        all-parents
+        (reduce (fn [res id]
+                  (into res (cfh/get-parent-ids objects id)))
+                (d/ordered-set)
+                ids)
+
+        find-all-empty-parents
+        (fn recursive-find-empty-parents [empty-parents]
+          (let [all-ids   (into empty-parents ids)
+                contains? (partial contains? all-ids)
+                xform     (comp (map lookup)
+                                (filter cfh/group-shape?)
+                                (remove #(->> (:shapes %) (remove contains?) seq))
+                                (map :id))
+                parents   (into #{} xform all-parents)]
+            (if (= empty-parents parents)
+              empty-parents
+              (recursive-find-empty-parents parents))))
+
+        empty-parents
+        ;; Any empty parent whose children are moved to another frame should be deleted
+        (if (empty? moving-shapes)
+          #{}
+          (into (d/ordered-set) (find-all-empty-parents #{})))
+
+        ;; Not move absolute shapes that won't change parent
+        moving-shapes
+        (->> moving-shapes
+             (remove (fn [shape]
+                       (and (ctl/position-absolute? shape)
+                            (= frame-id (:parent-id shape))))))
+
+        frame-component
+        (ctn/get-component-shape objects frame)
+
+        shape-ids-to-detach
+        (reduce (fn [result shape]
+                  (if (and (some? shape) (ctk/in-component-copy-not-head? shape))
+                    (let [shape-component (ctn/get-component-shape objects shape)]
+                      (if (= (:id frame-component) (:id shape-component))
+                        result
+                        (into result (cfh/get-children-ids-with-self objects (:id shape)))))
+                    result))
+                #{}
+                moving-shapes)
+
+        moving-shapes-ids
+        (map :id moving-shapes)
+
+        moving-shapes-children-ids
+        (->> moving-shapes-ids
+             (mapcat #(cfh/get-children-ids-with-self objects %)))
+
+        child-heads
+        (->> moving-shapes-ids
+             (mapcat #(ctn/get-child-heads objects %))
+             (map :id))]
+    (-> changes
+        (pcb/with-page-id page-id)
+        (pcb/with-objects objects)
+
+        ;; Remove layout-item properties when moving a shape outside a layout
+        (cond-> (not (ctl/any-layout? objects frame-id))
+          (pcb/update-shapes moving-shapes-ids ctl/remove-layout-item-data))
+
+        ;; Remove the swap slots if it is moving to a different component
+        (pcb/update-shapes
+         child-heads
+         (fn [shape]
+           (cond-> shape
+             (not= component-main-frame (ctn/find-component-main objects shape false))
+             (ctk/remove-swap-slot))))
+
+        ;; Remove component-root property when moving a shape inside a component
+        (cond-> (ctn/get-instance-root objects frame)
+          (pcb/update-shapes moving-shapes-children-ids #(dissoc % :component-root)))
+
+        ;; Add component-root property when moving a component outside a component
+        (cond-> (not (ctn/get-instance-root objects frame))
+          (pcb/update-shapes child-heads #(assoc % :component-root true)))
+
+        (pcb/update-shapes moving-shapes-ids #(cond-> % (cfh/frame-shape? %) (assoc :hide-in-viewer true)))
+        (pcb/update-shapes shape-ids-to-detach ctk/detach-shape)
+        (pcb/change-parent frame-id moving-shapes drop-index)
+
+        ;; Change the grid cell in a grid layout
+        (cond-> (ctl/grid-layout? objects frame-id)
+          (-> (pcb/update-shapes
+               [frame-id]
+               (fn [frame objects]
+                 (-> frame
+                     ;; Assign the cell when pushing into a specific grid cell
+                     (cond-> (some? cell)
+                       (-> (ctl/free-cell-shapes moving-shapes-ids)
+                           (ctl/push-into-cell moving-shapes-ids row column)
+                           (ctl/assign-cells objects)))
+                     (ctl/assign-cell-positions objects)))
+               {:with-objects? true})
+              (pcb/reorder-grid-children [frame-id])))
+        (pcb/remove-objects empty-parents))))
+
+
+(defn change-show-in-viewer [shape hide?]
+  (cond-> (assoc shape :hide-in-viewer hide?)
+    ;; When a frame is no longer shown in view mode, it cannot have interactions
+    hide?
+    (dissoc :interactions)))
+
+(defn add-new-interaction [shape interaction]
+  (-> shape
+      (update :interactions ctsi/add-interaction interaction)
+      ;; When a interaction is created, the frame must be shown in view mode
+      (dissoc :hide-in-viewer)))

common/src/app/common/record.cljc

@@ -429,22 +429,80 @@
     `(update ~ssym ~ksym ~f ~@params)))
 
 (defmacro define-properties!
+  "Define properties in the prototype with `.defineProperty`"
   [rsym & properties]
   (let [rsym (with-meta rsym {:tag 'js})]
     `(do
        ~@(for [params properties
                :let [pname  (get params :name)
                      get-fn (get params :get)
-                     set-fn (get params :set)]]
-           `(.defineProperty js/Object
-                             (.-prototype ~rsym)
-                             ~pname
+                     set-fn (get params :set)
+                     enum-p (get params :enumerable)
+                     conf-p (get params :configurable)
+                     writ-p (get params :writable)]]
+           `(.defineProperty js/Object (.-prototype ~rsym) ~pname
                              (cljs.core/js-obj
-                              "enumerable" true
-                              "configurable" true
                               ~@(concat
+                                 (if (some? enum-p)
+                                   ["enumerable" enum-p]
+                                   ["enumerable" true])
+
+                                 (if (some? conf-p)
+                                   ["configurable" conf-p]
+                                   ["configurable" true])
+
+                                 (when (some? writ-p)
+                                   ["writable" writ-p])
+
                                  (when get-fn
                                    ["get" get-fn])
+
                                  (when set-fn
                                    ["set" set-fn]))))))))
 
+(defmacro add-properties!
+  "Adds properties to an object using `.defineProperty`"
+  [rsym & properties]
+  (let [rsym (with-meta rsym {:tag 'js})
+        getf-sym (with-meta (gensym "get-fn") {:tag 'js})
+        setf-sym (with-meta (gensym "set-fn") {:tag 'js})
+        this-sym (with-meta (gensym "this") {:tag 'js})
+        target-sym (with-meta (gensym "target") {:tag 'js})]
+    `(let [~target-sym ~rsym]
+       ;; Creates the `.defineProperty` per property
+       ~@(for [params properties
+               :let [pname  (get params :name)
+                     get-fn (get params :get)
+                     set-fn (get params :set)
+                     enum-p (get params :enumerable)
+                     conf-p (get params :configurable)
+                     writ-p (get params :writable)]]
+           `(let [~getf-sym ~get-fn
+                  ~setf-sym ~set-fn]
+              (.defineProperty
+               js/Object
+               ~target-sym
+               ~pname
+               (cljs.core/js-obj
+                ~@(concat
+                   (if (some? enum-p)
+                     ["enumerable" enum-p]
+                     ;; Default in JS is false. We default to true
+                     ["enumerable" true])
+
+                   (when (some? conf-p)
+                     ["configurable" conf-p])
+
+                   (when (some? writ-p)
+                     ["writable" writ-p])
+
+                   (when get-fn
+                     ["get" `(fn []
+                               (cljs.core/this-as ~this-sym
+                                                  (~getf-sym ~this-sym)))])
+                   (when set-fn
+                     ["set" `(fn [value#]
+                               (cljs.core/this-as ~this-sym
+                                                  (~setf-sym ~this-sym value#)))]))))))
+       ;; Returns the object
+       ~target-sym)))

common/src/app/common/svg.cljc

@@ -1046,7 +1046,6 @@
     (str/includes? data "<!DOCTYPE")
     (str/replace #"<\!DOCTYPE[^>]*>" "")))
 
-
 (defn parse
   [text]
   #?(:cljs (tubax/xml->clj text)

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

@@ -22,6 +22,7 @@
    [app.common.svg :as csvg]
    [app.common.svg.path :as path]
    [app.common.types.shape :as cts]
+   [app.common.uuid :as uuid]
    [cuerdas.core :as str]))
 
 (def default-rect
@@ -78,67 +79,68 @@
 (declare parse-svg-element)
 
 (defn create-svg-shapes
-  [svg-data {:keys [x y]} objects frame-id parent-id selected center?]
-  (let [[vb-x vb-y vb-width vb-height] (svg-dimensions svg-data)
+  ([svg-data pos objects frame-id parent-id selected center?]
+   (create-svg-shapes (uuid/next) svg-data pos objects frame-id parent-id selected center?))
+  ([id svg-data {:keys [x y]} objects frame-id parent-id selected center?]
+   (let [[vb-x vb-y vb-width vb-height] (svg-dimensions svg-data)
 
+         unames   (cfh/get-used-names objects)
+         svg-name (str/replace (:name svg-data) ".svg" "")
 
-        unames   (cfh/get-used-names objects)
-        svg-name (str/replace (:name svg-data) ".svg" "")
+         svg-data (-> svg-data
+                      (assoc :x (mth/round
+                                 (if center?
+                                   (- x vb-x (/ vb-width 2))
+                                   x)))
+                      (assoc :y (mth/round
+                                 (if center?
+                                   (- y vb-y (/ vb-height 2))
+                                   y)))
+                      (assoc :offset-x vb-x)
+                      (assoc :offset-y vb-y)
+                      (assoc :width vb-width)
+                      (assoc :height vb-height)
+                      (assoc :name svg-name))
 
-        svg-data (-> svg-data
-                     (assoc :x (mth/round
-                                (if center?
-                                  (- x vb-x (/ vb-width 2))
-                                  x)))
-                     (assoc :y (mth/round
-                                (if center?
-                                  (- y vb-y (/ vb-height 2))
-                                  y)))
-                     (assoc :offset-x vb-x)
-                     (assoc :offset-y vb-y)
-                     (assoc :width vb-width)
-                     (assoc :height vb-height)
-                     (assoc :name svg-name))
+         [def-nodes svg-data]
+         (-> svg-data
+             (csvg/fix-default-values)
+             (csvg/fix-percents)
+             (csvg/extract-defs))
 
-        [def-nodes svg-data]
-        (-> svg-data
-            (csvg/fix-default-values)
-            (csvg/fix-percents)
-            (csvg/extract-defs))
+         ;; In penpot groups have the size of their children. To
+         ;; respect the imported svg size and empty space let's create
+         ;; a transparent shape as background to respect the imported
+         ;; size
+         background
+         {:tag :rect
+          :attrs {:x      (dm/str vb-x)
+                  :y      (dm/str vb-y)
+                  :width  (dm/str vb-width)
+                  :height (dm/str vb-height)
+                  :fill   "none"
+                  :id     "base-background"}
+          :hidden true
+          :content []}
 
-        ;; In penpot groups have the size of their children. To
-        ;; respect the imported svg size and empty space let's create
-        ;; a transparent shape as background to respect the imported
-        ;; size
-        background
-        {:tag :rect
-         :attrs {:x      (dm/str vb-x)
-                 :y      (dm/str vb-y)
-                 :width  (dm/str vb-width)
-                 :height (dm/str vb-height)
-                 :fill   "none"
-                 :id     "base-background"}
-         :hidden true
-         :content []}
+         svg-data   (-> svg-data
+                        (assoc :defs def-nodes)
+                        (assoc :content (into [background] (:content svg-data))))
 
-        svg-data   (-> svg-data
-                       (assoc :defs def-nodes)
-                       (assoc :content (into [background] (:content svg-data))))
+         root-shape (create-svg-root id frame-id parent-id svg-data)
+         root-id    (:id root-shape)
 
-        root-shape (create-svg-root frame-id parent-id svg-data)
-        root-id    (:id root-shape)
+         ;; Create the root shape
+         root-attrs (-> (:attrs svg-data)
+                        (csvg/format-styles))
 
-        ;; Create the root shape
-        root-attrs (-> (:attrs svg-data)
-                       (csvg/format-styles))
+         [_ children]
+         (reduce (partial create-svg-children objects selected frame-id root-id svg-data)
+                 [unames []]
+                 (d/enumerate (->> (:content svg-data)
+                                   (mapv #(csvg/inherit-attributes root-attrs %)))))]
 
-        [_ children]
-        (reduce (partial create-svg-children objects selected frame-id root-id svg-data)
-                [unames []]
-                (d/enumerate (->> (:content svg-data)
-                                  (mapv #(csvg/inherit-attributes root-attrs %)))))]
-
-    [root-shape children]))
+     [root-shape children])))
 
 (defn create-raw-svg
   [name frame-id {:keys [x y width height offset-x offset-y]} {:keys [attrs] :as data}]
@@ -157,12 +159,13 @@
       :svg-viewbox vbox})))
 
 (defn create-svg-root
-  [frame-id parent-id {:keys [name x y width height offset-x offset-y attrs]}]
+  [id frame-id parent-id {:keys [name x y width height offset-x offset-y attrs]}]
   (let [props (-> (dissoc attrs :viewBox :view-box :xmlns)
                   (d/without-keys csvg/inheritable-props)
                   (csvg/attrs->props))]
     (cts/setup-shape
-     {:type :group
+     {:id id
+      :type :group
       :name name
       :frame-id frame-id
       :parent-id parent-id