github/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2026-04-25 19:28:12 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/develop' into staging

Browse Source
This commit is contained in:
Andrey Antukh 2024-11-15 09:35:21 +01:00
commit 45d56f40e1
506 changed files with 61580 additions and 76544 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

249
.circleci/config.yml
View File

@ -1,6 +1,124 @@
version: 2
version: 2.1
jobs:
build:
test-common:
docker:
- image: penpotapp/devenv:latest
working_directory: ~/repo
resource_class: medium+
environment:
JAVA_OPTS: -Xmx4g -Xms100m -XX:+UseSerialGC
NODE_OPTIONS: --max-old-space-size=4096
steps:
- checkout
# Download and cache dependencies
- restore_cache:
keys:
- v1-dependencies-{{ checksum "common/deps.edn"}}
- run:
name: "fmt check & linter"
working_directory: "./common"
command: |
yarn install
yarn run fmt:clj:check
yarn run lint:clj
- run:
name: "JVM tests"
working_directory: "./common"
command: |
clojure -M:dev:test
- save_cache:
paths:
- ~/.m2
key: v1-dependencies-{{ checksum "common/deps.edn"}}
test-frontend:
docker:
- image: penpotapp/devenv:latest
working_directory: ~/repo
resource_class: medium+
environment:
JAVA_OPTS: -Xmx4g -Xms100m -XX:+UseSerialGC
NODE_OPTIONS: --max-old-space-size=4096
steps:
- checkout
# Download and cache dependencies
- restore_cache:
keys:
- v1-dependencies-{{ checksum "frontend/deps.edn"}}
- run:
name: "prepopulate linter cache"
working_directory: "./common"
command: |
yarn install
yarn run lint:clj
- run:
name: "fmt check & linter"
working_directory: "./frontend"
command: |
yarn install
yarn run fmt:clj:check
yarn run fmt:js:check
yarn run lint:scss
yarn run lint:clj
- run:
name: "unit tests"
working_directory: "./frontend"
command: |
yarn install
yarn run test
- save_cache:
paths:
- ~/.m2
key: v1-dependencies-{{ checksum "frontend/deps.edn"}}
test-integration:
docker:
- image: penpotapp/devenv:latest
working_directory: ~/repo
resource_class: large
environment:
JAVA_OPTS: -Xmx6g -Xms2g
NODE_OPTIONS: --max-old-space-size=4096
steps:
- checkout
# Download and cache dependencies
- restore_cache:
keys:
- v1-dependencies-{{ checksum "frontend/deps.edn"}}
- run:
name: "integration tests"
working_directory: "./frontend"
command: |
yarn install
yarn run build:app:assets
yarn run build:app
yarn run build:app:libs
yarn run playwright install --with-deps chromium
yarn run test:e2e -x --workers=4
test-backend:
docker:
- image: penpotapp/devenv:latest
- image: cimg/postgres:14.5
@ -20,104 +138,30 @@ jobs:
steps:
- checkout
# Download and cache dependencies
- restore_cache:
keys:
- v1-dependencies-{{ checksum "backend/deps.edn" }}-{{ checksum "frontend/deps.edn"}}-{{ checksum "common/deps.edn"}}
# fallback to using the latest cache if no exact match is found
- v1-dependencies-
- run: cd .clj-kondo && cat config.edn
- run: cat .cljfmt.edn
- run: clj-kondo --version
- v1-dependencies-{{ checksum "backend/deps.edn" }}
- run:
name: "backend fmt check"
working_directory: "./backend"
command: |
yarn install
yarn run fmt:clj:check
- run:
name: "exporter fmt check"
working_directory: "./exporter"
command: |
yarn install
yarn run fmt:clj:check
- run:
name: "common fmt check"
working_directory: "./common"
command: |
yarn install
yarn run fmt:clj:check
- run:
name: "frontend fmt check"
working_directory: "./frontend"
command: |
yarn install
yarn run fmt:clj:check
yarn run fmt:js:check
- run:
name: "common linter check"
name: "prepopulate linter cache"
working_directory: "./common"
command: |
yarn install
yarn run lint:clj
- run:
name: "frontend linter check"
working_directory: "./frontend"
command: |
yarn install
yarn run lint:scss
yarn run lint:clj
- run:
name: "backend linter check"
name: "fmt check & linter"
working_directory: "./backend"
command: |
yarn install
yarn run fmt:clj:check
yarn run lint:clj
- run:
name: "exporter linter check"
working_directory: "./exporter"
command: |
yarn install
yarn run lint:clj
- run:
name: "common tests"
working_directory: "./common"
command: |
yarn test
clojure -M:dev:test
- run:
name: "frontend tests"
working_directory: "./frontend"
command: |
yarn install
yarn test
- run:
name: "frontend integration tests"
working_directory: "./frontend"
command: |
yarn install
yarn run build:app:assets
clojure -M:dev:shadow-cljs release main
yarn playwright install --with-deps chromium
yarn test:e2e
- run:
name: "backend tests"
name: "tests"
working_directory: "./backend"
command: |
clojure -M:dev:test
clojure -M:dev:test --reporter kaocha.report/documentation
environment:
PENPOT_TEST_DATABASE_URI: "postgresql://localhost/penpot_test"
@ -128,4 +172,43 @@ jobs:
- save_cache:
paths:
- ~/.m2
key: v1-dependencies-{{ checksum "backend/deps.edn" }}-{{ checksum "frontend/deps.edn"}}-{{ checksum "common/deps.edn"}}
key: v1-dependencies-{{ checksum "backend/deps.edn" }}
test-exporter:
docker:
- image: penpotapp/devenv:latest
working_directory: ~/repo
resource_class: medium+
environment:
JAVA_OPTS: -Xmx4g -Xms100m -XX:+UseSerialGC
NODE_OPTIONS: --max-old-space-size=4096
steps:
- checkout
- run:
name: "prepopulate linter cache"
working_directory: "./common"
command: |
yarn install
yarn run lint:clj
- run:
name: "fmt check & linter"
working_directory: "./exporter"
command: |
yarn install
yarn run fmt:clj:check
yarn run lint:clj
workflows:
penpot:
jobs:
- test-frontend
- test-integration
- test-backend
- test-common
- test-exporter

1
.cljfmt.edn
View File

@ -4,7 +4,6 @@
:remove-consecutive-blank-lines? false
:extra-indents {rumext.v2/fnc [[:inner 0]]
cljs.test/async [[:inner 0]]
app.common.schema/register! [[:inner 0] [:inner 1]]
promesa.exec/thread [[:inner 0]]
specify! [[:inner 0] [:inner 1]]}
}

31
CHANGES.md
View File

@ -1,5 +1,35 @@
# CHANGELOG
## 2.4.0
### :rocket: Epics and highlights
### :boom: Breaking changes & Deprecations
- Use [nginx-unprivileged](https://hub.docker.com/r/nginxinc/nginx-unprivileged) as base image for
Penpot's frontend docker image. Now all the docker images runs with the same unprivileged user
(penpot). Because of that, the default NGINX listen port is now 8080 instead of 80, so
you will have to modify your infrastructure to apply this change.
- Redis 7.2 is explicitly pinned in our example docker-compose.yml file. This is done because,
starting with the next versions, Redis is no longer distributed under an open-source license.
On-premise users are obviously free to upgrade to the version they are using or a more modern one.
Keep in mind that if you were using a version other than 7.2, you may have to recreate the volume
associated with the Redis container because the 7.2 storage format may not be compatible with what
you already have stored on the volume, and Redis may not start. In the near future, we will evaluate
whether to move to an open-source version of Redis (such as https://valkey.io/).
### :heart: Community contributions (Thank you!)
### :sparkles: New features
- Viewer role for team members [Taiga #1056 & #6590](https://tree.taiga.io/project/penpot/us/1056 & https://tree.taiga.io/project/penpot/us/6590)
- File history versions management [Taiga](https://tree.taiga.io/project/penpot/us/187?milestone=411120)
- Rename selected layer via keyboard shortcut and context menu option [Taiga #8882](https://tree.taiga.io/project/penpot/us/8882)
### :bug: Bugs fixed
## 2.3.3
### :bug: Bugs fixed
@ -174,6 +204,7 @@ time being.
- Fix problem with comments max length [Taiga #8778](https://tree.taiga.io/project/penpot/issue/8778)
- Fix copy/paste images in Safari [Taiga #8771](https://tree.taiga.io/project/penpot/issue/8771)
- Fix swap when the copy is the only child of a group [#5075](https://github.com/penpot/penpot/issues/5075)
- Fix file builder hangs when exporting [#5099](https://github.com/penpot/penpot/issues/5099)
## 2.1.5

2
README.md
View File

@ -10,7 +10,7 @@
<p align="center">
<a href="https://www.mozilla.org/en-US/MPL/2.0" rel="nofollow"><img alt="License: MPL-2.0" src="https://img.shields.io/badge/MPL-2.0-blue.svg" style="max-width:100%;"></a>
<a href="https://gitter.im/penpot/community" rel="nofollow"><img alt="Gitter" src="https://badges.gitter.im/sereno-xyz/community.svg" style="max-width:100%;"></a>
<a href="https://community.penpot.app" rel="nofollow"><img alt="Penpot Community" src="https://img.shields.io/discourse/posts?server=https%3A%2F%2Fcommunity.penpot.app" style="max-width:100%;"></a>
<a href="https://tree.taiga.io/project/penpot/" title="Managed with Taiga.io" rel="nofollow"><img alt="Managed with Taiga.io" src="https://img.shields.io/badge/managed%20with-TAIGA.io-709f14.svg" style="max-width:100%;"></a>
<a href="https://gitpod.io/#https://github.com/penpot/penpot" rel="nofollow"><img alt="Gitpod ready-to-code" src="https://img.shields.io/badge/Gitpod-ready--to--code-blue?logo=gitpod" style="max-width:100%;"></a>
</p>

32
backend/deps.edn
View File

@ -3,10 +3,10 @@
:deps
{penpot/common {:local/root "../common"}
org.clojure/clojure {:mvn/version "1.12.0-alpha12"}
org.clojure/clojure {:mvn/version "1.12.0"}
org.clojure/tools.namespace {:mvn/version "1.5.0"}
com.github.luben/zstd-jni {:mvn/version "1.5.6-3"}
com.github.luben/zstd-jni {:mvn/version "1.5.6-6"}
io.prometheus/simpleclient {:mvn/version "0.16.0"}
io.prometheus/simpleclient_hotspot {:mvn/version "0.16.0"}
@ -17,33 +17,33 @@
io.prometheus/simpleclient_httpserver {:mvn/version "0.16.0"}
io.lettuce/lettuce-core {:mvn/version "6.3.2.RELEASE"}
io.lettuce/lettuce-core {:mvn/version "6.4.0.RELEASE"}
java-http-clj/java-http-clj {:mvn/version "0.4.3"}
funcool/yetti
{:git/tag "v10.0"
:git/sha "520613f"
{:git/tag "v11.4"
:git/sha "ce50d42"
:git/url "https://github.com/funcool/yetti.git"
:exclusions [org.slf4j/slf4j-api]}
com.github.seancorfield/next.jdbc {:mvn/version "1.3.939"}
metosin/reitit-core {:mvn/version "0.7.0"}
nrepl/nrepl {:mvn/version "1.1.2"}
cider/cider-nrepl {:mvn/version "0.48.0"}
com.github.seancorfield/next.jdbc {:mvn/version "1.3.955"}
metosin/reitit-core {:mvn/version "0.7.2"}
nrepl/nrepl {:mvn/version "1.3.0"}
cider/cider-nrepl {:mvn/version "0.50.2"}
org.postgresql/postgresql {:mvn/version "42.7.3"}
org.xerial/sqlite-jdbc {:mvn/version "3.46.0.0"}
org.postgresql/postgresql {:mvn/version "42.7.4"}
org.xerial/sqlite-jdbc {:mvn/version "3.46.1.3"}
com.zaxxer/HikariCP {:mvn/version "5.1.0"}
com.zaxxer/HikariCP {:mvn/version "6.0.0"}
io.whitfin/siphash {:mvn/version "2.0.0"}
buddy/buddy-hashers {:mvn/version "2.0.167"}
buddy/buddy-sign {:mvn/version "3.5.351"}
buddy/buddy-sign {:mvn/version "3.6.1-359"}
com.github.ben-manes.caffeine/caffeine {:mvn/version "3.1.8"}
org.jsoup/jsoup {:mvn/version "1.17.2"}
org.jsoup/jsoup {:mvn/version "1.18.1"}
org.im4java/im4java
{:git/tag "1.4.0-penpot-2"
:git/sha "e2b3e16"
@ -58,7 +58,7 @@
;; Pretty Print specs
pretty-spec/pretty-spec {:mvn/version "0.1.4"}
software.amazon.awssdk/s3 {:mvn/version "2.25.63"}
software.amazon.awssdk/s3 {:mvn/version "2.28.26"}
}
:paths ["src" "resources" "target/classes"]
@ -74,7 +74,7 @@
:build
{:extra-deps
{io.github.clojure/tools.build {:git/tag "v0.10.3" :git/sha "15ead66"}}
{io.github.clojure/tools.build {:git/tag "v0.10.5" :git/sha "2a21b7a"}}
:ns-default build}
:test

1
backend/dev/user.clj
View File

@ -137,7 +137,6 @@
;; :v6 v6
;; }])))
(defn calculate-frames
[{:keys [data]}]
(->> (vals (:pages-index data))

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

@ -1,5 +1,5 @@
<?xml version="1.0" encoding="UTF-8"?>
<Configuration status="info" monitorInterval="30">
<Configuration status="fatal" monitorInterval="30">
<Appenders>
<Console name="console" target="SYSTEM_OUT">
<PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] %level{length=1} %logger{36} - %msg%n"

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

@ -1,5 +1,5 @@
<?xml version="1.0" encoding="UTF-8"?>
<Configuration status="info" monitorInterval="30">
<Configuration status="fatal" monitorInterval="30">
<Appenders>
<Console name="console" target="SYSTEM_OUT">
<PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] %level{length=1} %logger{36} - %msg%n"

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

@ -1,5 +1,5 @@
<?xml version="1.0" encoding="UTF-8"?>
<Configuration status="info" monitorInterval="30">
<Configuration status="fatal" monitorInterval="30">
<Appenders>
<Console name="console" target="SYSTEM_OUT">
<PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] %level{length=1} %logger{36} - %msg%n"

2
backend/resources/log4j2.xml
View File

@ -1,5 +1,5 @@
<?xml version="1.0" encoding="UTF-8"?>
<Configuration status="info" monitorInterval="60">
<Configuration status="fatal" monitorInterval="60">
<Appenders>
<Console name="console" target="SYSTEM_OUT">
<PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] %level{length=1} %logger{36} - %msg%n"

3
backend/scripts/build
View File

@ -7,6 +7,8 @@ set -ex
rm -rf target;
mkdir -p target/classes;
mkdir -p target/dist;
mkdir -p target/dist/scripts;
echo "$CURRENT_VERSION" > target/classes/version.txt;
cp ../CHANGES.md target/classes/changelog.md;
@ -15,6 +17,7 @@ mv target/penpot.jar target/dist/penpot.jar
cp resources/log4j2.xml target/dist/log4j2.xml
cp scripts/run.template.sh target/dist/run.sh;
cp scripts/manage.py target/dist/manage.py
cp scripts/svgo-cli.js target/dist/scripts/;
chmod +x target/dist/run.sh;
chmod +x target/dist/manage.py

1
backend/scripts/repl
View File

@ -1,7 +1,6 @@
#!/usr/bin/env bash
export PENPOT_HOST=devenv
export PENPOT_TENANT=dev
export PENPOT_FLAGS="\
$PENPOT_FLAGS \
enable-login-with-ldap \

2
backend/scripts/start-dev
View File

@ -1,7 +1,6 @@
#!/usr/bin/env bash
export PENPOT_HOST=devenv
export PENPOT_TENANT=dev
export PENPOT_FLAGS="\
$PENPOT_FLAGS \
enable-prepl-server \
@ -10,6 +9,7 @@ export PENPOT_FLAGS="\
enable-webhooks \
enable-backend-asserts \
enable-audit-log \
enable-login-with-ldap \
enable-transit-readable-response \
enable-demo-users \
enable-feature-fdata-pointer-map \

214
backend/scripts/svgo-cli.js Normal file
View File

File diff suppressed because one or more lines are too long

75
backend/src/app/auth/ldap.clj
View File

@ -8,9 +8,8 @@
(:require
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.schema :as sm]
[clj-ldap.client :as ldap]
[clojure.spec.alpha :as s]
[clojure.string]
[integrant.core :as ig]))
@ -58,21 +57,26 @@
:email email
:backend "ldap"})))
(s/def ::fullname ::us/not-empty-string)
(s/def ::email ::us/email)
(s/def ::backend ::us/not-empty-string)
(def ^:private schema:info-data
[:map
[:fullname ::sm/text]
[:email ::sm/email]
[:backend ::sm/text]])
(s/def ::info-data
(s/keys :req-un [::fullname ::email ::backend]))
(def ^:private valid-info-data?
(sm/lazy-validator schema:info-data))
(def ^:private explain-info-data
(sm/lazy-explainer schema:info-data))
(defn authenticate
[cfg params]
(with-open [conn (connect cfg)]
(when-let [user (-> (assoc cfg ::conn conn)
(retrieve-user params))]
(when-not (s/valid? ::info-data user)
(let [explain (s/explain-str ::info-data user)]
(l/warn ::l/raw (str "invalid response from ldap, looks like ldap is not configured correctly\n" explain))
(when-not (valid-info-data? user)
(let [explain (explain-info-data user)]
(l/warn :hint "invalid response from ldap, looks like ldap is not configured correctly" :data user)
(ex/raise :type :restriction
:code :wrong-ldap-response
:explain explain)))
@ -102,38 +106,31 @@
:host (:host cfg) :port (:port cfg) :cause cause)
nil))))
(s/def ::enabled? ::us/boolean)
(s/def ::host ::us/string)
(s/def ::port ::us/integer)
(s/def ::ssl ::us/boolean)
(s/def ::tls ::us/boolean)
(s/def ::query ::us/string)
(s/def ::base-dn ::us/string)
(s/def ::bind-dn ::us/string)
(s/def ::bind-password ::us/string)
(s/def ::attrs-email ::us/string)
(s/def ::attrs-fullname ::us/string)
(s/def ::attrs-username ::us/string)
(def ^:private schema:params
[:map
[:host {:optional true} :string]
[:port {:optional true} ::sm/int]
[:bind-dn {:optional true} :string]
[:bind-passwor {:optional true} :string]
[:query {:optional true} :string]
[:base-dn {:optional true} :string]
[:attrs-email {:optional true} :string]
[:attrs-username {:optional true} :string]
[:attrs-fullname {:optional true} :string]
[:ssl {:optional true} ::sm/boolean]
[:tls {:optional true} ::sm/boolean]])
(s/def ::provider-params
(s/keys :opt-un [::host ::port
::ssl ::tls
::enabled?
::bind-dn
::bind-password
::query
::attrs-email
::attrs-username
::attrs-fullname]))
(def ^:private check-params
(sm/check-fn schema:params :hint "Invalid LDAP provider parameters"))
(s/def ::provider
(s/nilable ::provider-params))
(defmethod ig/pre-init-spec ::provider
[_]
(s/spec ::provider))
(defmethod ig/assert-key ::provider
[_ params]
(when (:enabled params)
(some->> params check-params)))
(defmethod ig/init-key ::provider
[_ cfg]
(when (:enabled? cfg)
(when (:enabled cfg)
(try-connectivity cfg)))
(sm/register! ::provider schema:params)

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

@ -12,7 +12,7 @@
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.uri :as u]
[app.config :as cf]
[app.db :as db]
@ -32,11 +32,10 @@
[buddy.sign.jwk :as jwk]
[buddy.sign.jwt :as jwt]
[clojure.set :as set]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[integrant.core :as ig]
[ring.request :as rreq]
[ring.response :as-alias rres]))
[yetti.request :as yreq]
[yetti.response :as-alias yres]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPERS
@ -140,8 +139,9 @@
(l/warn :hint "unable to retrieve JWKs (unexpected exception)"
:cause cause)))))
(defmethod ig/pre-init-spec ::providers/generic [_]
(s/keys :req [::http/client]))
(defmethod ig/assert-key ::providers/generic
[_ params]
(assert (http/client? (::http/client params)) "expected a valid http client"))
(defmethod ig/init-key ::providers/generic
[_ cfg]
@ -197,6 +197,10 @@
;; GITHUB AUTH PROVIDER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- int-in-range?
[val start end]
(and (<= start val) (< val end)))
(defn- retrieve-github-email
[cfg tdata props]
(or (some-> props :github/email)
@ -207,7 +211,7 @@
{:keys [status body]} (http/req! cfg params {:sync? true})]
(when-not (s/int-in-range? 200 300 status)
(when-not (int-in-range? status 200 300)
(ex/raise :type :internal
:code :unable-to-retrieve-github-emails
:hint "unable to retrieve github emails"
@ -217,8 +221,9 @@
(->> body json/decode (filter :primary) first :email))))
(defmethod ig/pre-init-spec ::providers/github [_]
(s/keys :req [::http/client]))
(defmethod ig/assert-key ::providers/github
[_ params]
(assert (http/client? (::http/client params)) "expected a valid http client"))
(defmethod ig/init-key ::providers/github
[_ cfg]
@ -394,7 +399,7 @@
:status (:status response)
:body (:body response))
(when-not (s/int-in-range? 200 300 (:status response))
(when-not (int-in-range? (:status response) 200 300)
(ex/raise :type :internal
:code :unable-to-retrieve-user-info
:hint "unable to retrieve user info"
@ -418,15 +423,15 @@
(l/warn :hint "unable to get user info from JWT token (unexpected exception)"
:cause cause))))
(s/def ::backend ::us/not-empty-string)
(s/def ::email ::us/not-empty-string)
(s/def ::fullname ::us/not-empty-string)
(s/def ::props (s/map-of ::us/keyword any?))
(s/def ::info
(s/keys :req-un [::backend
::email
::fullname
::props]))
(def ^:private schema:info
[:map
[:backend ::sm/text]
[:email ::sm/email]
[:fullname ::sm/text]
[:props [:map-of :keyword :any]]])
(def ^:private valid-info?
(sm/validator schema:info))
(defn- get-info
[{:keys [::provider ::setup/props] :as cfg} {:keys [params] :as request}]
@ -444,7 +449,7 @@
(l/trc :hint "user info" :info info)
(when-not (s/valid? ::info info)
(when-not (valid-info? info)
(l/warn :hint "received incomplete profile info object (please set correct scopes)" :info info)
(ex/raise :type :internal
:code :incomplete-user-info
@ -492,8 +497,8 @@
(defn- redirect-response
[uri]
{::rres/status 302
::rres/headers {"location" (str uri)}})
{::yres/status 302
::yres/headers {"location" (str uri)}})
(defn- redirect-with-error
([error] (redirect-with-error error nil))
@ -598,7 +603,7 @@
(defn- get-external-session-id
[request]
(let [session-id (rreq/get-header request "x-external-session-id")]
(let [session-id (yreq/get-header request "x-external-session-id")]
(when (string? session-id)
(if (or (> (count session-id) 256)
(= session-id "null")
@ -618,8 +623,8 @@
state (tokens/generate (::setup/props cfg)
(d/without-nils params))
uri (build-auth-uri cfg state)]
{::rres/status 200
::rres/body {:redirect-uri uri}}))
{::yres/status 200
::yres/body {:redirect-uri uri}}))
(defn- callback-handler
[{:keys [::provider] :as cfg} request]
@ -655,46 +660,37 @@
:provider provider
:hint "provider not configured"))))))})
(s/def ::client-id ::us/string)
(s/def ::client-secret ::us/string)
(s/def ::base-uri ::us/string)
(s/def ::token-uri ::us/string)
(s/def ::auth-uri ::us/string)
(s/def ::user-uri ::us/string)
(s/def ::scopes ::us/set-of-strings)
(s/def ::roles ::us/set-of-strings)
(s/def ::roles-attr ::us/string)
(s/def ::email-attr ::us/string)
(s/def ::name-attr ::us/string)
(def ^:private schema:provider
[:map {:title "provider"}
[:client-id ::sm/text]
[:client-secret ::sm/text]
[:base-uri {:optional true} ::sm/text]
[:token-uri {:optional true} ::sm/text]
[:auth-uri {:optional true} ::sm/text]
[:user-uri {:optional true} ::sm/text]
[:scopes {:optional true}
[::sm/set ::sm/text]]
[:roles {:optional true}
[::sm/set ::sm/text]]
[:roles-attr {:optional true} ::sm/text]
[:email-attr {:optional true} ::sm/text]
[:name-attr {:optional true} ::sm/text]])
(s/def ::provider
(s/keys :req-un [::client-id
::client-secret]
:opt-un [::base-uri
::token-uri
::auth-uri
::user-uri
::scopes
::roles
::roles-attr
::email-attr
::name-attr]))
(def ^:private schema:routes-params
[:map
::session/manager
::http/client
::setup/props
::db/pool
[::providers [:map-of :keyword [:maybe schema:provider]]]])
(s/def ::providers (s/map-of ::us/keyword (s/nilable ::provider)))
(s/def ::routes vector?)
(defmethod ig/pre-init-spec ::routes
[_]
(s/keys :req [::session/manager
::http/client
::setup/props
::db/pool
::providers]))
(defmethod ig/assert-key ::routes
[_ params]
(assert (sm/check schema:routes-params params)))
(defmethod ig/init-key ::routes
[_ cfg]
(let [cfg (update cfg :provider d/without-nils)]
(let [cfg (update cfg :providers d/without-nils)]
["" {:middleware [[session/authz cfg]
[provider-lookup cfg]]}
["/auth/oauth"

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

@ -37,6 +37,21 @@
(def ^:dynamic *state* nil)
(def ^:dynamic *options* nil)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DEFAULTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Threshold in MiB when we pass from using
;; in-memory byte-array's to use temporal files.
(def temp-file-threshold
(* 1024 1024 2))
;; A maximum (storage) object size allowed: 100MiB
(def ^:const max-object-size
(* 1024 1024 100))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def xf-map-id
(map :id))
@ -56,6 +71,13 @@
(def conj-vec
(fnil conj []))
(defn initial-state
[]
{:storage-objects #{}
:files #{}
:teams #{}
:projects #{}})
(defn collect-storage-objects
[state items]
(update state :storage-objects into xf-map-media-id items))
@ -87,6 +109,8 @@
attrs))
(defn update-index
([coll]
(update-index {} coll identity))
([index coll]
(update-index index coll identity))
([index coll attr]
@ -114,6 +138,16 @@
[cfg project-id]
(db/get cfg :project {:id project-id}))
(def ^:private sql:get-teams
"SELECT t.* FROM team WHERE id = ANY(?)")
(defn get-teams
[cfg ids]
(let [conn (db/get-connection cfg)
ids (db/create-array conn "uuid" ids)]
(->> (db/exec! conn [sql:get-teams ids])
(map decode-row))))
(defn get-team
[cfg team-id]
(-> (db/get cfg :team {:id team-id})
@ -167,9 +201,10 @@
(defn get-file-object-thumbnails
"Return all file object thumbnails for a given file."
[cfg file-id]
(db/query cfg :file-tagged-object-thumbnail
{:file-id file-id
:deleted-at nil}))
(->> (db/query cfg :file-tagged-object-thumbnail
{:file-id file-id
:deleted-at nil})
(not-empty)))
(defn get-file-thumbnail
"Return the thumbnail for the specified file-id"
@ -224,26 +259,26 @@
(->> (db/exec! conn [sql ids])
(mapv #(assoc % :file-id id)))))))
(def ^:private sql:get-team-files
(def ^:private sql:get-team-files-ids
"SELECT f.id FROM file AS f
JOIN project AS p ON (p.id = f.project_id)
WHERE p.team_id = ?")
(defn get-team-files
(defn get-team-files-ids
"Get a set of file ids for the specified team-id"
[{:keys [::db/conn]} team-id]
(->> (db/exec! conn [sql:get-team-files team-id])
(->> (db/exec! conn [sql:get-team-files-ids team-id])
(into #{} xf-map-id)))
(def ^:private sql:get-team-projects
"SELECT p.id FROM project AS p
"SELECT p.* FROM project AS p
WHERE p.team_id = ?
AND p.deleted_at IS NULL")
(defn get-team-projects
"Get a set of project ids for the team"
[{:keys [::db/conn]} team-id]
(->> (db/exec! conn [sql:get-team-projects team-id])
[cfg team-id]
(->> (db/exec! cfg [sql:get-team-projects team-id])
(into #{} xf-map-id)))
(def ^:private sql:get-project-files
@ -257,6 +292,10 @@
(->> (db/exec! conn [sql:get-project-files project-id])
(into #{} xf-map-id)))
(defn remap-thumbnail-object-id
[object-id file-id]
(str/replace-first object-id #"^(.*?)/" (str file-id "/")))
(defn- relink-shapes
"A function responsible to analyze all file data and
replace the old :component-file reference with the new
@ -339,6 +378,12 @@
data
library-ids)))
(defn disable-database-timeouts!
[cfg]
(let [conn (db/get-connection cfg)]
(db/exec-one! conn ["SET LOCAL idle_in_transaction_session_timeout = 0"])
(db/exec-one! conn ["SET CONSTRAINTS ALL DEFERRED"])))
(defn- fix-version
[file]
(let [file (fmg/fix-version file)]
@ -432,6 +477,20 @@
file))
(defn register-pending-migrations
"All features that are enabled and requires explicit migration are
added to the state for a posterior migration step."
[cfg {:keys [id features] :as file}]
(doseq [feature (-> (::features cfg)
(set/difference cfeat/no-migration-features)
(set/difference cfeat/backend-only-features)
(set/difference features))]
(vswap! *state* update :pending-to-migrate (fnil conj []) [feature id]))
file)
(defn apply-pending-migrations!
"Apply alredy registered pending migrations to files"
[cfg]

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

@ -49,15 +49,6 @@
(set! *warn-on-reflection* true)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DEFAULTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Threshold in MiB when we pass from using
;; in-memory byte-array's to use temporal files.
(def temp-file-threshold
(* 1024 1024 2))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LOW LEVEL STREAM IO API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -65,11 +56,6 @@
(def ^:const buffer-size (:xnio/buffer-size yt/defaults))
(def ^:const penpot-magic-number 800099563638710213)
;; A maximum (storage) object size allowed: 100MiB
(def ^:const max-object-size
(* 1024 1024 100))
(def ^:dynamic *position* nil)
(defn get-mark
@ -236,7 +222,7 @@
(defn copy-stream!
[^OutputStream output ^InputStream input ^long size]
(let [written (io/copy! input output :size size)]
(let [written (io/copy input output :size size)]
(l/trace :fn "copy-stream!" :position @*position* :size size :written written ::l/sync? true)
(swap! *position* + written)
written))
@ -258,18 +244,18 @@
p (tmp/tempfile :prefix "penpot.binfile.")]
(assert-mark m :stream)
(when (> s max-object-size)
(when (> s bfc/max-object-size)
(ex/raise :type :validation
:code :max-file-size-reached
:hint (str/ffmt "unable to import storage object with size % bytes" s)))
(if (> s temp-file-threshold)
(if (> s bfc/temp-file-threshold)
(with-open [^OutputStream output (io/output-stream p)]
(let [readed (io/copy! input output :offset 0 :size s)]
(let [readed (io/copy input output :offset 0 :size s)]
(l/trace :fn "read-stream*!" :expected s :readed readed :position @*position* ::l/sync? true)
(swap! *position* + readed)
[s p]))
[s (io/read-as-bytes input :size s)])))
[s (io/read input :size s)])))
(defmacro assert-read-label!
[input expected-label]
@ -381,10 +367,12 @@
::l/sync? true)
(doseq [item media]
(l/dbg :hint "write penpot file media object" :id (:id item) ::l/sync? true))
(l/dbg :hint "write penpot file media object"
:id (:id item) ::l/sync? true))
(doseq [item thumbnails]
(l/dbg :hint "write penpot file object thumbnail" :media-id (str (:media-id item)) ::l/sync? true))
(l/dbg :hint "write penpot file object thumbnail"
:media-id (str (:media-id item)) ::l/sync? true))
(doto output
(write-obj! file)
@ -466,8 +454,8 @@
(defn- read-import-v1
[{:keys [::db/conn ::project-id ::profile-id ::input] :as cfg}]
(db/exec-one! conn ["SET LOCAL idle_in_transaction_session_timeout = 0"])
(db/exec-one! conn ["SET CONSTRAINTS ALL DEFERRED"])
(bfc/disable-database-timeouts! cfg)
(pu/with-open [input (zstd-input-stream input)
input (io/data-input-stream input)]
@ -559,7 +547,9 @@
(when (seq thumbnails)
(let [thumbnails (remap-thumbnails thumbnails file-id')]
(l/dbg :hint "updated index with thumbnails" :total (count thumbnails) ::l/sync? true)
(l/dbg :hint "updated index with thumbnails"
:total (count thumbnails)
::l/sync? true)
(vswap! bfc/*state* update :thumbnails bfc/into-vec thumbnails)))
(when (seq media)
@ -709,7 +699,7 @@
(dm/assert!
"expected instance of jio/IOFactory for `input`"
(satisfies? jio/IOFactory output))
(io/coercible? output))
(let [id (uuid/next)
tp (dt/tpoint)
@ -738,7 +728,7 @@
:cause @cs)))))
(defn import-files!
[cfg input]
[{:keys [::input] :as cfg}]
(dm/assert!
"expected valid profile-id and project-id on `cfg`"

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

@ -141,16 +141,15 @@
(write! cfg :team-font-variant id font))))
(defn- write-project!
[cfg project-id]
(let [project (bfc/get-project cfg project-id)]
(events/tap :progress
{:op :export
:section :write-project
:id project-id
:name (:name project)})
(l/trc :hint "write" :obj "project" :id (str project-id))
(write! cfg :project (str project-id) project)
(vswap! bfc/*state* update :projects conj project-id)))
[cfg project]
(events/tap :progress
{:op :export
:section :write-project
:id (:id project)
:name (:name project)})
(l/trc :hint "write" :obj "project" :id (str (:id project)))
(write! cfg :project (str (:id project)) project)
(vswap! bfc/*state* update :projects conj (:id project)))
(defn- write-file!
[cfg file-id]
@ -191,7 +190,7 @@
[{:keys [::sto/storage] :as cfg} id]
(let [sobj (sto/get-object storage id)
data (with-open [input (sto/get-object-data storage sobj)]
(io/read-as-bytes input))]
(io/read input))]
(l/trc :hint "write" :obj "storage-object" :id (str id) :size (:size sobj))
(write! cfg :storage-object id (meta sobj) data)))
@ -363,7 +362,7 @@
(bfc/get-team-projects cfg team-id))
(run! (partial write-file! cfg)
(bfc/get-team-files cfg team-id))
(bfc/get-team-files-ids cfg team-id))
(run! (partial write-storage-object! cfg)
(-> bfc/*state* deref :storage-objects))

957
backend/src/app/binfile/v3.clj Normal file
View File

@ -0,0 +1,957 @@
;; 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.binfile.v3
"A ZIP based binary file exportation"
(:refer-clojure :exclude [read])
(:require
[app.binfile.common :as bfc]
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.json :as json]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.thumbnails :as cth]
[app.common.types.color :as ctcl]
[app.common.types.component :as ctc]
[app.common.types.file :as ctf]
[app.common.types.page :as ctp]
[app.common.types.plugins :as ctpg]
[app.common.types.shape :as cts]
[app.common.types.typography :as cty]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.storage :as sto]
[app.storage.impl :as sto.impl]
[app.util.events :as events]
[app.util.time :as dt]
[clojure.java.io :as jio]
[cuerdas.core :as str]
[datoteka.fs :as fs]
[datoteka.io :as io])
(:import
java.io.InputStream
java.io.OutputStreamWriter
java.util.zip.ZipEntry
java.util.zip.ZipFile
java.util.zip.ZipOutputStream))
;; --- SCHEMA
(def ^:private schema:manifest
[:map {:title "Manifest"}
[:version ::sm/int]
[:type :string]
[:generated-by {:optional true} :string]
[:files
[:vector
[:map
[:id ::sm/uuid]
[:name :string]
[:project-id ::sm/uuid]]]]
[:relations {:optional true}
[:vector
[:tuple ::sm/uuid ::sm/uuid]]]])
(def ^:private schema:storage-object
[:map {:title "StorageObject"}
[:id ::sm/uuid]
[:size ::sm/int]
[:content-type :string]
[:bucket [::sm/one-of {:format :string} sto/valid-buckets]]
[:hash :string]])
(def ^:private schema:file-thumbnail
[:map {:title "FileThumbnail"}
[:file-id ::sm/uuid]
[:page-id ::sm/uuid]
[:frame-id ::sm/uuid]
[:tag :string]
[:media-id ::sm/uuid]])
;; --- ENCODERS
(def encode-file
(sm/encoder ::ctf/file sm/json-transformer))
(def encode-page
(sm/encoder ::ctp/page sm/json-transformer))
(def encode-shape
(sm/encoder ::cts/shape sm/json-transformer))
(def encode-media
(sm/encoder ::ctf/media sm/json-transformer))
(def encode-component
(sm/encoder ::ctc/component sm/json-transformer))
(def encode-color
(sm/encoder ::ctcl/color sm/json-transformer))
(def encode-typography
(sm/encoder ::cty/typography sm/json-transformer))
(def encode-plugin-data
(sm/encoder ::ctpg/plugin-data sm/json-transformer))
(def encode-storage-object
(sm/encoder schema:storage-object sm/json-transformer))
(def encode-file-thumbnail
(sm/encoder schema:file-thumbnail sm/json-transformer))
;; --- DECODERS
(def decode-manifest
(sm/decoder schema:manifest sm/json-transformer))
(def decode-media
(sm/decoder ::ctf/media sm/json-transformer))
(def decode-component
(sm/decoder ::ctc/component sm/json-transformer))
(def decode-color
(sm/decoder ::ctcl/color sm/json-transformer))
(def decode-file
(sm/decoder ::ctf/file sm/json-transformer))
(def decode-page
(sm/decoder ::ctp/page sm/json-transformer))
(def decode-shape
(sm/decoder ::cts/shape sm/json-transformer))
(def decode-typography
(sm/decoder ::cty/typography sm/json-transformer))
(def decode-plugin-data
(sm/decoder ::ctpg/plugin-data sm/json-transformer))
(def decode-storage-object
(sm/decoder schema:storage-object sm/json-transformer))
(def decode-file-thumbnail
(sm/decoder schema:file-thumbnail sm/json-transformer))
;; --- VALIDATORS
(def validate-manifest
(sm/check-fn schema:manifest))
(def validate-file
(sm/check-fn ::ctf/file))
(def validate-page
(sm/check-fn ::ctp/page))
(def validate-shape
(sm/check-fn ::cts/shape))
(def validate-media
(sm/check-fn ::ctf/media))
(def validate-color
(sm/check-fn ::ctcl/color))
(def validate-component
(sm/check-fn ::ctc/component))
(def validate-typography
(sm/check-fn ::cty/typography))
(def validate-plugin-data
(sm/check-fn ::ctpg/plugin-data))
(def validate-storage-object
(sm/check-fn schema:storage-object))
(def validate-file-thumbnail
(sm/check-fn schema:file-thumbnail))
;; --- EXPORT IMPL
(defn- write-entry!
[^ZipOutputStream output ^String path data]
(.putNextEntry output (ZipEntry. path))
(let [writer (OutputStreamWriter. output "UTF-8")]
(json/write writer data :indent true :key-fn json/write-camel-key)
(.flush writer))
(.closeEntry output))
(defn- get-file
[{:keys [::embed-assets ::include-libraries] :as cfg} file-id]
(when (and include-libraries embed-assets)
(throw (IllegalArgumentException.
"the `include-libraries` and `embed-assets` are mutally excluding options")))
(let [detach? (and (not embed-assets) (not include-libraries))]
(cond-> (bfc/get-file cfg file-id)
detach?
(-> (ctf/detach-external-references file-id)
(dissoc :libraries))
embed-assets
(update :data #(bfc/embed-assets cfg % file-id)))))
(defn- resolve-extension
[mtype]
(case mtype
"image/png" ".png"
"image/jpeg" ".jpg"
"image/gif" ".gif"
"image/svg+xml" ".svg"
"image/webp" ".webp"
"font/woff" ".woff"
"font/woff2" ".woff2"
"font/ttf" ".ttf"
"font/otf" ".otf"
"application/octet-stream" ".bin"))
(defn- export-storage-objects
[{:keys [::output] :as cfg}]
(let [storage (sto/resolve cfg)]
(doseq [id (-> bfc/*state* deref :storage-objects not-empty)]
(let [sobject (sto/get-object storage id)
smeta (meta sobject)
ext (resolve-extension (:content-type smeta))
path (str "objects/" id ".json")
params (-> (meta sobject)
(assoc :id (:id sobject))
(assoc :size (:size sobject))
(encode-storage-object))]
(write-entry! output path params)
(with-open [input (sto/get-object-data storage sobject)]
(.putNextEntry output (ZipEntry. (str "objects/" id ext)))
(io/copy input output :size (:size sobject))
(.closeEntry output))))))
(defn- export-file
[{:keys [::file-id ::output] :as cfg}]
(let [file (get-file cfg file-id)
media (->> (bfc/get-file-media cfg file)
(map (fn [media]
(dissoc media :file-id))))
data (:data file)
typographies (:typographies data)
components (:components data)
colors (:colors data)
pages (:pages data)
pages-index (:pages-index data)
thumbnails (bfc/get-file-object-thumbnails cfg file-id)]
(vswap! bfc/*state* update :files assoc file-id
{:id file-id
:project-id (:project-id file)
:name (:name file)})
(let [file (cond-> (dissoc file :data)
(:options data)
(assoc :options (:options data))
:always
(encode-file))
path (str "files/" file-id ".json")]
(write-entry! output path file))
(doseq [[index page-id] (d/enumerate pages)]
(let [path (str "files/" file-id "/pages/" page-id ".json")
page (get pages-index page-id)
objects (:objects page)
page (-> page
(dissoc :objects)
(assoc :index index))
page (encode-page page)]
(write-entry! output path page)
(doseq [[shape-id shape] objects]
(let [path (str "files/" file-id "/pages/" page-id "/" shape-id ".json")
shape (assoc shape :page-id page-id)
shape (encode-shape shape)]
(write-entry! output path shape)))))
(vswap! bfc/*state* bfc/collect-storage-objects media)
(vswap! bfc/*state* bfc/collect-storage-objects thumbnails)
(doseq [{:keys [id] :as media} media]
(let [path (str "files/" file-id "/media/" id ".json")
media (encode-media media)]
(write-entry! output path media)))
(doseq [thumbnail thumbnails]
(let [data (cth/parse-object-id (:object-id thumbnail))
path (str "files/" file-id "/thumbnails/" (:tag data) "/" (:page-id data)
"/" (:frame-id data) ".json")
data (-> data
(assoc :media-id (:media-id thumbnail))
(encode-file-thumbnail))]
(write-entry! output path data)))
(doseq [[id component] components]
(let [path (str "files/" file-id "/components/" id ".json")
component (encode-component component)]
(write-entry! output path component)))
(doseq [[id color] colors]
(let [path (str "files/" file-id "/colors/" id ".json")
color (-> (encode-color color)
(dissoc :file-id))
color (cond-> color
(and (contains? color :path)
(str/empty? (:path color)))
(dissoc :path))]
(write-entry! output path color)))
(doseq [[id object] typographies]
(let [path (str "files/" file-id "/typographies/" id ".json")
color (encode-typography object)]
(write-entry! output path color)))))
(defn- export-files
[{:keys [::ids ::include-libraries ::output] :as cfg}]
(let [ids (into ids (when include-libraries (bfc/get-libraries cfg ids)))
rels (if include-libraries
(->> (bfc/get-files-rels cfg ids)
(mapv (juxt :file-id :library-file-id)))
[])]
(vswap! bfc/*state* assoc :files (d/ordered-map))
;; Write all the exporting files
(doseq [[index file-id] (d/enumerate ids)]
(-> cfg
(assoc ::file-id file-id)
(assoc ::file-seqn index)
(export-file)))
;; Write manifest file
(let [files (:files @bfc/*state*)
params {:type "penpot/export-files"
:version 1
:generated-by (str "penpot/" (:full cf/version))
:files (vec (vals files))
:relations rels}]
(write-entry! output "manifest.json" params))))
;; --- IMPORT IMPL
(defn- read-zip-entries
[^ZipFile input]
(into #{} (iterator-seq (.entries input))))
(defn- get-zip-entry*
[^ZipFile input ^String path]
(.getEntry input path))
(defn- get-zip-entry
[input path]
(let [entry (get-zip-entry* input path)]
(when-not entry
(ex/raise :type :validation
:code :inconsistent-penpot-file
:hint "the penpot file seems corrupt, missing underlying zip entry"
:path path))
entry))
(defn- get-zip-entry-size
[^ZipEntry entry]
(.getSize entry))
(defn- zip-entry-name
[^ZipEntry entry]
(.getName entry))
(defn- zip-entry-stream
^InputStream
[^ZipFile input ^ZipEntry entry]
(.getInputStream input entry))
(defn- zip-entry-reader
[^ZipFile input ^ZipEntry entry]
(-> (zip-entry-stream input entry)
(io/reader :encoding "UTF-8")))
(defn- zip-entry-storage-content
"Wraps a ZipFile and ZipEntry into a penpot storage compatible
object and avoid creating temporal objects"
[input entry]
(let [hash (delay (->> entry
(zip-entry-stream input)
(sto.impl/calculate-hash)))]
(reify
sto.impl/IContentObject
(get-size [_]
(get-zip-entry-size entry))
sto.impl/IContentHash
(get-hash [_]
(deref hash))
jio/IOFactory
(make-reader [this opts]
(jio/make-reader this opts))
(make-writer [_ _]
(throw (UnsupportedOperationException. "not implemented")))
(make-input-stream [_ _]
(zip-entry-stream input entry))
(make-output-stream [_ _]
(throw (UnsupportedOperationException. "not implemented"))))))
(defn- read-manifest
[^ZipFile input]
(let [entry (get-zip-entry input "manifest.json")]
(with-open [reader (zip-entry-reader input entry)]
(let [manifest (json/read reader :key-fn json/read-kebab-key)]
(decode-manifest manifest)))))
(defn- match-media-entry-fn
[file-id]
(let [pattern (str "^files/" file-id "/media/([^/]+).json$")
pattern (re-pattern pattern)]
(fn [entry]
(when-let [[_ id] (re-matches pattern (zip-entry-name entry))]
{:entry entry
:id (parse-uuid id)}))))
(defn- match-color-entry-fn
[file-id]
(let [pattern (str "^files/" file-id "/colors/([^/]+).json$")
pattern (re-pattern pattern)]
(fn [entry]
(when-let [[_ id] (re-matches pattern (zip-entry-name entry))]
{:entry entry
:id (parse-uuid id)}))))
(defn- match-component-entry-fn
[file-id]
(let [pattern (str "^files/" file-id "/components/([^/]+).json$")
pattern (re-pattern pattern)]
(fn [entry]
(when-let [[_ id] (re-matches pattern (zip-entry-name entry))]
{:entry entry
:id (parse-uuid id)}))))
(defn- match-typography-entry-fn
[file-id]
(let [pattern (str "^files/" file-id "/typographies/([^/]+).json$")
pattern (re-pattern pattern)]
(fn [entry]
(when-let [[_ id] (re-matches pattern (zip-entry-name entry))]
{:entry entry
:id (parse-uuid id)}))))
(defn- match-thumbnail-entry-fn
[file-id]
(let [pattern (str "^files/" file-id "/thumbnails/([^/]+)/([^/]+)/([^/]+).json$")
pattern (re-pattern pattern)]
(fn [entry]
(when-let [[_ tag page-id frame-id] (re-matches pattern (zip-entry-name entry))]
{:entry entry
:tag tag
:page-id (parse-uuid page-id)
:frame-id (parse-uuid frame-id)
:file-id file-id}))))
(defn- match-page-entry-fn
[file-id]
(let [pattern (str "^files/" file-id "/pages/([^/]+).json$")
pattern (re-pattern pattern)]
(fn [entry]
(when-let [[_ id] (re-matches pattern (zip-entry-name entry))]
{:entry entry
:id (parse-uuid id)}))))
(defn- match-shape-entry-fn
[file-id page-id]
(let [pattern (str "^files/" file-id "/pages/" page-id "/([^/]+).json$")
pattern (re-pattern pattern)]
(fn [entry]
(when-let [[_ id] (re-matches pattern (zip-entry-name entry))]
{:entry entry
:page-id page-id
:id (parse-uuid id)}))))
(defn- match-storage-entry-fn
[]
(let [pattern (str "^objects/([^/]+).json$")
pattern (re-pattern pattern)]
(fn [entry]
(when-let [[_ id] (re-matches pattern (zip-entry-name entry))]
{:entry entry
:id (parse-uuid id)}))))
(defn- read-entry
[^ZipFile input entry]
(with-open [reader (zip-entry-reader input entry)]
(json/read reader :key-fn json/read-kebab-key)))
(defn- read-file
[{:keys [::input ::file-id]}]
(let [path (str "files/" file-id ".json")
entry (get-zip-entry input path)]
(-> (read-entry input entry)
(decode-file)
(validate-file))))
(defn- read-file-plugin-data
[{:keys [::input ::file-id]}]
(let [path (str "files/" file-id "/plugin-data.json")
entry (get-zip-entry* input path)]
(some->> entry
(read-entry input)
(decode-plugin-data)
(validate-plugin-data))))
(defn- read-file-media
[{:keys [::input ::file-id ::entries]}]
(->> (keep (match-media-entry-fn file-id) entries)
(reduce (fn [result {:keys [id entry]}]
(let [object (->> (read-entry input entry)
(decode-media)
(validate-media))
object (assoc object :file-id file-id)]
(if (= id (:id object))
(conj result object)
result)))
[])
(not-empty)))
(defn- read-file-colors
[{:keys [::input ::file-id ::entries]}]
(->> (keep (match-color-entry-fn file-id) entries)
(reduce (fn [result {:keys [id entry]}]
(let [object (->> (read-entry input entry)
(decode-color)
(validate-color))]
(if (= id (:id object))
(assoc result id object)
result)))
{})
(not-empty)))
(defn- read-file-components
[{:keys [::input ::file-id ::entries]}]
(->> (keep (match-component-entry-fn file-id) entries)
(reduce (fn [result {:keys [id entry]}]
(let [object (->> (read-entry input entry)
(decode-component)
(validate-component))]
(if (= id (:id object))
(assoc result id object)
result)))
{})
(not-empty)))
(defn- read-file-typographies
[{:keys [::input ::file-id ::entries]}]
(->> (keep (match-typography-entry-fn file-id) entries)
(reduce (fn [result {:keys [id entry]}]
(let [object (->> (read-entry input entry)
(decode-typography)
(validate-typography))]
(if (= id (:id object))
(assoc result id object)
result)))
{})
(not-empty)))
(defn- read-file-shapes
[{:keys [::input ::file-id ::page-id ::entries] :as cfg}]
(->> (keep (match-shape-entry-fn file-id page-id) entries)
(reduce (fn [result {:keys [id entry]}]
(let [object (->> (read-entry input entry)
(decode-shape)
(validate-shape))]
(if (= id (:id object))
(assoc result id object)
result)))
{})
(not-empty)))
(defn- read-file-pages
[{:keys [::input ::file-id ::entries] :as cfg}]
(->> (keep (match-page-entry-fn file-id) entries)
(keep (fn [{:keys [id entry]}]
(let [page (->> (read-entry input entry)
(decode-page))
page (dissoc page :options)]
(when (= id (:id page))
(let [objects (-> (assoc cfg ::page-id id)
(read-file-shapes))]
(assoc page :objects objects))))))
(sort-by :index)
(reduce (fn [result {:keys [id] :as page}]
(assoc result id (dissoc page :index)))
(d/ordered-map))))
(defn- read-file-thumbnails
[{:keys [::input ::file-id ::entries] :as cfg}]
(->> (keep (match-thumbnail-entry-fn file-id) entries)
(reduce (fn [result {:keys [page-id frame-id tag entry]}]
(let [object (->> (read-entry input entry)
(decode-file-thumbnail)
(validate-file-thumbnail))]
(if (and (= frame-id (:frame-id object))
(= page-id (:page-id object))
(= tag (:tag object)))
(conj result object)
result)))
[])
(not-empty)))
(defn- read-file-data
[{:keys [] :as cfg}]
(let [colors (read-file-colors cfg)
typographies (read-file-typographies cfg)
components (read-file-components cfg)
plugin-data (read-file-plugin-data cfg)
pages (read-file-pages cfg)]
{:pages (-> pages keys vec)
:pages-index (into {} pages)
:colors colors
:typographies typographies
:components components
:plugin-data plugin-data}))
(defn- import-file
[{:keys [::db/conn ::project-id ::file-id ::file-name] :as cfg}]
(let [file-id' (bfc/lookup-index file-id)
file (read-file cfg)
media (read-file-media cfg)
thumbnails (read-file-thumbnails cfg)]
(l/dbg :hint "processing file"
:id (str file-id')
:prev-id (str file-id)
:features (str/join "," (:features file))
:version (:version file)
::l/sync? true)
(events/tap :progress {:section :file :name file-name})
(when media
;; Update index with media
(l/dbg :hint "update media index"
:file-id (str file-id')
:total (count media)
::l/sync? true)
(vswap! bfc/*state* update :index bfc/update-index (map :id media))
(vswap! bfc/*state* update :media into media))
(when thumbnails
(l/dbg :hint "update thumbnails index"
:file-id (str file-id')
:total (count thumbnails)
::l/sync? true)
(vswap! bfc/*state* update :index bfc/update-index (map :media-id thumbnails))
(vswap! bfc/*state* update :thumbnails into thumbnails))
(let [data (-> (read-file-data cfg)
(d/without-nils)
(assoc :id file-id')
(cond-> (:options file)
(assoc :options (:options file))))
file (-> file
(assoc :id file-id')
(assoc :data data)
(assoc :name file-name)
(assoc :project-id project-id)
(dissoc :options)
(bfc/process-file))]
(->> file
(bfc/register-pending-migrations cfg)
(bfc/persist-file! cfg))
(when (::bfc/overwrite cfg)
(db/delete! conn :file-thumbnail {:file-id file-id'}))
file-id')))
(defn- import-file-relations
[{:keys [::db/conn ::manifest ::bfc/timestamp] :as cfg}]
(events/tap :progress {:section :relations})
(doseq [[file-id libr-id] (:relations manifest)]
(let [file-id (bfc/lookup-index file-id)
libr-id (bfc/lookup-index libr-id)]
(when (and file-id libr-id)
(l/dbg :hint "create file library link"
:file-id (str file-id)
:lib-id (str libr-id)
::l/sync? true)
(db/insert! conn :file-library-rel
{:synced-at timestamp
:file-id file-id
:library-file-id libr-id})))))
(defn- import-storage-objects
[{:keys [::input ::entries ::bfc/timestamp] :as cfg}]
(events/tap :progress {:section :storage-objects})
(let [storage (sto/resolve cfg)
entries (keep (match-storage-entry-fn) entries)]
(doseq [{:keys [id entry]} entries]
(let [object (->> (read-entry input entry)
(decode-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 (resolve-extension (:content-type object))
path (str "objects/" id ext)
content (->> path
(get-zip-entry input)
(zip-entry-storage-content input))]
(when (not= (:size object) (sto/get-size content))
(ex/raise :type :validation
:code :inconsistent-penpot-file
:hint "found corrupted storage object: size does not match"
:path path
:expected-size (:size object)
:found-size (sto/get-size content)))
(when (not= (:hash object) (sto/get-hash content))
(ex/raise :type :validation
:code :inconsistent-penpot-file
:hint "found corrupted storage object: hash does not match"
:path path
:expected-hash (:hash object)
:found-hash (sto/get-hash content)))
(let [params (-> object
(dissoc :id :size)
(assoc ::sto/content content)
(assoc ::sto/deduplicate? true)
(assoc ::sto/touched-at timestamp))
sobject (sto/put-object! storage params)]
(l/dbg :hint "persisted storage object"
:id (str (:id sobject))
:prev-id (str id)
: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"
: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? (::bfc/overwrite cfg)}))))
(defn- import-files
[{:keys [::bfc/timestamp ::input ::name] :or {timestamp (dt/now)} :as cfg}]
(dm/assert!
"expected zip file"
(instance? ZipFile input))
(dm/assert!
"expected valid instant"
(dt/instant? timestamp))
(let [manifest (-> (read-manifest input)
(validate-manifest))
entries (read-zip-entries input)]
(when-not (= "penpot/export-files" (:type manifest))
(ex/raise :type :validation
:code :invalid-binfile-v3-manifest
:hint "unexpected type on manifest"
:manifest manifest))
;; Check if all files referenced on manifest are present
(doseq [{file-id :id} (:files manifest)]
(let [path (str "files/" file-id ".json")]
(when-not (get-zip-entry input path)
(ex/raise :type :validation
:code :invalid-binfile-v3
:hint "some files referenced on manifest not found"
:path path
:file-id file-id))))
(events/tap :progress {:section :manifest})
(let [index (bfc/update-index (map :id (:files manifest)))
state {:media [] :index index}
cfg (-> cfg
(assoc ::entries entries)
(assoc ::manifest manifest)
(assoc ::bfc/timestamp timestamp))]
(binding [bfc/*state* (volatile! state)]
(db/tx-run! cfg (fn [cfg]
(bfc/disable-database-timeouts! cfg)
(let [ids (->> (:files manifest)
(reduce (fn [result {:keys [id] :as file}]
(let [name' (get file :name)
name' (if (map? name)
(get name id)
name')]
(conj result (-> cfg
(assoc ::file-id id)
(assoc ::file-name name')
(import-file)))))
[]))]
(import-file-relations cfg)
(import-storage-objects cfg)
(import-file-media cfg)
(import-file-thumbnails cfg)
(bfc/apply-pending-migrations! cfg)
ids)))))))
;; --- PUBLIC API
(defn export-files!
"Do the exportation of a specified file in custom penpot binary
format. There are some options available for customize the output:
`::include-libraries`: additionally to the specified file, all the
linked libraries also will be included (including transitive
dependencies).
`::embed-assets`: instead of including the libraries, embed in the
same file library all assets used from external libraries."
[{:keys [::ids] :as cfg} output]
(dm/assert!
"expected a set of uuid's for `::ids` parameter"
(and (set? ids)
(every? uuid? ids)))
(dm/assert!
"expected instance of jio/IOFactory for `input`"
(satisfies? jio/IOFactory output))
(let [id (uuid/next)
tp (dt/tpoint)
ab (volatile! false)
cs (volatile! nil)]
(try
(l/info :hint "start exportation" :export-id (str id))
(binding [bfc/*state* (volatile! (bfc/initial-state))]
(with-open [output (io/output-stream output)]
(with-open [output (ZipOutputStream. output)]
(let [cfg (assoc cfg ::output output)]
(export-files cfg)
(export-storage-objects cfg)))))
(catch java.util.zip.ZipException cause
(vreset! cs cause)
(vreset! ab true)
(throw cause))
(catch java.io.IOException _cause
;; Do nothing, EOF means client closes connection abruptly
(vreset! ab true)
nil)
(catch Throwable cause
(vreset! cs cause)
(vreset! ab true)
(throw cause))
(finally
(l/info :hint "exportation finished" :export-id (str id)
:elapsed (str (inst-ms (tp)) "ms")
:aborted @ab
:cause @cs)))))
(defn import-files!
[{:keys [::input] :as cfg}]
(dm/assert!
"expected valid profile-id and project-id on `cfg`"
(and (uuid? (::profile-id cfg))
(uuid? (::project-id cfg))))
(dm/assert!
"expected instance of jio/IOFactory for `input`"
(io/coercible? input))
(let [id (uuid/next)
tp (dt/tpoint)
cs (volatile! nil)]
(l/info :hint "import: started" :id (str id))
(try
(with-open [input (ZipFile. (fs/file input))]
(import-files (assoc cfg ::input input)))
(catch Throwable cause
(vreset! cs cause)
(throw cause))
(finally
(l/info :hint "import: terminated"
:id (str id)
:elapsed (dt/format-duration (tp))
:error? (some? @cs))))))

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

@ -26,11 +26,11 @@
[_ data]
(d/without-nils data))
(defmethod ig/prep-key :default
[_ data]
(if (map? data)
(d/without-nils data)
data))
(defmethod ig/expand-key :default
[k v]
{k (if (map? v)
(d/without-nils v)
v)})
(def default
{:database-uri "postgresql://postgres/penpot"
@ -126,7 +126,7 @@
[:worker-webhook-parallelism {:optional true} ::sm/int]
[:database-password {:optional true} [:maybe :string]]
[:database-uri {:optional true} :string]
[:database-uri {:optional true} ::sm/uri]
[:database-username {:optional true} [:maybe :string]]
[:database-readonly {:optional true} ::sm/boolean]
[:database-min-pool-size {:optional true} ::sm/int]
@ -142,6 +142,8 @@
[:quotes-font-variants-per-team {:optional true} ::sm/int]
[:quotes-comment-threads-per-file {:optional true} ::sm/int]
[:quotes-comments-per-file {:optional true} ::sm/int]
[:quotes-snapshots-per-file {:optional true} ::sm/int]
[:quotes-snapshots-per-team {:optional true} ::sm/int]
[:auth-data-cookie-domain {:optional true} :string]
[:auth-token-cookie-name {:optional true} :string]
@ -188,7 +190,7 @@
[:profile-complaint-max-age {:optional true} ::dt/duration]
[:profile-complaint-threshold {:optional true} ::sm/int]
[:redis-uri {:optional true} :string]
[:redis-uri {:optional true} ::sm/uri]
[:email-domain-blacklist {:optional true} ::fs/path]
[:email-domain-whitelist {:optional true} ::fs/path]
@ -216,14 +218,14 @@
[: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} :string]
[: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} :string]
[:objects-storage-s3-endpoint {:optional true} ::sm/uri]
[:objects-storage-s3-io-threads {:optional true} ::sm/int]]))
(def default-flags

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

@ -11,7 +11,7 @@
[app.common.exceptions :as ex]
[app.common.geom.point :as gpt]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.transit :as t]
[app.common.uuid :as uuid]
[app.db.sql :as sql]
@ -20,7 +20,6 @@
[app.util.time :as dt]
[clojure.java.io :as io]
[clojure.set :as set]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[next.jdbc :as jdbc]
[next.jdbc.date-time :as jdbc-dt])
@ -49,27 +48,17 @@
;; Initialization
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::connection-timeout ::us/integer)
(s/def ::max-size ::us/integer)
(s/def ::min-size ::us/integer)
(s/def ::name keyword?)
(s/def ::password ::us/string)
(s/def ::uri ::us/not-empty-string)
(s/def ::username ::us/string)
(s/def ::validation-timeout ::us/integer)
(s/def ::read-only? ::us/boolean)
(s/def ::pool-options
(s/keys :opt [::uri
::name
::min-size
::max-size
::connection-timeout
::validation-timeout
::username
::password
::mtx/metrics
::read-only?]))
(def ^:private schema:pool-options
[:map {:title "pool-options"}
[::connect-timeout {:optional true} ::sm/int]
[::max-size {:optional true} ::sm/int]
[::min-size {:optional true} ::sm/int]
[::name {:optional true} :keyword]
[::uri {:optional true} ::sm/uri]
[::password {:optional true} :string]
[::username {:optional true} :string]
[::validation-timeout {:optional true} ::sm/int]
[::read-only {:optional true} ::sm/boolean]])
(def defaults
{::name :main
@ -79,27 +68,26 @@
::validation-timeout 10000
::idle-timeout 120000 ; 2min
::max-lifetime 1800000 ; 30m
::read-only? false})
::read-only false})
(defmethod ig/prep-key ::pool
[_ cfg]
(merge defaults (d/without-nils cfg)))
;; Don't validate here, just validate that a map is received.
(defmethod ig/pre-init-spec ::pool [_] ::pool-options)
(defmethod ig/assert-key ::pool
[_ options]
(assert (sm/check schema:pool-options options)))
(defmethod ig/init-key ::pool
[_ {:keys [::uri ::read-only?] :as cfg}]
(when uri
(l/info :hint "initialize connection pool"
:name (d/name (::name cfg))
:uri uri
:read-only read-only?
:with-credentials (and (contains? cfg ::username)
(contains? cfg ::password))
:min-size (::min-size cfg)
:max-size (::max-size cfg))
(create-pool cfg)))
[_ cfg]
(let [{:keys [::uri ::read-only] :as cfg}
(merge defaults cfg)]
(when uri
(l/info :hint "initialize connection pool"
:name (d/name (::name cfg))
:uri (str uri)
:read-only read-only
:credentials (and (contains? cfg ::username)
(contains? cfg ::password))
:min-size (::min-size cfg)
:max-size (::max-size cfg))
(create-pool cfg))))
(defmethod ig/halt-key! ::pool
[_ pool]
@ -115,13 +103,15 @@
"SET idle_in_transaction_session_timeout = 300000;"))
(defn- create-datasource-config
[{:keys [::mtx/metrics ::uri] :as cfg}]
[{:keys [::uri] :as cfg}]
;; (app.common.pprint/pprint cfg)
(let [config (HikariConfig.)]
(doto config
(.setJdbcUrl (str "jdbc:" uri))
(.setPoolName (d/name (::name cfg)))
(.setAutoCommit true)
(.setReadOnly (::read-only? cfg))
(.setReadOnly (::read-only cfg))
(.setConnectionTimeout (::connection-timeout cfg))
(.setValidationTimeout (::validation-timeout cfg))
(.setIdleTimeout (::idle-timeout cfg))
@ -132,8 +122,8 @@
(.setInitializationFailTimeout -1))
;; When metrics namespace is provided
(when metrics
(->> (::mtx/registry metrics)
(when-let [instance (::mtx/metrics cfg)]
(->> (mtx/get-registry instance)
(PrometheusMetricsTrackerFactory.)
(.setMetricsTrackerFactory config)))
@ -150,10 +140,22 @@
[conn]
(instance? Connection conn))
(s/def ::conn some?)
(s/def ::nilable-pool (s/nilable ::pool))
(s/def ::pool pool?)
(s/def ::connectable some?)
(defn connectable?
[o]
(or (connection? o)
(pool? o)))
(sm/register!
{:type ::conn
:pred connection?})
(sm/register!
{:type ::connectable
:pred connectable?})
(sm/register!
{:type ::pool
:pred pool?})
(defn closed?
[pool]

237
backend/src/app/email.clj
View File

@ -12,18 +12,12 @@
[app.common.logging :as l]
[app.common.pprint :as pp]
[app.common.schema :as sm]
[app.common.spec :as us]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as sql]
[app.email.invite-to-team :as-alias email.invite-to-team]
[app.email.join-team :as-alias email.join-team]
[app.email.request-team-access :as-alias email.request-team-access]
[app.metrics :as mtx]
[app.util.template :as tmpl]
[app.worker :as wrk]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[integrant.core :as ig])
(:import
@ -223,50 +217,47 @@
[{:type "text/html"
:content html}]))}))
(s/def ::priority #{:high :low})
(s/def ::to (s/or :single ::us/email
:multi (s/coll-of ::us/email)))
(s/def ::from ::us/email)
(s/def ::reply-to ::us/email)
(s/def ::lang string?)
(s/def ::extra-data ::us/string)
(def ^:private schema:context
[:map
[:to [:or ::sm/email [::sm/vec ::sm/email]]]
[:reply-to {:optional true} ::sm/email]
[:from {:optional true} ::sm/email]
[:lang {:optional true} ::sm/text]
[:priority {:optional true} [:enum :high :low]]
[:extra-data {:optional true} ::sm/text]])
(s/def ::context
(s/keys :req-un [::to]
:opt-un [::reply-to ::from ::lang ::priority ::extra-data]))
(def ^:private valid-context?
(sm/validator schema:context))
(defn template-factory
([id] (template-factory id {}))
([id extra-context]
(s/assert keyword? id)
(fn [context]
(us/verify ::context context)
(when-let [spec (s/get-spec id)]
(s/assert spec context))
[& {:keys [id schema]}]
(assert (keyword? id) "id should be provided and it should be a keyword")
(let [check-fn (if schema
(sm/check-fn schema)
(constantly nil))]
(fn [context]
(assert (valid-context? context) "expected a valid context")
(check-fn context)
(let [context (merge (if (fn? extra-context)
(extra-context)
extra-context)
context)
email (build-email-template id context)]
(when-not email
(ex/raise :type :internal
:code :email-template-does-not-exists
:hint "seems like the template is wrong or does not exists."
:context {:id id}))
(cond-> (assoc email :id (name id))
(:extra-data context)
(assoc :extra-data (:extra-data context))
(let [email (build-email-template id context)]
(when-not email
(ex/raise :type :internal
:code :email-template-does-not-exists
:hint "seems like the template is wrong or does not exists."
:template-id id))
(:from context)
(assoc :from (:from context))
(cond-> (assoc email :id (name id))
(:extra-data context)
(assoc :extra-data (:extra-data context))
(:reply-to context)
(assoc :reply-to (:reply-to context))
(:from context)
(assoc :from (:from context))
(:to context)
(assoc :to (:to context)))))))
(:reply-to context)
(assoc :reply-to (:reply-to context))
(:to context)
(assoc :to (:to context)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC HIGH-LEVEL API
@ -280,7 +271,8 @@
"Schedule an already defined email to be sent using asynchronously
using worker task."
[{:keys [::conn ::factory] :as context}]
(us/verify some? conn)
(assert (db/connection? conn) "expected a valid database connection")
(let [email (if factory
(factory context)
(dissoc context ::conn))]
@ -297,8 +289,6 @@
(declare send-to-logger!)
(s/def ::sendmail fn?)
(defmethod ig/init-key ::sendmail
[_ cfg]
(fn [params]
@ -324,8 +314,9 @@
(when (contains? cf/flags :log-emails)
(send-to-logger! cfg params))))
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::sendmail ::mtx/metrics]))
(defmethod ig/assert-key ::handler
[_ params]
(assert (fn? (::sendmail params)) "expected valid sendmail handler"))
(defmethod ig/init-key ::handler
[_ {:keys [::sendmail]}]
@ -352,125 +343,113 @@
;; EMAIL FACTORIES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::subject ::us/string)
(s/def ::content ::us/string)
(s/def ::feedback
(s/keys :req-un [::subject ::content]))
(def ^:private schema:feedback
[:map
[:subject ::sm/text]
[:content ::sm/text]])
(def feedback
"A profile feedback email."
(template-factory ::feedback))
(template-factory
:id ::feedback
:schema schema:feedback))
(s/def ::name ::us/string)
(s/def ::register
(s/keys :req-un [::name]))
(def ^:private schema:register
[:map [:name ::sm/text]])
(def register
"A new profile registration welcome email."
(template-factory ::register))
(template-factory
:id ::register
:schema schema:register))
(s/def ::token ::us/string)
(s/def ::password-recovery
(s/keys :req-un [::name ::token]))
(def ^:private schema:password-recovery
[:map
[:name ::sm/text]
[:token ::sm/text]])
(def password-recovery
"A password recovery notification email."
(template-factory ::password-recovery))
(template-factory
:id ::password-recovery
:schema schema:password-recovery))
(s/def ::pending-email ::us/email)
(s/def ::change-email
(s/keys :req-un [::name ::pending-email ::token]))
(def ^:private schema:change-email
[:map
[:name ::sm/text]
[:pending-email ::sm/email]
[:token ::sm/text]])
(def change-email
"Password change confirmation email"
(template-factory ::change-email))
(template-factory
:id ::change-email
:schema schema:change-email))
(s/def ::email.invite-to-team/invited-by ::us/string)
(s/def ::email.invite-to-team/team ::us/string)
(s/def ::email.invite-to-team/token ::us/string)
(s/def ::invite-to-team
(s/keys :req-un [::email.invite-to-team/invited-by
::email.invite-to-team/token
::email.invite-to-team/team]))
(def ^:private schema:invite-to-team
[:map
[:invited-by ::sm/text]
[:team ::sm/text]
[:token ::sm/text]])
(def invite-to-team
"Teams member invitation email."
(template-factory ::invite-to-team))
(template-factory
:id ::invite-to-team
:schema schema:invite-to-team))
(s/def ::email.join-team/invited-by ::us/string)
(s/def ::email.join-team/team ::us/string)
(s/def ::email.join-team/team-id ::us/uuid)
(s/def ::join-team
(s/keys :req-un [::email.join-team/invited-by
::email.join-team/team-id
::email.join-team/team]))
(def ^:private schema:join-team
[:map
[:invited-by ::sm/text]
[:team ::sm/text]
[:team-id ::sm/uuid]])
(def join-team
"Teams member joined after request email."
(template-factory ::join-team))
(template-factory
:id ::join-team
:schema schema:join-team))
(s/def ::email.request-team-access/requested-by ::us/string)
(s/def ::email.request-team-access/requested-by-email ::us/string)
(s/def ::email.request-team-access/team-name ::us/string)
(s/def ::email.request-team-access/team-id ::us/uuid)
(s/def ::email.request-team-access/file-name ::us/string)
(s/def ::email.request-team-access/file-id ::us/uuid)
(s/def ::email.request-team-access/page-id ::us/uuid)
(s/def ::request-file-access
(s/keys :req-un [::email.request-team-access/requested-by
::email.request-team-access/requested-by-email
::email.request-team-access/team-name
::email.request-team-access/team-id
::email.request-team-access/file-name
::email.request-team-access/file-id
::email.request-team-access/page-id]))
(def ^:private schema:request-file-access
[:map
[:requested-by ::sm/text]
[:requested-by-email ::sm/text]
[:team-name ::sm/text]
[:team-id ::sm/uuid]
[:file-name ::sm/text]
[:file-id ::sm/uuid]
[:page-id ::sm/uuid]])
(def request-file-access
"File access request email."
(template-factory ::request-file-access))
(s/def ::request-file-access-yourpenpot
(s/keys :req-un [::email.request-team-access/requested-by
::email.request-team-access/requested-by-email
::email.request-team-access/team-name
::email.request-team-access/team-id
::email.request-team-access/file-name
::email.request-team-access/file-id
::email.request-team-access/page-id]))
(template-factory
:id ::request-file-access
:schema schema:request-file-access))
(def request-file-access-yourpenpot
"File access on Your Penpot request email."
(template-factory ::request-file-access-yourpenpot))
(s/def ::request-file-access-yourpenpot-view
(s/keys :req-un [::email.request-team-access/requested-by
::email.request-team-access/requested-by-email
::email.request-team-access/team-name
::email.request-team-access/team-id
::email.request-team-access/file-name
::email.request-team-access/file-id
::email.request-team-access/page-id]))
(template-factory
:id ::request-file-access-yourpenpot
:schema schema:request-file-access))
(def request-file-access-yourpenpot-view
"File access on Your Penpot view mode request email."
(template-factory ::request-file-access-yourpenpot-view))
(template-factory
:id ::request-file-access-yourpenpot-view
:schema schema:request-file-access))
(s/def ::request-team-access
(s/keys :req-un [::email.request-team-access/requested-by
::email.request-team-access/requested-by-email
::email.request-team-access/team-name
::email.request-team-access/team-id]))
(def ^:private schema:request-team-access
[:map
[:requested-by ::sm/text]
[:requested-by-email ::sm/text]
[:team-name ::sm/text]
[:team-id ::sm/uuid]])
(def request-team-access
"Team access request email."
(template-factory ::request-team-access))
(template-factory
:id ::request-team-access
:schema schema:request-team-access))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BOUNCE/COMPLAINS HELPERS

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

@ -41,6 +41,7 @@
[app.common.types.shape.path :as ctsp]
[app.common.types.shape.text :as ctsx]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as sql]
[app.features.fdata :as fdata]
@ -1298,7 +1299,7 @@
(let [[mtype data] (parse-datauri href)
size (alength ^bytes data)
path (tmp/tempfile :prefix "penpot.media.download.")
written (io/write-to-file! data path :size size)]
written (io/write* path data :size size)]
(when (not= written size)
(ex/raise :type :internal
@ -1381,7 +1382,9 @@
(defn get-optimized-svg
[sid]
(let [svg-text (get-sobject-content sid)
svg-text (svgo/optimize *system* svg-text)]
svg-text (if (contains? cf/flags :backend-svgo)
(svgo/optimize *system* svg-text)
svg-text)]
(csvg/parse svg-text)))
(def base-path "/data/cache")
@ -1484,11 +1487,6 @@
:file-id (str (:id fdata))
:id (str (:id mobj)))
(instance? org.graalvm.polyglot.PolyglotException cause)
(l/inf :hint "skip processing media object: invalid svg found"
:file-id (str (:id fdata))
:id (str (:id mobj)))
(= (:type edata) :not-found)
(l/inf :hint "skip processing media object: underlying object does not exist"
:file-id (str (:id fdata))
@ -1747,8 +1745,8 @@
(fn [system]
(binding [*system* system]
(when (string? label)
(fsnap/take-file-snapshot! system {:file-id file-id
:label (str "migration/" label)}))
(fsnap/create-file-snapshot! system nil file-id (str "migration/" label)))
(let [file (get-file system file-id)
file (process-file! system file :validate? validate?)]

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

@ -9,6 +9,7 @@
[app.auth.oidc :as-alias oidc]
[app.common.data :as d]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.transit :as t]
[app.db :as-alias db]
[app.http.access-token :as actoken]
@ -24,14 +25,13 @@
[app.rpc :as-alias rpc]
[app.rpc.doc :as-alias rpc.doc]
[app.setup :as-alias setup]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[promesa.exec :as px]
[reitit.core :as r]
[reitit.middleware :as rr]
[ring.request :as rreq]
[ring.response :as-alias rres]
[yetti.adapter :as yt]))
[yetti.adapter :as yt]
[yetti.request :as yreq]
[yetti.response :as-alias yres]))
(declare router-handler)
@ -39,31 +39,28 @@
;; HTTP SERVER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::handler fn?)
(s/def ::router some?)
(s/def ::port integer?)
(s/def ::host string?)
(s/def ::name string?)
(def default-params
{::port 6060
::host "0.0.0.0"
::max-body-size (* 1024 1024 30) ; default 30 MiB
::max-multipart-body-size (* 1024 1024 120)}) ; default 120 MiB
(s/def ::max-body-size integer?)
(s/def ::max-multipart-body-size integer?)
(s/def ::io-threads integer?)
(defmethod ig/expand-key ::server
[k v]
{k (merge default-params (d/without-nils v))})
(defmethod ig/prep-key ::server
[_ cfg]
(merge {::port 6060
::host "0.0.0.0"
::max-body-size (* 1024 1024 30) ; default 30 MiB
::max-multipart-body-size (* 1024 1024 120)} ; default 120 MiB
(d/without-nils cfg)))
(def ^:private schema:server-params
[:map
[::port ::sm/int]
[::host ::sm/text]
[::max-body-size {:optional true} ::sm/int]
[::max-multipart-body-size {:optional true} ::sm/int]
[::router {:optional true} [:fn r/router?]]
[::handler {:optional true} ::sm/fn]])
(defmethod ig/pre-init-spec ::server [_]
(s/keys :req [::port ::host]
:opt [::max-body-size
::max-multipart-body-size
::router
::handler
::io-threads]))
(defmethod ig/assert-key ::server
[_ params]
(assert (sm/check schema:server-params params)))
(defmethod ig/init-key ::server
[_ {:keys [::handler ::router ::host ::port] :as cfg}]
@ -100,12 +97,12 @@
(defn- not-found-handler
[_]
{::rres/status 404})
{::yres/status 404})
(defn- router-handler
[router]
(letfn [(resolve-handler [request]
(if-let [match (r/match-by-path router (rreq/path request))]
(if-let [match (r/match-by-path router (yreq/path request))]
(let [params (:path-params match)
result (:result match)
handler (or (:handler result) not-found-handler)
@ -114,11 +111,11 @@
(partial not-found-handler request)))
(on-error [cause request]
(let [{:keys [::rres/body] :as response} (errors/handle cause request)]
(let [{:keys [::yres/body] :as response} (errors/handle cause request)]
(cond-> response
(map? body)
(-> (update ::rres/headers assoc "content-type" "application/transit+json")
(assoc ::rres/body (t/encode-str body {:type :json-verbose}))))))]
(-> (update ::yres/headers assoc "content-type" "application/transit+json")
(assoc ::yres/body (t/encode-str body {:type :json-verbose}))))))]
(fn [request]
(let [handler (resolve-handler request)]
@ -131,18 +128,26 @@
;; HTTP ROUTER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/pre-init-spec ::router [_]
(s/keys :req [::session/manager
::ws/routes
::rpc/routes
::rpc.doc/routes
::oidc/routes
::setup/props
::assets/routes
::debug/routes
::db/pool
::mtx/routes
::awsns/routes]))
(def ^:private schema:routes
[:vector :any])
(def ^:private schema:router-params
[:map
[::ws/routes schema:routes]
[::rpc/routes schema:routes]
[::rpc.doc/routes schema:routes]
[::oidc/routes schema:routes]
[::assets/routes schema:routes]
[::debug/routes schema:routes]
[::mtx/routes schema:routes]
[::awsns/routes schema:routes]
::session/manager
::setup/props
::db/pool])
(defmethod ig/assert-key ::router
[_ params]
(assert (sm/check schema:router-params params)))
(defmethod ig/init-key ::router
[_ cfg]

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

@ -12,13 +12,13 @@
[app.main :as-alias main]
[app.setup :as-alias setup]
[app.tokens :as tokens]
[ring.request :as rreq]))
[yetti.request :as yreq]))
(def header-re #"^Token\s+(.*)")
(defn- get-token
[request]
(some->> (rreq/get-header request "authorization")
(some->> (yreq/get-header request "authorization")
(re-matches header-re)
(second)))

25
backend/src/app/http/assets.clj
View File

@ -9,14 +9,12 @@
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.uri :as u]
[app.db :as db]
[app.storage :as sto]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[ring.response :as-alias rres]))
[yetti.response :as-alias yres]))
(def ^:private cache-max-age
(dt/duration {:hours 24}))
@ -37,8 +35,8 @@
(defn- serve-object-from-s3
[{:keys [::sto/storage] :as cfg} obj]
(let [{:keys [host port] :as url} (sto/get-object-url storage obj {:max-age signature-max-age})]
{::rres/status 307
::rres/headers {"location" (str url)
{::yres/status 307
::yres/headers {"location" (str url)
"x-host" (cond-> host port (str ":" port))
"x-mtype" (-> obj meta :content-type)
"cache-control" (str "max-age=" (inst-ms cache-max-age))}}))
@ -51,8 +49,8 @@
headers {"x-accel-redirect" (:path purl)
"content-type" (:content-type mdata)
"cache-control" (str "max-age=" (inst-ms cache-max-age))}]
{::rres/status 204
::rres/headers headers}))
{::yres/status 204
::yres/headers headers}))
(defn- serve-object
"Helper function that returns the appropriate response depending on
@ -69,7 +67,7 @@
obj (sto/get-object storage id)]
(if obj
(serve-object cfg obj)
{::rres/status 404})))
{::yres/status 404})))
(defn- generic-handler
"A generic handler helper/common code for file-media based handlers."
@ -80,7 +78,7 @@
sobj (sto/get-object storage (kf mobj))]
(if sobj
(serve-object cfg sobj)
{::rres/status 404})))
{::yres/status 404})))
(defn file-objects-handler
"Handler that serves storage objects by file media id."
@ -95,11 +93,10 @@
;; --- Initialization
(s/def ::path ::us/string)
(s/def ::routes vector?)
(defmethod ig/pre-init-spec ::routes [_]
(s/keys :req [::sto/storage ::path]))
(defmethod ig/assert-key ::routes
[_ params]
(assert (sto/valid-storage? (::sto/storage params)) "expected valid storage instance")
(assert (string? (::path params))))
(defmethod ig/init-key ::routes
[_ cfg]

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

@ -10,6 +10,7 @@
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.pprint :as pp]
[app.common.schema :as sm]
[app.db :as db]
[app.db.sql :as sql]
[app.http.client :as http]
@ -18,29 +19,29 @@
[app.tokens :as tokens]
[app.worker :as-alias wrk]
[clojure.data.json :as j]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[integrant.core :as ig]
[promesa.exec :as px]
[ring.request :as rreq]
[ring.response :as-alias rres]))
[yetti.request :as yreq]
[yetti.response :as-alias yres]))
(declare parse-json)
(declare handle-request)
(declare parse-notification)
(declare process-report)
(defmethod ig/pre-init-spec ::routes [_]
(s/keys :req [::http/client
::setup/props
::db/pool]))
(defmethod ig/assert-key ::routes
[_ params]
(assert (http/client? (::http/client params)) "expect a valid http client")
(assert (sm/valid? ::setup/props (::setup/props params)) "expected valid setup props")
(assert (db/pool? (::db/pool params)) "expect valid database pool"))
(defmethod ig/init-key ::routes
[_ cfg]
(letfn [(handler [request]
(let [data (-> request rreq/body slurp)]
(let [data (-> request yreq/body slurp)]
(px/run! :vthread (partial handle-request cfg data)))
{::rres/status 200})]
{::yres/status 200})]
["/sns" {:handler handler
:allowed-methods #{:post}}]))

16
backend/src/app/http/client.clj
View File

@ -7,20 +7,20 @@
(ns app.http.client
"Http client abstraction layer."
(:require
[app.common.spec :as us]
[clojure.spec.alpha :as s]
[app.common.schema :as sm]
[integrant.core :as ig]
[java-http-clj.core :as http]
[promesa.core :as p])
(:import
java.net.http.HttpClient))
(s/def ::client #(instance? HttpClient %))
(s/def ::client-holder
(s/keys :req [::client]))
(defn client?
[o]
(instance? HttpClient o))
(defmethod ig/pre-init-spec ::client [_]
(s/keys :req []))
(sm/register!
{:type ::client
:pred client?})
(defmethod ig/init-key ::client
[_ _]
@ -30,7 +30,7 @@
(defn send!
([client req] (send! client req {}))
([client req {:keys [response-type sync?] :or {response-type :string sync? false}}]
(us/assert! ::client client)
(assert (client? client) "expected valid http client")
(if sync?
(http/send req {:client client :as response-type})
(try

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

@ -26,15 +26,14 @@
[app.util.blob :as blob]
[app.util.template :as tmpl]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[datoteka.io :as io]
[emoji.core :as emj]
[integrant.core :as ig]
[markdown.core :as md]
[markdown.transformers :as mdt]
[ring.request :as rreq]
[ring.response :as rres]))
[yetti.request :as yreq]
[yetti.response :as yres]))
;; (selmer.parser/cache-off!)
@ -44,9 +43,9 @@
(defn index-handler
[_cfg _request]
{::rres/status 200
::rres/headers {"content-type" "text/html"}
::rres/body (-> (io/resource "app/templates/debug.tmpl")
{::yres/status 200
::yres/headers {"content-type" "text/html"}
::yres/body (-> (io/resource "app/templates/debug.tmpl")
(tmpl/render {:version (:full cf/version)}))})
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -56,17 +55,17 @@
(defn prepare-response
[body]
(let [headers {"content-type" "application/transit+json"}]
{::rres/status 200
::rres/body body
::rres/headers headers}))
{::yres/status 200
::yres/body body
::yres/headers headers}))
(defn prepare-download-response
[body filename]
(let [headers {"content-disposition" (str "attachment; filename=" filename)
"content-type" "application/octet-stream"}]
{::rres/status 200
::rres/body body
::rres/headers headers}))
{::yres/status 200
::yres/body body
::yres/headers headers}))
(def sql:retrieve-range-of-changes
"select revn, changes from file_change where file_id=? and revn >= ? and revn <= ? order by revn")
@ -108,8 +107,8 @@
(db/update! conn :file
{:data data}
{:id file-id})
{::rres/status 201
::rres/body "OK CREATED"})))
{::yres/status 201
::yres/body "OK CREATED"})))
:else
(prepare-response (blob/decode data))))))
@ -123,7 +122,7 @@
[{:keys [::db/pool]} {:keys [::session/profile-id params] :as request}]
(let [profile (profile/get-profile pool profile-id)
project-id (:default-project-id profile)
data (some-> params :file :path io/read-as-bytes)]
data (some-> params :file :path io/read*)]
(if (and data project-id)
(let [fname (str "Imported file *: " (dt/now))
@ -138,8 +137,8 @@
{:data data
:deleted-at nil}
{:id file-id})
{::rres/status 200
::rres/body "OK UPDATED"})
{::yres/status 200
::yres/body "OK UPDATED"})
(db/run! pool (fn [{:keys [::db/conn] :as cfg}]
(create-file cfg {:id file-id
@ -149,15 +148,15 @@
(db/update! conn :file
{:data data}
{:id file-id})
{::rres/status 201
::rres/body "OK CREATED"}))))
{::yres/status 201
::yres/body "OK CREATED"}))))
{::rres/status 500
::rres/body "ERROR"})))
{::yres/status 500
::yres/body "ERROR"})))
(defn file-data-handler
[cfg request]
(case (rreq/method request)
(case (yreq/method request)
:get (retrieve-file-data cfg request)
:post (upload-file-data cfg request)
(ex/raise :type :http
@ -238,12 +237,12 @@
1 (render-template-v1 report)
2 (render-template-v2 report)
3 (render-template-v3 report))]
{::rres/status 200
::rres/body result
::rres/headers {"content-type" "text/html; charset=utf-8"
{::yres/status 200
::yres/body result
::yres/headers {"content-type" "text/html; charset=utf-8"
"x-robots-tag" "noindex"}})
{::rres/status 404
::rres/body "not found"})))
{::yres/status 404
::yres/body "not found"})))
(def sql:error-reports
"SELECT id, created_at,
@ -256,10 +255,10 @@
[{:keys [::db/pool]} _request]
(let [items (->> (db/exec! pool [sql:error-reports])
(map #(update % :created-at dt/format-instant :rfc1123)))]
{::rres/status 200
::rres/body (-> (io/resource "app/templates/error-list.tmpl")
{::yres/status 200
::yres/body (-> (io/resource "app/templates/error-list.tmpl")
(tmpl/render {:items items}))
::rres/headers {"content-type" "text/html; charset=utf-8"
::yres/headers {"content-type" "text/html; charset=utf-8"
"x-robots-tag" "noindex"}}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -295,15 +294,16 @@
cfg (assoc cfg
::bf.v1/overwrite false
::bf.v1/profile-id profile-id
::bf.v1/project-id project-id)]
(bf.v1/import-files! cfg path)
{::rres/status 200
::rres/headers {"content-type" "text/plain"}
::rres/body "OK CLONED"})
::bf.v1/project-id project-id
::bf.v1/input path)]
(bf.v1/import-files! cfg)
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body "OK CLONED"})
{::rres/status 200
::rres/body (io/input-stream path)
::rres/headers {"content-type" "application/octet-stream"
{::yres/status 200
::yres/body (io/input-stream path)
::yres/headers {"content-type" "application/octet-stream"
"content-disposition" (str "attachmen; filename=" (first file-ids) ".penpot")}}))))
@ -329,11 +329,12 @@
::bf.v1/overwrite overwrite?
::bf.v1/migrate migrate?
::bf.v1/profile-id profile-id
::bf.v1/project-id project-id)]
(bf.v1/import-files! cfg path)
{::rres/status 200
::rres/headers {"content-type" "text/plain"}
::rres/body "OK"})))
::bf.v1/project-id project-id
::bf.v1/input path)]
(bf.v1/import-files! cfg)
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body "OK"})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ACTIONS
@ -363,34 +364,34 @@
(db/update! conn :profile {:is-blocked true} {:id (:id profile)})
(db/delete! conn :http-session {:profile-id (:id profile)})
{::rres/status 200
::rres/headers {"content-type" "text/plain"}
::rres/body (str/ffmt "PROFILE '%' BLOCKED" (:email profile))})
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body (str/ffmt "PROFILE '%' BLOCKED" (:email profile))})
(contains? params :unblock)
(do
(db/update! conn :profile {:is-blocked false} {:id (:id profile)})
{::rres/status 200
::rres/headers {"content-type" "text/plain"}
::rres/body (str/ffmt "PROFILE '%' UNBLOCKED" (:email profile))})
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body (str/ffmt "PROFILE '%' UNBLOCKED" (:email profile))})
(contains? params :resend)
(if (:is-blocked profile)
{::rres/status 200
::rres/headers {"content-type" "text/plain"}
::rres/body "PROFILE ALREADY BLOCKED"}
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body "PROFILE ALREADY BLOCKED"}
(do
(#'auth/send-email-verification! cfg profile)
{::rres/status 200
::rres/headers {"content-type" "text/plain"}
::rres/body (str/ffmt "RESENDED FOR '%'" (:email profile))}))
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body (str/ffmt "RESENDED FOR '%'" (:email profile))}))
:else
(do
(db/update! conn :profile {:is-active true} {:id (:id profile)})
{::rres/status 200
::rres/headers {"content-type" "text/plain"}
::rres/body (str/ffmt "PROFILE '%' ACTIVATED" (:email profile))}))))))
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body (str/ffmt "PROFILE '%' ACTIVATED" (:email profile))}))))))
(defn- reset-file-version
@ -415,9 +416,9 @@
(db/tx-run! cfg srepl/process-file! file-id #(assoc % :version version))
{::rres/status 200
::rres/headers {"content-type" "text/plain"}
::rres/body "OK"}))
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body "OK"}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -429,13 +430,13 @@
[{:keys [::db/pool]} _]
(try
(db/exec-one! pool ["select count(*) as count from server_prop;"])
{::rres/status 200
::rres/body "OK"}
{::yres/status 200
::yres/body "OK"}
(catch Throwable cause
(l/warn :hint "unable to execute query on health handler"
:cause cause)
{::rres/status 503
::rres/body "KO"})))
{::yres/status 503
::yres/body "KO"})))
(defn changelog-handler
[_ _]
@ -444,11 +445,11 @@
(md->html [text]
(md/md-to-html-string text :replacement-transformers (into [transform-emoji] mdt/transformer-vector)))]
(if-let [clog (io/resource "changelog.md")]
{::rres/status 200
::rres/headers {"content-type" "text/html; charset=utf-8"}
::rres/body (-> clog slurp md->html)}
{::rres/status 404
::rres/body "NOT FOUND"})))
{::yres/status 200
::yres/headers {"content-type" "text/html; charset=utf-8"}
::yres/body (-> clog slurp md->html)}
{::yres/status 404
::yres/body "NOT FOUND"})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INIT
@ -471,8 +472,10 @@
(ex/raise :type :authentication
:code :only-admins-allowed)))))})
(defmethod ig/pre-init-spec ::routes [_]
(s/keys :req [::db/pool ::session/manager]))
(defmethod ig/assert-key ::routes
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool")
(assert (session/manager? (::session/manager params)) "expected a valid session manager"))
(defmethod ig/init-key ::routes
[_ {:keys [::db/pool] :as cfg}]

127
backend/src/app/http/errors.clj
View File

@ -16,8 +16,8 @@
[app.http.session :as-alias session]
[app.util.inet :as inet]
[clojure.spec.alpha :as s]
[ring.request :as rreq]
[ring.response :as rres]))
[yetti.request :as yreq]
[yetti.response :as yres]))
(defn request->context
"Extracts error report relevant context data from request."
@ -29,10 +29,10 @@
{:request/path (:path request)
:request/method (:method request)
:request/params (:params request)
:request/user-agent (rreq/get-header request "user-agent")
:request/user-agent (yreq/get-header request "user-agent")
:request/ip-addr (inet/parse-request request)
:request/profile-id (:uid claims)
:version/frontend (or (rreq/get-header request "x-frontend-version") "unknown")
:version/frontend (or (yreq/get-header request "x-frontend-version") "unknown")
:version/backend (:full cf/version)}))
@ -46,34 +46,34 @@
(defmethod handle-error :authentication
[err _ _]
{::rres/status 401
::rres/body (ex-data err)})
{::yres/status 401
::yres/body (ex-data err)})
(defmethod handle-error :authorization
[err _ _]
{::rres/status 403
::rres/body (ex-data err)})
{::yres/status 403
::yres/body (ex-data err)})
(defmethod handle-error :restriction
[err _ _]
(let [{:keys [code] :as data} (ex-data err)]
(if (= code :method-not-allowed)
{::rres/status 405
::rres/body data}
{::rres/status 400
::rres/body data})))
{::yres/status 405
::yres/body data}
{::yres/status 400
::yres/body data})))
(defmethod handle-error :rate-limit
[err _ _]
(let [headers (-> err ex-data ::http/headers)]
{::rres/status 429
::rres/headers headers}))
{::yres/status 429
::yres/headers headers}))
(defmethod handle-error :concurrency-limit
[err _ _]
(let [headers (-> err ex-data ::http/headers)]
{::rres/status 429
::rres/headers headers}))
{::yres/status 429
::yres/headers headers}))
(defmethod handle-error :validation
[err request parent-cause]
@ -84,22 +84,26 @@
(= code :schema-validation)
(= code :data-validation))
(let [explain (ex/explain data)]
{::rres/status 400
::rres/body (-> data
{::yres/status 400
::yres/body (-> data
(dissoc ::s/problems ::s/value ::s/spec ::sm/explain)
(cond-> explain (assoc :explain explain)))})
(= code :vern-conflict)
{::yres/status 409 ;; 409 - Conflict
::yres/body data}
(= code :request-body-too-large)
{::rres/status 413 ::rres/body data}
{::yres/status 413 ::yres/body data}
(= code :invalid-image)
(binding [l/*context* (request->context request)]
(let [cause (or parent-cause err)]
(l/warn :hint "unexpected error on processing image" :cause cause)
{::rres/status 400 ::rres/body data}))
{::yres/status 400 ::yres/body data}))
:else
{::rres/status 400 ::rres/body data})))
{::yres/status 400 ::yres/body data})))
(defmethod handle-error :assertion
[error request parent-cause]
@ -110,46 +114,47 @@
(= code :data-validation)
(let [explain (ex/explain data)]
(l/error :hint "data assertion error" :cause cause)
{::rres/status 500
::rres/body {:type :server-error
:code :assertion
:data (-> data
(dissoc ::sm/explain)
(cond-> explain (assoc :explain explain)))}})
{::yres/status 500
::yres/body (-> data
(dissoc ::sm/explain)
(cond-> explain (assoc :explain explain))
(assoc :type :server-error)
(assoc :code :assertion))})
(= code :spec-validation)
(let [explain (ex/explain data)]
(l/error :hint "spec assertion error" :cause cause)
{::rres/status 500
::rres/body {:type :server-error
:code :assertion
:data (-> data
(dissoc ::s/problems ::s/value ::s/spec)
(cond-> explain (assoc :explain explain)))}})
{::yres/status 500
::yres/body (-> data
(dissoc ::s/problems ::s/value ::s/spec)
(cond-> explain (assoc :explain explain))
(assoc :type :server-error)
(assoc :code :assertion))})
:else
(do
(l/error :hint "assertion error" :cause cause)
{::rres/status 500
::rres/body {:type :server-error
:code :assertion
:data data}})))))
{::yres/status 500
::yres/body (-> data
(assoc :type :server-error)
(assoc :code :assertion))})))))
(defmethod handle-error :not-found
[err _ _]
{::rres/status 404
::rres/body (ex-data err)})
{::yres/status 404
::yres/body (ex-data err)})
(defmethod handle-error :internal
[error request parent-cause]
(binding [l/*context* (request->context request)]
(let [cause (or parent-cause error)]
(let [cause (or parent-cause error)
data (ex-data error)]
(l/error :hint "internal error" :cause cause)
{::rres/status 500
::rres/body {:type :server-error
:code :unhandled
:hint (ex-message error)
:data (ex-data error)}})))
{::yres/status 500
::yres/body (-> data
(assoc :type :server-error)
(update :code #(or % :unhandled))
(assoc :hint (ex-message error)))})))
(defmethod handle-error :default
[error request parent-cause]
@ -173,20 +178,20 @@
:cause cause)
(cond
(= state "57014")
{::rres/status 504
::rres/body {:type :server-error
{::yres/status 504
::yres/body {:type :server-error
:code :statement-timeout
:hint (ex-message error)}}
(= state "25P03")
{::rres/status 504
::rres/body {:type :server-error
{::yres/status 504
::yres/body {:type :server-error
:code :idle-in-transaction-timeout
:hint (ex-message error)}}
:else
{::rres/status 500
::rres/body {:type :server-error
{::yres/status 500
::yres/body {:type :server-error
:code :unexpected
:hint (ex-message error)
:state state}}))))
@ -200,25 +205,25 @@
(nil? edata)
(binding [l/*context* (request->context request)]
(l/error :hint "unexpected error" :cause cause)
{::rres/status 500
::rres/body {:type :server-error
{::yres/status 500
::yres/body {:type :server-error
:code :unexpected
:hint (ex-message error)}})
:else
(binding [l/*context* (request->context request)]
(l/error :hint "unhandled error" :cause cause)
{::rres/status 500
::rres/body {:type :server-error
:code :unhandled
:hint (ex-message error)
:data edata}}))))
{::yres/status 500
::yres/body (-> edata
(assoc :type :server-error)
(update :code #(or % :unhandled))
(assoc :hint (ex-message error)))}))))
(defmethod handle-exception java.io.IOException
[cause _ _]
(l/wrn :hint "io exception" :cause cause)
{::rres/status 500
::rres/body {:type :server-error
{::yres/status 500
::yres/body {:type :server-error
:code :io-exception
:hint (ex-message cause)}})
@ -244,4 +249,4 @@
(defn handle'
[cause request]
(::rres/body (handle cause request)))
(::yres/body (handle cause request)))

98
backend/src/app/http/middleware.clj
View File

@ -15,10 +15,10 @@
[app.http.errors :as errors]
[app.util.pointer-map :as pmap]
[cuerdas.core :as str]
[ring.request :as rreq]
[ring.response :as rres]
[yetti.adapter :as yt]
[yetti.middleware :as ymw])
[yetti.middleware :as ymw]
[yetti.request :as yreq]
[yetti.response :as yres])
(:import
io.undertow.server.RequestTooBigException
java.io.InputStream
@ -37,17 +37,17 @@
(defn- get-reader
^java.io.BufferedReader
[request]
(let [^InputStream body (rreq/body request)]
(let [^InputStream body (yreq/body request)]
(java.io.BufferedReader.
(java.io.InputStreamReader. body))))
(defn wrap-parse-request
[handler]
(letfn [(process-request [request]
(let [header (rreq/get-header request "content-type")]
(let [header (yreq/get-header request "content-type")]
(cond
(str/starts-with? header "application/transit+json")
(with-open [^InputStream is (rreq/body request)]
(with-open [^InputStream is (yreq/body request)]
(let [params (t/read! (t/reader is))]
(-> request
(assoc :body-params params)
@ -85,7 +85,7 @@
(errors/handle cause request)))]
(fn [request]
(if (= (rreq/method request) :post)
(if (= (yreq/method request) :post)
(try
(-> request process-request handler)
(catch Throwable cause
@ -113,57 +113,53 @@
(defn wrap-format-response
[handler]
(letfn [(transit-streamable-body [data opts]
(reify rres/StreamableResponseBody
(-write-body-to-stream [_ _ output-stream]
(try
(with-open [^OutputStream bos (buffered-output-stream output-stream buffer-size)]
(let [tw (t/writer bos opts)]
(t/write! tw data)))
(catch java.io.IOException _)
(catch Throwable cause
(binding [l/*context* {:value data}]
(l/error :hint "unexpected error on encoding response"
:cause cause)))
(finally
(.close ^OutputStream output-stream))))))
(letfn [(transit-streamable-body [data opts _ output-stream]
(try
(with-open [^OutputStream bos (buffered-output-stream output-stream buffer-size)]
(let [tw (t/writer bos opts)]
(t/write! tw data)))
(catch java.io.IOException _)
(catch Throwable cause
(binding [l/*context* {:value data}]
(l/error :hint "unexpected error on encoding response"
:cause cause)))
(finally
(.close ^OutputStream output-stream))))
(json-streamable-body [data]
(reify rres/StreamableResponseBody
(-write-body-to-stream [_ _ output-stream]
(try
(let [encode (or (-> data meta :encode/json) identity)
data (encode data)]
(with-open [^OutputStream bos (buffered-output-stream output-stream buffer-size)]
(with-open [^java.io.OutputStreamWriter writer (java.io.OutputStreamWriter. bos)]
(json/write writer data :key-fn json/write-camel-key :value-fn write-json-value))))
(catch java.io.IOException _)
(catch Throwable cause
(binding [l/*context* {:value data}]
(l/error :hint "unexpected error on encoding response"
:cause cause)))
(finally
(.close ^OutputStream output-stream))))))
(json-streamable-body [data _ output-stream]
(try
(let [encode (or (-> data meta :encode/json) identity)
data (encode data)]
(with-open [^OutputStream bos (buffered-output-stream output-stream buffer-size)]
(with-open [^java.io.OutputStreamWriter writer (java.io.OutputStreamWriter. bos)]
(json/write writer data :key-fn json/write-camel-key :value-fn write-json-value))))
(catch java.io.IOException _)
(catch Throwable cause
(binding [l/*context* {:value data}]
(l/error :hint "unexpected error on encoding response"
:cause cause)))
(finally
(.close ^OutputStream output-stream))))
(format-response-with-json [response _]
(let [body (::rres/body response)]
(let [body (::yres/body response)]
(if (or (boolean? body) (coll? body))
(-> response
(update ::rres/headers assoc "content-type" "application/json")
(assoc ::rres/body (json-streamable-body body)))
(update ::yres/headers assoc "content-type" "application/json")
(assoc ::yres/body (yres/stream-body (partial json-streamable-body body))))
response)))
(format-response-with-transit [response request]
(let [body (::rres/body response)]
(let [body (::yres/body response)]
(if (or (boolean? body) (coll? body))
(let [qs (rreq/query request)
(let [qs (yreq/query request)
opts (if (or (contains? cf/flags :transit-readable-response)
(str/includes? qs "transit_verbose"))
{:type :json-verbose}
{:type :json})]
(-> response
(update ::rres/headers assoc "content-type" "application/transit+json")
(assoc ::rres/body (transit-streamable-body body opts))))
(update ::yres/headers assoc "content-type" "application/transit+json")
(assoc ::yres/body (yres/stream-body (partial transit-streamable-body body opts)))))
response)))
(format-from-params [{:keys [query-params] :as request}]
@ -172,7 +168,7 @@
(format-response [response request]
(let [accept (or (format-from-params request)
(rreq/get-header request "accept"))]
(yreq/get-header request "accept"))]
(cond
(or (= accept "application/transit+json")
(str/includes? accept "application/transit+json"))
@ -221,11 +217,11 @@
(defn wrap-cors
[handler]
(fn [request]
(let [response (if (= (rreq/method request) :options)
{::rres/status 200}
(let [response (if (= (yreq/method request) :options)
{::yres/status 200}
(handler request))
origin (rreq/get-header request "origin")]
(update response ::rres/headers with-cors-headers origin))))
origin (yreq/get-header request "origin")]
(update response ::yres/headers with-cors-headers origin))))
(def cors
{:name ::cors
@ -240,7 +236,7 @@
(when-let [allowed (:allowed-methods data)]
(fn [handler]
(fn [request]
(let [method (rreq/method request)]
(let [method (yreq/method request)]
(if (contains? allowed method)
(handler request)
{::rres/status 405}))))))})
{::yres/status 405}))))))})

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

@ -9,7 +9,7 @@
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.uri :as u]
[app.config :as cf]
[app.db :as db]
@ -19,11 +19,9 @@
[app.setup :as-alias setup]
[app.tokens :as tokens]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[integrant.core :as ig]
[ring.request :as rreq]
[yetti.request :as yrq]))
[yetti.request :as yreq]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DEFAULTS
@ -52,21 +50,32 @@
(update! [_ data])
(delete! [_ key]))
(s/def ::manager #(satisfies? ISessionManager %))
(defn manager?
[o]
(satisfies? ISessionManager o))
(sm/register!
{:type ::manager
:pred manager?})
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; STORAGE IMPL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::session-params
(s/keys :req-un [::user-agent
::profile-id
::created-at]))
(def ^:private schema:params
[:map {:title "session-params"}
[:user-agent ::sm/text]
[:profile-id ::sm/uuid]
[:created-at ::sm/inst]])
(def ^:private valid-params?
(sm/validator schema:params))
(defn- prepare-session-params
[key params]
(us/assert! ::us/not-empty-string key)
(us/assert! ::session-params params)
(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")
{:user-agent (:user-agent params)
:profile-id (:profile-id params)
@ -117,8 +126,9 @@
(swap! cache dissoc token)
nil))))
(defmethod ig/pre-init-spec ::manager [_]
(s/keys :req [::db/pool]))
(defmethod ig/assert-key ::manager
[_ params]
(assert (db/pool? (::db/pool params)) "expect valid database pool"))
(defmethod ig/init-key ::manager
[_ {:keys [::db/pool]}]
@ -141,11 +151,11 @@
(defn create-fn
[{:keys [::manager ::setup/props]} profile-id]
(us/assert! ::manager manager)
(us/assert! ::us/uuid profile-id)
(assert (manager? manager) "expected valid session manager")
(assert (uuid? profile-id) "expected valid uuid for profile-id")
(fn [request response]
(let [uagent (rreq/get-header request "user-agent")
(let [uagent (yreq/get-header request "user-agent")
params {:profile-id profile-id
:user-agent uagent
:created-at (dt/now)}
@ -158,10 +168,10 @@
(defn delete-fn
[{:keys [::manager]}]
(us/assert! ::manager manager)
(assert (manager? manager) "expected valid session manager")
(fn [request response]
(let [cname (cf/get :auth-token-cookie-name default-auth-token-cookie-name)
cookie (yrq/get-cookie request cname)]
cookie (yreq/get-cookie request cname)]
(l/trace :hint "delete" :profile-id (:profile-id request))
(some->> (:value cookie) (delete! manager))
(-> response
@ -183,7 +193,7 @@
(defn- get-token
[request]
(let [cname (cf/get :auth-token-cookie-name default-auth-token-cookie-name)
cookie (some-> (yrq/get-cookie request cname) :value)]
cookie (some-> (yreq/get-cookie request cname) :value)]
(when-not (str/empty? cookie)
cookie)))
@ -199,7 +209,7 @@
(defn- wrap-soft-auth
[handler {:keys [::manager ::setup/props]}]
(us/assert! ::manager manager)
(assert (manager? manager) "expected valid session manager")
(letfn [(handle-request [request]
(try
(let [token (get-token request)
@ -217,7 +227,7 @@
(defn- wrap-authz
[handler {:keys [::manager]}]
(us/assert! ::manager manager)
(assert (manager? manager) "expected valid session manager")
(fn [request]
(let [session (get-session manager (::token request))
request (cond-> request
@ -308,16 +318,17 @@
;; TASK: SESSION GC
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::tasks/max-age ::dt/duration)
;; FIXME: MOVE
(defmethod ig/pre-init-spec ::tasks/gc [_]
(s/keys :req [::db/pool]
:opt [::tasks/max-age]))
(defmethod ig/assert-key ::tasks/gc
[_ params]
(assert (db/pool? (::db/pool params)) "expected valid database pool")
(assert (dt/duration? (::tasks/max-age params))))
(defmethod ig/prep-key ::tasks/gc
[_ cfg]
(defmethod ig/expand-key ::tasks/gc
[k v]
(let [max-age (cf/get :auth-token-cookie-max-age default-cookie-max-age)]
(merge {::tasks/max-age max-age} (d/without-nils cfg))))
{k (merge {::tasks/max-age max-age} (d/without-nils v))}))
(def ^:private
sql:delete-expired

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

@ -9,6 +9,7 @@
(:refer-clojure :exclude [tap])
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.transit :as t]
[app.http.errors :as errors]
@ -16,7 +17,7 @@
[promesa.exec :as px]
[promesa.exec.csp :as sp]
[promesa.util :as pu]
[ring.response :as rres])
[yetti.response :as yres])
(:import
java.io.OutputStream))
@ -49,24 +50,21 @@
(defn response
[handler & {:keys [buf] :or {buf 32} :as opts}]
(fn [request]
{::rres/headers default-headers
::rres/status 200
::rres/body (reify rres/StreamableResponseBody
(-write-body-to-stream [_ _ output]
(binding [events/*channel* (sp/chan :buf buf :xf (keep encode))]
(let [listener (events/start-listener
(partial write! output)
(partial pu/close! output))]
(try
(let [result (handler)]
(events/tap :end result))
(catch java.io.EOFException cause
(events/tap :error (errors/handle' cause request)))
(catch Throwable cause
(l/err :hint "unexpected error on processing sse response"
:cause cause)
(events/tap :error (errors/handle' cause request)))
(finally
(sp/close! events/*channel*)
(px/await! listener)))))))}))
{::yres/headers default-headers
::yres/status 200
::yres/body (yres/stream-body
(fn [_ output]
(binding [events/*channel* (sp/chan :buf buf :xf (keep encode))]
(let [listener (events/start-listener
(partial write! output)
(partial pu/close! output))]
(try
(let [result (handler)]
(events/tap :end result))
(catch Throwable cause
(events/tap :error (errors/handle' cause request))
(when-not (ex/instance? java.io.EOFException cause)
(l/err :hint "unexpected error on processing sse response" :cause cause)))
(finally
(sp/close! events/*channel*)
(px/await! listener)))))))}))

29
backend/src/app/http/websocket.clj
View File

@ -18,10 +18,8 @@
[app.msgbus :as mbus]
[app.util.time :as dt]
[app.util.websocket :as ws]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[promesa.exec.csp :as sp]
[ring.websocket :as rws]
[yetti.websocket :as yws]))
(def recv-labels
@ -113,7 +111,6 @@
fsub (::file-subscription @state)
tsub (::team-subscription @state)
msg {:type :disconnect
:subs-id profile-id
:profile-id profile-id
:session-id session-id}]
@ -138,9 +135,7 @@
(l/trace :fn "handle-message" :event "subscribe-team" :team-id team-id :conn-id id)
(let [prev-subs (get @state ::team-subscription)
channel (sp/chan :buf (sp/dropping-buffer 64)
:xf (comp
(remove #(= (:session-id %) session-id))
(map #(assoc % :subs-id team-id))))]
:xf (remove #(= (:session-id %) session-id)))]
(sp/pipe channel output-ch false)
(mbus/sub! msgbus :topic team-id :chan channel)
@ -159,8 +154,7 @@
(l/trace :fn "handle-message" :event "subscribe-file" :file-id file-id :conn-id id)
(let [psub (::file-subscription @state)
fch (sp/chan :buf (sp/dropping-buffer 64)
:xf (comp (remove #(= (:session-id %) session-id))
(map #(assoc % :subs-id file-id))))]
:xf (remove #(= (:session-id %) session-id)))]
(let [subs {:file-id file-id :channel fch :topic file-id}]
(swap! state assoc ::file-subscription subs))
@ -191,7 +185,6 @@
;; Notifify the rest of participants of the new connection.
(let [message {:type :join-file
:file-id file-id
:subs-id file-id
:session-id session-id
:profile-id profile-id}]
(mbus/pub! msgbus :topic file-id :message message))))
@ -303,7 +296,7 @@
:else
(do
(l/trace :hint "websocket request" :profile-id profile-id :session-id session-id)
{::rws/listener (ws/listener request
{::yws/listener (ws/listener request
::ws/on-rcv-message (partial on-rcv-message cfg)
::ws/on-snd-message (partial on-snd-message cfg)
::ws/on-connect (partial on-connect cfg)
@ -311,13 +304,17 @@
::profile-id profile-id
::session-id session-id)}))))
(defmethod ig/pre-init-spec ::routes [_]
(s/keys :req [::mbus/msgbus
::mtx/metrics
::db/pool
::session/manager]))
(s/def ::routes vector?)
(def ^:private schema:routes-params
[:map
::mbus/msgbus
::mtx/metrics
::db/pool
::session/manager])
(defmethod ig/assert-key ::routes
[_ params]
(assert (sm/valid? schema:routes-params params)))
(defmethod ig/init-key ::routes
[_ cfg]

62
backend/src/app/loggers/audit.clj
View File

@ -10,7 +10,7 @@
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
@ -25,9 +25,7 @@
[app.util.services :as-alias sv]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[integrant.core :as ig]))
[cuerdas.core :as str]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPERS
@ -95,46 +93,28 @@
;; --- SPECS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; COLLECTOR
;; COLLECTOR API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Defines a service that collects the audit/activity log using
;; internal database. Later this audit log can be transferred to
;; an external storage and data cleared.
(s/def ::profile-id ::us/uuid)
(s/def ::name ::us/string)
(s/def ::type ::us/string)
(s/def ::props (s/map-of ::us/keyword any?))
(s/def ::ip-addr ::us/string)
(def ^:private schema:event
[:map {:title "event"}
[::type ::sm/text]
[::name ::sm/text]
[::profile-id ::sm/uuid]
[::ip-addr {:optional true} ::sm/text]
[::props {:optional true} [:map-of :keyword :any]]
[::context {:optional true} [:map-of :keyword :any]]
[::webhooks/event? {:optional true} ::sm/boolean]
[::webhooks/batch-timeout {:optional true} ::dt/duration]
[::webhooks/batch-key {:optional true}
[:or ::sm/fn ::sm/text :keyword]]])
(s/def ::webhooks/event? ::us/boolean)
(s/def ::webhooks/batch-timeout ::dt/duration)
(s/def ::webhooks/batch-key
(s/or :fn fn? :str string? :kw keyword?))
(s/def ::event
(s/keys :req [::type ::name ::profile-id]
:opt [::ip-addr
::props
::webhooks/event?
::webhooks/batch-timeout
::webhooks/batch-key]))
(s/def ::collector
(s/keys :req [::wrk/executor ::db/pool]))
(defmethod ig/pre-init-spec ::collector [_]
(s/keys :req [::db/pool ::wrk/executor]))
(defmethod ig/init-key ::collector
[_ {:keys [::db/pool] :as cfg}]
(cond
(db/read-only? pool)
(l/warn :hint "audit disabled (db is read-only)")
:else
cfg))
(def ^:private check-event
(sm/check-fn schema:event))
(defn prepare-event
[cfg mdata params result]
@ -273,12 +253,12 @@
"Submit audit event to the collector."
[cfg event]
(try
(let [event (d/without-nils event)
(let [event (-> (d/without-nils event)
(check-event))
cfg (-> cfg
(assoc ::rtry/when rtry/conflict-exception?)
(assoc ::rtry/max-retries 6)
(assoc ::rtry/label "persist-audit-log"))]
(us/verify! ::event event)
(rtry/invoke! cfg db/tx-run! handle-event! event))
(catch Throwable cause
(l/error :hint "unexpected error processing event" :cause cause))))
@ -289,8 +269,8 @@
logic."
[cfg event]
(when (contains? cf/flags :audit-log)
(let [event (d/without-nils event)]
(us/verify! ::event event)
(let [event (-> (d/without-nils event)
(check-event))]
(db/run! cfg (fn [cfg]
(let [tnow (dt/now)
params (-> (event->params event)

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

@ -8,6 +8,7 @@
(:require
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.transit :as t]
[app.common.uuid :as uuid]
[app.config :as cf]
@ -16,7 +17,6 @@
[app.setup :as-alias setup]
[app.tokens :as tokens]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[lambdaisland.uri :as u]
[promesa.exec :as px]))
@ -108,8 +108,15 @@
(mark-archived! cfg rows)
(count events)))))))
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::db/pool ::setup/props ::http/client]))
(def ^:private schema:handler-params
[:map
::db/pool
::setup/props
::http/client])
(defmethod ig/assert-key ::handler
[_ params]
(assert (sm/valid? schema:handler-params params) "valid params expected for handler"))
(defmethod ig/init-key ::handler
[_ cfg]

6
backend/src/app/loggers/audit/gc_task.clj
View File

@ -8,7 +8,6 @@
(:require
[app.common.logging :as l]
[app.db :as db]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(def ^:private sql:clean-archived
@ -22,8 +21,9 @@
(l/debug :hint "delete archived audit log entries" :deleted result)
result))
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::db/pool]))
(defmethod ig/assert-key ::handler
[_ params]
(assert (db/pool? (::db/pool params)) "valid database pool expected"))
(defmethod ig/init-key ::handler
[_ cfg]

8
backend/src/app/loggers/database.clj
View File

@ -12,7 +12,6 @@
[app.common.logging :as l]
[app.common.pprint :as pp]
[app.common.schema :as sm]
[app.common.spec :as us]
[app.config :as cf]
[app.db :as db]
[clojure.spec.alpha :as s]
@ -38,7 +37,7 @@
(defn record->report
[{:keys [::l/context ::l/message ::l/props ::l/logger ::l/level ::l/cause] :as record}]
(us/assert! ::l/record record)
(assert (l/valid-record? record) "expectd valid log record")
(if (or (instance? java.util.concurrent.CompletionException cause)
(instance? java.util.concurrent.ExecutionException cause))
(-> record
@ -91,8 +90,9 @@
(catch Throwable cause
(l/warn :hint "unexpected exception on database error logger" :cause cause))))
(defmethod ig/pre-init-spec ::reporter [_]
(s/keys :req [::db/pool]))
(defmethod ig/assert-key ::reporter
[_ params]
(assert (db/pool? (::db/pool params)) "expect valid database pool"))
(defmethod ig/init-key ::reporter
[_ cfg]

9
backend/src/app/loggers/mattermost.clj
View File

@ -9,12 +9,10 @@
(:require
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.config :as cf]
[app.http.client :as http]
[app.loggers.database :as ldb]
[app.util.json :as json]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[promesa.exec :as px]
[promesa.exec.csp :as sp]))
@ -54,7 +52,7 @@
(defn record->report
[{:keys [::l/context ::l/id ::l/cause] :as record}]
(us/assert! ::l/record record)
(assert (l/valid-record? record) "expectd valid log record")
{:id id
:tenant (cf/get :tenant)
:host (cf/get :host)
@ -75,8 +73,9 @@
(catch Throwable cause
(l/warn :hint "unhandled error" :cause cause)))))
(defmethod ig/pre-init-spec ::reporter [_]
(s/keys :req [::http/client]))
(defmethod ig/assert-key ::reporter
[_ params]
(assert (http/client? (::http/client params)) "expect valid http client"))
(defmethod ig/init-key ::reporter
[_ cfg]

19
backend/src/app/loggers/webhooks.clj
View File

@ -18,7 +18,6 @@
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.data.json :as json]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[integrant.core :as ig]))
@ -60,8 +59,10 @@
(some->> (:project-id props) (lookup-webhooks-by-project pool))
(some->> (:file-id props) (lookup-webhooks-by-file pool))))
(defmethod ig/pre-init-spec ::process-event-handler [_]
(s/keys :req [::db/pool]))
(defmethod ig/assert-key ::process-event-handler
[_ params]
(assert (db/pool? (::db/pool params)) "expect valid database pool")
(assert (http/client? (::http/client params)) "expect valid http client"))
(defmethod ig/init-key ::process-event-handler
[_ cfg]
@ -87,12 +88,14 @@
{:key-fn str/camel
:indent true})
(defmethod ig/pre-init-spec ::run-webhook-handler [_]
(s/keys :req [::http/client ::db/pool]))
(defmethod ig/assert-key ::run-webhook-handler
[_ params]
(assert (db/pool? (::db/pool params)) "expect valid database pool")
(assert (http/client? (::http/client params)) "expect valid http client"))
(defmethod ig/prep-key ::run-webhook-handler
[_ cfg]
(merge {::max-errors 3} (d/without-nils cfg)))
(defmethod ig/expand-key ::run-webhook-handler
[k v]
{k (merge {::max-errors 3} (d/without-nils v))})
(defmethod ig/init-key ::run-webhook-handler
[_ {:keys [::db/pool ::max-errors] :as cfg}]

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

@ -9,6 +9,7 @@
[app.auth.ldap :as-alias ldap]
[app.auth.oidc :as-alias oidc]
[app.auth.oidc.providers :as-alias oidc.providers]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.config :as cf]
[app.db :as-alias db]
@ -28,6 +29,7 @@
[app.msgbus :as-alias mbus]
[app.redis :as-alias rds]
[app.rpc :as-alias rpc]
[app.rpc.climit :as-alias climit]
[app.rpc.doc :as-alias rpc.doc]
[app.setup :as-alias setup]
[app.srepl :as-alias srepl]
@ -169,7 +171,7 @@
{::db/uri (cf/get :database-uri)
::db/username (cf/get :database-username)
::db/password (cf/get :database-password)
::db/read-only? (cf/get :database-readonly false)
::db/read-only (cf/get :database-readonly false)
::db/min-size (cf/get :database-min-pool-size 0)
::db/max-size (cf/get :database-max-pool-size 60)
::mtx/metrics (ig/ref ::mtx/metrics)}
@ -245,7 +247,7 @@
:base-dn (cf/get :ldap-base-dn)
:bind-dn (cf/get :ldap-bind-dn)
:bind-password (cf/get :ldap-bind-password)
:enabled? (contains? cf/flags :login-with-ldap)}
:enabled (contains? cf/flags :login-with-ldap)}
::oidc.providers/google
{}
@ -302,9 +304,11 @@
::http.assets/cache-max-agesignature-max-age (dt/duration {:hours 24 :minutes 5})
::sto/storage (ig/ref ::sto/storage)}
:app.rpc/climit
{::mtx/metrics (ig/ref ::mtx/metrics)
::wrk/executor (ig/ref ::wrk/executor)}
::rpc/climit
{::mtx/metrics (ig/ref ::mtx/metrics)
::wrk/executor (ig/ref ::wrk/executor)
::climit/config (cf/get :rpc-climit-config)
::climit/enabled (contains? cf/flags :rpc-climit)}
:app.rpc/rlimit
{::wrk/executor (ig/ref ::wrk/executor)}
@ -319,7 +323,6 @@
::mtx/metrics (ig/ref ::mtx/metrics)
::mbus/msgbus (ig/ref ::mbus/msgbus)
::rds/redis (ig/ref ::rds/redis)
::svgo/optimizer (ig/ref ::svgo/optimizer)
::rpc/climit (ig/ref ::rpc/climit)
::rpc/rlimit (ig/ref ::rpc/rlimit)
@ -330,7 +333,7 @@
::email/whitelist (ig/ref ::email/whitelist)}
:app.rpc.doc/routes
{:methods (ig/ref :app.rpc/methods)}
{:app.rpc/methods (ig/ref :app.rpc/methods)}
:app.rpc/routes
{::rpc/methods (ig/ref :app.rpc/methods)
@ -379,8 +382,7 @@
::email/default-from (cf/get :smtp-default-from)}
::email/handler
{::email/sendmail (ig/ref ::email/sendmail)
::mtx/metrics (ig/ref ::mtx/metrics)}
{::email/sendmail (ig/ref ::email/sendmail)}
:app.tasks.tasks-gc/handler
{::db/pool (ig/ref ::db/pool)}
@ -430,9 +432,6 @@
;; module requires the migrations to run before initialize.
::migrations (ig/ref :app.migrations/migrations)}
::svgo/optimizer
{}
:app.loggers.audit.archive-task/handler
{::setup/props (ig/ref ::setup/props)
::db/pool (ig/ref ::db/pool)
@ -488,10 +487,7 @@
{::wrk/registry (ig/ref ::wrk/registry)
::db/pool (ig/ref ::db/pool)
::wrk/entries
[{:cron #app/cron "0 0 * * * ?" ;; hourly
:task :file-xlog-gc}
{:cron #app/cron "0 0 0 * * ?" ;; daily
[{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :session-gc}
{:cron #app/cron "0 0 0 * * ?" ;; daily
@ -523,11 +519,13 @@
::wrk/dispatcher
{::rds/redis (ig/ref ::rds/redis)
::mtx/metrics (ig/ref ::mtx/metrics)
::db/pool (ig/ref ::db/pool)}
::db/pool (ig/ref ::db/pool)
::wrk/tenant (cf/get :tenant)}
[::default ::wrk/runner]
{::wrk/parallelism (cf/get ::worker-default-parallelism 1)
::wrk/queue :default
::wrk/tenant (cf/get :tenant)
::rds/redis (ig/ref ::rds/redis)
::wrk/registry (ig/ref ::wrk/registry)
::mtx/metrics (ig/ref ::mtx/metrics)
@ -536,6 +534,7 @@
[::webhook ::wrk/runner]
{::wrk/parallelism (cf/get ::worker-webhook-parallelism 1)
::wrk/queue :webhooks
::wrk/tenant (cf/get :tenant)
::rds/redis (ig/ref ::rds/redis)
::wrk/registry (ig/ref ::wrk/registry)
::mtx/metrics (ig/ref ::mtx/metrics)
@ -553,7 +552,7 @@
(-> system-config
(cond-> (contains? cf/flags :backend-worker)
(merge worker-config))
(ig/prep)
(ig/expand)
(ig/init))))
(l/inf :hint "welcome to penpot"
:flags (str/join "," (map name cf/flags))
@ -566,7 +565,7 @@
(alter-var-root #'system (fn [sys]
(when sys (ig/halt! sys))
(-> config
(ig/prep)
(ig/expand)
(ig/init)))))
(defn stop
@ -622,12 +621,6 @@
(deref p))
(catch Throwable cause
(binding [*out* *err*]
(println "==== ERROR ===="))
(.printStackTrace cause)
(when-let [cause' (ex-cause cause)]
(binding [*out* *err*]
(println "==== CAUSE ===="))
(.printStackTrace cause'))
(ex/print-throwable cause)
(px/sleep 500)
(System/exit -1))))

25
backend/src/app/media.clj
View File

@ -46,14 +46,15 @@
(s/keys :req-un [::path]
:opt-un [::mtype]))
(sm/register! ::upload
[:map {:title "Upload"}
[:filename :string]
[:size ::sm/int]
[:path ::fs/path]
[:mtype {:optional true} :string]
[:headers {:optional true}
[:map-of :string :string]]])
(sm/register!
^{::sm/type ::upload}
[:map {:title "Upload"}
[:filename :string]
[:size ::sm/int]
[:path ::fs/path]
[:mtype {:optional true} :string]
[:headers {:optional true}
[:map-of :string :string]]])
(defn validate-media-type!
([upload] (validate-media-type! upload cm/valid-image-types))
@ -225,7 +226,7 @@
(letfn [(ttf->otf [data]
(let [finput (tmp/tempfile :prefix "penpot.font." :suffix "")
foutput (fs/path (str finput ".otf"))
_ (io/write-to-file! data finput)
_ (io/write* finput data)
res (sh/sh "fontforge" "-lang=ff" "-c"
(str/fmt "Open('%s'); Generate('%s')"
(str finput)
@ -236,7 +237,7 @@
(otf->ttf [data]
(let [finput (tmp/tempfile :prefix "penpot.font." :suffix "")
foutput (fs/path (str finput ".ttf"))
_ (io/write-to-file! data finput)
_ (io/write* finput data)
res (sh/sh "fontforge" "-lang=ff" "-c"
(str/fmt "Open('%s'); Generate('%s')"
(str finput)
@ -250,14 +251,14 @@
;; command.
(let [finput (tmp/tempfile :prefix "penpot.font." :suffix "")
foutput (fs/path (str finput ".woff"))
_ (io/write-to-file! data finput)
_ (io/write* finput data)
res (sh/sh "sfnt2woff" (str finput))]
(when (zero? (:exit res))
foutput)))
(woff->sfnt [data]
(let [finput (tmp/tempfile :prefix "penpot" :suffix "")
_ (io/write-to-file! data finput)
_ (io/write* finput data)
res (sh/sh "woff2sfnt" (str finput)
:out-enc :bytes)]
(when (zero? (:exit res))

96
backend/src/app/metrics.clj
View File

@ -8,9 +8,8 @@
(:refer-clojure :exclude [run!])
(:require
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.metrics.definition :as-alias mdef]
[clojure.spec.alpha :as s]
[integrant.core :as ig])
(:import
io.prometheus.client.CollectorRegistry
@ -34,41 +33,52 @@
(declare create-collector)
(declare handler)
(defprotocol IMetrics
(get-registry [_])
(get-collector [_ id])
(get-handler [_]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; METRICS SERVICE PROVIDER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::mdef/name string?)
(s/def ::mdef/help string?)
(s/def ::mdef/labels (s/every string? :kind vector?))
(s/def ::mdef/type #{:gauge :counter :summary :histogram})
(sm/register!
{:type ::collector
:pred #(instance? SimpleCollector %)
:type-properties
{:title "collector"
:description "An instance of SimpleCollector"}})
(s/def ::mdef/instance
#(instance? SimpleCollector %))
(sm/register!
{:type ::registry
:pred #(instance? CollectorRegistry %)
:type-properties
{:title "Metrics Registry"
:description "Instance of CollectorRegistry"}})
(s/def ::mdef/definition
(s/keys :req [::mdef/name
::mdef/help
::mdef/type]
:opt [::mdef/labels
::mdef/instance]))
(def ^:private schema:definitions
[:map-of :keyword
[:map {:title "definition"}
[::mdef/name :string]
[::mdef/help :string]
[::mdef/type [:enum :gauge :counter :summary :histogram]]
[::mdef/labels {:optional true} [::sm/vec :string]]
[::mdef/instance {:optional true} ::collector]]])
(s/def ::definitions
(s/map-of keyword? ::mdef/definition))
(defn metrics?
[o]
(satisfies? IMetrics o))
(s/def ::registry
#(instance? CollectorRegistry %))
(sm/register!
{:type ::metrics
:pred metrics?})
(s/def ::handler fn?)
(s/def ::metrics
(s/keys :req [::registry
::handler
::definitions]))
(def ^:private valid-definitions?
(sm/validator schema:definitions))
(s/def ::default ::definitions)
(defmethod ig/pre-init-spec ::metrics [_]
(s/keys :req-un [::default]))
(defmethod ig/assert-key ::metrics
[_ {:keys [default]}]
(assert (valid-definitions? default) "expected valid definitions"))
(defmethod ig/init-key ::metrics
[_ cfg]
@ -81,12 +91,14 @@
{}
(:default cfg))]
(us/verify! ::definitions definitions)
{::handler (partial handler registry)
::definitions definitions
::registry registry}))
(reify
IMetrics
(get-handler [_]
(partial handler registry))
(get-collector [_ id]
(get definitions id))
(get-registry [_]
registry))))
(defn- handler
[registry _]
@ -96,17 +108,14 @@
{:headers {"content-type" TextFormat/CONTENT_TYPE_004}
:body (.toString writer)}))
(s/def ::routes vector?)
(defmethod ig/pre-init-spec ::routes [_]
(s/keys :req [::metrics]))
(defmethod ig/assert-key ::routes
[_ {:keys [::metrics]}]
(assert (metrics? metrics) "expected a valid instance for metrics"))
(defmethod ig/init-key ::routes
[_ {:keys [::metrics]}]
(let [registry (::registry metrics)]
["/metrics" {:handler (partial handler registry)
:allowed-methods #{:get}}]))
["/metrics" {:handler (get-handler metrics)
:allowed-methods #{:get}}])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation
@ -126,8 +135,9 @@
(defmulti create-collector ::mdef/type)
(defn run!
[{:keys [::definitions]} & {:keys [id] :as params}]
(when-let [mobj (get definitions id)]
[instance & {:keys [id] :as params}]
(assert (metrics? instance) "expected valid metrics instance")
(when-let [mobj (get-collector instance id)]
(run-collector! mobj params)
true))

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

@ -11,7 +11,6 @@
[app.db :as db]
[app.migrations.clj.migration-0023 :as mg0023]
[app.util.migrations :as mg]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(def migrations
@ -412,7 +411,22 @@
:fn (mg/resource "app/migrations/sql/0129-mod-file-change-table.sql")}
{:name "0130-mod-file-change-table"
:fn (mg/resource "app/migrations/sql/0130-mod-file-change-table.sql")}])
:fn (mg/resource "app/migrations/sql/0130-mod-file-change-table.sql")}
{:name "0131-mod-webhook-table"
:fn (mg/resource "app/migrations/sql/0131-mod-webhook-table.sql")}
{:name "0132-mod-file-change-table"
:fn (mg/resource "app/migrations/sql/0132-mod-file-change-table.sql")}
{:name "0133-mod-file-table"
:fn (mg/resource "app/migrations/sql/0133-mod-file-table.sql")}
{:name "0134-mod-file-change-table"
:fn (mg/resource "app/migrations/sql/0134-mod-file-change-table.sql")}
{:name "0135-mod-team-invitation-table.sql"
:fn (mg/resource "app/migrations/sql/0135-mod-team-invitation-table.sql")}])
(defn apply-migrations!
[pool name migrations]
@ -420,9 +434,9 @@
(mg/setup! conn)
(mg/migrate! conn {:name name :steps migrations})))
(defmethod ig/pre-init-spec ::migrations
[_]
(s/keys :req [::db/pool]))
(defmethod ig/assert-key ::migrations
[_ {:keys [::db/pool]}]
(assert (db/pool? pool) "expected valid pool"))
(defmethod ig/init-key ::migrations
[module {:keys [::db/pool]}]

6
backend/src/app/migrations/sql/0131-mod-webhook-table.sql Normal file
View File

@ -0,0 +1,6 @@
ALTER TABLE webhook
ADD COLUMN profile_id uuid NULL REFERENCES profile (id) ON DELETE SET NULL;
CREATE INDEX webhook__profile_id__idx
ON webhook (profile_id)
WHERE profile_id IS NOT NULL;

2
backend/src/app/migrations/sql/0132-mod-file-change-table.sql Normal file
View File

@ -0,0 +1,2 @@
ALTER TABLE file_change
ADD COLUMN created_by text NOT NULL DEFAULT 'system';

2
backend/src/app/migrations/sql/0133-mod-file-table.sql Normal file
View File

@ -0,0 +1,2 @@
ALTER TABLE file
ADD COLUMN vern int NOT NULL DEFAULT 0;

18
backend/src/app/migrations/sql/0134-mod-file-change-table.sql Normal file
View File

@ -0,0 +1,18 @@
ALTER TABLE file_change
ADD COLUMN updated_at timestamptz DEFAULT now(),
ADD COLUMN deleted_at timestamptz DEFAULT NULL,
ALTER COLUMN created_at SET DEFAULT now();
DROP INDEX file_change__created_at__idx;
DROP INDEX file_change__created_at__label__idx;
DROP INDEX file_change__label__idx;
CREATE INDEX file_change__deleted_at__idx
ON file_change (deleted_at, id)
WHERE deleted_at IS NOT NULL;
CREATE INDEX file_change__system_snapshots__idx
ON file_change (file_id, created_at)
WHERE data IS NOT NULL
AND created_by = 'system'
AND deleted_at IS NULL;

2
backend/src/app/migrations/sql/0135-mod-team-invitation-table.sql Normal file
View File

@ -0,0 +1,2 @@
ALTER TABLE team_invitation
ADD COLUMN created_by uuid NULL REFERENCES profile(id) ON DELETE SET NULL;

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

@ -9,22 +9,27 @@
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.transit :as t]
[app.config :as cfg]
[app.redis :as rds]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px]
[promesa.exec.csp :as sp]))
(set! *warn-on-reflection* true)
(def ^:private prefix (cfg/get :tenant))
(defprotocol IMsgBus
(-sub [_ topics chan])
(-pub [_ topic message])
(-purge [_ chans]))
(defn- prefix-topic
[topic]
(str prefix "." topic))
@ -32,30 +37,33 @@
(def ^:private xform-prefix-topic
(map (fn [obj] (update obj :topic prefix-topic))))
(declare ^:private redis-pub!)
(declare ^:private redis-sub!)
(declare ^:private redis-unsub!)
(declare ^:private start-io-loop!)
(declare ^:private redis-pub)
(declare ^:private redis-sub)
(declare ^:private redis-unsub)
(declare ^:private start-io-loop)
(declare ^:private subscribe-to-topics)
(declare ^:private unsubscribe-channels)
(s/def ::cmd-ch sp/chan?)
(s/def ::rcv-ch sp/chan?)
(s/def ::pub-ch sp/chan?)
(s/def ::state ::us/agent)
(s/def ::pconn ::rds/connection-holder)
(s/def ::sconn ::rds/connection-holder)
(s/def ::msgbus
(s/keys :req [::cmd-ch ::rcv-ch ::pub-ch ::state ::pconn ::sconn ::wrk/executor]))
(defn msgbus?
[o]
(satisfies? IMsgBus o))
(defmethod ig/pre-init-spec ::msgbus [_]
(s/keys :req [::rds/redis ::wrk/executor]))
(sm/register!
{:type ::msgbus
:pred msgbus?})
(defmethod ig/prep-key ::msgbus
[_ cfg]
(-> cfg
(assoc ::buffer-size 128)
(assoc ::timeout (dt/duration {:seconds 30}))))
(defmethod ig/expand-key ::msgbus
[k v]
{k (-> (d/without-nils v)
(assoc ::buffer-size 128)
(assoc ::timeout (dt/duration {:seconds 30})))})
(def ^:private schema:params
[:map ::rds/redis ::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}]
@ -66,46 +74,66 @@
:xf xform-prefix-topic)
state (agent {})
pconn (rds/connect redis :timeout timeout)
pconn (rds/connect redis :type :default :timeout timeout)
sconn (rds/connect redis :type :pubsub :timeout timeout)
msgbus (-> cfg
_ (set-error-handler! state #(l/error :cause % :hint "unexpected error on agent" ::l/sync? true))
_ (set-error-mode! state :continue)
cfg (-> cfg
(assoc ::pconn pconn)
(assoc ::sconn sconn)
(assoc ::cmd-ch cmd-ch)
(assoc ::rcv-ch rcv-ch)
(assoc ::pub-ch pub-ch)
(assoc ::state state)
(assoc ::wrk/executor executor))]
(assoc ::state state))
(set-error-handler! state #(l/error :cause % :hint "unexpected error on agent" ::l/sync? true))
(set-error-mode! state :continue)
io-thr (start-io-loop cfg)]
(assoc msgbus ::io-thr (start-io-loop! msgbus))))
(reify
java.lang.AutoCloseable
(close [_]
(px/interrupt! io-thr)
(sp/close! cmd-ch)
(sp/close! rcv-ch)
(sp/close! pub-ch)
(d/close! pconn)
(d/close! sconn))
IMsgBus
(-sub [_ topics chan]
(l/debug :hint "subscribe" :topics topics :chan (hash chan))
(send-via executor state subscribe-to-topics cfg topics chan))
(-pub [_ topic message]
(let [message (assoc message :topic topic)]
(sp/put! pub-ch {:topic topic :message message})))
(-purge [_ chans]
(l/debug :hint "purge" :chans (count chans))
(send-via executor state unsubscribe-channels cfg chans)))))
(defmethod ig/halt-key! ::msgbus
[_ msgbus]
(px/interrupt! (::io-thr msgbus))
(sp/close! (::cmd-ch msgbus))
(sp/close! (::rcv-ch msgbus))
(sp/close! (::pub-ch msgbus))
(d/close! (::pconn msgbus))
(d/close! (::sconn msgbus)))
[_ instance]
(d/close! instance))
(defn sub!
[{:keys [::state ::wrk/executor] :as cfg} & {:keys [topic topics chan]}]
[instance & {:keys [topic topics chan]}]
(assert (satisfies? IMsgBus instance) "expected valid msgbus instance")
(let [topics (into [] (map prefix-topic) (if topic [topic] topics))]
(l/debug :hint "subscribe" :topics topics :chan (hash chan))
(send-via executor state subscribe-to-topics cfg topics chan)
(-sub instance topics chan)
nil))
(defn pub!
[{::keys [pub-ch]} & {:as params}]
(sp/put! pub-ch params))
[instance & {:keys [topic message]}]
(assert (satisfies? IMsgBus instance) "expected valid msgbus instance")
(-pub instance topic message))
(defn purge!
[{:keys [::state ::wrk/executor] :as msgbus} chans]
(l/debug :hint "purge" :chans (count chans))
(send-via executor state unsubscribe-channels msgbus chans)
[instance chans]
(assert (satisfies? IMsgBus instance) "expected valid msgbus instance")
(assert (every? sp/chan? chans) "expected a seq of chans")
(-purge instance chans)
nil)
;; --- IMPL
@ -118,7 +146,7 @@
(let [nsubs (if (nil? nsubs) #{chan} (conj nsubs chan))]
(when (= 1 (count nsubs))
(l/trace :hint "open subscription" :topic topic ::l/sync? true)
(redis-sub! cfg topic))
(redis-sub cfg topic))
nsubs))
(defn- disj-subscription
@ -129,7 +157,7 @@
(let [nsubs (disj nsubs chan)]
(when (empty? nsubs)
(l/trace :hint "close subscription" :topic topic ::l/sync? true)
(redis-unsub! cfg topic))
(redis-unsub cfg topic))
nsubs))
(defn- subscribe-to-topics
@ -170,7 +198,7 @@
(when-not (sp/offer! rcv-ch val)
(l/warn :msg "dropping message on subscription loop"))))))
(defn- process-input!
(defn- process-input
[{:keys [::state ::wrk/executor] :as cfg} topic message]
(let [chans (get-in @state [:topics topic])]
(when-let [closed (loop [chans (seq chans)
@ -183,9 +211,9 @@
(send-via executor state unsubscribe-channels cfg closed))))
(defn start-io-loop!
(defn start-io-loop
[{:keys [::sconn ::rcv-ch ::pub-ch ::state ::wrk/executor] :as cfg}]
(rds/add-listener! sconn (create-listener rcv-ch))
(rds/add-listener sconn (create-listener rcv-ch))
(px/thread
{:name "penpot/msgbus/io-loop"
@ -209,12 +237,12 @@
(identical? port rcv-ch)
(let [{:keys [topic message]} val]
(process-input! cfg topic message)
(process-input cfg topic message)
(recur))
(identical? port pub-ch)
(do
(redis-pub! cfg val)
(redis-pub cfg val)
(recur)))))
(catch InterruptedException _
@ -230,13 +258,12 @@
(l/debug :hint "io-loop thread terminated")))))
(defn- redis-pub!
(defn- redis-pub
"Publish a message to the redis server. Asynchronous operation,
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)))
(p/await! (rds/publish pconn topic (t/encode message)))
(catch InterruptedException cause
(throw cause))
(catch Throwable cause
@ -244,23 +271,23 @@
:message message
:cause cause))))
(defn- redis-sub!
(defn- redis-sub
"Create redis subscription. Blocking operation, intended to be used
inside an agent."
[{:keys [::sconn] :as cfg} topic]
(try
(rds/subscribe! sconn topic)
(rds/subscribe sconn [topic])
(catch InterruptedException cause
(throw cause))
(catch Throwable cause
(l/trace :hint "exception on subscribing" :topic topic :cause cause))))
(defn- redis-unsub!
(defn- redis-unsub
"Removes redis subscription. Blocking operation, intended to be used
inside an agent."
[{:keys [::sconn] :as cfg} topic]
(try
(rds/unsubscribe! sconn topic)
(rds/unsubscribe sconn [topic])
(catch InterruptedException cause
(throw cause))
(catch Throwable cause

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

@ -6,11 +6,12 @@
(ns app.redis
"The msgbus abstraction implemented using redis as underlying backend."
(:refer-clojure :exclude [eval])
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.metrics :as mtx]
[app.redis.script :as-alias rscript]
[app.util.cache :as cache]
@ -18,13 +19,11 @@
[app.worker :as-alias wrk]
[clojure.core :as c]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px])
(:import
clojure.lang.IDeref
clojure.lang.MapEntry
io.lettuce.core.KeyValue
io.lettuce.core.RedisClient
@ -53,79 +52,24 @@
(set! *warn-on-reflection* true)
(declare initialize-resources)
(declare shutdown-resources)
(declare connect*)
(declare ^:private initialize-resources)
(declare ^:private shutdown-resources)
(declare ^:private impl-eval)
(s/def ::timer
#(instance? Timer %))
(defprotocol IRedis
(-connect [_ options])
(-get-or-connect [_ key options]))
(s/def ::default-connection
#(or (instance? StatefulRedisConnection %)
(and (instance? IDeref %)
(instance? StatefulRedisConnection (deref %)))))
(defprotocol IConnection
(publish [_ topic message])
(rpush [_ key payload])
(blpop [_ timeout keys])
(eval [_ script]))
(s/def ::pubsub-connection
#(or (instance? StatefulRedisPubSubConnection %)
(and (instance? IDeref %)
(instance? StatefulRedisPubSubConnection (deref %)))))
(s/def ::connection
(s/or :default ::default-connection
:pubsub ::pubsub-connection))
(s/def ::connection-holder
(s/keys :req [::connection]))
(s/def ::redis-uri
#(instance? RedisURI %))
(s/def ::resources
#(instance? ClientResources %))
(s/def ::pubsub-listener
#(instance? RedisPubSubListener %))
(s/def ::uri ::us/not-empty-string)
(s/def ::timeout ::dt/duration)
(s/def ::connect? ::us/boolean)
(s/def ::io-threads ::us/integer)
(s/def ::worker-threads ::us/integer)
(s/def ::cache cache/cache?)
(s/def ::redis
(s/keys :req [::resources
::redis-uri
::timer
::mtx/metrics]
:opt [::connection
::cache]))
(defmethod ig/prep-key ::redis
[_ cfg]
(let [cpus (px/get-available-processors)
threads (max 1 (int (* cpus 0.2)))]
(merge {::timeout (dt/duration "10s")
::io-threads (max 3 threads)
::worker-threads (max 3 threads)}
(d/without-nils cfg))))
(defmethod ig/pre-init-spec ::redis [_]
(s/keys :req [::uri ::mtx/metrics]
:opt [::timeout
::connect?
::io-threads
::worker-threads]))
(defmethod ig/init-key ::redis
[_ {:keys [::connect?] :as cfg}]
(let [state (initialize-resources cfg)]
(cond-> state
connect? (assoc ::connection (connect* cfg {})))))
(defmethod ig/halt-key! ::redis
[_ state]
(shutdown-resources state))
(defprotocol IPubSubConnection
(add-listener [_ listener])
(subscribe [_ topics])
(unsubscribe [_ topics]))
(def default-codec
(RedisCodec/of StringCodec/UTF8 ByteArrayCodec/INSTANCE))
@ -133,23 +77,76 @@
(def string-codec
(RedisCodec/of StringCodec/UTF8 StringCodec/UTF8))
(defn- create-cache
[{:keys [::wrk/executor] :as cfg}]
(letfn [(on-remove [key val cause]
(l/trace :hint "evict connection (cache)" :key key :reason cause)
(some-> val d/close!))]
(cache/create :executor executor
:on-remove on-remove
:keepalive "5m")))
(sm/register!
{:type ::connection
:pred #(satisfies? IConnection %)
:type-properties
{:title "connection"
:description "redis connection instance"}})
(sm/register!
{:type ::pubsub-connection
:pred #(satisfies? IPubSubConnection %)
:type-properties
{:title "connection"
:description "redis connection instance"}})
(defn redis?
[o]
(satisfies? IRedis o))
(sm/register!
{:type ::redis
:pred redis?})
(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 (dt/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 ::dt/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 ::connect?] :as cfg}]
(l/info :hint "initialize redis resources"
:uri uri
:io-threads io-threads
:worker-threads worker-threads
:connect? connect?)
[{: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)
@ -158,147 +155,134 @@
(timer ^Timer timer)
(build))
redis-uri (RedisURI/create ^String uri)
cfg (-> cfg
(assoc ::resources resources)
(assoc ::timer timer)
(assoc ::redis-uri redis-uri))]
redis-uri (RedisURI/create ^String (str uri))
(assoc cfg ::cache (create-cache cfg))))
shutdown (fn [client conn]
(ex/ignoring (.close ^StatefulConnection conn))
(ex/ignoring (.close ^RedisClient client))
(l/trc :hint "disconnect" :hid (hash client)))
(defn- shutdown-resources
[{:keys [::resources ::cache ::timer]}]
(cache/invalidate! cache)
on-remove (fn [key val cause]
(l/trace :hint "evict connection (cache)" :key key :reason cause)
(some-> val d/close!))
(when resources
(.shutdown ^ClientResources resources))
(when timer
(.stop ^Timer timer)))
(defn connect*
[{:keys [::resources ::redis-uri] :as state}
{:keys [timeout codec type]
:or {codec default-codec type :default}}]
(us/assert! ::resources resources)
(let [client (RedisClient/create ^ClientResources resources ^RedisURI redis-uri)
timeout (or timeout (::timeout state))
conn (case type
:default (.connect ^RedisClient client ^RedisCodec codec)
:pubsub (.connectPubSub ^RedisClient client ^RedisCodec codec))]
(l/trc :hint "connect" :hid (hash client))
(.setTimeout ^StatefulConnection conn ^Duration timeout)
cache (cache/create :executor executor
:on-remove on-remove
:keepalive "5m")]
(reify
IDeref
(deref [_] conn)
AutoCloseable
java.lang.AutoCloseable
(close [_]
(ex/ignoring (.close ^StatefulConnection conn))
(ex/ignoring (.shutdown ^RedisClient client))
(l/trc :hint "disconnect" :hid (hash client))))))
(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]
(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))))))
(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))))))
AutoCloseable
(close [_] (shutdown client 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")
(let [pcomm (.async ^StatefulRedisConnection conn)]
(.publish ^RedisAsyncCommands pcomm ^String topic ^bytes message)))
(rpush [_ key payload]
(assert (or (and (vector? payload)
(every? bytes? payload))
(bytes? payload)))
(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)]
(when xs
(aset ^"[[B" vals i ^bytes (first xs))
(recur (inc i) (next xs))))
(.rpush ^RedisCommands cmd
^String key
^"[[B" vals))
(catch RedisCommandInterruptedException cause
(throw (InterruptedException. (ex-message cause))))))
(blpop [_ timeout keys]
(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
^double timeout
^"[Ljava.lang.String;" keys)]
(MapEntry/create
(.getKey ^KeyValue res)
(.getValue ^KeyValue res))))
(catch RedisCommandInterruptedException cause
(throw (InterruptedException. (ex-message cause))))))
(eval [_ script]
(assert (valid-script? script) "expected valid script")
(impl-eval conn metrics script))
AutoCloseable
(close [_] (shutdown client conn))))))))))
(defn connect
[state & {:as opts}]
(let [connection (connect* state opts)]
(-> state
(assoc ::connection connection)
(dissoc ::cache)
(vary-meta assoc `d/close! (fn [_] (d/close! connection))))))
[instance & {:as opts}]
(assert (satisfies? IRedis instance) "expected valid redis instance")
(-connect instance opts))
(defn get-or-connect
[{:keys [::cache] :as state} key options]
(us/assert! ::redis state)
(let [create (fn [_] (connect* state options))
connection (cache/get cache key create)]
(-> state
(dissoc ::cache)
(assoc ::connection connection))))
(defn add-listener!
[{:keys [::connection] :as conn} listener]
(us/assert! ::pubsub-connection connection)
(us/assert! ::pubsub-listener listener)
(.addListener ^StatefulRedisPubSubConnection @connection
^RedisPubSubListener listener)
conn)
(defn publish!
[{:keys [::connection]} topic message]
(us/assert! ::us/string topic)
(us/assert! ::us/bytes message)
(us/assert! ::default-connection connection)
(let [pcomm (.async ^StatefulRedisConnection @connection)]
(.publish ^RedisAsyncCommands pcomm ^String topic ^bytes message)))
(defn subscribe!
"Blocking operation, intended to be used on a thread/agent thread."
[{:keys [::connection]} & topics]
(us/assert! ::pubsub-connection connection)
(try
(let [topics (into-array String (map str topics))
cmd (.sync ^StatefulRedisPubSubConnection @connection)]
(.subscribe ^RedisPubSubCommands cmd topics))
(catch RedisCommandInterruptedException cause
(throw (InterruptedException. (ex-message cause))))))
(defn unsubscribe!
"Blocking operation, intended to be used on a thread/agent thread."
[{:keys [::connection]} & topics]
(us/assert! ::pubsub-connection connection)
(try
(let [topics (into-array String (map str topics))
cmd (.sync ^StatefulRedisPubSubConnection @connection)]
(.unsubscribe ^RedisPubSubCommands cmd topics))
(catch RedisCommandInterruptedException cause
(throw (InterruptedException. (ex-message cause))))))
(defn rpush!
[{:keys [::connection]} key payload]
(us/assert! ::default-connection connection)
(us/assert! (or (and (vector? payload)
(every? bytes? payload))
(bytes? payload)))
(try
(let [cmd (.sync ^StatefulRedisConnection @connection)
data (if (vector? payload) payload [payload])
vals (make-array (. Class (forName "[B")) (count data))]
(loop [i 0 xs (seq data)]
(when xs
(aset ^"[[B" vals i ^bytes (first xs))
(recur (inc i) (next xs))))
(.rpush ^RedisCommands cmd
^String key
^"[[B" vals))
(catch RedisCommandInterruptedException cause
(throw (InterruptedException. (ex-message cause))))))
(defn blpop!
[{:keys [::connection]} timeout & keys]
(us/assert! ::default-connection connection)
(try
(let [keys (into-array Object (map str keys))
cmd (.sync ^StatefulRedisConnection @connection)
timeout (/ (double (inst-ms timeout)) 1000.0)]
(when-let [res (.blpop ^RedisCommands cmd
^double timeout
^"[Ljava.lang.String;" keys)]
(MapEntry/create
(.getKey ^KeyValue res)
(.getValue ^KeyValue res))))
(catch RedisCommandInterruptedException cause
(throw (InterruptedException. (ex-message cause))))))
(defn open?
[{:keys [::connection]}]
(us/assert! ::pubsub-connection connection)
(.isOpen ^StatefulConnection @connection))
[instance key & {:as opts}]
(assert (satisfies? IRedis instance) "expected valid redis instance")
(-get-or-connect instance key opts))
(defn pubsub-listener
[& {:keys [on-message on-subscribe on-unsubscribe]}]
@ -328,26 +312,10 @@
(on-unsubscribe nil topic count)))))
(def ^:private scripts-cache (atom {}))
(def noop-fn (constantly nil))
(s/def ::rscript/name qualified-keyword?)
(s/def ::rscript/path ::us/not-empty-string)
(s/def ::rscript/keys (s/every any? :kind vector?))
(s/def ::rscript/vals (s/every any? :kind vector?))
(s/def ::rscript/script
(s/keys :req [::rscript/name
::rscript/path]
:opt [::rscript/keys
::rscript/vals]))
(defn eval!
[{:keys [::mtx/metrics ::connection] :as state} script]
(us/assert! ::redis state)
(us/assert! ::default-connection connection)
(us/assert! ::rscript/script script)
(let [cmd (.async ^StatefulRedisConnection @connection)
(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)]

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

@ -36,8 +36,8 @@
[cuerdas.core :as str]
[integrant.core :as ig]
[promesa.core :as p]
[ring.request :as rreq]
[ring.response :as rres]))
[yetti.request :as yreq]
[yetti.response :as yres]))
(s/def ::profile-id ::us/uuid)
@ -64,16 +64,16 @@
response (if (fn? result)
(result request)
(let [result (rph/unwrap result)]
{::rres/status (::http/status mdata 200)
::rres/headers (::http/headers mdata {})
::rres/body result}))]
{::yres/status (::http/status mdata 200)
::yres/headers (::http/headers mdata {})
::yres/body result}))]
(-> response
(handle-response-transformation request mdata)
(handle-before-comple-hook mdata))))
(defn get-external-session-id
[request]
(when-let [session-id (rreq/get-header request "x-external-session-id")]
(when-let [session-id (yreq/get-header request "x-external-session-id")]
(when-not (or (> (count session-id) 256)
(= session-id "null")
(str/blank? session-id))
@ -81,7 +81,7 @@
(defn- get-external-event-origin
[request]
(when-let [origin (rreq/get-header request "x-event-origin")]
(when-let [origin (yreq/get-header request "x-event-origin")]
(when-not (or (> (count origin) 256)
(= origin "null")
(str/blank? origin))
@ -92,7 +92,7 @@
internal async flow into ring async flow."
[methods {:keys [params path-params method] :as request}]
(let [handler-name (:type path-params)
etag (rreq/get-header request "if-none-match")
etag (yreq/get-header request "if-none-match")
profile-id (or (::session/profile-id request)
(::actoken/profile-id request))
@ -250,39 +250,49 @@
'app.rpc.commands.projects
'app.rpc.commands.search
'app.rpc.commands.teams
'app.rpc.commands.teams-invitations
'app.rpc.commands.verify-token
'app.rpc.commands.viewer
'app.rpc.commands.webhooks)
(map (partial process-method cfg))
(into {}))))
(defmethod ig/pre-init-spec ::methods [_]
(s/keys :req [::session/manager
::http.client/client
::db/pool
::mbus/msgbus
::ldap/provider
::sto/storage
::mtx/metrics
::setup/props]
:opt [::climit
::rlimit]))
(def ^:private schema:methods-params
[:map {:title "methods-params"}
::session/manager
::http.client/client
::db/pool
::mbus/msgbus
::sto/storage
::mtx/metrics
[::ldap/provider [:maybe ::ldap/provider]]
[::climit [:maybe ::climit]]
[::rlimit [:maybe ::rlimit]]
::setup/props])
(defmethod ig/assert-key ::methods
[_ params]
(assert (sm/check schema:methods-params params)))
(defmethod ig/init-key ::methods
[_ cfg]
(let [cfg (d/without-nils cfg)]
(resolve-command-methods cfg)))
(s/def ::methods
(s/map-of keyword? (s/tuple map? fn?)))
(def ^:private schema:methods
[:map-of :keyword [:tuple :map ::sm/fn]])
(s/def ::routes vector?)
(sm/register! ::methods schema:methods)
(defmethod ig/pre-init-spec ::routes [_]
(s/keys :req [::methods
::db/pool
::setup/props
::session/manager]))
(def ^:private valid-methods?
(sm/validator schema:methods))
(defmethod ig/assert-key ::routes
[_ params]
(assert (db/pool? (::db/pool params)) "expect valid database pool")
(assert (some? (::setup/props params)))
(assert (session/manager? (::session/manager params)) "expect valid session manager")
(assert (valid-methods? (::methods params)) "expect valid methods map"))
(defmethod ig/init-key ::routes
[_ {:keys [::methods] :as cfg}]

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

@ -10,18 +10,15 @@
(:require
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.config :as cf]
[app.common.schema :as sm]
[app.metrics :as mtx]
[app.rpc :as-alias rpc]
[app.rpc.climit.config :as-alias config]
[app.util.cache :as cache]
[app.util.services :as-alias sv]
[app.util.time :as dt]
[app.worker :as-alias wrk]
[clojure.edn :as edn]
[clojure.set :as set]
[clojure.spec.alpha :as s]
[datoteka.fs :as fs]
[integrant.core :as ig]
[promesa.exec :as px]
@ -32,6 +29,62 @@
(set! *warn-on-reflection* true)
(declare ^:private impl-invoke)
(declare ^:private id->str)
(declare ^:private create-cache)
(defprotocol IConcurrencyLimiter
(^:private get-config [_ limit-id] "get a config for a key")
(^:private invoke [_ config handler] "invoke a handler for a config"))
(sm/register!
{:type ::rpc/climit
:pred #(satisfies? IConcurrencyLimiter %)})
(def ^:private schema:config
[:map-of :keyword
[:map
[::id {:optional true} :keyword]
[::key {:optional true} :any]
[::label {:optional true} ::sm/text]
[::params {:optional true} :map]
[::permits {:optional true} ::sm/int]
[::queue {:optional true} ::sm/int]
[::timeout {:optional true} ::sm/int]]])
(def ^:private check-config
(sm/check-fn schema:config))
(def ^:private schema:climit-params
[:map
::mtx/metrics
::wrk/executor
[::enabled {:optional true} ::sm/boolean]
[::config {:optional true} ::fs/path]])
(defmethod ig/assert-key ::rpc/climit
[_ params]
(assert (sm/valid? schema:climit-params params)))
(defmethod ig/init-key ::rpc/climit
[_ {:keys [::config ::enabled ::mtx/metrics] :as cfg}]
(when enabled
(when-let [params (some->> config slurp edn/read-string check-config)]
(l/inf :hint "initializing concurrency limit" :config (str config))
(let [params (reduce-kv (fn [result k v]
(assoc result k (assoc v ::id k)))
params
params)
cache (create-cache cfg)]
(reify
IConcurrencyLimiter
(get-config [_ id]
(get params id))
(invoke [_ config handler]
(impl-invoke metrics cache config handler)))))))
(defn- id->str
([id]
(-> (str id)
@ -41,59 +94,23 @@
(str (-> (str id) (subs 1)) "/" key)
(id->str id))))
(defn- create-cache
[{:keys [::wrk/executor]}]
(letfn [(on-remove [key _ cause]
(let [[id skey] key]
(l/trc :hint "disposed" :id (id->str id skey) :reason (str cause))))]
(cache/create :executor executor
:on-remove on-remove
:keepalive "5m")))
(s/def ::config/permits ::us/integer)
(s/def ::config/queue ::us/integer)
(s/def ::config/timeout ::us/integer)
(s/def ::config
(s/map-of keyword?
(s/keys :opt-un [::config/permits
::config/queue
::config/timeout])))
(defmethod ig/prep-key ::rpc/climit
[_ cfg]
(assoc cfg ::path (cf/get :rpc-climit-config)))
(s/def ::path ::fs/path)
(defmethod ig/pre-init-spec ::rpc/climit [_]
(s/keys :req [::mtx/metrics ::wrk/executor ::path]))
(defmethod ig/init-key ::rpc/climit
[_ {:keys [::path ::mtx/metrics] :as cfg}]
(when (contains? cf/flags :rpc-climit)
(when-let [params (some->> path slurp edn/read-string)]
(l/inf :hint "initializing concurrency limit" :config (str path))
(us/verify! ::config params)
{::cache (create-cache cfg)
::config params
::mtx/metrics metrics})))
(s/def ::cache cache/cache?)
(s/def ::instance
(s/keys :req [::cache ::config]))
(s/def ::rpc/climit
(s/nilable ::instance))
(defn- create-limiter
[config [id skey]]
(l/trc :hint "created" :id (id->str id skey))
[config id]
(l/trc :hint "created" :id id)
(pbh/create :permits (or (:permits config) (:concurrency config))
:queue (or (:queue config) (:queue-size config))
:timeout (:timeout config)
:type :semaphore))
(defn- create-cache
[{:keys [::wrk/executor]}]
(letfn [(on-remove [id _ cause]
(l/trc :hint "disposed" :id id :reason (str cause)))]
(cache/create :executor executor
:on-remove on-remove
:keepalive "5m")))
(defn measure!
(defn- measure
[metrics mlabels stats elapsed]
(let [mpermits (:max-permits stats)
permits (:permits stats)
@ -117,8 +134,14 @@
:val (inst-ms elapsed)
:labels mlabels))))
(defn log!
[action req-id stats limit-id limit-label params elapsed]
(defn- prepare-params-for-debug
[params]
(-> (select-keys params [::rpc/profile-id :file-id :profile-id])
(set/rename-keys {::rpc/profile-id :profile-id})
(update-vals str)))
(defn- log
[action req-id stats limit-id limit-label limit-params elapsed]
(let [mpermits (:max-permits stats)
queue (:queue stats)
queue (- queue mpermits)
@ -132,37 +155,42 @@
:label limit-label
:queue queue
:elapsed (some-> elapsed dt/format-duration)
:params (-> (select-keys params [::rpc/profile-id :file-id :profile-id])
(set/rename-keys {::rpc/profile-id :profile-id})
(update-vals str)))))
:params @limit-params)))
(def ^:private idseq (AtomicLong. 0))
(defn- invoke
[limiter metrics limit-id limit-key limit-label handler params]
(let [tpoint (dt/tpoint)
mlabels (into-array String [(id->str limit-id)])
limit-id (id->str limit-id limit-key)
stats (pbh/get-stats limiter)
req-id (.incrementAndGet ^AtomicLong idseq)]
(defn- impl-invoke
[metrics cache config handler]
(let [limit-id (::id config)
limit-key (::key config)
limit-label (::label config)
limit-params (delay
(prepare-params-for-debug
(::params config)))
mlabels (into-array String [(id->str limit-id)])
limit-id (id->str limit-id limit-key)
limiter (cache/get cache limit-id (partial create-limiter config))
tpoint (dt/tpoint)
req-id (.incrementAndGet ^AtomicLong idseq)]
(try
(measure! metrics mlabels stats nil)
(log! "enqueued" req-id stats limit-id limit-label params nil)
(let [stats (pbh/get-stats limiter)]
(measure metrics mlabels stats nil)
(log "enqueued" req-id stats limit-id limit-label limit-params nil))
(px/invoke! limiter (fn []
(let [elapsed (tpoint)
stats (pbh/get-stats limiter)]
(measure! metrics mlabels stats elapsed)
(log! "acquired" req-id stats limit-id limit-label params elapsed)
(handler params))))
(measure metrics mlabels stats elapsed)
(log "acquired" req-id stats limit-id limit-label limit-params elapsed)
(handler))))
(catch ExceptionInfo cause
(let [{:keys [type code]} (ex-data cause)]
(if (= :bulkhead-error type)
(let [elapsed (tpoint)]
(log! "rejected" req-id stats limit-id limit-label params elapsed)
(let [elapsed (tpoint)
stats (pbh/get-stats limiter)]
(log "rejected" req-id stats limit-id limit-label limit-params elapsed)
(ex/raise :type :concurrency-limit
:code code
:hint "concurrency limit reached"
@ -173,8 +201,8 @@
(let [elapsed (tpoint)
stats (pbh/get-stats limiter)]
(measure! metrics mlabels stats nil)
(log! "finished" req-id stats limit-id limit-label params elapsed))))))
(measure metrics mlabels stats nil)
(log "finished" req-id stats limit-id limit-label limit-params elapsed))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MIDDLEWARE
@ -204,71 +232,70 @@
(throw (IllegalArgumentException. "unable to normalize limit")))))
(defn wrap
[{:keys [::rpc/climit ::mtx/metrics]} handler mdata]
(let [cache (::cache climit)
config (::config climit)
label (::sv/name mdata)]
[cfg handler {label ::sv/name :as mdata}]
(if-let [climit (::rpc/climit cfg)]
(reduce (fn [handler [limit-id key-fn]]
(if-let [config (get-config climit limit-id)]
(let [key-fn (or key-fn noop-fn)]
(l/trc :hint "instrumenting method"
:method label
:limit (id->str limit-id)
:timeout (:timeout config)
:permits (:permits config)
:queue (:queue config)
:keyed (not= key-fn nil))
(if climit
(reduce (fn [handler [limit-id key-fn]]
(if-let [config (get config limit-id)]
(let [key-fn (or key-fn noop-fn)]
(l/trc :hint "instrumenting method"
:method label
:limit (id->str limit-id)
:timeout (:timeout config)
:permits (:permits config)
:queue (:queue config)
:keyed (not= key-fn noop-fn))
(if (and (= key-fn ::rpc/profile-id)
(false? (::rpc/auth mdata true)))
(if (and (= key-fn ::rpc/profile-id)
(false? (::rpc/auth mdata true)))
;; We don't enforce by-profile limit on methods that does
;; not require authentication
handler
;; We don't enforce by-profile limit on methods that does
;; not require authentication
handler
(fn [cfg params]
(let [config (-> config
(assoc ::key (key-fn params))
(assoc ::label label)
;; NOTE: only used for debugging output
(assoc ::params params))]
(invoke climit config (partial handler cfg params))))))
(fn [cfg params]
(let [limit-key (key-fn params)
cache-key [limit-id limit-key]
limiter (cache/get cache cache-key (partial create-limiter config))
handler (partial handler cfg)]
(invoke limiter metrics limit-id limit-key label handler params)))))
(do
(l/wrn :hint "no config found for specified queue" :id (id->str limit-id))
handler)))
handler
(concat global-limits (get-limits mdata)))
(do
(l/wrn :hint "no config found for specified queue" :id (id->str limit-id))
handler)))
handler
(concat global-limits (get-limits mdata)))
handler)))
handler))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- build-exec-chain
[{:keys [::label ::rpc/climit ::mtx/metrics] :as cfg} f]
(let [config (get climit ::config)
cache (get climit ::cache)]
(reduce (fn [handler [limit-id limit-key :as ckey]]
(if-let [config (get config limit-id)]
[{:keys [::label ::rpc/climit] :as cfg} f]
(reduce (fn [handler [limit-id limit-key]]
(if-let [config (get-config climit limit-id)]
(let [config (-> config
(assoc ::key limit-key)
(assoc ::label label))]
(fn [cfg params]
(let [limiter (cache/get cache ckey (partial create-limiter config))
handler (partial handler cfg)]
(invoke limiter metrics limit-id limit-key label handler params)))
(do
(l/wrn :hint "config not found" :label label :id limit-id)
f)))
f
(get-limits cfg))))
(let [config (assoc config ::params params)]
(invoke climit config (partial handler cfg params)))))
(do
(l/wrn :hint "config not found" :label label :id limit-id)
f)))
f
(get-limits cfg)))
(defn invoke!
"Run a function in context of climit.
Intended to be used in virtual threads."
[{:keys [::executor] :as cfg} f params]
(let [f (if (some? executor)
(fn [cfg params] (px/await! (px/submit! executor (fn [] (f cfg params)))))
f)
f (build-exec-chain cfg f)]
[{:keys [::executor ::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))
f)]
(f cfg params)))

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

@ -383,7 +383,9 @@
invitation (when-let [token (:invitation-token params)]
(tokens/verify (::setup/props cfg) {:token token :iss :team-invitation}))
props (audit/profile->props profile)
props (-> (audit/profile->props profile)
(assoc :from-invitation (some? invitation)))
create-welcome-file-when-needed
(fn []

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

@ -8,6 +8,7 @@
(:refer-clojure :exclude [assert])
(:require
[app.binfile.v1 :as bf.v1]
[app.binfile.v3 :as bf.v3]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.db :as db]
@ -24,7 +25,7 @@
[app.util.time :as dt]
[app.worker :as-alias wrk]
[promesa.exec :as px]
[ring.response :as rres]))
[yetti.response :as yres]))
(set! *warn-on-reflection* true)
@ -35,51 +36,103 @@
[:map {:title "export-binfile"}
[:name [:string {:max 250}]]
[:file-id ::sm/uuid]
[:include-libraries :boolean]
[:embed-assets :boolean]])
[:version {:optional true} ::sm/int]
[:include-libraries ::sm/boolean]
[:embed-assets ::sm/boolean]])
(defn stream-export-v1
[cfg {:keys [file-id include-libraries embed-assets] :as params}]
(yres/stream-body
(fn [_ output-stream]
(try
(-> cfg
(assoc ::bf.v1/ids #{file-id})
(assoc ::bf.v1/embed-assets embed-assets)
(assoc ::bf.v1/include-libraries include-libraries)
(bf.v1/export-files! output-stream))
(catch Throwable cause
(l/err :hint "exception on exporting file"
:file-id (str file-id)
:cause cause))))))
(defn stream-export-v3
[cfg {:keys [file-id include-libraries embed-assets] :as params}]
(yres/stream-body
(fn [_ output-stream]
(try
(-> cfg
(assoc ::bf.v3/ids #{file-id})
(assoc ::bf.v3/embed-assets embed-assets)
(assoc ::bf.v3/include-libraries include-libraries)
(bf.v3/export-files! output-stream))
(catch Throwable cause
(l/err :hint "exception on exporting file"
:file-id (str file-id)
:cause cause))))))
(sv/defmethod ::export-binfile
"Export a penpot file in a binary format."
{::doc/added "1.15"
::webhooks/event? true
::sm/result schema:export-binfile}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id include-libraries embed-assets] :as params}]
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id version file-id] :as params}]
(files/check-read-permissions! pool profile-id file-id)
(fn [_]
{::rres/status 200
::rres/headers {"content-type" "application/octet-stream"}
::rres/body (reify rres/StreamableResponseBody
(-write-body-to-stream [_ _ output-stream]
(try
(-> cfg
(assoc ::bf.v1/ids #{file-id})
(assoc ::bf.v1/embed-assets embed-assets)
(assoc ::bf.v1/include-libraries include-libraries)
(bf.v1/export-files! output-stream))
(catch Throwable cause
(l/err :hint "exception on exporting file"
:file-id (str file-id)
:cause cause)))))}))
(let [version (or version 1)
body (case (int version)
1 (stream-export-v1 cfg params)
2 (throw (ex-info "not-implemented" {}))
3 (stream-export-v3 cfg params))]
{::yres/status 200
::yres/headers {"content-type" "application/octet-stream"}
::yres/body body})))
;; --- Command: import-binfile
(defn- import-binfile-v1
[{:keys [::wrk/executor] :as cfg} {:keys [project-id profile-id name file]}]
(let [cfg (-> cfg
(assoc ::bf.v1/project-id project-id)
(assoc ::bf.v1/profile-id profile-id)
(assoc ::bf.v1/name name)
(assoc ::bf.v1/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.
(px/invoke! executor (partial bf.v1/import-files! cfg))))
(defn- import-binfile-v3
[{:keys [::wrk/executor] :as cfg} {:keys [project-id profile-id name file]}]
(let [cfg (-> cfg
(assoc ::bf.v3/project-id project-id)
(assoc ::bf.v3/profile-id profile-id)
(assoc ::bf.v3/name name)
(assoc ::bf.v3/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.
(px/invoke! executor (partial bf.v3/import-files! cfg))))
(defn- import-binfile
[{:keys [::wrk/executor ::bf.v1/project-id ::db/pool] :as cfg} input]
;; NOTE: the importation process performs some operations that
;; are not very friendly with virtual threads, and for avoid
;; unexpected blocking of other concurrent operations we
;; dispatch that operation to a dedicated executor.
(let [result (px/invoke! executor (partial bf.v1/import-files! cfg input))]
[{:keys [::db/pool] :as cfg} {:keys [project-id version] :as params}]
(let [result (case (int version)
1 (import-binfile-v1 cfg params)
3 (import-binfile-v3 cfg params))]
(db/update! pool :project
{:modified-at (dt/now)}
{:id project-id})
result))
(def ^:private
schema:import-binfile
(def ^:private schema:import-binfile
[:map {:title "import-binfile"}
[:name [:string {:max 250}]]
[:name [:or [:string {:max 250}]
[:map-of ::sm/uuid [:string {:max 250}]]]]
[:project-id ::sm/uuid]
[:version {:optional true} ::sm/int]
[:file ::media/upload]])
(sv/defmethod ::import-binfile
@ -88,12 +141,11 @@
::webhooks/event? true
::sse/stream? true
::sm/params schema:import-binfile}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id name project-id file] :as params}]
(projects/check-read-permissions! pool profile-id project-id)
(let [cfg (-> cfg
(assoc ::bf.v1/project-id project-id)
(assoc ::bf.v1/profile-id profile-id)
(assoc ::bf.v1/name name))]
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id project-id version] :as params}]
(projects/check-edition-permissions! pool profile-id project-id)
(let [params (-> params
(assoc :profile-id profile-id)
(assoc :version (or version 1)))]
(with-meta
(sse/response #(import-binfile cfg (:path file)))
(sse/response (partial import-binfile cfg params))
{::audit/props {:file nil}})))

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

@ -17,6 +17,7 @@
[app.common.schema.desc-js-like :as-alias smdj]
[app.common.types.components-list :as ctkl]
[app.common.types.file :as ctf]
[app.common.uri :as uri]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as-alias sql]
@ -35,7 +36,8 @@
[app.util.services :as sv]
[app.util.time :as dt]
[app.worker :as wrk]
[cuerdas.core :as str]))
[cuerdas.core :as str]
[promesa.exec :as px]))
;; --- FEATURES
@ -181,6 +183,7 @@
[:comment-thread-seqn [::sm/int {:min 0}]]
[:name [:string {:max 250}]]
[:revn [::sm/int {:min 0}]]
[:vern [::sm/int {:min 0}]]
[:modified-at ::dt/instant]
[:is-shared ::sm/boolean]
[:project-id ::sm/uuid]
@ -243,16 +246,16 @@
file)))
(defn get-file
[{:keys [::db/conn] :as cfg} id & {:keys [project-id
migrate?
include-deleted?
lock-for-update?]
:or {include-deleted? false
lock-for-update? false
migrate? true}}]
(dm/assert!
"expected cfg with valid connection"
(db/connection-map? cfg))
[{:keys [::db/conn ::wrk/executor] :as cfg} id
& {:keys [project-id
migrate?
include-deleted?
lock-for-update?]
:or {include-deleted? false
lock-for-update? false
migrate? true}}]
(assert (db/connection? conn) "expected cfg with valid connection")
(let [params (merge {:id id}
(when (some? project-id)
@ -261,55 +264,76 @@
{::db/check-deleted (not include-deleted?)
::db/remove-deleted (not include-deleted?)
::sql/for-update lock-for-update?})
(feat.fdata/resolve-file-data cfg)
(decode-row))]
(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))]
(if (and migrate? (fmg/need-migration? file))
(migrate-file cfg file)
file)))
(defn get-minimal-file
[cfg id & {:as opts}]
(let [opts (assoc opts ::sql/columns [:id :modified-at :deleted-at :revn :data-ref-id :data-backend])]
(let [opts (assoc opts ::sql/columns [:id :modified-at :deleted-at :revn :vern :data-ref-id :data-backend])]
(db/get cfg :file {:id id} opts)))
(defn- get-minimal-file-with-perms
[cfg {:keys [:id ::rpc/profile-id]}]
(let [mfile (get-minimal-file cfg id)
perms (get-permissions cfg profile-id id)]
(assoc mfile :permissions perms)))
(defn get-file-etag
[{:keys [::rpc/profile-id]} {:keys [modified-at revn]}]
(str profile-id (dt/format-instant modified-at :iso) revn))
[{:keys [::rpc/profile-id]} {:keys [modified-at revn vern permissions]}]
(str profile-id "/" revn "/" vern "/"
(dt/format-instant modified-at :iso)
"/"
(uri/map->query-string permissions)))
(sv/defmethod ::get-file
"Retrieve a file by its ID. Only authenticated users."
{::doc/added "1.17"
::cond/get-object #(get-minimal-file %1 (:id %2))
::cond/get-object #(get-minimal-file-with-perms %1 %2)
::cond/key-fn get-file-etag
::sm/params schema:get-file
::sm/result schema:file-with-permissions}
[cfg {:keys [::rpc/profile-id id project-id] :as params}]
(db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
(let [perms (get-permissions conn profile-id id)]
(check-read-permissions! perms)
(let [team (teams/get-team conn
:profile-id profile-id
:project-id project-id
:file-id id)
::sm/result schema:file-with-permissions
::db/transaction true}
[{:keys [::db/conn] :as cfg} {:keys [::rpc/profile-id id project-id] :as params}]
;; The COND middleware makes initial request for a file and
;; permissions when the incoming request comes with an
;; ETAG. When ETAG does not matches, the request is resolved
;; and this code is executed, in this case the permissions
;; will be already prefetched and we just reuse them instead
;; of making an additional database queries.
(let [perms (or (:permissions (::cond/object params))
(get-permissions conn profile-id id))]
(check-read-permissions! perms)
file (-> (get-file cfg id :project-id project-id)
(assoc :permissions perms)
(check-version!))
(let [team (teams/get-team conn
:profile-id profile-id
:project-id project-id
:file-id id)
_ (-> (cfeat/get-team-enabled-features cf/flags team)
(cfeat/check-client-features! (:features params))
(cfeat/check-file-features! (:features file) (:features params)))
file (-> (get-file cfg id :project-id project-id)
(assoc :permissions perms)
(check-version!))]
;; This operation is needed for backward comapatibility with frontends that
;; does not support pointer-map resolution mechanism; this just resolves the
;; pointers on backend and return a complete file.
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))
file)]
(-> (cfeat/get-team-enabled-features cf/flags team)
(cfeat/check-client-features! (:features params))
(cfeat/check-file-features! (:features file) (:features params)))
(vary-meta file assoc ::cond/key (get-file-etag params file)))))))
;; This operation is needed for backward comapatibility with frontends that
;; does not support pointer-map resolution mechanism; this just resolves the
;; pointers on backend and return a complete file.
(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))
file))))
;; --- COMMAND QUERY: get-file-fragment (by id)
@ -355,6 +379,7 @@
f.modified_at,
f.name,
f.revn,
f.vern,
f.is_shared,
ft.media_id AS thumbnail_id
from file as f
@ -504,6 +529,7 @@
(def ^:private sql:team-shared-files
"select f.id,
f.revn,
f.vern,
f.data,
f.project_id,
f.created_at,
@ -587,6 +613,7 @@
l.deleted_at,
l.name,
l.revn,
l.vern,
l.synced_at
FROM libs AS l
WHERE l.deleted_at IS NULL OR l.deleted_at > now();")
@ -648,6 +675,7 @@
"with recent_files as (
select f.id,
f.revn,
f.vern,
f.project_id,
f.created_at,
f.modified_at,

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

@ -15,10 +15,11 @@
[app.db.sql :as-alias sql]
[app.features.fdata :as feat.fdata]
[app.main :as-alias main]
[app.msgbus :as mbus]
[app.rpc :as-alias rpc]
[app.rpc.commands.files :as files]
[app.rpc.commands.profile :as profile]
[app.rpc.doc :as-alias doc]
[app.rpc.quotes :as quotes]
[app.storage :as sto]
[app.util.blob :as blob]
[app.util.pointer-map :as pmap]
@ -26,173 +27,52 @@
[app.util.time :as dt]
[cuerdas.core :as str]))
(defn check-authorized!
[{:keys [::db/pool]} profile-id]
(when-not (or (= "devenv" (cf/get :host))
(let [profile (ex/ignoring (profile/get-profile pool profile-id))
admins (or (cf/get :admins) #{})]
(contains? admins (:email profile))))
(ex/raise :type :authentication
:code :authentication-required
:hint "only admins allowed")))
(def sql:get-file-snapshots
"SELECT id, label, revn, created_at
"SELECT id, label, revn, created_at, created_by, profile_id
FROM file_change
WHERE file_id = ?
AND created_at < ?
AND label IS NOT NULL
AND data IS NOT NULL
AND (deleted_at IS NULL OR deleted_at > now())
ORDER BY created_at DESC
LIMIT ?")
LIMIT 20")
(defn get-file-snapshots
[{:keys [::db/conn]} {:keys [file-id limit start-at]
:or {limit Long/MAX_VALUE}}]
(let [start-at (or start-at (dt/now))
limit (min limit 20)]
(->> (db/exec! conn [sql:get-file-snapshots file-id start-at limit])
(mapv (fn [row]
(update row :created-at dt/format-instant :rfc1123))))))
[conn file-id]
(db/exec! conn [sql:get-file-snapshots file-id]))
(def ^:private schema:get-file-snapshots
[:map [:file-id ::sm/uuid]])
[:map {:title "get-file-snapshots"}
[:file-id ::sm/uuid]])
(sv/defmethod ::get-file-snapshots
{::doc/added "1.20"
::doc/skip true
::sm/params schema:get-file-snapshots}
[cfg {:keys [::rpc/profile-id] :as params}]
(check-authorized! cfg profile-id)
(db/run! cfg get-file-snapshots params))
[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 restore-file-snapshot!
[{:keys [::db/conn] :as cfg} {:keys [file-id id]}]
(let [storage (sto/resolve cfg {::db/reuse-conn true})
file (files/get-minimal-file conn file-id {::db/for-update true})
snapshot (db/get* conn :file-change
{:file-id file-id
:id id}
{::db/for-share true})]
(when-not snapshot
(ex/raise :type :not-found
:code :snapshot-not-found
:hint "unable to find snapshot with the provided label"
:id id
:file-id file-id))
(let [snapshot (feat.fdata/resolve-file-data cfg snapshot)]
(when-not (:data snapshot)
(ex/raise :type :precondition
: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 restring 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)))
(db/update! conn :file
{:data (:data snapshot)
:revn (inc (:revn file))
: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)))
{:id (:id snapshot)
:label (:label snapshot)})))
(defn- resolve-snapshot-by-label
[conn file-id label]
(->> (db/query conn :file-change
{:file-id file-id
:label label}
{::sql/order-by [[:created-at :desc]]
::sql/columns [:file-id :id :label]})
(first)))
(def ^:private
schema:restore-file-snapshot
[:and
[:map
[:file-id ::sm/uuid]
[:id {:optional true} ::sm/uuid]
[:label {:optional true} :string]]
[::sm/contains-any #{:id :label}]])
(sv/defmethod ::restore-file-snapshot
{::doc/added "1.20"
::doc/skip true
::sm/params schema:restore-file-snapshot}
[cfg {:keys [::rpc/profile-id file-id id label] :as params}]
(check-authorized! cfg profile-id)
(db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
(let [params (cond-> params
(and (not id) (string? label))
(merge (resolve-snapshot-by-label conn file-id label)))]
(restore-file-snapshot! cfg params)))))
(def ^:private sql:get-file
"SELECT f.*,
p.id AS project_id,
p.team_id AS team_id
FROM file AS f
INNER JOIN project AS p ON (p.id = f.project_id)
WHERE f.id = ?")
(defn- get-file
[cfg file-id]
(let [file (->> (db/get cfg :file {:id file-id})
(let [file (->> (db/exec-one! cfg [sql:get-file file-id])
(feat.fdata/resolve-file-data cfg))]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg file-id)]
(-> file
(update :data blob/decode)
(update :data feat.fdata/process-pointers deref)
(update :data feat.fdata/process-objects (partial into {}))
(update :data assoc ::id file-id)
(update :data blob/encode)))))
(defn take-file-snapshot!
[cfg {:keys [file-id label ::rpc/profile-id]}]
(let [file (get-file cfg file-id)
id (uuid/next)]
(l/debug :hint "creating file snapshot"
:file-id (str file-id)
:label label)
(db/insert! cfg :file-change
{:id id
:revn (:revn file)
:data (:data file)
:version (:version file)
:features (:features file)
:profile-id profile-id
:file-id (:id file)
:label label}
{::db/return-keys false})
{:id id :label label}))
(defn generate-snapshot-label
(defn- generate-snapshot-label
[]
(let [ts (-> (dt/now)
(dt/format-instant)
@ -200,17 +80,218 @@
(str/rtrim "Z"))]
(str "snapshot-" ts)))
(def ^:private schema:take-file-snapshot
[:map [:file-id ::sm/uuid]])
(defn create-file-snapshot!
[cfg profile-id file-id label]
(let [file (get-file cfg file-id)
(sv/defmethod ::take-file-snapshot
;; NOTE: final user never can provide label as `:system`
;; keyword because the validator implies label always as
;; string; keyword is used for signal a special case
created-by
(if (= label :system)
"system"
"user")
deleted-at
(if (= label :system)
(dt/plus (dt/now) (cf/get-deletion-delay))
nil)
label
(if (= label :system)
(str "internal/snapshot/" (:revn file))
(or label (generate-snapshot-label)))
snapshot-id
(uuid/next)]
(-> cfg
(assoc ::quotes/profile-id profile-id)
(assoc ::quotes/project-id (:project-id file))
(assoc ::quotes/team-id (:team-id file))
(assoc ::quotes/file-id (:id file))
(quotes/check! {::quotes/id ::quotes/snapshots-per-file}
{::quotes/id ::quotes/snapshots-per-team}))
(l/debug :hint "creating file snapshot"
:file-id (str file-id)
:id (str snapshot-id)
:label label)
(db/insert! cfg :file-change
{:id snapshot-id
:revn (:revn file)
:data (:data file)
:version (:version file)
:features (:features file)
: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}))
(def ^:private schema:create-file-snapshot
[:map
[:file-id ::sm/uuid]
[:label {:optional true} :string]])
(sv/defmethod ::create-file-snapshot
{::doc/added "1.20"
::doc/skip true
::sm/params schema:take-file-snapshot}
[cfg {:keys [::rpc/profile-id] :as params}]
(check-authorized! cfg profile-id)
(db/tx-run! cfg (fn [cfg]
(let [params (update params :label (fn [label]
(or label (generate-snapshot-label))))]
(take-file-snapshot! cfg params)))))
::sm/params schema:create-file-snapshot}
[cfg {:keys [::rpc/profile-id file-id label]}]
(db/tx-run! cfg
(fn [{:keys [::db/conn] :as cfg}]
(files/check-edition-permissions! conn profile-id file-id)
(create-file-snapshot! cfg profile-id file-id label))))
(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))]
(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 restring 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)))
(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)}))
(def ^:private schema:restore-file-snapshot
[:map {:title "restore-file-snapshot"}
[:file-id ::sm/uuid]
[:id ::sm/uuid]])
(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}]
(files/check-edition-permissions! conn profile-id file-id)
(create-file-snapshot! cfg profile-id file-id :system)
(restore-file-snapshot! cfg file-id id))))
(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)))
(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]
::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)]
(files/check-edition-permissions! conn profile-id (:file-id snapshot))
(update-file-snapshot! conn id 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 (dt/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)]
(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
:snapshot-id id
:profile-id profile-id))
(delete-file-snapshot! conn id)))))

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

@ -34,7 +34,7 @@
[app.util.pointer-map :as pmap]
[app.util.services :as sv]
[app.util.time :as dt]
[app.worker :as-alias wrk]
[app.worker :as wrk]
[clojure.set :as set]
[promesa.exec :as px]))
@ -44,7 +44,6 @@
(declare ^:private update-file*)
(declare ^:private process-changes-and-validate)
(declare ^:private take-snapshot?)
(declare ^:private delete-old-snapshots!)
;; PUBLIC API; intended to be used outside of this module
(declare update-file!)
@ -60,6 +59,7 @@
[:id ::sm/uuid]
[:session-id ::sm/uuid]
[:revn {:min 0} ::sm/int]
[:vern {:min 0} ::sm/int]
[:features {:optional true} ::cfeat/features]
[:changes {:optional true} [:vector ::cpc/change]]
[:changes-with-metadata {:optional true}
@ -157,6 +157,14 @@
tpoint (dt/tpoint)]
(when (not= (:vern params)
(:vern file))
(ex/raise :type :validation
:code :vern-conflict
:hint "A different version has been restored for the file."
:context {:incoming-revn (:revn params)
:stored-revn (:revn file)}))
(when (> (:revn params)
(:revn file))
(ex/raise :type :validation
@ -215,23 +223,34 @@
(let [storage (sto/resolve cfg ::db/reuse-conn true)]
(some->> (:data-ref-id file) (sto/touch-object! storage))))
;; TODO: move this to asynchronous task
(when (::snapshot-data file)
(delete-old-snapshots! cfg file))
(-> cfg
(assoc ::wrk/task :file-xlog-gc)
(assoc ::wrk/label (str "xlog:" (:id file)))
(assoc ::wrk/params {:file-id (:id file)})
(assoc ::wrk/delay (dt/duration "5m"))
(assoc ::wrk/dedupe true)
(assoc ::wrk/priority 1)
(wrk/submit!))
(persist-file! cfg file)
(let [params (assoc params :file file)
response {:revn (:revn file)
:lagged (get-lagged-changes conn params)}
features (db/create-array conn "text" (:features file))]
features (db/create-array conn "text" (:features file))
deleted-at (if (::snapshot-data file)
(dt/plus timestamp (cf/get-deletion-delay))
(dt/plus timestamp (dt/duration {:hours 1})))]
;; Insert change (xlog)
;; Insert change (xlog) with deleted_at in a future data for
;; make them automatically eleggible for GC once they expires
(db/insert! conn :file-change
{:id (uuid/next)
:session-id session-id
:profile-id profile-id
:created-at timestamp
:updated-at timestamp
:deleted-at deleted-at
:file-id (:id file)
:revn (:revn file)
:version (:version file)
@ -449,33 +468,6 @@
(> (inst-ms (dt/diff modified-at (dt/now)))
(inst-ms timeout))))))
;; Get the latest available snapshots without exceeding the total
;; snapshot limit.
(def ^:private sql:get-latest-snapshots
"SELECT fch.id, fch.created_at
FROM file_change AS fch
WHERE fch.file_id = ?
AND fch.label LIKE 'internal/%'
ORDER BY fch.created_at DESC
LIMIT ?")
;; Mark all snapshots that are outside the allowed total threshold
;; available for the GC.
(def ^:private sql:delete-snapshots
"UPDATE file_change
SET label = NULL
WHERE file_id = ?
AND label LIKE 'internal/%'
AND created_at < ?")
(defn- delete-old-snapshots!
[{:keys [::db/conn] :as cfg} {:keys [id] :as file}]
(when-let [snapshots (not-empty (db/exec! conn [sql:get-latest-snapshots id
(cf/get :auto-file-snapshot-total 10)]))]
(let [last-date (-> snapshots peek :created-at)
result (db/exec-one! conn [sql:delete-snapshots id last-date])]
(l/trc :hint "delete old snapshots" :file-id (str id) :total (db/get-update-count result)))))
(def ^:private sql:lagged-changes
"select s.id, s.revn, s.file_id,
s.session_id, s.changes
@ -502,6 +494,7 @@
:file-id (:id file)
:session-id (:session-id params)
:revn (:revn file)
:vern (:vern file)
:changes changes})
(when (and (:is-shared file) (seq lchanges))

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

@ -176,7 +176,7 @@
(binding [bfc/*state* (volatile! {:index {team-id (uuid/next)}})]
(let [projs (bfc/get-team-projects cfg team-id)
files (bfc/get-team-files cfg team-id)
files (bfc/get-team-files-ids cfg team-id)
frels (bfc/get-files-rels cfg files)
team (-> (db/get-by-id conn :team team-id)
@ -326,7 +326,7 @@
(def ^:private
schema:move-files
[:map {:title "move-files"}
[:ids ::sm/set-of-uuid]
[:ids [::sm/set {:min 1} ::sm/uuid]]
[:project-id ::sm/uuid]])
(sv/defmethod ::move-files
@ -335,7 +335,7 @@
::webhooks/event? true
::sm/params schema:move-files}
[cfg {:keys [::rpc/profile-id] :as params}]
(db/tx-run! cfg #(move-files % (assoc params :profile-id profile-id))))
(db/tx-run! cfg move-files (assoc params :profile-id profile-id)))
;; --- COMMAND: Move project
@ -396,14 +396,15 @@
(defn clone-template
[cfg {:keys [project-id profile-id] :as params} template]
(db/tx-run! cfg (fn [{:keys [::db/conn ::wrk/executor] :as cfg}]
;; NOTE: the importation process performs some operations that
;; are not very friendly with virtual threads, and for avoid
;; unexpected blocking of other concurrent operations we
;; dispatch that operation to a dedicated executor.
;; NOTE: the importation process performs some operations
;; that are not very friendly with virtual threads, and for
;; avoid unexpected blocking of other concurrent operations
;; we dispatch that operation to a dedicated executor.
(let [cfg (-> cfg
(assoc ::bf.v1/project-id project-id)
(assoc ::bf.v1/profile-id profile-id))
result (px/invoke! executor (partial bf.v1/import-files! cfg template))]
(assoc ::bf.v1/profile-id profile-id)
(assoc ::bf.v1/input template))
result (px/invoke! executor (partial bf.v1/import-files! cfg))]
(db/update! conn :project
{:modified-at (dt/now)}

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

@ -216,7 +216,7 @@
{:response-type :input-stream :sync? true})
{:keys [size mtype]} (parse-and-validate response)
path (tmp/tempfile :prefix "penpot.media.download.")
written (io/write-to-file! body path :size size)]
written (io/write* path body :size size)]
(when (not= written size)
(ex/raise :type :internal

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

@ -222,7 +222,7 @@
::webhooks/event? true}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id team-id is-pinned] :as params}]
(db/with-atomic [conn pool]
(check-edition-permissions! conn profile-id id)
(check-read-permissions! conn profile-id id)
(db/exec-one! conn [sql:update-project-pin team-id id profile-id is-pinned is-pinned])
nil))

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

@ -10,8 +10,8 @@
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.features :as cfeat]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.types.team :as tt]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
@ -20,20 +20,17 @@
[app.loggers.audit :as audit]
[app.main :as-alias main]
[app.media :as media]
[app.msgbus :as mbus]
[app.rpc :as-alias rpc]
[app.rpc.commands.profile :as profile]
[app.rpc.doc :as-alias doc]
[app.rpc.helpers :as rph]
[app.rpc.permissions :as perms]
[app.rpc.quotes :as quotes]
[app.setup :as-alias setup]
[app.storage :as sto]
[app.tokens :as tokens]
[app.util.blob :as blob]
[app.util.services :as sv]
[app.util.time :as dt]
[app.worker :as wrk]
[cuerdas.core :as str]))
[app.worker :as wrk]))
;; --- Helpers & Specs
@ -82,7 +79,9 @@
(cond-> row
(some? features) (assoc :features (db/decode-pgarray features #{}))))
(defn- check-profile-muted
;; FIXME: move
(defn check-profile-muted
"Check if the member's email is part of the global bounce report"
[conn member]
(let [email (profile/clean-email (:email member))]
@ -92,7 +91,7 @@
:email email
:hint "the profile has reported repeatedly as spam or has bounces"))))
(defn- check-email-bounce
(defn check-email-bounce
"Check if the email is part of the global complain report"
[conn email show?]
(when (eml/has-bounce-reports? conn email)
@ -101,7 +100,7 @@
:email (if show? email "private")
:hint "this email has been repeatedly reported as bounce")))
(defn- check-email-spam
(defn check-email-spam
"Check if the member email is part of the global complain report"
[conn email show?]
(when (eml/has-complaint-reports? conn email)
@ -265,6 +264,8 @@
[:fn #(or (contains? % :team-id)
(contains? % :file-id))]])
;; FIXME: split in two separated requests
(sv/defmethod ::get-team-users
"Get team users by team-id or by file-id"
{::doc/added "1.17"
@ -302,20 +303,29 @@
inner join project as p on (f.project_id = p.id)
where p.team_id = ?")
(def sql:team-by-file
"select p.team_id as id
from project as p
join file as f on (p.id = f.project_id)
where f.id = ?")
(defn get-users
[conn team-id]
(db/exec! conn [sql:team-users team-id team-id team-id]))
(def sql:get-team-by-file
"SELECT t.*
FROM team AS t
JOIN project AS p ON (p.team_id = t.id)
JOIN file AS f ON (f.project_id = p.id)
WHERE f.id = ?")
(defn get-team-for-file
[conn file-id]
(->> [sql:team-by-file file-id]
(db/exec-one! conn)))
(let [team (->> (db/exec! conn [sql:get-team-by-file file-id])
(remove db/is-row-deleted?)
(map decode-row)
(first))]
(when-not team
(ex/raise :type :not-found
:code :object-not-found
:hint "database object not found"))
team))
;; --- Query: Team Stats
@ -503,8 +513,6 @@
;; --- Mutation: Leave Team
(declare role->params)
(defn leave-team
[conn {:keys [profile-id id reassign-to]}]
(let [perms (get-permissions conn profile-id id)
@ -534,7 +542,7 @@
;; assign owner role to new profile
(db/update! conn :team-profile-rel
(role->params :owner)
(get tt/permissions-for-role :owner)
{:team-id id :profile-id reassign-to}))
;; and finally, if all other conditions does not match and the
@ -606,24 +614,8 @@
;; --- Mutation: Team Update Role
;; Temporarily disabled viewer role
;; https://tree.taiga.io/project/penpot/issue/1083
(def valid-roles
#{:owner :admin :editor #_:viewer})
(def schema:role
[::sm/one-of valid-roles])
(defn role->params
[role]
(case role
:admin {:is-owner false :is-admin true :can-edit true}
:editor {:is-owner false :is-admin false :can-edit true}
:owner {:is-owner true :is-admin true :can-edit true}
:viewer {:is-owner false :is-admin false :can-edit false}))
(defn update-team-member-role
[conn {:keys [profile-id team-id member-id role] :as params}]
[{:keys [::db/conn ::mbus/msgbus]} {:keys [profile-id team-id member-id role] :as params}]
;; We retrieve all team members instead of query the
;; database for a single member. This is just for
;; convenience, if this becomes a bottleneck or problematic,
@ -631,7 +623,6 @@
(let [perms (get-permissions conn profile-id team-id)
members (get-team-members conn team-id)
member (d/seek #(= member-id (:id %)) members)
is-owner? (:is-owner perms)
is-admin? (:is-admin perms)]
@ -655,7 +646,14 @@
(ex/raise :type :validation
:code :cant-promote-to-owner))
(let [params (role->params role)]
(mbus/pub! msgbus
:topic member-id
:message {:type :team-role-change
:topic member-id
:team-id team-id
:role role})
(let [params (get tt/permissions-for-role role)]
;; Only allow single owner on team
(when (= role :owner)
(db/update! conn :team-profile-rel
@ -673,14 +671,13 @@
[:map {:title "update-team-member-role"}
[:team-id ::sm/uuid]
[:member-id ::sm/uuid]
[:role schema:role]])
[:role ::tt/role]])
(sv/defmethod ::update-team-member-role
{::doc/added "1.17"
::sm/params schema:update-team-member-role}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id] :as params}]
(db/with-atomic [conn pool]
(update-team-member-role conn (assoc params :profile-id profile-id))))
[cfg {:keys [::rpc/profile-id] :as params}]
(db/tx-run! cfg update-team-member-role (assoc params :profile-id profile-id)))
;; --- Mutation: Delete Team Member
@ -692,9 +689,10 @@
(sv/defmethod ::delete-team-member
{::doc/added "1.17"
::sm/params schema:delete-team-member}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id member-id] :as params}]
[{:keys [::db/pool ::mbus/msgbus] :as cfg} {:keys [::rpc/profile-id team-id member-id] :as params}]
(db/with-atomic [conn pool]
(let [perms (get-permissions conn profile-id team-id)]
(let [team (get-team pool :profile-id profile-id :team-id team-id)
perms (get-permissions conn profile-id team-id)]
(when-not (or (:is-owner perms)
(:is-admin perms))
(ex/raise :type :validation
@ -707,6 +705,13 @@
(db/delete! conn :team-profile-rel {:profile-id member-id
:team-id team-id})
(mbus/pub! msgbus
:topic member-id
:message {:type :team-membership-change
:change :removed
:team-id team-id
:team-name (:name team)})
nil)))
;; --- Mutation: Update Team Photo
@ -724,6 +729,7 @@
::sm/params schema:update-team-photo}
[cfg {:keys [::rpc/profile-id file] :as params}]
;; Validate incoming mime type
(media/validate-media-type! file #{"image/jpeg" "image/png" "image/webp"})
(update-team-photo cfg (assoc params :profile-id profile-id)))
@ -745,534 +751,3 @@
{:id team-id})
(assoc team :photo-id (:id photo)))))
;; --- Mutation: Create Team Invitation
(def sql:upsert-team-invitation
"insert into team_invitation(id, team_id, email_to, role, valid_until)
values (?, ?, ?, ?, ?)
on conflict(team_id, email_to) do
update set role = ?, valid_until = ?, updated_at = now()
returning *")
(defn- create-invitation-token
[cfg {:keys [profile-id valid-until team-id member-id member-email role]}]
(tokens/generate (::setup/props cfg)
{:iss :team-invitation
:exp valid-until
:profile-id profile-id
:role role
:team-id team-id
:member-email member-email
:member-id member-id}))
(defn- create-profile-identity-token
[cfg profile-id]
(dm/assert!
"expected valid uuid for profile-id"
(uuid? profile-id))
(tokens/generate (::setup/props cfg)
{:iss :profile-identity
:profile-id profile-id
:exp (dt/in-future {:days 30})}))
(def ^:private schema:create-invitation
[:map {:title "params:create-invitation"}
[::rpc/profile-id ::sm/uuid]
[:team
[:map
[:id ::sm/uuid]
[:name :string]]]
[:profile
[:map
[:id ::sm/uuid]
[:fullname :string]]]
[:role [::sm/one-of valid-roles]]
[:email ::sm/email]])
(def ^:private check-create-invitation-params!
(sm/check-fn schema:create-invitation))
(defn- create-invitation
[{:keys [::db/conn] :as cfg} {:keys [team profile role email] :as params}]
(dm/assert!
"expected valid connection on cfg parameter"
(db/connection? conn))
(dm/assert!
"expected valid params for `create-invitation` fn"
(check-create-invitation-params! params))
(let [email (profile/clean-email email)
member (profile/get-profile-by-email conn email)]
(check-profile-muted conn member)
(check-email-bounce conn email true)
(check-email-spam conn email true)
;; When we have email verification disabled and invitation user is
;; already present in the database, we proceed to add it to the
;; team as-is, without email roundtrip.
;; TODO: if member does not exists and email verification is
;; disabled, we should proceed to create the profile (?)
(if (and (not (contains? cf/flags :email-verification))
(some? member))
(let [params (merge {:team-id (:id team)
:profile-id (:id member)}
(role->params role))]
;; Insert the invited member to the team
(db/insert! conn :team-profile-rel params
{::db/on-conflict-do-nothing? true})
;; If profile is not yet verified, mark it as verified because
;; accepting an invitation link serves as verification.
(when-not (:is-active member)
(db/update! conn :profile
{:is-active true}
{:id (:id member)}))
nil)
(let [id (uuid/next)
expire (dt/in-future "168h") ;; 7 days
invitation (db/exec-one! conn [sql:upsert-team-invitation id
(:id team) (str/lower email)
(name role) expire
(name role) expire])
updated? (not= id (:id invitation))
profile-id (:id profile)
tprops {:profile-id profile-id
:invitation-id (:id invitation)
:valid-until expire
:team-id (:id team)
:member-email (:email-to invitation)
:member-id (:id member)
:role role}
itoken (create-invitation-token cfg tprops)
ptoken (create-profile-identity-token cfg profile-id)]
(when (contains? cf/flags :log-invitation-tokens)
(l/info :hint "invitation token" :token itoken))
(let [props (-> (dissoc tprops :profile-id)
(audit/clean-props))
evname (if updated?
"update-team-invitation"
"create-team-invitation")
event (-> (audit/event-from-rpc-params params)
(assoc ::audit/name evname)
(assoc ::audit/props props))]
(audit/submit! cfg event))
(eml/send! {::eml/conn conn
::eml/factory eml/invite-to-team
:public-uri (cf/get :public-uri)
:to email
:invited-by (:fullname profile)
:team (:name team)
:token itoken
:extra-data ptoken})
itoken))))
(defn- add-user-to-team
[conn profile team role email]
(let [team-id (:id team)
member (db/get* conn :profile
{:email (str/lower email)}
{::sql/columns [:id :email]})
params (merge
{:team-id team-id
:profile-id (:id member)}
(role->params role))]
;; Do not allow blocked users to join teams.
(when (:is-blocked member)
(ex/raise :type :restriction
:code :profile-blocked))
(quotes/check!
{::db/conn conn
::quotes/id ::quotes/profiles-per-team
::quotes/profile-id (:id member)
::quotes/team-id team-id})
;; Insert the member to the team
(db/insert! conn :team-profile-rel params {::db/on-conflict-do-nothing? true})
;; Delete any request
(db/delete! conn :team-access-request
{:team-id team-id :requester-id (:id member)})
;; Delete any invitation
(db/delete! conn :team-invitation
{:team-id team-id :email-to (:email member)})
(eml/send! {::eml/conn conn
::eml/factory eml/join-team
:public-uri (cf/get :public-uri)
:to email
:invited-by (:fullname profile)
:team (:name team)
:team-id (:id team)})))
(def sql:valid-requests-email
"SELECT p.email
FROM team_access_request AS tr
JOIN profile AS p ON (tr.requester_id = p.id)
WHERE tr.team_id = ?
AND tr.auto_join_until > now()")
(defn- get-valid-requests-email
[conn team-id]
(db/exec! conn [sql:valid-requests-email team-id]))
(def ^:private xf:map-email
(map :email))
(defn- create-team-invitations
[{:keys [::db/conn] :as cfg} {:keys [profile team role emails] :as params}]
(let [join-requests (into #{} xf:map-email
(get-valid-requests-email conn (:id team)))
team-members (into #{} xf:map-email
(get-team-members conn (:id team)))
invitations (into #{}
(comp
;; We don't re-send inviation to
;; already existing members
(remove team-members)
;; 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)]
;; For requested invitations, do not send invitation emails, add
;; the user directly to the team
(->> (filter join-requests emails)
(run! (partial add-user-to-team conn profile team role)))
invitations))
(def ^:private schema:create-team-invitations
[:map {:title "create-team-invitations"}
[:team-id ::sm/uuid]
[:role schema:role]
[:emails [::sm/set ::sm/email]]])
(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."
{::doc/added "1.17"
::sm/params schema:create-team-invitations}
[cfg {:keys [::rpc/profile-id team-id emails] :as params}]
(let [perms (get-permissions cfg profile-id team-id)
profile (db/get-by-id cfg :profile profile-id)
emails (into #{} (map profile/clean-email) emails)]
(when-not (:is-admin perms)
(ex/raise :type :validation
:code :insufficient-permissions))
(when (> (count emails) max-invitations-by-request-threshold)
(ex/raise :type :validation
:code :max-invitations-by-request
:hint "the maximum of invitation on single request is reached"
:threshold max-invitations-by-request-threshold))
(-> cfg
(assoc ::quotes/profile-id profile-id)
(assoc ::quotes/team-id team-id)
(assoc ::quotes/incr (count emails))
(quotes/check! {::quotes/id ::quotes/invitations-per-team}
{::quotes/id ::quotes/profiles-per-team}))
;; Check if the current profile is allowed to send emails
(check-profile-muted cfg profile)
(let [team (db/get-by-id cfg :team team-id)
;; NOTE: Is important pass RPC method params down to the
;; `create-team-invitations` because it uses the implicit
;; RPC properties from params for fill necessary data on
;; emiting an entry to the audit-log
invitations (db/tx-run! cfg create-team-invitations
(-> params
(assoc :profile profile)
(assoc :team team)
(assoc :emails emails)))]
(with-meta {:total (count invitations)
:invitations invitations}
{::audit/props {:invitations (count invitations)}}))))
;; --- Mutation: Create Team & Invite Members
(def ^:private schema:create-team-with-invitations
[:map {:title "create-team-with-invitations"}
[:name [:string {:max 250}]]
[:features {:optional true} ::cfeat/features]
[:id {:optional true} ::sm/uuid]
[:emails [::sm/set ::sm/email]]
[:role schema:role]])
(sv/defmethod ::create-team-with-invitations
{::doc/added "1.17"
::sm/params schema:create-team-with-invitations
::db/transaction true}
[{:keys [::db/conn] :as cfg} {:keys [::rpc/profile-id emails role name] :as params}]
(let [features (-> (cfeat/get-enabled-features cf/flags)
(cfeat/check-client-features! (:features params)))
params (-> params
(assoc :profile-id profile-id)
(assoc :features features))
team (create-team cfg params)
emails (into #{} (map profile/clean-email) emails)]
(-> cfg
(assoc ::quotes/profile-id profile-id)
(assoc ::quotes/team-id (:id team))
(assoc ::quotes/incr (count emails))
(quotes/check! {::quotes/id ::quotes/teams-per-profile}
{::quotes/id ::quotes/invitations-per-team}
{::quotes/id ::quotes/profiles-per-team}))
(when (> (count emails) max-invitations-by-request-threshold)
(ex/raise :type :validation
:code :max-invitations-by-request
:hint "the maximum of invitation on single request is reached"
:threshold max-invitations-by-request-threshold))
(let [props {:name name :features features}
event (-> (audit/event-from-rpc-params params)
(assoc ::audit/name "create-team")
(assoc ::audit/props props))]
(audit/submit! cfg event))
;; Create invitations for all provided emails.
(let [profile (db/get-by-id conn :profile profile-id)
params (-> params
(assoc :team team)
(assoc :profile profile)
(assoc :role role))
invitations (->> emails
(map (fn [email] (assoc params :email email)))
(map (partial create-invitation cfg)))]
(vary-meta team assoc ::audit/props {:invitations (count invitations)}))))
;; --- Query: get-team-invitation-token
(def ^:private schema:get-team-invitation-token
[:map {:title "get-team-invitation-token"}
[:team-id ::sm/uuid]
[:email ::sm/email]])
(sv/defmethod ::get-team-invitation-token
{::doc/added "1.17"
::sm/params schema:get-team-invitation-token}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id email] :as params}]
(check-read-permissions! pool profile-id team-id)
(let [email (profile/clean-email email)
invit (-> (db/get pool :team-invitation
{:team-id team-id
:email-to email})
(update :role keyword))
member (profile/get-profile-by-email pool (:email-to invit))
token (create-invitation-token cfg {:team-id (:team-id invit)
:profile-id profile-id
:valid-until (:valid-until invit)
:role (:role invit)
:member-id (:id member)
:member-email (or (:email member)
(profile/clean-email (:email-to invit)))})]
{:token token}))
;; --- Mutation: Update invitation role
(def ^:private schema:update-team-invitation-role
[:map {:title "update-team-invitation-role"}
[:team-id ::sm/uuid]
[:email ::sm/email]
[:role schema:role]])
(sv/defmethod ::update-team-invitation-role
{::doc/added "1.17"
::sm/params schema:update-team-invitation-role}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id email role] :as params}]
(db/with-atomic [conn pool]
(let [perms (get-permissions conn profile-id team-id)]
(when-not (:is-admin perms)
(ex/raise :type :validation
:code :insufficient-permissions))
(db/update! conn :team-invitation
{:role (name role) :updated-at (dt/now)}
{:team-id team-id :email-to (profile/clean-email email)})
nil)))
;; --- Mutation: Delete invitation
(def ^:private schema:delete-team-invition
[:map {:title "delete-team-invitation"}
[:team-id ::sm/uuid]
[:email ::sm/email]])
(sv/defmethod ::delete-team-invitation
{::doc/added "1.17"
::sm/params schema:delete-team-invition}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id email] :as params}]
(db/with-atomic [conn pool]
(let [perms (get-permissions conn profile-id team-id)]
(when-not (:is-admin perms)
(ex/raise :type :validation
:code :insufficient-permissions))
(let [invitation (db/delete! conn :team-invitation
{:team-id team-id
:email-to (profile/clean-email email)}
{::db/return-keys true})]
(rph/wrap nil {::audit/props {:invitation-id (:id invitation)}})))))
;; --- Mutation: Request Team Invitation
(def sql:upsert-team-access-request
"INSERT INTO team_access_request (id, team_id, requester_id, valid_until, auto_join_until)
VALUES (?, ?, ?, ?, ?)
ON conflict(id)
DO UPDATE SET valid_until = ?, auto_join_until = ?, updated_at = now()
RETURNING *")
(def sql:team-access-request
"SELECT id, (valid_until < now()) AS expired
FROM team_access_request
WHERE team_id = ?
AND requester_id = ?")
(def sql:team-owner
"SELECT profile_id
FROM team_profile_rel
WHERE team_id = ?
AND is_owner = true")
(defn- create-team-access-request
[{:keys [::db/conn] :as cfg} {:keys [team requester team-owner file is-viewer] :as params}]
(let [old-request (->> (db/exec-one! conn [sql:team-access-request (:id team) (:id requester)])
(decode-row))]
(when (false? (:expired old-request))
(ex/raise :type :validation
:code :request-already-sent
:hint "you have already made a request to join this team less than 24 hours ago"))
(let [id (or (:id old-request) (uuid/next))
valid_until (dt/in-future "24h")
auto_join_until (dt/in-future "168h") ;; 7 days
request (db/exec-one! conn [sql:upsert-team-access-request
id (:id team) (:id requester) valid_until auto_join_until
valid_until auto_join_until])
factory (cond
(and (some? file) (:is-default team) is-viewer)
eml/request-file-access-yourpenpot-view
(and (some? file) (:is-default team))
eml/request-file-access-yourpenpot
(some? file)
eml/request-file-access
:else
eml/request-team-access)
page-id (when (some? file)
(-> file :data :pages first))]
;; TODO needs audit?
(eml/send! {::eml/conn conn
::eml/factory factory
:public-uri (cf/get :public-uri)
:to (:email team-owner)
:requested-by (:fullname requester)
:requested-by-email (:email requester)
:team-name (:name team)
:team-id (:id team)
:file-name (:name file)
:file-id (:id file)
:page-id page-id})
request)))
(def ^:private schema:create-team-access-request
[:and
[:map {:title "create-team-access-request"}
[:file-id {:optional true} ::sm/uuid]
[:team-id {:optional true} ::sm/uuid]
[:is-viewer {:optional true} ::sm/boolean]]
[:fn (fn [params]
(or (contains? params :file-id)
(contains? params :team-id)))]])
(sv/defmethod ::create-team-access-request
"A rpc call that allow to request for an invitations to join the team."
{::doc/added "2.2.0"
::sm/params schema:create-team-access-request}
[cfg {:keys [::rpc/profile-id file-id team-id is-viewer] :as params}]
(db/tx-run! cfg
(fn [{:keys [::db/conn] :as cfg}]
(let [requester (db/get-by-id conn :profile profile-id)
team-id (if (some? team-id)
team-id
(:id (get-team-for-file conn file-id)))
team (db/get-by-id conn :team team-id)
owner-id (->> (db/exec! conn [sql:team-owner (:id team)])
(map decode-row)
(first)
:profile-id)
team-owner (db/get-by-id conn :profile owner-id)
file (when (some? file-id)
(db/get* conn :file
{:id file-id}
{::sql/columns [:id :name :data]}))
file (when (some? file)
(assoc file :data (blob/decode (:data file))))]
;;TODO needs quotes?
(when (or (nil? requester) (nil? team) (nil? team-owner) (and (some? file-id) (nil? file)))
(ex/raise :type :validation
:code :invalid-parameters))
;; Check that the requester is not muted
(check-profile-muted conn requester)
;; Check that the owner is not marked as bounce nor spam
(check-email-bounce conn (:email team-owner) false)
(check-email-spam conn (:email team-owner) true)
(let [request (create-team-access-request
cfg {:team team :requester requester :team-owner team-owner :file file :is-viewer is-viewer})]
(when request
(with-meta {:request request}
{::audit/props {:request 1}})))))))

573
backend/src/app/rpc/commands/teams_invitations.clj Normal file
View File

@ -0,0 +1,573 @@
;; 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.teams-invitations
(:require
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.features :as cfeat]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.types.team :as types.team]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as sql]
[app.email :as eml]
[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]
[app.rpc.helpers :as rph]
[app.rpc.quotes :as quotes]
[app.setup :as-alias setup]
[app.tokens :as tokens]
[app.util.services :as sv]
[app.util.time :as dt]
[cuerdas.core :as str]))
;; --- Mutation: Create Team Invitation
(def sql:upsert-team-invitation
"insert into team_invitation(id, team_id, email_to, created_by, role, valid_until)
values (?, ?, ?, ?, ?, ?)
on conflict(team_id, email_to) do
update set role = ?, valid_until = ?, updated_at = now()
returning *")
(defn- create-invitation-token
[cfg {:keys [profile-id valid-until team-id member-id member-email role]}]
(tokens/generate (::setup/props cfg)
{:iss :team-invitation
:exp valid-until
:profile-id profile-id
:role role
:team-id team-id
:member-email member-email
:member-id member-id}))
(defn- create-profile-identity-token
[cfg profile-id]
(dm/assert!
"expected valid uuid for profile-id"
(uuid? profile-id))
(tokens/generate (::setup/props cfg)
{:iss :profile-identity
:profile-id profile-id
:exp (dt/in-future {:days 30})}))
(def ^:private schema:create-invitation
[:map {:title "params:create-invitation"}
[::rpc/profile-id ::sm/uuid]
[:team
[:map
[:id ::sm/uuid]
[:name :string]]]
[:profile
[:map
[:id ::sm/uuid]
[:fullname :string]]]
[:role ::types.team/role]
[:email ::sm/email]])
(def ^:private check-create-invitation-params!
(sm/check-fn schema:create-invitation))
(defn- create-invitation
[{:keys [::db/conn] :as cfg} {:keys [team profile role email] :as params}]
(dm/assert!
"expected valid connection on cfg parameter"
(db/connection? conn))
(dm/assert!
"expected valid params for `create-invitation` fn"
(check-create-invitation-params! params))
(let [email (profile/clean-email email)
member (profile/get-profile-by-email conn email)]
(teams/check-profile-muted conn member)
(teams/check-email-bounce conn email true)
(teams/check-email-spam conn email true)
;; When we have email verification disabled and invitation user is
;; already present in the database, we proceed to add it to the
;; team as-is, without email roundtrip.
;; TODO: if member does not exists and email verification is
;; disabled, we should proceed to create the profile (?)
(if (and (not (contains? cf/flags :email-verification))
(some? member))
(let [params (merge {:team-id (:id team)
:profile-id (:id member)}
(get types.team/permissions-for-role role))]
;; Insert the invited member to the team
(db/insert! conn :team-profile-rel params
{::db/on-conflict-do-nothing? true})
;; If profile is not yet verified, mark it as verified because
;; accepting an invitation link serves as verification.
(when-not (:is-active member)
(db/update! conn :profile
{:is-active true}
{:id (:id member)}))
nil)
(let [id (uuid/next)
expire (dt/in-future "168h") ;; 7 days
invitation (db/exec-one! conn [sql:upsert-team-invitation id
(:id team) (str/lower email)
(:id profile)
(name role) expire
(name role) expire])
updated? (not= id (:id invitation))
profile-id (:id profile)
tprops {:profile-id profile-id
:invitation-id (:id invitation)
:valid-until expire
:team-id (:id team)
:member-email (:email-to invitation)
:member-id (:id member)
:role role}
itoken (create-invitation-token cfg tprops)
ptoken (create-profile-identity-token cfg profile-id)]
(when (contains? cf/flags :log-invitation-tokens)
(l/info :hint "invitation token" :token itoken))
(let [props (-> (dissoc tprops :profile-id)
(audit/clean-props))
evname (if updated?
"update-team-invitation"
"create-team-invitation")
event (-> (audit/event-from-rpc-params params)
(assoc ::audit/name evname)
(assoc ::audit/props props))]
(audit/submit! cfg event))
(eml/send! {::eml/conn conn
::eml/factory eml/invite-to-team
:public-uri (cf/get :public-uri)
:to email
:invited-by (:fullname profile)
:team (:name team)
:token itoken
:extra-data ptoken})
itoken))))
(defn- add-user-to-team
[conn profile team role email]
(let [team-id (:id team)
member (db/get* conn :profile
{:email (str/lower email)}
{::sql/columns [:id :email]})
params (merge
{:team-id team-id
:profile-id (:id member)}
(get types.team/permissions-for-role role))]
;; Do not allow blocked users to join teams.
(when (:is-blocked member)
(ex/raise :type :restriction
:code :profile-blocked))
(quotes/check!
{::db/conn conn
::quotes/id ::quotes/profiles-per-team
::quotes/profile-id (:id member)
::quotes/team-id team-id})
;; Insert the member to the team
(db/insert! conn :team-profile-rel params {::db/on-conflict-do-nothing? true})
;; Delete any request
(db/delete! conn :team-access-request
{:team-id team-id :requester-id (:id member)})
;; Delete any invitation
(db/delete! conn :team-invitation
{:team-id team-id :email-to (:email member)})
(eml/send! {::eml/conn conn
::eml/factory eml/join-team
:public-uri (cf/get :public-uri)
:to email
:invited-by (:fullname profile)
:team (:name team)
:team-id (:id team)})))
(def sql:valid-requests-email
"SELECT p.email
FROM team_access_request AS tr
JOIN profile AS p ON (tr.requester_id = p.id)
WHERE tr.team_id = ?
AND tr.auto_join_until > now()")
(defn- get-valid-requests-email
[conn team-id]
(db/exec! conn [sql:valid-requests-email team-id]))
(def ^:private xf:map-email
(map :email))
(defn- create-team-invitations
[{:keys [::db/conn] :as cfg} {:keys [profile team role emails] :as params}]
(let [join-requests (into #{} xf:map-email
(get-valid-requests-email conn (:id team)))
team-members (into #{} xf:map-email
(teams/get-team-members conn (:id team)))
invitations (into #{}
(comp
;; We don't re-send inviation to
;; already existing members
(remove team-members)
;; 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)]
;; For requested invitations, do not send invitation emails, add
;; the user directly to the team
(->> (filter join-requests emails)
(run! (partial add-user-to-team conn profile team role)))
invitations))
(def ^:private schema:create-team-invitations
[:map {:title "create-team-invitations"}
[:team-id ::sm/uuid]
[:role ::types.team/role]
[:emails [::sm/set ::sm/email]]])
(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."
{::doc/added "1.17"
::doc/module :teams
::sm/params schema:create-team-invitations}
[cfg {:keys [::rpc/profile-id team-id 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)]
(when-not (:is-admin perms)
(ex/raise :type :validation
:code :insufficient-permissions))
(when (> (count emails) max-invitations-by-request-threshold)
(ex/raise :type :validation
:code :max-invitations-by-request
:hint "the maximum of invitation on single request is reached"
:threshold max-invitations-by-request-threshold))
(-> cfg
(assoc ::quotes/profile-id profile-id)
(assoc ::quotes/team-id team-id)
(assoc ::quotes/incr (count emails))
(quotes/check! {::quotes/id ::quotes/invitations-per-team}
{::quotes/id ::quotes/profiles-per-team}))
;; Check if the current profile is allowed to send emails
(teams/check-profile-muted cfg profile)
(let [team (db/get-by-id cfg :team team-id)
;; NOTE: Is important pass RPC method params down to the
;; `create-team-invitations` because it uses the implicit
;; RPC properties from params for fill necessary data on
;; emiting an entry to the audit-log
invitations (db/tx-run! cfg create-team-invitations
(-> params
(assoc :profile profile)
(assoc :team team)
(assoc :emails emails)))]
(with-meta {:total (count invitations)
:invitations invitations}
{::audit/props {:invitations (count invitations)}}))))
;; --- Mutation: Create Team & Invite Members
(def ^:private schema:create-team-with-invitations
[:map {:title "create-team-with-invitations"}
[:name [:string {:max 250}]]
[:features {:optional true} ::cfeat/features]
[:id {:optional true} ::sm/uuid]
[:emails [::sm/set ::sm/email]]
[:role ::types.team/role]])
(sv/defmethod ::create-team-with-invitations
{::doc/added "1.17"
::doc/module :teams
::sm/params schema:create-team-with-invitations
::db/transaction true}
[{:keys [::db/conn] :as cfg} {:keys [::rpc/profile-id emails role name] :as params}]
(let [features (-> (cfeat/get-enabled-features cf/flags)
(cfeat/check-client-features! (:features params)))
params (-> params
(assoc :profile-id profile-id)
(assoc :features features))
team (teams/create-team cfg params)
emails (into #{} (map profile/clean-email) emails)]
(-> cfg
(assoc ::quotes/profile-id profile-id)
(assoc ::quotes/team-id (:id team))
(assoc ::quotes/incr (count emails))
(quotes/check! {::quotes/id ::quotes/teams-per-profile}
{::quotes/id ::quotes/invitations-per-team}
{::quotes/id ::quotes/profiles-per-team}))
(when (> (count emails) max-invitations-by-request-threshold)
(ex/raise :type :validation
:code :max-invitations-by-request
:hint "the maximum of invitation on single request is reached"
:threshold max-invitations-by-request-threshold))
(let [props {:name name :features features}
event (-> (audit/event-from-rpc-params params)
(assoc ::audit/name "create-team")
(assoc ::audit/props props))]
(audit/submit! cfg event))
;; Create invitations for all provided emails.
(let [profile (db/get-by-id conn :profile profile-id)
params (-> params
(assoc :team team)
(assoc :profile profile)
(assoc :role role))
invitations (->> emails
(map (fn [email] (assoc params :email email)))
(map (partial create-invitation cfg)))]
(vary-meta team assoc ::audit/props {:invitations (count invitations)}))))
;; --- Query: get-team-invitation-token
(def ^:private schema:get-team-invitation-token
[:map {:title "get-team-invitation-token"}
[:team-id ::sm/uuid]
[:email ::sm/email]])
(sv/defmethod ::get-team-invitation-token
{::doc/added "1.17"
::doc/module :teams
::sm/params schema:get-team-invitation-token}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id email] :as params}]
(teams/check-read-permissions! pool profile-id team-id)
(let [email (profile/clean-email email)
invit (-> (db/get pool :team-invitation
{:team-id team-id
:email-to email})
(update :role keyword))
member (profile/get-profile-by-email pool (:email-to invit))
token (create-invitation-token cfg {:team-id (:team-id invit)
:profile-id profile-id
:valid-until (:valid-until invit)
:role (:role invit)
:member-id (:id member)
:member-email (or (:email member)
(profile/clean-email (:email-to invit)))})]
{:token token}))
;; --- Mutation: Update invitation role
(def ^:private schema:update-team-invitation-role
[:map {:title "update-team-invitation-role"}
[:team-id ::sm/uuid]
[:email ::sm/email]
[:role ::types.team/role]])
(sv/defmethod ::update-team-invitation-role
{::doc/added "1.17"
::doc/module :teams
::sm/params schema:update-team-invitation-role}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id email role] :as params}]
(db/with-atomic [conn pool]
(let [perms (teams/get-permissions conn profile-id team-id)]
(when-not (:is-admin perms)
(ex/raise :type :validation
:code :insufficient-permissions))
(db/update! conn :team-invitation
{:role (name role) :updated-at (dt/now)}
{:team-id team-id :email-to (profile/clean-email email)})
nil)))
;; --- Mutation: Delete invitation
(def ^:private schema:delete-team-invition
[:map {:title "delete-team-invitation"}
[:team-id ::sm/uuid]
[:email ::sm/email]])
(sv/defmethod ::delete-team-invitation
{::doc/added "1.17"
::sm/params schema:delete-team-invition}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id email] :as params}]
(db/with-atomic [conn pool]
(let [perms (teams/get-permissions conn profile-id team-id)]
(when-not (:is-admin perms)
(ex/raise :type :validation
:code :insufficient-permissions))
(let [invitation (db/delete! conn :team-invitation
{:team-id team-id
:email-to (profile/clean-email email)}
{::db/return-keys true})]
(rph/wrap nil {::audit/props {:invitation-id (:id invitation)}})))))
;; --- Mutation: Request Team Invitation
(def ^:private sql:get-team-owner
"SELECT p.*
FROM profile AS p
JOIN team_profile_rel AS tpr ON (tpr.profile_id = p.id)
WHERE tpr.team_id = ?
AND tpr.is_owner IS TRUE")
(defn- get-team-owner
"Return a complete profile of the team owner"
[conn team-id]
(->> (db/exec! conn [sql:get-team-owner team-id])
(remove db/is-row-deleted?)
(map profile/decode-row)
(first)))
(defn- check-existing-team-access-request
"Checks if an existing team access request is still valid"
[conn team-id profile-id]
(when-let [request (db/get* conn :team-access-request
{:team-id team-id
:requester-id profile-id})]
(when (dt/is-after? (:valid-until request) (dt/now))
(ex/raise :type :validation
:code :request-already-sent
:hint "you have already made a request to join this team less than 24 hours ago"))))
(def ^:private sql:upsert-team-access-request
"INSERT INTO team_access_request (id, team_id, requester_id, valid_until, auto_join_until)
VALUES (?, ?, ?, ?, ?)
ON CONFLICT (team_id, requester_id)
DO UPDATE SET valid_until = ?, auto_join_until = ?, updated_at = now()
RETURNING *")
(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)
(let [valid-until (dt/in-future {:hours 24})
auto-join-until (dt/in-future {:days 7})
request-id (uuid/next)]
(db/exec-one! conn [sql:upsert-team-access-request
request-id team-id requester-id
valid-until auto-join-until
valid-until auto-join-until])))
(defn- get-file-for-team-access-request
"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)]
(-> file
(dissoc :data)
(dissoc :deleted-at)
(assoc :page-id (-> file :data :pages first)))))
(def ^:private schema:create-team-access-request
[:and
[:map {:title "create-team-access-request"}
[:file-id {:optional true} ::sm/uuid]
[:team-id {:optional true} ::sm/uuid]
[:is-viewer {:optional true} ::sm/boolean]]
[:fn (fn [params]
(or (contains? params :file-id)
(contains? params :team-id)))]])
(sv/defmethod ::create-team-access-request
"A rpc call that allow to request for an invitations to join the team."
{::doc/added "2.2.0"
::doc/module :teams
::sm/params schema:create-team-access-request
::db/transaction true}
[{:keys [::db/conn] :as cfg}
{:keys [::rpc/profile-id file-id team-id is-viewer] :as params}]
(let [requester (profile/get-profile conn profile-id)
team (if team-id
(->> (db/get-by-id conn :team team-id)
(teams/decode-row))
(teams/get-team-for-file conn file-id))
team-id (:id team)
team-owner (get-team-owner conn team-id)
file (when (some? file-id)
(get-file-for-team-access-request cfg file-id))
request (upsert-team-access-request conn team-id profile-id)]
;; FIXME missing quotes
(teams/check-profile-muted conn requester)
(teams/check-email-bounce conn (:email team-owner) false)
(teams/check-email-spam conn (:email team-owner) true)
(let [factory (cond
(and (some? file) (:is-default team) is-viewer)
eml/request-file-access-yourpenpot-view
(and (some? file) (:is-default team))
eml/request-file-access-yourpenpot
(some? file)
eml/request-file-access
:else
eml/request-team-access)]
(eml/send! {::eml/conn conn
::eml/factory factory
:public-uri (cf/get :public-uri)
:to (:email team-owner)
:requested-by (:fullname requester)
:requested-by-email (:email requester)
:team-name (:name team)
:team-id team-id
:file-name (:name file)
:file-id file-id
:page-id (:page-id file)}))
(with-meta {:request request}
{::audit/props {:request 1}})))

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

@ -8,6 +8,7 @@
(:require
[app.common.exceptions :as ex]
[app.common.schema :as sm]
[app.common.types.team :as types.team]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as-alias sql]
@ -16,7 +17,6 @@
[app.main :as-alias main]
[app.rpc :as-alias rpc]
[app.rpc.commands.profile :as profile]
[app.rpc.commands.teams :as teams]
[app.rpc.doc :as-alias doc]
[app.rpc.helpers :as rph]
[app.rpc.quotes :as quotes]
@ -92,7 +92,7 @@
params (merge
{:team-id team-id
:profile-id (:id member)}
(teams/role->params role))]
(get types.team/permissions-for-role role))]
;; Do not allow blocked users accept invitations.
(when (:is-blocked member)
@ -128,7 +128,7 @@
[:iss :keyword]
[:exp ::dt/instant]
[:profile-id ::sm/uuid]
[:role teams/schema:role]
[:role ::types.team/role]
[:team-id ::sm/uuid]
[:member-email ::sm/email]
[:member-id {:optional true} ::sm/uuid]])
@ -167,12 +167,24 @@
(let [props {:team-id (:team-id claims)
:role (:role claims)
:invitation-id (:id invitation)}
event (-> (audit/event-from-rpc-params params)
(assoc ::audit/name "accept-team-invitation")
(assoc ::audit/props props))]
accept-invitation-event
(-> (audit/event-from-rpc-params params)
(assoc ::audit/name "accept-team-invitation")
(assoc ::audit/props props))
accept-invitation-from-event
(-> (audit/event-from-rpc-params params)
(assoc ::audit/profile-id (:created-by invitation))
(assoc ::audit/name "accept-team-invitation-from")
(assoc ::audit/props (assoc props
:profile-id (:id profile)
:email (:email profile))))]
(audit/submit! cfg accept-invitation-event)
(audit/submit! cfg accept-invitation-from-event)
(accept-invitation cfg claims invitation profile)
(audit/submit! cfg event)
(assoc claims :state :created))
(ex/raise :type :validation

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

@ -15,12 +15,27 @@
[app.http.client :as http]
[app.loggers.webhooks :as webhooks]
[app.rpc :as-alias rpc]
[app.rpc.commands.teams :refer [check-edition-permissions! check-read-permissions!]]
[app.rpc.commands.teams :refer [check-read-permissions!] :as t]
[app.rpc.doc :as-alias doc]
[app.rpc.permissions :as perms]
[app.util.services :as sv]
[app.util.time :as dt]
[cuerdas.core :as str]))
(defn get-webhooks-permissions
[conn profile-id team-id creator-id]
(let [permissions (t/get-permissions conn profile-id team-id)
can-edit (boolean (or (:can-edit permissions)
(= profile-id creator-id)))]
(assoc permissions :can-edit can-edit)))
(def has-webhook-edit-permissions?
(perms/make-edition-predicate-fn get-webhooks-permissions))
(def check-webhook-edition-permissions!
(perms/make-check-fn has-webhook-edit-permissions?))
(defn decode-row
[{:keys [uri] :as row}]
(cond-> row
@ -65,11 +80,12 @@
max-hooks-for-team)))))
(defn- insert-webhook!
[{:keys [::db/pool]} {:keys [team-id uri mtype is-active] :as params}]
[{:keys [::db/pool]} {:keys [team-id uri mtype is-active ::rpc/profile-id] :as params}]
(-> (db/insert! pool :webhook
{:id (uuid/next)
:team-id team-id
:uri (str uri)
:profile-id profile-id
:is-active is-active
:mtype mtype})
(decode-row)))
@ -101,7 +117,7 @@
{::doc/added "1.17"
::sm/params schema:create-webhook}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id] :as params}]
(check-edition-permissions! pool profile-id team-id)
(check-webhook-edition-permissions! pool profile-id team-id profile-id)
(validate-quotes! cfg params)
(validate-webhook! cfg nil params)
(insert-webhook! cfg params))
@ -118,7 +134,7 @@
::sm/params schema:update-webhook}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id] :as params}]
(let [whook (-> (db/get pool :webhook {:id id}) (decode-row))]
(check-edition-permissions! pool profile-id (:team-id whook))
(check-webhook-edition-permissions! pool profile-id (:team-id whook) (:profile-id whook))
(validate-webhook! cfg whook params)
(update-webhook! cfg whook params)))
@ -132,15 +148,17 @@
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id]}]
(db/with-atomic [conn pool]
(let [whook (-> (db/get conn :webhook {:id id}) decode-row)]
(check-edition-permissions! conn profile-id (:team-id whook))
(check-webhook-edition-permissions! conn profile-id (:team-id whook) (:profile-id whook))
(db/delete! conn :webhook {:id id})
nil)))
;; --- Query: Webhooks
(def sql:get-webhooks
"select id, uri, mtype, is_active, error_code, error_count
from webhook where team_id = ? order by uri")
"SELECT id, uri, mtype, is_active, error_code, error_count, profile_id
FROM webhook
WHERE team_id = ?
ORDER BY uri")
(def ^:private schema:get-webhooks
[:map {:title "get-webhooks"}

21
backend/src/app/rpc/cond.clj
View File

@ -29,7 +29,7 @@
[app.util.services :as-alias sv]
[buddy.core.codecs :as bc]
[buddy.core.hash :as bh]
[ring.response :as-alias rres]))
[yetti.response :as-alias yres]))
(def
^{:dynamic true
@ -48,20 +48,25 @@
(str "W/\"" (encode s) "\""))
(defn wrap
[_ f {:keys [::get-object ::key-fn ::reuse-key?] :as mdata}]
[_ f {:keys [::get-object ::key-fn ::reuse-key?] :or {reuse-key? true} :as mdata}]
(if (and (ifn? get-object) (ifn? key-fn))
(do
(l/trc :hint "instrumenting method" :service (::sv/name mdata))
(fn [cfg {:keys [::key] :as params}]
(if *enabled*
(let [key' (when (or key reuse-key?)
(some->> (get-object cfg params) (key-fn params) (fmt-key)))]
(let [object (when (some? key)
(get-object cfg params))
key' (when (some? object)
(->> object (key-fn params) (fmt-key)))]
(if (and (some? key) (= key key'))
(fn [_] {::rres/status 304})
(let [result (f cfg params)
(fn [_] {::yres/status 304})
(let [params (if (some? object)
(assoc params ::object object)
params)
result (f cfg params)
etag (or (and reuse-key? key')
(some-> result meta ::key fmt-key)
(some-> result key-fn fmt-key))]
(some->> result meta ::key fmt-key)
(some->> result (key-fn params) fmt-key))]
(rph/with-header result "etag" etag))))
(f cfg params))))
f))

31
backend/src/app/rpc/doc.clj
View File

@ -27,7 +27,7 @@
[cuerdas.core :as str]
[integrant.core :as ig]
[pretty-spec.core :as ps]
[ring.response :as-alias rres]))
[yetti.response :as-alias yres]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DOC (human readable)
@ -87,11 +87,11 @@
(let [params (:query-params request)
pstyle (:type params "js")
context (assoc context :param-style pstyle)]
{::rres/status 200
::rres/body (-> (io/resource "app/templates/api-doc.tmpl")
{::yres/status 200
::yres/body (-> (io/resource "app/templates/api-doc.tmpl")
(tmpl/render context))}))
(fn [_]
{::rres/status 404})))
{::yres/status 404})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OPENAPI / SWAGGER (v3.1)
@ -175,12 +175,12 @@
[context]
(if (contains? cf/flags :backend-openapi-doc)
(fn [_]
{::rres/status 200
::rres/headers {"content-type" "application/json; charset=utf-8"}
::rres/body (json/encode context)})
{::yres/status 200
::yres/headers {"content-type" "application/json; charset=utf-8"}
::yres/body (json/encode context)})
(fn [_]
{::rres/status 404})))
{::yres/status 404})))
(defn openapi-handler
[]
@ -191,21 +191,20 @@
context {:public-uri (cf/get :public-uri)
:swagger-js swagger-js
:swagger-css swagger-cs}]
{::rres/status 200
::rres/headers {"content-type" "text/html"}
::rres/body (-> (io/resource "app/templates/openapi.tmpl")
{::yres/status 200
::yres/headers {"content-type" "text/html"}
::yres/body (-> (io/resource "app/templates/openapi.tmpl")
(tmpl/render context))}))
(fn [_]
{::rres/status 404})))
{::yres/status 404})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MODULE INIT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::routes vector?)
(defmethod ig/pre-init-spec ::routes [_]
(s/keys :req-un [::rpc/methods]))
(defmethod ig/assert-key ::routes
[_ params]
(assert (sm/valid? ::rpc/methods (::rpc/methods params)) "expected valid methods"))
(defmethod ig/init-key ::routes
[_ {:keys [methods] :as cfg}]

4
backend/src/app/rpc/helpers.clj
View File

@ -11,7 +11,7 @@
[app.common.data.macros :as dm]
[app.http :as-alias http]
[app.rpc :as-alias rpc]
[ring.response :as-alias rres]))
[yetti.response :as-alias yres]))
;; A utilty wrapper object for wrap service responses that does not
;; implements the IObj interface that make possible attach metadata to
@ -77,4 +77,4 @@
(fn [_ response]
(let [exp (if (integer? max-age) max-age (inst-ms max-age))
val (dm/fmt "max-age=%" (int (/ exp 1000.0)))]
(update response ::rres/headers assoc "cache-control" val)))))
(update response ::yres/headers assoc "cache-control" val)))))

35
backend/src/app/rpc/permissions.clj
View File

@ -8,25 +8,24 @@
"A permission checking helper factories."
(:require
[app.common.exceptions :as ex]
[app.common.schema :as sm]
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
[app.common.schema :as sm]))
(sm/register! ::permissions
[:map {:title "Permissions"}
[:type {:gen/elements [:membership :share-link]} :keyword]
[:is-owner ::sm/boolean]
[:is-admin ::sm/boolean]
[:can-edit ::sm/boolean]
[:can-read ::sm/boolean]
[:is-logged ::sm/boolean]])
(sm/register!
^{::sm/type ::permissions}
[:map {:title "Permissions"}
[:type {:gen/elements [:membership :share-link]} :keyword]
[:is-owner ::sm/boolean]
[:is-admin ::sm/boolean]
[:can-edit ::sm/boolean]
[:can-read ::sm/boolean]
[:is-logged ::sm/boolean]])
(s/def ::role #{:admin :owner :editor :viewer})
(def valid-roles
#{:admin :owner :editor :viewer})
(defn assign-role-flags
[params role]
(us/verify ::role role)
(assert (contains? valid-roles role) "expected a valid role")
(cond-> params
(= role :owner)
(assoc :is-owner true
@ -51,7 +50,7 @@
(defn make-admin-predicate-fn
"A simple factory for admin permission predicate functions."
[qfn]
(us/assert fn? qfn)
(assert (fn? qfn) "expected a function")
(fn check
([perms] (:is-admin perms))
([conn & args] (check (apply qfn conn args)))))
@ -59,7 +58,7 @@
(defn make-edition-predicate-fn
"A simple factory for edition permission predicate functions."
[qfn]
(us/assert fn? qfn)
(assert (fn? qfn) "expected a function")
(fn check
([perms] (:can-edit perms))
([conn & args] (check (apply qfn conn args)))))
@ -67,7 +66,7 @@
(defn make-read-predicate-fn
"A simple factory for read permission predicate functions."
[qfn]
(us/assert fn? qfn)
(assert (fn? qfn) "expected a function")
(fn check
([perms] (:can-read perms))
([conn & args] (check (apply qfn conn args)))))
@ -75,7 +74,7 @@
(defn make-comment-predicate-fn
"A simple factory for comment permission predicate functions."
[qfn]
(us/assert fn? qfn)
(assert (fn? qfn) "expected a function")
(fn check
([perms]
(and (:is-logged perms) (= (:who-comment perms) "all")))

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

@ -408,6 +408,70 @@
(assoc ::count-sql [sql:get-comments-per-file file-id])
(generic-check!)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; QUOTE: SNAPSHOTS-PER-FILE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:private schema:snapshots-per-file
[:map
[::profile-id ::sm/uuid]
[::project-id ::sm/uuid]
[::team-id ::sm/uuid]
[::file-id ::sm/uuid]])
(def ^:private valid-snapshots-per-file-quote?
(sm/lazy-validator schema:snapshots-per-file))
(def ^:private sql:get-snapshots-per-file
"SELECT count(*) AS total
FROM file_change AS fc
WHERE fc.file_id = ?
AND fc.created_by = 'user'
AND fc.deleted_at IS NULL
AND fc.data IS NOT NULL")
(defmethod check-quote ::snapshots-per-file
[{:keys [::profile-id ::file-id ::team-id ::project-id ::target] :as quote}]
(assert (valid-snapshots-per-file-quote? quote) "invalid quote parameters")
(-> quote
(assoc ::default (cf/get :quotes-snapshots-per-file Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-4 target file-id profile-id project-id
profile-id team-id profile-id profile-id])
(assoc ::count-sql [sql:get-snapshots-per-file file-id])
(generic-check!)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; QUOTE: SNAPSHOTS-PER-FILE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:private schema:snapshots-per-team
[:map
[::profile-id ::sm/uuid]
[::team-id ::sm/uuid]])
(def ^:private valid-snapshots-per-team-quote?
(sm/lazy-validator schema:snapshots-per-team))
(def ^:private sql:get-snapshots-per-team
"SELECT count(*) AS total
FROM file_change AS fc
JOIN file AS f ON (f.id = fc.file_id)
JOIN project AS p ON (p.id = f.project_id)
WHERE p.team_id = ?
AND fc.created_by = 'user'
AND fc.deleted_at IS NULL
AND fc.data IS NOT NULL")
(defmethod check-quote ::snapshots-per-team
[{:keys [::profile-id ::team-id ::target] :as quote}]
(assert (valid-snapshots-per-team-quote? quote) "invalid quote parameters")
(-> quote
(assoc ::default (cf/get :quotes-snapshots-per-team Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-2 target team-id profile-id profile-id])
(assoc ::count-sql [sql:get-snapshots-per-team team-id])
(generic-check!)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; QUOTE: DEFAULT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

@ -46,7 +46,7 @@
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.uri :as uri]
[app.common.uuid :as uuid]
[app.config :as cf]
@ -61,7 +61,6 @@
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.edn :as edn]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[datoteka.fs :as fs]
[integrant.core :as ig]
@ -95,9 +94,46 @@
(defmulti parse-limit (fn [[_ strategy _]] strategy))
(defmulti process-limit (fn [_ _ _ o] (::strategy o)))
(sm/register!
{:type ::rpc/rlimit
:pred #(instance? clojure.lang.Agent %)})
(def ^:private schema:strategy
[:enum :window :bucket])
(def ^:private schema:limit-tuple
[:tuple :keyword schema:strategy :string])
(def ^:private schema:limit
[:and
[:map
[::name :any]
[::strategy schema:strategy]
[::key :string]
[::opts :string]]
[:or
[:map
[::capacity ::sm/int]
[::rate ::sm/int]
[::internal ::dt/duration]
[::params [::sm/vec :any]]]
[:map
[::nreq ::sm/int]
[::unit [:enum :days :hours :minutes :seconds :weeks]]]]])
(def ^:private schema:limits
[:map-of :keyword [::sm/vec schema:limit]])
(def ^:private valid-limit-tuple?
(sm/lazy-validator schema:limit-tuple))
(def ^:private valid-rlimit-instance?
(sm/lazy-validator ::rpc/rlimit))
(defmethod parse-limit :window
[[name strategy opts :as vlimit]]
(us/assert! ::limit-tuple vlimit)
(assert (valid-limit-tuple? vlimit) "expected valid limit tuple")
(merge
{::name name
::strategy strategy}
@ -118,7 +154,8 @@
(defmethod parse-limit :bucket
[[name strategy opts :as vlimit]]
(us/assert! ::limit-tuple vlimit)
(assert (valid-limit-tuple? vlimit) "expected valid limit tuple")
(if-let [[_ capacity rate interval] (re-find bucket-opts-re opts)]
(let [interval (dt/duration interval)
rate (parse-long rate)
@ -140,7 +177,7 @@
(let [script (-> bucket-rate-limit-script
(assoc ::rscript/keys [(str key "." service "." user-id)])
(assoc ::rscript/vals (conj params (dt/->seconds now))))
result (rds/eval! redis script)
result (rds/eval redis script)
allowed? (boolean (nth result 0))
remaining (nth result 1)
reset (* (/ (inst-ms interval) rate)
@ -164,7 +201,7 @@
script (-> window-rate-limit-script
(assoc ::rscript/keys [(str key "." service "." user-id "." (dt/format-instant ts))])
(assoc ::rscript/vals [nreq (dt/->seconds ttl)]))
result (rds/eval! redis script)
result (rds/eval redis script)
allowed? (boolean (nth result 0))
remaining (nth result 1)]
(l/trace :hint "limit processed"
@ -245,8 +282,8 @@
(defn wrap
[{:keys [::rpc/rlimit ::rds/redis] :as cfg} f mdata]
(us/assert! ::rpc/rlimit rlimit)
(us/assert! ::rds/redis redis)
(assert (rds/redis? redis) "expected a valid redis instance")
(assert (or (nil? rlimit) (valid-rlimit-instance? rlimit)) "expected a valid rlimit instance")
(if rlimit
(let [skey (keyword (::rpc/type cfg) (->> mdata ::sv/spec name))
@ -275,42 +312,19 @@
;; CONFIG WATCHER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::strategy (s/and ::us/keyword #{:window :bucket}))
(s/def ::capacity ::us/integer)
(s/def ::rate ::us/integer)
(s/def ::interval ::dt/duration)
(s/def ::key ::us/string)
(s/def ::opts ::us/string)
(s/def ::params vector?)
(s/def ::unit #{:days :hours :minutes :seconds :weeks})
(s/def ::nreq ::us/integer)
(s/def ::refresh ::dt/duration)
(def ^:private schema:config
[:map-of
[:or :keyword [:set :keyword]]
[:vector schema:limit-tuple]])
(s/def ::limit-tuple
(s/tuple ::us/keyword ::strategy string?))
(def ^:private check-config
(sm/check-fn schema:config))
(s/def ::limits
(s/map-of keyword? (s/every ::limit :kind vector?)))
(def ^:private check-refresh
(sm/check-fn ::dt/duration))
(s/def ::limit
(s/and
(s/keys :req [::name ::strategy ::key ::opts])
(s/or :bucket
(s/keys :req [::capacity
::rate
::interval
::params])
:window
(s/keys :req [::nreq
::unit]))))
(s/def ::rpc/rlimit
(s/nilable
#(instance? clojure.lang.Agent %)))
(s/def ::config
(s/map-of (s/or :kw keyword? :set set?)
(s/every ::limit-tuple :kind vector?)))
(def ^:private check-limits
(sm/check-fn schema:limits))
(defn read-config
[path]
@ -336,13 +350,9 @@
{}
config)))]
(when-let [config (some->> path slurp edn/read-string)]
(us/verify! ::config config)
(let [refresh (->> config meta :refresh dt/duration)
limits (->> config compile-pass-1 compile-pass-2)]
(us/verify! ::limits limits)
(us/verify! ::refresh refresh)
(when-let [config (some->> path slurp edn/read-string check-config)]
(let [refresh (->> config meta :refresh dt/duration check-refresh)
limits (->> config compile-pass-1 compile-pass-2 check-limits)]
{::refresh refresh
::limits limits}))))
@ -385,8 +395,9 @@
(when-let [path (cf/get :rpc-rlimit-config)]
(and (fs/exists? path) (fs/regular-file? path) path)))
(defmethod ig/pre-init-spec :app.rpc/rlimit [_]
(s/keys :req [::wrk/executor]))
(defmethod ig/assert-key :app.rpc/rlimit
[_ {:keys [::wrk/executor]}]
(assert (sm/valid? ::wrk/executor executor) "expect valid executor"))
(defmethod ig/init-key ::rpc/rlimit
[_ {:keys [::wrk/executor] :as cfg}]

17
backend/src/app/setup.clj
View File

@ -9,7 +9,7 @@
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.uuid :as uuid]
[app.db :as db]
[app.main :as-alias main]
@ -17,7 +17,6 @@
[app.setup.templates]
[buddy.core.codecs :as bc]
[buddy.core.nonce :as bn]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(defn- generate-random-key
@ -73,12 +72,10 @@
(db/run! system (fn [{:keys [::db/conn]}]
(db/exec-one! conn [sql:add-prop prop value false value false])))))
(s/def ::key ::us/string)
(s/def ::props (s/map-of ::us/keyword some?))
(defmethod ig/pre-init-spec ::props [_]
(s/keys :req [::db/pool]
:opt [::key]))
(defmethod ig/assert-key ::props
[_ params]
(assert (db/pool? (::db/pool params)) "expected valid database pool")
(assert (string? (::key params)) "expected valid key string"))
(defmethod ig/init-key ::props
[_ {:keys [::db/pool ::key] :as cfg}]
@ -94,3 +91,7 @@
(assoc :secret-key secret)
(assoc :tokens-key (keys/derive secret :salt "tokens"))
(update :instance-id handle-instance-id conn (db/read-only? pool))))))
;; FIXME
(sm/register! ::props :any)

5
backend/src/app/setup/welcome_file.clj
View File

@ -10,6 +10,7 @@
[app.db :as db]
[app.rpc :as-alias rpc]
[app.rpc.climit :as-alias climit]
[app.rpc.commands.files :as files]
[app.rpc.commands.files-update :as fupdate]
[app.rpc.commands.management :as management]
[app.rpc.commands.profile :as profile]
@ -51,9 +52,11 @@
:project-id (:default-project-id profile)}
template-stream (tmpl/get-template-stream cfg "welcome")
file-id (-> (management/clone-template cfg params template-stream)
first)]
first)
file-name (str fullname "'s first file")]
(db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
(files/rename-file conn {:id file-id :name file-name})
(fupdate/update-file! cfg file-id update-welcome-shape fullname)
(profile/update-profile-props cfg id {:welcome-file-id file-id})
(db/exec-one! conn [sql:mark-file-object-thumbnails-deleted file-id])

18
backend/src/app/srepl.clj
View File

@ -8,7 +8,6 @@
"Server Repl."
(:require
[app.common.logging :as l]
[app.common.spec :as us]
[app.config :as cf]
[app.srepl.cli]
[app.srepl.main]
@ -16,7 +15,6 @@
[app.util.locks :as locks]
[clojure.core.server :as ccs]
[clojure.main :as cm]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(defn- repl-init
@ -44,16 +42,14 @@
;; --- State initialization
(s/def ::port ::us/integer)
(s/def ::host ::us/not-empty-string)
(defmethod ig/assert-key ::server
[_ params]
(assert (int? (::port params)) "expected valid port")
(assert (string? (::host params)) "expected valid host"))
(defmethod ig/pre-init-spec ::server
[_]
(s/keys :req [::host ::port]))
(defmethod ig/prep-key ::server
[[type _] cfg]
(assoc cfg ::flag (keyword (str (name type) "-server"))))
(defmethod ig/expand-key ::server
[[type :as k] v]
{k (assoc v ::flag (keyword (str (name type) "-server")))})
(defmethod ig/init-key ::server
[[type _] {:keys [::flag ::port ::host] :as cfg}]

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

@ -122,22 +122,19 @@
WHERE file_id = ANY(?)
AND id IS NOT NULL")
(defn get-file-snapshots
(defn search-file-snapshots
"Get a seq parirs of file-id and snapshot-id for a set of files
and specified label"
[conn label ids]
[conn file-ids label]
(db/exec! conn [sql:snapshots-with-file label
(db/create-array conn "uuid" ids)]))
(db/create-array conn "uuid" file-ids)]))
(defn take-team-snapshot!
[system team-id label]
(let [conn (db/get-connection system)]
(->> (feat.comp-v2/get-and-lock-team-files conn team-id)
(map (fn [file-id]
{:file-id file-id
:label label}))
(reduce (fn [result params]
(fsnap/take-file-snapshot! conn params)
(reduce (fn [result file-id]
(fsnap/create-file-snapshot! system nil file-id label)
(inc result))
0))))
@ -147,7 +144,7 @@
ids (->> (feat.comp-v2/get-and-lock-team-files conn team-id)
(into #{}))
snap (get-file-snapshots conn label ids)
snap (search-file-snapshots conn ids label)
ids' (into #{} (map :file-id) snap)
team (-> (feat.comp-v2/get-team conn team-id)
@ -157,8 +154,8 @@
(throw (RuntimeException. "no uniform snapshot available")))
(feat.comp-v2/update-team! conn team)
(reduce (fn [result params]
(fsnap/restore-file-snapshot! conn params)
(reduce (fn [result {:keys [file-id id]}]
(fsnap/restore-file-snapshot! system file-id id)
(inc result))
0
snap)))
@ -167,7 +164,7 @@
[system file-id update-fn & {:keys [label validate? with-libraries?] :or {validate? true} :as opts}]
(when (string? label)
(fsnap/take-file-snapshot! system {:file-id file-id :label label}))
(fsnap/create-file-snapshot! system nil file-id label))
(let [conn (db/get-connection system)
file (get-file system file-id opts)

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

@ -311,33 +311,29 @@
collectable file-changes entry."
[& {:keys [file-id label]}]
(let [file-id (h/parse-uuid file-id)]
(db/tx-run! main/system fsnap/take-file-snapshot! {:file-id file-id :label label})))
(db/tx-run! main/system fsnap/create-file-snapshot! {:file-id file-id :label label})))
(defn restore-file-snapshot!
[file-id label]
(let [file-id (h/parse-uuid file-id)]
(db/tx-run! main/system
(fn [{:keys [::db/conn] :as system}]
(when-let [snapshot (->> (h/get-file-snapshots conn label #{file-id})
(when-let [snapshot (->> (h/search-file-snapshots conn #{file-id} label)
(map :id)
(first))]
(fsnap/restore-file-snapshot! system
{:id (:id snapshot)
:file-id file-id}))))))
(fsnap/restore-file-snapshot! system file-id (:id snapshot)))))))
(defn list-file-snapshots!
[file-id & {:keys [limit]}]
[file-id & {:as _}]
(let [file-id (h/parse-uuid file-id)]
(db/tx-run! main/system
(fn [system]
(let [params {:file-id file-id :limit limit}]
(->> (fsnap/get-file-snapshots system (d/without-nils params))
(print-table [:label :id :revn :created-at])))))))
(fn [{:keys [::db/conn]}]
(->> (fsnap/get-file-snapshots conn file-id)
(print-table [:label :id :revn :created-at]))))))
(defn take-team-snapshot!
[team-id & {:keys [label rollback?] :or {rollback? true}}]
(let [team-id (h/parse-uuid team-id)
label (or label (fsnap/generate-snapshot-label))]
(let [team-id (h/parse-uuid team-id)]
(-> (assoc main/system ::db/rollback rollback?)
(db/tx-run! h/take-team-snapshot! team-id label))))

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

@ -11,7 +11,7 @@
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
@ -19,7 +19,6 @@
[app.storage.impl :as impl]
[app.storage.s3 :as ss3]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[datoteka.fs :as fs]
[integrant.core :as ig])
@ -34,23 +33,43 @@
:assets-s3 :s3
nil)))
(def valid-buckets
#{"file-media-object"
"team-font-variant"
"file-object-thumbnail"
"file-thumbnail"
"profile"
"file-data"
"file-data-fragment"
"file-change"})
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Storage Module State
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::id #{:assets-fs :assets-s3 :fs :s3})
(s/def ::s3 ::ss3/backend)
(s/def ::fs ::sfs/backend)
(s/def ::type #{:fs :s3})
(def ^:private schema:backends
[:map-of :keyword
[:maybe
[:or ::ss3/backend ::sfs/backend]]])
(s/def ::backends
(s/map-of ::us/keyword
(s/nilable
(s/or :s3 ::ss3/backend
:fs ::sfs/backend))))
(def ^:private valid-backends?
(sm/validator schema:backends))
(defmethod ig/pre-init-spec ::storage [_]
(s/keys :req [::db/pool ::backends]))
(def ^:private schema:storage
[:map {:title "storage"}
[::backends schema:backends]
[::backend [:enum :s3 :fs]]
::db/connectable])
(def valid-storage?
(sm/validator schema:storage))
(sm/register! ::storage schema:storage)
(defmethod ig/assert-key ::storage
[_ params]
(assert (db/pool? (::db/pool params)) "expected valid database pool")
(assert (valid-backends? (::backends params)) "expected valid backends map"))
(defmethod ig/init-key ::storage
[_ {:keys [::backends ::db/pool] :as cfg}]
@ -68,14 +87,6 @@
(assoc ::backend backend)
(assoc ::db/connectable pool))))
(s/def ::backend keyword?)
(s/def ::storage
(s/keys :req [::backends ::db/pool ::db/connectable]
:opt [::backend]))
(s/def ::storage-with-backend
(s/and ::storage #(contains? % ::backend)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Database Objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -190,15 +201,16 @@
(dm/export impl/object?)
(defn get-object
[{:keys [::db/connectable] :as storage} id]
(us/assert! ::storage storage)
[{:keys [::db/connectable] :as storage} id]
(assert (valid-storage? storage))
(retrieve-database-object connectable id))
(defn put-object!
"Creates a new object with the provided content."
[{:keys [::backend] :as storage} {:keys [::content] :as params}]
(us/assert! ::storage-with-backend storage)
(us/assert! ::impl/content content)
(assert (valid-storage? storage))
(assert (impl/content? content) "expected an instance of content")
(let [object (create-database-object storage params)]
(if (::created? (meta object))
;; Store the data finally on the underlying storage subsystem.
@ -209,7 +221,7 @@
(defn touch-object!
"Mark object as touched."
[{:keys [::db/connectable] :as storage} object-or-id]
(us/assert! ::storage storage)
(assert (valid-storage? storage))
(let [id (if (impl/object? object-or-id) (:id object-or-id) object-or-id)]
(-> (db/update! connectable :storage-object
{:touched-at (dt/now)}
@ -221,7 +233,7 @@
"Return an input stream instance of the object content."
^InputStream
[storage object]
(us/assert! ::storage storage)
(assert (valid-storage? storage))
(when (or (nil? (:expired-at object))
(dt/is-after? (:expired-at object) (dt/now)))
(-> (impl/resolve-backend storage (:backend object))
@ -230,7 +242,7 @@
(defn get-object-bytes
"Returns a byte array of object content."
[storage object]
(us/assert! ::storage storage)
(assert (valid-storage? storage))
(when (or (nil? (:expired-at object))
(dt/is-after? (:expired-at object) (dt/now)))
(-> (impl/resolve-backend storage (:backend object))
@ -240,7 +252,7 @@
([storage object]
(get-object-url storage object nil))
([storage object options]
(us/assert! ::storage storage)
(assert (valid-storage? storage))
(when (or (nil? (:expired-at object))
(dt/is-after? (:expired-at object) (dt/now)))
(-> (impl/resolve-backend storage (:backend object))
@ -250,7 +262,7 @@
"Get the Path to the object. Only works with `:fs` type of
storages."
[storage object]
(us/assert! ::storage storage)
(assert (valid-storage? storage))
(let [backend (impl/resolve-backend storage (:backend object))]
(when (and (= :fs (::type backend))
(or (nil? (:expired-at object))
@ -259,7 +271,7 @@
(defn del-object!
[{:keys [::db/connectable] :as storage} object-or-id]
(us/assert! ::storage storage)
(assert (valid-storage? storage))
(let [id (if (impl/object? object-or-id) (:id object-or-id) object-or-id)
res (db/update! connectable :storage-object
{:deleted-at (dt/now)}
@ -267,9 +279,12 @@
(pos? (db/get-update-count res))))
(dm/export impl/calculate-hash)
(dm/export impl/get-hash)
(dm/export impl/get-size)
(defn configure
[storage connectable]
(assert (valid-storage? storage))
(assoc storage ::db/connectable connectable))
(defn resolve

52
backend/src/app/storage/fs.clj
View File

@ -6,27 +6,29 @@
(ns app.storage.fs
(:require
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.uri :as u]
[app.storage :as-alias sto]
[app.storage.impl :as impl]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[datoteka.fs :as fs]
[datoteka.io :as io]
[integrant.core :as ig])
(:import
java.io.InputStream
java.io.OutputStream
java.nio.file.Files
java.nio.file.Path))
(set! *warn-on-reflection* true)
;; --- BACKEND INIT
(s/def ::directory ::us/string)
(defmethod ig/pre-init-spec ::backend [_]
(s/keys :opt [::directory]))
(defmethod ig/assert-key ::backend
[_ params]
;; FIXME: path (?)
(assert (string? (::directory params))))
(defmethod ig/init-key ::backend
[_ cfg]
@ -39,18 +41,22 @@
::directory (str dir)
::uri (u/uri (str "file://" dir))))))
(s/def ::uri u/uri?)
(s/def ::backend
(s/keys :req [::directory
::uri]
:opt [::sto/type
::sto/id]))
(def ^:private schema:backend
[:map {:title "fs-backend"}
[::directory :string]
[::uri ::sm/uri]
[::sto/type [:= :fs]]])
(sm/register! ::backend schema:backend)
(def ^:private valid-backend?
(sm/validator schema:backend))
;; --- API IMPL
(defmethod impl/put-object :fs
[backend {:keys [id] :as object} content]
(us/assert! ::backend backend)
(assert (valid-backend? backend) "expected a valid backend instance")
(let [base (fs/path (::directory backend))
path (fs/path (impl/id->path id))
full (fs/normalize (fs/join base path))]
@ -58,15 +64,15 @@
(when-not (fs/exists? (fs/parent full))
(fs/create-dir (fs/parent full)))
(dm/with-open [src (io/input-stream content)
dst (io/output-stream full)]
(io/copy! src dst))
(with-open [^InputStream src (io/input-stream content)]
(with-open [^OutputStream dst (io/output-stream full)]
(io/copy src dst)))
object))
(defmethod impl/get-object-data :fs
[backend {:keys [id] :as object}]
(us/assert! ::backend backend)
(assert (valid-backend? backend) "expected a valid backend instance")
(let [^Path base (fs/path (::directory backend))
^Path path (fs/path (impl/id->path id))
^Path full (fs/normalize (fs/join base path))]
@ -78,12 +84,12 @@
(defmethod impl/get-object-bytes :fs
[backend object]
(dm/with-open [input (impl/get-object-data backend object)]
(io/read-as-bytes input)))
(with-open [^InputStream input (impl/get-object-data backend object)]
(io/read input)))
(defmethod impl/get-object-url :fs
[{:keys [::uri] :as backend} {:keys [id] :as object} _]
(us/assert! ::backend backend)
(assert (valid-backend? backend) "expected a valid backend instance")
(update uri :path
(fn [existing]
(if (str/ends-with? existing "/")
@ -92,7 +98,7 @@
(defmethod impl/del-object :fs
[backend {:keys [id] :as object}]
(us/assert! ::backend backend)
(assert (valid-backend? backend) "expected a valid backend instance")
(let [base (fs/path (::directory backend))
path (fs/path (impl/id->path id))
path (fs/join base path)]
@ -100,7 +106,7 @@
(defmethod impl/del-objects-in-bulk :fs
[backend ids]
(us/assert! ::backend backend)
(assert (valid-backend? backend) "expected a valid backend instance")
(let [base (fs/path (::directory backend))]
(doseq [id ids]
(let [path (fs/path (impl/id->path id))

16
backend/src/app/storage/gc_deleted.clj
View File

@ -16,10 +16,9 @@
[app.common.data :as d]
[app.common.logging :as l]
[app.db :as db]
[app.storage :as-alias sto]
[app.storage :as sto]
[app.storage.impl :as impl]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(def ^:private sql:lock-sobjects
@ -100,13 +99,14 @@
0
(get-buckets conn min-age)))
(defmethod ig/assert-key ::handler
[_ params]
(assert (sto/valid-storage? (::sto/storage params)) "expect valid storage")
(assert (db/pool? (::db/pool params)) "expect valid storage"))
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::sto/storage ::db/pool]))
(defmethod ig/prep-key ::handler
[_ cfg]
(assoc cfg ::min-age (dt/duration {:hours 2})))
(defmethod ig/expand-key ::handler
[k v]
{k (assoc v ::min-age (dt/duration {:hours 2}))})
(defmethod ig/init-key ::handler
[_ {:keys [::min-age] :as cfg}]

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

@ -25,7 +25,6 @@
[app.db :as db]
[app.storage :as-alias sto]
[app.storage.impl :as impl]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(def ^:private sql:has-team-font-variant-refs
@ -226,8 +225,9 @@
;; HANDLER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::db/pool]))
(defmethod ig/assert-key ::handler
[_ params]
(assert (db/pool? (::db/pool params)) "expect valid storage"))
(defmethod ig/init-key ::handler
[_ cfg]

5
backend/src/app/storage/impl.clj
View File

@ -14,7 +14,6 @@
[buddy.core.codecs :as bc]
[buddy.core.hash :as bh]
[clojure.java.io :as jio]
[clojure.spec.alpha :as s]
[datoteka.io :as io])
(:import
java.nio.ByteBuffer
@ -234,7 +233,3 @@
[v]
(satisfies? IContentObject v))
(s/def ::object object?)
(s/def ::content content?)

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

@ -11,7 +11,7 @@
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.uri :as u]
[app.storage :as-alias sto]
[app.storage.impl :as impl]
@ -19,7 +19,6 @@
[app.util.time :as dt]
[app.worker :as-alias wrk]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[datoteka.fs :as fs]
[integrant.core :as ig]
[promesa.core :as p]
@ -86,61 +85,68 @@
;; --- BACKEND INIT
(s/def ::region ::us/keyword)
(s/def ::bucket ::us/string)
(s/def ::prefix ::us/string)
(s/def ::endpoint ::us/string)
(s/def ::io-threads ::us/integer)
(def ^:private schema:config
[:map {:title "s3-backend-config"}
::wrk/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]])
(defmethod ig/pre-init-spec ::backend [_]
(s/keys :opt [::region ::bucket ::prefix ::endpoint ::io-threads ::wrk/executor]))
(defmethod ig/expand-key ::backend
[k v]
{k (merge {::region :eu-central-1} (d/without-nils v))})
(defmethod ig/prep-key ::backend
[_ {:keys [::prefix ::region] :as cfg}]
(cond-> (d/without-nils cfg)
(some? prefix) (assoc ::prefix prefix)
(nil? region) (assoc ::region :eu-central-1)))
(defmethod ig/assert-key ::backend
[_ params]
(assert (sm/check schema:config params)))
(defmethod ig/init-key ::backend
[_ cfg]
;; Return a valid backend data structure only if all optional
;; parameters are provided.
(when (and (contains? cfg ::region)
(string? (::bucket cfg)))
(let [client (build-s3-client cfg)
presigner (build-s3-presigner cfg)]
(assoc cfg
[_ params]
(when (and (contains? params ::region)
(contains? params ::bucket))
(let [client (build-s3-client params)
presigner (build-s3-presigner params)]
(assoc params
::sto/type :s3
::client @client
::presigner presigner
::close-fn #(.close ^java.lang.AutoCloseable client)))))
(defmethod ig/resolve-key ::backend
[_ params]
(dissoc params ::close-fn))
(defmethod ig/halt-key! ::backend
[_ {:keys [::close-fn]}]
(when (fn? close-fn)
(px/run! close-fn)))
(s/def ::client #(instance? S3AsyncClient %))
(s/def ::presigner #(instance? S3Presigner %))
(s/def ::backend
(s/keys :req [::region
::bucket
::client
::presigner]
:opt [::prefix
::sto/id]))
(def ^:private schema:backend
[:map {:title "s3-backend"}
;; [::region :keyword]
;; [::bucket ::sm/text]
[::client [:fn #(instance? S3AsyncClient %)]]
[::presigner [:fn #(instance? S3Presigner %)]]
[::prefix {:optional true} ::sm/text]
#_[::sto/type [:= :s3]]])
(sm/register! ::backend schema:backend)
(def ^:private valid-backend?
(sm/validator schema:backend))
;; --- API IMPL
(defmethod impl/put-object :s3
[backend object content]
(us/assert! ::backend backend)
(assert (valid-backend? backend) "expected a valid backend instance")
(p/await! (put-object backend object content)))
(defmethod impl/get-object-data :s3
[backend object]
(us/assert! ::backend backend)
(assert (valid-backend? backend) "expected a valid backend instance")
(loop [result (get-object-data backend object)
retryn 0]
@ -167,22 +173,21 @@
(defmethod impl/get-object-bytes :s3
[backend object]
(us/assert! ::backend backend)
(assert (valid-backend? backend) "expected a valid backend instance")
(p/await! (get-object-bytes backend object)))
(defmethod impl/get-object-url :s3
[backend object options]
(us/assert! ::backend backend)
(assert (valid-backend? backend) "expected a valid backend instance")
(get-object-url backend object options))
(defmethod impl/del-object :s3
[backend object]
(us/assert! ::backend backend)
(p/await! (del-object backend object)))
(defmethod impl/del-objects-in-bulk :s3
[backend ids]
(us/assert! ::backend backend)
(assert (valid-backend? backend) "expected a valid backend instance")
(p/await! (del-object-in-bulk backend ids)))
;; --- HELPERS
@ -221,7 +226,7 @@
builder (.region ^S3AsyncClientBuilder builder (lookup-region region))
builder (cond-> ^S3AsyncClientBuilder builder
(some? endpoint)
(.endpointOverride (URI. endpoint)))]
(.endpointOverride (URI. (str endpoint))))]
(.build ^S3AsyncClientBuilder builder))]
(reify
@ -240,7 +245,7 @@
(.build))]
(-> (S3Presigner/builder)
(cond-> (some? endpoint) (.endpointOverride (URI. endpoint)))
(cond-> (some? endpoint) (.endpointOverride (URI. (str endpoint))))
(.region (lookup-region region))
(.serviceConfiguration ^S3Configuration config)
(.build))))
@ -337,7 +342,8 @@
(defn- get-object-url
[{:keys [::presigner ::bucket ::prefix]} {:keys [id]} {:keys [max-age] :or {max-age default-max-age}}]
(us/assert dt/duration? max-age)
(assert (dt/duration? max-age) "expected valid duration instance")
(let [gor (.. (GetObjectRequest/builder)
(bucket bucket)
(key (dm/str prefix (impl/id->path id)))

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

@ -11,10 +11,10 @@
permanently delete these files (look at systemd-tempfiles)."
(:require
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.uuid :as uuid]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
[datoteka.fs :as fs]
[integrant.core :as ig]
[promesa.exec :as px]
@ -29,12 +29,13 @@
(defonce queue (sp/chan :buf 128))
(defmethod ig/pre-init-spec ::cleaner [_]
(s/keys :req [::wrk/executor]))
(defmethod ig/assert-key ::cleaner
[_ {:keys [::wrk/executor]}]
(assert (sm/valid? ::wrk/executor executor)))
(defmethod ig/prep-key ::cleaner
[_ cfg]
(assoc cfg ::min-age (dt/duration "60m")))
(defmethod ig/expand-key ::cleaner
[k v]
{k (assoc v ::min-age (dt/duration "60m"))})
(defmethod ig/init-key ::cleaner
[_ cfg]

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

@ -7,36 +7,32 @@
(ns app.svgo
"A SVG Optimizer service"
(:require
[app.common.jsrt :as jsrt]
[app.common.logging :as l]
[app.worker :as-alias wrk]
[integrant.core :as ig]
[promesa.exec.semaphore :as ps]
[promesa.util :as pu]))
[app.util.shell :as shell]
[datoteka.fs :as fs]
[promesa.exec.semaphore :as ps]))
(def ^:dynamic *semaphore*
"A dynamic variable that can optionally contain a traffic light to
appropriately delimit the use of resources, managed externally."
nil)
(set! *warn-on-reflection* true)
(defn optimize
[{pool ::optimizer} data]
[system data]
(try
(some-> *semaphore* ps/acquire!)
(jsrt/run! pool
(fn [context]
(jsrt/set! context "svgData" data)
(jsrt/eval! context "penpotSvgo.optimize(svgData, {plugins: ['safeAndFastPreset']})")))
(let [script (fs/join fs/*cwd* "scripts/svgo-cli.js")
cmd ["node" (str script)]
result (shell/exec! system
:cmd cmd
:in data)]
(if (= (:exit result) 0)
(:out result)
(do
(l/raw! :warn (str "Error on optimizing svg, returning svg as-is." (:err result)))
data)))
(finally
(some-> *semaphore* ps/release!))))
(defmethod ig/init-key ::optimizer
[_ _]
(l/inf :hint "initializing svg optimizer pool")
(let [init (jsrt/resource->source "app/common/svg/optimizer.js")]
(jsrt/pool :init init)))
(defmethod ig/halt-key! ::optimizer
[_ pool]
(l/info :hint "stopping svg optimizer pool")
(pu/close! pool))

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

@ -12,7 +12,6 @@
[app.rpc.commands.files :as files]
[app.rpc.commands.profile :as profile]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(def ^:dynamic *team-deletion* false)
@ -113,8 +112,9 @@
[_cfg props]
(l/wrn :hint "not implementation found" :rel (:object props)))
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::db/pool]))
(defmethod ig/assert-key ::handler
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool"))
(defmethod ig/init-key ::handler
[_ cfg]

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

@ -27,7 +27,6 @@
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.set :as set]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(declare ^:private get-file)
@ -44,7 +43,7 @@
f.data_ref_id
FROM file_change AS f
WHERE f.file_id = ?
AND f.label IS NOT NULL
AND f.data IS NOT NULL
ORDER BY f.created_at ASC")
(def ^:private sql:mark-file-media-object-deleted
@ -315,8 +314,10 @@
;; HANDLER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::db/pool ::sto/storage]))
(defmethod ig/assert-key ::handler
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool")
(assert (sto/valid-storage? (::sto/storage params)) "expected valid storage to be provided"))
(defmethod ig/init-key ::handler
[_ cfg]

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

@ -12,7 +12,6 @@
[app.db :as db]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(def ^:private
@ -43,12 +42,13 @@
{:processed total}))
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::db/pool]))
(defmethod ig/assert-key ::handler
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool"))
(defmethod ig/prep-key ::handler
[_ cfg]
(assoc cfg ::min-age (cf/get-deletion-delay)))
(defmethod ig/expand-key ::handler
[k v]
{k (assoc v ::min-age (cf/get-deletion-delay))})
(defmethod ig/init-key ::handler
[_ cfg]

88
backend/src/app/tasks/file_xlog_gc.clj
View File

@ -5,64 +5,60 @@
;; Copyright (c) KALEIDOS INC
(ns app.tasks.file-xlog-gc
"A maintenance task that performs a garbage collection of the file
change (transaction) log."
(:require
[app.common.logging :as l]
[app.config :as cf]
[app.db :as db]
[app.features.fdata :as feat.fdata]
[app.storage :as sto]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(def ^:private
sql:delete-files-xlog
"DELETE FROM file_change
WHERE id IN (SELECT id FROM file_change
WHERE label IS NULL
AND created_at < ?
ORDER BY created_at LIMIT ?)
RETURNING id, data_backend, data_ref_id")
;; Get the latest available snapshots without exceeding the total
;; snapshot limit
(def ^:private sql:get-latest-snapshots
"SELECT fch.id, fch.created_at
FROM file_change AS fch
WHERE fch.file_id = ?
AND fch.created_by = 'system'
AND fch.data IS NOT NULL
AND fch.deleted_at > now()
ORDER BY fch.created_at DESC
LIMIT ?")
(def xf:filter-offloded
(comp
(filter feat.fdata/offloaded?)
(keep :data-ref-id)))
;; Mark all snapshots that are outside the allowed total threshold
;; available for the GC
(def ^:private sql:delete-snapshots
"UPDATE file_change
SET deleted_at = now()
WHERE file_id = ?
AND deleted_at > now()
AND data IS NOT NULL
AND created_by = 'system'
AND created_at < ?")
(defn- delete-in-chunks
[{:keys [::chunk-size ::threshold] :as cfg}]
(let [storage (sto/resolve cfg ::db/reuse-conn true)]
(loop [total 0]
(let [chunk (db/exec! cfg [sql:delete-files-xlog threshold chunk-size])
length (count chunk)]
(defn- get-alive-snapshots
[conn file-id]
(let [total (cf/get :auto-file-snapshot-total 10)
snapshots (db/exec! conn [sql:get-latest-snapshots file-id total])]
(not-empty snapshots)))
;; touch all references on offloaded changes entries
(doseq [data-ref-id (sequence xf:filter-offloded chunk)]
(l/trc :hint "touching referenced storage object"
:storage-object-id (str data-ref-id))
(sto/touch-object! storage data-ref-id))
(defn- delete-old-snapshots!
[{:keys [::db/conn] :as cfg} file-id]
(when-let [snapshots (get-alive-snapshots conn file-id)]
(let [last-date (-> snapshots peek :created-at)
result (db/exec-one! conn [sql:delete-snapshots file-id last-date])]
(l/inf :hint "delete old file snapshots"
:file-id (str file-id)
:current (count snapshots)
:deleted (db/get-update-count result)))))
(if (pos? length)
(recur (+ total length))
total)))))
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::db/pool]))
(defmethod ig/assert-key ::handler
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool"))
(defmethod ig/init-key ::handler
[_ cfg]
(fn [{:keys [props] :as task}]
(let [min-age (or (:min-age props)
(dt/duration "72h"))
chunk-size (:chunk-size props 5000)
threshold (dt/minus (dt/now) min-age)]
(let [file-id (:file-id props)]
(assert (uuid? file-id) "expected file-id on props")
(-> cfg
(assoc ::db/rollback (:rollback props false))
(assoc ::threshold threshold)
(assoc ::chunk-size chunk-size)
(db/tx-run! (fn [cfg]
(let [total (delete-in-chunks cfg)]
(l/trc :hint "file xlog cleaned" :total total)
total)))))))
(db/tx-run! delete-old-snapshots! file-id)))))

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

@ -13,7 +13,6 @@
[app.db :as db]
[app.storage :as sto]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(def ^:private sql:get-profiles
@ -27,7 +26,7 @@
(defn- delete-profiles!
[{:keys [::db/conn ::min-age ::chunk-size ::sto/storage] :as cfg}]
(->> (db/cursor conn [sql:get-profiles min-age chunk-size] {:chunk-size 1})
(->> (db/cursor conn [sql:get-profiles min-age chunk-size] {:chunk-size 5})
(reduce (fn [total {:keys [id photo-id]}]
(l/trc :hint "permanently delete" :rel "profile" :id (str id))
@ -50,7 +49,7 @@
(defn- delete-teams!
[{:keys [::db/conn ::min-age ::chunk-size ::sto/storage] :as cfg}]
(->> (db/cursor conn [sql:get-teams min-age chunk-size] {:chunk-size 1})
(->> (db/cursor conn [sql:get-teams min-age chunk-size] {:chunk-size 5})
(reduce (fn [total {:keys [id photo-id deleted-at]}]
(l/trc :hint "permanently delete"
:rel "team"
@ -78,7 +77,7 @@
(defn- delete-fonts!
[{:keys [::db/conn ::min-age ::chunk-size ::sto/storage] :as cfg}]
(->> (db/cursor conn [sql:get-fonts min-age chunk-size] {:chunk-size 1})
(->> (db/cursor conn [sql:get-fonts min-age chunk-size] {:chunk-size 5})
(reduce (fn [total {:keys [id team-id deleted-at] :as font}]
(l/trc :hint "permanently delete"
:rel "team-font-variant"
@ -110,7 +109,7 @@
(defn- delete-projects!
[{:keys [::db/conn ::min-age ::chunk-size] :as cfg}]
(->> (db/cursor conn [sql:get-projects min-age chunk-size] {:chunk-size 1})
(->> (db/cursor conn [sql:get-projects min-age chunk-size] {:chunk-size 5})
(reduce (fn [total {:keys [id team-id deleted-at]}]
(l/trc :hint "permanently delete"
:rel "project"
@ -136,7 +135,7 @@
(defn- delete-files!
[{:keys [::db/conn ::sto/storage ::min-age ::chunk-size] :as cfg}]
(->> (db/cursor conn [sql:get-files min-age chunk-size] {:chunk-size 1})
(->> (db/cursor conn [sql:get-files min-age chunk-size] {:chunk-size 5})
(reduce (fn [total {:keys [id deleted-at project-id] :as file}]
(l/trc :hint "permanently delete"
:rel "file"
@ -165,7 +164,7 @@
(defn delete-file-thumbnails!
[{:keys [::db/conn ::min-age ::chunk-size ::sto/storage] :as cfg}]
(->> (db/cursor conn [sql:get-file-thumbnails min-age chunk-size] {:chunk-size 1})
(->> (db/cursor conn [sql:get-file-thumbnails min-age chunk-size] {:chunk-size 5})
(reduce (fn [total {:keys [file-id revn media-id deleted-at]}]
(l/trc :hint "permanently delete"
:rel "file-thumbnail"
@ -194,7 +193,7 @@
(defn delete-file-object-thumbnails!
[{:keys [::db/conn ::min-age ::chunk-size ::sto/storage] :as cfg}]
(->> (db/cursor conn [sql:get-file-object-thumbnails min-age chunk-size] {:chunk-size 1})
(->> (db/cursor conn [sql:get-file-object-thumbnails min-age chunk-size] {:chunk-size 5})
(reduce (fn [total {:keys [file-id object-id media-id deleted-at]}]
(l/trc :hint "permanently delete"
:rel "file-tagged-object-thumbnail"
@ -223,7 +222,7 @@
(defn- delete-file-data-fragments!
[{:keys [::db/conn ::sto/storage ::min-age ::chunk-size] :as cfg}]
(->> (db/cursor conn [sql:get-file-data-fragments min-age chunk-size] {:chunk-size 1})
(->> (db/cursor conn [sql:get-file-data-fragments min-age chunk-size] {:chunk-size 5})
(reduce (fn [total {:keys [file-id id deleted-at data-ref-id]}]
(l/trc :hint "permanently delete"
:rel "file-data-fragment"
@ -249,7 +248,7 @@
(defn- delete-file-media-objects!
[{:keys [::db/conn ::min-age ::chunk-size ::sto/storage] :as cfg}]
(->> (db/cursor conn [sql:get-file-media-objects min-age chunk-size] {:chunk-size 1})
(->> (db/cursor conn [sql:get-file-media-objects min-age chunk-size] {:chunk-size 5})
(reduce (fn [total {:keys [id file-id deleted-at] :as fmo}]
(l/trc :hint "permanently delete"
:rel "file-media-object"
@ -266,6 +265,34 @@
(inc total))
0)))
(def ^:private sql:get-file-change
"SELECT id, file_id, deleted_at, data_backend, data_ref_id
FROM file_change
WHERE deleted_at IS NOT NULL
AND deleted_at < now() - ?::interval
ORDER BY deleted_at ASC
LIMIT ?
FOR UPDATE
SKIP LOCKED")
(defn- delete-file-change!
[{:keys [::db/conn ::min-age ::chunk-size ::sto/storage] :as cfg}]
(->> (db/cursor conn [sql:get-file-change min-age chunk-size] {:chunk-size 5})
(reduce (fn [total {:keys [id file-id deleted-at] :as xlog}]
(l/trc :hint "permanently delete"
:rel "file-change"
:id (str id)
:file-id (str file-id)
:deleted-at (dt/format-instant 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))
0)))
(def ^:private deletion-proc-vars
[#'delete-profiles!
#'delete-file-media-objects!
@ -275,7 +302,8 @@
#'delete-files!
#'delete-projects!
#'delete-fonts!
#'delete-teams!])
#'delete-teams!
#'delete-file-change!])
(defn- execute-proc!
"A generic function that executes the specified proc iterativelly
@ -289,14 +317,16 @@
(recur (+ total result))
total))))
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::db/pool ::sto/storage]))
(defmethod ig/assert-key ::handler
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool")
(assert (sto/valid-storage? (::sto/storage params)) "expected valid storage to be provided"))
(defmethod ig/prep-key ::handler
[_ cfg]
(assoc cfg
::min-age (cf/get-deletion-delay)
::chunk-size 10))
(defmethod ig/expand-key ::handler
[k v]
{k (assoc v
::min-age (cf/get-deletion-delay)
::chunk-size 50)})
(defmethod ig/init-key ::handler
[_ cfg]

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

@ -13,7 +13,6 @@
[app.db :as db]
[app.db.sql :as-alias sql]
[app.storage :as sto]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(defn- offload-file-data!
@ -109,8 +108,10 @@
;; HANDLER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::db/pool ::sto/storage]))
(defmethod ig/assert-key ::handler
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool")
(assert (sto/valid-storage? (::sto/storage params)) "expected valid storage to be provided"))
(defmethod ig/init-key ::handler
[_ cfg]

12
backend/src/app/tasks/tasks_gc.clj
View File

@ -11,19 +11,19 @@
[app.common.logging :as l]
[app.config :as cf]
[app.db :as db]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(def ^:private
sql:delete-completed-tasks
"DELETE FROM task WHERE scheduled_at < now() - ?::interval")
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::db/pool]))
(defmethod ig/assert-key ::handler
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool"))
(defmethod ig/prep-key ::handler
[_ cfg]
(assoc cfg ::min-age (cf/get-deletion-delay)))
(defmethod ig/expand-key ::handler
[k v]
{k (assoc v ::min-age (cf/get-deletion-delay))})
(defmethod ig/init-key ::handler
[_ {:keys [::db/pool ::min-age] :as cfg}]

10
backend/src/app/tasks/telemetry.clj
View File

@ -17,7 +17,6 @@
[app.main :as-alias main]
[app.setup :as-alias setup]
[app.util.json :as json]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[promesa.exec :as px]))
@ -205,10 +204,11 @@
;; TASK ENTRY POINT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::http/client
::db/pool
::setup/props]))
(defmethod ig/assert-key ::handler
[_ params]
(assert (http/client? (::http/client params)) "expected a valid http client")
(assert (db/pool? (::db/pool params)) "expected a valid database pool")
(assert (some? (::setup/props params)) "expected setup props to be available"))
(defmethod ig/init-key ::handler
[_ {:keys [::db/pool ::setup/props] :as cfg}]

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

@ -8,6 +8,7 @@
"In-memory cache backed by Caffeine"
(:refer-clojure :exclude [get])
(:require
[app.common.schema :as sm]
[app.util.time :as dt]
[promesa.exec :as px])
(:import
@ -77,3 +78,9 @@
(defn cache?
[o]
(satisfies? ICache o))
(sm/register!
{:type ::cache
:pred cache?
:type-properties
{:title "cache instance"}})

8
backend/src/app/util/inet.clj
View File

@ -8,7 +8,7 @@
"INET addr parsing and validation helpers"
(:require
[cuerdas.core :as str]
[ring.request :as rreq])
[yetti.request :as yreq])
(:import
com.google.common.net.InetAddresses
java.net.InetAddress))
@ -27,11 +27,11 @@
(defn parse-request
[request]
(or (some-> (rreq/get-header request "x-real-ip")
(or (some-> (yreq/get-header request "x-real-ip")
(normalize))
(some-> (rreq/get-header request "x-forwarded-for")
(some-> (yreq/get-header request "x-forwarded-for")
(str/split #"\s*,\s*")
(first)
(normalize))
(some-> (rreq/remote-addr request)
(some-> (yreq/remote-addr request)
(normalize))))

24
backend/src/app/util/overrides.clj
View File

@ -25,15 +25,15 @@
clojure.lang.IPersistentMap
clojure.lang.IDeref)
(sm/register! ::fs/path
{:type ::fs/path
:pred fs/path?
:type-properties
{:title "path"
:description "filesystem path"
:error/message "expected a valid fs path instance"
:error/code "errors.invalid-path"
:gen/gen (sg/generator :string)
:decode/string fs/path
::oapi/type "string"
::oapi/format "unix-path"}})
(sm/register!
{:type ::fs/path
:pred fs/path?
:type-properties
{:title "path"
:description "filesystem path"
:error/message "expected a valid fs path instance"
:error/code "errors.invalid-path"
:gen/gen (sg/generator :string)
:decode/string fs/path
::oapi/type "string"
::oapi/format "unix-path"}})

71
backend/src/app/util/shell.clj Normal file
View File

@ -0,0 +1,71 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.util.shell
"A penpot specific, modern api for executing external (shell)
subprocesses"
(:require
[app.worker :as-alias wrk]
[datoteka.io :as io]
[promesa.exec :as px])
(:import
java.io.InputStream
java.io.OutputStream
java.util.List
org.apache.commons.io.IOUtils))
(set! *warn-on-reflection* true)
(defn- read-as-bytes
[in]
(with-open [^InputStream input (io/input-stream in)]
(io/read input)))
(defn- read-as-string
([in] (read-as-string in "UTF-8"))
([in enc]
(IOUtils/toString ^InputStream in ^String enc)))
(defn- read-with-enc
[stream enc]
(if (= enc :bytes)
(read-as-bytes stream)
(read-as-string stream enc)))
(defn- set-env
[penv k v]
(.put ^java.util.Map penv
^String k
^String v))
(defn exec!
[system & {:keys [cmd in out-enc in-enc env]
:or {out-enc "UTF-8"
in-enc "UTF-8"}}]
(assert (vector? cmd) "a command parameter should be a vector")
(assert (every? string? cmd) "the command should be a vector of strings")
(let [executor (::wrk/executor system)
builder (ProcessBuilder. ^List cmd)
env-map (.environment ^ProcessBuilder builder)
_ (reduce-kv set-env env-map env)
process (.start builder)]
(if in
(px/run! executor
(fn []
(with-open [^OutputStream stdin (.getOutputStream ^Process process)]
(io/write stdin in :encoding in-enc))))
(io/close (.getOutputStream ^Process process)))
(with-open [stdout (.getInputStream ^Process process)
stderr (.getErrorStream ^Process process)]
(let [out (px/submit! executor (fn [] (read-with-enc stdout out-enc)))
err (px/submit! executor (fn [] (read-as-string stderr)))
ext (.waitFor ^Process process)]
{:exit ext
:out @out
:err @err}))))

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

@ -158,6 +158,7 @@
:iso8601 (Instant/from (.parse DateTimeFormatter/ISO_INSTANT ^String s)))))
(defn is-after?
"Analgous to: da > db"
[da db]
(.isAfter ^Instant da ^Instant db))
@ -369,30 +370,30 @@
(let [p1 (System/nanoTime)]
#(duration {:nanos (- (System/nanoTime) p1)})))
(sm/register! ::instant
{:type ::instant
:pred instant?
:type-properties
{:error/message "should be an instant"
:title "instant"
:decode/string instant
:encode/string format-instant
:decode/json instant
:encode/json format-instant
:gen/gen (tgen/fmap (fn [i] (in-past i)) tgen/pos-int)
::oapi/type "string"
::oapi/format "iso"}})
(sm/register!
{:type ::instant
:pred instant?
:type-properties
{:error/message "should be an instant"
:title "instant"
:decode/string instant
:encode/string format-instant
:decode/json instant
:encode/json format-instant
:gen/gen (tgen/fmap (fn [i] (in-past i)) tgen/pos-int)
::oapi/type "string"
::oapi/format "iso"}})
(sm/register! ::duration
{:type :durations
:pred duration?
:type-properties
{:error/message "should be a duration"
:gen/gen (tgen/fmap duration tgen/pos-int)
:title "duration"
:decode/string duration
:encode/string format-duration
:decode/json duration
:encode/json format-duration
::oapi/type "string"
::oapi/format "duration"}})
(sm/register!
{:type ::duration
:pred duration?
:type-properties
{:error/message "should be a duration"
:gen/gen (tgen/fmap duration tgen/pos-int)
:title "duration"
:decode/string duration
:encode/string format-duration
:decode/json duration
:encode/json format-duration
::oapi/type "string"
::oapi/format "duration"}})

17
backend/src/app/util/websocket.clj
View File

@ -16,8 +16,7 @@
[promesa.exec :as px]
[promesa.exec.csp :as sp]
[promesa.util :as pu]
[ring.request :as rreq]
[ring.websocket :as rws]
[yetti.request :as yreq]
[yetti.websocket :as yws])
(:import
java.nio.ByteBuffer))
@ -85,7 +84,7 @@
hbeat-ch (sp/chan :buf (sp/sliding-buffer 6))
close-ch (sp/chan)
ip-addr (inet/parse-request request)
uagent (rreq/get-header request "user-agent")
uagent (yreq/get-header request "user-agent")
id (uuid/next)
state (atom {})
beats (atom #{})
@ -138,7 +137,7 @@
(defn- handle-ping!
[{:keys [::id ::beats ::channel] :as wsp} beat-id]
(l/trc :hint "send ping" :beat beat-id :conn-id (str id))
(rws/ping channel (encode-beat beat-id))
(yws/ping channel (encode-beat beat-id))
(let [issued (swap! beats conj (long beat-id))]
(not (>= (count issued) max-missed-heartbeats))))
@ -151,14 +150,14 @@
(loop [i 0]
(let [ping-ch (sp/timeout-chan heartbeat-interval)
[msg p] (sp/alts! [close-ch input-ch output-ch heartbeat-ch ping-ch])]
(when (rws/open? channel)
(when (yws/open? channel)
(cond
(identical? p ping-ch)
(if (handle-ping! wsp i)
(recur (inc i))
(do
(l/trc :hint "closing" :reason "missing to many pings")
(rws/close channel 8802 "missing to many pings")))
(yws/close channel 8802 "missing to many pings")))
(or (identical? p close-ch) (nil? msg))
(do :nothing)
@ -183,7 +182,7 @@
(identical? p output-ch)
(let [message (on-snd-message msg)
message (t/encode-str message {:type :json-verbose})]
(rws/send channel message)
(yws/send channel message)
(recur i))))))
(catch InterruptedException _cause
@ -202,13 +201,13 @@
(try
(handler wsp {:type :close})
(when (rws/open? channel)
(when (yws/open? channel)
;; NOTE: we need to ignore all exceptions here because
;; there can be a race condition that first returns that
;; channel is connected but on closing, will raise that
;; channel is already closed.
(ex/ignoring
(rws/close channel 8899 "terminated")))
(yws/close channel 8899 "terminated")))
(when-let [on-disconnect (::on-disconnect wsp)]
(on-disconnect))

76
backend/src/app/worker.clj
View File

@ -8,15 +8,13 @@
"Async tasks abstraction (impl)."
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.metrics :as mtx]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[integrant.core :as ig]))
@ -26,6 +24,9 @@
;; TASKS REGISTRY
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defprotocol IRegistry
(get-task [_ name]))
(defn- wrap-with-metrics
[f metrics tname]
(let [labels (into-array String [tname])]
@ -39,21 +40,37 @@
:val (inst-ms (tp))
:labels labels})))))))
(s/def ::registry (s/map-of ::us/string fn?))
(s/def ::tasks (s/map-of keyword? fn?))
(def ^:private schema:tasks
[:map-of :keyword ::sm/fn])
(defmethod ig/pre-init-spec ::registry [_]
(s/keys :req [::mtx/metrics ::tasks]))
(def ^:private valid-tasks?
(sm/validator schema:tasks))
(defmethod ig/assert-key ::registry
[_ params]
(assert (mtx/metrics? (::mtx/metrics params)) "expected valid metrics instance")
(assert (valid-tasks? (::tasks params)) "expected a valid map of tasks"))
(defmethod ig/init-key ::registry
[_ {:keys [::mtx/metrics ::tasks]}]
(l/inf :hint "registry initialized" :tasks (count tasks))
(reduce-kv (fn [registry k f]
(let [tname (name k)]
(l/trc :hint "register task" :name tname)
(assoc registry tname (wrap-with-metrics f metrics tname))))
{}
tasks))
(let [tasks (reduce-kv (fn [registry k f]
(let [tname (name k)]
(l/trc :hint "register task" :name tname)
(assoc registry tname (wrap-with-metrics f metrics tname))))
{}
tasks)]
(reify
clojure.lang.Counted
(count [_] (count tasks))
IRegistry
(get-task [_ name]
(get tasks (d/name name))))))
(sm/register!
{:type ::registry
:pred #(satisfies? IRegistry %)})
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SUBMIT API
@ -73,29 +90,27 @@
AND status = 'new'
AND scheduled_at > now()")
(s/def ::label string?)
(s/def ::task (s/or :kw keyword? :str string?))
(s/def ::queue (s/or :kw keyword? :str string?))
(s/def ::delay (s/or :int integer? :duration dt/duration?))
(s/def ::priority integer?)
(s/def ::max-retries integer?)
(s/def ::dedupe boolean?)
(def ^:private schema:options
[:map {:title "submit-options"}
[::task [:or ::sm/text :keyword]]
[::label {:optional true} ::sm/text]
[::delay {:optional true}
[:or ::sm/int ::dt/duration]]
[::queue {:optional true} [:or ::sm/text :keyword]]
[::priority {:optional true} ::sm/int]
[::max-retries {:optional true} ::sm/int]
[::dedupe {:optional true} ::sm/boolean]])
(s/def ::submit-options
(s/and
(s/keys :req [::task]
:opt [::label ::delay ::queue ::priority ::max-retries ::dedupe])
(fn [{:keys [::dedupe ::label] :or {label ""}}]
(if dedupe
(not= label "")
true))))
(def check-options!
(sm/check-fn schema:options))
(defn submit!
[& {:keys [::params ::task ::delay ::queue ::priority ::max-retries ::dedupe ::label]
:or {delay 0 queue :default priority 100 max-retries 3 label ""}
:as options}]
(us/verify! ::submit-options options)
(check-options! options)
(let [duration (dt/duration delay)
interval (db/interval duration)
props (db/tjson params)
@ -125,5 +140,6 @@
[{:keys [::task ::params] :as cfg}]
(assert (contains? cfg :app.worker/registry)
"missing worker registry on `cfg`")
(let [task-fn (dm/get-in cfg [:app.worker/registry (name task)])]
(let [registry (get cfg ::registry)
task-fn (get-task registry task)]
(task-fn {:props params})))

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