johanels/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-12-12 06:24:17 +01:00
Code Issues Actions 9 Packages Projects Releases Wiki Activity

Merge tag '2.11.0-RC3'
Some checks failed
Commit Message Check / Check Commit Message (push) Has been cancelled
Details

Browse Source
This commit is contained in:
Andrey Antukh
2025-11-04 16:43:32 +01:00
parent 245190f4f9 37aa59b164
commit 4a01121043
745 changed files with 78479 additions and 39907 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
.circleci/config.yml
View File

@@ -326,24 +326,16 @@ jobs:
workflows:
penpot:
jobs:
- lint
- test-frontend:
requires:
- lint: success
- test-library:
requires:
- test-frontend: success
- lint: success
- test-components:
requires:
- test-frontend: success
- lint: success
- test-integration:
requires:
- test-frontend: success
- lint: success
- test-backend:
@@ -354,4 +346,6 @@ workflows:
requires:
- lint: success
- lint
- test-integration
- test-render-wasm

27
.github/workflows/build-docker.yml vendored
View File

@@ -46,6 +46,7 @@ jobs:
mv penpot/backend bundle-backend
mv penpot/frontend bundle-frontend
mv penpot/exporter bundle-exporter
mv penpot/storybook bundle-storybook
popd
- name: Set up Docker Buildx
@@ -99,3 +100,29 @@ jobs:
tags: ${{ secrets.DOCKER_REGISTRY }}/${{ env.DOCKER_IMAGE }}:${{ steps.vars.outputs.gh_ref }}
cache-from: type=registry,ref=${{ secrets.DOCKER_REGISTRY }}/${{ env.DOCKER_IMAGE }}:buildcache
cache-to: type=registry,ref=${{ secrets.DOCKER_REGISTRY }}/${{ env.DOCKER_IMAGE }}:buildcache,mode=max
- name: Build and push Storybook Docker image
uses: docker/build-push-action@v6
env:
DOCKER_IMAGE: 'storybook'
BUNDLE_PATH: './bundle-storybook'
with:
context: ./docker/images/
file: ./docker/images/Dockerfile.storybook
platforms: linux/amd64,linux/arm64
push: true
tags: ${{ secrets.DOCKER_REGISTRY }}/${{ env.DOCKER_IMAGE }}:${{ steps.vars.outputs.gh_ref }}
cache-from: type=registry,ref=${{ secrets.DOCKER_REGISTRY }}/${{ env.DOCKER_IMAGE }}:buildcache
cache-to: type=registry,ref=${{ secrets.DOCKER_REGISTRY }}/${{ env.DOCKER_IMAGE }}:buildcache,mode=max
- name: Notify Mattermost
if: failure()
uses: mattermost/action-mattermost-notify@master
with:
MATTERMOST_WEBHOOK_URL: ${{ secrets.MATTERMOST_WEBHOOK }}
MATTERMOST_CHANNEL: bot-alerts-cicd
TEXT: |
❌ 🐳 *[PENPOT] Error building penpot docker images.*
📄 Triggered from ref: `${{ steps.vars.outputs.gh_ref }}`
🔗 Run: https://github.com/${{ github.repository }}/actions/runs/${{ github.run_id }}
@infra

2
.github/workflows/commit-checker.yml vendored
View File

@@ -26,7 +26,7 @@ jobs:
- name: Check Commit Type
uses: gsactions/commit-message-checker@v2
with:
pattern: '^(Merge|Revert|:(lipstick|globe_with_meridians|wrench|books|arrow_up|arrow_down|zap|ambulance|construction|boom|fire|whale|bug|sparkles|paperclip|tada|recycle|rewind):)\s["A-Z].*[^.]$'
pattern: '^(Merge|Revert|:(lipstick|globe_with_meridians|wrench|books|arrow_up|arrow_down|zap|ambulance|construction|boom|fire|whale|bug|sparkles|paperclip|tada|recycle|rewind|construction_worker):)\s["A-Z].*[^.]$'
flags: 'gm'
error: 'Commit should match CONTRIBUTING.md guideline'
checkAllCommitMessages: 'true' # optional: this checks all commits associated with a pull request

84
CHANGES.md
View File

@@ -1,17 +1,91 @@
# CHANGELOG
## 2.11.0 (Unreleased)
### :boom: Breaking changes & Deprecations
- Deprecated configuration variables with the prefix `PENPOT_ASSETS_*`, and will be
removed in future versions:
- The `PENPOT_ASSETS_STORAGE_BACKEND` becomes `PENPOT_OBJECTS_STORAGE_BACKEND` and its
values passes from (`assets-fs` or `assets-s3`) to (`fs` or `s3`)
- The `PENPOT_STORAGE_ASSETS_FS_DIRECTORY` becomes `PENPOT_OBJECTS_STORAGE_FS_DIRECTORY`
- The `PENPOT_STORAGE_ASSETS_S3_BUCKET` becomes `PENPOT_OBJECTS_STORAGE_S3_BUCKET`
- The `PENPOT_STORAGE_ASSETS_S3_REGION` becomes `PENPOT_OBJECTS_STORAGE_S3_REGION`
- The `PENPOT_STORAGE_ASSETS_S3_ENDPOINT` becomes `PENPOT_OBJECTS_STORAGE_S3_ENDPOINT`
- The `PENPOT_STORAGE_ASSETS_S3_IO_THREADS` replaced (see below)
- Add `PENPOT_NETTY_IO_THREADS` and `PENPOT_EXECUTOR_THREADS` variables to provide the
control over concurrency of the shared resources used by netty. Penpot uses the netty IO
threads for AWS S3 SDK and Redis/Valkey communication, and the EXEC threads to perform
out of HTTP serving threads tasks such that cache invalidation, S3 response completion,
configuration reloading and many other auxiliar tasks. By default they use a half number
if available cpus with a minumum of 2 for both executors. You should not touch that
variables unless you are know what you are doing.
- Replace the `PENPOT_STORAGE_ASSETS_S3_IO_THREADS` with a more general configuration
`PENPOT_NETTY_IO_THREADS` used to configure a shared netty resources across different
services which use netty internally (redis connection, S3 SDK client). This
configuration is not very commonly used so don't expected real impact on any user.
### :rocket: Epics and highlights
### :heart: Community contributions (Thank you!)
### :sparkles: New features & Enhancements
- New composite token: Typography [Taiga #10200](https://tree.taiga.io/project/penpot/us/10200)
- Show current Penpot version [Taiga #11603](https://tree.taiga.io/project/penpot/us/11603)
- Switch several variant copies at the same time [Taiga #11411](https://tree.taiga.io/project/penpot/us/11411)
- Invitations management improvements [Taiga #3479](https://tree.taiga.io/project/penpot/us/3479)
- Alternative ways of creating variants - Button Viewport [Taiga #11931](https://tree.taiga.io/project/penpot/us/11931)
- Reorder properties for a component [Taiga #10225](https://tree.taiga.io/project/penpot/us/10225)
- File Data storage layout refactor [Github #7345](https://github.com/penpot/penpot/pull/7345)
- Make several queries optimization on comment threads [Github #7506](https://github.com/penpot/penpot/pull/7506)
### :bug: Bugs fixed
- Fix selection problems when devtools open [Taiga #11950](https://tree.taiga.io/project/penpot/issue/11950)
- Fix long font names overlap [Taiga #11844](https://tree.taiga.io/project/penpot/issue/11844)
- Fix paste behavior according to the selected element [Taiga #11979](https://tree.taiga.io/project/penpot/issue/11979)
- Fix problem with export size [Github #7160](https://github.com/penpot/penpot/issues/7160)
- Fix multi level library dependencies [Taiga #12155](https://tree.taiga.io/project/penpot/issue/12155)
- Fix component context menu options order in assets tab [Taiga #11941](https://tree.taiga.io/project/penpot/issue/11941)
- Fix error updating library [Taiga #12218](https://tree.taiga.io/project/penpot/issue/12218)
- Fix restoring a variant in another file makes it overlap the existing variant [Taiga #12049](https://tree.taiga.io/project/penpot/issue/12049)
- Fix auto-width changes to fixed when switching variants [Taiga #12172](https://tree.taiga.io/project/penpot/issue/12172)
- Fix component number has no singular translation string [Taiga #12106](https://tree.taiga.io/project/penpot/issue/12106)
- Fix adding/removing identical text fills [Taiga #12287](https://tree.taiga.io/project/penpot/issue/12287)
- Fix scroll on the inspect tab [Taiga #12293](https://tree.taiga.io/project/penpot/issue/12293)
- Fix lock proportion tooltip [Taiga #12326](https://tree.taiga.io/project/penpot/issue/12326)
- Fix internal Error when selecting a set by name in the token theme editor [Taiga #12310](https://tree.taiga.io/project/penpot/issue/12310)
- Fix drag & drop functionality is swapping instead or reordering [Taiga #12254](https://tree.taiga.io/project/penpot/issue/12254)
- Fix variants not syncronizing tokens on switch [Taiga #12290](https://tree.taiga.io/project/penpot/issue/12290)
- Fix incorrect behavior of Alt + Drag for variants [Taiga #12309](https://tree.taiga.io/project/penpot/issue/12309)
- Fix text override is lost after switch [Taiga #12269](https://tree.taiga.io/project/penpot/issue/12269)
- Fix exporting a board crashing the app [Taiga #12384](https://tree.taiga.io/project/penpot/issue/12384)
- Fix nested variant in a component doesn't keep inherited overrides [Taiga #12299](https://tree.taiga.io/project/penpot/issue/12299)
- Fix selected colors not showing colors from children shapes in multiple selection [Taiga #12384](https://tree.taiga.io/project/penpot/issue/12385)
- Fix scrollbar issue in design tab [Taiga #12367](https://tree.taiga.io/project/penpot/issue/12367)
- Fix library update notificacions showing when they should not [Taiga #12397](https://tree.taiga.io/project/penpot/issue/12397)
- Fix remove flex button doesn’t work within variant [Taiga #12314](https://tree.taiga.io/project/penpot/issue/12314)
- Fix an error translation [Taiga #12402](https://tree.taiga.io/project/penpot/issue/12402)
- Fix problem with certain text input in some editable labels (pages, components, tokens...) being in conflict with the drag/drop functionality [Taiga #12316](https://tree.taiga.io/project/penpot/issue/12316)
- Fix not controlled theme renaming [Taiga #12411](https://tree.taiga.io/project/penpot/issue/12411)
- Fix paste without selection sends the new element in the back [Taiga #12382](https://tree.taiga.io/project/penpot/issue/12382)
- Fix options button does not work for comments created in the lower part of the screen [Taiga #12422](https://tree.taiga.io/project/penpot/issue/12422)
- Fix problem when checking usage with removed teams [Taiga #12442](https://tree.taiga.io/project/penpot/issue/12442)
## 2.10.1
### :sparkles: New features & Enhancements
- Improve workpace file loading [Github 7366](https://github.com/penpot/penpot/pull/7366)
### :bug: Bugs fixed
- Fix regression with text shapes creation with Plugins API [Taiga #12244](https://tree.taiga.io/project/penpot/issue/12244)
## 2.10.0
### :rocket: Epics and highlights
@@ -47,6 +121,7 @@
- Retrieve variants with nested components [Taiga #10277](https://tree.taiga.io/project/penpot/us/10277)
- Create variants in bulk from existing components [Taiga #7926](https://tree.taiga.io/project/penpot/us/7926)
- Alternative ways of creating variants - Button Design Tab [Taiga #10316](https://tree.taiga.io/project/penpot/us/10316)
- Fix problem with component swapping panel [Taiga #12175](https://tree.taiga.io/project/penpot/issue/12175)
### :bug: Bugs fixed
@@ -60,7 +135,7 @@
- Fix issue where Alt + arrow keys shortcut interferes with letter-spacing when moving text layers [Taiga #11552](https://tree.taiga.io/project/penpot/issue/11771)
- Fix consistency issues on how font variants are visualized [Taiga #11499](https://tree.taiga.io/project/penpot/us/11499)
- Fix parsing rx and ry SVG values for rect radius [Taiga #11861](https://tree.taiga.io/project/penpot/issue/11861)
- Misleading affordance in saved versions [Taiga #11887](https://tree.taiga.io/project/penpot/issue/11887)
- Fix misleading affordance in saved versions [Taiga #11887](https://tree.taiga.io/project/penpot/issue/11887)
- Fix pasting RTF text crashes penpot [Taiga #11717](https://tree.taiga.io/project/penpot/issue/11717)
- Fix navigation arrows in Libraries & Templates carousel [Taiga #10609](https://tree.taiga.io/project/penpot/issue/10609)
- Fix applying tokens with zero value to size [Taiga #11618](https://tree.taiga.io/project/penpot/issue/11618)
@@ -107,7 +182,6 @@
- Add info to apply-token event [Taiga #11710](https://tree.taiga.io/project/penpot/task/11710)
- Fix double click on set name input [Taiga #11747](https://tree.taiga.io/project/penpot/issue/11747)
### :bug: Bugs fixed
- Copying font size does not copy the unit [Taiga #11143](https://tree.taiga.io/project/penpot/issue/11143)
@@ -155,7 +229,7 @@
**Penpot Library**
The initial prototype is completly reworked for provide a more consistent API
The initial prototype is completly reworked to provide a more consistent API
and to have proper validation and params decoding. All the details can be found
on [its own changelog](library/CHANGES.md)

9
README.md
View File

@@ -77,17 +77,14 @@ Provide your team or organization with a completely owned collaborative design t
### 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.
### Design Tokens ###
With Penpot’s standardized [design tokens](https://penpot.dev/collaboration/design-tokens) format, you can easily reuse and sync tokens across different platforms, workflows, and disciplines.
### Building Design Systems: design tokens, components and variants ###
Penpot brings design systems to code-minded teams: a single source of truth with native Design Tokens, Components, and Variants for scalable, reusable, and consistent UI across projects and platforms.
<br />
<p align="center">
<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%;">
<img src="https://github.com/user-attachments/assets/cce75ad6-f783-473f-8803-da9eb8255fef">
</p>
<br />

33
backend/deps.edn
View File

@@ -6,7 +6,7 @@
org.clojure/clojure {:mvn/version "1.12.2"}
org.clojure/tools.namespace {:mvn/version "1.5.0"}
com.github.luben/zstd-jni {:mvn/version "1.5.7-3"}
com.github.luben/zstd-jni {:mvn/version "1.5.7-4"}
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.7.0.RELEASE"}
io.lettuce/lettuce-core {:mvn/version "6.8.1.RELEASE"}
;; Minimal dependencies required by lettuce, we need to include them
;; explicitly because clojure dependency management does not support
;; yet the BOM format.
@@ -28,29 +28,30 @@
com.google.guava/guava {:mvn/version "33.4.8-jre"}
funcool/yetti
{:git/tag "v11.4"
:git/sha "ce50d42"
{:git/tag "v11.6"
:git/sha "94dc017"
:git/url "https://github.com/funcool/yetti.git"
:exclusions [org.slf4j/slf4j-api]}
com.github.seancorfield/next.jdbc
{:mvn/version "1.3.1002"}
{:mvn/version "1.3.1070"}
metosin/reitit-core {:mvn/version "0.9.1"}
nrepl/nrepl {:mvn/version "1.3.1"}
nrepl/nrepl {:mvn/version "1.4.0"}
org.postgresql/postgresql {:mvn/version "42.7.7"}
org.xerial/sqlite-jdbc {:mvn/version "3.49.1.0"}
org.xerial/sqlite-jdbc {:mvn/version "3.50.3.0"}
com.zaxxer/HikariCP {:mvn/version "6.3.0"}
com.zaxxer/HikariCP {:mvn/version "7.0.2"}
io.whitfin/siphash {:mvn/version "2.0.0"}
buddy/buddy-hashers {:mvn/version "2.0.167"}
buddy/buddy-sign {:mvn/version "3.6.1-359"}
com.github.ben-manes.caffeine/caffeine {:mvn/version "3.2.0"}
com.github.ben-manes.caffeine/caffeine {:mvn/version "3.2.2"}
org.jsoup/jsoup {:mvn/version "1.20.1"}
org.jsoup/jsoup {:mvn/version "1.21.2"}
org.im4java/im4java
{:git/tag "1.4.0-penpot-2"
:git/sha "e2b3e16"
@@ -60,12 +61,12 @@
org.clojars.pntblnk/clj-ldap {:mvn/version "0.0.17"}
dawran6/emoji {:mvn/version "0.1.5"}
markdown-clj/markdown-clj {:mvn/version "1.12.3"}
dawran6/emoji {:mvn/version "0.2.0"}
markdown-clj/markdown-clj {:mvn/version "1.12.4"}
;; Pretty Print specs
pretty-spec/pretty-spec {:mvn/version "0.1.4"}
software.amazon.awssdk/s3 {:mvn/version "2.33.8"}}
software.amazon.awssdk/s3 {:mvn/version "2.33.10"}}
:paths ["src" "resources" "target/classes"]
:aliases
@@ -80,12 +81,14 @@
:build
{:extra-deps
{io.github.clojure/tools.build {:git/tag "v0.10.9" :git/sha "e405aac"}}
{io.github.clojure/tools.build {:mvn/version "0.10.10"}}
:ns-default build}
:test
{:main-opts ["-m" "kaocha.runner"]
:jvm-opts ["-Dlog4j2.configurationFile=log4j2-devenv-repl.xml"]
:jvm-opts ["-Dlog4j2.configurationFile=log4j2-devenv-repl.xml"
"--sun-misc-unsafe-memory-access=allow"
"--enable-native-access=ALL-UNNAMED"]
:extra-deps {lambdaisland/kaocha {:mvn/version "1.91.1392"}}}
:outdated

4
backend/dev/user.clj
View File

@@ -30,8 +30,8 @@
[app.config :as cf]
[app.db :as db]
[app.main :as main]
[app.srepl.helpers :as srepl.helpers]
[app.srepl.main :as srepl]
[app.srepl.helpers :as h]
[app.srepl.main :refer :all]
[app.util.blob :as blob]
[clj-async-profiler.core :as prof]
[clojure.contrib.humanize :as hum]

2
backend/resources/app/email/invite-to-team/en.subj
View File

@@ -1 +1 @@
Invitation to join {{team}}
{{invited-by|abbreviate:25}} has invited you to join the team “{{ team|abbreviate:25 }}”

8
backend/resources/app/onboarding.edn
View File

@@ -1,6 +1,9 @@
[{:id "tokens-starter-kit"
:name "Design tokens starter kit"
:file-uri "https://github.com/penpot/penpot-files/raw/refs/heads/main/Tokens%20starter%20kit.penpot"},
:file-uri "https://github.com/penpot/penpot-files/raw/refs/heads/main/Tokens%20starter%20kit.penpot"}
{:id "penpot-design-system"
:name "Penpot Design System | Pencil"
:file-uri "https://github.com/penpot/penpot-files/raw/refs/heads/main/penpot-app.penpot"}
{:id "wireframing-kit"
:name "Wireframe library"
:file-uri "https://github.com/penpot/penpot-files/raw/refs/heads/main/Wireframing%20kit%20v1.1.penpot"}
@@ -10,9 +13,6 @@
{:id "plants-app"
:name "UI mockup example"
:file-uri "https://github.com/penpot/penpot-files/raw/main/Plants-app.penpot"}
{:id "penpot-design-system"
:name "Design system example"
:file-uri "https://github.com/penpot/penpot-files/raw/refs/heads/main/Penpot%20-%20Design%20System%20v2.1.penpot"}
{:id "tutorial-for-beginners"
:name "Tutorial for beginners"
:file-uri "https://github.com/penpot/penpot-files/raw/main/tutorial-for-beginners.penpot"}

34
backend/resources/app/templates/debug.tmpl
View File

@@ -45,7 +45,41 @@ Debug Main Page
</form>
</fieldset>
<fieldset>
<legend>VIRTUAL CLOCK</legend>
<desc>
<p>
CURRENT CLOCK: <b>{{current-clock}}</b>
<br />
CURRENT OFFSET: <b>{{current-offset}}</b>
<br />
CURRENT TIME: <b>{{current-time}}</b>
</p>
<p>Examples: 3h, -7h, 24h (allowed suffixes: h, s)</p>
</desc>
<form method="post" action="/dbg/actions/set-virtual-clock">
<div class="row">
<input type="text" name="offset" placeholder="3h" value="" />
</div>
<div class="row">
<label for="force-verify">Are you sure?</label>
<input id="force-verify" type="checkbox" name="force" />
<br />
<small>
This is a just a security double check for prevent non intentional submits.
</small>
</div>
<div class="row">
<input type="submit" name="submit" value="Submit" />
<input type="submit" name="reset" value="Reset" />
</div>
</form>
</fieldset>
</section>

81
backend/scripts/_env Normal file
View File

@@ -0,0 +1,81 @@
#!/usr/bin/env bash
export PENPOT_MANAGEMENT_API_SHARED_KEY=super-secret-management-api-key
export PENPOT_SECRET_KEY=super-secret-devenv-key
export PENPOT_HOST=devenv
export PENPOT_FLAGS="\
$PENPOT_FLAGS \
enable-login-with-ldap \
enable-login-with-password
enable-login-with-oidc \
enable-login-with-google \
enable-login-with-github \
enable-login-with-gitlab \
enable-backend-worker \
enable-backend-asserts \
disable-feature-fdata-pointer-map \
enable-feature-fdata-objects-map \
enable-audit-log \
enable-transit-readable-response \
enable-demo-users \
disable-secure-session-cookies \
enable-smtp \
enable-prepl-server \
enable-urepl-server \
enable-rpc-climit \
enable-rpc-rlimit \
enable-quotes \
enable-soft-rpc-rlimit \
enable-auto-file-snapshot \
enable-webhooks \
enable-access-tokens \
disable-tiered-file-data-storage \
enable-file-validation \
enable-file-schema-validation \
enable-redis-cache \
enable-subscriptions";
# Default deletion delay for devenv
export PENPOT_DELETION_DELAY="24h"
# Setup default upload media file size to 100MiB
export PENPOT_MEDIA_MAX_FILE_SIZE=104857600
# Setup default multipart upload size to 300MiB
export PENPOT_HTTP_SERVER_MAX_MULTIPART_BODY_SIZE=314572800
export AWS_ACCESS_KEY_ID=penpot-devenv
export AWS_SECRET_ACCESS_KEY=penpot-devenv
export PENPOT_OBJECTS_STORAGE_BACKEND=s3
export PENPOT_OBJECTS_STORAGE_S3_ENDPOINT=http://minio:9000
export PENPOT_OBJECTS_STORAGE_S3_BUCKET=penpot
export JAVA_OPTS="\
-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager \
-Djdk.attach.allowAttachSelf \
-Dlog4j2.configurationFile=log4j2-devenv.xml \
-Djdk.tracePinnedThreads=full \
-Dim4java.useV7=true \
-XX:+UnlockExperimentalVMOptions \
-XX:+UseShenandoahGC \
-XX:+UseCompactObjectHeaders \
-XX:ShenandoahGCMode=generational \
-XX:-OmitStackTraceInFastThrow \
--sun-misc-unsafe-memory-access=allow \
--enable-preview \
--enable-native-access=ALL-UNNAMED";
function setup_minio() {
# Initialize MINIO config
mc alias set penpot-s3/ http://minio:9000 minioadmin minioadmin -q
mc admin user add penpot-s3 penpot-devenv penpot-devenv -q
mc admin user info penpot-s3 penpot-devenv |grep -F -q "readwrite"
if [ "$?" = "1" ]; then
mc admin policy attach penpot-s3 readwrite --user=penpot-devenv -q
fi
mc mb penpot-s3/penpot -p -q
}

107
backend/scripts/repl
View File

@@ -1,112 +1,13 @@
#!/usr/bin/env bash
export PENPOT_SECRET_KEY=super-secret-devenv-key
export PENPOT_HOST=devenv
export PENPOT_FLAGS="\
$PENPOT_FLAGS \
enable-login-with-ldap \
enable-login-with-password
enable-login-with-oidc \
enable-login-with-google \
enable-login-with-github \
enable-login-with-gitlab \
enable-backend-worker \
enable-backend-asserts \
disable-feature-fdata-pointer-map \
enable-feature-fdata-objects-map \
enable-audit-log \
enable-transit-readable-response \
enable-demo-users \
disable-secure-session-cookies \
enable-smtp \
enable-prepl-server \
enable-urepl-server \
enable-rpc-climit \
enable-rpc-rlimit \
enable-quotes \
enable-soft-rpc-rlimit \
enable-auto-file-snapshot \
enable-webhooks \
enable-access-tokens \
disable-tiered-file-data-storage \
enable-file-validation \
enable-file-schema-validation \
enable-subscriptions \
disable-subscriptions-old";
# Default deletion delay for devenv
export PENPOT_DELETION_DELAY="24h"
# Setup default upload media file size to 100MiB
export PENPOT_MEDIA_MAX_FILE_SIZE=104857600
# Setup default multipart upload size to 300MiB
export PENPOT_HTTP_SERVER_MAX_MULTIPART_BODY_SIZE=314572800
# export PENPOT_DATABASE_URI="postgresql://172.17.0.1:5432/penpot"
# export PENPOT_DATABASE_USERNAME="penpot"
# export PENPOT_DATABASE_PASSWORD="penpot"
# export PENPOT_DATABASE_READONLY=true
# export PENPOT_DATABASE_URI="postgresql://172.17.0.1:5432/penpot_pre"
# export PENPOT_DATABASE_USERNAME="penpot_pre"
# export PENPOT_DATABASE_PASSWORD="penpot_pre"
# export PENPOT_LOGGERS_LOKI_URI="http://172.17.0.1:3100/loki/api/v1/push"
# export PENPOT_AUDIT_LOG_ARCHIVE_URI="http://localhost:6070/api/audit"
SCRIPT_DIR=$(dirname $0);
source $SCRIPT_DIR/_env;
# Initialize MINIO config
mc alias set penpot-s3/ http://minio:9000 minioadmin minioadmin -q
mc admin user add penpot-s3 penpot-devenv penpot-devenv -q
mc admin user info penpot-s3 penpot-devenv |grep -F -q "readwrite"
if [ "$?" = "1" ]; then
mc admin policy attach penpot-s3 readwrite --user=penpot-devenv -q
fi
mc mb penpot-s3/penpot -p -q
export AWS_ACCESS_KEY_ID=penpot-devenv
export AWS_SECRET_ACCESS_KEY=penpot-devenv
export PENPOT_OBJECTS_STORAGE_BACKEND=s3
export PENPOT_OBJECTS_STORAGE_S3_ENDPOINT=http://minio:9000
export PENPOT_OBJECTS_STORAGE_S3_BUCKET=penpot
export PENPOT_OBJECTS_STORAGE_FS_DIRECTORY="assets"
export JAVA_OPTS="\
-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager \
-Djdk.attach.allowAttachSelf \
-Dlog4j2.configurationFile=log4j2-devenv-repl.xml \
-Djdk.tracePinnedThreads=full \
-Dim4java.useV7=true \
-XX:+EnableDynamicAgentLoading \
-XX:-OmitStackTraceInFastThrow \
-XX:+UnlockDiagnosticVMOptions \
-XX:+DebugNonSafepoints \
--sun-misc-unsafe-memory-access=allow \
--enable-preview \
--enable-native-access=ALL-UNNAMED";
setup_minio;
export JAVA_OPTS="$JAVA_OPTS -Dlog4j2.configurationFile=log4j2-devenv-repl.xml"
export OPTIONS="-A:jmx-remote -A:dev"
# Setup HEAP
# export OPTIONS="$OPTIONS -J-Xms50m -J-Xmx1024m"
# export OPTIONS="$OPTIONS -J-Xms1100m -J-Xmx1100m -J-XX:+AlwaysPreTouch"
# Increase virtual thread pool size
# export OPTIONS="$OPTIONS -J-Djdk.virtualThreadScheduler.parallelism=16"
# Disable C2 Compiler
# export OPTIONS="$OPTIONS -J-XX:TieredStopAtLevel=1"
# Disable all compilers
# export OPTIONS="$OPTIONS -J-Xint"
# Setup GC
# export OPTIONS="$OPTIONS -J-XX:+UseG1GC"
# Setup GC
# export OPTIONS="$OPTIONS -J-XX:+UseZGC"
export OPTIONS_EVAL="nil"
# export OPTIONS_EVAL="(set! *warn-on-reflection* true)"

48
backend/scripts/repl-test
View File

@@ -1,48 +0,0 @@
#!/usr/bin/env bash
source /home/penpot/environ
export PENPOT_FLAGS="$PENPOT_FLAGS disable-backend-worker"
export OPTIONS="
-A:jmx-remote -A:dev \
-J-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager \
-J-Djdk.attach.allowAttachSelf \
-J-Dlog4j2.configurationFile=log4j2-experiments.xml \
-J-XX:-OmitStackTraceInFastThrow \
-J-XX:+UnlockDiagnosticVMOptions \
-J-XX:+DebugNonSafepoints \
-J-Djdk.tracePinnedThreads=full \
-J-XX:+UseTransparentHugePages \
-J-XX:ReservedCodeCacheSize=1g \
-J-Dpolyglot.engine.WarnInterpreterOnly=false \
-J--enable-preview";
# Setup HEAP
export OPTIONS="$OPTIONS -J-Xms320g -J-Xmx320g -J-XX:+AlwaysPreTouch"
export PENPOT_HTTP_SERVER_IO_THREADS=2
export PENPOT_HTTP_SERVER_WORKER_THREADS=2
# Increase virtual thread pool size
# export OPTIONS="$OPTIONS -J-Djdk.virtualThreadScheduler.parallelism=16"
# Disable C2 Compiler
# export OPTIONS="$OPTIONS -J-XX:TieredStopAtLevel=1"
# Disable all compilers
# export OPTIONS="$OPTIONS -J-Xint"
# Setup GC
export OPTIONS="$OPTIONS -J-XX:+UseG1GC -J-Xlog:gc:logs/gc.log"
# Setup GC
#export OPTIONS="$OPTIONS -J-XX:+UseZGC -J-XX:+ZGenerational -J-Xlog:gc:logs/gc.log"
# Enable ImageMagick v7.x support
# export OPTIONS="-J-Dim4java.useV7=true $OPTIONS";
export OPTIONS_EVAL="nil"
# export OPTIONS_EVAL="(set! *warn-on-reflection* true)"
set -ex
exec clojure $OPTIONS -M -e "$OPTIONS_EVAL" -m rebel-readline.main

41
backend/scripts/run
View File

@@ -1,44 +1,13 @@
#!/usr/bin/env bash
export PENPOT_SECRET_KEY=super-secret-devenv-key
export PENPOT_HOST=devenv
export PENPOT_FLAGS="\
$PENPOT_FLAGS \
enable-backend-asserts \
enable-feature-fdata-pointer-map \
enable-feature-fdata-objects-map \
enable-file-snapshot \
enable-tiered-file-data-storage";
SCRIPT_DIR=$(dirname $0);
export JAVA_OPTS="
-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager \
-Djdk.attach.allowAttachSelf \
-Dlog4j2.configurationFile=log4j2-devenv.xml \
-XX:+EnableDynamicAgentLoading \
-XX:-OmitStackTraceInFastThrow \
-XX:+UnlockDiagnosticVMOptions \
-XX:+DebugNonSafepoints";
export CLOJURE_OPTIONS="-A:dev"
# Default deletion delay for devenv
export PENPOT_DELETION_DELAY="24h"
# Setup default upload media file size to 100MiB
export PENPOT_MEDIA_MAX_FILE_SIZE=104857600
# Setup default multipart upload size to 300MiB
export PENPOT_HTTP_SERVER_MAX_MULTIPART_BODY_SIZE=314572800
export AWS_ACCESS_KEY_ID=penpot-devenv
export AWS_SECRET_ACCESS_KEY=penpot-devenv
export PENPOT_OBJECTS_STORAGE_BACKEND=s3
export PENPOT_OBJECTS_STORAGE_S3_ENDPOINT=http://minio:9000
export PENPOT_OBJECTS_STORAGE_S3_BUCKET=penpot
source $SCRIPT_DIR/_env;
export OPTIONS="-A:dev"
entrypoint=${1:-app.main};
shift 1;
set -ex
clojure $CLOJURE_OPTIONS -A:dev -M -m $entrypoint "$@";
exec clojure $OPTIONS -A:dev -M -m $entrypoint "$@";

69
backend/scripts/start-dev
View File

@@ -1,70 +1,11 @@
#!/usr/bin/env bash
export PENPOT_SECRET_KEY=super-secret-devenv-key
export PENPOT_HOST=devenv
export PENPOT_FLAGS="\
$PENPOT_FLAGS \
enable-prepl-server \
enable-urepl-server \
enable-nrepl-server \
enable-webhooks \
enable-backend-asserts \
enable-audit-log \
enable-login-with-ldap \
enable-transit-readable-response \
enable-demo-users \
disable-feature-fdata-pointer-map \
enable-feature-fdata-objects-map \
disable-secure-session-cookies \
enable-rpc-climit \
enable-smtp \
enable-quotes \
enable-file-snapshot \
enable-access-tokens \
disable-tiered-file-data-storage \
enable-file-validation \
enable-file-schema-validation \
enable-subscriptions \
disable-subscriptions-old";
# Default deletion delay for devenv
export PENPOT_DELETION_DELAY="24h"
# Setup default upload media file size to 100MiB
export PENPOT_MEDIA_MAX_FILE_SIZE=104857600
# Setup default multipart upload size to 300MiB
export PENPOT_HTTP_SERVER_MAX_MULTIPART_BODY_SIZE=314572800
SCRIPT_DIR=$(dirname $0);
source $SCRIPT_DIR/_env;
# Initialize MINIO config
mc alias set penpot-s3/ http://minio:9000 minioadmin minioadmin -q
mc admin user add penpot-s3 penpot-devenv penpot-devenv -q
mc admin user info penpot-s3 penpot-devenv |grep -F -q "readwrite"
if [ "$?" = "1" ]; then
mc admin policy attach penpot-s3 readwrite --user=penpot-devenv -q
fi
mc mb penpot-s3/penpot -p -q
export AWS_ACCESS_KEY_ID=penpot-devenv
export AWS_SECRET_ACCESS_KEY=penpot-devenv
export PENPOT_OBJECTS_STORAGE_BACKEND=s3
export PENPOT_OBJECTS_STORAGE_S3_ENDPOINT=http://minio:9000
export PENPOT_OBJECTS_STORAGE_S3_BUCKET=penpot
entrypoint=${1:-app.main};
export JAVA_OPTS="\
-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager \
-Djdk.attach.allowAttachSelf \
-Dlog4j2.configurationFile=log4j2-devenv.xml \
-Djdk.tracePinnedThreads=full \
-Dim4java.useV7=true \
-XX:-OmitStackTraceInFastThrow \
--sun-misc-unsafe-memory-access=allow \
--enable-preview \
--enable-native-access=ALL-UNNAMED";
export OPTIONS="-A:jmx-remote -A:dev"
setup_minio;
shift 1;
set -ex
clojure $OPTIONS -M -m $entrypoint;
exec clojure -A:jmx-remote -A:dev -M -m app.main "$@";

11
backend/src/app/auth/oidc.clj
View File

@@ -434,10 +434,10 @@
(sm/validator schema:info))
(defn- get-info
[{:keys [::provider ::setup/props] :as cfg} {:keys [params] :as request}]
[{:keys [::provider] :as cfg} {:keys [params] :as request}]
(let [state (get params :state)
code (get params :code)
state (tokens/verify props {:token state :iss :oauth})
state (tokens/verify cfg {:token state :iss :oauth})
tdata (fetch-access-token cfg code)
info (case (cf/get :oidc-user-info-source)
:token (get-user-info cfg tdata)
@@ -516,7 +516,7 @@
:iss :prepared-register
:exp (ct/in-future {:hours 48}))
params {:token (tokens/generate (::setup/props cfg) info)
params {:token (tokens/generate cfg info)
:provider (:provider (:path-params request))
:fullname (:fullname info)}
params (d/without-nils params)]
@@ -569,7 +569,7 @@
:else
(let [sxf (session/create-fn cfg (:id profile))
token (or (:invitation-token info)
(tokens/generate (::setup/props cfg)
(tokens/generate cfg
{:iss :auth
:exp (ct/in-future "15m")
:profile-id (:id profile)}))
@@ -620,8 +620,7 @@
:external-session-id esid
:props props
:exp (ct/in-future "4h")}
state (tokens/generate (::setup/props cfg)
(d/without-nils params))
state (tokens/generate cfg (d/without-nils params))
uri (build-auth-uri cfg state)]
{::yres/status 200
::yres/body {:redirect-uri uri}}))

244
backend/src/app/binfile/common.clj
View File

@@ -34,8 +34,7 @@
[clojure.set :as set]
[cuerdas.core :as str]
[datoteka.fs :as fs]
[datoteka.io :as io]
[promesa.exec :as px]))
[datoteka.io :as io]))
(set! *warn-on-reflection* true)
@@ -142,13 +141,11 @@
([index coll attr]
(reduce #(index-object %1 %2 attr) index coll)))
(defn decode-row
[{:keys [data changes features] :as row}]
(defn- decode-row-features
[{:keys [features] :as row}]
(when row
(cond-> row
features (assoc :features (db/decode-pgarray features #{}))
changes (assoc :changes (blob/decode changes))
data (assoc :data (blob/decode data)))))
(db/pgarray? features) (assoc :features (db/decode-pgarray features #{})))))
(def sql:get-minimal-file
"SELECT f.id,
@@ -162,23 +159,158 @@
[cfg id & {:as opts}]
(db/get-with-sql cfg [sql:get-minimal-file id] opts))
(defn decode-file
"A general purpose file decoding function that resolves all external
pointers, run migrations and return plain vanilla file map"
[cfg {:keys [id] :as file} & {:keys [migrate?] :or {migrate? true}}]
(binding [pmap/*load-fn* (partial fdata/load-pointer cfg id)]
(let [file (->> file
(def sql:files-with-data
"SELECT f.id,
f.project_id,
f.created_at,
f.modified_at,
f.deleted_at,
f.name,
f.is_shared,
f.has_media_trimmed,
f.revn,
f.data AS legacy_data,
f.ignore_sync_until,
f.comment_thread_seqn,
f.features,
f.version,
f.vern,
p.team_id,
coalesce(fd.backend, 'legacy-db') AS backend,
fd.metadata AS metadata,
fd.data AS data
FROM file AS f
LEFT JOIN file_data AS fd ON (fd.file_id = f.id AND fd.id = f.id)
INNER JOIN project AS p ON (p.id = f.project_id)")
(def sql:get-file
(str sql:files-with-data " WHERE f.id = ?"))
(def sql:get-file-without-data
(str "WITH files AS (" sql:files-with-data ")"
"SELECT f.id,
f.project_id,
f.created_at,
f.modified_at,
f.deleted_at,
f.name,
f.is_shared,
f.has_media_trimmed,
f.revn,
f.ignore_sync_until,
f.comment_thread_seqn,
f.features,
f.version,
f.vern,
f.team_id
FROM files AS f
WHERE f.id = ?"))
(defn- migrate-file
[{:keys [::db/conn] :as cfg} {:keys [read-only?]} {:keys [id] :as file}]
(binding [pmap/*load-fn* (partial fdata/load-pointer cfg id)
pmap/*tracked* (pmap/create-tracked)]
(let [libs (delay (get-resolved-file-libraries cfg file))
;; For avoid unnecesary overhead of creating multiple
;; pointers and handly internally with objects map in their
;; worst case (when probably all shapes and all pointers
;; will be readed in any case), we just realize/resolve them
;; before applying the migration to the file.
file (-> (fdata/realize cfg file)
(fmg/migrate-file libs))]
(if (or read-only? (db/read-only? conn))
file
(do ;; When file is migrated, we break the rule of no
;; perform mutations on get operations and update the
;; file with all migrations applied
(update-file! cfg file)
(fmigr/resolve-applied-migrations cfg file))))))
(defn- get-file*
[{:keys [::db/conn] :as cfg} id
{:keys [migrate?
realize?
decode?
skip-locked?
include-deleted?
load-data?
throw-if-not-exists?
lock-for-update?
lock-for-share?]
:or {lock-for-update? false
lock-for-share? false
load-data? true
migrate? true
decode? true
include-deleted? false
throw-if-not-exists? true
realize? false}
:as options}]
(assert (db/connection? conn) "expected cfg with valid connection")
(when (and (not load-data?)
(or lock-for-share? lock-for-share? skip-locked?))
(throw (IllegalArgumentException. "locking is incompatible when `load-data?` is false")))
(let [sql
(if load-data?
sql:get-file
sql:get-file-without-data)
sql
(cond
lock-for-update?
(str sql " FOR UPDATE of f")
lock-for-share?
(str sql " FOR SHARE of f")
:else
sql)
sql
(if skip-locked?
(str sql " SKIP LOCKED")
sql)
file
(db/get-with-sql conn [sql id]
{::db/throw-if-not-exists false
::db/remove-deleted (not include-deleted?)})
file
(-> file
(d/update-when :features db/decode-pgarray #{})
(d/update-when :metadata fdata/decode-metadata))]
(if file
(if load-data?
(let [file
(->> file
(fmigr/resolve-applied-migrations cfg)
(fdata/resolve-file-data cfg))
libs (delay (get-resolved-file-libraries cfg file))]
(-> file
(update :features db/decode-pgarray #{})
(update :data blob/decode)
(update :data fdata/process-pointers deref)
(update :data fdata/process-objects (partial into {}))
(update :data assoc :id id)
(cond-> migrate? (fmg/migrate-file libs))))))
will-migrate?
(and migrate? (fmg/need-migration? file))]
(if decode?
(cond->> (fdata/decode-file-data cfg file)
(and realize? (not will-migrate?))
(fdata/realize cfg)
will-migrate?
(migrate-file cfg options))
file))
file)
(when-not (or skip-locked? (not throw-if-not-exists?))
(ex/raise :type :not-found
:code :object-not-found
:hint "database object not found"
:table :file
:file-id id)))))
(defn get-file
"Get file, resolve all features and apply migrations.
@@ -187,10 +319,7 @@
operations on file, because it removes the ovehead of lazy fetching
and decoding."
[cfg file-id & {:as opts}]
(db/run! cfg (fn [{:keys [::db/conn] :as cfg}]
(when-let [row (db/get* conn :file {:id file-id}
(assoc opts ::db/remove-deleted false))]
(decode-file cfg row opts)))))
(db/run! cfg get-file* file-id opts))
(defn clean-file-features
[file]
@@ -214,12 +343,12 @@
(let [conn (db/get-connection cfg)
ids (db/create-array conn "uuid" ids)]
(->> (db/exec! conn [sql:get-teams ids])
(map decode-row))))
(map decode-row-features))))
(defn get-team
[cfg team-id]
(-> (db/get cfg :team {:id team-id})
(decode-row)))
(decode-row-features)))
(defn get-fonts
[cfg team-id]
@@ -311,7 +440,6 @@
(do
(l/trc :hint "lookup index"
:file-id (str file-id)
:snap-id (str (:snapshot-id file))
:id (str id)
:result (str (get mobj :id)))
(get mobj :id))
@@ -328,7 +456,6 @@
(doseq [[old-id item] missing-index]
(l/dbg :hint "create missing references"
:file-id (str file-id)
:snap-id (str (:snapshot-id file))
:old-id (str old-id)
:id (str (:id item)))
(db/insert! conn :file-media-object item
@@ -339,12 +466,16 @@
(def sql:get-file-media
"SELECT * FROM file_media_object WHERE id = ANY(?)")
(defn get-file-media
[cfg {:keys [data] :as file}]
(db/run! cfg (fn [{:keys [::db/conn]}]
(defn get-file-media*
[{:keys [::db/conn] :as cfg} {:keys [data id] :as file}]
(let [used (cfh/collect-used-media data)
used (db/create-array conn "uuid" used)]
(db/exec! conn [sql:get-file-media used])))))
(->> (db/exec! conn [sql:get-file-media used])
(mapv (fn [row] (assoc row :file-id id))))))
(defn get-file-media
[cfg file]
(db/run! cfg get-file-media* file))
(def ^:private sql:get-team-files-ids
"SELECT f.id FROM file AS f
@@ -475,8 +606,8 @@
;; all of them, not only the applied
(vary-meta dissoc ::fmg/migrated))))
(defn encode-file
[{:keys [::wrk/executor] :as cfg} {:keys [id features] :as file}]
(defn- encode-file
[cfg {:keys [id features] :as file}]
(let [file (if (and (contains? features "fdata/objects-map")
(:data file))
(fdata/enable-objects-map file)
@@ -493,18 +624,33 @@
(-> file
(d/update-when :features into-array)
(d/update-when :data (fn [data] (px/invoke! executor #(blob/encode data)))))))
(d/update-when :data blob/encode))))
(defn- file->params
[file]
(-> (select-keys file file-attrs)
(assoc :data nil)
(dissoc :team-id)
(dissoc :migrations)))
(defn- file->file-data-params
[{:keys [id] :as file} & {:as opts}]
(let [created-at (or (:created-at file) (ct/now))
modified-at (or (:modified-at file) created-at)]
(d/without-nils
{:id id
:type "main"
:file-id id
:data (:data file)
:metadata (:metadata file)
:created-at created-at
:modified-at modified-at})))
(defn insert-file!
"Insert a new file into the database table. Expectes a not-encoded file.
Returns nil."
[{:keys [::db/conn] :as cfg} file & {:as opts}]
(db/exec-one! conn ["SET CONSTRAINTS ALL DEFERRED"])
(when (:migrations file)
(fmigr/upsert-migrations! conn file))
@@ -512,35 +658,43 @@
(let [file (encode-file cfg file)]
(db/insert! conn :file
(file->params file)
{::db/return-keys false})
(assoc opts ::db/return-keys false))
(->> (file->file-data-params file)
(fdata/upsert! cfg))
nil))
(defn update-file!
"Update an existing file on the database. Expects not encoded file."
[{:keys [::db/conn] :as cfg} {:keys [id] :as file} & {:as opts}]
(if (::reset-migrations opts false)
(if (::reset-migrations? opts false)
(fmigr/reset-migrations! conn file)
(fmigr/upsert-migrations! conn file))
(let [file
(encode-file cfg file)
params
(file->params (dissoc file :id))]
file-params
(file->params (dissoc file :id))
(db/update! conn :file params
file-data-params
(file->file-data-params file)]
(db/update! conn :file file-params
{:id id}
{::db/return-keys false})
(fdata/upsert! cfg file-data-params)
nil))
(defn save-file!
"Applies all the final validations and perist the file, binfile
specific, should not be used outside of binfile domain.
Returns nil"
[{:keys [::timestamp] :as cfg} file & {:as opts}]
(assert (ct/inst? timestamp) "expected valid timestamp")
(let [file (-> file
@@ -565,7 +719,7 @@
(l/error :hint "file schema validation error" :cause result))))
(if (::overwrite cfg)
(update-file! cfg file (assoc opts ::reset-migrations true))
(update-file! cfg file (assoc opts ::reset-migrations? true))
(insert-file! cfg file opts))))
(def ^:private sql:get-file-libraries
@@ -595,7 +749,7 @@
l.version
FROM libs AS l
INNER JOIN project AS p ON (p.id = l.project_id)
WHERE l.deleted_at IS NULL OR l.deleted_at > now();")
WHERE l.deleted_at IS NULL;")
(defn get-file-libraries
[conn file-id]
@@ -604,7 +758,7 @@
;; FIXME: :is-indirect set to false to all rows looks
;; completly useless
(map #(assoc % :is-indirect false))
(map decode-row))
(map decode-row-features))
(db/exec! conn [sql:get-file-libraries file-id])))
(defn get-resolved-file-libraries

2
backend/src/app/binfile/v1.clj
View File

@@ -346,7 +346,7 @@
thumbnails (->> (bfc/get-file-object-thumbnails cfg file-id)
(mapv #(dissoc % :file-id)))
file (cond-> (bfc/get-file cfg file-id)
file (cond-> (bfc/get-file cfg file-id :realize? true)
detach?
(-> (ctf/detach-external-references file-id)
(dissoc :libraries))

2
backend/src/app/binfile/v2.clj
View File

@@ -153,7 +153,7 @@
(defn- write-file!
[cfg file-id]
(let [file (bfc/get-file cfg file-id)
(let [file (bfc/get-file cfg file-id :realize? true)
thumbs (bfc/get-file-object-thumbnails cfg file-id)
media (bfc/get-file-media cfg file)
rels (bfc/get-files-rels cfg #{file-id})]

115
backend/src/app/binfile/v3.clj
View File

@@ -226,7 +226,9 @@
(let [detach? (and (not embed-assets) (not include-libraries))]
(db/tx-run! cfg (fn [cfg]
(cond-> (bfc/get-file cfg file-id {::sql/for-update true})
(cond-> (bfc/get-file cfg file-id
{:realize? true
:lock-for-update? true})
detach?
(-> (ctf/detach-external-references file-id)
(dissoc :libraries))
@@ -713,7 +715,7 @@
:plugin-data plugin-data}))
(defn- import-file
[{:keys [::bfc/project-id] :as cfg} {file-id :id file-name :name}]
[{:keys [::db/conn ::bfc/project-id] :as cfg} {file-id :id file-name :name}]
(let [file-id' (bfc/lookup-index file-id)
file (read-file cfg file-id)
media (read-file-media cfg file-id)
@@ -726,26 +728,48 @@
:version (:version file)
::l/sync? true)
(events/tap :progress {:section :file :name file-name})
(vswap! bfc/*state* update :index bfc/update-index media :id)
(when media
;; Update index with media
(l/dbg :hint "update media index"
(events/tap :progress {:section :media :file-id file-id})
(doseq [item media]
(let [params (-> item
(update :id bfc/lookup-index)
(assoc :file-id file-id')
(d/update-when :media-id bfc/lookup-index)
(d/update-when :thumbnail-id bfc/lookup-index))]
(l/dbg :hint "inserting media object"
:file-id (str file-id')
:total (count media)
:id (str (:id params))
:media-id (str (:media-id params))
:thumbnail-id (str (:thumbnail-id params))
:old-id (str (:id item))
::l/sync? true)
(vswap! bfc/*state* update :index bfc/update-index (map :id media))
(vswap! bfc/*state* update :media into media))
(db/insert! conn :file-media-object params
::db/on-conflict-do-nothing? (::bfc/overwrite cfg))))
(when thumbnails
(l/dbg :hint "update thumbnails index"
(events/tap :progress {:section :thumbnails :file-id file-id})
(doseq [item thumbnails]
(let [media-id (bfc/lookup-index (:media-id item))
object-id (-> (assoc item :file-id file-id')
(cth/fmt-object-id))
params {:file-id file-id'
:object-id object-id
:tag (:tag item)
:media-id media-id}]
(l/dbg :hint "inserting object thumbnail"
:file-id (str file-id')
:total (count thumbnails)
:media-id (str media-id)
::l/sync? true)
(vswap! bfc/*state* update :index bfc/update-index (map :media-id thumbnails))
(vswap! bfc/*state* update :thumbnails into thumbnails))
(db/insert! conn :file-tagged-object-thumbnail params
::db/on-conflict-do-nothing? true)))
(events/tap :progress {:section :file :file-id file-id})
(let [data (-> (read-file-data cfg file-id)
(d/without-nils)
@@ -796,16 +820,9 @@
(doseq [{:keys [id entry]} entries]
(let [object (->> (read-entry input entry)
(decode-storage-object)
(validate-storage-object))]
(validate-storage-object))
(when (not= id (:id object))
(ex/raise :type :validation
:code :inconsistent-penpot-file
:hint "the penpot file seems corrupt, found unexpected uuid (storage-object-id)"
:expected-id (str id)
:found-id (str (:id object))))
(let [ext (cmedia/mtype->extension (:content-type object))
ext (cmedia/mtype->extension (:content-type object))
path (str "objects/" id ext)
content (->> path
(get-zip-entry input)
@@ -841,48 +858,7 @@
:bucket (:bucket params)
::l/sync? true)
(vswap! bfc/*state* update :index assoc id (:id sobject))))))))
(defn- import-file-media
[{:keys [::db/conn] :as cfg}]
(events/tap :progress {:section :media})
(doseq [item (:media @bfc/*state*)]
(let [params (-> item
(update :id bfc/lookup-index)
(update :file-id bfc/lookup-index)
(d/update-when :media-id bfc/lookup-index)
(d/update-when :thumbnail-id bfc/lookup-index))]
(l/dbg :hint "inserting file media object"
:old-id (str (:id item))
:id (str (:id params))
:file-id (str (:file-id params))
::l/sync? true)
(db/insert! conn :file-media-object params
::db/on-conflict-do-nothing? (::bfc/overwrite cfg)))))
(defn- import-file-thumbnails
[{:keys [::db/conn] :as cfg}]
(events/tap :progress {:section :thumbnails})
(doseq [item (:thumbnails @bfc/*state*)]
(let [file-id (bfc/lookup-index (:file-id item))
media-id (bfc/lookup-index (:media-id item))
object-id (-> (assoc item :file-id file-id)
(cth/fmt-object-id))
params {:file-id file-id
:object-id object-id
:tag (:tag item)
:media-id media-id}]
(l/dbg :hint "inserting file object thumbnail"
:file-id (str file-id)
:media-id (str media-id)
::l/sync? true)
(db/insert! conn :file-tagged-object-thumbnail params
{::db/on-conflict-do-nothing? true}))))
(vswap! bfc/*state* update :index assoc id (:id sobject)))))))
(defn- import-files*
[{:keys [::manifest] :as cfg}]
@@ -890,6 +866,8 @@
(vswap! bfc/*state* update :index bfc/update-index (:files manifest) :id)
(import-storage-objects cfg)
(let [files (get manifest :files)
result (reduce (fn [result {:keys [id] :as file}]
(let [name' (get file :name)
@@ -902,10 +880,6 @@
files)]
(import-file-relations cfg)
(import-storage-objects cfg)
(import-file-media cfg)
(import-file-thumbnails cfg)
(bfm/apply-pending-migrations! cfg)
result))
@@ -930,9 +904,8 @@
(binding [bfc/*options* cfg
bfc/*reference-file* ref-file]
(import-file cfg file)
(import-storage-objects cfg)
(import-file-media cfg)
(import-file cfg file)
(bfc/invalidate-thumbnails cfg file-id)
(bfm/apply-pending-migrations! cfg)

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

@@ -52,6 +52,8 @@
:redis-uri "redis://redis/0"
:file-data-backend "legacy-db"
:objects-storage-backend "fs"
:objects-storage-fs-directory "assets"
@@ -96,7 +98,9 @@
[:http-server-max-body-size {:optional true} ::sm/int]
[:http-server-max-multipart-body-size {:optional true} ::sm/int]
[:http-server-io-threads {:optional true} ::sm/int]
[:http-server-worker-threads {:optional true} ::sm/int]
[:http-server-max-worker-threads {:optional true} ::sm/int]
[:management-api-shared-key {:optional true} :string]
[:telemetry-uri {:optional true} :string]
[:telemetry-with-taiga {:optional true} ::sm/boolean] ;; DELETE
@@ -105,7 +109,8 @@
[:auto-file-snapshot-timeout {:optional true} ::ct/duration]
[:media-max-file-size {:optional true} ::sm/int]
[:deletion-delay {:optional true} ::ct/duration] ;; REVIEW
[:deletion-delay {:optional true} ::ct/duration]
[:file-clean-delay {:optional true} ::ct/duration]
[:telemetry-enabled {:optional true} ::sm/boolean]
[:default-blob-version {:optional true} ::sm/int]
[:allow-demo-users {:optional true} ::sm/boolean]
@@ -146,7 +151,6 @@
[:quotes-team-access-requests-per-team {:optional true} ::sm/int]
[:quotes-team-access-requests-per-requester {:optional true} ::sm/int]
[:auth-data-cookie-domain {:optional true} :string]
[:auth-token-cookie-name {:optional true} :string]
[:auth-token-cookie-max-age {:optional true} ::ct/duration]
@@ -210,24 +214,27 @@
[:prepl-host {:optional true} :string]
[:prepl-port {:optional true} ::sm/int]
[:file-data-backend {:optional true} [:enum "db" "legacy-db" "storage"]]
[:media-directory {:optional true} :string] ;; REVIEW
[:media-uri {:optional true} :string]
[:assets-path {:optional true} :string]
;; Legacy, will be removed in 2.5
[:netty-io-threads {:optional true} ::sm/int]
[:executor-threads {:optional true} ::sm/int]
;; DEPRECATED
[:assets-storage-backend {:optional true} :keyword]
[:storage-assets-fs-directory {:optional true} :string]
[:storage-assets-s3-bucket {:optional true} :string]
[:storage-assets-s3-region {:optional true} :keyword]
[:storage-assets-s3-endpoint {:optional true} ::sm/uri]
[:storage-assets-s3-io-threads {:optional true} ::sm/int]
[:objects-storage-backend {:optional true} :keyword]
[:objects-storage-fs-directory {:optional true} :string]
[:objects-storage-s3-bucket {:optional true} :string]
[:objects-storage-s3-region {:optional true} :keyword]
[:objects-storage-s3-endpoint {:optional true} ::sm/uri]
[:objects-storage-s3-io-threads {:optional true} ::sm/int]]))
[:objects-storage-s3-endpoint {:optional true} ::sm/uri]]))
(defn- parse-flags
[config]
@@ -300,6 +307,11 @@
(or (c/get config :deletion-delay)
(ct/duration {:days 7})))
(defn get-file-clean-delay
[]
(or (c/get config :file-clean-delay)
(ct/duration {:days 2})))
(defn get
"A configuration getter. Helps code be more testable."
([key]

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

@@ -298,7 +298,7 @@
(defn insert!
"A helper that builds an insert sql statement and executes it. By
default returns the inserted row with all the field; you can delimit
the returned columns with the `::columns` option."
the returned columns with the `::sql/columns` option."
[ds table params & {:as opts}]
(let [conn (get-connectable ds)
sql (sql/insert table params opts)
@@ -379,9 +379,7 @@
(defn is-row-deleted?
[{:keys [deleted-at]}]
(and (ct/inst? deleted-at)
(< (inst-ms deleted-at)
(inst-ms (ct/now)))))
(some? deleted-at))
(defn get*
"Retrieve a single row from database that matches a simple filters. Do
@@ -406,10 +404,10 @@
:hint "database object not found"))
row))
(defn get-with-sql
[ds sql & {:as opts}]
(let [rows (cond->> (exec! ds sql opts)
(let [rows
(cond->> (exec! ds sql opts)
(::remove-deleted opts true)
(remove is-row-deleted?)
@@ -423,7 +421,6 @@
(first rows)))
(def ^:private default-plan-opts
(-> default-opts
(assoc :fetch-size 1000)
@@ -578,10 +575,10 @@
[system f & params]
(cond
(connection? system)
(run! {::conn system} f)
(apply run! {::conn system} f params)
(pool? system)
(run! {::pool system} f)
(apply run! {::pool system} f params)
(::conn system)
(apply f system params)

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

@@ -9,32 +9,46 @@
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.files.helpers :as cfh]
[app.common.files.migrations :as fmg]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.types.objects-map :as omap]
[app.common.types.path :as path]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as-alias sql]
[app.storage :as sto]
[app.util.blob :as blob]
[app.util.objects-map :as omap.legacy]
[app.util.pointer-map :as pmap]
[app.worker :as wrk]
[promesa.exec :as px]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OFFLOAD
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn offloaded?
[file]
(= "objects-storage" (:data-backend file)))
[app.util.pointer-map :as pmap]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OBJECTS-MAP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn process-objects
"Apply a function to all objects-map on the file. Usualy used for convert
the objects-map instances to plain maps"
[fdata update-fn]
(if (contains? fdata :pages-index)
(update fdata :pages-index d/update-vals
(fn [page]
(update page :objects
(fn [objects]
(if (or (omap/objects-map? objects)
(omap.legacy/objects-map? objects))
(update-fn objects)
objects)))))
fdata))
(defn realize-objects
"Process a file and remove all instances of objects map realizing them
to a plain data. Used in operation where is more efficient have the
whole file loaded in memory or we going to persist it in an
alterantive storage."
[_cfg file]
(update file :data process-objects (partial into {})))
(defn enable-objects-map
[file & _opts]
(let [update-page
@@ -63,51 +77,194 @@
(update :data update-data)
(update :features disj "fdata/objects-map"))))
(defn process-objects
"Apply a function to all objects-map on the file. Usualy used for convert
the objects-map instances to plain maps"
[fdata update-fn]
(if (contains? fdata :pages-index)
(update fdata :pages-index d/update-vals
(fn [page]
(update page :objects
(fn [objects]
(if (or (omap/objects-map? objects)
(omap.legacy/objects-map? objects))
(update-fn objects)
objects)))))
fdata))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; STORAGE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmulti resolve-file-data
(fn [_cfg file] (get file :backend "legacy-db")))
(defmethod resolve-file-data "legacy-db"
[_cfg {:keys [legacy-data] :as file}]
(-> file
(assoc :data legacy-data)
(dissoc :legacy-data)))
(defmethod resolve-file-data "db"
[_cfg file]
(dissoc file :legacy-data))
(defmethod resolve-file-data "storage"
[cfg {:keys [metadata] :as file}]
(let [storage (sto/resolve cfg ::db/reuse-conn true)
ref-id (:storage-ref-id metadata)
data (->> (sto/get-object storage ref-id)
(sto/get-object-bytes storage))]
(-> file
(assoc :data data)
(dissoc :legacy-data))))
(defn decode-file-data
[_cfg {:keys [data] :as file}]
(cond-> file
(bytes? data)
(assoc :data (blob/decode data))))
(def ^:private sql:insert-file-data
"INSERT INTO file_data (file_id, id, created_at, modified_at, deleted_at,
type, backend, metadata, data)
VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)")
(def ^:private sql:upsert-file-data
(str sql:insert-file-data
" ON CONFLICT (file_id, id)
DO UPDATE SET modified_at=?,
deleted_at=?,
backend=?,
metadata=?,
data=?"))
(defn- upsert-in-database
[cfg {:keys [id file-id created-at modified-at deleted-at type backend data metadata]}]
(let [created-at (or created-at (ct/now))
metadata (some-> metadata db/json)
modified-at (or modified-at created-at)]
(db/exec-one! cfg [sql:upsert-file-data
file-id id
created-at
modified-at
deleted-at
type
backend
metadata
data
modified-at
deleted-at
backend
metadata
data])))
(defn- handle-persistence
[cfg {:keys [type backend id file-id data] :as params}]
(cond
(= backend "storage")
(let [storage (sto/resolve cfg)
content (sto/content data)
sobject (sto/put-object! storage
{::sto/content content
::sto/touch true
:bucket "file-data"
:content-type "application/octet-stream"
:file-id file-id
:id id})
metadata {:storage-ref-id (:id sobject)}
params (-> params
(assoc :metadata metadata)
(assoc :data nil))]
(upsert-in-database cfg params))
(= backend "db")
(->> (dissoc params :metadata)
(upsert-in-database cfg))
(= backend "legacy-db")
(cond
(= type "main")
(do
(db/delete! cfg :file-data
{:id id :file-id file-id :type "main"}
{::db/return-keys false})
(db/update! cfg :file
{:data data}
{:id file-id}
{::db/return-keys false}))
(= type "snapshot")
(do
(db/delete! cfg :file-data
{:id id :file-id file-id :type "snapshot"}
{::db/return-keys false})
(db/update! cfg :file-change
{:data data}
{:file-id file-id :id id}
{::db/return-keys false}))
(= type "fragment")
(upsert-in-database cfg
(-> (dissoc params :metadata)
(assoc :backend "db")))
:else
(throw (RuntimeException. "not implemented")))
:else
(throw (IllegalArgumentException.
(str "backend '" backend "' not supported")))))
(defn process-metadata
[cfg metadata]
(when-let [storage-id (:storage-ref-id metadata)]
(let [storage (sto/resolve cfg ::db/reuse-conn true)]
(sto/touch-object! storage storage-id))))
(defn- default-backend
[backend]
(or backend (cf/get :file-data-backend)))
(def ^:private schema:metadata
[:map {:title "Metadata"}
[:storage-ref-id {:optional true} ::sm/uuid]])
(def decode-metadata-with-schema
(sm/decoder schema:metadata sm/json-transformer))
(defn decode-metadata
[metadata]
(some-> metadata
(db/decode-json-pgobject)
(decode-metadata-with-schema)))
(def ^:private schema:update-params
[:map {:closed true}
[:id ::sm/uuid]
[:type [:enum "main" "snapshot" "fragment"]]
[:file-id ::sm/uuid]
[:backend {:optional true} [:enum "db" "legacy-db" "storage"]]
[:metadata {:optional true} [:maybe schema:metadata]]
[:data {:optional true} bytes?]
[:created-at {:optional true} ::ct/inst]
[:modified-at {:optional true} [:maybe ::ct/inst]]
[:deleted-at {:optional true} [:maybe ::ct/inst]]])
(def ^:private check-update-params
(sm/check-fn schema:update-params :hint "invalid params received for update"))
(defn upsert!
"Create or update file data"
[cfg params & {:as opts}]
(let [params (-> (check-update-params params)
(update :backend default-backend))]
(some->> (:metadata params)
(process-metadata cfg))
(-> (handle-persistence cfg params)
(db/get-update-count)
(pos?))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; POINTER-MAP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn get-file-data
"Get file data given a file instance."
[system file]
(if (offloaded? file)
(let [storage (sto/resolve system ::db/reuse-conn true)]
(->> (sto/get-object storage (:data-ref-id file))
(sto/get-object-bytes storage)))
(:data file)))
(defn resolve-file-data
[system file]
(let [data (get-file-data system file)]
(assoc file :data data)))
(defn decode-file-data
[{:keys [::wrk/executor]} {:keys [data] :as file}]
(cond-> file
(bytes? data)
(assoc :data (px/invoke! executor #(blob/decode data)))))
(defn load-pointer
"A database loader pointer helper"
[system file-id id]
(let [fragment (db/get* system :file-data-fragment
{:id id :file-id file-id}
{::sql/columns [:data :data-backend :data-ref-id :id]})]
[cfg file-id id]
(let [fragment (some-> (db/get* cfg :file-data
{:id id :file-id file-id :type "fragment"}
{::sql/columns [:data :backend :id :metadata]})
(update :metadata decode-metadata))]
(l/trc :hint "load pointer"
:file-id (str file-id)
@@ -121,22 +278,21 @@
:file-id file-id
:fragment-id id))
(let [data (get-file-data system fragment)]
;; FIXME: conditional thread scheduling for decoding big objects
(blob/decode data))))
(-> (resolve-file-data cfg fragment)
(get :data)
(blob/decode))))
(defn persist-pointers!
"Persist all currently tracked pointer objects"
[system file-id]
(let [conn (db/get-connection system)]
[cfg file-id]
(doseq [[id item] @pmap/*tracked*]
(when (pmap/modified? item)
(l/trc :hint "persist pointer" :file-id (str file-id) :id (str id))
(let [content (-> item deref blob/encode)]
(db/insert! conn :file-data-fragment
{:id id
(upsert! cfg {:id id
:file-id file-id
:data content}))))))
:type "fragment"
:data content})))))
(defn process-pointers
"Apply a function to all pointers on the file. Usuly used for
@@ -150,6 +306,14 @@
(d/update-vals update-fn')
(update :pages-index d/update-vals update-fn'))))
(defn realize-pointers
"Process a file and remove all instances of pointers realizing them to
a plain data. Used in operation where is more efficient have the
whole file loaded in memory."
[cfg {:keys [id] :as file}]
(binding [pmap/*load-fn* (partial load-pointer cfg id)]
(update file :data process-pointers deref)))
(defn get-used-pointer-ids
"Given a file, return all pointer ids used in the data."
[fdata]
@@ -169,47 +333,12 @@
(update :features conj "fdata/pointer-map")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PATH-DATA
;; GENERAL PURPOSE HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn enable-path-data
"Enable the fdata/path-data feature on the file."
[file & _opts]
(letfn [(update-object [object]
(if (or (cfh/path-shape? object)
(cfh/bool-shape? object))
(update object :content path/content)
object))
(update-container [container]
(d/update-when container :objects d/update-vals update-object))]
(-> file
(update :data (fn [data]
(-> data
(update :pages-index d/update-vals update-container)
(d/update-when :components d/update-vals update-container))))
(update :features conj "fdata/path-data"))))
(defn disable-path-data
[file & _opts]
(letfn [(update-object [object]
(if (or (cfh/path-shape? object)
(cfh/bool-shape? object))
(update object :content vec)
object))
(update-container [container]
(d/update-when container :objects d/update-vals update-object))]
(when-let [conn db/*conn*]
(db/delete! conn :file-migration {:file-id (:id file)
:name "0003-convert-path-content"}))
(-> file
(update :data (fn [data]
(-> data
(update :pages-index d/update-vals update-container)
(d/update-when :components d/update-vals update-container))))
(update :features disj "fdata/path-data")
(update :migrations disj "0003-convert-path-content")
(vary-meta update ::fmg/migrated disj "0003-convert-path-content"))))
(defn realize
"A helper that combines realize-pointers and realize-objects"
[cfg file]
(->> file
(realize-pointers cfg)
(realize-objects cfg)))

446
backend/src/app/features/file_snapshots.clj Normal file
View File

@@ -0,0 +1,446 @@
;; 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.features.file-snapshots
(:require
[app.binfile.common :as bfc]
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.features :as-alias cfeat]
[app.common.files.migrations :as fmg]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as-alias sql]
[app.features.fdata :as fdata]
[app.storage :as sto]
[app.util.blob :as blob]
[app.worker :as wrk]
[cuerdas.core :as str]))
(def sql:snapshots
"SELECT c.id,
c.label,
c.created_at,
c.updated_at AS modified_at,
c.deleted_at,
c.profile_id,
c.created_by,
c.locked_by,
c.revn,
c.features,
c.migrations,
c.version,
c.file_id,
c.data AS legacy_data,
fd.data AS data,
coalesce(fd.backend, 'legacy-db') AS backend,
fd.metadata AS metadata
FROM file_change AS c
LEFT JOIN file_data AS fd ON (fd.file_id = c.file_id
AND fd.id = c.id
AND fd.type = 'snapshot')
WHERE c.label IS NOT NULL")
(defn- decode-snapshot
[snapshot]
(some-> snapshot
(-> (d/update-when :metadata fdata/decode-metadata)
(d/update-when :migrations db/decode-pgarray [])
(d/update-when :features db/decode-pgarray #{}))))
(def ^:private sql:get-minimal-file
"SELECT f.id,
f.revn,
f.modified_at,
f.deleted_at,
fd.backend AS backend,
fd.metadata AS metadata
FROM file AS f
LEFT JOIN file_data AS fd ON (fd.file_id = f.id AND fd.id = f.id)
WHERE f.id = ?")
(defn- get-minimal-file
[cfg id & {:as opts}]
(-> (db/get-with-sql cfg [sql:get-minimal-file id] opts)
(d/update-when :metadata fdata/decode-metadata)))
(def ^:private sql:get-snapshot-without-data
(str "WITH snapshots AS (" sql:snapshots ")"
"SELECT c.id,
c.label,
c.revn,
c.created_at,
c.modified_at,
c.deleted_at,
c.profile_id,
c.created_by,
c.locked_by,
c.features,
c.metadata,
c.migrations,
c.version,
c.file_id
FROM snapshots AS c
WHERE c.id = ?
AND CASE WHEN c.created_by = 'user'
THEN c.deleted_at IS NULL
WHEN c.created_by = 'system'
THEN c.deleted_at IS NULL OR c.deleted_at >= ?::timestamptz
END"))
(defn get-minimal-snapshot
[cfg snapshot-id]
(let [now (ct/now)]
(-> (db/get-with-sql cfg [sql:get-snapshot-without-data snapshot-id now]
{::db/remove-deleted false})
(decode-snapshot))))
(def ^:private sql:get-snapshot
(str sql:snapshots
" AND c.file_id = ?
AND c.id = ?
AND CASE WHEN c.created_by = 'user'
THEN (c.deleted_at IS NULL)
WHEN c.created_by = 'system'
THEN (c.deleted_at IS NULL OR c.deleted_at >= ?::timestamptz)
END"))
(defn- get-snapshot
"Get snapshot with decoded data"
[cfg file-id snapshot-id]
(let [now (ct/now)]
(->> (db/get-with-sql cfg [sql:get-snapshot file-id snapshot-id now]
{::db/remove-deleted false})
(decode-snapshot)
(fdata/resolve-file-data cfg)
(fdata/decode-file-data cfg))))
(def ^:private sql:get-visible-snapshots
(str "WITH "
"snapshots1 AS ( " sql:snapshots "),"
"snapshots2 AS (
SELECT c.id,
c.label,
c.revn,
c.version,
c.created_at,
c.modified_at,
c.created_by,
c.locked_by,
c.profile_id,
c.deleted_at
FROM snapshots1 AS c
WHERE c.file_id = ?
), snapshots3 AS (
(SELECT * FROM snapshots2
WHERE created_by = 'system'
AND (deleted_at IS NULL OR
deleted_at >= ?::timestamptz)
LIMIT 500)
UNION ALL
(SELECT * FROM snapshots2
WHERE created_by = 'user'
AND deleted_at IS NULL
LIMIT 500)
)
SELECT * FROM snapshots3
ORDER BY created_at DESC"))
(defn get-visible-snapshots
"Return a list of snapshots fecheable from the API, it has a limited
set of fields and applies big but safe limits over all available
snapshots. It return a ordered vector by the snapshot date of
creation."
[cfg file-id]
(let [now (ct/now)]
(->> (db/exec! cfg [sql:get-visible-snapshots file-id now])
(mapv decode-snapshot))))
(def ^:private schema:decoded-file
[:map {:title "DecodedFile"}
[:id ::sm/uuid]
[:revn :int]
[:vern :int]
[:data :map]
[:version :int]
[:features ::cfeat/features]
[:migrations [::sm/set :string]]])
(def ^:private schema:snapshot
[:map {:title "Snapshot"}
[:id ::sm/uuid]
[:revn [::sm/int {:min 0}]]
[:version [::sm/int {:min 0}]]
[:features ::cfeat/features]
[:migrations [::sm/set ::sm/text]]
[:profile-id {:optional true} ::sm/uuid]
[:label ::sm/text]
[:file-id ::sm/uuid]
[:created-by [:enum "system" "user" "admin"]]
[:deleted-at {:optional true} ::ct/inst]
[:modified-at ::ct/inst]
[:created-at ::ct/inst]])
(def ^:private check-snapshot
(sm/check-fn schema:snapshot))
(def ^:private check-decoded-file
(sm/check-fn schema:decoded-file))
(defn- generate-snapshot-label
[]
(let [ts (-> (ct/now)
(ct/format-inst)
(str/replace #"[T:\.]" "-")
(str/rtrim "Z"))]
(str "snapshot-" ts)))
(def ^:private schema:create-params
[:map {:title "SnapshotCreateParams"}
[:profile-id ::sm/uuid]
[:created-by {:optional true} [:enum "user" "system"]]
[:label {:optional true} ::sm/text]
[:session-id {:optional true} ::sm/uuid]
[:modified-at {:optional true} ::ct/inst]
[:deleted-at {:optional true} ::ct/inst]])
(def ^:private check-create-params
(sm/check-fn schema:create-params))
(defn create!
"Create a file snapshot; expects a non-encoded file"
[cfg file & {:as params}]
(let [{:keys [label created-by deleted-at profile-id session-id]}
(check-create-params params)
file
(check-decoded-file file)
created-by
(or created-by "system")
snapshot-id
(uuid/next)
created-at
(ct/now)
deleted-at
(or deleted-at
(if (= created-by "system")
(ct/in-future (cf/get-deletion-delay))
nil))
label
(or label (generate-snapshot-label))
snapshot
(cond-> {:id snapshot-id
:revn (:revn file)
:version (:version file)
:file-id (:id file)
:features (:features file)
:migrations (:migrations file)
:label label
:created-at created-at
:modified-at created-at
:created-by created-by}
deleted-at
(assoc :deleted-at deleted-at)
:always
(check-snapshot))]
(db/insert! cfg :file-change
(-> snapshot
(update :features into-array)
(update :migrations into-array)
(assoc :updated-at created-at)
(assoc :profile-id profile-id)
(assoc :session-id session-id)
(dissoc :modified-at))
{::db/return-keys false})
(fdata/upsert! cfg
{:id snapshot-id
:file-id (:id file)
:type "snapshot"
:data (blob/encode (:data file))
:created-at created-at
:deleted-at deleted-at})
snapshot))
(def ^:private schema:update-params
[:map {:title "SnapshotUpdateParams"}
[:id ::sm/uuid]
[:file-id ::sm/uuid]
[:label ::sm/text]
[:modified-at {:optional true} ::ct/inst]])
(def ^:private check-update-params
(sm/check-fn schema:update-params))
(defn update!
[cfg params]
(let [{:keys [id file-id label modified-at]}
(check-update-params params)
modified-at
(or modified-at (ct/now))]
(db/update! cfg :file-data
{:deleted-at nil
:modified-at modified-at}
{:file-id file-id
:id id
:type "snapshot"}
{::db/return-keys false})
(-> (db/update! cfg :file-change
{:label label
:created-by "user"
:updated-at modified-at
:deleted-at nil}
{:file-id file-id
:id id}
{::db/return-keys false})
(db/get-update-count)
(pos?))))
(defn restore!
[{:keys [::db/conn] :as cfg} file-id snapshot-id]
(let [file (get-minimal-file conn file-id {::db/for-update true})
vern (rand-int Integer/MAX_VALUE)
storage
(sto/resolve cfg {::db/reuse-conn true})
snapshot
(get-snapshot cfg file-id snapshot-id)]
(when-not snapshot
(ex/raise :type :not-found
:code :snapshot-not-found
:hint "unable to find snapshot with the provided label"
:snapshot-id snapshot-id
:file-id file-id))
(when-not (:data snapshot)
(ex/raise :type :internal
:code :snapshot-without-data
:hint "snapshot has no data"
:label (:label snapshot)
:file-id file-id))
(let [;; If the snapshot has applied migrations stored, we reuse
;; them, if not, we take a safest set of migrations as
;; starting point. This is because, at the time of
;; implementing snapshots, migrations were not taken into
;; account so we need to make this backward compatible in
;; some way.
migrations
(or (:migrations snapshot)
(fmg/generate-migrations-from-version 67))
file
(-> file
(update :revn inc)
(assoc :migrations migrations)
(assoc :data (:data snapshot))
(assoc :vern vern)
(assoc :version (:version snapshot))
(assoc :has-media-trimmed false)
(assoc :modified-at (:modified-at snapshot))
(assoc :features (:features snapshot)))]
(l/dbg :hint "restoring snapshot"
:file-id (str file-id)
:label (:label snapshot)
:snapshot-id (str (:id snapshot)))
;; In the same way, on reseting the file data, we need to restore
;; the applied migrations on the moment of taking the snapshot
(bfc/update-file! cfg file ::bfc/reset-migrations? true)
;; FIXME: this should be separated functions, we should not have
;; inline sql here.
;; clean object thumbnails
(let [sql (str "update file_tagged_object_thumbnail "
" set deleted_at = now() "
" where file_id=? returning media_id")
res (db/exec! conn [sql file-id])]
(doseq [media-id (into #{} (keep :media-id) res)]
(sto/touch-object! storage media-id)))
;; clean file thumbnails
(let [sql (str "update file_thumbnail "
" set deleted_at = now() "
" where file_id=? returning media_id")
res (db/exec! conn [sql file-id])]
(doseq [media-id (into #{} (keep :media-id) res)]
(sto/touch-object! storage media-id)))
vern)))
(defn delete!
[cfg & {:keys [id file-id deleted-at]}]
(assert (uuid? id) "missing id")
(assert (uuid? file-id) "missing file-id")
(assert (ct/inst? deleted-at) "missing deleted-at")
(wrk/submit! {::db/conn (db/get-connection cfg)
::wrk/task :delete-object
::wrk/params {:object :snapshot
:deleted-at deleted-at
:file-id file-id
:id id}})
(db/update! cfg :file-change
{:deleted-at deleted-at}
{:id id :file-id file-id}
{::db/return-keys false})
true)
(def ^:private sql:get-snapshots
(str sql:snapshots " AND c.file_id = ?"))
(defn lock-by!
[conn id profile-id]
(-> (db/update! conn :file-change
{:locked-by profile-id}
{:id id}
{::db/return-keys false})
(db/get-update-count)
(pos?)))
(defn unlock!
[conn id]
(-> (db/update! conn :file-change
{:locked-by nil}
{:id id}
{::db/return-keys false})
(db/get-update-count)
(pos?)))
(defn reduce-snapshots
"Process the file snapshots using efficient reduction; the file
reduction comes with all snapshots, including maked as deleted"
[cfg file-id xform f init]
(let [conn (db/get-connection cfg)
xform (comp
(map (partial fdata/resolve-file-data cfg))
(map (partial fdata/decode-file-data cfg))
xform)]
(->> (db/plan conn [sql:get-snapshots file-id] {:fetch-size 1})
(transduce xform f init))))

35
backend/src/app/http.clj
View File

@@ -19,6 +19,7 @@
[app.http.errors :as errors]
[app.http.management :as mgmt]
[app.http.middleware :as mw]
[app.http.security :as sec]
[app.http.session :as session]
[app.http.websocket :as-alias ws]
[app.main :as-alias main]
@@ -26,9 +27,7 @@
[app.rpc :as-alias rpc]
[app.rpc.doc :as-alias rpc.doc]
[app.setup :as-alias setup]
[app.worker :as wrk]
[integrant.core :as ig]
[promesa.exec :as px]
[reitit.core :as r]
[reitit.middleware :as rr]
[yetti.adapter :as yt]
@@ -55,6 +54,8 @@
[:map
[::port ::sm/int]
[::host ::sm/text]
[::io-threads {:optional true} ::sm/int]
[::max-worker-threads {:optional true} ::sm/int]
[::max-body-size {:optional true} ::sm/int]
[::max-multipart-body-size {:optional true} ::sm/int]
[::router {:optional true} [:fn r/router?]]
@@ -65,20 +66,30 @@
(assert (sm/check schema:server-params params)))
(defmethod ig/init-key ::server
[_ {:keys [::handler ::router ::host ::port ::wrk/executor] :as cfg}]
[_ {:keys [::handler ::router ::host ::port ::mtx/metrics] :as cfg}]
(l/info :hint "starting http server" :port port :host host)
(let [options {:http/port port
(let [on-dispatch
(fn [_ start-at-ns]
(let [timing (- (System/nanoTime) start-at-ns)
timing (int (/ timing 1000000))]
(mtx/run! metrics
:id :http-server-dispatch-timing
:val timing)))
options
{:http/port port
:http/host host
:http/max-body-size (::max-body-size cfg)
:http/max-multipart-body-size (::max-multipart-body-size cfg)
:xnio/direct-buffers false
:xnio/io-threads (or (::io-threads cfg)
(max 3 (px/get-available-processors)))
:xnio/dispatch executor
:xnio/io-threads (::io-threads cfg)
:xnio/max-worker-threads (::max-worker-threads cfg)
:ring/compat :ring2
:events/on-dispatch on-dispatch
:socket/backlog 4069}
handler (cond
handler
(cond
(some? router)
(router-handler router)
@@ -88,8 +99,8 @@
:else
(throw (UnsupportedOperationException. "handler or router are required")))
options (d/without-nils options)
server (yt/server handler options)]
server
(yt/server handler (d/without-nils options))]
(assoc cfg ::server (yt/start! server))))
@@ -157,6 +168,7 @@
[_ cfg]
(rr/router
[["" {:middleware [[mw/server-timing]
[sec/sec-fetch-metadata]
[mw/params]
[mw/format-response]
[session/soft-auth cfg]
@@ -177,7 +189,8 @@
(::ws/routes cfg)
["/api" {:middleware [[mw/cors]]}
["/api" {:middleware [[mw/cors]
[sec/client-header-check]]}
(::oidc/routes cfg)
(::rpc.doc/routes cfg)
(::rpc/routes cfg)]]]))

12
backend/src/app/http/access_token.clj
View File

@@ -14,18 +14,18 @@
[app.tokens :as tokens]
[yetti.request :as yreq]))
(def header-re #"^Token\s+(.*)")
(def header-re #"(?i)^Token\s+(.*)")
(defn- get-token
(defn get-token
[request]
(some->> (yreq/get-header request "authorization")
(re-matches header-re)
(second)))
(defn- decode-token
[props token]
[cfg token]
(when token
(tokens/verify props {:token token :iss "access-token"})))
(tokens/verify cfg {:token token :iss "access-token"})))
(def sql:get-token-data
"SELECT perms, profile_id, expires_at
@@ -43,11 +43,11 @@
(defn- wrap-soft-auth
"Soft Authentication, will be executed synchronously on the undertow
worker thread."
[handler {:keys [::setup/props]}]
[handler cfg]
(letfn [(handle-request [request]
(try
(let [token (get-token request)
claims (decode-token props token)]
claims (decode-token cfg token)]
(cond-> request
(map? claims)
(assoc ::id (:tid claims))))

8
backend/src/app/http/awsns.clj
View File

@@ -17,11 +17,9 @@
[app.main :as-alias main]
[app.setup :as-alias setup]
[app.tokens :as tokens]
[app.worker :as-alias wrk]
[clojure.data.json :as j]
[cuerdas.core :as str]
[integrant.core :as ig]
[promesa.exec :as px]
[yetti.request :as yreq]
[yetti.response :as-alias yres]))
@@ -40,8 +38,8 @@
[_ cfg]
(letfn [(handler [request]
(let [data (-> request yreq/body slurp)]
(px/run! :vthread (partial handle-request cfg data)))
{::yres/status 200})]
(handle-request cfg data)
{::yres/status 200}))]
["/sns" {:handler handler
:allowed-methods #{:post}}]))
@@ -109,7 +107,7 @@
[cfg headers]
(let [tdata (get headers "x-penpot-data")]
(when-not (str/empty? tdata)
(let [result (tokens/verify (::setup/props cfg) {:token tdata :iss :profile-identity})]
(let [result (tokens/verify cfg {:token tdata :iss :profile-identity})]
(:profile-id result)))))
(defn- parse-notification

59
backend/src/app/http/debug.clj
View File

@@ -27,6 +27,7 @@
[app.rpc.commands.profile :as profile]
[app.rpc.commands.teams :as teams]
[app.setup :as-alias setup]
[app.setup.clock :as clock]
[app.srepl.main :as srepl]
[app.storage :as-alias sto]
[app.storage.tmp :as tmp]
@@ -49,11 +50,17 @@
(defn index-handler
[_cfg _request]
(let [{:keys [clock offset]} @clock/current]
{::yres/status 200
::yres/headers {"content-type" "text/html"}
::yres/body (-> (io/resource "app/templates/debug.tmpl")
(tmpl/render {:version (:full cf/version)
:supported-features cfeat/supported-features}))})
:current-clock (str clock)
:current-offset (if offset
(ct/format-duration offset)
"NO OFFSET")
:current-time (ct/format-inst (ct/now) :http)
:supported-features cfeat/supported-features}))}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FILE CHANGES
@@ -390,34 +397,6 @@
::yres/headers {"content-type" "text/plain"}
::yres/body (str/ffmt "PROFILE '%' ACTIVATED" (:email profile))}))))))
(defn- reset-file-version
[cfg {:keys [params] :as request}]
(let [file-id (some-> params :file-id d/parse-uuid)
version (some-> params :version d/parse-integer)]
(when-not (contains? params :force)
(ex/raise :type :validation
:code :missing-force
:hint "missing force checkbox"))
(when (nil? file-id)
(ex/raise :type :validation
:code :invalid-file-id
:hint "provided invalid file id"))
(when (nil? version)
(ex/raise :type :validation
:code :invalid-version
:hint "provided invalid version"))
(db/tx-run! cfg srepl/process-file! file-id #(assoc % :version version))
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body "OK"}))
(defn- handle-team-features
[cfg {:keys [params] :as request}]
(let [team-id (some-> params :team-id d/parse-uuid)
@@ -462,6 +441,24 @@
::yres/headers {"content-type" "text/plain"}
::yres/body "OK"}))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; VIRTUAL CLOCK
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- set-virtual-clock
[_ {:keys [params] :as request}]
(let [offset (some-> params :offset str/trim not-empty ct/duration)
reset? (contains? params :reset)]
(if (= "production" (cf/get :tenant))
{::yres/status 501
::yres/body "OPERATION NOT ALLOWED"}
(do
(if (or reset? (zero? (inst-ms offset)))
(clock/set-offset! nil)
(clock/set-offset! offset))
{::yres/status 302
::yres/headers {"location" "/dbg"}}))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OTHER SMALL VIEWS/HANDLERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -548,10 +545,10 @@
["/error/:id" {:handler (partial error-handler cfg)}]
["/error" {:handler (partial error-list-handler cfg)}]
["/actions" {:middleware [[errors]]}
["/set-virtual-clock"
{:handler (partial set-virtual-clock cfg)}]
["/resend-email-verification"
{:handler (partial resend-email-notification cfg)}]
["/reset-file-version"
{:handler (partial reset-file-version cfg)}]
["/handle-team-features"
{:handler (partial handle-team-features cfg)}]
["/file-export" {:handler (partial export-handler cfg)}]

22
backend/src/app/http/management.clj
View File

@@ -11,7 +11,9 @@
[app.common.schema :as sm]
[app.common.schema.generators :as sg]
[app.common.time :as ct]
[app.config :as cf]
[app.db :as db]
[app.http.access-token :refer [get-token]]
[app.main :as-alias main]
[app.rpc.commands.profile :as cmd.profile]
[app.setup :as-alias setup]
@@ -30,6 +32,20 @@
[_ params]
(assert (db/pool? (::db/pool params)) "expect valid database pool"))
(def ^:private auth
{:name ::auth
:compile
(fn [_ _]
(fn [handler shared-key]
(if shared-key
(fn [request]
(let [token (get-token request)]
(if (= token shared-key)
(handler request)
{::yres/status 403})))
(fn [_ _]
{::yres/status 403}))))})
(def ^:private default-system
{:name ::default-system
:compile
@@ -49,7 +65,8 @@
(defmethod ig/init-key ::routes
[_ cfg]
["" {:middleware [[default-system cfg]
["" {:middleware [[auth (cf/get :management-api-shared-key)]
[default-system cfg]
[transaction]]}
["/authenticate"
{:handler authenticate
@@ -79,8 +96,7 @@
(defn- authenticate
[cfg request]
(let [token (-> request :params :token)
props (get cfg ::setup/props)
result (tokens/verify props {:token token :iss "authentication"})]
result (tokens/verify cfg {:token token :iss "authentication"})]
{::yres/status 200
::yres/body result}))

55
backend/src/app/http/security.clj Normal file
View File

@@ -0,0 +1,55 @@
;; 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.http.security
"Additional security layer middlewares"
(:require
[app.config :as cf]
[yetti.request :as yreq]
[yetti.response :as yres]))
(def ^:private safe-methods
#{:get :head :options})
(defn- wrap-sec-fetch-metadata
"Sec-Fetch metadata security layer middleware"
[handler]
(fn [request]
(let [site (yreq/get-header request "sec-fetch-site")]
(cond
(= site "same-origin")
(handler request)
(or (= site "same-site")
(= site "cross-site"))
(if (contains? safe-methods (yreq/method request))
(handler request)
{::yres/status 403})
:else
(handler request)))))
(def sec-fetch-metadata
{:name ::sec-fetch-metadata
:compile (fn [_ _]
(when (contains? cf/flags :sec-fetch-metadata-middleware)
wrap-sec-fetch-metadata))})
(defn- wrap-client-header-check
"Check for a penpot custom header to be present as additional CSRF
protection"
[handler]
(fn [request]
(let [client (yreq/get-header request "x-client")]
(if (some? client)
(handler request)
{::yres/status 403}))))
(def client-header-check
{:name ::client-header-check
:compile (fn [_ _]
(when (contains? cf/flags :client-header-check-middleware)
wrap-client-header-check))})

106
backend/src/app/http/session.clj
View File

@@ -11,7 +11,6 @@
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.uri :as u]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as sql]
@@ -72,7 +71,7 @@
(sm/validator schema:params))
(defn- prepare-session-params
[key params]
[params key]
(assert (string? key) "expected key to be a string")
(assert (not (str/blank? key)) "expected key to be not empty")
(assert (valid-params? params) "expected valid params")
@@ -90,7 +89,9 @@
(db/exec-one! pool (sql/select :http-session {:id token})))
(write! [_ key params]
(let [params (prepare-session-params key params)]
(let [params (-> params
(assoc :created-at (ct/now))
(prepare-session-params key))]
(db/insert! pool :http-session params)
params))
@@ -113,7 +114,9 @@
(get @cache token))
(write! [_ key params]
(let [params (prepare-session-params key params)]
(let [params (-> params
(assoc :created-at (ct/now))
(prepare-session-params key))]
(swap! cache assoc key params)
params))
@@ -144,27 +147,23 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare ^:private assign-auth-token-cookie)
(declare ^:private assign-auth-data-cookie)
(declare ^:private clear-auth-token-cookie)
(declare ^:private clear-auth-data-cookie)
(declare ^:private gen-token)
(defn create-fn
[{:keys [::manager ::setup/props]} profile-id]
[{:keys [::manager] :as cfg} profile-id]
(assert (manager? manager) "expected valid session manager")
(assert (uuid? profile-id) "expected valid uuid for profile-id")
(fn [request response]
(let [uagent (yreq/get-header request "user-agent")
params {:profile-id profile-id
:user-agent uagent
:created-at (ct/now)}
token (gen-token props params)
:user-agent uagent}
token (gen-token cfg params)
session (write! manager token params)]
(l/trace :hint "create" :profile-id (str profile-id))
(l/trc :hint "create" :profile-id (str profile-id))
(-> response
(assign-auth-token-cookie session)
(assign-auth-data-cookie session)))))
(assign-auth-token-cookie session)))))
(defn delete-fn
[{:keys [::manager]}]
@@ -172,23 +171,22 @@
(fn [request response]
(let [cname (cf/get :auth-token-cookie-name default-auth-token-cookie-name)
cookie (yreq/get-cookie request cname)]
(l/trace :hint "delete" :profile-id (:profile-id request))
(l/trc :hint "delete" :profile-id (:profile-id request))
(some->> (:value cookie) (delete! manager))
(-> response
(assoc :status 204)
(assoc :body nil)
(clear-auth-token-cookie)
(clear-auth-data-cookie)))))
(clear-auth-token-cookie)))))
(defn- gen-token
[props {:keys [profile-id created-at]}]
(tokens/generate props {:iss "authentication"
[cfg {:keys [profile-id created-at]}]
(tokens/generate cfg {:iss "authentication"
:iat created-at
:uid profile-id}))
(defn- decode-token
[props token]
[cfg token]
(when token
(tokens/verify props {:token token :iss "authentication"})))
(tokens/verify cfg {:token token :iss "authentication"})))
(defn- get-token
[request]
@@ -208,18 +206,18 @@
(neg? (compare default-renewal-max-age elapsed)))))
(defn- wrap-soft-auth
[handler {:keys [::manager ::setup/props]}]
[handler {:keys [::manager] :as cfg}]
(assert (manager? manager) "expected valid session manager")
(letfn [(handle-request [request]
(try
(let [token (get-token request)
claims (decode-token props token)]
claims (decode-token cfg token)]
(cond-> request
(map? claims)
(-> (assoc ::token-claims claims)
(assoc ::token token))))
(catch Throwable cause
(l/trace :hint "exception on decoding malformed token" :cause cause)
(l/trc :hint "exception on decoding malformed token" :cause cause)
request)))]
(fn [request]
@@ -239,8 +237,7 @@
(if (renew-session? session)
(let [session (update! manager session)]
(-> response
(assign-auth-token-cookie session)
(assign-auth-data-cookie session)))
(assign-auth-token-cookie session)))
response))))
(def soft-auth
@@ -256,7 +253,7 @@
(defn- assign-auth-token-cookie
[response {token :id updated-at :updated-at}]
(let [max-age (cf/get :auth-token-cookie-max-age default-cookie-max-age)
created-at (or updated-at (ct/now))
created-at updated-at
renewal (ct/plus created-at default-renewal-max-age)
expires (ct/plus created-at max-age)
secure? (contains? cf/flags :secure-session-cookies)
@@ -273,53 +270,15 @@
:secure secure?}]
(update response :cookies assoc name cookie)))
(defn- assign-auth-data-cookie
[response {profile-id :profile-id updated-at :updated-at}]
(let [max-age (cf/get :auth-token-cookie-max-age default-cookie-max-age)
domain (cf/get :auth-data-cookie-domain)
cname default-auth-data-cookie-name
created-at (or updated-at (ct/now))
renewal (ct/plus created-at default-renewal-max-age)
expires (ct/plus created-at max-age)
comment (str "Renewal at: " (ct/format-inst renewal :rfc1123))
secure? (contains? cf/flags :secure-session-cookies)
strict? (contains? cf/flags :strict-session-cookies)
cors? (contains? cf/flags :cors)
cookie {:domain domain
:expires expires
:path "/"
:comment comment
:value (u/map->query-string {:profile-id profile-id})
:same-site (if cors? :none (if strict? :strict :lax))
:secure secure?}]
(cond-> response
(string? domain)
(update :cookies assoc cname cookie))))
(defn- clear-auth-token-cookie
[response]
(let [cname (cf/get :auth-token-cookie-name default-auth-token-cookie-name)]
(update response :cookies assoc cname {:path "/" :value "" :max-age 0})))
(defn- clear-auth-data-cookie
[response]
(let [cname default-auth-data-cookie-name
domain (cf/get :auth-data-cookie-domain)]
(cond-> response
(string? domain)
(update :cookies assoc cname {:domain domain :path "/" :value "" :max-age 0}))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TASK: SESSION GC
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FIXME: MOVE
(defmethod ig/assert-key ::tasks/gc
[_ params]
(assert (db/pool? (::db/pool params)) "expected valid database pool")
@@ -332,22 +291,23 @@
(def ^:private
sql:delete-expired
"delete from http_session
where updated_at < now() - ?::interval
"DELETE FROM http_session
WHERE updated_at < ?::timestamptz
or (updated_at is null and
created_at < now() - ?::interval)")
created_at < ?::timestamptz)")
(defn- collect-expired-tasks
[{:keys [::db/conn ::tasks/max-age]}]
(let [interval (db/interval max-age)
result (db/exec-one! conn [sql:delete-expired interval interval])
result (:next.jdbc/update-count result)]
(l/debug :task "gc"
(let [threshold (ct/minus (ct/now) max-age)
result (-> (db/exec-one! conn [sql:delete-expired threshold threshold])
(db/get-update-count))]
(l/dbg :task "gc"
:hint "clean http sessions"
:deleted result)
result))
(defmethod ig/init-key ::tasks/gc
[_ {:keys [::tasks/max-age] :as cfg}]
(l/debug :hint "initializing session gc task" :max-age max-age)
(fn [_] (db/tx-run! cfg collect-expired-tasks)))
(l/dbg :hint "initializing session gc task" :max-age max-age)
(fn [_]
(db/tx-run! cfg collect-expired-tasks)))

2
backend/src/app/http/sse.clj
View File

@@ -55,7 +55,7 @@
::yres/body (yres/stream-body
(fn [_ output]
(let [channel (sp/chan :buf buf :xf (keep encode))
listener (events/start-listener
listener (events/spawn-listener
channel
(partial write! output)
(partial pu/close! output))]

4
backend/src/app/loggers/audit/archive_task.clj
View File

@@ -9,7 +9,6 @@
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.transit :as t]
[app.common.uuid :as uuid]
[app.config :as cf]
@@ -53,9 +52,8 @@
(defn- send!
[{:keys [::uri] :as cfg} events]
(let [token (tokens/generate (::setup/props cfg)
(let [token (tokens/generate cfg
{:iss "authentication"
:iat (ct/now)
:uid uuid/zero})
body (t/encode {:events events})
headers {"content-type" "application/transit+json"

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

@@ -42,6 +42,7 @@
[app.svgo :as-alias svgo]
[app.util.cron]
[app.worker :as-alias wrk]
[app.worker.executor]
[clojure.test :as test]
[clojure.tools.namespace.repl :as repl]
[cuerdas.core :as str]
@@ -148,23 +149,11 @@
::mdef/labels []
::mdef/type :histogram}
:executors-active-threads
{::mdef/name "penpot_executors_active_threads"
::mdef/help "Current number of threads available in the executor service."
::mdef/labels ["name"]
::mdef/type :gauge}
:executors-completed-tasks
{::mdef/name "penpot_executors_completed_tasks_total"
::mdef/help "Approximate number of completed tasks by the executor."
::mdef/labels ["name"]
::mdef/type :counter}
:executors-running-threads
{::mdef/name "penpot_executors_running_threads"
::mdef/help "Current number of threads with state RUNNING."
::mdef/labels ["name"]
::mdef/type :gauge}})
:http-server-dispatch-timing
{::mdef/name "penpot_http_server_dispatch_timing"
::mdef/help "Histogram of dispatch handler"
::mdef/labels []
::mdef/type :histogram}})
(def system-config
{::db/pool
@@ -176,14 +165,12 @@
::db/max-size (cf/get :database-max-pool-size 60)
::mtx/metrics (ig/ref ::mtx/metrics)}
;; Default thread pool for IO operations
::wrk/executor
{}
;; Default netty IO pool (shared between several services)
::wrk/netty-io-executor
{:threads (cf/get :netty-io-threads)}
::wrk/monitor
{::mtx/metrics (ig/ref ::mtx/metrics)
::wrk/executor (ig/ref ::wrk/executor)
::wrk/name "default"}
::wrk/netty-executor
{:threads (cf/get :executor-threads)}
:app.migrations/migrations
{::db/pool (ig/ref ::db/pool)}
@@ -194,17 +181,27 @@
::mtx/routes
{::mtx/metrics (ig/ref ::mtx/metrics)}
::rds/redis
{::rds/uri (cf/get :redis-uri)
::mtx/metrics (ig/ref ::mtx/metrics)
::wrk/executor (ig/ref ::wrk/executor)}
::rds/client
{::rds/uri
(cf/get :redis-uri)
::wrk/netty-executor
(ig/ref ::wrk/netty-executor)
::wrk/netty-io-executor
(ig/ref ::wrk/netty-io-executor)}
::rds/pool
{::rds/client (ig/ref ::rds/client)
::mtx/metrics (ig/ref ::mtx/metrics)}
::mbus/msgbus
{::wrk/executor (ig/ref ::wrk/executor)
::rds/redis (ig/ref ::rds/redis)}
{::wrk/executor (ig/ref ::wrk/netty-executor)
::rds/client (ig/ref ::rds/client)
::mtx/metrics (ig/ref ::mtx/metrics)}
:app.storage.tmp/cleaner
{::wrk/executor (ig/ref ::wrk/executor)}
{::wrk/executor (ig/ref ::wrk/netty-executor)}
::sto.gc-deleted/handler
{::db/pool (ig/ref ::db/pool)
@@ -232,9 +229,10 @@
::http/host (cf/get :http-server-host)
::http/router (ig/ref ::http/router)
::http/io-threads (cf/get :http-server-io-threads)
::http/max-worker-threads (cf/get :http-server-max-worker-threads)
::http/max-body-size (cf/get :http-server-max-body-size)
::http/max-multipart-body-size (cf/get :http-server-max-multipart-body-size)
::wrk/executor (ig/ref ::wrk/executor)}
::mtx/metrics (ig/ref ::mtx/metrics)}
::ldap/provider
{:host (cf/get :ldap-host)
@@ -312,23 +310,24 @@
::rpc/climit
{::mtx/metrics (ig/ref ::mtx/metrics)
::wrk/executor (ig/ref ::wrk/executor)
::wrk/executor (ig/ref ::wrk/netty-executor)
::climit/config (cf/get :rpc-climit-config)
::climit/enabled (contains? cf/flags :rpc-climit)}
:app.rpc/rlimit
{::wrk/executor (ig/ref ::wrk/executor)}
{::wrk/executor (ig/ref ::wrk/netty-executor)}
:app.rpc/methods
{::http.client/client (ig/ref ::http.client/client)
::db/pool (ig/ref ::db/pool)
::wrk/executor (ig/ref ::wrk/executor)
::rds/pool (ig/ref ::rds/pool)
::wrk/executor (ig/ref ::wrk/netty-executor)
::session/manager (ig/ref ::session/manager)
::ldap/provider (ig/ref ::ldap/provider)
::sto/storage (ig/ref ::sto/storage)
::mtx/metrics (ig/ref ::mtx/metrics)
::mbus/msgbus (ig/ref ::mbus/msgbus)
::rds/redis (ig/ref ::rds/redis)
::rds/client (ig/ref ::rds/client)
::rpc/climit (ig/ref ::rpc/climit)
::rpc/rlimit (ig/ref ::rpc/rlimit)
@@ -341,7 +340,7 @@
:app.rpc.doc/routes
{:app.rpc/methods (ig/ref :app.rpc/methods)}
:app.rpc/routes
::rpc/routes
{::rpc/methods (ig/ref :app.rpc/methods)
::db/pool (ig/ref ::db/pool)
::session/manager (ig/ref ::session/manager)
@@ -433,6 +432,9 @@
;; module requires the migrations to run before initialize.
::migrations (ig/ref :app.migrations/migrations)}
::setup/clock
{}
:app.loggers.audit.archive-task/handler
{::setup/props (ig/ref ::setup/props)
::db/pool (ig/ref ::db/pool)
@@ -476,13 +478,14 @@
(cf/get :objects-storage-s3-bucket))
::sto.s3/io-threads (or (cf/get :storage-assets-s3-io-threads)
(cf/get :objects-storage-s3-io-threads))
::wrk/executor (ig/ref ::wrk/executor)}
::wrk/netty-io-executor
(ig/ref ::wrk/netty-io-executor)}
:app.storage.fs/backend
{::sto.fs/directory (or (cf/get :storage-assets-fs-directory)
(cf/get :objects-storage-fs-directory))}})
(def worker-config
{::wrk/cron
{::wrk/registry (ig/ref ::wrk/registry)
@@ -518,7 +521,7 @@
:task :audit-log-gc})]}
::wrk/dispatcher
{::rds/redis (ig/ref ::rds/redis)
{::rds/client (ig/ref ::rds/client)
::mtx/metrics (ig/ref ::mtx/metrics)
::db/pool (ig/ref ::db/pool)
::wrk/tenant (cf/get :tenant)}
@@ -527,7 +530,7 @@
{::wrk/parallelism (cf/get ::worker-default-parallelism 1)
::wrk/queue :default
::wrk/tenant (cf/get :tenant)
::rds/redis (ig/ref ::rds/redis)
::rds/client (ig/ref ::rds/client)
::wrk/registry (ig/ref ::wrk/registry)
::mtx/metrics (ig/ref ::mtx/metrics)
::db/pool (ig/ref ::db/pool)}
@@ -536,7 +539,7 @@
{::wrk/parallelism (cf/get ::worker-webhook-parallelism 1)
::wrk/queue :webhooks
::wrk/tenant (cf/get :tenant)
::rds/redis (ig/ref ::rds/redis)
::rds/client (ig/ref ::rds/client)
::wrk/registry (ig/ref ::wrk/registry)
::mtx/metrics (ig/ref ::mtx/metrics)
::db/pool (ig/ref ::db/pool)}})

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

@@ -447,7 +447,10 @@
:fn (mg/resource "app/migrations/sql/0140-add-locked-by-column-to-file-change-table.sql")}
{:name "0141-add-idx-to-file-library-rel"
:fn (mg/resource "app/migrations/sql/0141-add-idx-to-file-library-rel.sql")}])
:fn (mg/resource "app/migrations/sql/0141-add-idx-to-file-library-rel.sql")}
{:name "0141-add-file-data-table.sql"
:fn (mg/resource "app/migrations/sql/0141-add-file-data-table.sql")}])
(defn apply-migrations!
[pool name migrations]

25
backend/src/app/migrations/media_refs.clj
View File

@@ -10,8 +10,8 @@
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.pprint]
[app.srepl.fixes.media-refs :refer [process-file]]
[app.srepl.main :as srepl]
[app.srepl.procs.media-refs]
[clojure.edn :as edn]))
(def ^:private required-services
@@ -20,7 +20,10 @@
:app.storage/storage
:app.metrics/metrics
:app.db/pool
:app.worker/executor])
:app.worker/netty-io-executor])
(def default-options
{:rollback? false})
(defn -main
[& [options]]
@@ -28,22 +31,20 @@
(let [config-var (requiring-resolve 'app.main/system-config)
start-var (requiring-resolve 'app.main/start-custom)
stop-var (requiring-resolve 'app.main/stop)
config (select-keys @config-var required-services)]
config (select-keys @config-var required-services)
options (if (string? options)
(ex/ignoring (edn/read-string options))
{})
options (-> (merge default-options options)
(assoc :proc-fn #'app.srepl.procs.media-refs/fix-media-refs))]
(start-var config)
(let [options (if (string? options)
(ex/ignoring (edn/read-string options))
{})]
(l/inf :hint "executing media-refs migration" :options options)
(srepl/process-files! process-file options))
(srepl/process! options)
(stop-var)
(System/exit 0))
(catch Throwable cause
(ex/print-throwable cause)
(flush)
(System/exit -1))))

38
backend/src/app/migrations/sql/0141-add-file-data-table.sql Normal file
View File

@@ -0,0 +1,38 @@
CREATE TABLE file_data (
file_id uuid NOT NULL REFERENCES file(id) DEFERRABLE,
id uuid NOT NULL,
created_at timestamptz NOT NULL DEFAULT now(),
modified_at timestamptz NOT NULL DEFAULT now(),
deleted_at timestamptz NULL,
type text NOT NULL,
backend text NULL,
metadata jsonb NULL,
data bytea NULL,
PRIMARY KEY (file_id, id)
) PARTITION BY HASH (file_id);
CREATE TABLE file_data_00 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 0);
CREATE TABLE file_data_01 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 1);
CREATE TABLE file_data_02 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 2);
CREATE TABLE file_data_03 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 3);
CREATE TABLE file_data_04 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 4);
CREATE TABLE file_data_05 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 5);
CREATE TABLE file_data_06 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 6);
CREATE TABLE file_data_07 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 7);
CREATE TABLE file_data_08 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 8);
CREATE TABLE file_data_09 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 9);
CREATE TABLE file_data_10 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 10);
CREATE TABLE file_data_11 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 11);
CREATE TABLE file_data_12 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 12);
CREATE TABLE file_data_13 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 13);
CREATE TABLE file_data_14 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 14);
CREATE TABLE file_data_15 PARTITION OF file_data FOR VALUES WITH (MODULUS 16, REMAINDER 15);
CREATE INDEX file_data__deleted_at__idx
ON file_data (deleted_at, file_id, id)
WHERE deleted_at IS NOT NULL;

24
backend/src/app/msgbus.clj
View File

@@ -16,7 +16,6 @@
[app.redis :as rds]
[app.worker :as wrk]
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px]
[promesa.exec.csp :as sp]))
@@ -59,14 +58,16 @@
(assoc ::timeout (ct/duration {:seconds 30})))})
(def ^:private schema:params
[:map ::rds/redis ::wrk/executor])
[:map
::rds/client
::wrk/executor])
(defmethod ig/assert-key ::msgbus
[_ params]
(assert (sm/check schema:params params)))
(defmethod ig/init-key ::msgbus
[_ {:keys [::buffer-size ::wrk/executor ::timeout ::rds/redis] :as cfg}]
[_ {:keys [::buffer-size ::wrk/executor ::timeout] :as cfg}]
(l/info :hint "initialize msgbus" :buffer-size buffer-size)
(let [cmd-ch (sp/chan :buf buffer-size)
rcv-ch (sp/chan :buf (sp/dropping-buffer buffer-size))
@@ -74,8 +75,9 @@
:xf xform-prefix-topic)
state (agent {})
pconn (rds/connect redis :type :default :timeout timeout)
sconn (rds/connect redis :type :pubsub :timeout timeout)
;; Open persistent connections to redis
pconn (rds/connect cfg :timeout timeout)
sconn (rds/connect-pubsub cfg :timeout timeout)
_ (set-error-handler! state #(l/error :cause % :hint "unexpected error on agent" ::l/sync? true))
_ (set-error-mode! state :continue)
@@ -189,14 +191,13 @@
(defn- create-listener
[rcv-ch]
(rds/pubsub-listener
:on-message (fn [_ topic message]
{:on-message (fn [_ topic message]
;; There are no back pressure, so we use a slidding
;; buffer for cases when the pubsub broker sends
;; more messages that we can process.
(let [val {:topic topic :message (t/decode message)}]
(let [val {:topic topic :message (t/decode-str message)}]
(when-not (sp/offer! rcv-ch val)
(l/warn :msg "dropping message on subscription loop"))))))
(l/warn :msg "dropping message on subscription loop"))))})
(defn- process-input
[{:keys [::state ::wrk/executor] :as cfg} topic message]
@@ -216,8 +217,7 @@
(rds/add-listener sconn (create-listener rcv-ch))
(px/thread
{:name "penpot/msgbus/io-loop"
:virtual true}
{:name "penpot/msgbus"}
(try
(loop []
(let [timeout-ch (sp/timeout-chan 1000)
@@ -263,7 +263,7 @@
intended to be used in core.async go blocks."
[{:keys [::pconn] :as cfg} {:keys [topic message]}]
(try
(p/await! (rds/publish pconn topic (t/encode message)))
(rds/publish pconn topic (t/encode-str message))
(catch InterruptedException cause
(throw cause))
(catch Throwable cause

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

@@ -6,23 +6,22 @@
(ns app.redis
"The msgbus abstraction implemented using redis as underlying backend."
(:refer-clojure :exclude [eval])
(:refer-clojure :exclude [eval get set run!])
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.generic-pool :as gpool]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.metrics :as mtx]
[app.redis.script :as-alias rscript]
[app.util.cache :as cache]
[app.worker :as-alias wrk]
[app.worker :as wrk]
[app.worker.executor]
[clojure.core :as c]
[clojure.java.io :as io]
[cuerdas.core :as str]
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px])
[integrant.core :as ig])
(:import
clojure.lang.MapEntry
io.lettuce.core.KeyValue
@@ -32,12 +31,10 @@
io.lettuce.core.RedisException
io.lettuce.core.RedisURI
io.lettuce.core.ScriptOutputType
io.lettuce.core.api.StatefulConnection
io.lettuce.core.SetArgs
io.lettuce.core.api.StatefulRedisConnection
io.lettuce.core.api.async.RedisAsyncCommands
io.lettuce.core.api.async.RedisScriptingAsyncCommands
io.lettuce.core.api.sync.RedisCommands
io.lettuce.core.codec.ByteArrayCodec
io.lettuce.core.api.sync.RedisScriptingCommands
io.lettuce.core.codec.RedisCodec
io.lettuce.core.codec.StringCodec
io.lettuce.core.pubsub.RedisPubSubListener
@@ -45,220 +42,158 @@
io.lettuce.core.pubsub.api.sync.RedisPubSubCommands
io.lettuce.core.resource.ClientResources
io.lettuce.core.resource.DefaultClientResources
io.netty.channel.nio.NioEventLoopGroup
io.netty.util.HashedWheelTimer
io.netty.util.Timer
io.netty.util.concurrent.EventExecutorGroup
java.lang.AutoCloseable
java.time.Duration))
(set! *warn-on-reflection* true)
(declare ^:private initialize-resources)
(declare ^:private shutdown-resources)
(declare ^:private impl-eval)
(def ^:const MAX-EVAL-RETRIES 18)
(defprotocol IRedis
(-connect [_ options])
(-get-or-connect [_ key options]))
(def default-timeout
(ct/duration "10s"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; IMPL & PRIVATE API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defprotocol IConnection
(publish [_ topic message])
(rpush [_ key payload])
(blpop [_ timeout keys])
(eval [_ script]))
(-set-timeout [_ timeout] "set connection timeout")
(-get-timeout [_] "get current timeout")
(-reset-timeout [_] "reset to default timeout"))
(defprotocol IDefaultConnection
"Public API of default redis connection"
(-publish [_ topic message])
(-rpush [_ key payload])
(-blpop [_ timeout keys])
(-eval [_ script])
(-get [_ key])
(-set [_ key val args])
(-del [_ key-or-keys])
(-ping [_]))
(defprotocol IPubSubConnection
(add-listener [_ listener])
(subscribe [_ topics])
(unsubscribe [_ topics]))
(-add-listener [_ listener])
(-subscribe [_ topics])
(-unsubscribe [_ topics]))
(def default-codec
(RedisCodec/of StringCodec/UTF8 ByteArrayCodec/INSTANCE))
(def string-codec
(def ^:private default-codec
(RedisCodec/of StringCodec/UTF8 StringCodec/UTF8))
(sm/register!
{:type ::connection
:pred #(satisfies? IConnection %)
:type-properties
{:title "connection"
:description "redis connection instance"}})
(defn- impl-eval
[cmd cache metrics script]
(let [keys (into-array String (map str (::rscript/keys script)))
vals (into-array String (map str (::rscript/vals script)))
sname (::rscript/name script)
(sm/register!
{:type ::pubsub-connection
:pred #(satisfies? IPubSubConnection %)
:type-properties
{:title "connection"
:description "redis connection instance"}})
read-script
(fn []
(-> script ::rscript/path io/resource slurp))
(defn redis?
[o]
(satisfies? IRedis o))
load-script
(fn []
(let [id (.scriptLoad ^RedisScriptingCommands cmd
^String (read-script))]
(swap! cache assoc sname id)
(l/trc :hint "load script" :name sname :id id)
(sm/register!
{:type ::redis
:pred redis?})
id))
(def ^:private schema:script
[:map {:title "script"}
[::rscript/name qualified-keyword?]
[::rscript/path ::sm/text]
[::rscript/keys {:optional true} [:vector :any]]
[::rscript/vals {:optional true} [:vector :any]]])
(def valid-script?
(sm/lazy-validator schema:script))
(defmethod ig/expand-key ::redis
[k v]
(let [cpus (px/get-available-processors)
threads (max 1 (int (* cpus 0.2)))]
{k (-> (d/without-nils v)
(assoc ::timeout (ct/duration "10s"))
(assoc ::io-threads (max 3 threads))
(assoc ::worker-threads (max 3 threads)))}))
(def ^:private schema:redis-params
[:map {:title "redis-params"}
::wrk/executor
::mtx/metrics
[::uri ::sm/uri]
[::worker-threads ::sm/int]
[::io-threads ::sm/int]
[::timeout ::ct/duration]])
(defmethod ig/assert-key ::redis
[_ params]
(assert (sm/check schema:redis-params params)))
(defmethod ig/init-key ::redis
[_ params]
(initialize-resources params))
(defmethod ig/halt-key! ::redis
[_ instance]
(d/close! instance))
(defn- initialize-resources
"Initialize redis connection resources"
[{:keys [::uri ::io-threads ::worker-threads ::wrk/executor ::mtx/metrics] :as params}]
(l/inf :hint "initialize redis resources"
:uri (str uri)
:io-threads io-threads
:worker-threads worker-threads)
(let [timer (HashedWheelTimer.)
resources (.. (DefaultClientResources/builder)
(ioThreadPoolSize ^long io-threads)
(computationThreadPoolSize ^long worker-threads)
(timer ^Timer timer)
(build))
redis-uri (RedisURI/create ^String (str uri))
shutdown (fn [client conn]
(ex/ignoring (.close ^StatefulConnection conn))
(ex/ignoring (.close ^RedisClient client))
(l/trc :hint "disconnect" :hid (hash client)))
on-remove (fn [key val cause]
(l/trace :hint "evict connection (cache)" :key key :reason cause)
(some-> val d/close!))
cache (cache/create :executor executor
:on-remove on-remove
:keepalive "5m")]
(reify
java.lang.AutoCloseable
(close [_]
(ex/ignoring (cache/invalidate! cache))
(ex/ignoring (.shutdown ^ClientResources resources))
(ex/ignoring (.stop ^Timer timer)))
IRedis
(-get-or-connect [this key options]
(let [create (fn [_] (-connect this options))]
(cache/get cache key create)))
(-connect [_ options]
(let [timeout (or (:timeout options) (::timeout params))
codec (get options :codec default-codec)
type (get options :type :default)
client (RedisClient/create ^ClientResources resources
^RedisURI redis-uri)]
(l/trc :hint "connect" :hid (hash client))
(if (= type :pubsub)
(let [conn (.connectPubSub ^RedisClient client
^RedisCodec codec)]
(.setTimeout ^StatefulConnection conn
^Duration timeout)
(reify
IPubSubConnection
(add-listener [_ listener]
(assert (instance? RedisPubSubListener listener) "expected listener instance")
(.addListener ^StatefulRedisPubSubConnection conn
^RedisPubSubListener listener))
(subscribe [_ topics]
eval-script
(fn [id]
(try
(let [topics (into-array String (map str topics))
cmd (.sync ^StatefulRedisPubSubConnection conn)]
(.subscribe ^RedisPubSubCommands cmd topics))
(catch RedisCommandInterruptedException cause
(throw (InterruptedException. (ex-message cause))))))
(let [tpoint (ct/tpoint)
result (.evalsha ^RedisScriptingCommands cmd
^String id
^ScriptOutputType ScriptOutputType/MULTI
^"[Ljava.lang.String;" keys
^"[Ljava.lang.String;" vals)
elapsed (tpoint)]
(unsubscribe [_ topics]
(try
(let [topics (into-array String (map str topics))
cmd (.sync ^StatefulRedisPubSubConnection conn)]
(.unsubscribe ^RedisPubSubCommands cmd topics))
(catch RedisCommandInterruptedException cause
(throw (InterruptedException. (ex-message cause))))))
(mtx/run! metrics {:id :redis-eval-timing
:labels [(name sname)]
:val (inst-ms elapsed)})
(l/trc :hint "eval script"
:name (name sname)
:id id
:params (str/join "," (::rscript/vals script))
:elapsed (ct/format-duration elapsed))
result)
(catch io.lettuce.core.RedisNoScriptException _cause
::load)
(catch Throwable cause
(when-let [on-error (::rscript/on-error script)]
(on-error cause))
(throw cause))))
eval-script'
(fn [id]
(loop [id id
retries 0]
(if (> retries MAX-EVAL-RETRIES)
(ex/raise :type :internal
:code ::max-eval-retries-reached
:hint (str "unable to eval redis script " sname))
(let [result (eval-script id)]
(if (= result ::load)
(recur (load-script)
(inc retries))
result)))))]
(if-let [id (c/get @cache sname)]
(eval-script' id)
(-> (load-script)
(eval-script')))))
(deftype Connection [^StatefulRedisConnection conn
^RedisCommands cmd
^Duration timeout
cache metrics]
AutoCloseable
(close [_] (shutdown client conn))))
(close [_]
(ex/ignoring (.close conn)))
(let [conn (.connect ^RedisClient client ^RedisCodec codec)]
(.setTimeout ^StatefulConnection conn ^Duration timeout)
(reify
IConnection
(publish [_ topic message]
(assert (string? topic) "expected topic to be string")
(assert (bytes? message) "expected message to be a byte array")
(-set-timeout [_ timeout]
(.setTimeout conn ^Duration timeout))
(let [pcomm (.async ^StatefulRedisConnection conn)]
(.publish ^RedisAsyncCommands pcomm ^String topic ^bytes message)))
(-reset-timeout [_]
(.setTimeout conn timeout))
(rpush [_ key payload]
(assert (or (and (vector? payload)
(every? bytes? payload))
(bytes? payload)))
(-get-timeout [_]
(.getTimeout conn))
IDefaultConnection
(-publish [_ topic message]
(.publish cmd ^String topic ^String message))
(-rpush [_ key elements]
(try
(let [cmd (.sync ^StatefulRedisConnection conn)
data (if (vector? payload) payload [payload])
vals (make-array (. Class (forName "[B")) (count data))]
(loop [i 0 xs (seq data)]
(let [vals (make-array String (count elements))]
(loop [i 0 xs (seq elements)]
(when xs
(aset ^"[[B" vals i ^bytes (first xs))
(aset ^"[[Ljava.lang.String;" vals i ^String (first xs))
(recur (inc i) (next xs))))
(.rpush ^RedisCommands cmd
(.rpush cmd
^String key
^"[[B" vals))
^"[[Ljava.lang.String;" vals))
(catch RedisCommandInterruptedException cause
(throw (InterruptedException. (ex-message cause))))))
(blpop [_ timeout keys]
(-blpop [_ keys timeout]
(try
(let [keys (into-array Object (map str keys))
cmd (.sync ^StatefulRedisConnection conn)
timeout (/ (double (inst-ms timeout)) 1000.0)]
(when-let [res (.blpop ^RedisCommands cmd
(let [keys (into-array String keys)]
(when-let [res (.blpop cmd
^double timeout
^"[Ljava.lang.String;" keys)]
(MapEntry/create
@@ -267,22 +202,78 @@
(catch RedisCommandInterruptedException cause
(throw (InterruptedException. (ex-message cause))))))
(eval [_ script]
(assert (valid-script? script) "expected valid script")
(impl-eval conn metrics script))
(-get [_ key]
(assert (string? key) "key expected to be string")
(.get cmd ^String key))
(-set [_ key val args]
(.set cmd
^String key
^bytes val
^SetArgs args))
(-del [_ keys]
(let [keys (into-array String keys)]
(.del cmd ^String/1 keys)))
(-ping [_]
(.ping cmd))
(-eval [_ script]
(impl-eval cmd cache metrics script)))
(deftype SubscriptionConnection [^StatefulRedisPubSubConnection conn
^RedisPubSubCommands cmd
^Duration timeout]
AutoCloseable
(close [_] (shutdown client conn))))))))))
(close [_]
(ex/ignoring (.close conn)))
(defn connect
[instance & {:as opts}]
(assert (satisfies? IRedis instance) "expected valid redis instance")
(-connect instance opts))
IConnection
(-set-timeout [_ timeout]
(.setTimeout conn ^Duration timeout))
(defn get-or-connect
[instance key & {:as opts}]
(assert (satisfies? IRedis instance) "expected valid redis instance")
(-get-or-connect instance key opts))
(-reset-timeout [_]
(.setTimeout conn timeout))
(-get-timeout [_]
(.getTimeout conn))
IPubSubConnection
(-add-listener [_ listener]
(.addListener conn ^RedisPubSubListener listener))
(-subscribe [_ topics]
(try
(let [topics (into-array String topics)]
(.subscribe cmd topics))
(catch RedisCommandInterruptedException cause
(throw (InterruptedException. (ex-message cause))))))
(-unsubscribe [_ topics]
(try
(let [topics (into-array String topics)]
(.unsubscribe cmd topics))
(catch RedisCommandInterruptedException cause
(throw (InterruptedException. (ex-message cause)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn build-set-args
[options]
(reduce-kv (fn [^SetArgs args k v]
(case k
:ex (if (instance? Duration v)
(.ex args ^Duration v)
(.ex args (long v)))
:px (.px args (long v))
:nx (if v (.nx args) args)
:keep-ttl (if v (.keepttl args) args)))
(SetArgs.)
options))
(defn pubsub-listener
[& {:keys [on-message on-subscribe on-unsubscribe]}]
@@ -311,61 +302,172 @@
(when on-unsubscribe
(on-unsubscribe nil topic count)))))
(def ^:private scripts-cache (atom {}))
(defn connect
[cfg & {:as options}]
(assert (contains? cfg ::mtx/metrics) "missing ::mtx/metrics on provided system")
(assert (contains? cfg ::client) "missing ::rds/client on provided system")
(defn- impl-eval
[^StatefulRedisConnection connection metrics script]
(let [cmd (.async ^StatefulRedisConnection connection)
keys (into-array String (map str (::rscript/keys script)))
vals (into-array String (map str (::rscript/vals script)))
sname (::rscript/name script)]
(let [state (::client cfg)
(letfn [(on-error [cause]
(if (instance? io.lettuce.core.RedisNoScriptException cause)
(do
(l/error :hint "no script found" :name sname :cause cause)
(->> (load-script)
(p/mcat eval-script)))
(if-let [on-error (::rscript/on-error script)]
(on-error cause)
(p/rejected cause))))
cache (::cache state)
client (::client state)
timeout (or (some-> (:timeout options) ct/duration)
(::timeout state))
(eval-script [sha]
(let [tpoint (ct/tpoint)]
(->> (.evalsha ^RedisScriptingAsyncCommands cmd
^String sha
^ScriptOutputType ScriptOutputType/MULTI
^"[Ljava.lang.String;" keys
^"[Ljava.lang.String;" vals)
(p/fmap (fn [result]
(let [elapsed (tpoint)]
(mtx/run! metrics {:id :redis-eval-timing
:labels [(name sname)]
:val (inst-ms elapsed)})
(l/trace :hint "eval script"
:name (name sname)
:sha sha
:params (str/join "," (::rscript/vals script))
:elapsed (ct/format-duration elapsed))
result)))
(p/merr on-error))))
conn (.connect ^RedisClient client
^RedisCodec default-codec)
cmd (.sync ^StatefulRedisConnection conn)]
(read-script []
(-> script ::rscript/path io/resource slurp))
(.setTimeout ^StatefulRedisConnection conn ^Duration timeout)
(->Connection conn cmd timeout cache (::mtx/metrics cfg))))
(load-script []
(l/trace :hint "load script" :name sname)
(->> (.scriptLoad ^RedisScriptingAsyncCommands cmd
^String (read-script))
(p/fmap (fn [sha]
(swap! scripts-cache assoc sname sha)
sha))))]
(defn connect-pubsub
[cfg & {:as options}]
(let [state (::client cfg)
client (::client state)
(p/await!
(if-let [sha (get @scripts-cache sname)]
(eval-script sha)
(->> (load-script)
(p/mapcat eval-script)))))))
timeout (or (some-> (:timeout options) ct/duration)
(::timeout state))
conn (.connectPubSub ^RedisClient client
^RedisCodec default-codec)
cmd (.sync ^StatefulRedisPubSubConnection conn)]
(.setTimeout ^StatefulRedisPubSubConnection conn
^Duration timeout)
(->SubscriptionConnection conn cmd timeout)))
(defn get
[conn key]
(assert (string? key) "key must be string instance")
(try
(-get conn key)
(catch RedisCommandTimeoutException cause
(l/err :hint "timeout on get redis key" :key key :cause cause)
nil)))
(defn set
([conn key val]
(set conn key val nil))
([conn key val args]
(assert (string? key) "key must be string instance")
(assert (string? val) "val must be string instance")
(let [args (cond
(or (instance? SetArgs args)
(nil? args))
args
(map? args)
(build-set-args args)
:else
(throw (IllegalArgumentException. "invalid args")))]
(try
(-set conn key val args)
(catch RedisCommandTimeoutException cause
(l/err :hint "timeout on set redis key" :key key :cause cause)
nil)))))
(defn del
[conn key-or-keys]
(let [keys (if (vector? key-or-keys) key-or-keys [key-or-keys])]
(assert (every? string? keys) "only string keys allowed")
(try
(-del conn keys)
(catch RedisCommandTimeoutException cause
(l/err :hint "timeout on del redis key" :key key :cause cause)
nil))))
(defn ping
[conn]
(-ping conn))
(defn blpop
[conn key-or-keys timeout]
(let [keys (if (vector? key-or-keys) key-or-keys [key-or-keys])
timeout (cond
(ct/duration? timeout)
(/ (double (inst-ms timeout)) 1000.0)
(double? timeout)
timeout
(int? timeout)
(/ (double timeout) 1000.0)
:else
0)]
(assert (every? string? keys) "only string keys allowed")
(-blpop conn keys timeout)))
(defn rpush
[conn key elements]
(assert (string? key) "key must be string instance")
(assert (every? string? elements) "elements should be all strings")
(let [elements (vec elements)]
(-rpush conn key elements)))
(defn publish
[conn topic payload]
(assert (string? topic) "expected topic to be string")
(assert (string? payload) "expected message to be a byte array")
(-publish conn topic payload))
(def ^:private schema:script
[:map {:title "script"}
[::rscript/name qualified-keyword?]
[::rscript/path ::sm/text]
[::rscript/keys {:optional true} [:vector :any]]
[::rscript/vals {:optional true} [:vector :any]]])
(def ^:private valid-script?
(sm/lazy-validator schema:script))
(defn eval
[conn script]
(assert (valid-script? script) "expected valid script")
(-eval conn script))
(defn add-listener
[conn listener]
(let [listener (cond
(map? listener)
(pubsub-listener listener)
(instance? RedisPubSubListener listener)
listener
:else
(throw (IllegalArgumentException. "invalid listener provided")))]
(-add-listener conn listener)))
(defn subscribe
[conn topic-or-topics]
(let [topics (if (vector? topic-or-topics) topic-or-topics [topic-or-topics])]
(assert (every? string? topics))
(-subscribe conn topics)))
(defn unsubscribe
[conn topic-or-topics]
(let [topics (if (vector? topic-or-topics) topic-or-topics [topic-or-topics])]
(assert (every? string? topics))
(-unsubscribe conn topics)))
(defn set-timeout
[conn timeout]
(let [timeout (ct/duration timeout)]
(-set-timeout conn timeout)))
(defn get-timeout
[conn]
(-get-timeout conn))
(defn reset-timeout
[conn]
(-reset-timeout conn))
(defn timeout-exception?
[cause]
@@ -374,3 +476,121 @@
(defn exception?
[cause]
(instance? RedisException cause))
(defn get-pooled
[cfg]
(let [pool (::pool cfg)]
(gpool/get pool)))
(defn close
[o]
(.close ^AutoCloseable o))
(defn pool
[cfg & {:as options}]
(gpool/create :create-fn (partial connect cfg options)
:destroy-fn close
:dispose-fn -reset-timeout))
(defn run!
[cfg f & args]
(if (gpool/pool? cfg)
(apply f {::pool cfg} f args)
(let [pool (::pool cfg)]
(with-open [^AutoCloseable conn (gpool/get pool)]
(apply f (assoc cfg ::conn @conn) args)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INITIALIZATION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/expand-key ::client
[k v]
{k (-> (d/without-nils v)
(assoc ::timeout (ct/duration "10s")))})
(def ^:private schema:client
[:map {:title "RedisClient"}
[::timer [:fn #(instance? HashedWheelTimer %)]]
[::cache ::sm/atom]
[::timeout ::ct/duration]
[::resources [:fn #(instance? DefaultClientResources %)]]])
(def check-client
(sm/check-fn schema:client))
(sm/register! ::client schema:client)
(sm/register!
{:type ::pool
:pred gpool/pool?})
(def ^:private schema:client-params
[:map {:title "redis-params"}
::wrk/netty-io-executor
::wrk/netty-executor
[::uri ::sm/uri]
[::timeout ::ct/duration]])
(def ^:private check-client-params
(sm/check-fn schema:client-params))
(defmethod ig/assert-key ::client
[_ params]
(check-client-params params))
(defmethod ig/init-key ::client
[_ {:keys [::uri ::wrk/netty-io-executor ::wrk/netty-executor] :as params}]
(l/inf :hint "initialize redis client" :uri (str uri))
(let [timer (HashedWheelTimer.)
cache (atom {})
resources (.. (DefaultClientResources/builder)
(eventExecutorGroup ^EventExecutorGroup netty-executor)
;; We provide lettuce with a shared event loop
;; group instance instead of letting lettuce to
;; create its own
(eventLoopGroupProvider
(reify io.lettuce.core.resource.EventLoopGroupProvider
(allocate [_ _] netty-io-executor)
(threadPoolSize [_]
(.executorCount ^NioEventLoopGroup netty-io-executor))
(release [_ _ _ _ _]
;; Do nothing
)
(shutdown [_ _ _ _]
;; Do nothing
)))
(timer ^Timer timer)
(build))
redis-uri (RedisURI/create ^String (str uri))
client (RedisClient/create ^ClientResources resources
^RedisURI redis-uri)]
{::client client
::cache cache
::timer timer
::timeout default-timeout
::resources resources}))
(defmethod ig/halt-key! ::client
[_ {:keys [::client ::timer ::resources]}]
(ex/ignoring (.shutdown ^RedisClient client))
(ex/ignoring (.shutdown ^ClientResources resources))
(ex/ignoring (.stop ^Timer timer)))
(defmethod ig/assert-key ::pool
[_ {:keys [::client]}]
(check-client client))
(defmethod ig/init-key ::pool
[_ cfg]
(pool cfg {:timeout (ct/duration 2000)}))
(defmethod ig/halt-key! ::pool
[_ instance]
(.close ^java.lang.AutoCloseable instance))

3
backend/src/app/rpc.clj
View File

@@ -23,6 +23,7 @@
[app.main :as-alias main]
[app.metrics :as mtx]
[app.msgbus :as-alias mbus]
[app.redis :as rds]
[app.rpc.climit :as climit]
[app.rpc.cond :as cond]
[app.rpc.helpers :as rph]
@@ -239,7 +240,6 @@
'app.rpc.commands.files
'app.rpc.commands.files-create
'app.rpc.commands.files-share
'app.rpc.commands.files-temp
'app.rpc.commands.files-update
'app.rpc.commands.files-snapshot
'app.rpc.commands.files-thumbnails
@@ -262,6 +262,7 @@
::session/manager
::http.client/client
::db/pool
::rds/pool
::mbus/msgbus
::sto/storage
::mtx/metrics

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

@@ -21,7 +21,6 @@
[clojure.set :as set]
[datoteka.fs :as fs]
[integrant.core :as ig]
[promesa.exec :as px]
[promesa.exec.bulkhead :as pbh])
(:import
clojure.lang.ExceptionInfo
@@ -289,13 +288,9 @@
(get-limits cfg)))
(defn invoke!
"Run a function in context of climit.
Intended to be used in virtual threads."
[{:keys [::executor ::rpc/climit] :as cfg} f params]
"Run a function in context of climit."
[{:keys [::rpc/climit] :as cfg} f params]
(let [f (if climit
(let [f (if (some? executor)
(fn [cfg params] (px/await! (px/submit! executor (fn [] (f cfg params)))))
f)]
(build-exec-chain cfg f))
(build-exec-chain cfg f)
f)]
(f cfg params)))

14
backend/src/app/rpc/commands/access_token.clj
View File

@@ -23,14 +23,14 @@
(dissoc row :perms))
(defn create-access-token
[{:keys [::db/conn ::setup/props]} profile-id name expiration]
(let [created-at (ct/now)
token-id (uuid/next)
token (tokens/generate props {:iss "access-token"
:tid token-id
:iat created-at})
[{:keys [::db/conn] :as cfg} profile-id name expiration]
(let [token-id (uuid/next)
expires-at (some-> expiration (ct/in-future))
created-at (ct/now)
token (tokens/generate cfg {:iss "access-token"
:iat created-at
:tid token-id})
expires-at (some-> expiration ct/in-future)
token (db/insert! conn :access-token
{:id token-id
:name name

29
backend/src/app/rpc/commands/auth.clj
View File

@@ -6,6 +6,7 @@
(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]
@@ -62,7 +63,7 @@
(ex/raise :type :validation
:code :account-without-password
:hint "the current account does not have password")
(let [result (profile/verify-password cfg password (:password profile))]
(let [result (auth/verify-password password (:password profile))]
(when (:update result)
(l/trc :hint "updating profile password"
:id (str (:id profile))
@@ -98,7 +99,7 @@
(profile/strip-private-attrs))
invitation (when-let [token (:invitation-token params)]
(tokens/verify (::setup/props cfg) {:token token :iss :team-invitation}))
(tokens/verify cfg {:token token :iss :team-invitation}))
;; If invitation member-id does not matches the profile-id, we just proceed to ignore the
;; invitation because invitations matches exactly; and user can't login with other email and
@@ -152,11 +153,11 @@
(defn recover-profile
[{:keys [::db/conn] :as cfg} {:keys [token password]}]
(letfn [(validate-token [token]
(let [tdata (tokens/verify (::setup/props cfg) {:token token :iss :password-recovery})]
(let [tdata (tokens/verify cfg {:token token :iss :password-recovery})]
(:profile-id tdata)))
(update-password [conn profile-id]
(let [pwd (profile/derive-password cfg password)]
(let [pwd (auth/derive-password password)]
(db/update! conn :profile {:password pwd :is-active true} {:id profile-id})
nil))]
@@ -191,7 +192,7 @@
:hint "registration disabled"))
(when (contains? params :invitation-token)
(let [invitation (tokens/verify (::setup/props cfg)
(let [invitation (tokens/verify cfg
{:token (:invitation-token params)
:iss :team-invitation})]
(when-not (= (:email params) (:member-email invitation))
@@ -248,7 +249,7 @@
:props {:newsletter-updates (or accept-newsletter-updates false)}}
params (d/without-nils params)
token (tokens/generate (::setup/props cfg) params)]
token (tokens/generate cfg params)]
(with-meta {:token token}
{::audit/profile-id uuid/zero})))
@@ -342,14 +343,14 @@
(defn send-email-verification!
[{:keys [::db/conn] :as cfg} profile]
(let [vtoken (tokens/generate (::setup/props cfg)
(let [vtoken (tokens/generate cfg
{:iss :verify-email
:exp (ct/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 (::setup/props cfg)
ptoken (tokens/generate cfg
{:iss :profile-identity
:profile-id (:id profile)
:exp (ct/in-future {:days 30})})]
@@ -363,7 +364,7 @@
(defn register-profile
[{:keys [::db/conn ::wrk/executor] :as cfg} {:keys [token] :as params}]
(let [claims (tokens/verify (::setup/props cfg) {:token token :iss :prepared-register})
(let [claims (tokens/verify cfg {:token token :iss :prepared-register})
params (into claims params)
profile (if-let [profile-id (:profile-id claims)]
@@ -378,7 +379,7 @@
(not (contains? cf/flags :email-verification)))
params (-> params
(assoc :is-active is-active)
(update :password #(profile/derive-password cfg %)))
(update :password auth/derive-password))
profile (->> (create-profile! conn params)
(create-profile-rels! conn))]
(vary-meta profile assoc :created true))))
@@ -386,7 +387,7 @@
created? (-> profile meta :created true?)
invitation (when-let [token (:invitation-token params)]
(tokens/verify (::setup/props cfg) {:token token :iss :team-invitation}))
(tokens/verify cfg {:token token :iss :team-invitation}))
props (-> (audit/profile->props profile)
(assoc :from-invitation (some? invitation)))
@@ -419,7 +420,7 @@
(= (:email profile)
(:member-email invitation)))
(let [claims (assoc invitation :member-id (:id profile))
token (tokens/generate (::setup/props cfg) claims)]
token (tokens/generate cfg claims)]
(-> {:invitation-token token}
(rph/with-transform (session/create-fn cfg (:id profile)))
(rph/with-meta {::audit/replace-props props
@@ -493,14 +494,14 @@
(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)
(let [token (tokens/generate cfg
{:iss :password-recovery
:exp (ct/in-future "15m")
:profile-id id})]
(assoc profile :token token)))
(send-email-notification [conn profile]
(let [ptoken (tokens/generate (::setup/props cfg)
(let [ptoken (tokens/generate cfg
{:iss :profile-identity
:profile-id (:id profile)
:exp (ct/in-future {:days 30})})]

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

@@ -28,7 +28,6 @@
[app.tasks.file-gc]
[app.util.services :as sv]
[app.worker :as-alias wrk]
[promesa.exec :as px]
[yetti.response :as yres]))
(set! *warn-on-reflection* true)
@@ -94,7 +93,7 @@
;; --- Command: import-binfile
(defn- import-binfile
[{:keys [::db/pool ::wrk/executor] :as cfg} {:keys [profile-id project-id version name file]}]
[{:keys [::db/pool] :as cfg} {:keys [profile-id project-id version name file]}]
(let [team (teams/get-team pool
:profile-id profile-id
:project-id project-id)
@@ -105,13 +104,9 @@
(assoc ::bfc/name name)
(assoc ::bfc/input (:path file)))
;; 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.
result (case (int version)
1 (px/invoke! executor (partial bf.v1/import-files! cfg))
3 (px/invoke! executor (partial bf.v3/import-files! cfg)))]
1 (bf.v1/import-files! cfg)
3 (bf.v3/import-files! cfg))]
(db/update! pool :project
{:modified-at (ct/now)}

107
backend/src/app/rpc/commands/comments.clj
View File

@@ -6,6 +6,7 @@
(ns app.rpc.commands.comments
(:require
[app.binfile.common :as bfc]
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
@@ -163,34 +164,16 @@
(def xf-decode-row
(map decode-row))
(def ^:private
sql:get-file
"SELECT f.id, f.modified_at, f.revn, f.features, f.name,
f.project_id, p.team_id, f.data,
f.data_ref_id, f.data_backend
FROM file as f
INNER JOIN project as p on (p.id = f.project_id)
WHERE f.id = ?
AND (f.deleted_at IS NULL OR f.deleted_at > now())")
(defn- get-file
"A specialized version of get-file for comments module."
[cfg file-id page-id]
(let [file (db/exec-one! cfg [sql:get-file file-id])]
(when-not file
(ex/raise :type :not-found
:code :object-not-found
:hint "file not found"))
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg file-id)]
(let [file (->> file
(files/decode-row)
(feat.fdata/resolve-file-data cfg))
(let [file (bfc/get-file cfg file-id)
data (get file :data)]
(-> file
(assoc :page-name (dm/get-in data [:pages-index page-id :name]))
(assoc :page-id page-id)
(dissoc :data))))))
(dissoc :data)))))
;; FIXME: rename
(defn- get-comment-thread
@@ -251,7 +234,9 @@
(files/check-comment-permissions! conn profile-id file-id share-id)
(get-comment-threads conn profile-id file-id))))
(def ^:private sql:comment-threads
(defn- get-comment-threads-sql
[where]
(str/ffmt
"SELECT DISTINCT ON (ct.id)
ct.*,
pf.fullname AS owner_fullname,
@@ -274,11 +259,14 @@
INNER JOIN project AS p ON (p.id = f.project_id)
LEFT JOIN comment_thread_status AS cts ON (cts.thread_id = ct.id AND cts.profile_id = ?)
LEFT JOIN profile AS pf ON (ct.owner_id = pf.id)
WINDOW w AS (PARTITION BY c.thread_id ORDER BY c.created_at ASC)")
WHERE f.deleted_at IS NULL
AND p.deleted_at IS NULL
%1
WINDOW w AS (PARTITION BY c.thread_id ORDER BY c.created_at ASC)"
where))
(def ^:private sql:comment-threads-by-file-id
(str "WITH threads AS (" sql:comment-threads ")"
"SELECT * FROM threads WHERE file_id = ?"))
(get-comment-threads-sql "AND ct.file_id = ?"))
(defn- get-comment-threads
[conn profile-id file-id]
@@ -287,7 +275,30 @@
;; --- COMMAND: Get Unread Comment Threads
(declare ^:private get-unread-comment-threads)
(def ^:private sql:unread-all-comment-threads-by-team
(str "WITH threads AS ("
(get-comment-threads-sql "AND p.team_id = ?")
")"
"SELECT t.* FROM threads AS t
WHERE t.count_unread_comments > 0"))
(def ^:private sql:unread-partial-comment-threads-by-team
(str "WITH threads AS ("
(get-comment-threads-sql "AND p.team_id = ? AND (ct.owner_id = ? OR ? = ANY(ct.mentions))")
")"
"SELECT t.* FROM threads AS t
WHERE t.count_unread_comments > 0"))
(defn- get-unread-comment-threads
[cfg profile-id team-id]
(let [profile (-> (db/get cfg :profile {:id profile-id} ::db/remove-deleted false)
(profile/decode-row))
notify (or (-> profile :props :notifications :dashboard-comments) :all)
result (case notify
:all (db/exec! cfg [sql:unread-all-comment-threads-by-team profile-id team-id])
:partial (db/exec! cfg [sql:unread-partial-comment-threads-by-team profile-id team-id profile-id profile-id])
[])]
(into [] xf-decode-row result)))
(def ^:private
schema:get-unread-comment-threads
@@ -298,41 +309,8 @@
{::doc/added "1.15"
::sm/params schema:get-unread-comment-threads}
[cfg {:keys [::rpc/profile-id team-id] :as params}]
(db/run!
cfg
(fn [{:keys [::db/conn]}]
(teams/check-read-permissions! conn profile-id team-id)
(get-unread-comment-threads conn profile-id team-id))))
(def sql:unread-all-comment-threads-by-team
(str "WITH threads AS (" sql:comment-threads ")"
"SELECT * FROM threads WHERE count_unread_comments > 0 AND team_id = ?"))
;; The partial configuration will retrieve only comments created by the user and
;; threads that have a mention to the user.
(def sql:unread-partial-comment-threads-by-team
(str "WITH threads AS (" sql:comment-threads ")"
"SELECT * FROM threads
WHERE count_unread_comments > 0
AND team_id = ?
AND (owner_id = ? OR ? = ANY(mentions))"))
(defn- get-unread-comment-threads
[conn profile-id team-id]
(let [profile (-> (db/get conn :profile {:id profile-id})
(profile/decode-row))
notify (or (-> profile :props :notifications :dashboard-comments) :all)]
(case notify
:all
(->> (db/exec! conn [sql:unread-all-comment-threads-by-team profile-id team-id])
(into [] xf-decode-row))
:partial
(->> (db/exec! conn [sql:unread-partial-comment-threads-by-team profile-id team-id profile-id profile-id])
(into [] xf-decode-row))
[])))
(teams/check-read-permissions! cfg profile-id team-id)
(get-unread-comment-threads cfg profile-id team-id))
;; --- COMMAND: Get Single Comment Thread
@@ -343,16 +321,17 @@
[:id ::sm/uuid]
[:share-id {:optional true} [:maybe ::sm/uuid]]])
(def ^:private sql:get-comment-thread
(get-comment-threads-sql "AND ct.file_id = ? AND ct.id = ?"))
(sv/defmethod ::get-comment-thread
{::doc/added "1.15"
::sm/params schema:get-comment-thread}
[cfg {:keys [::rpc/profile-id file-id id share-id] :as params}]
(db/run! cfg (fn [{:keys [::db/conn]}]
(files/check-comment-permissions! conn profile-id file-id share-id)
(let [sql (str "WITH threads AS (" sql:comment-threads ")"
"SELECT * FROM threads WHERE id = ? AND file_id = ?")]
(-> (db/exec-one! conn [sql profile-id id file-id])
(decode-row))))))
(some-> (db/exec-one! conn [sql:get-comment-thread profile-id file-id id])
(decode-row)))))
;; --- COMMAND: Retrieve Comments

5
backend/src/app/rpc/commands/demo.clj
View File

@@ -7,6 +7,7 @@
(ns app.rpc.commands.demo
"A demo specific mutations."
(:require
[app.auth :refer [derive-password]]
[app.common.exceptions :as ex]
[app.common.time :as ct]
[app.config :as cf]
@@ -14,7 +15,6 @@
[app.loggers.audit :as audit]
[app.rpc :as-alias rpc]
[app.rpc.commands.auth :as auth]
[app.rpc.commands.profile :as profile]
[app.rpc.doc :as-alias doc]
[app.util.services :as sv]
[buddy.core.codecs :as bc]
@@ -45,8 +45,9 @@
params {:email email
:fullname fullname
:is-active true
:is-demo true
:deleted-at (ct/in-future (cf/get-deletion-delay))
:password (profile/derive-password cfg password)
:password (derive-password password)
:props {}}
profile (db/tx-run! cfg (fn [{:keys [::db/conn]}]
(->> (auth/create-profile! conn params)

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

@@ -17,6 +17,7 @@
[app.common.schema :as sm]
[app.common.schema.desc-js-like :as-alias smdj]
[app.common.time :as ct]
[app.common.transit :as t]
[app.common.types.components-list :as ctkl]
[app.common.types.file :as ctf]
[app.common.uri :as uri]
@@ -24,10 +25,11 @@
[app.db :as db]
[app.db.sql :as-alias sql]
[app.features.fdata :as feat.fdata]
[app.features.file-migrations :as feat.fmigr]
[app.features.logical-deletion :as ldel]
[app.loggers.audit :as-alias audit]
[app.loggers.webhooks :as-alias webhooks]
[app.msgbus :as mbus]
[app.redis :as rds]
[app.rpc :as-alias rpc]
[app.rpc.commands.projects :as projects]
[app.rpc.commands.teams :as teams]
@@ -39,8 +41,7 @@
[app.util.pointer-map :as pmap]
[app.util.services :as sv]
[app.worker :as wrk]
[cuerdas.core :as str]
[promesa.exec :as px]))
[cuerdas.core :as str]))
;; --- FEATURES
@@ -55,12 +56,10 @@
(ct/duration {:days 7}))
(defn decode-row
[{:keys [data changes features] :as row}]
[{:keys [features] :as row}]
(when row
(cond-> row
features (assoc :features (db/decode-pgarray features #{}))
changes (assoc :changes (blob/decode changes))
data (assoc :data (blob/decode data)))))
(db/pgarray? features) (assoc :features (db/decode-pgarray features #{})))))
(defn check-version!
[file]
@@ -84,8 +83,10 @@
fpr.is_admin,
fpr.can_edit
from file_profile_rel as fpr
inner join file as f on (f.id = fpr.file_id)
where fpr.file_id = ?
and fpr.profile_id = ?
and f.deleted_at is null
union all
select tpr.is_owner,
tpr.is_admin,
@@ -95,6 +96,7 @@
inner join file as f on (p.id = f.project_id)
where f.id = ?
and tpr.profile_id = ?
and f.deleted_at is null
union all
select ppr.is_owner,
ppr.is_admin,
@@ -102,7 +104,8 @@
from project_profile_rel as ppr
inner join file as f on (f.project_id = ppr.project_id)
where f.id = ?
and ppr.profile_id = ?")
and ppr.profile_id = ?
and f.deleted_at is null")
(defn get-file-permissions
[conn profile-id file-id]
@@ -207,93 +210,11 @@
schema:get-file
[:map {:title "get-file"}
[:features {:optional true} ::cfeat/features]
[:id ::sm/uuid]
[:project-id {:optional true} ::sm/uuid]])
(defn- migrate-file
[{:keys [::db/conn] :as cfg} {:keys [id] :as file} {:keys [read-only?]}]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)
pmap/*tracked* (pmap/create-tracked)]
(let [libs (delay (bfc/get-resolved-file-libraries cfg file))
;; For avoid unnecesary overhead of creating multiple pointers and
;; handly internally with objects map in their worst case (when
;; probably all shapes and all pointers will be readed in any
;; case), we just realize/resolve them before applying the
;; migration to the file
file (-> file
(update :data feat.fdata/process-pointers deref)
(update :data feat.fdata/process-objects (partial into {}))
(fmg/migrate-file libs))]
(if (or read-only? (db/read-only? conn))
file
(let [;; When file is migrated, we break the rule of no perform
;; mutations on get operations and update the file with all
;; migrations applied
file (if (contains? (:features file) "fdata/objects-map")
(feat.fdata/enable-objects-map file)
file)
file (if (contains? (:features file) "fdata/pointer-map")
(feat.fdata/enable-pointer-map file)
file)]
(db/update! conn :file
{:data (blob/encode (:data file))
:version (:version file)
:features (db/create-array conn "text" (:features file))}
{:id id}
{::db/return-keys false})
(when (contains? (:features file) "fdata/pointer-map")
(feat.fdata/persist-pointers! cfg id))
(feat.fmigr/upsert-migrations! conn file)
(feat.fmigr/resolve-applied-migrations cfg file))))))
(defn get-file
[{:keys [::db/conn ::wrk/executor] :as cfg} id
& {:keys [project-id
migrate?
include-deleted?
lock-for-update?
preload-pointers?]
:or {include-deleted? false
lock-for-update? false
migrate? true
preload-pointers? false}
:as options}]
(assert (db/connection? conn) "expected cfg with valid connection")
(let [params (merge {:id id}
(when (some? project-id)
{:project-id project-id}))
file (->> (db/get conn :file params
{::db/check-deleted (not include-deleted?)
::db/remove-deleted (not include-deleted?)
::sql/for-update lock-for-update?})
(feat.fmigr/resolve-applied-migrations cfg)
(feat.fdata/resolve-file-data cfg))
;; NOTE: we perform the file decoding in a separate thread
;; because it has heavy and synchronous operations for
;; decoding file body that are not very friendly with virtual
;; threads.
file (px/invoke! executor #(decode-row file))
file (if (and migrate? (fmg/need-migration? file))
(migrate-file cfg file options)
file)]
(if preload-pointers?
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)]
(update file :data feat.fdata/process-pointers deref))
file)))
[:id ::sm/uuid]])
(defn get-minimal-file
[cfg id & {:as opts}]
(let [opts (assoc opts ::sql/columns [:id :modified-at :deleted-at :revn :vern :data-ref-id :data-backend])]
(let [opts (assoc opts ::sql/columns [:id :modified-at :deleted-at :revn :vern])]
(db/get cfg :file {:id id} opts)))
(defn- get-minimal-file-with-perms
@@ -333,9 +254,9 @@
:project-id project-id
:file-id id)
file (-> (get-file cfg id :project-id project-id)
file (-> (bfc/get-file cfg id
:project-id project-id)
(assoc :permissions perms)
(assoc :team-id (:id team))
(check-version!))]
(-> (cfeat/get-team-enabled-features cf/flags team)
@@ -349,8 +270,7 @@
;; return a complete file
(if (and (contains? (:features file) "fdata/pointer-map")
(not (contains? (:features params) "fdata/pointer-map")))
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)]
(update file :data feat.fdata/process-pointers deref))
(feat.fdata/realize-pointers cfg file)
file)
;; This operation is needed for backward comapatibility with
@@ -358,7 +278,7 @@
;; just converts all objects map instaces to plain maps
(if (and (contains? (:features file) "fdata/objects-map")
(not (contains? (:features params) "fdata/objects-map")))
(update file :data feat.fdata/process-objects (partial into {}))
(feat.fdata/realize-objects cfg file)
file)))))
;; --- COMMAND QUERY: get-file-fragment (by id)
@@ -378,10 +298,8 @@
(defn- get-file-fragment
[cfg file-id fragment-id]
(let [resolve-file-data (partial feat.fdata/resolve-file-data cfg)]
(some-> (db/get cfg :file-data-fragment {:file-id file-id :id fragment-id})
(resolve-file-data)
(update :data blob/decode))))
(some-> (db/get cfg :file-data {:file-id file-id :id fragment-id :type "fragment"})
(update :data blob/decode)))
(sv/defmethod ::get-file-fragment
"Retrieve a file fragment by its ID. Only authenticated users."
@@ -540,7 +458,7 @@
(let [perms (get-permissions conn profile-id file-id share-id)
file (get-file cfg file-id :read-only? true)
file (bfc/get-file cfg file-id :read-only? true)
proj (db/get conn :project {:id (:project-id file)})
@@ -596,87 +514,136 @@
;; --- COMMAND QUERY: get-team-shared-files
(defn- components-and-variants
"Return a set with all the variant-ids, and a list of components, but with
only one component by variant"
[components]
(let [{:keys [variant-ids components]}
(reduce (fn [{:keys [variant-ids components] :as acc} {:keys [variant-id] :as component}]
(defn- get-components-with-variants
"Return a set with all the variant-ids, and a list of components, but
with only one component by variant.
Returns a vector of unique components and a set of all variant ids"
[fdata]
(loop [variant-ids #{}
components' []
components (ctkl/components-seq fdata)]
(if-let [{:keys [variant-id] :as component} (first components)]
(cond
(nil? variant-id)
{:variant-ids variant-ids :components (conj components component)}
(recur variant-ids
(conj components' component)
(rest components))
(contains? variant-ids variant-id)
acc
(recur variant-ids
components'
(rest components))
:else
{:variant-ids (conj variant-ids variant-id) :components (conj components component)}))
{:variant-ids #{} :components []}
components)]
{:components components
:variant-ids variant-ids}))
(recur (conj variant-ids variant-id)
(conj components' component)
(rest components)))
[(d/index-by :id components') variant-ids])))
(defn- sample-assets
[assets limit]
(let [assets (into [] (map val) assets)]
{:count (count assets)
:sample (->> assets
(sort-by #(str/lower (:name %)))
(into [] (take limit)))}))
(defn- calculate-library-summary
"Calculate the file library summary (counters and samples)"
[{:keys [data] :as file}]
(let [load-objects
(fn [sample]
(mapv #(ctf/load-component-objects data %) sample))
[components variant-ids]
(get-components-with-variants data)
components-sample
(-> (sample-assets components 4)
(update :sample load-objects))]
{:components components-sample
:variants {:count (count variant-ids)}
:colors (sample-assets (:colors data) 3)
:typographies (sample-assets (:typographies data) 3)}))
(def ^:private file-summary-cache-key-ttl
(ct/duration {:days 30}))
(def file-summary-cache-key-prefix
"penpot.library-summary.")
(defn- get-file-with-summary
"Get a file without data with a summary of its local library content"
[cfg id]
(let [get-from-cache
(fn [{:keys [::rds/conn]} cache-key]
(when-let [result (rds/get conn cache-key)]
(let [file (bfc/get-file cfg id :load-data? false)
summary (t/decode-str result)]
(-> (assoc file :library-summary summary)
(dissoc :data)))))
calculate-from-db
(fn []
(let [file (bfc/get-file cfg id)
result (binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)]
(calculate-library-summary file))]
(-> file
(assoc :library-summary result)
(dissoc :legacy-data)
(dissoc :data))))
persist-to-cache
(fn [{:keys [::rds/conn]} data cache-key]
(rds/set conn cache-key (t/encode-str data)
(rds/build-set-args {:ex file-summary-cache-key-ttl})))]
(if (contains? cf/flags :redis-cache)
(let [cache-key (str file-summary-cache-key-prefix id)]
(or (rds/run! cfg get-from-cache cache-key)
(let [file (calculate-from-db)]
(rds/run! cfg persist-to-cache (:library-summary file) cache-key)
file)))
(calculate-from-db))))
(def ^:private sql:team-shared-files
"select f.id,
f.revn,
f.vern,
f.data,
f.project_id,
f.created_at,
f.modified_at,
f.data_backend,
f.data_ref_id,
f.name,
f.version,
f.is_shared,
ft.media_id,
p.team_id
from file as f
inner join project as p on (p.id = f.project_id)
left join file_thumbnail as ft on (ft.file_id = f.id and ft.revn = f.revn and ft.deleted_at is null)
where f.is_shared = true
and f.deleted_at is null
and p.deleted_at is null
and p.team_id = ?
order by f.modified_at desc")
"WITH file_library_agg AS (
SELECT flr.file_id,
coalesce(array_agg(flr.library_file_id) filter (WHERE flr.library_file_id IS NOT NULL), '{}') AS library_file_ids
FROM file_library_rel flr
GROUP BY flr.file_id
)
(defn- get-library-summary
[cfg {:keys [id data] :as file}]
(letfn [(assets-sample [assets limit]
(let [sorted-assets (->> (vals assets)
(sort-by #(str/lower (:name %))))]
{:count (count sorted-assets)
:sample (into [] (take limit sorted-assets))}))]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)]
(let [load-objects (fn [component]
(ctf/load-component-objects data component))
comps-and-variants (components-and-variants (ctkl/components-seq data))
components (into {} (map (juxt :id identity) (:components comps-and-variants)))
components-sample (-> (assets-sample components 4)
(update :sample #(mapv load-objects %))
(assoc :variants-count (-> comps-and-variants :variant-ids count)))]
{:components components-sample
:media (assets-sample (:media data) 3)
:colors (assets-sample (:colors data) 3)
:typographies (assets-sample (:typographies data) 3)}))))
SELECT f.id,
fla.library_file_ids,
ft.media_id AS thumbnail_id
FROM file AS f
INNER JOIN project AS p ON (p.id = f.project_id)
LEFT JOIN file_thumbnail AS ft ON (ft.file_id = f.id AND ft.revn = f.revn AND ft.deleted_at IS NULL)
LEFT JOIN file_library_agg AS fla ON (fla.file_id = f.id)
WHERE f.is_shared = true
AND f.deleted_at IS NULL
AND p.deleted_at IS NULL
AND p.team_id = ?
ORDER BY f.modified_at DESC")
(defn- get-team-shared-files
[{:keys [::db/conn] :as cfg} {:keys [team-id profile-id]}]
(teams/check-read-permissions! conn profile-id team-id)
(->> (db/exec! conn [sql:team-shared-files team-id])
(into #{} (comp
;; NOTE: this decode operation is a workaround for a
;; fast fix, this should be approached with a more
;; efficient implementation, for now it loads all
;; the files in memory.
(map (partial bfc/decode-file cfg))
(map (fn [row]
(if-let [media-id (:media-id row)]
(-> row
(dissoc :media-id)
(assoc :thumbnail-id media-id))
(dissoc row :media-id))))
(map #(assoc % :library-summary (get-library-summary cfg %)))
(map #(dissoc % :data))))))
(let [process-row
(fn [{:keys [id library-file-ids]}]
(let [file (get-file-with-summary cfg id)]
(assoc file :library-file-ids (db/decode-pgarray library-file-ids #{}))))
xform
(map process-row)]
(->> (db/plan conn [sql:team-shared-files team-id] {:fetch-size 1})
(transduce xform conj #{}))))
(def ^:private schema:get-team-shared-files
[:map {:title "get-team-shared-files"}
@@ -689,6 +656,28 @@
[cfg {:keys [::rpc/profile-id] :as params}]
(db/tx-run! cfg get-team-shared-files (assoc params :profile-id profile-id)))
;; --- COMMAND QUERY: get-file-summary
(defn- get-file-summary
[cfg id]
(let [file (get-file-with-summary cfg id)]
(-> (:library-summary file)
(assoc :name (:name file)))))
(def ^:private
schema:get-file-summary
[:map {:title "get-file-summary"}
[:id ::sm/uuid]])
(sv/defmethod ::get-file-summary
"Retrieve a file summary by its ID. Only authenticated users."
{::doc/added "1.20"
::sm/params schema:get-file-summary}
[cfg {:keys [::rpc/profile-id id] :as params}]
(check-read-permissions! cfg profile-id id)
(get-file-summary cfg id))
;; --- COMMAND QUERY: get-file-libraries
(def ^:private schema:get-file-libraries
@@ -707,7 +696,6 @@
;; --- COMMAND QUERY: Files that use this File library
(def ^:private sql:library-using-files
"SELECT f.id,
f.name
@@ -777,51 +765,14 @@
(teams/check-read-permissions! conn profile-id team-id)
(get-team-recent-files conn team-id)))
;; --- COMMAND QUERY: get-file-summary
(defn- get-file-summary
[{:keys [::db/conn] :as cfg} {:keys [profile-id id project-id] :as params}]
(check-read-permissions! conn profile-id id)
(let [team (teams/get-team conn
:profile-id profile-id
:project-id project-id
:file-id id)
file (get-file cfg id
:project-id project-id
:read-only? true)]
(-> (cfeat/get-team-enabled-features cf/flags team)
(cfeat/check-client-features! (:features params))
(cfeat/check-file-features! (:features file)))
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)]
(let [components-and-variants (components-and-variants (ctkl/components-seq (:data file)))]
{:name (:name file)
:components-count (-> components-and-variants :components count)
:variants-count (-> components-and-variants :variant-ids count)
:graphics-count (count (get-in file [:data :media] []))
:colors-count (count (get-in file [:data :colors] []))
:typography-count (count (get-in file [:data :typographies] []))}))))
(sv/defmethod ::get-file-summary
"Retrieve a file summary by its ID. Only authenticated users."
{::doc/added "1.20"
::sm/params schema:get-file}
[cfg {:keys [::rpc/profile-id] :as params}]
(db/tx-run! cfg get-file-summary (assoc params :profile-id profile-id)))
;; --- COMMAND QUERY: get-file-info
(defn- get-file-info
[{:keys [::db/conn] :as cfg} {:keys [id] :as params}]
(db/get* conn :file
(db/get conn :file
{:id id}
{::sql/columns [:id]}))
{::sql/columns [:id :deleted-at]}))
(sv/defmethod ::get-file-info
"Retrieve minimal file info by its ID."
@@ -881,7 +832,7 @@
;; --- MUTATION COMMAND: set-file-shared
(def sql:get-referenced-files
(def ^:private sql:get-referenced-files
"SELECT f.id
FROM file_library_rel AS flr
INNER JOIN file AS f ON (f.id = flr.file_id)
@@ -892,13 +843,12 @@
(defn- absorb-library-by-file!
[cfg ldata file-id]
(dm/assert!
"expected cfg with valid connection"
(db/connection-map? cfg))
(assert (db/connection-map? cfg)
"expected cfg with valid connection")
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg file-id)
pmap/*tracked* (pmap/create-tracked)]
(let [file (-> (get-file cfg file-id
(let [file (-> (bfc/get-file cfg file-id
:include-deleted? true
:lock-for-update? true)
(update :data ctf/absorb-assets ldata))]
@@ -907,39 +857,35 @@
:library-id (str (:id ldata))
:file-id (str file-id))
(db/update! cfg :file
{:revn (inc (:revn file))
:data (blob/encode (:data file))
(bfc/update-file! cfg {:id file-id
:migrations (:migrations file)
:revn (inc (:revn file))
:data (:data file)
:modified-at (ct/now)
:has-media-trimmed false}
{:id file-id})
(feat.fdata/persist-pointers! cfg file-id))))
:has-media-trimmed false}))))
(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}]
[cfg {:keys [id data] :as library}]
(dm/assert!
"expected cfg with valid connection"
(db/connection-map? cfg))
(assert (db/connection-map? cfg)
"expected cfg with valid connection")
(let [ldata (binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)]
(-> library :data (feat.fdata/process-pointers deref)))
ids (->> (db/exec! cfg [sql:get-referenced-files id])
(map :id))]
(let [ids (->> (db/exec! cfg [sql:get-referenced-files id])
(sequence bfc/xf-map-id))]
(l/trc :hint "absorbing library"
: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 data) ids)
library))
(defn absorb-library!
[{:keys [::db/conn] :as cfg} id]
(let [file (-> (get-file cfg id
(let [file (-> (bfc/get-file cfg id
:realize? true
:lock-for-update? true
:include-deleted? true)
(check-version!))
@@ -1038,7 +984,14 @@
(let [team (teams/get-team conn
:profile-id profile-id
:file-id id)
file (mark-file-deleted conn team id)]
file (mark-file-deleted conn team id)
msgbus (::mbus/msgbus cfg)]
(mbus/pub! msgbus
:topic id
:message {:type :file-deleted
:file-id id
:profile-id profile-id})
(rph/with-meta (rph/wrap)
{::audit/props {:project-id (:project-id file)
@@ -1071,6 +1024,7 @@
[:library-id ::sm/uuid]])
(sv/defmethod ::link-file-to-library
"Link a file to a library. Returns the recursive list of libraries used by that library"
{::doc/added "1.17"
::webhooks/event? true
::sm/params schema:link-file-to-library}
@@ -1084,7 +1038,8 @@
(fn [{:keys [::db/conn]}]
(check-edition-permissions! conn profile-id file-id)
(check-edition-permissions! conn profile-id library-id)
(link-file-to-library conn params))))
(link-file-to-library conn params)
(bfc/get-libraries cfg [library-id]))))
;; --- MUTATION COMMAND: unlink-file-from-library

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

@@ -8,6 +8,7 @@
(:require
[app.binfile.common :as bfc]
[app.common.features :as cfeat]
[app.common.files.migrations :as fmg]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.types.file :as ctf]
@@ -45,12 +46,14 @@
(binding [pmap/*tracked* (pmap/create-tracked)
cfeat/*current* features]
(let [file (ctf/make-file {:id id
:project-id project-id
:name name
:revn revn
:is-shared is-shared
:features features
:migrations fmg/available-migrations
:ignore-sync-until ignore-sync-until
:created-at modified-at
:deleted-at deleted-at}
@@ -66,7 +69,7 @@
{:modified-at (ct/now)}
{:id project-id})
file)))
(bfc/get-file cfg (:id file)))))
(def ^:private schema:create-file
[:map {:title "create-file"}

328
backend/src/app/rpc/commands/files_snapshot.clj
View File

@@ -8,52 +8,20 @@
(:require
[app.binfile.common :as bfc]
[app.common.exceptions :as ex]
[app.common.files.migrations :as fmg]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as-alias sql]
[app.features.fdata :as feat.fdata]
[app.features.file-migrations :refer [reset-migrations!]]
[app.features.file-snapshots :as fsnap]
[app.features.logical-deletion :as ldel]
[app.main :as-alias main]
[app.msgbus :as mbus]
[app.rpc :as-alias rpc]
[app.rpc.commands.files :as files]
[app.rpc.commands.teams :as teams]
[app.rpc.doc :as-alias doc]
[app.rpc.quotes :as quotes]
[app.storage :as sto]
[app.util.blob :as blob]
[app.util.services :as sv]
[cuerdas.core :as str]))
(defn decode-row
[{:keys [migrations] :as row}]
(when row
(cond-> row
(some? migrations)
(assoc :migrations (db/decode-pgarray migrations)))))
(def sql:get-file-snapshots
"WITH changes AS (
SELECT id, label, revn, created_at, created_by, profile_id, locked_by
FROM file_change
WHERE file_id = ?
AND data IS NOT NULL
AND (deleted_at IS NULL OR deleted_at > now())
), versions AS (
(SELECT * FROM changes WHERE created_by = 'system' LIMIT 1000)
UNION ALL
(SELECT * FROM changes WHERE created_by != 'system' LIMIT 1000)
)
SELECT * FROM versions
ORDER BY created_at DESC;")
(defn get-file-snapshots
[conn file-id]
(db/exec! conn [sql:get-file-snapshots file-id]))
[app.util.services :as sv]))
(def ^:private schema:get-file-snapshots
[:map {:title "get-file-snapshots"}
@@ -65,73 +33,7 @@
[cfg {:keys [::rpc/profile-id file-id] :as params}]
(db/run! cfg (fn [{:keys [::db/conn]}]
(files/check-read-permissions! conn profile-id file-id)
(get-file-snapshots conn file-id))))
(defn- generate-snapshot-label
[]
(let [ts (-> (ct/now)
(ct/format-inst)
(str/replace #"[T:\.]" "-")
(str/rtrim "Z"))]
(str "snapshot-" ts)))
(defn create-file-snapshot!
[cfg file & {:keys [label created-by deleted-at profile-id]
:or {deleted-at :default
created-by :system}}]
(assert (#{:system :user :admin} created-by)
"expected valid keyword for created-by")
(let [created-by
(name created-by)
deleted-at
(cond
(= deleted-at :default)
(ct/plus (ct/now) (cf/get-deletion-delay))
(ct/inst? deleted-at)
deleted-at
:else
nil)
label
(or label (generate-snapshot-label))
snapshot-id
(uuid/next)
data
(blob/encode (:data file))
features
(into-array (:features file))
migrations
(into-array (:migrations file))]
(l/dbg :hint "creating file snapshot"
:file-id (str (:id file))
:id (str snapshot-id)
:label label)
(db/insert! cfg :file-change
{:id snapshot-id
:revn (:revn file)
:data data
:version (:version file)
:features features
:migrations migrations
:profile-id profile-id
:file-id (:id file)
:label label
:deleted-at deleted-at
:created-by created-by}
{::db/return-keys false})
{:id snapshot-id :label label}))
(fsnap/get-visible-snapshots conn file-id))))
(def ^:private schema:create-file-snapshot
[:map
@@ -144,7 +46,7 @@
::db/transaction true}
[{:keys [::db/conn] :as cfg} {:keys [::rpc/profile-id file-id label]}]
(files/check-edition-permissions! conn profile-id file-id)
(let [file (bfc/get-file cfg file-id)
(let [file (bfc/get-file cfg file-id :realize? true)
project (db/get-by-id cfg :project (:project-id file))]
(-> cfg
@@ -155,96 +57,10 @@
(quotes/check! {::quotes/id ::quotes/snapshots-per-file}
{::quotes/id ::quotes/snapshots-per-team}))
(create-file-snapshot! cfg file
(fsnap/create! cfg file
{:label label
:profile-id profile-id
:created-by :user})))
(defn restore-file-snapshot!
[{:keys [::db/conn ::mbus/msgbus] :as cfg} file-id snapshot-id]
(let [storage (sto/resolve cfg {::db/reuse-conn true})
file (files/get-minimal-file conn file-id {::db/for-update true})
vern (rand-int Integer/MAX_VALUE)
snapshot (some->> (db/get* conn :file-change
{:file-id file-id
:id snapshot-id}
{::db/for-share true})
(feat.fdata/resolve-file-data cfg)
(decode-row))
;; If snapshot has tracked applied migrations, we reuse them,
;; if not we take a safest set of migrations as starting
;; point. This is because, at the time of implementing
;; snapshots, migrations were not taken into account so we
;; need to make this backward compatible in some way.
file (assoc file :migrations
(or (:migrations snapshot)
(fmg/generate-migrations-from-version 67)))]
(when-not snapshot
(ex/raise :type :not-found
:code :snapshot-not-found
:hint "unable to find snapshot with the provided label"
:snapshot-id snapshot-id
:file-id file-id))
(when-not (:data snapshot)
(ex/raise :type :validation
:code :snapshot-without-data
:hint "snapshot has no data"
:label (:label snapshot)
:file-id file-id))
(l/dbg :hint "restoring snapshot"
:file-id (str file-id)
:label (:label snapshot)
:snapshot-id (str (:id snapshot)))
;; If the file was already offloaded, on restoring the snapshot we
;; are going to replace the file data, so we need to touch the old
;; referenced storage object and avoid possible leaks
(when (feat.fdata/offloaded? file)
(sto/touch-object! storage (:data-ref-id file)))
;; In the same way, on reseting the file data, we need to restore
;; the applied migrations on the moment of taking the snapshot
(reset-migrations! conn file)
(db/update! conn :file
{:data (:data snapshot)
:revn (inc (:revn file))
:vern vern
:version (:version snapshot)
:data-backend nil
:data-ref-id nil
:has-media-trimmed false
:features (:features snapshot)}
{:id file-id})
;; clean object thumbnails
(let [sql (str "update file_tagged_object_thumbnail "
" set deleted_at = now() "
" where file_id=? returning media_id")
res (db/exec! conn [sql file-id])]
(doseq [media-id (into #{} (keep :media-id) res)]
(sto/touch-object! storage media-id)))
;; clean file thumbnails
(let [sql (str "update file_thumbnail "
" set deleted_at = now() "
" where file_id=? returning media_id")
res (db/exec! conn [sql file-id])]
(doseq [media-id (into #{} (keep :media-id) res)]
(sto/touch-object! storage media-id)))
;; Send to the clients a notification to reload the file
(mbus/pub! msgbus
:topic (:id file)
:message {:type :file-restore
:file-id (:id file)
:vern vern})
{:id (:id snapshot)
:label (:label snapshot)}))
:created-by "user"})))
(def ^:private schema:restore-file-snapshot
[:map {:title "restore-file-snapshot"}
@@ -253,88 +69,76 @@
(sv/defmethod ::restore-file-snapshot
{::doc/added "1.20"
::sm/params schema:restore-file-snapshot}
[cfg {:keys [::rpc/profile-id file-id id] :as params}]
(db/tx-run! cfg
(fn [{:keys [::db/conn] :as cfg}]
::sm/params schema:restore-file-snapshot
::db/transaction true}
[{:keys [::db/conn ::mbus/msgbus] :as cfg} {:keys [::rpc/profile-id file-id id] :as params}]
(files/check-edition-permissions! conn profile-id file-id)
(let [file (bfc/get-file cfg file-id)]
(create-file-snapshot! cfg file
(let [file (bfc/get-file cfg file-id)
team (teams/get-team conn
:profile-id profile-id
:file-id file-id)
delay (ldel/get-deletion-delay team)]
(fsnap/create! cfg file
{:profile-id profile-id
:created-by :system})
(restore-file-snapshot! cfg file-id id)))))
:deleted-at (ct/in-future delay)
:created-by "system"})
(let [vern (fsnap/restore! cfg file-id id)]
;; Send to the clients a notification to reload the file
(mbus/pub! msgbus
:topic (:id file)
:message {:type :file-restore
:file-id (:id file)
:vern vern})
nil)))
(def ^:private schema:update-file-snapshot
[:map {:title "update-file-snapshot"}
[:id ::sm/uuid]
[:label ::sm/text]])
(defn- update-file-snapshot!
[conn snapshot-id label]
(-> (db/update! conn :file-change
{:label label
:created-by "user"
:deleted-at nil}
{:id snapshot-id}
{::db/return-keys true})
(dissoc :data :features :migrations)))
(defn- get-snapshot
"Get a minimal snapshot from database and lock for update"
[conn id]
(db/get conn :file-change
{:id id}
{::sql/columns [:id :file-id :created-by :deleted-at :profile-id :locked-by]
::db/for-update true}))
(sv/defmethod ::update-file-snapshot
{::doc/added "1.20"
::sm/params schema:update-file-snapshot}
[cfg {:keys [::rpc/profile-id id label]}]
(db/tx-run! cfg
(fn [{:keys [::db/conn]}]
(let [snapshot (get-snapshot conn id)]
::sm/params schema:update-file-snapshot
::db/transaction true}
[{:keys [::db/conn]} {:keys [::rpc/profile-id id label]}]
(let [snapshot (fsnap/get-minimal-snapshot conn id)]
(files/check-edition-permissions! conn profile-id (:file-id snapshot))
(update-file-snapshot! conn id label)))))
(fsnap/update! conn (assoc snapshot :label label))))
(def ^:private schema:remove-file-snapshot
[:map {:title "remove-file-snapshot"}
[:id ::sm/uuid]])
(defn- delete-file-snapshot!
[conn snapshot-id]
(db/update! conn :file-change
{:deleted-at (ct/now)}
{:id snapshot-id}
{::db/return-keys false})
nil)
(sv/defmethod ::delete-file-snapshot
{::doc/added "1.20"
::sm/params schema:remove-file-snapshot}
[cfg {:keys [::rpc/profile-id id]}]
(db/tx-run! cfg
(fn [{:keys [::db/conn]}]
(let [snapshot (get-snapshot conn id)]
::sm/params schema:remove-file-snapshot
::db/transaction true}
[{:keys [::db/conn]} {:keys [::rpc/profile-id id]}]
(let [snapshot (fsnap/get-minimal-snapshot conn id)]
(files/check-edition-permissions! conn profile-id (:file-id snapshot))
(when (not= (:created-by snapshot) "user")
(ex/raise :type :validation
:code :system-snapshots-cant-be-deleted
:file-id (:file-id snapshot)
:snapshot-id id
:profile-id profile-id))
;; Check if version is locked by someone else
(when (and (:locked-by snapshot)
(when (and (some? (:locked-by snapshot))
(not= (:locked-by snapshot) profile-id))
(ex/raise :type :validation
:code :snapshot-is-locked
:hint "Cannot delete a locked version"
:file-id (:file-id snapshot)
:snapshot-id id
:profile-id profile-id
:locked-by (:locked-by snapshot)))
:profile-id profile-id))
(delete-file-snapshot! conn id)))))
(let [team (teams/get-team conn
:profile-id profile-id
:file-id (:file-id snapshot))
delay (ldel/get-deletion-delay team)]
(fsnap/delete! conn (assoc snapshot :deleted-at (ct/in-future delay))))))
;;; Lock/unlock version endpoints
@@ -342,21 +146,12 @@
[:map {:title "lock-file-snapshot"}
[:id ::sm/uuid]])
(defn- lock-file-snapshot!
[conn snapshot-id profile-id]
(db/update! conn :file-change
{:locked-by profile-id}
{:id snapshot-id}
{::db/return-keys false})
nil)
(sv/defmethod ::lock-file-snapshot
{::doc/added "1.20"
::sm/params schema:lock-file-snapshot}
[cfg {:keys [::rpc/profile-id id]}]
(db/tx-run! cfg
(fn [{:keys [::db/conn]}]
(let [snapshot (get-snapshot conn id)]
::sm/params schema:lock-file-snapshot
::db/transaction true}
[{:keys [::db/conn]} {:keys [::rpc/profile-id id]}]
(let [snapshot (fsnap/get-minimal-snapshot conn id)]
(files/check-edition-permissions! conn profile-id (:file-id snapshot))
(when (not= (:created-by snapshot) "user")
@@ -384,27 +179,18 @@
:profile-id profile-id
:locked-by (:locked-by snapshot)))
(lock-file-snapshot! conn id profile-id)))))
(fsnap/lock-by! conn id profile-id)))
(def ^:private schema:unlock-file-snapshot
[:map {:title "unlock-file-snapshot"}
[:id ::sm/uuid]])
(defn- unlock-file-snapshot!
[conn snapshot-id]
(db/update! conn :file-change
{:locked-by nil}
{:id snapshot-id}
{::db/return-keys false})
nil)
(sv/defmethod ::unlock-file-snapshot
{::doc/added "1.20"
::sm/params schema:unlock-file-snapshot}
[cfg {:keys [::rpc/profile-id id]}]
(db/tx-run! cfg
(fn [{:keys [::db/conn]}]
(let [snapshot (get-snapshot conn id)]
::sm/params schema:unlock-file-snapshot
::db/transaction true}
[{:keys [::db/conn]} {:keys [::rpc/profile-id id]}]
(let [snapshot (fsnap/get-minimal-snapshot conn id)]
(files/check-edition-permissions! conn profile-id (:file-id snapshot))
(when (not= (:created-by snapshot) "user")
@@ -431,4 +217,4 @@
:snapshot-id id
:profile-id profile-id))
(unlock-file-snapshot! conn id)))))
(fsnap/unlock! conn id)))

160
backend/src/app/rpc/commands/files_temp.clj
View File

@@ -1,160 +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.rpc.commands.files-temp
(:require
[app.common.exceptions :as ex]
[app.common.features :as cfeat]
[app.common.files.changes :as cpc]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as sql]
[app.features.fdata :as fdata]
[app.loggers.audit :as audit]
[app.rpc :as-alias rpc]
[app.rpc.commands.files :as files]
[app.rpc.commands.files-create :as files.create]
[app.rpc.commands.files-update :as-alias files.update]
[app.rpc.commands.projects :as projects]
[app.rpc.commands.teams :as teams]
[app.rpc.doc :as-alias doc]
[app.rpc.helpers :as rph]
[app.util.blob :as blob]
[app.util.pointer-map :as pmap]
[app.util.services :as sv]
[clojure.set :as set]))
;; --- MUTATION COMMAND: create-temp-file
(def ^:private schema:create-temp-file
[:map {:title "create-temp-file"}
[:name [:string {:max 250}]]
[:project-id ::sm/uuid]
[:id {:optional true} ::sm/uuid]
[:is-shared ::sm/boolean]
[:features ::cfeat/features]
[:create-page ::sm/boolean]])
(sv/defmethod ::create-temp-file
{::doc/added "1.17"
::doc/module :files
::sm/params schema:create-temp-file
::db/transaction true}
[{:keys [::db/conn] :as cfg} {:keys [::rpc/profile-id project-id] :as params}]
(projects/check-edition-permissions! conn profile-id project-id)
(let [team (teams/get-team conn :profile-id profile-id :project-id project-id)
;; When we create files, we only need to respect the team
;; features, because some features can be enabled
;; globally, but the team is still not migrated properly.
input-features
(:features params #{})
;; If the imported project doesn't contain v2 we need to remove it
team-features
(cond-> (cfeat/get-team-enabled-features cf/flags team)
(not (contains? input-features "components/v2"))
(disj "components/v2"))
;; We also include all no migration features declared by
;; client; that enables the ability to enable a runtime
;; feature on frontend and make it permanent on file
features
(-> input-features
(set/intersection cfeat/no-migration-features)
(set/union team-features))
params
(-> params
(assoc :profile-id profile-id)
(assoc :deleted-at (ct/in-future {:days 1}))
(assoc :features features))]
(files.create/create-file cfg params)))
;; --- MUTATION COMMAND: update-temp-file
(def ^:private schema:update-temp-file
[:map {:title "update-temp-file"}
[:changes [:vector cpc/schema:change]]
[:revn [::sm/int {:min 0}]]
[:session-id ::sm/uuid]
[:id ::sm/uuid]])
(sv/defmethod ::update-temp-file
{::doc/added "1.17"
::doc/module :files
::sm/params schema:update-temp-file}
[cfg {:keys [::rpc/profile-id session-id id revn changes] :as params}]
(db/tx-run! cfg (fn [{:keys [::db/conn]}]
(db/insert! conn :file-change
{:id (uuid/next)
:session-id session-id
:profile-id profile-id
:created-at (ct/now)
:file-id id
:revn revn
:data nil
:changes (blob/encode changes)})
(rph/with-meta (rph/wrap nil)
{::audit/replace-props {:file-id id
:revn revn}}))))
;; --- MUTATION COMMAND: persist-temp-file
(defn persist-temp-file
[{:keys [::db/conn] :as cfg} {:keys [id] :as params}]
(let [file (files/get-file cfg id
:migrate? false
:lock-for-update? true)]
(when (nil? (:deleted-at file))
(ex/raise :type :validation
:code :cant-persist-already-persisted-file))
(let [changes (->> (db/cursor conn
(sql/select :file-change {:file-id id}
{:order-by [[:revn :asc]]})
{:chunk-size 10})
(sequence (mapcat (comp blob/decode :changes))))
file (update file :data cpc/process-changes changes)
file (if (contains? (:features file) "fdata/objects-map")
(fdata/enable-objects-map file)
file)
file (if (contains? (:features file) "fdata/pointer-map")
(binding [pmap/*tracked* (pmap/create-tracked)]
(let [file (fdata/enable-pointer-map file)]
(fdata/persist-pointers! cfg id)
file))
file)]
;; Delete changes from the changes history
(db/delete! conn :file-change {:file-id id})
(db/update! conn :file
{:deleted-at nil
:revn 1
:data (blob/encode (:data file))}
{:id id})
nil)))
(def ^:private schema:persist-temp-file
[:map {:title "persist-temp-file"}
[:id ::sm/uuid]])
(sv/defmethod ::persist-temp-file
{::doc/added "1.17"
::doc/module :files
::sm/params schema:persist-temp-file}
[cfg {:keys [::rpc/profile-id id] :as params}]
(db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
(files/check-edition-permissions! conn profile-id id)
(persist-temp-file cfg params))))

6
backend/src/app/rpc/commands/files_thumbnails.clj
View File

@@ -6,6 +6,7 @@
(ns app.rpc.commands.files-thumbnails
(:require
[app.binfile.common :as bfc]
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.features :as cfeat]
@@ -202,8 +203,8 @@
:profile-id profile-id
:file-id file-id)
file (files/get-file cfg file-id
:preload-pointers? true
file (bfc/get-file cfg file-id
:realize? true
:read-only? true)]
(-> (cfeat/get-team-enabled-features cf/flags team)
@@ -339,6 +340,7 @@
data (-> (sto/content path)
(sto/wrap-with-hash hash))
tnow (ct/now)
media (sto/put-object! storage
{::sto/content data
::sto/deduplicate? true

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

@@ -19,27 +19,25 @@
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.features.fdata :as feat.fdata]
[app.features.file-migrations :as feat.fmigr]
[app.features.fdata :as fdata]
[app.features.file-snapshots :as fsnap]
[app.features.logical-deletion :as ldel]
[app.http.errors :as errors]
[app.loggers.audit :as audit]
[app.loggers.webhooks :as webhooks]
[app.metrics :as mtx]
[app.msgbus :as mbus]
[app.redis :as rds]
[app.rpc :as-alias rpc]
[app.rpc.climit :as climit]
[app.rpc.commands.files :as files]
[app.rpc.commands.teams :as teams]
[app.rpc.doc :as-alias doc]
[app.rpc.helpers :as rph]
[app.storage :as sto]
[app.util.blob :as blob]
[app.util.pointer-map :as pmap]
[app.util.services :as sv]
[app.worker :as wrk]
[clojure.set :as set]
[promesa.exec :as px]))
[clojure.set :as set]))
(declare ^:private get-lagged-changes)
(declare ^:private send-notifications!)
@@ -47,6 +45,7 @@
(declare ^:private update-file*)
(declare ^:private process-changes-and-validate)
(declare ^:private take-snapshot?)
(declare ^:private invalidate-caches!)
;; PUBLIC API; intended to be used outside of this module
(declare update-file!)
@@ -129,14 +128,15 @@
::sm/params schema:update-file
::sm/result schema:update-file-result
::doc/module :files
::doc/added "1.17"}
[{:keys [::mtx/metrics] :as cfg}
::doc/added "1.17"
::db/transaction true}
[{:keys [::mtx/metrics ::db/conn] :as cfg}
{:keys [::rpc/profile-id id changes changes-with-metadata] :as params}]
(db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
(files/check-edition-permissions! conn profile-id id)
(db/xact-lock! conn id)
(let [file (get-file conn id)
(let [file (get-file cfg id)
team (teams/get-team conn
:profile-id profile-id
:team-id (:team-id file))
@@ -176,8 +176,8 @@
:context {:incoming-revn (:revn params)
:stored-revn (:revn file)}))
;; When newly computed features does not match exactly with
;; the features defined on team row, we update it
;; When newly computed features does not match exactly with the
;; features defined on team row, we update it
(when-let [features (-> features
(set/difference (:features team))
(set/difference cfeat/no-team-inheritable-features)
@@ -191,6 +191,7 @@
{:id (:id team)}
{::db/return-keys false})))
(mtx/run! metrics {:id :update-file-changes :inc (count changes)})
(binding [l/*context* (some-> (meta params)
@@ -198,7 +199,7 @@
(errors/request->context))]
(-> (update-file* cfg params)
(rph/with-defer #(let [elapsed (tpoint)]
(l/trace :hint "update-file" :time (ct/format-duration elapsed))))))))))
(l/trace :hint "update-file" :time (ct/format-duration elapsed))))))))
(defn- update-file*
"Internal function, part of the update-file process, that encapsulates
@@ -208,31 +209,41 @@
Follow the inner implementation to `update-file-data!` function.
Only intended for internal use on this module."
[{:keys [::db/conn ::wrk/executor ::timestamp] :as cfg}
[{:keys [::db/conn ::timestamp] :as cfg}
{:keys [profile-id file team features changes session-id skip-validate] :as params}]
(let [;; Retrieve the file data
file (feat.fmigr/resolve-applied-migrations cfg file)
file (feat.fdata/resolve-file-data cfg file)
file (assoc file :features
(binding [pmap/*tracked* (pmap/create-tracked)
pmap/*load-fn* (partial fdata/load-pointer cfg (:id file))]
(let [file (assoc file :features
(-> features
(set/difference cfeat/frontend-only-features)
(set/union (:features file))))]
(set/union (:features file))))
;; We create a new lexycal scope for clearly delimit the result of
;; executing this update file operation and all its side effects
(let [file (px/invoke! executor
(fn []
;; Process the file data on separated thread for avoid to do
;; the CPU intensive operation on vthread.
;; We need to preserve the original revn for the response
revn
(get file :revn)
file
(binding [cfeat/*current* features
cfeat/*previous* (:features file)]
(update-file-data! cfg file
process-changes-and-validate
changes skip-validate))))]
changes skip-validate))
(feat.fmigr/upsert-migrations! conn file)
(persist-file! cfg file)
deleted-at
(ct/plus timestamp (ct/duration {:hours 1}))]
(when-let [file (::snapshot file)]
(let [deleted-at (ct/plus timestamp (ldel/get-deletion-delay team))
label (str "internal/snapshot/" revn)]
(fsnap/create! cfg file
{:label label
:created-by "system"
:deleted-at deleted-at
:profile-id profile-id
:session-id session-id})))
;; Insert change (xlog) with deleted_at in a future data for
;; make them automatically eleggible for GC once they expires
@@ -242,87 +253,71 @@
:profile-id profile-id
:created-at timestamp
:updated-at timestamp
:deleted-at (if (::snapshot-data file)
(ct/plus timestamp (ldel/get-deletion-delay team))
(ct/plus timestamp (ct/duration {:hours 1})))
:deleted-at deleted-at
:file-id (:id file)
:revn (:revn file)
:version (:version file)
:features (:features file)
:label (::snapshot-label file)
:data (::snapshot-data file)
:features (into-array (:features file))
:changes (blob/encode changes)}
{::db/return-keys false})
(persist-file! cfg file)
(when (contains? cf/flags :redis-cache)
(invalidate-caches! cfg file))
;; Send asynchronous notifications
(send-notifications! cfg params file))
(send-notifications! cfg params file)
(when (feat.fdata/offloaded? file)
(let [storage (sto/resolve cfg ::db/reuse-conn true)]
(some->> (:data-ref-id file) (sto/touch-object! storage))))
(let [response {:revn (:revn file)
:lagged (get-lagged-changes conn params)}]
(vary-meta response assoc ::audit/replace-props
(with-meta {:revn revn :lagged (get-lagged-changes conn params)}
{::audit/replace-props
{:id (:id file)
:name (:name file)
:features (:features file)
:project-id (:project-id file)
:team-id (:team-id file)}))))
(defn update-file!
"A public api that allows apply a transformation to a file with all context setup."
[{:keys [::db/conn] :as cfg} file-id update-fn & args]
(let [file (get-file cfg file-id)
file (apply update-file-data! cfg file update-fn args)]
(feat.fmigr/upsert-migrations! conn file)
(persist-file! cfg file)))
(def ^:private sql:get-file
"SELECT f.*, p.team_id
FROM file AS f
JOIN project AS p ON (p.id = f.project_id)
WHERE f.id = ?
AND (f.deleted_at IS NULL OR
f.deleted_at > now())
FOR KEY SHARE")
:team-id (:team-id file)}}))))
(defn get-file
"Get not-decoded file, only decodes the features set."
[conn id]
(let [file (db/exec-one! conn [sql:get-file id])]
(when-not file
(ex/raise :type :not-found
:code :object-not-found
:hint (format "file with id '%s' does not exists" id)))
(update file :features db/decode-pgarray #{})))
[cfg id]
(bfc/get-file cfg id :decode? false :lock-for-share? true))
(defn persist-file!
"Function responsible of persisting already encoded file. Should be
used together with `get-file` and `update-file-data!`.
It also updates the project modified-at attr."
[{:keys [::db/conn ::timestamp]} file]
[{:keys [::db/conn ::timestamp] :as cfg} file]
(let [;; The timestamp can be nil because this function is also
;; intended to be used outside of this module
modified-at (or timestamp (ct/now))]
modified-at
(or timestamp (ct/now))
file
(-> file
(dissoc ::snapshot)
(assoc :modified-at modified-at)
(assoc :has-media-trimmed false))]
(db/update! conn :project
{:modified-at modified-at}
{:id (:project-id file)}
{::db/return-keys false})
(db/update! conn :file
{:revn (:revn file)
:data (:data file)
:version (:version file)
:features (:features file)
:data-backend nil
:data-ref-id nil
:modified-at modified-at
:has-media-trimmed false}
{:id (:id file)}
{::db/return-keys false})))
(bfc/update-file! cfg file)))
(defn- invalidate-caches!
[cfg {:keys [id] :as file}]
(rds/run! cfg (fn [{:keys [::rds/conn]}]
(let [key (str files/file-summary-cache-key-prefix id)]
(rds/del conn key)))))
(defn- attach-snapshot
"Attach snapshot data to the file. This should be called before the
upcoming file operations are applied to the file."
[cfg migrated? file]
(let [snapshot (if migrated? file (fdata/realize cfg file))]
(assoc file ::snapshot snapshot)))
(defn- update-file-data!
"Perform a file data transformation in with all update context setup.
@@ -334,52 +329,35 @@
fdata/pointer-map modified fragments."
[cfg {:keys [id] :as file} update-fn & args]
(binding [pmap/*tracked* (pmap/create-tracked)
pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)]
(let [file (update file :data (fn [data]
(-> data
(blob/decode)
(assoc :id (:id file)))))
(assoc :id id))))
libs (delay (bfc/get-resolved-file-libraries cfg file))
;; For avoid unnecesary overhead of creating multiple pointers
;; and handly internally with objects map in their worst
;; case (when probably all shapes and all pointers will be
;; readed in any case), we just realize/resolve them before
;; applying the migration to the file
file (if (fmg/need-migration? file)
(-> file
(update :data feat.fdata/process-pointers deref)
(update :data feat.fdata/process-objects (partial into {}))
(fmg/migrate-file libs))
file)
need-migration?
(fmg/need-migration? file)
file (apply update-fn cfg file args)
take-snapshot?
(take-snapshot? file)
;; TODO: reuse operations if file is migrated
;; TODO: move encoding to a separated thread
file (if (take-snapshot? file)
(let [tpoint (ct/tpoint)
snapshot (-> (:data file)
(feat.fdata/process-pointers deref)
(feat.fdata/process-objects (partial into {}))
(blob/encode))
elapsed (tpoint)
label (str "internal/snapshot/" (:revn file))]
;; For avoid unnecesary overhead of creating multiple
;; pointers and handly internally with objects map in their
;; worst case (when probably all shapes and all pointers
;; will be readed in any case), we just realize/resolve them
;; before applying the migration to the file
file
(cond-> file
;; need-migration?
;; (->> (fdata/realize cfg))
(l/trc :hint "take snapshot"
:file-id (str (:id file))
:revn (:revn file)
:label label
:elapsed (ct/format-duration elapsed))
need-migration?
(fmg/migrate-file libs)
(-> file
(assoc ::snapshot-data snapshot)
(assoc ::snapshot-label label)))
file)]
(bfc/encode-file cfg file))))
take-snapshot?
(->> (attach-snapshot cfg need-migration?)))]
(apply update-fn cfg file args)))
(defn- soft-validate-file-schema!
[file]
@@ -468,8 +446,9 @@
(defn- get-lagged-changes
[conn {:keys [id revn] :as params}]
(->> (db/exec! conn [sql:lagged-changes id revn])
(map files/decode-row)
(vec)))
(filter :changes)
(mapv (fn [row]
(update row :changes blob/decode)))))
(defn- send-notifications!
[cfg {:keys [team changes session-id] :as params} file]

8
backend/src/app/rpc/commands/fonts.clj
View File

@@ -26,9 +26,7 @@
[app.rpc.helpers :as rph]
[app.rpc.quotes :as quotes]
[app.storage :as sto]
[app.util.services :as sv]
[app.worker :as-alias wrk]
[promesa.exec :as px]))
[app.util.services :as sv]))
(def valid-weight #{100 200 300 400 500 600 700 800 900 950})
(def valid-style #{"normal" "italic"})
@@ -105,7 +103,7 @@
(create-font-variant cfg (assoc params :profile-id profile-id)))))
(defn create-font-variant
[{:keys [::sto/storage ::db/conn ::wrk/executor]} {:keys [data] :as params}]
[{:keys [::sto/storage ::db/conn]} {:keys [data] :as params}]
(letfn [(generate-missing! [data]
(let [data (media/run {:cmd :generate-fonts :input data})]
(when (and (not (contains? data "font/otf"))
@@ -157,7 +155,7 @@
:otf-file-id (:id otf)
:ttf-file-id (:id ttf)}))]
(let [data (px/invoke! executor (partial generate-missing! data))
(let [data (generate-missing! data)
assets (persist-fonts-files! data)
result (insert-font-variant! assets)]
(vary-meta result assoc ::audit/replace-props (update params :data (comp vec keys))))))

6
backend/src/app/rpc/commands/ldap.clj
View File

@@ -38,7 +38,7 @@
::doc/added "1.15"
::doc/module :auth
::sm/params schema:login-with-ldap}
[{:keys [::setup/props ::ldap/provider] :as cfg} params]
[{:keys [::ldap/provider] :as cfg} params]
(when-not provider
(ex/raise :type :restriction
:code :ldap-not-initialized
@@ -60,11 +60,11 @@
;; 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).
(let [claims (tokens/verify props {:token token :iss :team-invitation})
(let [claims (tokens/verify cfg {:token token :iss :team-invitation})
claims (assoc claims
:member-id (:id profile)
:member-email (:email profile))
token (tokens/generate props claims)]
token (tokens/generate cfg claims)]
(-> {:invitation-token token}
(rph/with-transform (session/create-fn cfg (:id profile)))
(rph/with-meta {::audit/props (:props profile)

32
backend/src/app/rpc/commands/management.clj
View File

@@ -28,16 +28,14 @@
[app.setup :as-alias setup]
[app.setup.templates :as tmpl]
[app.storage.tmp :as tmp]
[app.util.services :as sv]
[app.worker :as-alias wrk]
[promesa.exec :as px]))
[app.util.services :as sv]))
;; --- COMMAND: Duplicate File
(defn duplicate-file
[{:keys [::db/conn ::bfc/timestamp] :as cfg} {:keys [profile-id file-id name reset-shared-flag] :as params}]
(let [;; We don't touch the original file on duplication
file (bfc/get-file cfg file-id)
file (bfc/get-file cfg file-id :realize? true)
project-id (:project-id file)
file (-> file
(update :id bfc/lookup-index)
@@ -313,15 +311,14 @@
;; Update the modification date of the all affected projects
;; ensuring that the destination project is the most recent one.
(doseq [project-id (into (list project-id) source)]
;; NOTE: as this is executed on virtual thread, sleeping does
;; not causes major issues, and allows an easy way to set a
;; trully different modification date to each file.
(px/sleep 10)
(loop [project-ids (into (list project-id) source)
modified-at (ct/now)]
(when-let [project-id (first project-ids)]
(db/update! conn :project
{:modified-at (ct/now)}
{:id project-id}))
{:modified-at modified-at}
{:id project-id})
(recur (rest project-ids)
(ct/plus modified-at 10))))
nil))
@@ -396,12 +393,7 @@
;; --- COMMAND: Clone Template
(defn clone-template
[{:keys [::db/pool ::wrk/executor] :as cfg} {:keys [project-id profile-id] :as params} template]
;; 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.
[{:keys [::db/pool] :as cfg} {:keys [project-id profile-id] :as params} template]
(let [template (tmp/tempfile-from template
:prefix "penpot.template."
:suffix ""
@@ -419,8 +411,8 @@
(assoc ::bfc/features (cfeat/get-team-enabled-features cf/flags team)))
result (if (= format :binfile-v3)
(px/invoke! executor (partial bf.v3/import-files! cfg))
(px/invoke! executor (partial bf.v1/import-files! cfg)))]
(bf.v3/import-files! cfg)
(bf.v1/import-files! cfg))]
(db/tx-run! cfg
(fn [{:keys [::db/conn] :as cfg}]

8
backend/src/app/rpc/commands/media.clj
View File

@@ -24,10 +24,8 @@
[app.storage :as sto]
[app.storage.tmp :as tmp]
[app.util.services :as sv]
[app.worker :as-alias wrk]
[cuerdas.core :as str]
[datoteka.io :as io]
[promesa.exec :as px]))
[datoteka.io :as io]))
(def default-max-file-size
(* 1024 1024 10)) ; 10 MiB
@@ -153,9 +151,9 @@
(assoc ::image (process-main-image info)))))
(defn- create-file-media-object
[{:keys [::sto/storage ::db/conn ::wrk/executor] :as cfg}
[{:keys [::sto/storage ::db/conn] :as cfg}
{:keys [id file-id is-local name content]}]
(let [result (px/invoke! executor (partial process-image content))
(let [result (process-image content)
image (sto/put-object! storage (::image result))
thumb (when-let [params (::thumb result)]
(sto/put-object! storage params))]

34
backend/src/app/rpc/commands/profile.clj
View File

@@ -30,16 +30,13 @@
[app.tokens :as tokens]
[app.util.services :as sv]
[app.worker :as wrk]
[cuerdas.core :as str]
[promesa.exec :as px]))
[cuerdas.core :as str]))
(declare check-profile-existence!)
(declare decode-row)
(declare derive-password)
(declare filter-props)
(declare get-profile)
(declare strip-private-attrs)
(declare verify-password)
(def schema:props-notifications
[:map {:title "props-notifications"}
@@ -110,7 +107,9 @@
(defn get-profile
"Get profile by id. Throws not-found exception if no profile found."
[conn id & {:as opts}]
(-> (db/get-by-id conn :profile id opts)
;; NOTE: We need to set ::db/remove-deleted to false because demo profiles
;; are created with a set deleted-at value
(-> (db/get-by-id conn :profile id (assoc opts ::db/remove-deleted false))
(decode-row)))
;; --- MUTATION: Update Profile (own)
@@ -192,7 +191,7 @@
[{:keys [::db/conn] :as cfg} {:keys [profile-id old-password] :as params}]
(let [profile (db/get-by-id conn :profile profile-id ::sql/for-update true)]
(when (and (not= (:password profile) "!")
(not (:valid (verify-password cfg old-password (:password profile)))))
(not (:valid (auth/verify-password old-password (:password profile)))))
(ex/raise :type :validation
:code :old-password-not-match))
profile))
@@ -201,7 +200,7 @@
[{:keys [::db/conn] :as cfg} {:keys [id password] :as profile}]
(when-not (db/read-only? conn)
(db/update! conn :profile
{:password (derive-password cfg password)}
{:password (auth/derive-password password)}
{:id id})
nil))
@@ -303,12 +302,11 @@
:content-type (:mtype thumb)}))
(defn upload-photo
[{:keys [::sto/storage ::wrk/executor] :as cfg} {:keys [file] :as params}]
[{:keys [::sto/storage] :as cfg} {:keys [file] :as params}]
(let [params (-> cfg
(assoc ::climit/id [[:process-image/by-profile (:profile-id params)]
[:process-image/global]])
(assoc ::climit/label "upload-photo")
(assoc ::climit/executor executor)
(climit/invoke! generate-thumbnail! file))]
(sto/put-object! storage params)))
@@ -349,12 +347,12 @@
(defn- request-email-change!
[{:keys [::db/conn] :as cfg} {:keys [profile email] :as params}]
(let [token (tokens/generate (::setup/props cfg)
(let [token (tokens/generate cfg
{:iss :change-email
:exp (ct/in-future "15m")
:profile-id (:id profile)
:email email})
ptoken (tokens/generate (::setup/props cfg)
ptoken (tokens/generate cfg
{:iss :profile-identity
:profile-id (:id profile)
:exp (ct/in-future {:days 30})})]
@@ -477,13 +475,16 @@
p.fullname AS name,
p.email AS email
FROM team_profile_rel AS tpr1
JOIN team as t
ON tpr1.team_id = t.id
JOIN team_profile_rel AS tpr2
ON (tpr1.team_id = tpr2.team_id)
JOIN profile AS p
ON (tpr2.profile_id = p.id)
WHERE tpr1.profile_id = ?
AND tpr1.is_owner IS true
AND tpr2.can_edit IS true")
AND tpr2.can_edit IS true
AND t.deleted_at IS NULL")
(sv/defmethod ::get-subscription-usage
{::doc/added "2.9"}
@@ -548,15 +549,6 @@
[props]
(into {} (filter (fn [[k _]] (simple-ident? k))) props))
(defn derive-password
[{:keys [::wrk/executor]} password]
(when password
(px/invoke! executor (partial auth/derive-password password))))
(defn verify-password
[{:keys [::wrk/executor]} password password-data]
(px/invoke! executor (partial auth/verify-password password password-data)))
(defn decode-row
[{:keys [props] :as row}]
(cond-> row

25
backend/src/app/rpc/commands/teams.clj
View File

@@ -37,14 +37,14 @@
;; --- Helpers & Specs
(def ^:private sql:team-permissions
"select tpr.is_owner,
"SELECT tpr.is_owner,
tpr.is_admin,
tpr.can_edit
from team_profile_rel as tpr
join team as t on (t.id = tpr.team_id)
where tpr.profile_id = ?
and tpr.team_id = ?
and t.deleted_at is null")
FROM team_profile_rel AS tpr
JOIN team AS t ON (t.id = tpr.team_id)
WHERE tpr.profile_id = ?
AND tpr.team_id = ?
AND t.deleted_at IS NULL")
(defn get-permissions
[conn profile-id team-id]
@@ -443,13 +443,18 @@
[:team-id ::sm/uuid]])
(def sql:team-invitations
"select email_to as email, role, (valid_until < now()) as expired
from team_invitation where team_id = ? order by valid_until desc, created_at desc")
"SELECT email_to AS email,
role,
(valid_until < ?::timestamptz) AS expired
FROM team_invitation
WHERE team_id = ?
ORDER BY valid_until DESC, created_at DESC")
(defn get-team-invitations
[conn team-id]
(->> (db/exec! conn [sql:team-invitations team-id])
(mapv #(update % :role keyword))))
(let [now (ct/now)]
(->> (db/exec! conn [sql:team-invitations now team-id])
(mapv #(update % :role keyword)))))
(sv/defmethod ::get-team-invitations
{::doc/added "1.17"

117
backend/src/app/rpc/commands/teams_invitations.clj
View File

@@ -6,6 +6,7 @@
(ns app.rpc.commands.teams-invitations
(:require
[app.binfile.common :as bfc]
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
@@ -21,7 +22,6 @@
[app.loggers.audit :as audit]
[app.main :as-alias main]
[app.rpc :as-alias rpc]
[app.rpc.commands.files :as files]
[app.rpc.commands.profile :as profile]
[app.rpc.commands.teams :as teams]
[app.rpc.doc :as-alias doc]
@@ -43,7 +43,7 @@
(defn- create-invitation-token
[cfg {:keys [profile-id valid-until team-id member-id member-email role]}]
(tokens/generate (::setup/props cfg)
(tokens/generate cfg
{:iss :team-invitation
:exp valid-until
:profile-id profile-id
@@ -54,12 +54,8 @@
(defn- create-profile-identity-token
[cfg profile-id]
(dm/assert!
"expected valid uuid for profile-id"
(uuid? profile-id))
(tokens/generate (::setup/props cfg)
(assert (uuid? profile-id) "expected valid uuid for profile-id")
(tokens/generate cfg
{:iss :profile-identity
:profile-id profile-id
:exp (ct/in-future {:days 30})}))
@@ -224,8 +220,25 @@
(def ^:private xf:map-email (map :email))
(defn- create-team-invitations
[{:keys [::db/conn] :as cfg} {:keys [profile team role emails] :as params}]
(let [emails (set emails)
"Unified function to handle both create and resend team invitations.
Accepts either:
- emails (set) + role (single role for all emails)
- invitations (vector of {:email :role} maps)"
[{:keys [::db/conn] :as cfg} {:keys [profile team role emails invitations] :as params}]
(let [;; Normalize input to a consistent format: [{:email :role}]
invitation-data (cond
;; Case 1: emails + single role (create invitations style)
(and emails role)
(map (fn [email] {:email email :role role}) emails)
;; Case 2: invitations with individual roles (resend invitations style)
(some? invitations)
invitations
:else
(throw (ex-info "Invalid parameters: must provide either emails+role or invitations" {})))
invitation-emails (into #{} (map :email) invitation-data)
join-requests (->> (get-valid-access-request-profiles conn (:id team))
(d/index-by :email))
@@ -235,51 +248,84 @@
invitations (into #{}
(comp
;; We don't re-send inviation to
;; We don't re-send invitations to
;; already existing members
(remove team-members)
(remove #(contains? team-members (:email %)))
;; We don't send invitations to
;; join-requested members
(remove join-requests)
(map (fn [email] (assoc params :email email)))
(keep (partial create-invitation cfg)))
emails)]
(remove #(contains? join-requests (:email %)))
(map (fn [{:keys [email role]}]
(create-invitation cfg
(-> params
(assoc :email email)
(assoc :role role)))))
(remove nil?))
invitation-data)]
;; For requested invitations, do not send invitation emails, add
;; the user directly to the team
(->> join-requests
(filter #(contains? emails (key %)))
(map val)
(run! (partial add-member-to-team conn profile team role)))
(filter #(contains? invitation-emails (key %)))
(map (fn [[email member]]
(let [role (:role (first (filter #(= (:email %) email) invitation-data)))]
(add-member-to-team conn profile team role member))))
(doall))
invitations))
(def ^:private schema:create-team-invitations
[:and
[:map {:title "create-team-invitations"}
[:team-id ::sm/uuid]
[:role types.team/schema:role]
[:emails [::sm/set ::sm/email]]])
;; Support both formats:
;; 1. emails (set) + role (single role for all)
;; 2. invitations (vector of {:email :role} maps)
[:emails {:optional true} [::sm/set ::sm/email]]
[:role {:optional true} types.team/schema:role]
[:invitations {:optional true} [:vector [:map
[:email ::sm/email]
[:role types.team/schema:role]]]]]
;; Ensure exactly one format is provided
[:fn (fn [params]
(let [has-emails-role (and (contains? params :emails)
(contains? params :role))
has-invitations (contains? params :invitations)]
(and (or has-emails-role has-invitations)
(not (and has-emails-role has-invitations)))))]])
(def ^:private max-invitations-by-request-threshold
"The number of invitations can be sent in a single rpc request"
25)
(sv/defmethod ::create-team-invitations
"A rpc call that allow to send a single or multiple invitations to
join the team."
"A rpc call that allows to send single or multiple invitations to join the team.
Supports two parameter formats:
1. emails (set) + role (single role for all emails)
2. invitations (vector of {:email :role} maps for individual roles)"
{::doc/added "1.17"
::doc/module :teams
::sm/params schema:create-team-invitations}
[cfg {:keys [::rpc/profile-id team-id emails] :as params}]
[cfg {:keys [::rpc/profile-id team-id role emails] :as params}]
(let [perms (teams/get-permissions cfg profile-id team-id)
profile (db/get-by-id cfg :profile profile-id)
emails (into #{} (map profile/clean-email) emails)]
;; Determine which format is being used
using-emails-format? (and emails role)
;; Handle both parameter formats
emails (if using-emails-format?
(into #{} (map profile/clean-email) emails)
#{})
;; Calculate total invitation count for both formats
invitation-count (if using-emails-format?
(count emails)
(count (:invitations params)))]
(when-not (:is-admin perms)
(ex/raise :type :validation
:code :insufficient-permissions))
(when (> (count emails) max-invitations-by-request-threshold)
(when (> invitation-count max-invitations-by-request-threshold)
(ex/raise :type :validation
:code :max-invitations-by-request
:hint "the maximum of invitation on single request is reached"
@@ -288,7 +334,7 @@
(-> cfg
(assoc ::quotes/profile-id profile-id)
(assoc ::quotes/team-id team-id)
(assoc ::quotes/incr (count emails))
(assoc ::quotes/incr invitation-count)
(quotes/check! {::quotes/id ::quotes/invitations-per-team}
{::quotes/id ::quotes/profiles-per-team}))
@@ -304,7 +350,12 @@
(-> params
(assoc :profile profile)
(assoc :team team)
(assoc :emails emails)))]
;; Pass parameters in the correct format for the unified function
(cond-> using-emails-format?
;; If using emails+role format, ensure both are present
(assoc :emails emails :role role)
;; If using invitations format, the :invitations key is already in params
(not using-emails-format?) identity)))]
(with-meta {:total (count invitations)
:invitations invitations}
@@ -467,7 +518,7 @@
(defn- check-existing-team-access-request
"Checks if an existing team access request is still valid"
[conn team-id profile-id]
[{:keys [::db/conn]} team-id profile-id]
(when-let [request (db/get* conn :team-access-request
{:team-id team-id
:requester-id profile-id})]
@@ -485,8 +536,8 @@
(defn- upsert-team-access-request
"Create or update team access request for provided team and profile-id"
[conn team-id requester-id]
(check-existing-team-access-request conn team-id requester-id)
[{:keys [::db/conn] :as cfg} team-id requester-id]
(check-existing-team-access-request cfg team-id requester-id)
(let [valid-until (ct/in-future {:hours 24})
auto-join-until (ct/in-future {:days 7})
request-id (uuid/next)]
@@ -499,7 +550,7 @@
"A specific method for obtain a file with name and page-id used for
team request access procediment"
[cfg file-id]
(let [file (files/get-file cfg file-id :migrate? false)]
(let [file (bfc/get-file cfg file-id :migrate? false)]
(-> file
(dissoc :data)
(dissoc :deleted-at)
@@ -548,7 +599,7 @@
(teams/check-email-bounce conn (:email team-owner) false)
(teams/check-email-spam conn (:email team-owner) true)
(let [request (upsert-team-access-request conn team-id profile-id)
(let [request (upsert-team-access-request cfg team-id profile-id)
factory (cond
(and (some? file) (:is-default team) is-viewer)
eml/request-file-access-yourpenpot-view

2
backend/src/app/rpc/commands/verify_token.clj
View File

@@ -38,7 +38,7 @@
::doc/module :auth
::sm/params schema:verify-token}
[cfg {:keys [token] :as params}]
(let [claims (tokens/verify (::setup/props cfg) {:token token})]
(let [claims (tokens/verify cfg {:token token})]
(db/tx-run! cfg process-token params claims)))
(defmethod process-token :change-email

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

@@ -51,7 +51,7 @@
(defn- get-view-only-bundle
[{:keys [::db/conn] :as cfg} {:keys [profile-id file-id ::perms] :as params}]
(let [file (files/get-file cfg file-id)
(let [file (bfc/get-file cfg file-id)
project (db/get conn :project
{:id (:project-id file)}
@@ -81,7 +81,7 @@
libs (->> (bfc/get-file-libraries conn file-id)
(mapv (fn [{:keys [id] :as lib}]
(merge lib (files/get-file cfg id)))))
(merge lib (bfc/get-file cfg id)))))
links (->> (db/query conn :share-link {:file-id file-id})
(mapv (fn [row]

64
backend/src/app/rpc/rlimit.clj
View File

@@ -66,13 +66,6 @@
[integrant.core :as ig]
[promesa.exec :as px]))
(def ^:private default-timeout
(ct/duration 400))
(def ^:private default-options
{:codec rds/string-codec
:timeout default-timeout})
(def ^:private bucket-rate-limit-script
{::rscript/name ::bucket-rate-limit
::rscript/path "app/rpc/rlimit/bucket.lua"})
@@ -177,11 +170,11 @@
:hint (str/ffmt "looks like '%' does not have a valid format" opts))))
(defmethod process-limit :bucket
[redis user-id now {:keys [::key ::params ::service ::capacity ::interval ::rate] :as limit}]
[rconn user-id now {:keys [::key ::params ::service ::capacity ::interval ::rate] :as limit}]
(let [script (-> bucket-rate-limit-script
(assoc ::rscript/keys [(str key "." service "." user-id)])
(assoc ::rscript/vals (conj params (->seconds now))))
result (rds/eval redis script)
result (rds/eval rconn script)
allowed? (boolean (nth result 0))
remaining (nth result 1)
reset (* (/ (inst-ms interval) rate)
@@ -199,13 +192,13 @@
(assoc ::lresult/remaining remaining))))
(defmethod process-limit :window
[redis user-id now {:keys [::nreq ::unit ::key ::service] :as limit}]
[rconn user-id now {:keys [::nreq ::unit ::key ::service] :as limit}]
(let [ts (ct/truncate now unit)
ttl (ct/diff now (ct/plus ts {unit 1}))
script (-> window-rate-limit-script
(assoc ::rscript/keys [(str key "." service "." user-id "." (ct/format-inst ts))])
(assoc ::rscript/vals [nreq (->seconds ttl)]))
result (rds/eval redis script)
result (rds/eval rconn script)
allowed? (boolean (nth result 0))
remaining (nth result 1)]
(l/trace :hint "limit processed"
@@ -220,9 +213,9 @@
(assoc ::lresult/remaining remaining)
(assoc ::lresult/reset (ct/plus ts {unit 1})))))
(defn- process-limits!
[redis user-id limits now]
(let [results (into [] (map (partial process-limit redis user-id now)) limits)
(defn- process-limits
[rconn user-id limits now]
(let [results (into [] (map (partial process-limit rconn user-id now)) limits)
remaining (->> results
(d/index-by ::name ::lresult/remaining)
(uri/map->query-string))
@@ -259,34 +252,25 @@
(some-> request inet/parse-request)
uuid/zero)))
(defn process-request!
[{:keys [::rpc/rlimit ::rds/redis ::skey ::sname] :as cfg} params]
(when-let [limits (get-limits rlimit skey sname)]
(let [redis (rds/get-or-connect redis ::rpc/rlimit default-options)
uid (get-uid params)
;; FIXME: why not clasic try/catch?
result (ex/try! (process-limits! redis uid limits (ct/now)))]
(l/trc :hint "process-limits"
:service sname
:remaining (::remaingin result)
:reset (::reset result))
(cond
(ex/exception? result)
(do
(l/error :hint "error on processing rate-limit" :cause result)
{::enabled false})
(contains? cf/flags :soft-rpc-rlimit)
(defn- process-request'
[{:keys [::rds/conn] :as cfg} limits params]
(try
(let [uid (get-uid params)
result (process-limits conn uid limits (ct/now))]
(if (contains? cf/flags :soft-rpc-rlimit)
{::enabled false}
result))
(catch Throwable cause
(l/error :hint "error on processing rate-limit" :cause cause)
{::enabled false})))
:else
result))))
(defn- process-request
[{:keys [::rpc/rlimit ::skey ::sname] :as cfg} params]
(when-let [limits (get-limits rlimit skey sname)]
(rds/run! cfg process-request' limits params)))
(defn wrap
[{:keys [::rpc/rlimit ::rds/redis] :as cfg} f mdata]
(assert (rds/redis? redis) "expected a valid redis instance")
[{:keys [::rpc/rlimit] :as cfg} f mdata]
(assert (or (nil? rlimit) (valid-rlimit-instance? rlimit)) "expected a valid rlimit instance")
(if rlimit
@@ -298,7 +282,7 @@
(fn [hcfg params]
(if @enabled
(let [result (process-request! cfg params)]
(let [result (process-request cfg params)]
(if (::enabled result)
(if (::allowed result)
(-> (f hcfg params)
@@ -399,7 +383,7 @@
(when-let [path (cf/get :rpc-rlimit-config)]
(and (fs/exists? path) (fs/regular-file? path) path)))
(defmethod ig/assert-key :app.rpc/rlimit
(defmethod ig/assert-key ::rpc/rlimit
[_ {:keys [::wrk/executor]}]
(assert (sm/valid? ::wrk/executor executor) "expect valid executor"))

48
backend/src/app/setup/clock.clj Normal file
View File

@@ -0,0 +1,48 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.setup.clock
"A service/module that manages the system clock and allows runtime
modification of time offset (useful for testing and time adjustments)."
(:require
[app.common.logging :as l]
[app.common.time :as ct]
[app.setup :as-alias setup]
[integrant.core :as ig])
(:import
java.time.Clock
java.time.Duration))
(defonce current
(atom {:clock (Clock/systemDefaultZone)
:offset nil}))
(defmethod ig/init-key ::setup/clock
[_ _]
(add-watch current ::common
(fn [_ _ _ {:keys [clock offset]}]
(let [clock (if (ct/duration? offset)
(Clock/offset ^Clock clock
^Duration offset)
clock)]
(l/wrn :hint "altering clock" :clock (str clock))
(alter-var-root #'ct/*clock* (constantly clock))))))
(defmethod ig/halt-key! ::setup/clock
[_ _]
(remove-watch current ::common))
(defn set-offset!
[duration]
(swap! current assoc :offset (some-> duration ct/duration)))
(defn set-clock!
([]
(swap! current assoc :clock (Clock/systemDefaultZone)))
([clock]
(when (instance? Clock clock)
(swap! current assoc :clock clock))))

11
backend/src/app/srepl/cli.clj
View File

@@ -7,7 +7,7 @@
(ns app.srepl.cli
"PREPL API for external usage (CLI or ADMIN)"
(:require
[app.auth :as auth]
[app.auth :refer [derive-password]]
[app.common.exceptions :as ex]
[app.common.schema :as sm]
[app.common.schema.generators :as sg]
@@ -54,7 +54,7 @@
(some-> (get-current-system)
(db/tx-run!
(fn [{:keys [::db/conn] :as system}]
(let [password (cmd.profile/derive-password system password)
(let [password (derive-password password)
params {:id (uuid/next)
:email email
:fullname fullname
@@ -74,7 +74,7 @@
(assoc :fullname fullname)
(some? password)
(assoc :password (auth/derive-password password))
(assoc :password (derive-password password))
(some? is-active)
(assoc :is-active is-active))]
@@ -124,13 +124,12 @@
(defmethod exec-command "derive-password"
[{:keys [password]}]
(auth/derive-password password))
(derive-password password))
(defmethod exec-command "authenticate"
[{:keys [token]}]
(when-let [system (get-current-system)]
(let [props (get system ::setup/props)]
(tokens/verify props {:token token :iss "authentication"}))))
(tokens/verify system {:token token :iss "authentication"})))
(def ^:private schema:get-customer
[:map [:id ::sm/uuid]])

278
backend/src/app/srepl/fixes.clj
View File

@@ -1,278 +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.srepl.fixes
"A misc of fix functions"
(:refer-clojure :exclude [parse-uuid])
(:require
[app.binfile.common :as bfc]
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.files.changes :as cpc]
[app.common.files.helpers :as cfh]
[app.common.files.repair :as cfr]
[app.common.files.validate :as cfv]
[app.common.logging :as l]
[app.common.types.component :as ctk]
[app.common.types.container :as ctn]
[app.common.types.file :as ctf]
[app.common.uuid :as uuid]
[app.db :as db]
[app.features.fdata :as feat.fdata]
[app.srepl.helpers :as h]))
(defn disable-fdata-features
[{:keys [id features] :as file} _]
(when (or (contains? features "fdata/pointer-map")
(contains? features "fdata/objects-map"))
(l/warn :hint "disable fdata features" :file-id (str id))
(-> file
(update :data feat.fdata/process-pointers deref)
(update :data feat.fdata/process-objects (partial into {}))
(update :features disj "fdata/pointer-map" "fdata/objects-map"))))
(def sql:get-fdata-files
"SELECT id FROM file
WHERE deleted_at is NULL
AND (features @> '{fdata/pointer-map}' OR
features @> '{fdata/objects-map}')
ORDER BY created_at DESC")
(defn find-fdata-pointers
[{:keys [id features data] :as file} _]
(when (contains? features "fdata/pointer-map")
(let [pointers (feat.fdata/get-used-pointer-ids data)]
(l/warn :hint "found pointers" :file-id (str id) :pointers pointers)
nil)))
(defn repair-file-media
"A helper intended to be used with `srepl.main/process-files!` that
fixes all not propertly referenced file-media-object for a file"
[{:keys [id data] :as file} & _]
(let [conn (db/get-connection h/*system*)
used (cfh/collect-used-media data)
ids (db/create-array conn "uuid" used)
sql "SELECT * FROM file_media_object WHERE id = ANY(?)"
rows (db/exec! conn [sql ids])
index (reduce (fn [index media]
(if (not= (:file-id media) id)
(let [media-id (uuid/next)]
(l/wrn :hint "found not referenced media"
:file-id (str id)
:media-id (str (:id media)))
(db/insert! conn :file-media-object
(-> media
(assoc :file-id id)
(assoc :id media-id)))
(assoc index (:id media) media-id))
index))
{}
rows)]
(when (seq index)
(binding [bfc/*state* (atom {:index index})]
(update file :data (fn [fdata]
(-> fdata
(update :pages-index #'bfc/relink-shapes)
(update :components #'bfc/relink-shapes)
(update :media #'bfc/relink-media)
(d/without-nils))))))))
(defn repair-file
"Internal helper for validate and repair the file. The operation is
applied multiple times untile file is fixed or max iteration counter
is reached (default 10)"
[file libs & {:keys [max-iterations] :or {max-iterations 10}}]
(let [validate-and-repair
(fn [file libs iteration]
(when-let [errors (not-empty (cfv/validate-file file libs))]
(l/trc :hint "repairing file"
:file-id (str (:id file))
:iteration iteration
:errors (count errors))
(let [changes (cfr/repair-file file libs errors)]
(-> file
(update :revn inc)
(update :data cpc/process-changes changes)))))
process-file
(fn [file libs]
(loop [file file
iteration 0]
(if (< iteration max-iterations)
(if-let [file (validate-and-repair file libs iteration)]
(recur file (inc iteration))
file)
(do
(l/wrn :hint "max retry num reached on repairing file"
:file-id (str (:id file))
:iteration iteration)
file))))
file'
(process-file file libs)]
(when (not= (:revn file) (:revn file'))
(l/trc :hint "file repaired" :file-id (str (:id file))))
file'))
(defn fix-touched-shapes-group
[file _]
;; Remove :shapes-group from the touched elements
(letfn [(fix-fdata [data]
(-> data
(update :pages-index update-vals fix-container)))
(fix-container [container]
(d/update-when container :objects update-vals fix-shape))
(fix-shape [shape]
(d/update-when shape :touched
(fn [touched]
(disj touched :shapes-group))))]
file (-> file
(update :data fix-fdata))))
(defn add-swap-slots
[file libs _opts]
;; Detect swapped copies and try to generate a valid swap-slot.
(letfn [(process-fdata [data]
;; Walk through all containers in the file, both pages and deleted components.
(reduce process-container data (ctf/object-containers-seq data)))
(process-container [data container]
;; Walk through all shapes in depth-first tree order.
(l/dbg :hint "Processing container" :type (:type container) :name (:name container))
(let [root-shape (ctn/get-container-root container)]
(ctf/update-container data
container
#(reduce process-shape % (ctn/get-direct-children container root-shape)))))
(process-shape [container shape]
;; Look for head copies in the first level (either component roots or inside main components).
;; Even if they have been swapped, we don't add slot to them because there is no way to know
;; the original shape. Only children.
(if (and (ctk/instance-head? shape)
(ctk/in-component-copy? shape)
(nil? (ctk/get-swap-slot shape)))
(process-copy-head container shape)
(reduce process-shape container (ctn/get-direct-children container shape))))
(process-copy-head [container head-shape]
;; Process recursively all children, comparing each one with the corresponding child in the main
;; component, looking by position. If the shape-ref does not point to the found child, then it has
;; been swapped and need to set up a slot.
(l/trc :hint "Processing copy-head" :id (:id head-shape) :name (:name head-shape))
(let [component-shape (ctf/find-ref-shape file container libs head-shape :include-deleted? true :with-context? true)
component-container (:container (meta component-shape))]
(loop [container container
children (map #(ctn/get-shape container %) (:shapes head-shape))
component-children (map #(ctn/get-shape component-container %) (:shapes component-shape))]
(let [child (first children)
component-child (first component-children)]
(if (or (nil? child) (nil? component-child))
container
(let [container (if (and (not (ctk/is-main-of? component-child child))
(nil? (ctk/get-swap-slot child))
(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) #(ctk/set-swap-slot % slot)))
container)]
(recur (process-copy-head container child)
(rest children)
(rest component-children))))))))
(guess-swap-slot [shape container]
;; To guess the slot, we must follow the chain until we find the definitive main. But
;; we cannot navigate by shape-ref, because main shapes may also have been swapped. So
;; chain by position, too.
(if-let [slot (ctk/get-swap-slot shape)]
slot
(if-not (ctk/in-component-copy? shape)
(:id shape)
(let [head-copy (ctn/get-component-shape (:objects container) shape)]
(if (= (:id head-copy) (:id shape))
(:id shape)
(let [head-main (ctf/find-ref-shape file
container
libs
head-copy
:include-deleted? true
:with-context? true)
container-main (:container (meta head-main))
shape-main (find-match-by-position shape
head-copy
container
head-main
container-main)]
(guess-swap-slot shape-main container-main)))))))
(find-match-by-position [shape-copy head-copy container-copy head-main container-main]
;; Find the shape in the main that has the same position under its parent than
;; the copy under its one. To get the parent we must process recursively until
;; the component head, because mains may also have been swapped.
(let [parent-copy (ctn/get-shape container-copy (:parent-id shape-copy))
parent-main (if (= (:id parent-copy) (:id head-copy))
head-main
(find-match-by-position parent-copy
head-copy
container-copy
head-main
container-main))
index (cfh/get-position-on-parent (:objects container-copy)
(:id shape-copy))
shape-main-id (dm/get-in parent-main [:shapes index])]
(ctn/get-shape container-main shape-main-id)))]
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))

88
backend/src/app/srepl/fixes/lost_colors.clj
View File

@@ -1,88 +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.srepl.fixes.lost-colors
"A collection of adhoc fixes scripts."
(:require
[app.binfile.common :as bfc]
[app.common.logging :as l]
[app.common.types.color :as types.color]
[app.db :as db]
[app.srepl.helpers :as h]))
(def sql:get-affected-files
"SELECT fm.file_id AS id FROM file_migration AS fm WHERE fm.name = '0008-fix-library-colors-v2'")
(def sql:get-matching-snapshot
"SELECT * FROM file_change
WHERE file_id = ?
AND created_at <= ?
AND label IS NOT NULL
AND data IS NOT NULL
ORDER BY created_at DESC
LIMIT 2")
(defn get-affected-migration
[conn file-id]
(db/get* conn :file-migration
{:name "0008-fix-library-colors-v2"
:file-id file-id}))
(defn get-last-valid-snapshot
[conn migration]
(let [[snapshot] (db/exec! conn [sql:get-matching-snapshot
(:file-id migration)
(:created-at migration)])]
(when snapshot
(let [snapshot (assoc snapshot :id (:file-id snapshot))]
(bfc/decode-file h/*system* snapshot)))))
(defn restore-color
[{:keys [data] :as snapshot} color]
(when-let [scolor (get-in data [:colors (:id color)])]
(-> (select-keys scolor types.color/library-color-attrs)
(types.color/check-library-color))))
(defn restore-missing-colors
[{:keys [id] :as file} & _opts]
(l/inf :hint "process file" :file-id (str id) :name (:name file) :has-colors (-> file :data :colors not-empty boolean))
(if-let [colors (-> file :data :colors not-empty)]
(let [migration (get-affected-migration h/*system* id)]
(if-let [snapshot (get-last-valid-snapshot h/*system* migration)]
(do
(l/inf :hint "using snapshot" :snapshot (:label snapshot))
(let [colors (reduce-kv (fn [colors color-id color]
(if-let [result (restore-color snapshot color)]
(do
(l/inf :hint "restored color" :file-id (str id) :color-id (str color-id))
(assoc colors color-id result))
(do
(l/wrn :hint "ignoring color" :file-id (str id) :color (pr-str color))
colors)))
colors
colors)
file (-> file
(update :data assoc :colors colors)
(update :migrations disj "0008-fix-library-colors-v2"))]
(db/delete! h/*system* :file-migration
{:name "0008-fix-library-colors-v2"
:file-id (:id file)})
file))
(do
(db/delete! h/*system* :file-migration
{:name "0008-fix-library-colors-v2"
:file-id (:id file)})
nil)))
(do
(db/delete! h/*system* :file-migration
{:name "0008-fix-library-colors-v2"
:file-id (:id file)})
nil)))

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

@@ -14,9 +14,8 @@
[app.common.files.validate :as cfv]
[app.common.time :as ct]
[app.db :as db]
[app.main :as main]
[app.rpc.commands.files :as files]
[app.rpc.commands.files-snapshot :as fsnap]))
[app.features.file-snapshots :as fsnap]
[app.main :as main]))
(def ^:dynamic *system* nil)
@@ -48,7 +47,7 @@
([system id]
(db/run! system
(fn [system]
(files/get-file system id :migrate? false)))))
(bfc/get-file system id :decode? false)))))
(defn update-team!
[system {:keys [id] :as team}]
@@ -118,10 +117,10 @@
(let [conn (db/get-connection system)]
(->> (get-and-lock-team-files conn team-id)
(reduce (fn [result file-id]
(let [file (fsnap/get-file-snapshots system file-id)]
(fsnap/create-file-snapshot! system file
(let [file (bfc/get-file system file-id :realize? true :lock-for-update? true)]
(fsnap/create! system file
{:label label
:created-by :admin})
:created-by "admin"})
(inc result)))
0))))
@@ -132,21 +131,34 @@
(into #{}))
snap (search-file-snapshots conn ids label)
ids' (into #{} (map :file-id) snap)]
(when (not= ids ids')
(throw (RuntimeException. "no uniform snapshot available")))
(reduce (fn [result {:keys [file-id id]}]
(fsnap/restore-file-snapshot! system file-id id)
(fsnap/restore! system file-id id)
(inc result))
0
snap)))
(defn mark-migrated!
"A helper that inserts an entry in the file migration table for make
file migrated for the specified migration label."
[system file-id label]
(db/insert! system :file-migration
{:file-id file-id
:name label}
{::db/return-keys false}))
(defn process-file!
[system file-id update-fn & {:keys [label validate? with-libraries?] :or {validate? true} :as opts}]
(let [file (bfc/get-file system file-id ::db/for-update true)
[system file-id update-fn
& {:keys [::snapshot-label ::validate? ::with-libraries?]
:or {validate? true} :as opts}]
(let [file (bfc/get-file system file-id
:lock-for-update? true
:realize? true)
libs (when with-libraries?
(bfc/get-resolved-file-libraries system file))
@@ -162,12 +174,12 @@
(when validate?
(cfv/validate-file-schema! file'))
(when (string? label)
(fsnap/create-file-snapshot! system file
{:label label
(when (string? snapshot-label)
(fsnap/create! system file
{:label snapshot-label
:deleted-at (ct/in-future {:days 30})
:created-by :admin}))
:created-by "admin"}))
(let [file' (update file' :revn inc)]
(bfc/update-file! system file')
(bfc/update-file! system file' opts)
true))))

236
backend/src/app/srepl/main.clj
View File

@@ -5,7 +5,6 @@
;; Copyright (c) KALEIDOS INC
(ns app.srepl.main
"A collection of adhoc fixes scripts."
#_:clj-kondo/ignore
(:require
[app.auth :refer [derive-password]]
@@ -24,19 +23,19 @@
[app.config :as cf]
[app.db :as db]
[app.db.sql :as-alias sql]
[app.features.fdata :as feat.fdata]
[app.features.fdata :as fdata]
[app.features.file-snapshots :as fsnap]
[app.loggers.audit :as audit]
[app.main :as main]
[app.msgbus :as mbus]
[app.rpc.commands.auth :as auth]
[app.rpc.commands.files :as files]
[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.srepl.procs.file-repair :as procs.file-repair]
[app.util.blob :as blob]
[app.util.pointer-map :as pmap]
[app.worker :as wrk]
@@ -48,6 +47,7 @@
[cuerdas.core :as str]
[datoteka.fs :as fs]
[promesa.exec :as px]
[promesa.exec.csp :as sp]
[promesa.exec.semaphore :as ps]
[promesa.util :as pu]))
@@ -147,25 +147,6 @@
;; FEATURES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare process-file!)
(defn enable-objects-map-feature-on-file!
[file-id & {:as opts}]
(process-file! file-id feat.fdata/enable-objects-map opts))
(defn enable-pointer-map-feature-on-file!
[file-id & {:as opts}]
(process-file! file-id feat.fdata/enable-pointer-map opts))
(defn enable-path-data-feature-on-file!
[file-id & {:as opts}]
(process-file! file-id feat.fdata/enable-path-data opts))
(defn enable-storage-features-on-file!
[file-id & {:as opts}]
(enable-objects-map-feature-on-file! file-id opts)
(enable-pointer-map-feature-on-file! file-id opts))
(defn enable-team-feature!
[team-id feature & {:keys [skip-check] :or {skip-check false}}]
(when (and (not skip-check) (not (contains? cfeat/supported-features feature)))
@@ -339,7 +320,10 @@
collectable file-changes entry."
[& {:keys [file-id label]}]
(let [file-id (h/parse-uuid file-id)]
(db/tx-run! main/system fsnap/create-file-snapshot! {:file-id file-id :label label})))
(db/tx-run! main/system
(fn [cfg]
(let [file (bfc/get-file cfg file-id :realize? true)]
(fsnap/create! cfg file {:label label :created-by "admin"}))))))
(defn restore-file-snapshot!
[file-id & {:keys [label id]}]
@@ -349,13 +333,13 @@
(fn [{:keys [::db/conn] :as system}]
(cond
(uuid? snapshot-id)
(fsnap/restore-file-snapshot! system file-id snapshot-id)
(fsnap/restore! system file-id snapshot-id)
(string? label)
(->> (h/search-file-snapshots conn #{file-id} label)
(map :id)
(first)
(fsnap/restore-file-snapshot! system file-id))
(fsnap/restore! system file-id))
:else
(throw (ex-info "snapshot id or label should be provided" {})))))))
@@ -364,9 +348,9 @@
[file-id & {:as _}]
(let [file-id (h/parse-uuid file-id)]
(db/tx-run! main/system
(fn [{:keys [::db/conn]}]
(->> (fsnap/get-file-snapshots conn file-id)
(print-table [:label :id :revn :created-at]))))))
(fn [cfg]
(->> (fsnap/get-visible-snapshots cfg file-id)
(print-table [:label :id :revn :created-at :created-by]))))))
(defn take-team-snapshot!
[team-id & {:keys [label rollback?] :or {rollback? true}}]
@@ -413,24 +397,19 @@
(println (sm/humanize-explain explain))
(ex/print-throwable cause))))))))
(defn repair-file!
"Repair the list of errors detected by validation."
[file-id & {:keys [rollback?] :or {rollback? true} :as opts}]
(let [system (assoc main/system ::db/rollback rollback?)
file-id (h/parse-uuid file-id)
opts (assoc opts :with-libraries? true)]
(db/tx-run! system h/process-file! file-id fixes/repair-file opts)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PROCESSING
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def sql:get-files
"SELECT id FROM file
WHERE deleted_at is NULL
ORDER BY created_at DESC")
(defn repair-file!
"Repair the list of errors detected by validation."
[file-id & {:keys [rollback?] :or {rollback? true} :as options}]
(let [system (assoc main/system ::db/rollback rollback?)
file-id (h/parse-uuid file-id)
options (assoc options ::h/with-libraries? true)]
(db/tx-run! system h/process-file! file-id procs.file-repair/repair-file options)))
(defn process-file!
(defn update-file!
"Apply a function to the file. Optionally save the changes or not.
The function receives the decoded and migrated file data."
[file-id update-fn & {:keys [rollback?] :or {rollback? true} :as opts}]
@@ -441,114 +420,117 @@
db/*conn* (db/get-connection system)]
(h/process-file! system file-id update-fn opts))))))
(defn process-team-files!
"Apply a function to each file of the specified team."
[team-id update-fn & {:keys [rollback? label] :or {rollback? true} :as opts}]
(let [team-id (h/parse-uuid team-id)
opts (dissoc opts :label)]
(db/tx-run! (assoc main/system ::db/rollback rollback?)
(fn [{:keys [::db/conn] :as system}]
(when (string? label)
(h/take-team-snapshot! system team-id label))
(binding [h/*system* system
db/*conn* (db/get-connection system)]
(->> (h/get-and-lock-team-files conn team-id)
(reduce (fn [result file-id]
(if (h/process-file! system file-id update-fn opts)
(inc result)
result))
0)))))))
(defn process-files!
"Apply a function to all files in the database"
[update-fn & {:keys [max-items
(defn process!
[& {:keys [max-items
max-jobs
rollback?
query]
:or {max-jobs 1
max-items Long/MAX_VALUE
query
proc-fn
buffer]
:or {max-items Long/MAX_VALUE
rollback? true
query sql:get-files}
max-jobs 1
buffer 128}
:as opts}]
(l/dbg :hint "process:start"
(l/inf :hint "process start"
:rollback rollback?
:max-jobs max-jobs
:max-items max-items)
(let [tpoint (ct/tpoint)
factory (px/thread-factory :virtual false :prefix "penpot/file-process/")
executor (px/cached-executor :factory factory)
sjobs (ps/create :permits max-jobs)
max-jobs (or max-jobs (px/get-available-processors))
query (or query
(:query (meta proc-fn))
(throw (ex-info "missing query" {})))
query (if (vector? query) query [query])
process-file
(fn [file-id idx tpoint]
(let [thread-id (px/get-thread-id)]
proc-fn (if (var? proc-fn)
(deref proc-fn)
proc-fn)
in-ch (sp/chan :buf buffer)
worker-fn
(fn [worker-id]
(l/dbg :hint "worker started"
:id worker-id)
(loop []
(when-let [[index item] (sp/<! in-ch)]
(l/dbg :hint "process item" :worker-id worker-id :index index :item item)
(try
(l/trc :hint "process:file:start"
:tid thread-id
:file-id (str file-id)
:index idx)
(let [system (assoc main/system ::db/rollback rollback?)]
(db/tx-run! system (fn [system]
(-> main/system
(assoc ::db/rollback rollback?)
(db/tx-run! (fn [system]
(binding [h/*system* system
db/*conn* (db/get-connection system)]
(h/process-file! system file-id update-fn opts)))))
(proc-fn system item opts)))))
(catch Throwable cause
(l/wrn :hint "unexpected error on processing file (skiping)"
:tid thread-id
:file-id (str file-id)
:index idx
(l/wrn :hint "unexpected error on processing item (skiping)"
:worker-id worker-id
:item item
:cause cause))
(finally
(when-let [pause (:pause opts)]
(Thread/sleep (int pause)))
(Thread/sleep (int pause)))))
(ps/release! sjobs)
(let [elapsed (ct/format-duration (tpoint))]
(l/trc :hint "process:file:end"
:tid thread-id
:file-id (str file-id)
:index idx
:elapsed elapsed))))))
(recur)))
process-file*
(fn [idx file-id]
(ps/acquire! sjobs)
(px/run! executor (partial process-file file-id idx (ct/tpoint)))
(inc idx))
(l/dbg :hint "worker stoped"
:id worker-id))
process-files
enqueue-item
(fn [index row]
(sp/>! in-ch [index (into {} row)])
(inc index))
process-items
(fn [{:keys [::db/conn] :as system}]
(db/exec! conn ["SET statement_timeout = 0"])
(db/exec! conn ["SET idle_in_transaction_session_timeout = 0"])
(try
(->> (db/plan conn [query])
(transduce (comp
(take max-items)
(map :id))
(completing process-file*)
(->> (db/plan conn query {:fetch-size (* max-jobs 3)})
(transduce (take max-items)
(completing enqueue-item)
0))
(finally
;; Close and await tasks
(pu/close! executor))))]
(sp/close! in-ch))
threads
(->> (range max-jobs)
(map (fn [idx]
(px/fn->thread (partial worker-fn idx)
:name (str "pentpot/process/" idx))))
(doall))]
(try
(db/tx-run! main/system process-files)
(db/tx-run! main/system process-items)
;; Await threads termination
(doseq [thread threads]
(px/await! thread))
(catch Throwable cause
(l/dbg :hint "process:error" :cause cause))
(finally
(let [elapsed (ct/format-duration (tpoint))]
(l/dbg :hint "process:end"
(l/inf :hint "process end"
:rollback rollback?
:elapsed elapsed))))))
(defn process-file!
"A specialized, file specific process! alternative"
[& {:keys [id] :as opts}]
(let [id (h/parse-uuid id)]
(-> opts
(assoc :query ["select id from file where id = ?" id])
(assoc :max-items 1)
(assoc :max-jobs 1)
(process!))))
(defn mark-file-as-trimmed
[id]
(let [id (h/parse-uuid id)]
@@ -590,25 +572,34 @@
(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
{:id file-id}
{::db/return-keys false})
(db/update! conn :file-media-object
{:deleted-at nil}
{:file-id file-id})
{:file-id file-id}
{::db/return-keys false})
(db/update! conn :file-change
{:deleted-at nil}
{:file-id file-id}
{::db/return-keys false})
(db/update! conn :file-data
{:deleted-at nil}
{:file-id file-id}
{::db/return-keys false})
;; Mark thumbnails to be deleted
(db/update! conn :file-thumbnail
{:deleted-at nil}
{:file-id file-id})
{:file-id file-id}
{::db/return-keys false})
(db/update! conn :file-tagged-object-thumbnail
{:deleted-at nil}
{:file-id file-id})
{:file-id file-id}
{::db/return-keys false})
:restored)
@@ -618,11 +609,10 @@
(let [file-id (h/parse-uuid file-id)]
(db/tx-run! main/system
(fn [system]
(when-let [file (some-> (db/get* system :file
(when-let [file (db/get* system :file
{:id file-id}
{::db/remove-deleted false
::sql/columns [:id :name]})
(files/decode-row))]
::sql/columns [:id :name]})]
(audit/insert! system
{::audit/name "restore-file"
::audit/type "action"

141
backend/src/app/srepl/procs/fdata_storage.clj Normal file
View File

@@ -0,0 +1,141 @@
;; 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.srepl.procs.fdata-storage
(:require
[app.common.logging :as l]
[app.db :as db]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SNAPSHOTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def sql:get-unmigrated-snapshots
"SELECT fc.id, fc.file_id
FROM file_change AS fc
WHERE fc.data IS NOT NULL
AND fc.label IS NOT NULL
ORDER BY fc.id ASC")
(def sql:get-migrated-snapshots
"SELECT f.id, f.file_id
FROM file_data AS f
WHERE f.data IS NOT NULL
AND f.type = 'snapshot'
AND f.id != f.file_id
ORDER BY f.id ASC")
(defn migrate-snapshot-to-storage
"Migrate the current existing files to store data in new storage
tables."
{:query sql:get-unmigrated-snapshots}
[{:keys [::db/conn]} {:keys [id file-id]} & {:as options}]
(let [{:keys [id file-id data created-at updated-at]}
(db/get* conn :file-change {:id id :file-id file-id}
::db/for-update true
::db/remove-deleted false)]
(when data
(l/inf :hint "migrating snapshot" :file-id (str file-id) :id (str id))
(db/update! conn :file-change
{:data nil}
{:id id :file-id file-id}
{::db/return-keys false})
(db/insert! conn :file-data
{:backend "db"
:metadata nil
:type "snapshot"
:data data
:created-at created-at
:modified-at updated-at
:file-id file-id
:id id}
{::db/return-keys false}))))
(defn rollback-snapshot-from-storage
"Migrate back to the file table storage."
{:query sql:get-unmigrated-snapshots}
[{:keys [::db/conn]} {:keys [id file-id]} & {:as opts}]
(when-let [{:keys [id file-id data]}
(db/get* conn :file-data {:id id :file-id file-id :type "snapshot"}
::db/for-update true
::db/remove-deleted false)]
(l/inf :hint "rollback snapshot" :file-id (str file-id) :id (str id))
(db/update! conn :file-change
{:data data}
{:id id :file-id file-id}
{::db/return-keys false})
(db/delete! conn :file-data
{:id id :file-id file-id :type "snapshot"}
{::db/return-keys false})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FILES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def sql:get-unmigrated-files
"SELECT f.id
FROM file AS f
WHERE f.data IS NOT NULL
ORDER BY f.modified_at ASC")
(def sql:get-migrated-files
"SELECT f.id, f.file_id
FROM file_data AS f
WHERE f.data IS NOT NULL
AND f.id = f.file_id
ORDER BY f.id ASC")
(defn migrate-file-to-storage
"Migrate the current existing files to store data in new storage
tables."
{:query sql:get-unmigrated-files}
[{:keys [::db/conn] :as cfg} {:keys [id]} & {:as opts}]
(let [{:keys [id data created-at modified-at]}
(db/get* conn :file {:id id}
::db/for-update true
::db/remove-deleted false)]
(when data
(l/inf :hint "migrating file" :file-id (str id))
(db/update! conn :file {:data nil} {:id id} ::db/return-keys false)
(db/insert! conn :file-data
{:backend "db"
:metadata nil
:type "main"
:data data
:created-at created-at
:modified-at modified-at
:file-id id
:id id}
{::db/return-keys false}))
(let [snapshots-sql
(str "WITH snapshots AS (" sql:get-unmigrated-snapshots ") "
"SELECT s.* FROM snapshots AS s WHERE s.file_id = ?")]
(run! (fn [params]
(migrate-snapshot-to-storage cfg params opts))
(db/plan cfg [snapshots-sql id])))))
(defn rollback-file-from-storage
"Migrate back to the file table storage."
{:query sql:get-migrated-files}
[{:keys [::db/conn] :as cfg} {:keys [id]} & {:as opts}]
(when-let [{:keys [id data]}
(db/get* conn :file-data {:id id :file-id id :type "main"}
::db/for-update true
::db/remove-deleted false)]
(l/inf :hint "rollback file" :file-id (str id))
(db/update! conn :file {:data data} {:id id} ::db/return-keys false)
(db/delete! conn :file-data {:file-id id :id id :type "main"} ::db/return-keys false)
(let [snapshots-sql
(str "WITH snapshots AS (" sql:get-migrated-snapshots ") "
"SELECT s.* FROM snapshots AS s WHERE s.file_id = ?")]
(run! (fn [params]
(rollback-snapshot-from-storage cfg params opts))
(db/plan cfg [snapshots-sql id])))))

60
backend/src/app/srepl/procs/file_repair.clj Normal file
View File

@@ -0,0 +1,60 @@
;; 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.srepl.procs.file-repair
(:require
[app.common.files.changes :as cfc]
[app.common.files.repair :as cfr]
[app.common.files.validate :as cfv]
[app.common.logging :as l]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GENERAL PURPOSE REPAIR
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn repair-file
"Internal helper for validate and repair the file. The operation is
applied multiple times untile file is fixed or max iteration counter
is reached (default 10).
This function should not be used directly, it is used throught the
app.srepl.main/repair-file! helper. In practical terms this function
is private and implementation detail."
[file libs & {:keys [max-iterations] :or {max-iterations 10}}]
(let [validate-and-repair
(fn [file libs iteration]
(when-let [errors (not-empty (cfv/validate-file file libs))]
(l/trc :hint "repairing file"
:file-id (str (:id file))
:iteration iteration
:errors (count errors))
(let [changes (cfr/repair-file file libs errors)]
(-> file
(update :revn inc)
(update :data cfc/process-changes changes)))))
process-file
(fn [file libs]
(loop [file file
iteration 0]
(if (< iteration max-iterations)
(if-let [file (validate-and-repair file libs iteration)]
(recur file (inc iteration))
file)
(do
(l/wrn :hint "max retry num reached on repairing file"
:file-id (str (:id file))
:iteration iteration)
file))))
file'
(process-file file libs)]
(when (not= (:revn file) (:revn file'))
(l/trc :hint "file repaired" :file-id (str (:id file))))
file'))

26
backend/src/app/srepl/fixes/media_refs.clj → backend/src/app/srepl/procs/media_refs.clj
View File

@@ -4,10 +4,11 @@
;;
;; Copyright (c) KALEIDOS INC
(ns app.srepl.fixes.media-refs
(ns app.srepl.procs.media-refs
(:require
[app.binfile.common :as bfc]
[app.common.files.helpers :as cfh]
[app.common.logging :as l]
[app.srepl.helpers :as h]))
(defn- collect-media-refs
@@ -37,7 +38,22 @@
(let [media-refs (collect-media-refs (:data file))]
(bfc/update-media-references! cfg file media-refs)))
(defn process-file
[file _opts]
(let [system (h/get-current-system)]
(update-all-media-references system file)))
(def ^:private sql:get-files
"SELECT f.id
FROM file AS f
LEFT JOIN file_migration AS fm ON (fm.file_id = f.id AND fm.name = 'internal/procs/media-refs')
WHERE fm.name IS NULL
ORDER BY f.project_id")
(defn fix-media-refs
{:query sql:get-files}
[cfg {:keys [id]} & {:as options}]
(l/inf :hint "processing file" :id (str id))
(h/process-file! cfg id
(fn [file _opts]
(update-all-media-references cfg file))
(assoc options
::bfc/reset-migrations? true
::h/validate? false))
(h/mark-migrated! cfg id "internal/procs/media-refs"))

57
backend/src/app/srepl/procs/path_data.clj Normal file
View File

@@ -0,0 +1,57 @@
;; 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.srepl.procs.path-data
(:require
[app.binfile.common :as bfc]
[app.common.data :as d]
[app.common.files.helpers :as cfh]
[app.common.logging :as l]
[app.srepl.helpers :as h]))
(def ^:private sql:get-files-with-path-data
"SELECT id FROM file WHERE features @> '{fdata/path-data}'")
(defn disable
"A script responsible for remove the path data type from file data and
allow file to be open in older penpot versions.
Should be used only in cases when you want to downgrade to an older
penpot version for some reason."
{:query sql:get-files-with-path-data}
[cfg {:keys [id]} & {:as options}]
(l/inf :hint "disabling path-data" :file-id (str id))
(let [update-object
(fn [object]
(if (or (cfh/path-shape? object)
(cfh/bool-shape? object))
(update object :content vec)
object))
update-container
(fn [container]
(d/update-when container :objects d/update-vals update-object))
update-file
(fn [file & _opts]
(-> file
(update :data (fn [data]
(-> data
(update :pages-index d/update-vals update-container)
(d/update-when :components d/update-vals update-container))))
(update :features disj "fdata/path-data")
(update :migrations disj
"0003-convert-path-content-v2"
"0003-convert-path-content")))
options
(-> options
(assoc ::bfc/reset-migrations? true)
(assoc ::h/validate? false))]
(h/process-file! cfg id update-file options)))

11
backend/src/app/storage.clj
View File

@@ -27,7 +27,9 @@
(defn get-legacy-backend
[]
(let [name (cf/get :assets-storage-backend)]
(when-let [name (cf/get :assets-storage-backend)]
(l/wrn :hint "using deprecated configuration, please read 2.11 release notes"
:href "https://github.com/penpot/penpot/releases/tag/2.11.0")
(case name
:assets-fs :fs
:assets-s3 :s3
@@ -113,13 +115,10 @@
(defn- create-database-object
[{:keys [::backend ::db/connectable]} {:keys [::content ::expired-at ::touched-at ::touch] :as params}]
(let [id (or (:id params) (uuid/random))
(let [id (or (::id params) (uuid/random))
mdata (cond-> (get-metadata params)
(satisfies? impl/IContentHash content)
(assoc :hash (impl/get-hash content))
:always
(dissoc :id))
(assoc :hash (impl/get-hash content)))
touched-at (if touch
(or touched-at (ct/now))

92
backend/src/app/storage/gc_touched.clj
View File

@@ -34,7 +34,7 @@
(SELECT EXISTS (SELECT 1 FROM team_font_variant WHERE ttf_file_id = ?))) AS has_refs")
(defn- has-team-font-variant-refs?
[conn id]
[conn {:keys [id]}]
(-> (db/exec-one! conn [sql:has-team-font-variant-refs id id id id])
(get :has-refs)))
@@ -44,7 +44,7 @@
(SELECT EXISTS (SELECT 1 FROM file_media_object WHERE thumbnail_id = ?))) AS has_refs")
(defn- has-file-media-object-refs?
[conn id]
[conn {:keys [id]}]
(-> (db/exec-one! conn [sql:has-file-media-object-refs id id])
(get :has-refs)))
@@ -53,7 +53,7 @@
(SELECT EXISTS (SELECT 1 FROM team WHERE photo_id = ?))) AS has_refs")
(defn- has-profile-refs?
[conn id]
[conn {:keys [id]}]
(-> (db/exec-one! conn [sql:has-profile-refs id id])
(get :has-refs)))
@@ -62,7 +62,7 @@
"SELECT EXISTS (SELECT 1 FROM file_tagged_object_thumbnail WHERE media_id = ?) AS has_refs")
(defn- has-file-object-thumbnails-refs?
[conn id]
[conn {:keys [id]}]
(-> (db/exec-one! conn [sql:has-file-object-thumbnail-refs id])
(get :has-refs)))
@@ -71,36 +71,23 @@
"SELECT EXISTS (SELECT 1 FROM file_thumbnail WHERE media_id = ?) AS has_refs")
(defn- has-file-thumbnails-refs?
[conn id]
[conn {:keys [id]}]
(-> (db/exec-one! conn [sql:has-file-thumbnail-refs id])
(get :has-refs)))
(def ^:private
sql:has-file-data-refs
"SELECT EXISTS (SELECT 1 FROM file WHERE data_ref_id = ?) AS has_refs")
(def sql:exists-file-data-refs
"SELECT EXISTS (
SELECT 1 FROM file_data
WHERE file_id = ?
AND id = ?
AND metadata->>'storage-ref-id' = ?::text
) AS has_refs")
(defn- has-file-data-refs?
[conn id]
(-> (db/exec-one! conn [sql:has-file-data-refs id])
(get :has-refs)))
(def ^:private
sql:has-file-data-fragment-refs
"SELECT EXISTS (SELECT 1 FROM file_data_fragment WHERE data_ref_id = ?) AS has_refs")
(defn- has-file-data-fragment-refs?
[conn id]
(-> (db/exec-one! conn [sql:has-file-data-fragment-refs id])
(get :has-refs)))
(def ^:private
sql:has-file-change-refs
"SELECT EXISTS (SELECT 1 FROM file_change WHERE data_ref_id = ?) AS has_refs")
(defn- has-file-change-refs?
[conn id]
(-> (db/exec-one! conn [sql:has-file-change-refs id])
(get :has-refs)))
[conn sobject]
(let [{:keys [file-id id]} (:metadata sobject)]
(-> (db/exec-one! conn [sql:exists-file-data-refs file-id id (:id sobject)])
(get :has-refs))))
(def ^:private sql:mark-freeze-in-bulk
"UPDATE storage_object
@@ -143,52 +130,48 @@
"file-media-object"))
(defn- process-objects!
[conn has-refs? ids bucket]
[conn has-refs? bucket objects]
(loop [to-freeze #{}
to-delete #{}
ids (seq ids)]
(if-let [id (first ids)]
(if (has-refs? conn id)
objects (seq objects)]
(if-let [{:keys [id] :as object} (first objects)]
(if (has-refs? conn object)
(do
(l/debug :hint "processing object"
:id (str id)
(l/debug :id (str id)
:status "freeze"
:bucket bucket)
(recur (conj to-freeze id) to-delete (rest ids)))
(recur (conj to-freeze id) to-delete (rest objects)))
(do
(l/debug :hint "processing object"
:id (str id)
(l/debug :id (str id)
:status "delete"
:bucket bucket)
(recur to-freeze (conj to-delete id) (rest ids))))
(recur to-freeze (conj to-delete id) (rest objects))))
(do
(some->> (seq to-freeze) (mark-freeze-in-bulk! conn))
(some->> (seq to-delete) (mark-delete-in-bulk! conn))
[(count to-freeze) (count to-delete)]))))
(defn- process-bucket!
[conn bucket ids]
[conn bucket objects]
(case bucket
"file-media-object" (process-objects! conn has-file-media-object-refs? ids bucket)
"team-font-variant" (process-objects! conn has-team-font-variant-refs? ids bucket)
"file-object-thumbnail" (process-objects! conn has-file-object-thumbnails-refs? ids bucket)
"file-thumbnail" (process-objects! conn has-file-thumbnails-refs? ids bucket)
"profile" (process-objects! conn has-profile-refs? ids bucket)
"file-data" (process-objects! conn has-file-data-refs? ids bucket)
"file-data-fragment" (process-objects! conn has-file-data-fragment-refs? ids bucket)
"file-change" (process-objects! conn has-file-change-refs? ids bucket)
"file-media-object" (process-objects! conn has-file-media-object-refs? bucket objects)
"team-font-variant" (process-objects! conn has-team-font-variant-refs? bucket objects)
"file-object-thumbnail" (process-objects! conn has-file-object-thumbnails-refs? bucket objects)
"file-thumbnail" (process-objects! conn has-file-thumbnails-refs? bucket objects)
"profile" (process-objects! conn has-profile-refs? bucket objects)
"file-data" (process-objects! conn has-file-data-refs? bucket objects)
(ex/raise :type :internal
:code :unexpected-unknown-reference
:hint (dm/fmt "unknown reference '%'" bucket))))
(defn process-chunk!
[{:keys [::db/conn]} chunk]
(reduce-kv (fn [[nfo ndo] bucket ids]
(let [[nfo' ndo'] (process-bucket! conn bucket ids)]
(reduce-kv (fn [[nfo ndo] bucket objects]
(let [[nfo' ndo'] (process-bucket! conn bucket objects)]
[(+ nfo nfo')
(+ ndo ndo')]))
[0 0]
(d/group-by lookup-bucket :id #{} chunk)))
(d/group-by lookup-bucket identity #{} chunk)))
(def ^:private
sql:get-touched-storage-objects
@@ -214,12 +197,7 @@
(let [[nfo ndo] (db/tx-run! cfg process-chunk! chunk)]
(recur (long (+ freezed nfo))
(long (+ deleted ndo))))
(do
(l/inf :hint "task finished"
:to-freeze freezed
:to-delete deleted)
{:freeze freezed :delete deleted}))))
{:freeze freezed :delete deleted})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HANDLER

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

@@ -31,13 +31,13 @@
java.time.Duration
java.util.Collection
java.util.Optional
java.util.concurrent.atomic.AtomicLong
org.reactivestreams.Subscriber
software.amazon.awssdk.core.ResponseBytes
software.amazon.awssdk.core.async.AsyncRequestBody
software.amazon.awssdk.core.async.AsyncResponseTransformer
software.amazon.awssdk.core.async.BlockingInputStreamAsyncRequestBody
software.amazon.awssdk.core.client.config.ClientAsyncConfiguration
software.amazon.awssdk.core.client.config.SdkAdvancedAsyncClientOption
software.amazon.awssdk.http.nio.netty.NettyNioAsyncHttpClient
software.amazon.awssdk.http.nio.netty.SdkEventLoopGroup
software.amazon.awssdk.regions.Region
@@ -87,12 +87,11 @@
(def ^:private schema:config
[:map {:title "s3-backend-config"}
::wrk/executor
::wrk/netty-io-executor
[::region {:optional true} :keyword]
[::bucket {:optional true} ::sm/text]
[::prefix {:optional true} ::sm/text]
[::endpoint {:optional true} ::sm/uri]
[::io-threads {:optional true} ::sm/int]])
[::endpoint {:optional true} ::sm/uri]])
(defmethod ig/expand-key ::backend
[k v]
@@ -110,6 +109,7 @@
presigner (build-s3-presigner params)]
(assoc params
::sto/type :s3
::counter (AtomicLong. 0)
::client @client
::presigner presigner
::close-fn #(.close ^java.lang.AutoCloseable client)))))
@@ -121,7 +121,7 @@
(defmethod ig/halt-key! ::backend
[_ {:keys [::close-fn]}]
(when (fn? close-fn)
(px/run! close-fn)))
(close-fn)))
(def ^:private schema:backend
[:map {:title "s3-backend"}
@@ -198,19 +198,16 @@
(Region/of (name region)))
(defn- build-s3-client
[{:keys [::region ::endpoint ::io-threads ::wrk/executor]}]
[{:keys [::region ::endpoint ::wrk/netty-io-executor]}]
(let [aconfig (-> (ClientAsyncConfiguration/builder)
(.advancedOption SdkAdvancedAsyncClientOption/FUTURE_COMPLETION_EXECUTOR executor)
(.build))
sconfig (-> (S3Configuration/builder)
(cond-> (some? endpoint) (.pathStyleAccessEnabled true))
(.build))
thr-num (or io-threads (min 16 (px/get-available-processors)))
hclient (-> (NettyNioAsyncHttpClient/builder)
(.eventLoopGroupBuilder (-> (SdkEventLoopGroup/builder)
(.numberOfThreads (int thr-num))))
(.eventLoopGroup (SdkEventLoopGroup/create netty-io-executor))
(.connectionAcquisitionTimeout default-timeout)
(.connectionTimeout default-timeout)
(.readTimeout default-timeout)
@@ -262,7 +259,7 @@
(.close ^InputStream input))))
(defn- make-request-body
[executor content]
[counter content]
(let [size (impl/get-size content)]
(reify
AsyncRequestBody
@@ -272,16 +269,19 @@
(^void subscribe [_ ^Subscriber subscriber]
(let [delegate (AsyncRequestBody/forBlockingInputStream (long size))
input (io/input-stream content)]
(px/run! executor (partial write-input-stream delegate input))
(px/thread-call (partial write-input-stream delegate input)
{:name (str "penpot/storage/" (.getAndIncrement ^AtomicLong counter))})
(.subscribe ^BlockingInputStreamAsyncRequestBody delegate
^Subscriber subscriber))))))
(defn- put-object
[{:keys [::client ::bucket ::prefix ::wrk/executor]} {:keys [id] :as object} content]
[{:keys [::client ::bucket ::prefix ::counter]} {:keys [id] :as object} content]
(let [path (dm/str prefix (impl/id->path id))
mdata (meta object)
mtype (:content-type mdata "application/octet-stream")
rbody (make-request-body executor content)
rbody (make-request-body counter content)
request (.. (PutObjectRequest/builder)
(bucket bucket)
(contentType mtype)

2
backend/src/app/storage/tmp.clj
View File

@@ -44,7 +44,7 @@
[_ cfg]
(fs/create-dir default-tmp-dir)
(px/fn->thread (partial io-loop cfg)
{:name "penpot/storage/tmp-cleaner" :virtual true}))
{:name "penpot/storage/tmp-cleaner"}))
(defmethod ig/halt-key! ::cleaner
[_ thread]

49
backend/src/app/tasks/delete_object.clj
View File

@@ -10,6 +10,7 @@
[app.common.logging :as l]
[app.common.time :as ct]
[app.db :as db]
[app.db.sql :as-alias sql]
[app.rpc.commands.files :as files]
[app.rpc.commands.profile :as profile]
[integrant.core :as ig]))
@@ -19,10 +20,28 @@
(defmulti delete-object
(fn [_ props] (:object props)))
(defmethod delete-object :snapshot
[{:keys [::db/conn] :as cfg} {:keys [id file-id deleted-at]}]
(l/trc :obj "snapshot" :id (str id) :file-id (str file-id)
:deleted-at (ct/format-inst deleted-at))
(db/update! conn :file-change
{:deleted-at deleted-at}
{:id id :file-id file-id}
{::db/return-keys false})
(db/update! conn :file-data
{:deleted-at deleted-at}
{:id id :file-id file-id :type "snapshot"}
{::db/return-keys false}))
(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)
(when-let [file (db/get* conn :file {:id id}
{::db/remove-deleted false
::sql/columns [:id :is-shared]})]
(l/trc :obj "file" :id (str id)
:deleted-at (ct/format-inst deleted-at))
(db/update! conn :file
@@ -43,25 +62,35 @@
;; Mark file change to be deleted
(db/update! conn :file-change
{:deleted-at deleted-at}
{:file-id id})
{:file-id id}
{::db/return-keys false})
;; Mark file data fragment to be deleted
(db/update! conn :file-data
{:deleted-at deleted-at}
{:file-id id}
{::db/return-keys false})
;; Mark file media objects to be deleted
(db/update! conn :file-media-object
{:deleted-at deleted-at}
{:file-id id})
{:file-id id}
{::db/return-keys false})
;; Mark thumbnails to be deleted
(db/update! conn :file-thumbnail
{:deleted-at deleted-at}
{:file-id id})
{:file-id id}
{::db/return-keys false})
(db/update! conn :file-tagged-object-thumbnail
{:deleted-at deleted-at}
{:file-id id})))
{:file-id id}
{::db/return-keys false})))
(defmethod delete-object :project
[{:keys [::db/conn] :as cfg} {:keys [id deleted-at]}]
(l/trc :hint "marking for deletion" :rel "project" :id (str id)
(l/trc :obj "project" :id (str id)
:deleted-at (ct/format-inst deleted-at))
(db/update! conn :project
@@ -78,7 +107,7 @@
(defmethod delete-object :team
[{:keys [::db/conn] :as cfg} {:keys [id deleted-at]}]
(l/trc :hint "marking for deletion" :rel "team" :id (str id)
(l/trc :obj "team" :id (str id)
:deleted-at (ct/format-inst deleted-at))
(db/update! conn :team
{:deleted-at deleted-at}
@@ -100,7 +129,7 @@
(defmethod delete-object :profile
[{:keys [::db/conn] :as cfg} {:keys [id deleted-at]}]
(l/trc :hint "marking for deletion" :rel "profile" :id (str id)
(l/trc :obj "profile" :id (str id)
:deleted-at (ct/format-inst deleted-at))
(db/update! conn :profile
@@ -115,7 +144,7 @@
(defmethod delete-object :default
[_cfg props]
(l/wrn :hint "not implementation found" :rel (:object props)))
(l/wrn :obj (:object props) :hint "not implementation found"))
(defmethod ig/assert-key ::handler
[_ params]

188
backend/src/app/tasks/file_gc.clj
View File

@@ -23,29 +23,16 @@
[app.config :as cf]
[app.db :as db]
[app.features.fdata :as feat.fdata]
[app.features.file-snapshots :as fsnap]
[app.storage :as sto]
[app.worker :as wrk]
[integrant.core :as ig]))
(declare get-file)
(def sql:get-snapshots
"SELECT fc.file_id AS id,
fc.id AS snapshot_id,
fc.data,
fc.revn,
fc.version,
fc.features,
fc.data_backend,
fc.data_ref_id
FROM file_change AS fc
WHERE fc.file_id = ?
AND fc.data IS NOT NULL
ORDER BY fc.created_at ASC")
(def ^:private sql:mark-file-media-object-deleted
"UPDATE file_media_object
SET deleted_at = now()
SET deleted_at = ?
WHERE file_id = ? AND id != ALL(?::uuid[])
RETURNING id")
@@ -56,37 +43,35 @@
(defn- clean-file-media!
"Performs the garbage collection of file media objects."
[{:keys [::db/conn] :as cfg} {:keys [id] :as file}]
(let [xform (comp
(map (partial bfc/decode-file cfg))
xf:collect-used-media)
[{:keys [::db/conn ::timestamp] :as cfg} {:keys [id] :as file}]
(let [used-media
(fsnap/reduce-snapshots cfg id xf:collect-used-media conj #{})
used (->> (db/plan conn [sql:get-snapshots id] {:fetch-size 1})
(transduce xform conj #{}))
used (into used xf:collect-used-media [file])
used-media
(into used-media xf:collect-used-media [file])
ids (db/create-array conn "uuid" used)
unused (->> (db/exec! conn [sql:mark-file-media-object-deleted id ids])
used-media
(db/create-array conn "uuid" used-media)
unused-media
(->> (db/exec! conn [sql:mark-file-media-object-deleted timestamp id used-media])
(into #{} (map :id)))]
(l/dbg :hint "clean" :rel "file-media-object" :file-id (str id) :total (count unused))
(doseq [id unused]
(l/trc :hint "mark deleted"
:rel "file-media-object"
:id (str id)
:file-id (str id)))
(doseq [id unused-media]
(l/trc :obj "media-object"
:file-id (str id)
:id (str id)))
file))
(def ^:private sql:mark-file-object-thumbnails-deleted
"UPDATE file_tagged_object_thumbnail
SET deleted_at = now()
SET deleted_at = ?
WHERE file_id = ? AND object_id != ALL(?::text[])
RETURNING object_id")
(defn- clean-file-object-thumbnails!
[{:keys [::db/conn]} {:keys [data] :as file}]
[{:keys [::db/conn ::timestamp]} {:keys [data] :as file}]
(let [file-id (:id file)
using (->> (vals (:pages-index data))
(into #{} (comp
@@ -98,49 +83,37 @@
(thc/fmt-object-id file-id page-id id "frame")
(thc/fmt-object-id file-id page-id id "component")))))))
ids (db/create-array conn "text" using)
unused (->> (db/exec! conn [sql:mark-file-object-thumbnails-deleted file-id ids])
ids (into-array String using)
unused (->> (db/exec! conn [sql:mark-file-object-thumbnails-deleted timestamp file-id ids])
(into #{} (map :object-id)))]
(l/dbg :hint "clean" :rel "file-object-thumbnail" :file-id (str file-id) :total (count unused))
(doseq [object-id unused]
(l/trc :hint "mark deleted"
:rel "file-tagged-object-thumbnail"
:object-id object-id
:file-id (str file-id)))
(l/trc :obj "object-thumbnail"
:file-id (str file-id)
:id object-id))
file))
(def ^:private sql:mark-file-thumbnails-deleted
"UPDATE file_thumbnail
SET deleted_at = now()
SET deleted_at = ?
WHERE file_id = ? AND revn < ?
RETURNING revn")
(defn- clean-file-thumbnails!
[{:keys [::db/conn]} {:keys [id revn] :as file}]
(let [unused (->> (db/exec! conn [sql:mark-file-thumbnails-deleted id revn])
[{:keys [::db/conn ::timestamp]} {:keys [id revn] :as file}]
(let [unused (->> (db/exec! conn [sql:mark-file-thumbnails-deleted timestamp id revn])
(into #{} (map :revn)))]
(l/dbg :hint "clean" :rel "file-thumbnail" :file-id (str id) :total (count unused))
(doseq [revn unused]
(l/trc :hint "mark deleted"
:rel "file-thumbnail"
:revn revn
:file-id (str id)))
(l/trc :obj "thumbnail"
:file-id (str id)
:revn revn))
file))
(def ^:private sql:get-files-for-library
"SELECT f.id,
f.data,
f.modified_at,
f.features,
f.version,
f.data_backend,
f.data_ref_id
"SELECT f.id
FROM file AS f
LEFT JOIN file_library_rel AS fl ON (fl.file_id = f.id)
WHERE fl.library_file_id = ?
@@ -161,15 +134,21 @@
deleted-components
(ctkl/deleted-components-seq data)
xform
file-xform
(mapcat (partial get-used-components deleted-components file-id))
library-xform
(comp
(map :id)
(map #(bfc/get-file cfg % :realize? true :read-only? true))
file-xform)
used-remote
(->> (db/plan conn [sql:get-files-for-library file-id] {:fetch-size 1})
(transduce (comp (map (partial bfc/decode-file cfg)) xform) conj #{}))
(transduce library-xform conj #{}))
used-local
(into #{} xform [file])
(into #{} file-xform [file])
unused
(transduce bfc/xf-map-id disj
@@ -180,21 +159,21 @@
(update file :data
(fn [data]
(reduce (fn [data id]
(l/trc :hint "delete component"
:component-id (str id)
:file-id (str file-id))
(l/trc :obj "component"
:file-id (str file-id)
:id (str id))
(ctkl/delete-component data id))
data
unused)))]
(l/dbg :hint "clean" :rel "components" :file-id (str file-id) :total (count unused))
file))
(def ^:private sql:mark-deleted-data-fragments
"UPDATE file_data_fragment
SET deleted_at = now()
"UPDATE file_data
SET deleted_at = ?
WHERE file_id = ?
AND id != ALL(?::uuid[])
AND type = 'fragment'
AND deleted_at IS NULL
RETURNING id")
@@ -203,19 +182,16 @@
(mapcat feat.fdata/get-used-pointer-ids)))
(defn- clean-fragments!
[{:keys [::db/conn]} {:keys [id] :as file}]
[{:keys [::db/conn ::timestamp]} {:keys [id] :as file}]
(let [used (into #{} xf:collect-pointers [file])
unused (->> (db/exec! conn [sql:mark-deleted-data-fragments id
unused (->> (db/exec! conn [sql:mark-deleted-data-fragments timestamp id
(db/create-array conn "uuid" used)])
(into #{} bfc/xf-map-id))]
(l/dbg :hint "clean" :rel "file-data-fragment" :file-id (str id) :total (count unused))
(doseq [id unused]
(l/trc :hint "mark deleted"
:rel "file-data-fragment"
:id (str id)
:file-id (str id)))
(l/trc :obj "fragment"
:file-id (str id)
:id (str id)))
file))
@@ -229,36 +205,23 @@
(cfv/validate-file-schema! file)
file))
(def ^:private sql:get-file
"SELECT f.id,
f.data,
f.revn,
f.version,
f.features,
f.modified_at,
f.data_backend,
f.data_ref_id
FROM file AS f
WHERE f.has_media_trimmed IS false
AND f.modified_at < now() - ?::interval
AND f.deleted_at IS NULL
AND f.id = ?
FOR UPDATE
SKIP LOCKED")
(defn get-file
[{:keys [::db/conn ::min-age]} file-id]
(let [min-age (if min-age
(db/interval min-age)
(db/interval 0))]
(->> (db/exec! conn [sql:get-file min-age file-id])
(first))))
[cfg {:keys [file-id revn]}]
(let [file (bfc/get-file cfg file-id
:realize? true
:skip-locked? true
:lock-for-update? true)]
;; We should ensure that the scheduled file and the procesing file
;; has not changed since schedule, for this reason we check the
;; revn from props with the revn from retrieved file from database
(when (or (nil? revn) (= revn (:revn file)))
file)))
(defn- process-file!
[cfg file-id]
(if-let [file (get-file cfg file-id)]
[cfg {:keys [file-id] :as props}]
(if-let [file (get-file cfg props)]
(let [file (->> file
(bfc/decode-file cfg)
(bfl/clean-file)
(clean-media! cfg)
(clean-fragments! cfg))
@@ -267,7 +230,7 @@
true)
(do
(l/dbg :hint "skip" :file-id (str file-id))
(l/dbg :hint "skip cleaning, criteria does not match" :file-id (str file-id))
false)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -282,26 +245,23 @@
(defmethod ig/init-key ::handler
[_ cfg]
(fn [{:keys [props] :as task}]
(let [min-age (ct/duration (or (:min-age props)
(cf/get-deletion-delay)))
file-id (get props :file-id)
cfg (-> cfg
(assoc ::db/rollback (:rollback? props))
(assoc ::min-age min-age))]
(try
(db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
(let [cfg (update cfg ::sto/storage sto/configure conn)
processed? (process-file! cfg file-id)]
(-> cfg
(assoc ::db/rollback (:rollback? props))
(db/tx-run! (fn [{:keys [::db/conn] :as cfg}]
(let [cfg (-> cfg
(update ::sto/storage sto/configure conn)
(assoc ::timestamp (ct/now)))
processed? (process-file! cfg props)]
(when (and processed? (contains? cf/flags :tiered-file-data-storage))
(wrk/submit! (-> cfg
(assoc ::wrk/task :offload-file-data)
(assoc ::wrk/params props)
(assoc ::wrk/priority 10)
(assoc ::wrk/delay 1000))))
processed?)))
processed?))))
(catch Throwable cause
(l/err :hint "error on cleaning file"
:file-id (str (:file-id props))
:cause cause))))))
:cause cause)))))

14
backend/src/app/tasks/file_gc_scheduler.clj
View File

@@ -17,29 +17,29 @@
(def ^:private
sql:get-candidates
"SELECT f.id,
f.revn,
f.modified_at
FROM file AS f
WHERE f.has_media_trimmed IS false
AND f.modified_at < now() - ?::interval
AND f.deleted_at IS NULL
ORDER BY f.modified_at DESC
FOR UPDATE
FOR UPDATE OF f
SKIP LOCKED")
(defn- get-candidates
[{:keys [::db/conn ::min-age] :as cfg}]
(let [min-age (db/interval min-age)]
(db/cursor conn [sql:get-candidates min-age] {:chunk-size 10})))
(db/plan conn [sql:get-candidates min-age] {:fetch-size 10})))
(defn- schedule!
[{:keys [::min-age] :as cfg}]
(let [total (reduce (fn [total {:keys [id]}]
(let [params {:file-id id :min-age min-age}]
[cfg]
(let [total (reduce (fn [total {:keys [id modified-at revn]}]
(let [params {:file-id id :modified-at modified-at :revn revn}]
(wrk/submit! (assoc cfg ::wrk/params params))
(inc total)))
0
(get-candidates cfg))]
{:processed total}))
(defmethod ig/assert-key ::handler
@@ -48,7 +48,7 @@
(defmethod ig/expand-key ::handler
[k v]
{k (assoc v ::min-age (cf/get-deletion-delay))})
{k (assoc v ::min-age (cf/get-file-clean-delay))})
(defmethod ig/init-key ::handler
[_ cfg]

179
backend/src/app/tasks/objects_gc.clj
View File

@@ -11,6 +11,7 @@
[app.common.logging :as l]
[app.common.time :as ct]
[app.db :as db]
[app.features.fdata :as fdata]
[app.storage :as sto]
[integrant.core :as ig]))
@@ -27,14 +28,14 @@
[{:keys [::db/conn ::deletion-threshold ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-profiles deletion-threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [id photo-id]}]
(l/trc :hint "permanently delete" :rel "profile" :id (str id))
(l/trc :obj "profile" :id (str id))
;; Mark as deleted the storage object
(some->> photo-id (sto/touch-object! storage))
(db/delete! conn :profile {:id id})
(inc total))
(let [affected (-> (db/delete! conn :profile {:id id})
(db/get-update-count))]
(+ total affected)))
0)))
(def ^:private sql:get-teams
@@ -50,8 +51,7 @@
[{:keys [::db/conn ::deletion-threshold ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-teams deletion-threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [id photo-id deleted-at]}]
(l/trc :hint "permanently delete"
:rel "team"
(l/trc :obj "team"
:id (str id)
:deleted-at (ct/format-inst deleted-at))
@@ -59,9 +59,9 @@
(some->> photo-id (sto/touch-object! storage))
;; And finally, permanently delete the team.
(db/delete! conn :team {:id id})
(inc total))
(let [affected (-> (db/delete! conn :team {:id id})
(db/get-update-count))]
(+ total affected)))
0)))
(def ^:private sql:get-fonts
@@ -78,8 +78,7 @@
[{:keys [::db/conn ::deletion-threshold ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-fonts deletion-threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [id team-id deleted-at] :as font}]
(l/trc :hint "permanently delete"
:rel "team-font-variant"
(l/trc :obj "font-variant"
:id (str id)
:team-id (str team-id)
:deleted-at (ct/format-inst deleted-at))
@@ -90,10 +89,9 @@
(some->> (:otf-file-id font) (sto/touch-object! storage))
(some->> (:ttf-file-id font) (sto/touch-object! storage))
;; And finally, permanently delete the team font variant
(db/delete! conn :team-font-variant {:id id})
(inc total))
(let [affected (-> (db/delete! conn :team-font-variant {:id id})
(db/get-update-count))]
(+ total affected)))
0)))
(def ^:private sql:get-projects
@@ -110,45 +108,40 @@
[{:keys [::db/conn ::deletion-threshold ::chunk-size] :as cfg}]
(->> (db/plan conn [sql:get-projects deletion-threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [id team-id deleted-at]}]
(l/trc :hint "permanently delete"
:rel "project"
(l/trc :obj "project"
:id (str id)
:team-id (str team-id)
:deleted-at (ct/format-inst deleted-at))
;; And finally, permanently delete the project.
(db/delete! conn :project {:id id})
(inc total))
(let [affected (-> (db/delete! conn :project {:id id})
(db/get-update-count))]
(+ total affected)))
0)))
(def ^:private sql:get-files
"SELECT id, deleted_at, project_id, data_backend, data_ref_id
FROM file
WHERE deleted_at IS NOT NULL
AND deleted_at < now() + ?::interval
ORDER BY deleted_at ASC
"SELECT f.id,
f.deleted_at,
f.project_id
FROM file AS f
WHERE f.deleted_at IS NOT NULL
AND f.deleted_at < now() + ?::interval
ORDER BY f.deleted_at ASC
LIMIT ?
FOR UPDATE
SKIP LOCKED")
(defn- delete-files!
[{:keys [::db/conn ::sto/storage ::deletion-threshold ::chunk-size] :as cfg}]
[{:keys [::db/conn ::deletion-threshold ::chunk-size] :as cfg}]
(->> (db/plan conn [sql:get-files deletion-threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [id deleted-at project-id] :as file}]
(l/trc :hint "permanently delete"
:rel "file"
(l/trc :obj "file"
:id (str id)
:project-id (str project-id)
:deleted-at (ct/format-inst deleted-at))
(when (= "objects-storage" (:data-backend file))
(sto/touch-object! storage (:data-ref-id file)))
;; And finally, permanently delete the file.
(db/delete! conn :file {:id id})
(inc total))
(let [affected (-> (db/delete! conn :file {:id id})
(db/get-update-count))]
(+ total affected)))
0)))
(def ^:private sql:get-file-thumbnails
@@ -165,8 +158,7 @@
[{:keys [::db/conn ::deletion-threshold ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-file-thumbnails deletion-threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [file-id revn media-id deleted-at]}]
(l/trc :hint "permanently delete"
:rel "file-thumbnail"
(l/trc :obj "file-thumbnail"
:file-id (str file-id)
:revn revn
:deleted-at (ct/format-inst deleted-at))
@@ -174,10 +166,9 @@
;; Mark as deleted the storage object
(some->> media-id (sto/touch-object! storage))
;; And finally, permanently delete the object
(db/delete! conn :file-thumbnail {:file-id file-id :revn revn})
(inc total))
(let [affected (-> (db/delete! conn :file-thumbnail {:file-id file-id :revn revn})
(db/get-update-count))]
(+ total affected)))
0)))
(def ^:private sql:get-file-object-thumbnails
@@ -194,8 +185,7 @@
[{:keys [::db/conn ::deletion-threshold ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-file-object-thumbnails deletion-threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [file-id object-id media-id deleted-at]}]
(l/trc :hint "permanently delete"
:rel "file-tagged-object-thumbnail"
(l/trc :obj "file-object-thumbnail"
:file-id (str file-id)
:object-id object-id
:deleted-at (ct/format-inst deleted-at))
@@ -203,36 +193,10 @@
;; Mark as deleted the storage object
(some->> media-id (sto/touch-object! storage))
;; And finally, permanently delete the object
(db/delete! conn :file-tagged-object-thumbnail {:file-id file-id :object-id object-id})
(inc total))
0)))
(def ^:private sql:get-file-data-fragments
"SELECT file_id, id, deleted_at, data_ref_id
FROM file_data_fragment
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 ::sto/storage ::deletion-threshold ::chunk-size] :as cfg}]
(->> (db/plan conn [sql:get-file-data-fragments deletion-threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [file-id id deleted-at data-ref-id]}]
(l/trc :hint "permanently delete"
:rel "file-data-fragment"
:id (str id)
:file-id (str file-id)
:deleted-at (ct/format-inst deleted-at))
(some->> data-ref-id (sto/touch-object! storage))
(db/delete! conn :file-data-fragment {:file-id file-id :id id})
(inc total))
(let [affected (-> (db/delete! conn :file-tagged-object-thumbnail
{:file-id file-id :object-id object-id})
(db/get-update-count))]
(+ total affected)))
0)))
(def ^:private sql:get-file-media-objects
@@ -249,8 +213,7 @@
[{:keys [::db/conn ::deletion-threshold ::chunk-size ::sto/storage] :as cfg}]
(->> (db/plan conn [sql:get-file-media-objects deletion-threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [id file-id deleted-at] :as fmo}]
(l/trc :hint "permanently delete"
:rel "file-media-object"
(l/trc :obj "file-media-object"
:id (str id)
:file-id (str file-id)
:deleted-at (ct/format-inst deleted-at))
@@ -259,13 +222,48 @@
(some->> (:media-id fmo) (sto/touch-object! storage))
(some->> (:thumbnail-id fmo) (sto/touch-object! storage))
(db/delete! conn :file-media-object {:id id})
(let [affected (-> (db/delete! conn :file-media-object {:id id})
(db/get-update-count))]
(+ total affected)))
0)))
(inc total))
(def ^:private sql:get-file-data
"SELECT file_id, id, type, deleted_at, metadata, backend
FROM file_data
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!
[{:keys [::db/conn ::deletion-threshold ::chunk-size] :as cfg}]
(->> (db/plan conn [sql:get-file-data deletion-threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [file-id id type deleted-at metadata backend]}]
(some->> metadata
(fdata/decode-metadata)
(fdata/process-metadata cfg))
(l/trc :obj "file-data"
:id (str id)
:file-id (str file-id)
:type type
:backend backend
:deleted-at (ct/format-inst deleted-at))
(let [affected (-> (db/delete! conn :file-data
{:file-id file-id
:id id
:type type})
(db/get-update-count))]
(+ total affected)))
0)))
(def ^:private sql:get-file-change
"SELECT id, file_id, deleted_at, data_backend, data_ref_id
"SELECT id, file_id, deleted_at
FROM file_change
WHERE deleted_at IS NOT NULL
AND deleted_at < now() + ?::interval
@@ -275,29 +273,25 @@
SKIP LOCKED")
(defn- delete-file-changes!
[{:keys [::db/conn ::deletion-threshold ::chunk-size ::sto/storage] :as cfg}]
[{:keys [::db/conn ::deletion-threshold ::chunk-size] :as cfg}]
(->> (db/plan conn [sql:get-file-change deletion-threshold chunk-size] {:fetch-size 5})
(reduce (fn [total {:keys [id file-id deleted-at] :as xlog}]
(l/trc :hint "permanently delete"
:rel "file-change"
(l/trc :obj "file-change"
:id (str id)
:file-id (str file-id)
:deleted-at (ct/format-inst deleted-at))
(when (= "objects-storage" (:data-backend xlog))
(sto/touch-object! storage (:data-ref-id xlog)))
(db/delete! conn :file-change {:id id})
(inc total))
(let [affected (-> (db/delete! conn :file-change {:id id})
(db/get-update-count))]
(+ total affected)))
0)))
(def ^:private deletion-proc-vars
[#'delete-profiles!
#'delete-file-media-objects!
#'delete-file-data-fragments!
#'delete-file-object-thumbnails!
#'delete-file-thumbnails!
#'delete-file-data!
#'delete-file-changes!
#'delete-files!
#'delete-projects!
@@ -309,7 +303,8 @@
until 0 results is returned"
[cfg proc-fn]
(loop [total 0]
(let [result (db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
(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)
@@ -336,6 +331,4 @@
(let [result (execute-proc! cfg proc-fn)]
(recur (rest procs)
(long (+ total result))))
(do
(l/inf :hint "task finished" :deleted total)
{:processed total}))))))
{:processed total})))))

111
backend/src/app/tasks/offload_file_data.clj
View File

@@ -8,101 +8,25 @@
"A maintenance task responsible of moving file data from hot
storage (the database row) to a cold storage (fs or s3)."
(:require
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.db :as db]
[app.db.sql :as-alias sql]
[app.features.fdata :as fdata]
[app.storage :as sto]
[integrant.core :as ig]))
(defn- offload-file-data!
[{:keys [::db/conn ::sto/storage ::file-id] :as cfg}]
(let [file (db/get conn :file {:id file-id}
{::sql/for-update true})]
(when (nil? (:data file))
(ex/raise :hint "file already offloaded"
:type :internal
:code :file-already-offloaded
:file-id file-id))
(def ^:private sql:get-file-data
"SELECT fd.*
FROM file_data AS fd
WHERE fd.file_id = ?
AND fd.backend = 'db'
AND fd.deleted_at IS NULL")
(let [data (sto/content (:data file))
sobj (sto/put-object! storage
{::sto/content data
::sto/touch true
:bucket "file-data"
:content-type "application/octet-stream"
:file-id file-id})]
(l/trc :hint "offload file data"
:file-id (str file-id)
:storage-id (str (:id sobj)))
(db/update! conn :file
{:data-backend "objects-storage"
:data-ref-id (:id sobj)
:data nil}
{:id file-id}
{::db/return-keys false}))))
(defn- offload-file-data-fragments!
[{:keys [::db/conn ::sto/storage ::file-id] :as cfg}]
(doseq [fragment (db/query conn :file-data-fragment
{:file-id file-id
:deleted-at nil
:data-backend nil}
{::db/for-update true})]
(let [data (sto/content (:data fragment))
sobj (sto/put-object! storage
{::sto/content data
::sto/touch true
:bucket "file-data-fragment"
:content-type "application/octet-stream"
:file-id file-id
:file-fragment-id (:id fragment)})]
(l/trc :hint "offload file data fragment"
:file-id (str file-id)
:file-fragment-id (str (:id fragment))
:storage-id (str (:id sobj)))
(db/update! conn :file-data-fragment
{:data-backend "objects-storage"
:data-ref-id (:id sobj)
:data nil}
{:id (:id fragment)}
{::db/return-keys false}))))
(def sql:get-snapshots
"SELECT fc.*
FROM file_change AS fc
WHERE fc.file_id = ?
AND fc.label IS NOT NULL
AND fc.data IS NOT NULL
AND fc.data_backend IS NULL")
(defn- offload-file-snapshots!
[{:keys [::db/conn ::sto/storage ::file-id] :as cfg}]
(doseq [snapshot (db/exec! conn [sql:get-snapshots file-id])]
(let [data (sto/content (:data snapshot))
sobj (sto/put-object! storage
{::sto/content data
::sto/touch true
:bucket "file-change"
:content-type "application/octet-stream"
:file-id file-id
:file-change-id (:id snapshot)})]
(l/trc :hint "offload file change"
:file-id (str file-id)
:file-change-id (str (:id snapshot))
:storage-id (str (:id sobj)))
(db/update! conn :file-change
{:data-backend "objects-storage"
:data-ref-id (:id sobj)
:data nil}
{:id (:id snapshot)}
{::db/return-keys false}))))
(defn- offload-file-data
[cfg {:keys [id file-id type] :as fdata}]
(fdata/upsert! cfg (assoc fdata :backend "storage"))
(l/trc :file-id (str file-id)
:id (str id)
:type type))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HANDLER
@@ -116,10 +40,9 @@
(defmethod ig/init-key ::handler
[_ cfg]
(fn [{:keys [props] :as task}]
(let [file-id (:file-id props)]
(-> cfg
(assoc ::db/rollback (:rollback? props))
(assoc ::file-id (:file-id props))
(db/tx-run! (fn [cfg]
(offload-file-data! cfg)
(offload-file-data-fragments! cfg)
(offload-file-snapshots! cfg))))))
(db/tx-run! (fn [{:keys [::db/conn] :as cfg}]
(run! (partial offload-file-data cfg)
(db/plan conn [sql:get-file-data file-id]))))))))

29
backend/src/app/tokens.clj
View File

@@ -8,33 +8,40 @@
"Tokens generation API."
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.time :as ct]
[app.common.transit :as t]
[app.setup :as-alias setup]
[buddy.sign.jwe :as jwe]))
(defn generate
[{:keys [tokens-key]} claims]
[{:keys [::setup/props] :as cfg} claims]
(assert (contains? cfg ::setup/props))
(dm/assert!
"expexted token-key to be bytes instance"
(bytes? tokens-key))
(let [tokens-key
(get props :tokens-key)
(let [payload (-> claims
(assoc :iat (ct/now))
payload
(-> claims
(update :iat (fn [v] (or v (ct/now))))
(d/without-nils)
(t/encode))]
(jwe/encrypt payload tokens-key {:alg :a256kw :enc :a256gcm})))
(defn decode
[{:keys [tokens-key]} token]
(let [payload (jwe/decrypt token tokens-key {:alg :a256kw :enc :a256gcm})]
[{:keys [::setup/props] :as cfg} token]
(let [tokens-key
(get props :tokens-key)
payload
(jwe/decrypt token tokens-key {:alg :a256kw :enc :a256gcm})]
(t/decode payload)))
(defn verify
[sprops {:keys [token] :as params}]
(let [claims (decode sprops token)]
[cfg {:keys [token] :as params}]
(let [claims (decode cfg token)]
(when (and (ct/inst? (:exp claims))
(ct/is-before? (:exp claims) (ct/now)))
(ex/raise :type :validation

4
backend/src/app/util/events.clj
View File

@@ -27,7 +27,7 @@
(sp/put! channel [type data])
nil)))
(defn start-listener
(defn spawn-listener
[channel on-event on-close]
(assert (sp/chan? channel) "expected active events channel")
@@ -51,7 +51,7 @@
[f on-event]
(binding [*channel* (sp/chan :buf 32)]
(let [listener (start-listener *channel* on-event (constantly nil))]
(let [listener (spawn-listener *channel* on-event (constantly nil))]
(try
(f)
(finally

142
backend/src/app/worker/dispatcher.clj
View File

@@ -7,7 +7,6 @@
(ns app.worker.dispatcher
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.time :as ct]
@@ -18,7 +17,9 @@
[app.worker :as-alias wrk]
[cuerdas.core :as str]
[integrant.core :as ig]
[promesa.exec :as px]))
[promesa.exec :as px])
(:import
java.lang.AutoCloseable))
(set! *warn-on-reflection* true)
@@ -27,7 +28,7 @@
[::wrk/tenant ::sm/text]
::mtx/metrics
::db/pool
::rds/redis])
::rds/client])
(defmethod ig/expand-key ::wrk/dispatcher
[k v]
@@ -41,42 +42,107 @@
(assert (sm/check schema:dispatcher cfg)))
(def ^:private sql:select-next-tasks
"select id, queue from task as t
where t.scheduled_at <= now()
and (t.status = 'new' or t.status = 'retry')
and queue ~~* ?::text
order by t.priority desc, t.scheduled_at
limit ?
for update skip locked")
"SELECT id, queue, scheduled_at from task AS t
WHERE t.scheduled_at <= ?::timestamptz
AND (t.status = 'new' OR t.status = 'retry')
AND queue ~~* ?::text
ORDER BY t.priority DESC, t.scheduled_at
LIMIT ?
FOR UPDATE
SKIP LOCKED")
(def ^:private sql:mark-task-scheduled
"UPDATE task SET status = 'scheduled'
WHERE id = ANY(?)")
(def ^:private sql:reschedule-lost
"UPDATE task
SET status='new', scheduled_at=?::timestamptz
FROM (SELECT t.id
FROM task AS t
WHERE status = 'scheduled'
AND (?::timestamptz - t.scheduled_at) > '5 min'::interval) AS subquery
WHERE task.id=subquery.id
RETURNING task.id, task.queue")
(def ^:private sql:clean-orphan
"UPDATE task
SET status='failed', modified_at=?::timestamptz,
error='orphan with running status'
FROM (SELECT t.id
FROM task AS t
WHERE status = 'running'
AND (?::timestamptz - t.modified_at) > '24 hour'::interval) AS subquery
WHERE task.id=subquery.id
RETURNING task.id, task.queue")
(defmethod ig/init-key ::wrk/dispatcher
[_ {:keys [::db/pool ::rds/redis ::wrk/tenant ::batch-size ::timeout] :as cfg}]
(letfn [(get-tasks [conn]
(let [prefix (str tenant ":%")]
(seq (db/exec! conn [sql:select-next-tasks prefix batch-size]))))
[_ {:keys [::db/pool ::wrk/tenant ::batch-size ::timeout] :as cfg}]
(letfn [(reschedule-lost-tasks [{:keys [::db/conn ::timestamp]}]
(doseq [{:keys [id queue]} (db/exec! conn [sql:reschedule-lost timestamp timestamp]
{:return-keys true})]
(l/wrn :hint "reschedule"
:id (str id)
:queue queue)))
(push-tasks! [conn rconn [queue tasks]]
(let [ids (mapv :id tasks)
key (str/ffmt "taskq:%" queue)
res (rds/rpush rconn key (mapv t/encode ids))
sql [(str "update task set status = 'scheduled'"
" where id = ANY(?)")
(clean-orphan [{:keys [::db/conn ::timestamp]}]
(doseq [{:keys [id queue]} (db/exec! conn [sql:clean-orphan timestamp timestamp]
{:return-keys true})]
(l/wrn :hint "mark as orphan failed"
:id (str id)
:queue queue)))
(get-tasks [{:keys [::db/conn ::timestamp] :as cfg}]
(let [prefix (str tenant ":%")
result (db/exec! conn [sql:select-next-tasks timestamp prefix batch-size])]
(not-empty result)))
(mark-as-scheduled [{:keys [::db/conn]} items]
(let [ids (map :id items)
sql [sql:mark-task-scheduled
(db/create-array conn "uuid" ids)]]
(db/exec-one! conn sql)))
(db/exec-one! conn sql)
(l/trc :hist "enqueue tasks on redis"
:queue queue
:tasks (count ids)
:queued res)))
(push-tasks [{:keys [::rds/conn] :as cfg} [queue tasks]]
(let [items (mapv (juxt :id :scheduled-at) tasks)
key (str/ffmt "penpot.worker.queue:%" queue)]
(run-batch! [rconn]
(try
(db/tx-run! cfg (fn [{:keys [::db/conn]}]
(if-let [tasks (get-tasks conn)]
(rds/rpush conn key (mapv t/encode-str items))
(mark-as-scheduled cfg tasks)
(doseq [{:keys [id queue]} tasks]
(l/trc :hist "schedule"
:id (str id)
:queue queue))))
(run-batch' [cfg]
(let [cfg (assoc cfg ::timestamp (ct/now))]
;; Reschedule lost in transit tasks (can happen when
;; redis server is restarted just after task is pushed)
(reschedule-lost-tasks cfg)
;; Mark as failed all tasks that are still marked as
;; running but it's been more than 24 hours since its
;; last modification
(clean-orphan cfg)
;; Then, schedule the next tasks in queue
(if-let [tasks (get-tasks cfg)]
(->> (group-by :queue tasks)
(run! (partial push-tasks! conn rconn)))
;; FIXME: this sleep should be outside the transaction
(px/sleep (::wait-duration cfg)))))
(run! (partial push-tasks cfg)))
;; If no tasks found on this batch run, we signal the
;; run-loop to wait for some time before start running
;; the next batch interation
::wait)))
(run-batch []
(let [rconn (rds/connect cfg)]
(try
(-> cfg
(assoc ::rds/conn rconn)
(db/tx-run! run-batch'))
(catch InterruptedException cause
(throw cause))
(catch Exception cause
@@ -94,14 +160,18 @@
:else
(do
(l/err :hint "unhandled exception (will retry in an instant)" :cause cause)
(px/sleep timeout))))))
(px/sleep timeout))))
(finally
(.close ^AutoCloseable rconn)))))
(dispatcher []
(l/inf :hint "started")
(try
(dm/with-open [rconn (rds/connect redis)]
(loop []
(run-batch! rconn)
(let [result (run-batch)]
(when (= result ::wait)
(px/sleep (::wait-duration cfg)))
(recur)))
(catch InterruptedException _
(l/trc :hint "interrupted"))
@@ -112,7 +182,7 @@
(if (db/read-only? pool)
(l/wrn :hint "not started (db is read-only)")
(px/fn->thread dispatcher :name "penpot/worker/dispatcher" :virtual false))))
(px/fn->thread dispatcher :name "penpot/worker-dispatcher"))))
(defmethod ig/halt-key! ::wrk/dispatcher
[_ thread]

134
backend/src/app/worker/executor.clj
View File

@@ -7,97 +7,83 @@
(ns app.worker.executor
"Async tasks abstraction (impl)."
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.common.math :as mth]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.metrics :as mtx]
[app.worker :as-alias wrk]
[integrant.core :as ig]
[promesa.exec :as px])
(:import
java.util.concurrent.ThreadPoolExecutor))
io.netty.channel.nio.NioEventLoopGroup
io.netty.util.concurrent.DefaultEventExecutorGroup
java.util.concurrent.ExecutorService
java.util.concurrent.ThreadFactory
java.util.concurrent.TimeUnit))
(set! *warn-on-reflection* true)
(sm/register!
{:type ::wrk/executor
:pred #(instance? ThreadPoolExecutor %)
:pred #(instance? ExecutorService %)
:type-properties
{:title "executor"
:description "Instance of ThreadPoolExecutor"}})
:description "Instance of ExecutorService"}})
(sm/register!
{:type ::wrk/netty-io-executor
:pred #(instance? NioEventLoopGroup %)
:type-properties
{:title "executor"
:description "Instance of NioEventLoopGroup"}})
(sm/register!
{:type ::wrk/netty-executor
:pred #(instance? DefaultEventExecutorGroup %)
:type-properties
{:title "executor"
:description "Instance of DefaultEventExecutorGroup"}})
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; EXECUTOR
;; IO Executor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/init-key ::wrk/executor
[_ _]
(let [factory (px/thread-factory :prefix "penpot/default/")
executor (px/cached-executor :factory factory :keepalive 60000)]
(l/inf :hint "executor started")
executor))
(defmethod ig/assert-key ::wrk/netty-io-executor
[_ {:keys [threads]}]
(assert (or (nil? threads) (int? threads))
"expected valid threads value, revisit PENPOT_NETTY_IO_THREADS environment variable"))
(defmethod ig/halt-key! ::wrk/executor
(defmethod ig/init-key ::wrk/netty-io-executor
[_ {:keys [threads]}]
(let [factory (px/thread-factory :prefix "penpot/netty-io/")
nthreads (or threads (mth/round (/ (px/get-available-processors) 2)))
nthreads (max 2 nthreads)]
(l/inf :hint "start netty io executor" :threads nthreads)
(NioEventLoopGroup. (int nthreads) ^ThreadFactory factory)))
(defmethod ig/halt-key! ::wrk/netty-io-executor
[_ instance]
(deref (.shutdownGracefully ^NioEventLoopGroup instance
(long 100)
(long 1000)
TimeUnit/MILLISECONDS)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; IO Offload Executor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/assert-key ::wrk/netty-executor
[_ {:keys [threads]}]
(assert (or (nil? threads) (int? threads))
"expected valid threads value, revisit PENPOT_EXEC_THREADS environment variable"))
(defmethod ig/init-key ::wrk/netty-executor
[_ {:keys [threads]}]
(let [factory (px/thread-factory :prefix "penpot/exec/")
nthreads (or threads (mth/round (/ (px/get-available-processors) 2)))
nthreads (max 2 nthreads)]
(l/inf :hint "start default executor" :threads nthreads)
(DefaultEventExecutorGroup. (int nthreads) ^ThreadFactory factory)))
(defmethod ig/halt-key! ::wrk/netty-executor
[_ instance]
(px/shutdown! instance))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MONITOR
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- get-stats
[^ThreadPoolExecutor executor]
{:active (.getPoolSize ^ThreadPoolExecutor executor)
:running (.getActiveCount ^ThreadPoolExecutor executor)
:completed (.getCompletedTaskCount ^ThreadPoolExecutor executor)})
(defmethod ig/expand-key ::wrk/monitor
[k v]
{k (-> (d/without-nils v)
(assoc ::interval (ct/duration "2s")))})
(defmethod ig/init-key ::wrk/monitor
[_ {:keys [::wrk/executor ::mtx/metrics ::interval ::wrk/name]}]
(letfn [(monitor! [executor prev-completed]
(let [labels (into-array String [(d/name name)])
stats (get-stats executor)
completed (:completed stats)
completed-inc (- completed prev-completed)
completed-inc (if (neg? completed-inc) 0 completed-inc)]
(mtx/run! metrics
:id :executor-active-threads
:labels labels
:val (:active stats))
(mtx/run! metrics
:id :executor-running-threads
:labels labels
:val (:running stats))
(mtx/run! metrics
:id :executors-completed-tasks
:labels labels
:inc completed-inc)
completed-inc))]
(px/thread
{:name "penpot/executors-monitor" :virtual true}
(l/inf :hint "monitor started" :name name)
(try
(loop [completed 0]
(px/sleep interval)
(recur (long (monitor! executor completed))))
(catch InterruptedException _cause
(l/trc :hint "monitor: interrupted" :name name))
(catch Throwable cause
(l/err :hint "monitor: unexpected error" :name name :cause cause))
(finally
(l/inf :hint "monitor: terminated" :name name))))))
(defmethod ig/halt-key! ::wrk/monitor
[_ thread]
(px/interrupt! thread))

84
backend/src/app/worker/runner.clj
View File

@@ -8,7 +8,6 @@
"Async tasks abstraction (impl)."
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.schema :as sm]
@@ -20,7 +19,9 @@
[app.worker :as wrk]
[cuerdas.core :as str]
[integrant.core :as ig]
[promesa.exec :as px]))
[promesa.exec :as px])
(:import
java.lang.AutoCloseable))
(set! *warn-on-reflection* true)
@@ -37,7 +38,7 @@
[:max-retries :int]
[:retry-num :int]
[:priority :int]
[:status [:enum "scheduled" "completed" "new" "retry" "failed"]]
[:status [:enum "scheduled" "running" "completed" "new" "retry" "failed"]]
[:label {:optional true} :string]
[:props :map]])
@@ -68,7 +69,7 @@
(decode-task-row))))
(defn- run-task
[{:keys [::wrk/registry ::id ::queue] :as cfg} task]
[{:keys [::db/pool ::wrk/registry ::id ::queue] :as cfg} task]
(try
(l/dbg :hint "start"
:name (:name task)
@@ -76,6 +77,14 @@
:queue queue
:runner-id id
:retry (:retry-num task))
;; Mark task as running
(db/update! pool :task
{:status "running"
:modified-at (ct/now)}
{:id (:id task)}
{::db/return-keys false})
(let [tpoint (ct/tpoint)
task-fn (wrk/get-task registry (:name task))
result (when task-fn (task-fn task))
@@ -119,7 +128,7 @@
{:status "retry" :error cause})))))))
(defn- run-task!
[{:keys [::id ::timeout] :as cfg} task-id]
[{:keys [::id ::timeout] :as cfg} task-id scheduled-at]
(loop [task (get-task cfg task-id)]
(cond
(ex/exception? task)
@@ -127,20 +136,26 @@
(db/serialization-error? task))
(do
(l/wrn :hint "connection error on retrieving task from database (retrying in some instants)"
:id id
:runner-id id
:cause task)
(px/sleep timeout)
(recur (get-task cfg task-id)))
(do
(l/err :hint "unhandled exception on retrieving task from database (retrying in some instants)"
:id id
:runner-id id
:cause task)
(px/sleep timeout)
(recur (get-task cfg task-id))))
(not= (inst-ms scheduled-at)
(inst-ms (:scheduled-at task)))
(l/wrn :hint "skiping task, rescheduled"
:task-id task-id
:runner-id id)
(nil? task)
(l/wrn :hint "no task found on the database"
:id id
:runner-id id
:task-id task-id)
:else
@@ -149,7 +164,7 @@
{::task task})))))
(defn- run-worker-loop!
[{:keys [::db/pool ::rds/rconn ::timeout ::queue] :as cfg}]
[{:keys [::db/pool ::rds/conn ::timeout ::queue] :as cfg}]
(letfn [(handle-task-retry [{:keys [error inc-by delay] :or {inc-by 1 delay 1000} :as result}]
(let [explain (if (ex/exception? error)
(ex-message error)
@@ -183,21 +198,23 @@
(db/update! pool :task
{:completed-at now
:modified-at now
:error nil
:status "completed"}
{:id (:id task)})
nil))
(decode-payload [^bytes payload]
(decode-payload [payload]
(try
(let [task-id (t/decode payload)]
(if (uuid? task-id)
task-id
(l/err :hint "received unexpected payload (uuid expected)"
:payload task-id)))
(let [[task-id scheduled-at :as payload] (t/decode-str payload)]
(if (and (uuid? task-id)
(ct/inst? scheduled-at))
payload
(l/err :hint "received unexpected payload"
:payload payload)))
(catch Throwable cause
(l/err :hint "unable to decode payload"
:payload payload
:length (alength payload)
:length (alength ^String/1 payload)
:cause cause))))
(process-result [{:keys [status] :as result}]
@@ -209,8 +226,8 @@
(throw (IllegalArgumentException.
(str "invalid status received: " status))))))
(run-task-loop [task-id]
(loop [result (run-task! cfg task-id)]
(run-task-loop [[task-id scheduled-at]]
(loop [result (run-task! cfg task-id scheduled-at)]
(when-let [cause (process-result result)]
(if (or (db/connection-error? cause)
(db/serialization-error? cause))
@@ -220,14 +237,12 @@
(px/sleep timeout)
(recur result))
(do
(l/err :hint "unhandled exception on processing task result (retrying in some instants)"
:cause cause)
(px/sleep timeout)
(recur result))))))]
(l/err :hint "unhandled exception on processing task result"
:cause cause))))))]
(try
(let [key (str/ffmt "taskq:%" queue)
[_ payload] (rds/blpop rconn timeout [key])]
(let [key (str/ffmt "penpot.worker.queue:%" queue)
[_ payload] (rds/blpop conn [key] timeout)]
(some-> payload
decode-payload
run-task-loop))
@@ -246,22 +261,22 @@
(l/err :hint "unhandled exception" :cause cause))))))
(defn- start-thread!
[{:keys [::rds/redis ::id ::queue ::wrk/tenant] :as cfg}]
[{:keys [::id ::queue ::wrk/tenant] :as cfg}]
(px/thread
{:name (format "penpot/worker/runner:%s" id)}
{:name (str "penpot/job-runner/" id)}
(l/inf :hint "started" :id id :queue queue)
(let [rconn (rds/connect cfg)]
(try
(dm/with-open [rconn (rds/connect redis)]
(let [cfg (-> cfg
(assoc ::rds/rconn rconn)
(loop [cfg (-> cfg
(assoc ::rds/conn rconn)
(assoc ::queue (str/ffmt "%:%" tenant queue))
(assoc ::timeout (ct/duration "5s")))]
(loop []
(when (px/interrupted?)
(throw (InterruptedException. "interrupted")))
(run-worker-loop! cfg)
(recur))))
(recur cfg))
(catch InterruptedException _
(l/dbg :hint "interrupted"
@@ -273,9 +288,10 @@
:queue queue
:cause cause))
(finally
(.close ^AutoCloseable rconn)
(l/inf :hint "terminated"
:id id
:queue queue)))))
:queue queue))))))
(def ^:private schema:params
[:map
@@ -285,7 +301,7 @@
::wrk/registry
::mtx/metrics
::db/pool
::rds/redis])
::rds/client])
(defmethod ig/assert-key ::wrk/runner
[_ params]
@@ -303,7 +319,7 @@
(l/wrn :hint "not started (db is read-only)" :queue queue :parallelism parallelism)
(doall
(->> (range parallelism)
(map #(assoc cfg ::id %))
(map #(assoc cfg ::id (str queue "/" %)))
(map start-thread!))))))
(defmethod ig/halt-key! ::wrk/runner

2
backend/src/data_readers.clj
View File

@@ -4,7 +4,7 @@
penpot/path-data app.common.types.path/from-string
penpot/matrix app.common.geom.matrix/decode-matrix
penpot/point app.common.geom.point/decode-point
penpot/token-lib app.common.types.tokens-lib/parse-multi-set-dtcg-json
penpot/tokens-lib app.common.types.tokens-lib/parse-multi-set-dtcg-json
penpot/token-set app.common.types.tokens-lib/make-token-set
penpot/token-theme app.common.types.tokens-lib/make-token-theme
penpot/token app.common.types.tokens-lib/make-token}

45
backend/test/backend_tests/bounce_handling_test.clj
View File

@@ -101,12 +101,10 @@
(t/deftest test-parse-bounce-report
(let [profile (th/create-profile* 1)
props (:app.setup/props th/*system*)
cfg {:app.setup/props props}
report (bounce-report {:token (tokens/generate props
report (bounce-report {:token (tokens/generate th/*system*
{:iss :profile-identity
:profile-id (:id profile)})})
result (#'awsns/parse-notification cfg report)]
result (#'awsns/parse-notification th/*system* report)]
;; (pprint result)
(t/is (= "bounce" (:type result)))
@@ -117,12 +115,10 @@
(t/deftest test-parse-complaint-report
(let [profile (th/create-profile* 1)
props (:app.setup/props th/*system*)
cfg {:app.setup/props props}
report (complaint-report {:token (tokens/generate props
report (complaint-report {:token (tokens/generate th/*system*
{:iss :profile-identity
:profile-id (:id profile)})})
result (#'awsns/parse-notification cfg report)]
result (#'awsns/parse-notification th/*system* report)]
;; (pprint result)
(t/is (= "complaint" (:type result)))
(t/is (= "abuse" (:kind result)))
@@ -143,15 +139,13 @@
(t/deftest test-process-bounce-report
(let [profile (th/create-profile* 1)
props (:app.setup/props th/*system*)
pool (:app.db/pool th/*system*)
cfg {:app.setup/props props :app.db/pool pool}
report (bounce-report {:token (tokens/generate props
report (bounce-report {:token (tokens/generate th/*system*
{:iss :profile-identity
:profile-id (:id profile)})})
report (#'awsns/parse-notification cfg report)]
report (#'awsns/parse-notification th/*system* report)]
(#'awsns/process-report cfg report)
(#'awsns/process-report th/*system* report)
(let [rows (->> (db/query pool :profile-complaint-report {:profile-id (:id profile)})
(mapv decode-row))]
@@ -170,16 +164,13 @@
(t/deftest test-process-complaint-report
(let [profile (th/create-profile* 1)
props (:app.setup/props th/*system*)
pool (:app.db/pool th/*system*)
cfg {:app.setup/props props
:app.db/pool pool}
report (complaint-report {:token (tokens/generate props
report (complaint-report {:token (tokens/generate th/*system*
{:iss :profile-identity
:profile-id (:id profile)})})
report (#'awsns/parse-notification cfg report)]
report (#'awsns/parse-notification th/*system* report)]
(#'awsns/process-report cfg report)
(#'awsns/process-report th/*system* report)
(let [rows (->> (db/query pool :profile-complaint-report {:profile-id (:id profile)})
(mapv decode-row))]
@@ -200,16 +191,14 @@
(t/deftest test-process-bounce-report-to-self
(let [profile (th/create-profile* 1)
props (:app.setup/props th/*system*)
pool (:app.db/pool th/*system*)
cfg {:app.setup/props props :app.db/pool pool}
report (bounce-report {:email (:email profile)
:token (tokens/generate props
:token (tokens/generate th/*system*
{:iss :profile-identity
:profile-id (:id profile)})})
report (#'awsns/parse-notification cfg report)]
report (#'awsns/parse-notification th/*system* report)]
(#'awsns/process-report cfg report)
(#'awsns/process-report th/*system* report)
(let [rows (db/query pool :profile-complaint-report {:profile-id (:id profile)})]
(t/is (= 1 (count rows))))
@@ -222,16 +211,14 @@
(t/deftest test-process-complaint-report-to-self
(let [profile (th/create-profile* 1)
props (:app.setup/props th/*system*)
pool (:app.db/pool th/*system*)
cfg {:app.setup/props props :app.db/pool pool}
report (complaint-report {:email (:email profile)
:token (tokens/generate props
:token (tokens/generate th/*system*
{:iss :profile-identity
:profile-id (:id profile)})})
report (#'awsns/parse-notification cfg report)]
report (#'awsns/parse-notification th/*system* report)]
(#'awsns/process-report cfg report)
(#'awsns/process-report th/*system* report)
(let [rows (db/query pool :profile-complaint-report {:profile-id (:id profile)})]
(t/is (= 1 (count rows))))

9
backend/test/backend_tests/helpers.clj
View File

@@ -62,7 +62,8 @@
(def default
{:database-uri "postgresql://postgres/penpot_test"
:redis-uri "redis://redis/1"
:auto-file-snapshot-every 1})
:auto-file-snapshot-every 1
:file-data-backend "db"})
(def config
(cf/read-config :prefix "penpot-test"
@@ -74,9 +75,6 @@
:enable-smtp
:enable-quotes
:enable-rpc-climit
:enable-feature-fdata-pointer-map
:enable-feature-fdata-objets-map
:enable-feature-components-v2
:enable-auto-file-snapshot
:disable-file-validation])
@@ -99,7 +97,7 @@
:thumbnail-uri "test"
:path (-> "backend_tests/test_files/template.penpot" io/resource fs/path)}]
system (-> (merge main/system-config main/worker-config)
(assoc-in [:app.redis/redis :app.redis/uri] (:redis-uri config))
(assoc-in [:app.redis/client :app.redis/uri] (:redis-uri config))
(assoc-in [::db/pool ::db/uri] (:database-uri config))
(assoc-in [::db/pool ::db/username] (:database-username config))
(assoc-in [::db/pool ::db/password] (:database-password config))
@@ -113,7 +111,6 @@
:app.auth.oidc.providers/generic
:app.setup/templates
:app.auth.oidc/routes
:app.worker/monitor
:app.http.oauth/handler
:app.notifications/handler
:app.loggers.mattermost/reporter

3
backend/test/backend_tests/http_management_test.clj
View File

@@ -25,8 +25,7 @@
(t/deftest authenticate-method
(let [profile (th/create-profile* 1)
props (get th/*system* :app.setup/props)
token (#'sess/gen-token props {:profile-id (:id profile)})
token (#'sess/gen-token th/*system* {:profile-id (:id profile)})
request {:params {:token token}}
response (#'mgmt/authenticate th/*system* request)]

59
backend/test/backend_tests/http_middleware_security.clj Normal file
View File

@@ -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 backend-tests.http-middleware-security
(:require
[app.http.security :as sec]
[clojure.test :as t]
[yetti.request :as yreq]
[yetti.response :as yres]))
(defn- mock-request
[method value]
(reify yreq/IRequest
(method [_]
method)
(get-header [_ _]
value)))
(t/deftest sec-fetch-metadata
(let [request1 (mock-request :get "same-origin")
request2 (mock-request :post "same-origin")
request3 (mock-request :get "same-site")
request4 (mock-request :post "same-site")
request5 (mock-request :get "cross-site")
request6 (mock-request :post "cross-site")
handler (fn [request]
{::yres/status 200})
handler (#'sec/wrap-sec-fetch-metadata handler)
resp1 (handler request1)
resp2 (handler request2)
resp3 (handler request3)
resp4 (handler request4)
resp5 (handler request5)
resp6 (handler request6)]
(t/is (= 200 (::yres/status resp1)))
(t/is (= 200 (::yres/status resp2)))
(t/is (= 200 (::yres/status resp3)))
(t/is (= 403 (::yres/status resp4)))
(t/is (= 200 (::yres/status resp5)))
(t/is (= 403 (::yres/status resp6)))))
(t/deftest client-header-check
(let [request1 (mock-request :get "some")
request2 (mock-request :post nil)
handler (fn [request]
{::yres/status 200})
handler (#'sec/wrap-client-header-check handler)
resp1 (handler request1)
resp2 (handler request2)]
(t/is (= 200 (::yres/status resp1)))
(t/is (= 403 (::yres/status resp2)))))

1
backend/test/backend_tests/rpc_comment_test.clj
View File

@@ -144,7 +144,6 @@
(t/is (not= (:modified-at comment) (:modified-at comment')))
(t/is (= (:content data) (:content comment'))))))
(t/testing "retrieve threads"
(let [data {::th/type :get-comment-threads
::rpc/profile-id (:id profile-1)

2
backend/test/backend_tests/rpc_doc_test.clj
View File

@@ -29,7 +29,7 @@
true
(catch Throwable _cause
false)))
{:num 30}))
{:num 15}))

26
backend/test/backend_tests/rpc_file_snapshot_test.clj
View File

@@ -8,10 +8,10 @@
(:require
[app.common.features :as cfeat]
[app.common.pprint :as pp]
[app.common.pprint :as pp]
[app.common.thumbnails :as thc]
[app.common.types.shape :as cts]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as sql]
[app.http :as http]
@@ -87,10 +87,7 @@
;; (th/print-result! out)
(t/is (nil? (:error out)))
(let [result (:result out)]
(t/is (= "label1" (:label result)))
(t/is (uuid? (:id result)))))
(t/is (nil? (:result out))))
(let [[row1 row2 :as rows]
(th/db-query :file-change
@@ -116,7 +113,7 @@
;; (th/print-result! out)
(t/is (nil? (:error out)))
(t/is (nil? (:result out)))))
(t/is (true? (:result out)))))
(t/testing "delete system created snapshot"
(let [params {::th/type :delete-file-snapshot
@@ -130,7 +127,14 @@
data (ex-data error)]
(t/is (th/ex-info? error))
(t/is (= (:type data) :validation))
(t/is (= (:code data) :system-snapshots-cant-be-deleted)))))))))
(t/is (= (:code data) :system-snapshots-cant-be-deleted)))))
;; this will run pending task triggered by deleting user snapshot
(th/run-pending-tasks!)
(let [res (th/run-task! :objects-gc {:deletion-threshold (cf/get-deletion-delay)})]
;; delete 2 snapshots and 2 file data entries
(t/is (= 4 (:processed res))))))))
(t/deftest snapshots-locking
(let [profile-1 (th/create-profile* 1 {:is-active true})
@@ -172,9 +176,9 @@
out (th/command! params)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(t/is (nil? (:result out)))
(t/is (true? (:result out)))
(let [snapshot (th/db-get :file-change {:id (:id snapshot)})]
(let [snapshot (th/db-get :file-change {:id (:id snapshot)} {::db/remove-deleted false})]
(t/is (= (:id profile-1) (:locked-by snapshot))))))
(t/testing "delete locked snapshot"
@@ -199,7 +203,7 @@
out (th/command! params)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(t/is (nil? (:result out)))
(t/is (true? (:result out)))
(let [snapshot (th/db-get :file-change {:id (:id snapshot)})]
(t/is (= nil (:locked-by snapshot))))))
@@ -213,4 +217,4 @@
;; (th/print-result! out)
(t/is (nil? (:error out)))
(t/is (nil? (:result out)))))))
(t/is (true? (:result out)))))))

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

@@ -15,6 +15,7 @@
[app.config :as cf]
[app.db :as db]
[app.db.sql :as sql]
[app.features.fdata :as fdata]
[app.http :as http]
[app.rpc :as-alias rpc]
[app.rpc.commands.files :as files]
@@ -116,29 +117,8 @@
(t/is (nil? (:error out)))
(t/is (nil? (:result out)))))
(t/testing "query single file after delete"
(let [data {::th/type :get-file
::rpc/profile-id (:id prof)
:id file-id
:components-v2 true}
out (th/command! data)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(let [result (:result out)]
(t/is (some? (:deleted-at result)))
(t/is (= file-id (:id result)))
(t/is (= "new name" (:name result)))
(t/is (= 1 (count (get-in result [:data :pages]))))
(t/is (nil? (:users result))))))
(th/db-update! :file
{:deleted-at (ct/now)}
{:id file-id})
(t/testing "query single file after delete and wait"
(let [data {::th/type :get-file
::rpc/profile-id (:id prof)
:id file-id
@@ -185,10 +165,10 @@
shape-id (uuid/random)]
;; Preventive file-gc
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file) :revn (:revn file)})))
;; Check the number of fragments before adding the page
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
(t/is (= 2 (count rows))))
;; Add page
@@ -203,22 +183,23 @@
:id page-id}])
;; Check the number of fragments before adding the page
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
(t/is (= 3 (count rows))))
;; The file-gc should mark for remove unused fragments
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; Check the number of fragments
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(t/is (= 5 (count rows))))
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
(t/is (= 5 (count rows)))
(t/is (= 3 (count (filterv :deleted-at rows)))))
;; The objects-gc should remove unused fragments
(let [res (th/run-task! :objects-gc {})]
(t/is (= 3 (:processed res))))
;; Check the number of fragments
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
(t/is (= 2 (count rows))))
;; Add shape to page that should add a new fragment
@@ -242,44 +223,47 @@
:type :rect})}])
;; Check the number of fragments
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
(t/is (= 3 (count rows))))
;; The file-gc should mark for remove unused fragments
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; The objects-gc should remove unused fragments
(let [res (th/run-task! :objects-gc {})]
(t/is (= 3 (:processed res))))
;; Check the number of fragments;
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)
(let [rows (th/db-query :file-data {:file-id (:id file)
:type "fragment"
:deleted-at nil})]
(t/is (= 2 (count rows))))
;; Lets proceed to delete all changes
(th/db-delete! :file-change {:file-id (:id file)})
(th/db-delete! :file-data {:file-id (:id file) :type "snapshot"})
(th/db-update! :file
{:has-media-trimmed false}
{:id (:id file)})
;; The file-gc should remove fragments related to changes
;; snapshots previously deleted.
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; Check the number of fragments;
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
;; (pp/pprint rows)
(t/is (= 4 (count rows)))
(t/is (= 2 (count (remove (comp some? :deleted-at) rows)))))
(t/is (= 2 (count (remove :deleted-at rows)))))
(let [res (th/run-task! :objects-gc {})]
(t/is (= 2 (:processed res))))
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
(t/is (= 2 (count rows)))))))
(t/deftest file-gc-task-with-thumbnails
(t/deftest file-gc-with-thumbnails
(letfn [(add-file-media-object [& {:keys [profile-id file-id]}]
(let [mfile {:filename "sample.jpg"
:path (th/tempfile "backend_tests/test_files/sample.jpg")
@@ -347,7 +331,7 @@
:fills [{:fill-opacity 1
:fill-image {:id (:id fmo1) :width 100 :height 100 :mtype "image/jpeg"}}]})}])
;; Check that reference storage objects on filemediaobjects
;; Check that reference storage objects on file_media_objects
;; are the same because of deduplication feature.
(t/is (= (:media-id fmo1) (:media-id fmo2)))
(t/is (= (:thumbnail-id fmo1) (:thumbnail-id fmo2)))
@@ -360,32 +344,33 @@
(t/is (= 2 (:freeze res)))
(t/is (= 0 (:delete res))))
;; run the file-gc task immediately without forced min-age
(t/is (false? (th/run-task! :file-gc {:file-id (:id file)})))
;; run the task again
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; retrieve file and check trimmed attribute
(let [row (th/db-get :file {:id (:id file)})]
(t/is (true? (:has-media-trimmed row))))
;; check file media objects
(let [rows (th/db-query :file-media-object {:file-id (:id file)})]
(t/is (= 2 (count rows)))
(t/is (= 1 (count (remove (comp some? :deleted-at) rows)))))
(let [[row1 row2 :as rows]
(th/db-query :file-media-object
{:file-id (:id file)}
{:order-by [:created-at]})]
(t/is (= (:id fmo1) (:id row1)))
(t/is (= (:id fmo2) (:id row2)))
(t/is (ct/inst? (:deleted-at row2))))
(let [res (th/run-task! :objects-gc {})]
;; delete 2 fragments and 1 media object
(t/is (= 3 (:processed res))))
;; check file media objects
(let [rows (th/db-query :file-media-object {:file-id (:id file)})]
(t/is (= 1 (count rows)))
(t/is (= 1 (count (remove (comp some? :deleted-at) rows)))))
(t/is (= 1 (count (remove :deleted-at rows)))))
;; The underlying storage objects are still available.
(t/is (some? (sto/get-object storage (:media-id fmo2))))
(t/is (some? (sto/get-object storage (:thumbnail-id fmo2))))
(t/is (some? (sto/get-object storage (:media-id fmo1))))
(t/is (some? (sto/get-object storage (:thumbnail-id fmo1))))
@@ -402,34 +387,40 @@
;; Now, we have deleted the usage of pointers to the
;; file-media-objects, if we paste file-gc, they should be marked
;; as deleted.
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; This only clears fragments, the file media objects still referenced because
;; snapshots are preserved
(let [res (th/run-task! :objects-gc {})]
(t/is (= 2 (:processed res))))
;; Mark all snapshots to be a non-snapshot file change
(th/db-exec! ["update file_change set data = null where file_id = ?" (:id file)])
;; Delete all snapshots
(th/db-exec! ["update file_data set deleted_at = now() where file_id = ? and type = 'snapshot'" (:id file)])
(th/db-exec! ["update file_change set deleted_at = now() where file_id = ? and label is not null" (:id file)])
(th/db-exec! ["update file set has_media_trimmed = false where id = ?" (:id file)])
(let [res (th/run-task! :objects-gc {:deletion-threshold 0})]
;; this will remove the file change and file data entries for two snapshots
(t/is (= 4 (:processed res))))
;; Rerun the file-gc and objects-gc
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(let [res (th/run-task! :objects-gc {})]
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(let [res (th/run-task! :objects-gc {:deletion-threshold 0})]
;; this will remove the file media objects marked as deleted
;; on prev file-gc
(t/is (= 2 (:processed res))))
;; Now that file-gc have deleted the file-media-object usage,
;; lets execute the touched-gc task, we should see that two of
;; them are marked to be deleted.
;; them are marked to be deleted
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 0 (:freeze res)))
(t/is (= 2 (:delete res))))
;; Finally, check that some of the objects that are marked as
;; deleted we are unable to retrieve them using standard storage
;; public api.
(t/is (nil? (sto/get-object storage (:media-id fmo2))))
(t/is (nil? (sto/get-object storage (:thumbnail-id fmo2))))
;; public api
(t/is (nil? (sto/get-object storage (:media-id fmo1))))
(t/is (nil? (sto/get-object storage (:thumbnail-id fmo1)))))))
@@ -470,7 +461,8 @@
page-id (first (get-in file [:data :pages]))]
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)
(let [rows (th/db-query :file-data {:file-id (:id file)
:type "fragment"
:deleted-at nil})]
(t/is (= (count rows) 1)))
@@ -536,16 +528,14 @@
:strokes [{:stroke-opacity 1 :stroke-image {:id (:id fmo5) :width 100 :height 100 :mtype "image/jpeg"}}]})}])
;; run the file-gc task immediately without forced min-age
(t/is (false? (th/run-task! :file-gc {:file-id (:id file)})))
;; run the task again
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(let [res (th/run-task! :objects-gc {})]
(t/is (= 2 (:processed res))))
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)
(let [rows (th/db-query :file-data {:file-id (:id file)
:type "fragment"
:deleted-at nil})]
(t/is (= (count rows) 1)))
@@ -583,7 +573,7 @@
;; Now, we have deleted the usage of pointers to the
;; file-media-objects, if we paste file-gc, they should be marked
;; as deleted.
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; This only removes unused fragments, file media are still
;; referenced on snapshots.
@@ -592,15 +582,17 @@
;; Mark all snapshots to be a non-snapshot file change
(th/db-exec! ["update file set has_media_trimmed = false where id = ?" (:id file)])
(th/db-exec! ["update file_change set data = null where file_id = ?" (:id file)])
(th/db-delete! :file-data {:file-id (:id file)
:type "snapshot"})
;; Rerun file-gc and objects-gc task for the same file once all snapshots are
;; "expired/deleted"
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(let [res (th/run-task! :objects-gc {})]
(t/is (= 6 (:processed res))))
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)
(let [rows (th/db-query :file-data {:file-id (:id file)
:type "fragment"
:deleted-at nil})]
(t/is (= (count rows) 1)))
@@ -620,7 +612,7 @@
(t/is (nil? (sto/get-object storage (:media-id fmo2))))
(t/is (nil? (sto/get-object storage (:media-id fmo1)))))))
(t/deftest file-gc-task-with-object-thumbnails
(t/deftest file-gc-with-object-thumbnails
(letfn [(insert-file-object-thumbnail! [& {:keys [profile-id file-id page-id frame-id]}]
(let [object-id (thc/fmt-object-id file-id page-id frame-id "frame")
mfile {:filename "sample.jpg"
@@ -704,11 +696,7 @@
(t/is (= 1 (:freeze res)))
(t/is (= 0 (:delete res))))
;; run the file-gc task immediately without forced min-age
(t/is (false? (th/run-task! :file-gc {:file-id (:id file)})))
;; run the task again
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; retrieve file and check trimmed attribute
(let [row (th/db-get :file {:id (:id file)})]
@@ -738,7 +726,7 @@
:page-id page-id
:id frame-id-2}])
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(let [rows (th/db-query :file-tagged-object-thumbnail {:file-id file-id})]
(t/is (= 2 (count rows)))
@@ -772,7 +760,7 @@
:page-id page-id
:id frame-id-1}])
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
(let [rows (th/db-query :file-tagged-object-thumbnail {:file-id file-id})]
(t/is (= 1 (count rows)))
@@ -933,6 +921,8 @@
out (th/command! params)]
(t/is (nil? (:error out))))
(th/run-pending-tasks!)
;; query the list of files after soft deletion
(let [data {::th/type :get-project-files
::rpc/profile-id (:id profile1)
@@ -943,23 +933,24 @@
(let [result (:result out)]
(t/is (= 0 (count result)))))
;; run permanent deletion (should be noop)
(let [result (th/run-task! :objects-gc {})]
(t/is (= 0 (:processed result))))
;; query the list of file libraries of a after hard deletion
(let [data {::th/type :get-file-libraries
::rpc/profile-id (:id profile1)
:file-id (:id file)}
out (th/command! data)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(let [result (:result out)]
(t/is (= 0 (count result)))))
(let [error (:error out)
error-data (ex-data error)]
(t/is (th/ex-info? error))
(t/is (= (:type error-data) :not-found))))
;; run permanent deletion (should be noop)
(let [result (th/run-task! :objects-gc {})]
(t/is (= 0 (:processed result))))
;; run permanent deletion
(let [result (th/run-task! :objects-gc {:deletion-threshold (cf/get-deletion-delay)})]
(t/is (= 1 (:processed result))))
(t/is (= 3 (:processed result))))
;; query the list of file libraries of a after hard deletion
(let [data {::th/type :get-file-libraries
@@ -972,7 +963,6 @@
(t/is (th/ex-info? error))
(t/is (= (:type error-data) :not-found))))))
(t/deftest object-thumbnails-ops
(let [prof (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id prof)
@@ -1282,17 +1272,19 @@
:is-shared false})
page-id (uuid/random)
shape-id (uuid/random)]
shape-id (uuid/random)
sobject (volatile! nil)]
;; Preventive file-gc
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; Preventive objects-gc
(let [result (th/run-task! :objects-gc {})]
;; deletes the fragment created by file-gc
(t/is (= 1 (:processed result))))
;; Check the number of fragments before adding the page
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
(t/is (= 1 (count rows)))
(t/is (every? #(some? (:data %)) rows)))
@@ -1303,29 +1295,36 @@
;; Run FileGC again, with tiered storage activated
(with-redefs [app.config/flags (conj app.config/flags :tiered-file-data-storage)]
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)}))))
;; The FileGC task will schedule an inner taskq
(th/run-pending-tasks!))
(th/run-pending-tasks!)
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 2 (:freeze res)))
(t/is (= 0 (:delete res))))
;; Clean objects after file-gc
(let [result (th/run-task! :objects-gc {})]
(t/is (= 1 (:processed result))))
;; Check the number of fragments before adding the page
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
;; (pp/pprint rows)
(t/is (= 1 (count rows)))
(t/is (every? #(nil? (:data %)) rows))
(t/is (every? #(uuid? (:data-ref-id %)) rows))
(t/is (every? #(= "objects-storage" (:data-backend %)) rows)))
(t/is (every? #(= "storage" (:backend %)) rows)))
(let [file (th/db-get :file {:id (:id file)})
(let [file (-> (th/db-get :file-data {:id (:id file) :type "main"})
(update :metadata fdata/decode-metadata))
storage (sto/resolve th/*system*)]
(t/is (= "objects-storage" (:data-backend file)))
;; (pp/pprint file)
(t/is (= "storage" (:backend file)))
(t/is (nil? (:data file)))
(t/is (uuid? (:data-ref-id file)))
(let [sobj (sto/get-object storage (:data-ref-id file))]
(let [sobj (sto/get-object storage (-> file :metadata :storage-ref-id))]
(vreset! sobject sobj)
;; (pp/pprint (meta sobj))
(t/is (= "file-data" (:bucket (meta sobj))))
(t/is (= (:id file) (:file-id (meta sobj))))))
@@ -1340,36 +1339,68 @@
:name "test"
:id page-id}])
;; Check the number of fragments
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(t/is (= 2 (count rows))))
;; Check the number of fragments
(let [[row1 row2 :as rows]
(th/db-query :file-data-fragment
(th/db-query :file-data
{:file-id (:id file)
:deleted-at nil}
:type "fragment"}
{:order-by [:created-at]})]
;; (pp/pprint rows)
(t/is (= 2 (count rows)))
(t/is (nil? (:data row1)))
(t/is (= "objects-storage" (:data-backend row1)))
(t/is (= "storage" (:backend row1)))
(t/is (bytes? (:data row2)))
(t/is (nil? (:data-backend row2))))
(t/is (= "db" (:backend row2))))
;; The file-gc should mark for remove unused fragments
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; The objects-gc should remove unused fragments
;; The file-gc task, recreates all fragments, so after it we have
;; now the double of fragments, and the old ones are marked as
;; deleted, and the new ones are on DB
(let [[row1 row2 row3 row4 :as rows]
(th/db-query :file-data
{:file-id (:id file)
:type "fragment"}
{:order-by [:created-at]})]
;; (pp/pprint rows)
(t/is (= 4 (count rows)))
(t/is (nil? (:data row1)))
(t/is (ct/inst? (:deleted-at row1)))
(t/is (= "storage" (:backend row1)))
(t/is (bytes? (:data row2)))
(t/is (= "db" (:backend row2)))
(t/is (ct/inst? (:deleted-at row2)))
(t/is (bytes? (:data row3)))
(t/is (= "db" (:backend row3)))
(t/is (nil? (:deleted-at row3)))
(t/is (bytes? (:data row4)))
(t/is (= "db" (:backend row4)))
(t/is (nil? (:deleted-at row4))))
;; The objects-gc should remove the marked to delete fragments
(let [res (th/run-task! :objects-gc {})]
(t/is (= 2 (:processed res))))
;; Check the number of fragments before adding the page
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(let [rows (th/db-query :file-data {:file-id (:id file) :type "fragment"})]
(t/is (= 2 (count rows)))
(t/is (every? #(bytes? (:data %)) rows))
(t/is (every? #(nil? (:data-ref-id %)) rows))
(t/is (every? #(nil? (:data-backend %)) rows)))))
(t/is (every? #(= "db" (:backend %)) rows)))
;; we ensure that once object-gc is passed and marked two storage
;; objects to delete
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 0 (:freeze res)))
(t/is (= 2 (:delete res))))
(let [storage (sto/resolve th/*system*)]
(t/is (uuid? (:id @sobject)))
(t/is (nil? (sto/get-object storage (:id @sobject)))))))
(t/deftest file-gc-with-components-1
(let [storage (:app.storage/storage th/*system*)
@@ -1384,7 +1415,8 @@
page-id (first (get-in file [:data :pages]))]
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)
(let [rows (th/db-query :file-data {:file-id (:id file)
:type "fragment"
:deleted-at nil})]
(t/is (= (count rows) 1)))
@@ -1437,11 +1469,8 @@
:id c-id
:anotation nil}])
;; Run the file-gc task immediately without forced min-age
(t/is (false? (th/run-task! :file-gc {:file-id (:id file)})))
;; Run the task again
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file)})))
;; Retrieve file and check trimmed attribute
(let [row (th/db-get :file {:id (:id file)})]
@@ -1651,8 +1680,7 @@
(t/is (some? (not-empty (:objects component))))))
;; Re-run the file-gc task
(t/is (true? (th/run-task! :file-gc {:min-age 0 :file-id (:id file-1)})))
(t/is (false? (th/run-task! :file-gc {:min-age 0 :file-id (:id file-2)})))
(t/is (true? (th/run-task! :file-gc {:file-id (:id file-1)})))
;; Check that component is still there after file-gc task
(let [data {::th/type :get-file

22
backend/test/backend_tests/rpc_management_test.clj
View File

@@ -39,8 +39,6 @@
(t/is (nil? (:error out)))
(:result out)))
;; TODO: migrate to commands
(t/deftest duplicate-file
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))
@@ -233,15 +231,7 @@
;; check that the both files are equivalent
(doseq [[fa fb] (map vector p1-files p2-files)]
(t/is (not= (:id fa) (:id fb)))
(t/is (= (:name fa) (:name fb)))
(when (= (:id fa) (:id file1))
(t/is (false? (b/equals? (:data fa)
(:data fb)))))
(when (= (:id fa) (:id file2))
(t/is (false? (b/equals? (:data fa)
(:data fb)))))))))))
(t/is (= (:name fa) (:name fb)))))))))
(t/deftest duplicate-project-with-deleted-files
(let [storage (-> (:app.storage/storage th/*system*)
@@ -297,15 +287,7 @@
;; check that the both files are equivalent
(doseq [[fa fb] (map vector (rest p1-files) p2-files)]
(t/is (not= (:id fa) (:id fb)))
(t/is (= (:name fa) (:name fb)))
(when (= (:id fa) (:id file1))
(t/is (false? (b/equals? (:data fa)
(:data fb)))))
(when (= (:id fa) (:id file2))
(t/is (false? (b/equals? (:data fa)
(:data fb)))))))))))
(t/is (= (:name fa) (:name fb)))))))))
(t/deftest move-file-on-same-team
(let [profile (th/create-profile* 1 {:is-active true})

21
backend/test/backend_tests/rpc_profile_test.clj
View File

@@ -162,7 +162,7 @@
;; execute permanent deletion task
(let [result (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 4 (:processed result))))
(t/is (= 6 (:processed result))))
(let [row (th/db-get :team
{:id (:default-team-id prof)}
@@ -324,7 +324,7 @@
;; execute permanent deletion task
(let [result (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 4 (:processed result))))
(t/is (= 6 (:processed result))))
(let [row (th/db-get :team
{:id (:default-team-id prof1)}
@@ -363,7 +363,7 @@
;; execute permanent deletion task
(let [result (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 8 (:processed result))))))
(t/is (= 10 (:processed result))))))
(t/deftest email-blacklist-1
@@ -514,8 +514,7 @@
(t/is (= 0 (:call-count @mock))))))))
(t/deftest prepare-and-register-with-invitation-and-enabled-registration-1
(let [sprops (:app.setup/props th/*system*)
itoken (tokens/generate sprops
(let [itoken (tokens/generate th/*system*
{:iss :team-invitation
:exp (ct/in-future "48h")
:role :editor
@@ -543,8 +542,7 @@
(t/is (string? (:invitation-token result))))))
(t/deftest prepare-and-register-with-invitation-and-enabled-registration-2
(let [sprops (:app.setup/props th/*system*)
itoken (tokens/generate sprops
(let [itoken (tokens/generate th/*system*
{:iss :team-invitation
:exp (ct/in-future "48h")
:role :editor
@@ -565,8 +563,7 @@
(t/deftest prepare-and-register-with-invitation-and-disabled-registration-1
(with-redefs [app.config/flags [:disable-registration]]
(let [sprops (:app.setup/props th/*system*)
itoken (tokens/generate sprops
(let [itoken (tokens/generate th/*system*
{:iss :team-invitation
:exp (ct/in-future "48h")
:role :editor
@@ -586,8 +583,7 @@
(t/deftest prepare-and-register-with-invitation-and-disabled-registration-2
(with-redefs [app.config/flags [:disable-registration]]
(let [sprops (:app.setup/props th/*system*)
itoken (tokens/generate sprops
(let [itoken (tokens/generate th/*system*
{:iss :team-invitation
:exp (ct/in-future "48h")
:role :editor
@@ -608,8 +604,7 @@
(t/deftest prepare-and-register-with-invitation-and-disabled-login-with-password
(with-redefs [app.config/flags [:disable-login-with-password]]
(let [sprops (:app.setup/props th/*system*)
itoken (tokens/generate sprops
(let [itoken (tokens/generate th/*system*
{:iss :team-invitation
:exp (ct/in-future "48h")
:role :editor

11
backend/test/backend_tests/rpc_team_test.clj
View File

@@ -208,8 +208,6 @@
profile2 (th/create-profile* 2 {:is-active true})
team (th/create-team* 1 {:profile-id (:id profile1)})
sprops (:app.setup/props th/*system*)
pool (:app.db/pool th/*system*)]
;; Try to invite a not existing user
@@ -226,7 +224,7 @@
(t/is (= 1 (-> out :result :total)))
(let [token (-> out :result :invitations first)
claims (tokens/decode sprops token)]
claims (tokens/decode th/*system* token)]
(t/is (= :team-invitation (:iss claims)))
(t/is (= (:id profile1) (:profile-id claims)))
(t/is (= :editor (:role claims)))
@@ -250,7 +248,7 @@
(t/is (= 1 (-> out :result :total)))
(let [token (-> out :result :invitations first)
claims (tokens/decode sprops token)]
claims (tokens/decode th/*system* token)]
(t/is (= :team-invitation (:iss claims)))
(t/is (= (:id profile1) (:profile-id claims)))
(t/is (= :editor (:role claims)))
@@ -266,10 +264,9 @@
team (th/create-team* 1 {:profile-id (:id profile1)})
sprops (:app.setup/props th/*system*)
pool (:app.db/pool th/*system*)]
(let [token (tokens/generate sprops
(let [token (tokens/generate th/*system*
{:iss :team-invitation
:exp (ct/in-future "1h")
:profile-id (:id profile1)
@@ -585,7 +582,7 @@
(t/is (ct/inst? (:deleted-at (first rows)))))
(let [result (th/run-task! :objects-gc {:deletion-threshold (cf/get-deletion-delay)})]
(t/is (= 5 (:processed result))))))
(t/is (= 7 (:processed result))))))
(t/deftest create-team-access-request
(with-mocks [mock {:target 'app.email/send! :return nil}]

24
common/deps.edn
View File

@@ -6,26 +6,28 @@
org.clojure/data.fressian {:mvn/version "1.1.0"}
org.clojure/clojurescript {:mvn/version "1.12.42"}
org.apache.commons/commons-pool2 {:mvn/version "2.12.1"}
;; Logging
org.apache.logging.log4j/log4j-api {:mvn/version "2.24.3"}
org.apache.logging.log4j/log4j-core {:mvn/version "2.24.3"}
org.apache.logging.log4j/log4j-web {:mvn/version "2.24.3"}
org.apache.logging.log4j/log4j-jul {:mvn/version "2.24.3"}
org.apache.logging.log4j/log4j-slf4j2-impl {:mvn/version "2.24.3"}
org.apache.logging.log4j/log4j-api {:mvn/version "2.25.1"}
org.apache.logging.log4j/log4j-core {:mvn/version "2.25.1"}
org.apache.logging.log4j/log4j-web {:mvn/version "2.25.1"}
org.apache.logging.log4j/log4j-jul {:mvn/version "2.25.1"}
org.apache.logging.log4j/log4j-slf4j2-impl {:mvn/version "2.25.1"}
org.slf4j/slf4j-api {:mvn/version "2.0.17"}
pl.tkowalcz.tjahzi/log4j2-appender {:mvn/version "0.9.32"}
pl.tkowalcz.tjahzi/log4j2-appender {:mvn/version "0.9.40"}
selmer/selmer {:mvn/version "1.12.62"}
criterium/criterium {:mvn/version "0.4.6"}
metosin/jsonista {:mvn/version "0.3.13"}
metosin/malli {:mvn/version "0.18.0"}
metosin/malli {:mvn/version "0.19.1"}
expound/expound {:mvn/version "0.9.0"}
com.cognitect/transit-clj {:mvn/version "1.0.333"}
com.cognitect/transit-cljs {:mvn/version "0.8.280"}
java-http-clj/java-http-clj {:mvn/version "0.4.3"}
integrant/integrant {:mvn/version "0.13.1"}
integrant/integrant {:mvn/version "1.0.0"}
funcool/tubax {:mvn/version "2021.05.20-0"}
funcool/cuerdas {:mvn/version "2025.06.16-414"}
@@ -47,7 +49,7 @@
org.la4j/la4j {:mvn/version "0.6.0"}
;; exception printing
fipp/fipp {:mvn/version "0.6.27"}
fipp/fipp {:mvn/version "0.6.29"}
me.flowthing/pp {:mvn/version "2024-11-13.77"}
@@ -59,7 +61,7 @@
{:dev
{:extra-deps
{org.clojure/tools.namespace {:mvn/version "RELEASE"}
thheller/shadow-cljs {:mvn/version "3.1.5"}
thheller/shadow-cljs {:mvn/version "3.2.0"}
com.clojure-goes-fast/clj-async-profiler {:mvn/version "RELEASE"}
com.bhauman/rebel-readline {:mvn/version "RELEASE"}
criterium/criterium {:mvn/version "RELEASE"}
@@ -68,7 +70,7 @@
:build
{:extra-deps
{io.github.clojure/tools.build {:git/tag "v0.10.9" :git/sha "e405aac"}}
{io.github.clojure/tools.build {:mvn/version "0.10.10"}}
:ns-default build}
:test

74
common/src/app/common/buffer.cljc
View File

@@ -50,6 +50,13 @@
(let [target (with-meta target {:tag 'java.nio.ByteBuffer})]
`(long (.getInt ~target (unchecked-int ~offset))))))
(defmacro read-long
[target offset]
(if (:ns &env)
`(.getInt64 ~target ~offset true)
(let [target (with-meta target {:tag 'java.nio.ByteBuffer})]
`(.getLong ~target (unchecked-int ~offset)))))
(defmacro read-float
[target offset]
(if (:ns &env)
@@ -75,6 +82,40 @@
(finally
(.order ~target ByteOrder/LITTLE_ENDIAN))))))
(defmacro read-bytes
"Get a byte array from buffer. It is potentially unsafe because on
JS/CLJS it returns a subarray without doing any copy of data."
[target offset size]
(if (:ns &env)
`(new js/Uint8Array
(.-buffer ~target)
(+ (.-byteOffset ~target) ~offset)
~size)
(let [target (with-meta target {:tag 'java.nio.ByteBuffer})
bbuf (with-meta (gensym "bbuf") {:tag bytes})]
`(let [~bbuf (byte-array ~size)]
(.get ~target
(unchecked-int ~offset)
~bbuf
0
~size)
~bbuf))))
;; FIXME: implement in cljs
(defmacro write-bytes
([target offset src size]
`(write-bytes ~target ~offset ~src 0 ~size))
([target offset src src-offset size]
(if (:ns &env)
(throw (ex-info "not implemented" {}))
(let [target (with-meta target {:tag 'java.nio.ByteBuffer})
src (with-meta src {:tag 'bytes})]
`(.put ~target
(unchecked-int ~offset)
~src
(unchecked-int ~src-offset)
(unchecked-int ~size))))))
(defmacro write-byte
[target offset value]
(if (:ns &env)
@@ -144,13 +185,15 @@
(.setUint32 ~target (+ ~offset 12) (aget barray# 3) true))
(let [target (with-meta target {:tag 'java.nio.ByteBuffer})
value (with-meta value {:tag 'java.util.UUID})]
`(try
value (with-meta value {:tag 'java.util.UUID})
prev (with-meta (gensym "prev-") {:tag 'java.nio.ByteOrder})]
`(let [~prev (.order ~target)]
(try
(.order ~target ByteOrder/BIG_ENDIAN)
(.putLong ~target (unchecked-int (+ ~offset 0)) (.getMostSignificantBits ~value))
(.putLong ~target (unchecked-int (+ ~offset 8)) (.getLeastSignificantBits ~value))
(finally
(.order ~target ByteOrder/LITTLE_ENDIAN))))))
(.order ~target ~prev)))))))
(defn wrap
[data]
@@ -160,7 +203,7 @@
(defn allocate
[size]
#?(:clj (let [buffer (ByteBuffer/allocate (int size))]
#?(:clj (let [buffer (ByteBuffer/allocate (unchecked-int size))]
(.order buffer ByteOrder/LITTLE_ENDIAN))
:cljs (new js/DataView (new js/ArrayBuffer size))))
@@ -181,6 +224,14 @@
(.set dst-view src-view)
(js/DataView. dst-buff))))
;; FIXME: cljs impl
#?(:clj
(defn copy-bytes
[src src-offset size dst dst-offset]
(let [tmp (byte-array size)]
(.get ^ByteBuffer src src-offset tmp 0 size)
(.put ^ByteBuffer dst dst-offset tmp 0 size))))
(defn equals?
[buffer-a buffer-b]
#?(:clj
@@ -208,3 +259,18 @@
[o]
#?(:clj (instance? ByteBuffer o)
:cljs (instance? js/DataView o)))
(defn slice
[buffer offset size]
#?(:cljs
(let [offset (+ (.-byteOffset buffer) offset)]
(new js/DataView (.-buffer buffer) offset size))
:clj
(-> (.slice ^ByteBuffer buffer (unchecked-int offset) (unchecked-int size))
(.order ByteOrder/LITTLE_ENDIAN))))
(defn size
[o]
#?(:cljs (.-byteLength ^js o)
:clj (.capacity ^ByteBuffer o)))

Some files were not shown because too many files have changed in this diff Show More