Penpot/penpot
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-04-13 15:31:26 -05:00
Code Issues Activity

Merge branch 'develop' into staging

Browse source
This commit is contained in:
Andrey Antukh 2022-07-12 11:55:13 +02:00
commit 40415bb0d8
313 changed files with 9532 additions and 5230 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
CHANGES.md
View file

@ -1,5 +1,39 @@
# CHANGELOG
## :rocket: Next
### :boom: Breaking changes & Deprecations
- The `PENPOT_LOGIN_WITH_LDAP` environment variable is finally removed (after
many version with deprecation). It is replaced with the
`enable-login-with-ldap` flag.
- The `PENPOT_LDAP_ATTRS_PHOTO` finally removed, it was unused for many
versions.
- If you are using social login (google, github, gitlab or generic OIDC) you
will need to ensure to add the following flags respectivelly to let them
enabled: `enable-login-with-google`, `enable-login-with-github`,
`enable-login-with-gitlab` and `enable-login-with-oidc`. If not, they will
remain disabled after application start independently if you set the client-id
and client-sectet options.
- The `PENPOT_REGISTRATION_ENABLED` is finally removed in favour of
`<enable|disable>-registration` flag.
- The OIDC providers are now initialized synchronously, and if you are using the
discovery mechanism of the generic OIDC integration, the start time of the
application will depend on how fast the OIDC provider responds to the
discovery http request.
### :sparkles: New features
- Allow for nested and rotated boards inside other boards and groups [Taiga #2874](https://tree.taiga.io/project/penpot/us/2874?milestone=319982)
- View mode improvements to enable access and use in different conditions [Taiga #3023](https://tree.taiga.io/project/penpot/us/3023)
- Improved share link options. Now you can allow non-team members to comment and/or inspect [Taiga #3056] (https://tree.taiga.io/project/penpot/us/3056)
- Signin/Signup from shared link [Taiga #3472](https://tree.taiga.io/project/penpot/us/3472)
- Support for import/export binary format [Taiga #2991](https://tree.taiga.io/project/penpot/us/2991)
### :bug: Bugs fixed
### :arrow_up: Deps updates
### :heart: Community contributions by (Thank you!)
## 1.14.2-beta
### :bug: Bugs fixed

29
backend/deps.edn
View file

@ -1,13 +1,13 @@
{:deps
{penpot/common {:local/root "../common"}
org.clojure/clojure {:mvn/version "1.10.3"}
org.clojure/clojure {:mvn/version "1.11.1"}
org.clojure/core.async {:mvn/version "1.5.648"}
;; Logging
org.zeromq/jeromq {:mvn/version "0.5.2"}
com.taoensso/nippy {:mvn/version "3.1.1"}
com.github.luben/zstd-jni {:mvn/version "1.5.2-2"}
com.github.luben/zstd-jni {:mvn/version "1.5.2-3"}
org.clojure/data.fressian {:mvn/version "1.0.0"}
io.prometheus/simpleclient {:mvn/version "0.15.0"}
@ -17,24 +17,27 @@
org.eclipse.jetty/jetty-servlet]}
io.prometheus/simpleclient_httpserver {:mvn/version "0.15.0"}
io.lettuce/lettuce-core {:mvn/version "6.1.6.RELEASE"}
io.lettuce/lettuce-core {:mvn/version "6.1.8.RELEASE"}
java-http-clj/java-http-clj {:mvn/version "0.4.3"}
funcool/yetti {:git/tag "v9.1" :git/sha "63f35d9"
funcool/yetti {:git/tag "v9.2" :git/sha "4ddcc03"
:git/url "https://github.com/funcool/yetti.git"
:exclusions [org.slf4j/slf4j-api]}
com.github.seancorfield/next.jdbc {:mvn/version "1.2.772"}
metosin/reitit-core {:mvn/version "0.5.16"}
org.postgresql/postgresql {:mvn/version "42.3.3"}
com.github.seancorfield/next.jdbc {:mvn/version "1.2.780"}
metosin/reitit-core {:mvn/version "0.5.18"}
org.postgresql/postgresql {:mvn/version "42.4.0"}
com.zaxxer/HikariCP {:mvn/version "5.0.1"}
funcool/datoteka {:mvn/version "2.0.0"}
funcool/datoteka {:mvn/version "3.0.64"}
buddy/buddy-hashers {:mvn/version "1.8.158"}
buddy/buddy-sign {:mvn/version "3.4.333"}
org.jsoup/jsoup {:mvn/version "1.14.3"}
org.im4java/im4java {:mvn/version "1.4.0"}
org.jsoup/jsoup {:mvn/version "1.15.1"}
org.im4java/im4java {:git/tag "1.4.0-penpot-2" :git/sha "e2b3e16"
:git/url "https://github.com/penpot/im4java"}
org.lz4/lz4-java {:mvn/version "1.8.0"}
org.clojars.pntblnk/clj-ldap {:mvn/version "0.0.17"}
@ -43,11 +46,11 @@
io.sentry/sentry {:mvn/version "5.6.1"}
dawran6/emoji {:mvn/version "0.1.5"}
markdown-clj/markdown-clj {:mvn/version "1.11.0"}
markdown-clj/markdown-clj {:mvn/version "1.11.1"}
;; Pretty Print specs
pretty-spec/pretty-spec {:mvn/version "0.1.4"}
software.amazon.awssdk/s3 {:mvn/version "2.17.136"}}
software.amazon.awssdk/s3 {:mvn/version "2.17.209"}}
:paths ["src" "resources" "target/classes"]
:aliases
@ -64,7 +67,7 @@
:build
{:extra-deps
{io.github.clojure/tools.build {:git/tag "v0.7.7" :git/sha "1474ad6"}}
{io.github.clojure/tools.build {:git/tag "v0.8.2" :git/sha "ba1a2bf"}}
:ns-default build}
:test

10
backend/resources/api-doc.css
View file

@ -85,6 +85,16 @@ header {
.rpc-row-info > .name {
width: 280px;
/* font-weight: bold; */
border-right: 1px dotted #777;
padding-right: 10px;
}
.rpc-row-info > .module {
width: 120px;
font-weight: bold;
border-right: 1px dotted #777;
text-align: right;
padding-right: 10px;
}
.rpc-row-info > .tags > .tag > span:first-child {

31
backend/resources/api-doc.tmpl
View file

@ -20,12 +20,42 @@
</header>
<section class="rpc-doc-content">
<h2>RPC COMMAND METHODS:</h2>
<ul class="rpc-items">
{% for item in command-methods %}
<li class="rpc-item">
<div class="rpc-row-info">
{# <div class="type">{{item.type}}</div> #}
<div class="module">{{item.module}}:</div>
<div class="name">{{item.name}}</div>
<div class="tags">
<span class="tag">
<span>Auth:</span>
<span>{% if item.auth %}YES{% else %}NO{% endif %}</span>
</span>
</div>
</div>
<div class="rpc-row-detail hidden">
{% if item.docs %}
<h3>DOCSTRING:</h3>
<p>{{item.docs}}</p>
{% endif %}
<h3>SPEC EXPLAIN:</h3>
<pre>{{item.spec}}</pre>
</div>
</li>
{% endfor %}
</ul>
<h2>RPC QUERY METHODS:</h2>
<ul class="rpc-items">
{% for item in query-methods %}
<li class="rpc-item">
<div class="rpc-row-info">
{# <div class="type">{{item.type}}</div> #}
<div class="module">{{item.module}}:</div>
<div class="name">{{item.name}}</div>
<div class="tags">
<span class="tag">
@ -53,6 +83,7 @@
<li class="rpc-item">
<div class="rpc-row-info">
{# <div class="type">{{item.type}}</div> #}
<div class="module">{{item.module}}:</div>
<div class="name">{{item.name}}</div>
<div class="tags">
<span class="tag">

15
backend/resources/log4j2-devenv.xml
View file

@ -20,11 +20,17 @@
</Appenders>
<Loggers>
<Logger name="com.zaxxer.hikari" level="error"/>
<Logger name="io.lettuce" level="error" />
<Logger name="org.eclipse.jetty" level="error" />
<Logger name="com.zaxxer.hikari" level="error"/>
<Logger name="org.postgresql" level="error" />
<Logger name="app.rpc.commands.binfile" level="debug" />
<Logger name="app.storage.tmp" level="trace" />
<Logger name="app.worker" level="info" />
<Logger name="app.msgbus" level="info" />
<Logger name="app.http.websocket" level="info" />
<Logger name="app.util.websocket" level="info" />
<Logger name="app.cli" level="debug" additivity="false">
<AppenderRef ref="console"/>
</Logger>
@ -38,11 +44,6 @@
<AppenderRef ref="zmq" level="debug" />
</Logger>
<Logger name="penpot" level="debug" additivity="false">
<AppenderRef ref="main" level="debug" />
<AppenderRef ref="zmq" level="debug" />
</Logger>
<Logger name="user" level="trace" additivity="false">
<AppenderRef ref="main" level="trace" />
</Logger>

14
backend/resources/log4j2.xml
View file

@ -7,17 +7,21 @@
</Appenders>
<Loggers>
<Logger name="io.lettuce" level="error" />
<Logger name="com.zaxxer.hikari" level="error" />
<Logger name="org.eclipse.jetty" level="error" />
<Logger name="org.postgresql" level="error" />
<Logger name="app.rpc.commands.binfile" level="info" />
<Logger name="app.storage.tmp" level="info" />
<Logger name="app.worker" level="info" />
<Logger name="app.msgbus" level="info" />
<Logger name="app.http.websocket" level="info" />
<Logger name="app.util.websocket" level="info" />
<Logger name="app" level="debug" additivity="false">
<AppenderRef ref="console" />
</Logger>
<Logger name="penpot" level="fatal" additivity="false">
<AppenderRef ref="console" />
</Logger>
<Root level="info">
<AppenderRef ref="console" />
</Root>

125
backend/resources/templates/debug.tmpl
View file

@ -10,23 +10,118 @@ Debug Main Page
<div>[<a href="/dbg/error">ERRORS</a>]</div>
</nav>
<main class="index">
<section>
<h2>Download file data:</h2>
<desc>Given an FILE-ID, downloads the file data as file. The file data is encoded using transit.</desc>
<form method="get" action="/dbg/file/data">
<input type="text" style="width:300px" name="file-id" placeholder="file-id" />
<input type="hidden" name="download" value="1" />
<input type="submit" value="Download" />
</form>
<section class="widget">
<fieldset>
<legend>Download file data:</legend>
<desc>Given an FILE-ID, downloads the file data as file. The file data is encoded using transit.</desc>
<form method="get" action="/dbg/file/data">
<div class="row">
<input type="text" style="width:300px" name="file-id" placeholder="file-id" />
</div>
<div class="row">
<input type="submit" name="download" value="Download" />
<input type="submit" name="clone" value="Clone" />
</div>
</form>
</fieldset>
<fieldset>
<legend>Upload File Data:</legend>
<desc>Create a new file on your draft projects using the file downloaded from the previous section.</desc>
<form method="post" enctype="multipart/form-data" action="/dbg/file/data">
<div class="row">
<input type="file" name="file" value="" />
</div>
<div class="row">
<label>Import with same id?</label>
<input type="checkbox" name="reuseid" />
</div>
<input type="submit" value="Upload" />
</form>
</fieldset>
</section>
<section>
<h2>Upload File Data:</h2>
<desc>Create a new file on your draft projects using the file downloaded from the previous section.</desc>
<form method="post" enctype="multipart/form-data" action="/dbg/file/data">
<input type="file" name="file" value="" />
<input type="submit" value="Upload" />
</form>
<section class="widget">
<fieldset>
<legend>Export binfile:</legend>
<desc>Given an FILE-ID, downloads the file and optionally all
the related libraries in a single custom formatted binary
file.</desc>
<form method="get" action="/dbg/file/export">
<div class="row set-of-inputs">
<input type="text" style="width:300px" name="file-ids" placeholder="file-id" />
<input type="text" style="width:300px" name="file-ids" placeholder="file-id" />
<input type="text" style="width:300px" name="file-ids" placeholder="file-id" />
<input type="text" style="width:300px" name="file-ids" placeholder="file-id" />
</div>
<div class="row">
<label>Include libraries?</label>
<input type="checkbox" name="includelibs" />
</div>
<div class="row">
<label>Embed assets?</label>
<input type="checkbox" name="embedassets" checked/>
</div>
<div class="row">
<input type="submit" name="download" value="Download" />
<input type="submit" name="clone" value="Clone" />
</div>
</form>
</fieldset>
<fieldset>
<legend>Import binfile:</legend>
<desc>Import penpot file in binary
format. If <strong>overwrite</strong> is checked, all files will
be overwriten using the same ids found in the file instead of
generating a new ones.</desc>
<form method="post" enctype="multipart/form-data" action="/dbg/file/import">
<div class="row">
<input type="file" name="file" value="" />
</div>
<div class="row">
<label>Overwrite?</label>
<input type="checkbox" name="overwrite" />
<br />
<small>
Instead of creating a new file with all relations remaped,
reuses all ids and updates/overwrites the objects that are
already exists on the database.
<strong>Warning, this operation should be used with caution.</strong>
</small>
</div>
<div class="row">
<label>Migrate?</label>
<input type="checkbox" name="migrate" />
<br />
<small>
Applies the file migrations on the importation process.
</small>
</div>
<div class="row">
<label>Ignore index errors?</label>
<input type="checkbox" name="ignore-index-errors" checked/>
<br />
<small>
Do not break on index lookup erros (remap operation).
Useful when importing a broken file that has broken
relations or missing pieces.
</small>
</div>
<div class="row">
<input type="submit" name="upload" value="Upload" />
</div>
</form>
</fieldset>
</section>
</main>
{% endblock %}

35
backend/resources/templates/styles.css
View file

@ -14,7 +14,6 @@ pre {
}
desc {
display: flex;
margin-bottom: 10px;
font-size: 10px;
color: #666;
@ -28,6 +27,15 @@ main {
margin: 20px;
}
small {
font-size: 9px;
color: #888;
}
small > strong {
font-size: 9px;
}
nav {
position: fixed;
width: 100vw;
@ -95,17 +103,25 @@ nav > div:not(:last-child) {
.index {
margin-top: 40px;
display: flex;
}
.index > section {
padding: 10px;
background-color: #e3e3e3;
max-width: 400px;
margin: 5px;
height: fit-content;
}
.index > section:not(:last-child) {
margin-bottom: 10px;
.index fieldset:not(:first-child) {
margin-top: 15px;
}
/* .index > section:not(:last-child) { */
/* margin-bottom: 10px; */
/* } */
.index > section > h2 {
margin-top: 0px;
@ -148,3 +164,16 @@ nav > div:not(:last-child) {
color: inherit;
}
form .row {
padding: 5px 0;
}
.set-of-inputs {
flex-direction: column;
display: flex;
}
.set-of-inputs input:not(:last-child) {
margin-bottom: 3px;
}

6
backend/scripts/repl
View file

@ -24,9 +24,8 @@ mc mb penpot-s3/penpot -p
export AWS_ACCESS_KEY_ID=penpot-devenv
export AWS_SECRET_ACCESS_KEY=penpot-devenv
export PENPOT_ASSETS_STORAGE_BACKEND=assets-fs
export PENPOT_ASSETS_STORAGE_BACKEND=assets-s3
export PENPOT_STORAGE_ASSETS_S3_ENDPOINT=http://minio:9000
export PENPOT_STORAGE_ASSETS_S3_REGION=eu-central-1
export PENPOT_STORAGE_ASSETS_S3_BUCKET=penpot
export OPTIONS="
@ -40,6 +39,9 @@ export OPTIONS="
-J-XX:+UnlockDiagnosticVMOptions \
-J-XX:+DebugNonSafepoints";
# Uncomment for use the ImageMagick v7.x
# export OPTIONS="-J-Dim4java.useV7=true $OPTIONS";
export OPTIONS_EVAL="nil"
# export OPTIONS_EVAL="(set! *warn-on-reflection* true)"

137
backend/src/app/auth/ldap.clj Normal file
View file

@ -0,0 +1,137 @@
;; 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) UXBOX Labs SL
(ns app.auth.ldap
(:require
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.config :as cf]
[clj-ldap.client :as ldap]
[clojure.spec.alpha :as s]
[clojure.string]
[integrant.core :as ig]))
(defn- prepare-params
[cfg]
{:ssl? (:ssl cfg)
:startTLS? (:tls cfg)
:bind-dn (:bind-dn cfg)
:password (:bind-password cfg)
:host {:address (:host cfg)
:port (:port cfg)}})
(defn- connect
"Connects to the LDAP provider and returns a connection. An
exception is raised if no connection is possible."
^java.lang.AutoCloseable
[cfg]
(try
(-> cfg prepare-params ldap/connect)
(catch Throwable cause
(ex/raise :type :restriction
:code :unable-to-connect-to-ldap
:hint "unable to connect to ldap server"
:cause cause))))
(defn- replace-several [s & {:as replacements}]
(reduce-kv clojure.string/replace s replacements))
(defn- search-user
[{:keys [conn attrs base-dn] :as cfg} email]
(let [query (replace-several (:query cfg) ":username" email)
params {:filter query
:sizelimit 1
:attributes attrs}]
(first (ldap/search conn base-dn params))))
(defn- retrieve-user
[{:keys [conn] :as cfg} {:keys [email password]}]
(when-let [{:keys [dn] :as user} (search-user cfg email)]
(when (ldap/bind? conn dn password)
{:fullname (get user (-> cfg :attrs-fullname keyword))
:email email
:backend "ldap"})))
(s/def ::fullname ::us/not-empty-string)
(s/def ::email ::us/email)
(s/def ::backend ::us/not-empty-string)
(s/def ::info-data
(s/keys :req-un [::fullname ::email ::backend]))
(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))
(ex/raise :type :restriction
:code :wrong-ldap-response
:explain explain)))
user)))
(defn- try-connectivity
[cfg]
;; If we have ldap parameters, try to establish connection
(when (and (:bind-dn cfg)
(:bind-password cfg)
(:host cfg)
(:port cfg))
(try
(with-open [_ (connect cfg)]
(l/info :hint "provider initialized"
:provider "ldap"
:host (:host cfg)
:port (:port cfg)
:tls? (:tls cfg)
:ssl? (:ssl cfg)
:bind-dn (:bind-dn cfg)
:base-dn (:base-dn cfg)
:query (:query cfg))
cfg)
(catch Throwable cause
(l/error :hint "unable to connect to LDAP server (LDAP auth provider disabled)"
:host (:host cfg) :port (:port cfg) :cause cause)
nil))))
(defn- prepare-attributes
[cfg]
(assoc cfg :attrs [(:attrs-username cfg)
(:attrs-email cfg)
(:attrs-fullname cfg)]))
(defmethod ig/init-key ::provider
[_ cfg]
(when (:enabled? cfg)
(some-> cfg try-connectivity prepare-attributes)))
(s/def ::enabled? ::us/boolean)
(s/def ::host ::cf/ldap-host)
(s/def ::port ::cf/ldap-port)
(s/def ::ssl ::cf/ldap-ssl)
(s/def ::tls ::cf/ldap-starttls)
(s/def ::query ::cf/ldap-user-query)
(s/def ::base-dn ::cf/ldap-base-dn)
(s/def ::bind-dn ::cf/ldap-bind-dn)
(s/def ::bind-password ::cf/ldap-bind-password)
(s/def ::attrs-email ::cf/ldap-attrs-email)
(s/def ::attrs-fullname ::cf/ldap-attrs-fullname)
(s/def ::attrs-username ::cf/ldap-attrs-username)
(defmethod ig/pre-init-spec ::provider
[_]
(s/keys :opt-un [::host ::port
::ssl ::tls
::enabled?
::bind-dn
::bind-password
::query
::attrs-email
::attrs-username
::attrs-fullname]))

509
backend/src/app/http/oauth.clj → backend/src/app/auth/oidc.clj
View file

@ -4,19 +4,23 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.http.oauth
(ns app.auth.oidc
"OIDC client implementation."
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.uri :as u]
[app.config :as cf]
[app.db :as db]
[app.http.middleware :as hmw]
[app.loggers.audit :as audit]
[app.rpc.queries.profile :as profile]
[app.util.json :as json]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.set :as set]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
@ -25,6 +29,218 @@
[promesa.exec :as px]
[yetti.response :as yrs]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- obfuscate-string
[s]
(if (< (count s) 10)
(apply str (take (count s) (repeat "*")))
(str (subs s 0 5)
(apply str (take (- (count s) 5) (repeat "*"))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OIDC PROVIDER (GENERIC)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- discover-oidc-config
[{:keys [http-client]} {:keys [base-uri] :as opts}]
(let [discovery-uri (u/join base-uri ".well-known/openid-configuration")
response (ex/try (http-client {:method :get :uri (str discovery-uri)} {:sync? true}))]
(cond
(ex/exception? response)
(do
(l/warn :hint "unable to discover oidc configuration"
:discover-uri (str discovery-uri)
:cause response)
nil)
(= 200 (:status response))
(let [data (json/read (:body response))]
{:token-uri (get data :token_endpoint)
:auth-uri (get data :authorization_endpoint)
:user-uri (get data :userinfo_endpoint)})
:else
(do
(l/warn :hint "unable to discover OIDC configuration"
:uri (str discovery-uri)
:response-status-code (:status response))
nil))))
(defn- prepare-oidc-opts
[cfg]
(let [opts {:base-uri (:base-uri cfg)
:client-id (:client-id cfg)
:client-secret (:client-secret cfg)
:token-uri (:token-uri cfg)
:auth-uri (:auth-uri cfg)
:user-uri (:user-uri cfg)
:scopes (:scopes cfg #{"openid" "profile" "email"})
:roles-attr (:roles-attr cfg)
:roles (:roles cfg)
:name "oidc"}
opts (d/without-nils opts)]
(when (and (string? (:base-uri opts))
(string? (:client-id opts))
(string? (:client-secret opts)))
(if (and (string? (:token-uri opts))
(string? (:user-uri opts))
(string? (:auth-uri opts)))
opts
(some-> (discover-oidc-config cfg opts)
(merge opts {:discover? true}))))))
(defmethod ig/prep-key ::generic-provider
[_ cfg]
(d/without-nils cfg))
(defmethod ig/init-key ::generic-provider
[_ cfg]
(when (:enabled? cfg)
(if-let [opts (prepare-oidc-opts cfg)]
(do
(l/info :hint "provider initialized"
:provider :oidc
:method (if (:discover? opts) "discover" "manual")
:client-id (:client-id opts)
:client-secret (obfuscate-string (:client-secret opts))
:scopes (str/join "," (:scopes opts))
:auth-uri (:auth-uri opts)
:user-uri (:user-uri opts)
:token-uri (:token-uri opts)
:roles-attr (:roles-attr opts)
:roles (:roles opts))
opts)
(do
(l/warn :hint "unable to initialize auth provider, missing configuration" :provider :oidc)
nil))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GOOGLE AUTH PROVIDER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/prep-key ::google-provider
[_ cfg]
(d/without-nils cfg))
(defmethod ig/init-key ::google-provider
[_ cfg]
(let [opts {:client-id (:client-id cfg)
:client-secret (:client-secret cfg)
:scopes #{"openid" "email" "profile"}
:auth-uri "https://accounts.google.com/o/oauth2/v2/auth"
:token-uri "https://oauth2.googleapis.com/token"
:user-uri "https://openidconnect.googleapis.com/v1/userinfo"
:name "google"}]
(when (:enabled? cfg)
(if (and (string? (:client-id opts))
(string? (:client-secret opts)))
(do
(l/info :hint "provider initialized"
:provider :google
:client-id (:client-id opts)
:client-secret (obfuscate-string (:client-secret opts)))
opts)
(do
(l/warn :hint "unable to initialize auth provider, missing configuration" :provider :google)
nil)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GITHUB AUTH PROVIDER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- retrieve-github-email
[{:keys [http-client]} tdata info]
(or (some-> info :email p/resolved)
(-> (http-client {:uri "https://api.github.com/user/emails"
:headers {"Authorization" (dm/str (:type tdata) " " (:token tdata))}
:timeout 6000
:method :get})
(p/then (fn [{:keys [status body] :as response}]
(when-not (s/int-in-range? 200 300 status)
(ex/raise :type :internal
:code :unable-to-retrieve-github-emails
:hint "unable to retrieve github emails"
:http-status status
:http-body body))
(->> response :body json/read (filter :primary) first :email))))))
(defmethod ig/prep-key ::github-provider
[_ cfg]
(d/without-nils cfg))
(defmethod ig/init-key ::github-provider
[_ cfg]
(let [opts {:client-id (:client-id cfg)
:client-secret (:client-secret cfg)
:scopes #{"read:user" "user:email"}
:auth-uri "https://github.com/login/oauth/authorize"
:token-uri "https://github.com/login/oauth/access_token"
:user-uri "https://api.github.com/user"
:name "github"
;; Additional hooks for provider specific way of
;; retrieve emails.
:get-email-fn (partial retrieve-github-email cfg)}]
(when (:enabled? cfg)
(if (and (string? (:client-id opts))
(string? (:client-secret opts)))
(do
(l/info :hint "provider initialized"
:provider :github
:client-id (:client-id opts)
:client-secret (obfuscate-string (:client-secret opts)))
opts)
(do
(l/warn :hint "unable to initialize auth provider, missing configuration" :provider :github)
nil)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GITLAB AUTH PROVIDER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/prep-key ::gitlab-provider
[_ cfg]
(d/without-nils cfg))
(defmethod ig/init-key ::gitlab-provider
[_ cfg]
(let [base (:base-uri cfg "https://gitlab.com")
opts {:base-uri base
:client-id (:client-id cfg)
:client-secret (:client-secret cfg)
:scopes #{"openid" "profile" "email"}
:auth-uri (str base "/oauth/authorize")
:token-uri (str base "/oauth/token")
:user-uri (str base "/oauth/userinfo")
:name "gitlab"}]
(when (:enabled? cfg)
(if (and (string? (:client-id opts))
(string? (:client-secret opts)))
(do
(l/info :hint "provider initialized"
:provider :gitlab
:base-uri base
:client-id (:client-id opts)
:client-secret (obfuscate-string (:client-secret opts)))
opts)
(do
(l/warn :hint "unable to initialize auth provider, missing configuration" :provider :gitlab)
nil)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HANDLERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- build-redirect-uri
[{:keys [provider] :as cfg}]
(let [public (u/uri (:public-uri cfg))]
@ -81,47 +297,35 @@
:timeout 6000
:method :get}))
(retrieve-emails []
(if (some? (:emails-uri provider))
(http-client {:uri (:emails-uri provider)
:headers {"Authorization" (str (:type tdata) " " (:token tdata))}
:timeout 6000
:method :get})
(p/resolved {:status 200})))
(validate-response [[retrieve-res emails-res]]
(when-not (s/int-in-range? 200 300 (:status retrieve-res))
(validate-response [response]
(when-not (s/int-in-range? 200 300 (:status response))
(ex/raise :type :internal
:code :unable-to-retrieve-user-info
:hint "unable to retrieve user info"
:http-status (:status retrieve-res)
:http-body (:body retrieve-res)))
(when-not (s/int-in-range? 200 300 (:status emails-res))
(ex/raise :type :internal
:code :unable-to-retrieve-user-info
:hint "unable to retrieve user info"
:http-status (:status emails-res)
:http-body (:body emails-res)))
[retrieve-res emails-res])
:http-status (:status response)
:http-body (:body response)))
response)
(get-email [info]
(let [attr-kw (cf/get :oidc-email-attr :email)]
(get info attr-kw)))
;; Allow providers hook into this for custom email
;; retrieval method.
(if-let [get-email-fn (:get-email-fn provider)]
(get-email-fn tdata info)
(let [attr-kw (cf/get :oidc-email-attr :email)]
(get info attr-kw))))
(get-name [info]
(let [attr-kw (cf/get :oidc-name-attr :name)]
(get info attr-kw)))
(process-response [[retrieve-res emails-res]]
(let [info (json/read (:body retrieve-res))
email (if (some? (:extract-email-callback provider))
((:extract-email-callback provider) emails-res)
(get-email info))]
(process-response [response]
(p/let [info (-> response :body json/read)
email (get-email info)]
{:backend (:name provider)
:email email
:fullname (or (get-name info) email)
:props (->> (dissoc info :name :email)
(qualify-props provider))}))
:props (->> (dissoc info :name :email)
(qualify-props provider))}))
(validate-info [info]
(when-not (s/valid? ::info info)
@ -133,10 +337,10 @@
:info info))
info)]
(-> (p/all [(retrieve) (retrieve-emails)])
(p/then' validate-response)
(p/then' process-response)
(p/then' validate-info))))
(-> (retrieve)
(p/then validate-response)
(p/then process-response)
(p/then validate-info))))
(s/def ::backend ::us/not-empty-string)
(s/def ::email ::us/not-empty-string)
@ -195,8 +399,6 @@
(p/then' validate-oidc)
(p/then' (partial post-process state))))))
;; --- HTTP HANDLERS
(defn- retrieve-profile
[{:keys [pool executor] :as cfg} info]
(px/with-dispatch executor
@ -256,21 +458,18 @@
(redirect-response uri))))
(defn- auth-handler
[{:keys [tokens] :as cfg} {:keys [params] :as request} respond raise]
(try
(let [props (audit/extract-utm-params params)
state (tokens :generate
{:iss :oauth
:invitation-token (:invitation-token params)
:props props
:exp (dt/in-future "15m")})
uri (build-auth-uri cfg state)]
(respond (yrs/response 200 {:redirect-uri uri})))
(catch Throwable cause
(raise cause))))
[{:keys [tokens] :as cfg} {:keys [params] :as request}]
(let [props (audit/extract-utm-params params)
state (tokens :generate
{:iss :oauth
:invitation-token (:invitation-token params)
:props props
:exp (dt/in-future "15m")})
uri (build-auth-uri cfg state)]
(yrs/response 200 {:redirect-uri uri})))
(defn- callback-handler
[cfg request respond _]
[cfg request]
(letfn [(process-request []
(p/let [info (retrieve-info cfg request)
profile (retrieve-profile cfg info)]
@ -278,182 +477,62 @@
(handle-error [cause]
(l/error :hint "error on oauth process" :cause cause)
(respond (generate-error-redirect cfg cause)))]
(generate-error-redirect cfg cause))]
(-> (process-request)
(p/then respond)
(p/catch handle-error))))
;; --- INIT
(declare initialize)
(def provider-lookup
{:compile
(fn [& _]
(fn [handler]
(fn [{:keys [providers] :as cfg} request]
(let [provider (some-> request :path-params :provider keyword)]
(if-let [provider (get providers provider)]
(handler (assoc cfg :provider provider) request)
(ex/raise :type :restriction
:code :provider-not-configured
:provider provider
:hint "provider not configured"))))))})
(s/def ::public-uri ::us/not-empty-string)
(s/def ::http-client fn?)
(s/def ::session map?)
(s/def ::tokens fn?)
(s/def ::rpc map?)
(s/def ::providers map?)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::public-uri ::session ::tokens ::rpc ::db/pool]))
(defmethod ig/pre-init-spec ::routes
[_]
(s/keys :req-un [::public-uri
::session
::tokens
::http-client
::providers
::db/pool
::wrk/executor]))
(defn wrap-handler
[cfg handler]
(fn [request respond raise]
(let [provider (get-in request [:path-params :provider])
provider (get-in @cfg [:providers provider])]
(if provider
(handler (assoc @cfg :provider provider)
request
respond
raise)
(raise
(ex/error
:type :not-found
:provider provider
:hint "provider not configured"))))))
(defmethod ig/init-key ::routes
[_ {:keys [executor session] :as cfg}]
(let [cfg (update cfg :provider d/without-nils)]
["" {:middleware [[(:middleware session)]
[hmw/with-promise-async executor]
[hmw/with-config cfg]
[provider-lookup]
]}
;; We maintain the both URI prefixes for backward compatibility.
(defmethod ig/init-key ::handler
[_ cfg]
(let [cfg (initialize cfg)]
{:handler (wrap-handler cfg auth-handler)
:callback-handler (wrap-handler cfg callback-handler)}))
["/auth/oauth"
["/:provider"
{:handler auth-handler
:allowed-methods #{:post}}]
["/:provider/callback"
{:handler callback-handler
:allowed-methods #{:get}}]]
(defn- discover-oidc-config
[{:keys [http-client]} {:keys [base-uri] :as opts}]
(let [discovery-uri (u/join base-uri ".well-known/openid-configuration")
response (ex/try (http-client {:method :get :uri (str discovery-uri)} {:sync? true}))]
(cond
(ex/exception? response)
(do
(l/warn :hint "unable to discover oidc configuration"
:discover-uri (str discovery-uri)
:cause response)
nil)
(= 200 (:status response))
(let [data (json/read (:body response))]
{:token-uri (get data :token_endpoint)
:auth-uri (get data :authorization_endpoint)
:user-uri (get data :userinfo_endpoint)})
:else
(do
(l/warn :hint "unable to discover OIDC configuration"
:uri (str discovery-uri)
:response-status-code (:status response))
nil))))
(defn- obfuscate-string
[s]
(if (< (count s) 10)
(apply str (take (count s) (repeat "*")))
(str (subs s 0 5)
(apply str (take (- (count s) 5) (repeat "*"))))))
(defn- initialize-oidc-provider
[cfg]
(let [opts {:base-uri (cf/get :oidc-base-uri)
:client-id (cf/get :oidc-client-id)
:client-secret (cf/get :oidc-client-secret)
:token-uri (cf/get :oidc-token-uri)
:auth-uri (cf/get :oidc-auth-uri)
:user-uri (cf/get :oidc-user-uri)
:scopes (cf/get :oidc-scopes #{"openid" "profile" "email"})
:roles-attr (cf/get :oidc-roles-attr)
:roles (cf/get :oidc-roles)
:name "oidc"}]
(if (and (string? (:base-uri opts))
(string? (:client-id opts))
(string? (:client-secret opts)))
(do
(l/debug :hint "initialize oidc provider" :name "generic-oidc"
:opts (update opts :client-secret obfuscate-string))
(if (and (string? (:token-uri opts))
(string? (:user-uri opts))
(string? (:auth-uri opts)))
(do
(l/debug :hint "initialized with user provided configuration")
(assoc-in cfg [:providers "oidc"] opts))
(do
(l/debug :hint "trying to discover oidc provider configuration using BASE_URI")
(if-let [opts' (discover-oidc-config cfg opts)]
(do
(l/debug :hint "discovered opts" :additional-opts opts')
(assoc-in cfg [:providers "oidc"] (merge opts opts')))
cfg))))
cfg)))
(defn- initialize-google-provider
[cfg]
(let [opts {:client-id (cf/get :google-client-id)
:client-secret (cf/get :google-client-secret)
:scopes #{"openid" "email" "profile"}
:auth-uri "https://accounts.google.com/o/oauth2/v2/auth"
:token-uri "https://oauth2.googleapis.com/token"
:user-uri "https://openidconnect.googleapis.com/v1/userinfo"
:name "google"}]
(if (and (string? (:client-id opts))
(string? (:client-secret opts)))
(do
(l/info :action "initialize" :provider "google"
:opts (pr-str (update opts :client-secret obfuscate-string)))
(assoc-in cfg [:providers "google"] opts))
cfg)))
(defn extract-github-email
[response]
(let [emails (json/read (:body response))
primary-email (->> emails
(filter #(:primary %))
first)]
(:email primary-email)))
(defn- initialize-github-provider
[cfg]
(let [opts {:client-id (cf/get :github-client-id)
:client-secret (cf/get :github-client-secret)
:scopes #{"read:user" "user:email"}
:auth-uri "https://github.com/login/oauth/authorize"
:token-uri "https://github.com/login/oauth/access_token"
:emails-uri "https://api.github.com/user/emails"
:extract-email-callback extract-github-email
:user-uri "https://api.github.com/user"
:name "github"}]
(if (and (string? (:client-id opts))
(string? (:client-secret opts)))
(do
(l/info :action "initialize" :provider "github"
:opts (pr-str (update opts :client-secret obfuscate-string)))
(assoc-in cfg [:providers "github"] opts))
cfg)))
(defn- initialize-gitlab-provider
[cfg]
(let [base (cf/get :gitlab-base-uri "https://gitlab.com")
opts {:base-uri base
:client-id (cf/get :gitlab-client-id)
:client-secret (cf/get :gitlab-client-secret)
:scopes #{"openid" "profile" "email"}
:auth-uri (str base "/oauth/authorize")
:token-uri (str base "/oauth/token")
:user-uri (str base "/oauth/userinfo")
:name "gitlab"}]
(if (and (string? (:client-id opts))
(string? (:client-secret opts)))
(do
(l/info :action "initialize" :provider "gitlab"
:opts (pr-str (update opts :client-secret obfuscate-string)))
(assoc-in cfg [:providers "gitlab"] opts))
cfg)))
(defn- initialize
[cfg]
(let [cfg (agent cfg :error-mode :continue)]
(send-off cfg initialize-google-provider)
(send-off cfg initialize-gitlab-provider)
(send-off cfg initialize-github-provider)
(send-off cfg initialize-oidc-provider)
cfg))
["/auth/oidc"
["/:provider"
{:handler auth-handler
:allowed-methods #{:post}}]
["/:provider/callback"
{:handler callback-handler
:allowed-methods #{:get}}]]]))

5
backend/src/app/cli/manage.clj
View file

@ -10,6 +10,7 @@
[app.common.logging :as l]
[app.db :as db]
[app.main :as main]
[app.rpc.commands.auth :as cmd.auth]
[app.rpc.mutations.profile :as profile]
[app.rpc.queries.profile :refer [retrieve-profile-data-by-email]]
[clojure.string :as str]
@ -54,13 +55,13 @@
:type :password}))]
(try
(db/with-atomic [conn (:app.db/pool system)]
(->> (profile/create-profile conn
(->> (cmd.auth/create-profile conn
{:fullname fullname
:email email
:password password
:is-active true
:is-demo false})
(profile/create-profile-relations conn)))
(cmd.auth/create-profile-relations conn)))
(when (pos? (:verbosity options))
(println "User created successfully."))

19
backend/src/app/config.clj
View file

@ -11,6 +11,7 @@
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.flags :as flags]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.version :as v]
[app.util.time :as dt]
@ -79,18 +80,14 @@
:ldap-attrs-username "uid"
:ldap-attrs-email "mail"
:ldap-attrs-fullname "cn"
:ldap-attrs-photo "jpegPhoto"
;; a server prop key where initial project is stored.
:initial-project-skey "initial-project"})
(s/def ::flags ::us/set-of-keywords)
(s/def ::flags ::us/vec-of-keywords)
;; DEPRECATED PROPERTIES
(s/def ::registration-enabled ::us/boolean)
(s/def ::smtp-enabled ::us/boolean)
(s/def ::telemetry-enabled ::us/boolean)
(s/def ::asserts-enabled ::us/boolean)
;; END DEPRECATED
(s/def ::audit-log-archive-uri ::us/string)
@ -149,7 +146,6 @@
(s/def ::initial-project-skey ::us/string)
(s/def ::ldap-attrs-email ::us/string)
(s/def ::ldap-attrs-fullname ::us/string)
(s/def ::ldap-attrs-photo ::us/string)
(s/def ::ldap-attrs-username ::us/string)
(s/def ::ldap-base-dn ::us/string)
(s/def ::ldap-bind-dn ::us/string)
@ -256,7 +252,6 @@
::initial-project-skey
::ldap-attrs-email
::ldap-attrs-fullname
::ldap-attrs-photo
::ldap-attrs-username
::ldap-base-dn
::ldap-bind-dn
@ -276,7 +271,6 @@
::public-uri
::redis-uri
::registration-domain-whitelist
::registration-enabled
::rlimit-font
::rlimit-file-update
::rlimit-image
@ -287,7 +281,6 @@
::sentry-trace-sample-rate
::smtp-default-from
::smtp-default-reply-to
::smtp-enabled
::smtp-host
::smtp-password
::smtp-port
@ -354,8 +347,12 @@
(str/trim))
"%version%")))
(def ^:dynamic config (read-config))
(def ^:dynamic flags (parse-flags config))
(defonce ^:dynamic config (read-config))
(defonce ^:dynamic flags
(let [flags (parse-flags config)]
(l/info :hint "flags initialized" :flags (str/join "," (map name flags)))
flags))
(def deletion-delay
(dt/duration {:days 7}))

74
backend/src/app/db.clj
View file

@ -55,54 +55,66 @@
(s/def ::migrations map?)
(s/def ::name keyword?)
(s/def ::password ::us/string)
(s/def ::read-only ::us/boolean)
(s/def ::uri ::us/not-empty-string)
(s/def ::username ::us/string)
(s/def ::validation-timeout ::us/integer)
(s/def ::read-only? ::us/boolean)
(defmethod ig/pre-init-spec ::pool [_]
(s/keys :req-un [::uri ::name
(s/def ::pool-options
(s/keys :opt-un [::uri ::name
::min-size
::max-size
::connection-timeout
::validation-timeout]
:opt-un [::migrations
::validation-timeout
::migrations
::username
::password
::mtx/metrics
::read-only]))
::read-only?]))
(def defaults
{:name :main
:min-size 0
:max-size 30
:connection-timeout 10000
:validation-timeout 10000
:idle-timeout 120000 ; 2min
:max-lifetime 1800000 ; 30m
:read-only? false})
(defmethod ig/prep-key ::pool
[_ cfg]
(merge {:name :main
:min-size 0
:max-size 30
:connection-timeout 10000
:validation-timeout 10000
:idle-timeout 120000 ; 2min
:max-lifetime 1800000 ; 30m
:read-only false}
(d/without-nils 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/init-key ::pool
[_ {:keys [migrations name read-only] :as cfg}]
(l/info :hint "initialize connection pool"
:name (d/name name)
:uri (:uri cfg)
:read-only read-only
:with-credentials (and (contains? cfg :username)
(contains? cfg :password))
:min-size (:min-size cfg)
:max-size (:max-size cfg))
[_ {:keys [migrations read-only? uri] :as cfg}]
(if uri
(let [pool (create-pool cfg)]
(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))
(when-not read-only?
(some->> (seq migrations) (apply-migrations! pool)))
pool)
(let [pool (create-pool cfg)]
(when-not read-only
(some->> (seq migrations) (apply-migrations! pool)))
pool))
(do
(l/warn :hint "unable to initialize pool, missing url"
:name (d/name (:name cfg))
:read-only read-only?)
nil)))
(defmethod ig/halt-key! ::pool
[_ pool]
(.close ^HikariDataSource pool))
(when pool
(.close ^HikariDataSource pool)))
(defn- apply-migrations!
[pool migrations]
@ -126,7 +138,7 @@
(.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))
@ -213,7 +225,7 @@
[& args]
`(jdbc/with-transaction ~@args))
(defn ^Connection open
(defn open
[pool]
(jdbc/get-connection pool))

57
backend/src/app/http.clj
View file

@ -9,7 +9,6 @@
[app.common.data :as d]
[app.common.logging :as l]
[app.common.transit :as t]
[app.http.doc :as doc]
[app.http.errors :as errors]
[app.http.middleware :as middleware]
[app.metrics :as mtx]
@ -67,8 +66,10 @@
:xnio/worker-threads (:worker-threads cfg)
:xnio/dispatch (:executor cfg)
:ring/async true}
handler (if (some? router)
(wrap-router router)
handler)
server (yt/server handler (d/without-nils options))]
(assoc cfg :server (yt/start! server))))
@ -113,23 +114,35 @@
;; HTTP ROUTER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::rpc map?)
(s/def ::oauth map?)
(s/def ::storage map?)
(s/def ::assets map?)
(s/def ::feedback fn?)
(s/def ::ws fn?)
(s/def ::audit-handler fn?)
(s/def ::debug map?)
(s/def ::awsns-handler fn?)
(s/def ::session map?)
(s/def ::rpc-routes (s/nilable vector?))
(s/def ::debug-routes (s/nilable vector?))
(s/def ::oidc-routes (s/nilable vector?))
(s/def ::doc-routes (s/nilable vector?))
(defmethod ig/pre-init-spec ::router [_]
(s/keys :req-un [::rpc ::mtx/metrics ::ws ::oauth ::storage ::assets
::session ::feedback ::awsns-handler ::debug ::audit-handler]))
(s/keys :req-un [::mtx/metrics
::ws
::storage
::assets
::session
::feedback
::awsns-handler
::debug-routes
::oidc-routes
::audit-handler
::rpc-routes
::doc-routes]))
(defmethod ig/init-key ::router
[_ {:keys [ws session rpc oauth metrics assets feedback debug] :as cfg}]
[_ {:keys [ws session metrics assets feedback] :as cfg}]
(rr/router
[["" {:middleware [[middleware/server-timing]
[middleware/format-response]
@ -137,20 +150,14 @@
[middleware/parse-request]
[middleware/errors errors/handle]
[middleware/restrict-methods]]}
["/metrics" {:handler (:handler metrics)}]
["/assets" {:middleware [(:middleware session)]}
["/by-id/:id" {:handler (:objects-handler assets)}]
["/by-file-media-id/:id" {:handler (:file-objects-handler assets)}]
["/by-file-media-id/:id/thumbnail" {:handler (:file-thumbnails-handler assets)}]]
["/dbg" {:middleware [(:middleware session)]}
["" {:handler (:index debug)}]
["/changelog" {:handler (:changelog debug)}]
["/error-by-id/:id" {:handler (:retrieve-error debug)}]
["/error/:id" {:handler (:retrieve-error debug)}]
["/error" {:handler (:retrieve-error-list debug)}]
["/file/data" {:handler (:file-data debug)}]
["/file/changes" {:handler (:retrieve-file-changes debug)}]]
(:debug-routes cfg)
["/webhooks"
["/sns" {:handler (:awsns-handler cfg)
@ -161,22 +168,12 @@
:allowed-methods #{:get}}]
["/api" {:middleware [[middleware/cors]
(:middleware session)]}
["/health" {:handler (:health-check debug)}]
["/_doc" {:handler (doc/handler rpc)
:allowed-methods #{:get}}]
["/feedback" {:handler feedback
:allowed-methods #{:post}}]
["/auth/oauth/:provider" {:handler (:handler oauth)
:allowed-methods #{:post}}]
["/auth/oauth/:provider/callback" {:handler (:callback-handler oauth)
:allowed-methods #{:get}}]
[(:middleware session)]]}
["/audit/events" {:handler (:audit-handler cfg)
:allowed-methods #{:post}}]
["/feedback" {:handler feedback
:allowed-methods #{:post}}]
(:doc-routes cfg)
(:oidc-routes cfg)
(:rpc-routes cfg)]]]))
["/rpc"
["/query/:type" {:handler (:query-handler rpc)}]
["/mutation/:type" {:handler (:mutation-handler rpc)
:allowed-methods #{:post}}]]]]]))

329
backend/src/app/http/debug.clj
View file

@ -5,36 +5,39 @@
;; Copyright (c) UXBOX Labs SL
(ns app.http.debug
(:refer-clojure :exclude [error-handler])
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.pprint :as pp]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as sql]
[app.rpc.mutations.files :as m.files]
[app.http.middleware :as mw]
[app.rpc.commands.binfile :as binf]
[app.rpc.mutations.files :refer [create-file]]
[app.rpc.queries.profile :as profile]
[app.util.blob :as blob]
[app.util.bytes :as bs]
[app.util.template :as tmpl]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[datoteka.core :as fs]
[emoji.core :as emj]
[fipp.edn :as fpp]
[integrant.core :as ig]
[markdown.core :as md]
[markdown.transformers :as mdt]
[promesa.core :as p]
[promesa.exec :as px]
[yetti.request :as yrq]
[yetti.response :as yrs]))
;; (selmer.parser/cache-off!)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn authorized?
[pool {:keys [profile-id]}]
(or (= "devenv" (cf/get :host))
@ -42,7 +45,22 @@
admins (or (cf/get :admins) #{})]
(contains? admins (:email profile)))))
(defn index
(defn prepare-response
[body]
(let [headers {"content-type" "application/transit+json"}]
(yrs/response :status 200 :body body :headers headers)))
(defn prepare-download-response
[body filename]
(let [headers {"content-disposition" (str "attachment; filename=" filename)
"content-type" "application/octet-stream"}]
(yrs/response :status 200 :body body :headers headers)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INDEX
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn index-handler
[{:keys [pool]} request]
(when-not (authorized? pool request)
(ex/raise :type :authentication
@ -52,6 +70,9 @@
:body (-> (io/resource "templates/debug.tmpl")
(tmpl/render {}))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FILE CHANGES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def sql:retrieve-range-of-changes
"select revn, changes from file_change where file_id=? and revn >= ? and revn <= ? order by revn")
@ -59,28 +80,16 @@
(def sql:retrieve-single-change
"select revn, changes, data from file_change where file_id=? and revn = ?")
(defn prepare-response
[{:keys [params] :as request} body filename]
(when-not body
(ex/raise :type :not-found
:code :enpty-data
:hint "empty response"))
(cond-> (yrs/response :status 200
:body body
:headers {"content-type" "application/transit+json"})
(contains? params :download)
(update :headers assoc "content-disposition" (str "attachment; filename=" filename))))
(defn- retrieve-file-data
[{:keys [pool]} {:keys [params] :as request}]
[{:keys [pool]} {:keys [params profile-id] :as request}]
(when-not (authorized? pool request)
(ex/raise :type :authentication
:code :only-admins-allowed))
(let [file-id (some-> (get-in request [:params :file-id]) uuid/uuid)
revn (some-> (get-in request [:params :revn]) d/parse-integer)
(let [file-id (some-> params :file-id parse-uuid)
revn (some-> params :revn parse-long)
filename (str file-id)]
(when-not file-id
(ex/raise :type :validation
:code :missing-arguments))
@ -88,35 +97,63 @@
(let [data (if (integer? revn)
(some-> (db/exec-one! pool [sql:retrieve-single-change file-id revn]) :data)
(some-> (db/get-by-id pool :file file-id) :data))]
(if (contains? params :download)
(-> (prepare-response request data filename)
(update :headers assoc "content-type" "application/octet-stream"))
(prepare-response request (some-> data blob/decode) filename)))))
(when-not data
(ex/raise :type :not-found
:code :enpty-data
:hint "empty response"))
(cond
(contains? params :download)
(prepare-download-response data filename)
(contains? params :clone)
(let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)
data (some-> data blob/decode)]
(create-file pool {:id (uuid/next)
:name (str "Cloned file: " filename)
:project-id project-id
:profile-id profile-id
:data data})
(yrs/response 201 "OK CREATED"))
:else
(prepare-response (some-> data blob/decode))))))
(defn- is-file-exists?
[pool id]
(let [sql "select exists (select 1 from file where id=?) as exists;"]
(-> (db/exec-one! pool [sql id]) :exists)))
(defn- upload-file-data
[{:keys [pool]} {:keys [profile-id params] :as request}]
(let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)
data (some-> params :file :path fs/slurp-bytes blob/decode)]
data (some-> params :file :path bs/read-as-bytes blob/decode)]
(if (and data project-id)
(let [fname (str "imported-file-" (dt/now))
file-id (try
(uuid/uuid (-> params :file :filename))
(catch Exception _ (uuid/next)))
file (db/exec-one! pool (sql/select :file {:id file-id}))]
(if file
(db/update! pool :file
{:data (blob/encode data)}
{:id file-id})
(m.files/create-file pool {:id file-id
:name fname
:project-id project-id
:profile-id profile-id
:data data}))
(yrs/response 200 "OK"))
(let [fname (str "Imported file *: " (dt/now))
overwrite? (contains? params :overwrite?)
file-id (or (and overwrite? (ex/ignoring (-> params :file :filename parse-uuid)))
(uuid/next))]
(if (and overwrite? file-id
(is-file-exists? pool file-id))
(do
(db/update! pool :file
{:data (blob/encode data)}
{:id file-id})
(yrs/response 200 "OK UPDATED"))
(do
(create-file pool {:id file-id
:name fname
:project-id project-id
:profile-id profile-id
:data data})
(yrs/response 201 "OK CREATED"))))
(yrs/response 500 "ERROR"))))
(defn file-data
(defn file-data-handler
[cfg request]
(case (yrq/method request)
:get (retrieve-file-data cfg request)
@ -124,43 +161,47 @@
(ex/raise :type :http
:code :method-not-found)))
(defn retrieve-file-changes
[{:keys [pool]} request]
(defn file-changes-handler
[{:keys [pool]} {:keys [params] :as request}]
(when-not (authorized? pool request)
(ex/raise :type :authentication
:code :only-admins-allowed))
(let [file-id (some-> (get-in request [:params :id]) uuid/uuid)
revn (or (get-in request [:params :revn]) "latest")
filename (str file-id)]
(letfn [(retrieve-changes [file-id revn]
(if (str/includes? revn ":")
(let [[start end] (->> (str/split revn #":")
(map str/trim)
(map parse-long))]
(some->> (db/exec! pool [sql:retrieve-range-of-changes file-id start end])
(map :changes)
(map blob/decode)
(mapcat identity)
(vec)))
(when (or (not file-id) (not revn))
(ex/raise :type :validation
:code :invalid-arguments
:hint "missing arguments"))
(if-let [revn (parse-long revn)]
(let [item (db/exec-one! pool [sql:retrieve-single-change file-id revn])]
(some-> item :changes blob/decode vec))
(ex/raise :type :validation :code :invalid-arguments))))]
(cond
(d/num-string? revn)
(let [item (db/exec-one! pool [sql:retrieve-single-change file-id (d/parse-integer revn)])]
(prepare-response request (some-> item :changes blob/decode vec) filename))
(let [file-id (some-> params :id parse-uuid)
revn (or (some-> params :revn parse-long) "latest")
filename (str file-id)]
(str/includes? revn ":")
(let [[start end] (->> (str/split revn #":")
(map str/trim)
(map d/parse-integer))
items (db/exec! pool [sql:retrieve-range-of-changes file-id start end])]
(prepare-response request
(some->> items
(map :changes)
(map blob/decode)
(mapcat identity)
(vec))
filename))
:else
(ex/raise :type :validation :code :invalid-arguments))))
(when (or (not file-id) (not revn))
(ex/raise :type :validation
:code :invalid-arguments
:hint "missing arguments"))
(let [data (retrieve-changes file-id revn)]
(if (contains? params :download)
(prepare-download-response data filename)
(prepare-response data))))))
(defn retrieve-error
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ERROR BROWSER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn error-handler
[{:keys [pool]} request]
(letfn [(parse-id [request]
(let [id (get-in request [:path-params :id])
@ -176,9 +217,8 @@
(let [context (dissoc report
:trace :cause :params :data :spec-problems
:spec-explain :spec-value :error :explain :hint)
params {:context (with-out-str
(fpp/pprint context {:width 200}))
:hint (:hint report)
params {:context (pp/pprint-str context :width 200)
:hint (:hint report)
:spec-explain (:spec-explain report)
:spec-problems (:spec-problems report)
:spec-value (:spec-value report)
@ -206,7 +246,7 @@
(def sql:error-reports
"select id, created_at from server_error_report order by created_at desc limit 100")
(defn retrieve-error-list
(defn error-list-handler
[{:keys [pool]} request]
(when-not (authorized? pool request)
(ex/raise :type :authentication
@ -219,14 +259,94 @@
:headers {"content-type" "text/html; charset=utf-8"
"x-robots-tag" "noindex"})))
(defn health-check
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; EXPORT/IMPORT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn export-handler
[{:keys [pool] :as cfg} {:keys [params profile-id] :as request}]
(let [file-ids (->> (:file-ids params)
(remove empty?)
(mapv parse-uuid))
libs? (contains? params :includelibs)
clone? (contains? params :clone)
embed? (contains? params :embedassets)]
(when-not (seq file-ids)
(ex/raise :type :validation
:code :missing-arguments))
(let [path (-> cfg
(assoc ::binf/file-ids file-ids)
(assoc ::binf/embed-assets? embed?)
(assoc ::binf/include-libraries? libs?)
(binf/export!))]
(if clone?
(let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)]
(binf/import!
(assoc cfg
::binf/input path
::binf/overwrite? false
::binf/ignore-index-errors? true
::binf/profile-id profile-id
::binf/project-id project-id))
(yrs/response
:status 200
:headers {"content-type" "text/plain"}
:body "OK CLONED"))
(yrs/response
:status 200
:headers {"content-type" "application/octet-stream"
"content-disposition" (str "attachmen; filename=" (first file-ids) ".penpot")}
:body (io/input-stream path))))))
(defn import-handler
[{:keys [pool] :as cfg} {:keys [params profile-id] :as request}]
(when-not (contains? params :file)
(ex/raise :type :validation
:code :missing-upload-file
:hint "missing upload file"))
(let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)
overwrite? (contains? params :overwrite)
migrate? (contains? params :migrate)
ignore-index-errors? (contains? params :ignore-index-errors)]
(when-not project-id
(ex/raise :type :validation
:code :missing-project
:hint "project not found"))
(binf/import!
(assoc cfg
::binf/input (-> params :file :path)
::binf/overwrite? overwrite?
::binf/migrate? migrate?
::binf/ignore-index-errors? ignore-index-errors?
::binf/profile-id profile-id
::binf/project-id project-id))
(yrs/response
:status 200
:headers {"content-type" "text/plain"}
:body "OK")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OTHER SMALL VIEWS/HANDLERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn health-handler
"Mainly a task that performs a health check."
[{:keys [pool]} _]
(db/with-atomic [conn pool]
(db/exec-one! conn ["select count(*) as count from server_prop;"])
(yrs/response 200 "OK")))
(defn changelog
(defn changelog-handler
[_ _]
(letfn [(transform-emoji [text state]
[(emj/emojify text) state])
@ -238,22 +358,39 @@
:body (-> clog slurp md->html))
(yrs/response :status 404 :body "NOT FOUND"))))
(defn- wrap-async
[{:keys [executor] :as cfg} f]
(fn [request respond raise]
(-> (px/submit! executor #(f cfg request))
(p/then respond)
(p/catch raise))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INIT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/pre-init-spec ::handlers [_]
(s/keys :req-un [::db/pool ::wrk/executor]))
(def with-authorization
{:compile
(fn [& _]
(fn [handler pool]
(fn [request respond raise]
(if (authorized? pool request)
(handler request respond raise)
(raise (ex/error :type :authentication
:code :only-admins-allowed))))))})
(defmethod ig/init-key ::handlers
[_ cfg]
{:index (wrap-async cfg index)
:health-check (wrap-async cfg health-check)
:retrieve-file-changes (wrap-async cfg retrieve-file-changes)
:retrieve-error (wrap-async cfg retrieve-error)
:retrieve-error-list (wrap-async cfg retrieve-error-list)
:file-data (wrap-async cfg file-data)
:changelog (wrap-async cfg changelog)})
(s/def ::session map?)
(defmethod ig/pre-init-spec ::routes [_]
(s/keys :req-un [::db/pool ::wrk/executor ::session]))
(defmethod ig/init-key ::routes
[_ {:keys [session pool executor] :as cfg}]
["/dbg" {:middleware [[(:middleware session)]
[with-authorization pool]
[mw/with-promise-async executor]
[mw/with-config cfg]]}
["" {:handler index-handler}]
["/health" {:handler health-handler}]
["/changelog" {:handler changelog-handler}]
;; ["/error-by-id/:id" {:handler error-handler}]
["/error/:id" {:handler error-handler}]
["/error" {:handler error-list-handler}]
["/file/export" {:handler export-handler}]
["/file/import" {:handler import-handler}]
["/file/data" {:handler file-data-handler}]
["/file/changes" {:handler file-changes-handler}]])

57
backend/src/app/http/doc.clj
View file

@ -9,14 +9,17 @@
(:require
[app.common.data :as d]
[app.config :as cf]
[app.rpc :as-alias rpc]
[app.util.services :as sv]
[app.util.template :as tmpl]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[integrant.core :as ig]
[pretty-spec.core :as ps]
[yetti.response :as yrs]))
(defn get-spec-str
(defn- get-spec-str
[k]
(with-out-str
(ps/pprint (s/form k)
@ -24,31 +27,47 @@
"clojure.core.specs.alpha" "score"
"clojure.core" nil}})))
(defn prepare-context
[rpc]
(defn- prepare-context
[methods]
(letfn [(gen-doc [type [name f]]
(let [mdata (meta f)]
;; (prn name mdata)
{:type (d/name type)
:name (d/name name)
:module (-> (:ns mdata) (str/split ".") last)
:auth (:auth mdata true)
:docs (::sv/docs mdata)
:spec (get-spec-str (::sv/spec mdata))}))]
{:query-methods
(into []
(map (partial gen-doc :query))
(->> rpc :methods :query (sort-by first)))
:mutation-methods
(into []
(map (partial gen-doc :mutation))
(->> rpc :methods :mutation (sort-by first)))}))
(defn handler
[rpc]
(let [context (prepare-context rpc)]
(if (contains? cf/flags :backend-api-doc)
{:command-methods
(->> (:commands methods)
(map (partial gen-doc :command))
(sort-by (juxt :module :name)))
:query-methods
(->> (:queries methods)
(map (partial gen-doc :query))
(sort-by (juxt :module :name)))
:mutation-methods
(->> (:mutations methods)
(map (partial gen-doc :query))
(sort-by (juxt :module :name)))}))
(defn- handler
[methods]
(if (contains? cf/flags :backend-api-doc)
(let [context (prepare-context methods)]
(fn [_ respond _]
(respond (yrs/response 200 (-> (io/resource "api-doc.tmpl")
(tmpl/render context)))))
(fn [_ respond _]
(respond (yrs/response 404))))))
(tmpl/render context))))))
(fn [_ respond _]
(respond (yrs/response 404)))))
(defmethod ig/pre-init-spec ::routes [_]
(s/keys :req-un [::rpc/methods]))
(defmethod ig/init-key ::routes
[_ {:keys [methods] :as cfg}]
["/_doc" {:handler (handler methods)
:allowed-methods #{:get}}])

4
backend/src/app/http/errors.clj
View file

@ -71,7 +71,7 @@
[error request]
(let [edata (ex-data error)
explain (us/pretty-explain edata)]
(l/error ::l/raw (ex-message error)
(l/error ::l/raw (str (ex-message error) "\n" explain)
::l/context (get-context request)
:cause error)
(yrs/response :status 500
@ -143,13 +143,11 @@
(defn handle
[cause request]
(cond
(or (instance? java.util.concurrent.CompletionException cause)
(instance? java.util.concurrent.ExecutionException cause))
(handle-exception (.getCause ^Throwable cause) request)
(ex/wrapped? cause)
(let [context (meta cause)
cause (deref cause)]

20
backend/src/app/http/middleware.clj
View file

@ -12,6 +12,8 @@
[app.config :as cf]
[app.util.json :as json]
[cuerdas.core :as str]
[promesa.core :as p]
[promesa.exec :as px]
[yetti.adapter :as yt]
[yetti.middleware :as ymw]
[yetti.request :as yrq]
@ -192,3 +194,21 @@
(def restrict-methods
{:name ::restrict-methods
:compile compile-restrict-methods})
(def with-promise-async
{:compile
(fn [& _]
(fn [handler executor]
(fn [request respond raise]
(-> (px/submit! executor #(handler request))
(p/bind p/wrap)
(p/then respond)
(p/catch raise)))))})
(def with-config
{:compile
(fn [& _]
(fn [handler config]
(fn
([request] (handler config request))
([request respond raise] (handler config request respond raise)))))})

25
backend/src/app/http/session.clj
View file

@ -162,21 +162,22 @@
(defn- make-middleware
[{:keys [::events-ch store] :as cfg}]
{:name :session-middleware
:wrap (fn [handler]
(fn [request respond raise]
(try
(-> (retrieve-session store request)
(p/then' #(merge request %))
(p/finally (fn [request cause]
(if cause
(raise cause)
(do
{:name :session
:compile (fn [& _]
(fn [handler]
(fn [request respond raise]
(try
(-> (retrieve-session store request)
(p/then' #(merge request %))
(p/finally (fn [request cause]
(if cause
(raise cause)
(do
(when-let [session-id (:session-id request)]
(a/offer! events-ch session-id))
(handler request respond raise))))))
(catch Throwable cause
(raise cause)))))})
(catch Throwable cause
(raise cause))))))})
;; --- STATE INIT: SESSION

338
backend/src/app/http/websocket.clj
View file

@ -9,28 +9,103 @@
(:require
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.pprint :as pp]
[app.common.spec :as us]
[app.db :as db]
[app.metrics :as mtx]
[app.util.time :as dt]
[app.util.websocket :as ws]
[clojure.core.async :as a]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[yetti.websocket :as yws]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; WEBSOCKET HOOKS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def state (atom {}))
(defn- on-connect
[{:keys [metrics]} wsp]
(let [created-at (dt/now)]
(swap! state assoc (::ws/id @wsp) wsp)
(mtx/run! metrics {:id :websocket-active-connections :inc 1})
(fn []
(swap! state dissoc (::ws/id @wsp))
(mtx/run! metrics {:id :websocket-active-connections :dec 1})
(mtx/run! metrics {:id :websocket-session-timing
:val (/ (inst-ms (dt/diff created-at (dt/now))) 1000.0)}))))
(defn- on-rcv-message
[{:keys [metrics]} _ message]
(mtx/run! metrics {:id :websocket-messages-total :labels ["recv"] :inc 1})
message)
(defn- on-snd-message
[{:keys [metrics]} _ message]
(mtx/run! metrics {:id :websocket-messages-total :labels ["send"] :inc 1})
message)
;; REPL HELPERS
(defn repl-get-connections-for-file
[file-id]
(->> (vals @state)
(filter #(= file-id (-> % deref ::file-subscription :file-id)))
(map deref)
(map ::ws/id)))
(defn repl-get-connections-for-team
[team-id]
(->> (vals @state)
(filter #(= team-id (-> % deref ::team-subscription :team-id)))
(map deref)
(map ::ws/id)))
(defn repl-close-connection
[id]
(when-let [wsp (get @state id)]
(a/>!! (::ws/close-ch @wsp) [8899 "closed from server"])
(a/close! (::ws/close-ch @wsp))))
(defn repl-get-connection-info
[id]
(when-let [wsp (get @state id)]
{:id id
:created-at (dt/instant id)
:profile-id (::profile-id @wsp)
:session-id (::session-id @wsp)
:user-agent (::ws/user-agent @wsp)
:ip-addr (::ws/remote-addr @wsp)
:last-activity-at (::ws/last-activity-at @wsp)
:http-session-id (::ws/http-session-id @wsp)
:subscribed-file (-> wsp deref ::file-subscription :file-id)
:subscribed-team (-> wsp deref ::team-subscription :team-id)}))
(defn repl-print-connection-info
[id]
(some-> id repl-get-connection-info pp/pprint))
(defn repl-print-connection-info-for-file
[file-id]
(some->> (repl-get-connections-for-file file-id)
(map repl-get-connection-info)
(pp/pprint)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; WEBSOCKET HANDLER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmulti handle-message
(fn [_ message]
(fn [_ _ message]
(:type message)))
(defmethod handle-message :connect
[wsp _]
(l/trace :fn "handle-message" :event :connect)
[cfg wsp _]
(let [msgbus-fn (:msgbus @wsp)
(let [msgbus-fn (:msgbus cfg)
conn-id (::ws/id @wsp)
profile-id (::profile-id @wsp)
session-id (::session-id @wsp)
output-ch (::ws/output-ch @wsp)
@ -38,94 +113,122 @@
xform (remove #(= (:session-id %) session-id))
channel (a/chan (a/dropping-buffer 16) xform)]
(swap! wsp assoc ::profile-subs-channel channel)
(l/trace :fn "handle-message" :event :connect :conn-id conn-id)
;; Subscribe to the profile channel and forward all messages to
;; websocket output channel (send them to the client).
(swap! wsp assoc ::profile-subscription channel)
(a/pipe channel output-ch false)
(msgbus-fn :cmd :sub :topic profile-id :chan channel)))
(defmethod handle-message :disconnect
[wsp _]
(l/trace :fn "handle-message" :event :disconnect)
(a/go
(let [msgbus-fn (:msgbus @wsp)
profile-id (::profile-id @wsp)
session-id (::session-id @wsp)
profile-ch (::profile-subs-channel @wsp)
subs (::subscriptions @wsp)]
[cfg wsp _]
(let [msgbus-fn (:msgbus cfg)
conn-id (::ws/id @wsp)
profile-id (::profile-id @wsp)
session-id (::session-id @wsp)
profile-ch (::profile-subscription @wsp)
fsub (::file-subscription @wsp)
tsub (::team-subscription @wsp)
message {:type :disconnect
:subs-id profile-id
:profile-id profile-id
:session-id session-id}]
(l/trace :fn "handle-message"
:event :disconnect
:conn-id conn-id)
(a/go
;; Close the main profile subscription
(a/close! profile-ch)
(a/<! (msgbus-fn :cmd :purge :chans [profile-ch]))
;; Close all other active subscrption on this websocket context.
(doseq [{:keys [channel topic]} (map second subs)]
;; Close tram subscription if exists
(when-let [channel (:channel tsub)]
(a/close! channel)
(a/<! (msgbus-fn :cmd :pub :topic topic
:message {:type :disconnect
:profile-id profile-id
:session-id session-id}))
(a/<! (msgbus-fn :cmd :purge :chans [channel]))))))
(a/<! (msgbus-fn :cmd :purge :chans [channel])))
(when-let [{:keys [topic channel]} fsub]
(a/close! channel)
(a/<! (msgbus-fn :cmd :purge :chans [channel]))
(a/<! (msgbus-fn :cmd :pub :topic topic :message message))))))
(defmethod handle-message :subscribe-team
[wsp {:keys [team-id] :as params}]
(l/trace :fn "handle-message" :event :subscribe-team :team-id team-id)
(let [msgbus-fn (:msgbus @wsp)
[cfg wsp {:keys [team-id] :as params}]
(let [msgbus-fn (:msgbus cfg)
conn-id (::ws/id @wsp)
session-id (::session-id @wsp)
output-ch (::ws/output-ch @wsp)
subs (get-in @wsp [::subscriptions team-id])
prev-subs (get @wsp ::team-subscription)
xform (comp
(remove #(= (:session-id %) session-id))
(map #(assoc % :subs-id team-id)))]
(a/go
(when (not= (:team-id subs) team-id)
;; if it exists we just need to close that
(when-let [channel (:channel subs)]
(a/close! channel)
(a/<! (msgbus-fn :cmd :purge :chans [channel])))
(let [channel (a/chan (a/dropping-buffer 64) xform)]
;; Message forwarding
(a/pipe channel output-ch false)
(let [state {:team-id team-id :channel channel :topic team-id}]
(swap! wsp update ::subscriptions assoc team-id state))
(a/<! (msgbus-fn :cmd :sub :topic team-id :chan channel)))))))
(defmethod handle-message :subscribe-file
[wsp {:keys [subs-id file-id] :as params}]
(l/trace :fn "handle-message" :event :subscribe-file :subs-id subs-id :file-id file-id)
(let [msgbus-fn (:msgbus @wsp)
profile-id (::profile-id @wsp)
session-id (::session-id @wsp)
output-ch (::ws/output-ch @wsp)
xform (comp
(remove #(= (:session-id %) session-id))
(map #(assoc % :subs-id subs-id)))
(map #(assoc % :subs-id team-id)))
channel (a/chan (a/dropping-buffer 64) xform)]
;; Message forwarding
(a/go-loop []
(when-let [{:keys [type] :as message} (a/<! channel)]
(when (or (= :join-file type)
(= :leave-file type)
(= :disconnect type))
(let [message {:type :presence
:file-id file-id
:session-id session-id
:profile-id profile-id}]
(a/<! (msgbus-fn :cmd :pub
:topic file-id
:message message))))
(a/>! output-ch message)
(recur)))
(l/trace :fn "handle-message"
:event :subscribe-team
:team-id team-id
:conn-id conn-id)
(a/pipe channel output-ch false)
(let [state {:team-id team-id :channel channel :topic team-id}]
(swap! wsp assoc ::team-subscription state))
(a/go
;; Close previous subscription if exists
(when-let [channel (:channel prev-subs)]
(a/close! channel)
(a/<! (msgbus-fn :cmd :purge :chans [channel]))))
(a/go
(a/<! (msgbus-fn :cmd :sub :topic team-id :chan channel)))))
(defmethod handle-message :subscribe-file
[cfg wsp {:keys [file-id] :as params}]
(let [msgbus-fn (:msgbus cfg)
conn-id (::ws/id @wsp)
profile-id (::profile-id @wsp)
session-id (::session-id @wsp)
output-ch (::ws/output-ch @wsp)
prev-subs (::file-subscription @wsp)
xform (comp (remove #(= (:session-id %) session-id))
(map #(assoc % :subs-id file-id)))
channel (a/chan (a/dropping-buffer 64) xform)]
(l/trace :fn "handle-message"
:event :subscribe-file
:file-id file-id
:conn-id conn-id)
(let [state {:file-id file-id :channel channel :topic file-id}]
(swap! wsp update ::subscriptions assoc subs-id state))
(swap! wsp assoc ::file-subscription state))
(a/go
;; Close previous subscription if exists
(when-let [channel (:channel prev-subs)]
(a/close! channel)
(a/<! (msgbus-fn :cmd :purge :chans [channel]))))
;; Message forwarding
(a/go
(loop []
(when-let [{:keys [type] :as message} (a/<! channel)]
(when (or (= :join-file type)
(= :leave-file type)
(= :disconnect type))
(let [message {:type :presence
:file-id file-id
:session-id session-id
:profile-id profile-id}]
(a/<! (msgbus-fn :cmd :pub
:topic file-id
:message message))))
(a/>! output-ch message)
(recur))))
(a/go
;; Subscribe to file topic
@ -134,6 +237,7 @@
;; 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}]
(a/<! (msgbus-fn :cmd :pub
@ -141,49 +245,59 @@
:message message))))))
(defmethod handle-message :unsubscribe-file
[wsp {:keys [subs-id] :as params}]
(l/trace :fn "handle-message" :event :unsubscribe-file :subs-id subs-id)
(let [msgbus-fn (:msgbus @wsp)
[cfg wsp {:keys [file-id] :as params}]
(let [msgbus-fn (:msgbus cfg)
conn-id (::ws/id @wsp)
session-id (::session-id @wsp)
profile-id (::profile-id @wsp)]
profile-id (::profile-id @wsp)
subs (::file-subscription @wsp)
message {:type :leave-file
:file-id file-id
:session-id session-id
:profile-id profile-id}]
(l/trace :fn "handle-message"
:event :unsubscribe-file
:file-id file-id
:conn-id conn-id)
(a/go
(when-let [{:keys [file-id channel]} (get-in @wsp [::subscriptions subs-id])]
(let [message {:type :leave-file
:file-id file-id
:session-id session-id
:profile-id profile-id}]
(when (= (:file-id subs) file-id)
(let [channel (:channel subs)]
(a/close! channel)
(a/<! (msgbus-fn :cmd :pub :topic file-id :message message))
(a/<! (msgbus-fn :cmd :purge :chans [channel])))))))
(a/<! (msgbus-fn :cmd :purge :chans [channel]))
(a/<! (msgbus-fn :cmd :pub :topic file-id :message message)))))))
(defmethod handle-message :keepalive
[_ _]
[_ _ _]
(l/trace :fn "handle-message" :event :keepalive)
(a/go :nothing))
(defmethod handle-message :pointer-update
[wsp {:keys [subs-id] :as message}]
(a/go
;; Only allow receive pointer updates when active subscription
(when-let [{:keys [topic]} (get-in @wsp [::subscriptions subs-id])]
(let [msgbus-fn (:msgbus @wsp)
profile-id (::profile-id @wsp)
session-id (::session-id @wsp)
message (-> message
(dissoc :subs-id)
(assoc :profile-id profile-id)
(assoc :session-id session-id))]
[cfg wsp {:keys [file-id] :as message}]
(let [msgbus-fn (:msgbus cfg)
profile-id (::profile-id @wsp)
session-id (::session-id @wsp)
subs (::file-subscription @wsp)
message (-> message
(assoc :subs-id file-id)
(assoc :profile-id profile-id)
(assoc :session-id session-id))]
(a/go
;; Only allow receive pointer updates when active subscription
(when subs
(a/<! (msgbus-fn :cmd :pub
:topic topic
:topic file-id
:message message))))))
(defmethod handle-message :default
[_ message]
(a/go
(l/log :level :warn
:msg "received unexpected message"
:message message)))
[_ wsp message]
(let [conn-id (::ws/id @wsp)]
(l/warn :hint "received unexpected message"
:message message
:conn-id conn-id)
(a/go :none)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HTTP HANDLER
@ -201,12 +315,7 @@
(defmethod ig/init-key ::handler
[_ cfg]
(fn [{:keys [profile-id params] :as req} respond raise]
(let [{:keys [session-id]} (us/conform ::handler-params params)
cfg (-> cfg
(assoc ::profile-id profile-id)
(assoc ::session-id session-id))]
(l/trace :hint "http request to websocket" :profile-id profile-id :session-id session-id)
(let [{:keys [session-id]} (us/conform ::handler-params params)]
(cond
(not profile-id)
(raise (ex/error :type :authentication
@ -218,6 +327,15 @@
:hint "this endpoint only accepts websocket connections"))
:else
(->> (ws/handler handle-message cfg)
(yws/upgrade req)
(respond))))))
(do
(l/trace :hint "websocket request" :profile-id profile-id :session-id session-id)
(->> (ws/handler
::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)
::ws/handler (partial handle-message cfg)
::profile-id profile-id
::session-id session-id)
(yws/upgrade req)
(respond)))))))

18
backend/src/app/loggers/audit.clj
View file

@ -32,7 +32,7 @@
[request]
(or (some-> (yrq/get-header request "x-forwarded-for") (str/split ",") first)
(yrq/get-header request "x-real-ip")
(yrq/remote-addr request)))
(some-> (yrq/remote-addr request) str)))
(defn extract-utm-params
"Extracts additional data from params and namespace them under
@ -257,12 +257,16 @@
(ex/raise :type :internal
:code :task-not-configured
:hint "archive task not configured, missing uri"))
(when enabled
(loop []
(let [res (archive-events cfg)]
(when (= res :continue)
(aa/thread-sleep 200)
(recur))))))))
(loop [total 0]
(let [n (archive-events cfg)]
(if n
(do
(aa/thread-sleep 200)
(recur (+ total n)))
(when (pos? total)
(l/trace :hint "events chunk archived" :num total)))))))))
(def sql:retrieve-batch-of-audit-log
"select * from audit_log
@ -332,7 +336,7 @@
(l/debug :action "archive-events" :uri uri :events (count events))
(when (send events)
(mark-as-archived conn rows)
:continue))))))
(count events)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GC Task

117
backend/src/app/main.clj
View file

@ -6,6 +6,7 @@
(ns app.main
(:require
[app.auth.oidc]
[app.common.logging :as l]
[app.config :as cf]
[app.util.time :as dt]
@ -71,6 +72,10 @@
:app.tokens/tokens
{:keys (ig/ref :app.setup/keys)}
:app.storage.tmp/cleaner
{:executor (ig/ref [::worker :app.worker/executor])
:scheduler (ig/ref :app.worker/scheduler)}
:app.storage/gc-deleted-task
{:pool (ig/ref :app.db/pool)
:storage (ig/ref :app.storage/storage)
@ -86,6 +91,9 @@
:app.http/session
{:store (ig/ref :app.http.session/store)}
:app.http.doc/routes
{:methods (ig/ref :app.rpc/methods)}
:app.http.session/store
{:pool (ig/ref :app.db/pool)
:tokens (ig/ref :app.tokens/tokens)
@ -119,25 +127,88 @@
:max-body-size (cf/get :http-server-max-body-size)
:max-multipart-body-size (cf/get :http-server-max-multipart-body-size)}
:app.auth.ldap/provider
{:host (cf/get :ldap-host)
:port (cf/get :ldap-port)
:ssl (cf/get :ldap-ssl)
:tls (cf/get :ldap-starttls)
:query (cf/get :ldap-user-query)
:attrs-email (cf/get :ldap-attrs-email)
:attrs-fullname (cf/get :ldap-attrs-fullname)
:attrs-username (cf/get :ldap-attrs-username)
: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)}
:app.auth.oidc/google-provider
{:enabled? (contains? cf/flags :login-with-google)
:client-id (cf/get :google-client-id)
:client-secret (cf/get :google-client-secret)}
:app.auth.oidc/github-provider
{:enabled? (contains? cf/flags :login-with-github)
:http-client (ig/ref :app.http/client)
:client-id (cf/get :github-client-id)
:client-secret (cf/get :github-client-secret)}
:app.auth.oidc/gitlab-provider
{:enabled? (contains? cf/flags :login-with-gitlab)
:base-uri (cf/get :gitlab-base-uri "https://gitlab.com")
:client-id (cf/get :gitlab-client-id)
:client-secret (cf/get :gitlab-client-secret)}
:app.auth.oidc/generic-provider
{:enabled? (contains? cf/flags :login-with-oidc)
:http-client (ig/ref :app.http/client)
:client-id (cf/get :oidc-client-id)
:client-secret (cf/get :oidc-client-secret)
:base-uri (cf/get :oidc-base-uri)
:token-uri (cf/get :oidc-token-uri)
:auth-uri (cf/get :oidc-auth-uri)
:user-uri (cf/get :oidc-user-uri)
:scopes (cf/get :oidc-scopes)
:roles-attr (cf/get :oidc-roles-attr)
:roles (cf/get :oidc-roles)}
:app.auth.oidc/routes
{:providers {:google (ig/ref :app.auth.oidc/google-provider)
:github (ig/ref :app.auth.oidc/github-provider)
:gitlab (ig/ref :app.auth.oidc/gitlab-provider)
:oidc (ig/ref :app.auth.oidc/generic-provider)}
:tokens (ig/ref :app.tokens/tokens)
:http-client (ig/ref :app.http/client)
:pool (ig/ref :app.db/pool)
:session (ig/ref :app.http/session)
:public-uri (cf/get :public-uri)
:executor (ig/ref [::default :app.worker/executor])}
:app.http/router
{:assets (ig/ref :app.http.assets/handlers)
:feedback (ig/ref :app.http.feedback/handler)
:session (ig/ref :app.http/session)
:awsns-handler (ig/ref :app.http.awsns/handler)
:oauth (ig/ref :app.http.oauth/handler)
:debug (ig/ref :app.http.debug/handlers)
:debug-routes (ig/ref :app.http.debug/routes)
:oidc-routes (ig/ref :app.auth.oidc/routes)
:ws (ig/ref :app.http.websocket/handler)
:metrics (ig/ref :app.metrics/metrics)
:public-uri (cf/get :public-uri)
:storage (ig/ref :app.storage/storage)
:tokens (ig/ref :app.tokens/tokens)
:audit-handler (ig/ref :app.loggers.audit/http-handler)
:rpc (ig/ref :app.rpc/rpc)
:rpc-routes (ig/ref :app.rpc/routes)
:doc-routes (ig/ref :app.http.doc/routes)
:executor (ig/ref [::default :app.worker/executor])}
:app.http.debug/handlers
{:pool (ig/ref :app.db/pool)
:executor (ig/ref [::worker :app.worker/executor])}
:app.http.debug/routes
{:pool (ig/ref :app.db/pool)
:executor (ig/ref [::worker :app.worker/executor])
:storage (ig/ref :app.storage/storage)
:session (ig/ref :app.http/session)}
:app.http.websocket/handler
{:pool (ig/ref :app.db/pool)
@ -156,17 +227,7 @@
{:pool (ig/ref :app.db/pool)
:executor (ig/ref [::default :app.worker/executor])}
:app.http.oauth/handler
{:rpc (ig/ref :app.rpc/rpc)
:session (ig/ref :app.http/session)
:pool (ig/ref :app.db/pool)
:tokens (ig/ref :app.tokens/tokens)
:audit (ig/ref :app.loggers.audit/collector)
:executor (ig/ref [::default :app.worker/executor])
:http-client (ig/ref :app.http/client)
:public-uri (cf/get :public-uri)}
:app.rpc/rpc
:app.rpc/methods
{:pool (ig/ref :app.db/pool)
:session (ig/ref :app.http/session)
:tokens (ig/ref :app.tokens/tokens)
@ -175,9 +236,13 @@
:msgbus (ig/ref :app.msgbus/msgbus)
:public-uri (cf/get :public-uri)
:audit (ig/ref :app.loggers.audit/collector)
:ldap (ig/ref :app.auth.ldap/provider)
:http-client (ig/ref :app.http/client)
:executors (ig/ref :app.worker/executors)}
:app.rpc/routes
{:methods (ig/ref :app.rpc/methods)}
:app.worker/worker
{:executor (ig/ref [::worker :app.worker/executor])
:tasks (ig/ref :app.worker/registry)
@ -336,23 +401,12 @@
:backends
{:assets-s3 (ig/ref [::assets :app.storage.s3/backend])
:assets-db (ig/ref [::assets :app.storage.db/backend])
:assets-fs (ig/ref [::assets :app.storage.fs/backend])
:tmp (ig/ref [::tmp :app.storage.fs/backend])
:fdata-s3 (ig/ref [::fdata :app.storage.s3/backend])
;; keep this for backward compatibility
:s3 (ig/ref [::assets :app.storage.s3/backend])
:fs (ig/ref [::assets :app.storage.fs/backend])}}
[::fdata :app.storage.s3/backend]
{:region (cf/get :storage-fdata-s3-region)
:bucket (cf/get :storage-fdata-s3-bucket)
:endpoint (cf/get :storage-fdata-s3-endpoint)
:prefix (cf/get :storage-fdata-s3-prefix)
:executor (ig/ref [::default :app.worker/executor])}
[::assets :app.storage.s3/backend]
{:region (cf/get :storage-assets-s3-region)
:endpoint (cf/get :storage-assets-s3-endpoint)
@ -361,12 +415,7 @@
[::assets :app.storage.fs/backend]
{:directory (cf/get :storage-assets-fs-directory)}
[::tmp :app.storage.fs/backend]
{:directory "/tmp/penpot"}
[::assets :app.storage.db/backend]
{:pool (ig/ref :app.db/pool)}})
})
(def system nil)

97
backend/src/app/media.clj
View file

@ -12,18 +12,16 @@
[app.common.media :as cm]
[app.common.spec :as us]
[app.config :as cf]
[app.storage.tmp :as tmp]
[app.util.bytes :as bs]
[app.util.svg :as svg]
[buddy.core.bytes :as bb]
[buddy.core.codecs :as bc]
[clojure.java.io :as io]
[clojure.java.shell :as sh]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[datoteka.core :as fs])
(:import
java.io.ByteArrayInputStream
java.io.OutputStream
org.apache.commons.io.IOUtils
org.im4java.core.ConvertCmd
org.im4java.core.IMOperation
org.im4java.core.Info))
@ -93,18 +91,16 @@
(let [{:keys [path mtype]} input
format (or (cm/mtype->format mtype) format)
ext (cm/format->extension format)
tmp (fs/create-tempfile :suffix ext)]
tmp (tmp/tempfile :prefix "penpot.media." :suffix ext)]
(doto (ConvertCmd.)
(.run operation (into-array (map str [path tmp]))))
(let [thumbnail-data (fs/slurp-bytes tmp)]
(fs/delete tmp)
(assoc params
:format format
:mtype (cm/format->mtype format)
:size (alength ^bytes thumbnail-data)
:data (ByteArrayInputStream. thumbnail-data)))))
(assoc params
:format format
:mtype (cm/format->mtype format)
:size (fs/size tmp)
:data tmp)))
(defmethod process :generic-thumbnail
[{:keys [quality width height] :as params}]
@ -201,59 +197,54 @@
(defmethod process :generate-fonts
[{:keys [input] :as params}]
(letfn [(ttf->otf [data]
(let [input-file (fs/create-tempfile :prefix "penpot")
output-file (fs/path (str input-file ".otf"))
_ (with-open [out (io/output-stream input-file)]
(IOUtils/writeChunked ^bytes data ^OutputStream out)
(.flush ^OutputStream out))
res (sh/sh "fontforge" "-lang=ff" "-c"
(str/fmt "Open('%s'); Generate('%s')"
(str input-file)
(str output-file)))]
(let [finput (tmp/tempfile :prefix "penpot.font." :suffix "")
foutput (fs/path (str finput ".otf"))
_ (bs/write-to-file! data finput)
res (sh/sh "fontforge" "-lang=ff" "-c"
(str/fmt "Open('%s'); Generate('%s')"
(str finput)
(str foutput)))]
(when (zero? (:exit res))
(fs/slurp-bytes output-file))))
foutput)))
(otf->ttf [data]
(let [input-file (fs/create-tempfile :prefix "penpot")
output-file (fs/path (str input-file ".ttf"))
_ (with-open [out (io/output-stream input-file)]
(IOUtils/writeChunked ^bytes data ^OutputStream out)
(.flush ^OutputStream out))
res (sh/sh "fontforge" "-lang=ff" "-c"
(str/fmt "Open('%s'); Generate('%s')"
(str input-file)
(str output-file)))]
(let [finput (tmp/tempfile :prefix "penpot.font." :suffix "")
foutput (fs/path (str finput ".ttf"))
_ (bs/write-to-file! data finput)
res (sh/sh "fontforge" "-lang=ff" "-c"
(str/fmt "Open('%s'); Generate('%s')"
(str finput)
(str foutput)))]
(when (zero? (:exit res))
(fs/slurp-bytes output-file))))
foutput)))
(ttf-or-otf->woff [data]
(let [input-file (fs/create-tempfile :prefix "penpot" :suffix "")
output-file (fs/path (str input-file ".woff"))
_ (with-open [out (io/output-stream input-file)]
(IOUtils/writeChunked ^bytes data ^OutputStream out)
(.flush ^OutputStream out))
res (sh/sh "sfnt2woff" (str input-file))]
;; NOTE: foutput is not used directly, it represents the
;; default output of the exection of the underlying
;; command.
(let [finput (tmp/tempfile :prefix "penpot.font." :suffix "")
foutput (fs/path (str finput ".woff"))
_ (bs/write-to-file! data finput)
res (sh/sh "sfnt2woff" (str finput))]
(when (zero? (:exit res))
(fs/slurp-bytes output-file))))
foutput)))
(ttf-or-otf->woff2 [data]
(let [input-file (fs/create-tempfile :prefix "penpot" :suffix "")
output-file (fs/path (str input-file ".woff2"))
_ (with-open [out (io/output-stream input-file)]
(IOUtils/writeChunked ^bytes data ^OutputStream out)
(.flush ^OutputStream out))
res (sh/sh "woff2_compress" (str input-file))]
;; NOTE: foutput is not used directly, it represents the
;; default output of the exection of the underlying
;; command.
(let [finput (tmp/tempfile :prefix "penpot.font." :suffix ".tmp")
foutput (fs/path (str (fs/base finput) ".woff2"))
_ (bs/write-to-file! data finput)
res (sh/sh "woff2_compress" (str finput))]
(when (zero? (:exit res))
(fs/slurp-bytes output-file))))
foutput)))
(woff->sfnt [data]
(let [input-file (fs/create-tempfile :prefix "penpot" :suffix "")
_ (with-open [out (io/output-stream input-file)]
(IOUtils/writeChunked ^bytes data ^OutputStream out)
(.flush ^OutputStream out))
res (sh/sh "woff2sfnt" (str input-file)
:out-enc :bytes)]
(let [finput (tmp/tempfile :prefix "penpot" :suffix "")
_ (bs/write-to-file! data finput)
res (sh/sh "woff2sfnt" (str finput)
:out-enc :bytes)]
(when (zero? (:exit res))
(:out res))))

9
backend/src/app/migrations.clj
View file

@ -226,6 +226,15 @@
{:name "0072-mod-file-object-thumbnail-table"
:fn (mg/resource "app/migrations/sql/0072-mod-file-object-thumbnail-table.sql")}
{:name "0073-mod-file-media-object-constraints"
:fn (mg/resource "app/migrations/sql/0073-mod-file-media-object-constraints.sql")}
{:name "0074-mod-file-library-rel-constraints"
:fn (mg/resource "app/migrations/sql/0074-mod-file-library-rel-constraints.sql")}
{:name "0075-mod-share-link-table"
:fn (mg/resource "app/migrations/sql/0075-mod-share-link-table.sql")}
])

11
backend/src/app/migrations/sql/0073-mod-file-media-object-constraints.sql Normal file
View file

@ -0,0 +1,11 @@
ALTER TABLE file_media_object
ALTER CONSTRAINT file_media_object_media_id_fkey DEFERRABLE INITIALLY IMMEDIATE;
ALTER TABLE file_media_object
ALTER CONSTRAINT file_media_object_thumbnail_id_fkey DEFERRABLE INITIALLY IMMEDIATE;
ALTER TABLE file_media_object
RENAME CONSTRAINT media_object_file_id_fkey TO file_media_object_file_id_fkey;
ALTER TABLE file_media_object
ALTER CONSTRAINT file_media_object_file_id_fkey DEFERRABLE INITIALLY IMMEDIATE;

5
backend/src/app/migrations/sql/0074-mod-file-library-rel-constraints.sql Normal file
View file

@ -0,0 +1,5 @@
ALTER TABLE file_library_rel
ALTER CONSTRAINT file_library_rel_file_id_fkey DEFERRABLE INITIALLY IMMEDIATE;
ALTER TABLE file_library_rel
ALTER CONSTRAINT file_library_rel_library_file_id_fkey DEFERRABLE INITIALLY IMMEDIATE;

5
backend/src/app/migrations/sql/0075-mod-share-link-table.sql Normal file
View file

@ -0,0 +1,5 @@
ALTER TABLE share_link
ADD COLUMN who_comment text NOT NULL DEFAULT('team'),
ADD COLUMN who_inspect text NOT NULL DEFAULT('team');
--- TODO: remove flags column in 1.15.x

5
backend/src/app/msgbus.clj
View file

@ -160,7 +160,6 @@
"Function responsible to attach local subscription to the
state. Intended to be used in agent."
[state cfg topics chan done-ch]
(l/trace :hint "subscribe-to-topics" :topics topics ::l/async false)
(aa/with-closing done-ch
(let [state (update state :chans assoc chan topics)]
(reduce (fn [state topic]
@ -184,15 +183,15 @@
useful when client disconnects or in-bulk unsubscribe
operations. Intended to be executed in agent."
[state cfg channels done-ch]
(l/trace :hint "unsubscribe-channels" :chans (count channels) ::l/async false)
(aa/with-closing done-ch
(reduce #(unsubscribe-single-channel %1 cfg %2) state channels)))
(defn- subscribe
[{:keys [::state executor] :as cfg} {:keys [topic topics chan]}]
(let [done-ch (a/chan)
topics (into [] (map prefix-topic) (if topic [topic] topics))]
(l/trace :hint "subscribe" :topics topics)
(l/debug :hint "subscribe" :topics topics)
(send-via executor state subscribe-to-topics cfg topics chan done-ch)
done-ch))

103
backend/src/app/rpc.clj
View file

@ -86,6 +86,30 @@
(let [context {:profile-id profile-id}]
(raise (ex/wrap-with-context cause context)))))))))
(defn- rpc-command-handler
"Ring handler that dispatches cmd requests and convert between
internal async flow into ring async flow."
[methods {:keys [profile-id session-id params] :as request} respond raise]
(letfn [(handle-response [result]
(let [mdata (meta result)]
(p/-> (yrs/response 200 result)
(handle-response-transformation request mdata)
(handle-before-comple-hook mdata))))]
(let [cmd (keyword (:command params))
data (into {::request request} params)
data (if profile-id
(assoc data :profile-id profile-id ::session-id session-id)
(dissoc data :profile-id))
method (get methods cmd default-handler)]
(-> (method data)
(p/then handle-response)
(p/then respond)
(p/catch (fn [cause]
(let [context {:profile-id profile-id}]
(raise (ex/wrap-with-context cause context)))))))))
(defn- wrap-metrics
"Wrap service method with metrics measurement."
[{:keys [metrics ::metrics-id]} f mdata]
@ -180,8 +204,9 @@
(defn- process-method
[cfg vfn]
(let [mdata (meta vfn)]
;; (prn mdata)
[(keyword (::sv/name mdata))
(wrap cfg (deref vfn) mdata)]))
(wrap cfg vfn mdata)]))
(defn- resolve-query-methods
[cfg]
@ -199,35 +224,81 @@
(defn- resolve-mutation-methods
[cfg]
(let [cfg (assoc cfg ::type "mutation" ::metrics-id :rpc-mutation-timing)]
(->> (sv/scan-ns 'app.rpc.mutations.demo
'app.rpc.mutations.media
(->> (sv/scan-ns 'app.rpc.mutations.media
'app.rpc.mutations.profile
'app.rpc.mutations.files
'app.rpc.mutations.comments
'app.rpc.mutations.projects
'app.rpc.mutations.teams
'app.rpc.mutations.management
'app.rpc.mutations.ldap
'app.rpc.mutations.fonts
'app.rpc.mutations.share-link
'app.rpc.mutations.verify-token)
(map (partial process-method cfg))
(into {}))))
(s/def ::storage some?)
(s/def ::session map?)
(s/def ::tokens fn?)
(defn- resolve-command-methods
[cfg]
(let [cfg (assoc cfg ::type "command" ::metrics-id :rpc-command-timing)]
(->> (sv/scan-ns 'app.rpc.commands.binfile
'app.rpc.commands.auth
'app.rpc.commands.ldap
'app.rpc.commands.demo)
(map (partial process-method cfg))
(into {}))))
(s/def ::audit (s/nilable fn?))
(s/def ::executors (s/map-of keyword? ::wrk/executor))
(s/def ::executors map?)
(s/def ::http-client fn?)
(s/def ::ldap (s/nilable map?))
(s/def ::msgbus fn?)
(s/def ::public-uri ::us/not-empty-string)
(s/def ::session map?)
(s/def ::storage some?)
(s/def ::tokens fn?)
(defmethod ig/pre-init-spec ::rpc [_]
(s/keys :req-un [::storage ::session ::tokens ::audit
::executors ::mtx/metrics ::db/pool]))
(defmethod ig/pre-init-spec ::methods [_]
(s/keys :req-un [::storage
::session
::tokens
::audit
::executors
::public-uri
::msgbus
::http-client
::mtx/metrics
::db/pool
::ldap]))
(defmethod ig/init-key ::rpc
(defmethod ig/init-key ::methods
[_ cfg]
(let [mq (resolve-query-methods cfg)
mm (resolve-mutation-methods cfg)]
{:methods {:query mq :mutation mm}
:query-handler (partial rpc-query-handler mq)
:mutation-handler (partial rpc-mutation-handler mm)}))
{:mutations (resolve-mutation-methods cfg)
:queries (resolve-query-methods cfg)
:commands (resolve-command-methods cfg)})
(s/def ::mutations
(s/map-of keyword? fn?))
(s/def ::queries
(s/map-of keyword? fn?))
(s/def ::commands
(s/map-of keyword? fn?))
(s/def ::methods
(s/keys :req-un [::mutations
::queries
::commands]))
(defmethod ig/pre-init-spec ::routes [_]
(s/keys :req-un [::methods]))
(defmethod ig/init-key ::routes
[_ {:keys [methods] :as cfg}]
[["/rpc"
["/command/:command" {:handler (partial rpc-command-handler (:commands methods))}]
["/query/:type" {:handler (partial rpc-query-handler (:queries methods))}]
["/mutation/:type" {:handler (partial rpc-mutation-handler (:mutations methods))
:allowed-methods #{:post}}]]])

416
backend/src/app/rpc/commands/auth.clj Normal file
View file

@ -0,0 +1,416 @@
;; 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) UXBOX Labs SL
(ns app.rpc.commands.auth
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.emails :as eml]
[app.loggers.audit :as audit]
[app.rpc.mutations.teams :as teams]
[app.rpc.queries.profile :as profile]
[app.rpc.rlimit :as rlimit]
[app.util.services :as sv]
[app.util.time :as dt]
[buddy.hashers :as hashers]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]))
(s/def ::email ::us/email)
(s/def ::fullname ::us/not-empty-string)
(s/def ::lang ::us/string)
(s/def ::path ::us/string)
(s/def ::profile-id ::us/uuid)
(s/def ::password ::us/not-empty-string)
(s/def ::old-password ::us/not-empty-string)
(s/def ::theme ::us/string)
(s/def ::invitation-token ::us/not-empty-string)
(s/def ::token ::us/not-empty-string)
;; ---- HELPERS
(defn derive-password
[password]
(hashers/derive password
{:alg :argon2id
:memory 16384
:iterations 20
:parallelism 2}))
(defn verify-password
[attempt password]
(try
(hashers/verify attempt password)
(catch Exception _e
{:update false
:valid false})))
(defn email-domain-in-whitelist?
"Returns true if email's domain is in the given whitelist or if
given whitelist is an empty string."
[domains email]
(if (or (empty? domains)
(nil? domains))
true
(let [[_ candidate] (-> (str/lower email)
(str/split #"@" 2))]
(contains? domains candidate))))
(def ^:private sql:profile-existence
"select exists (select * from profile
where email = ?
and deleted_at is null) as val")
(defn check-profile-existence!
[conn {:keys [email] :as params}]
(let [email (str/lower email)
result (db/exec-one! conn [sql:profile-existence email])]
(when (:val result)
(ex/raise :type :validation
:code :email-already-exists))
params))
;; ---- COMMAND: login with password
(defn login-with-password
[{:keys [pool session tokens] :as cfg} {:keys [email password] :as params}]
(when-not (contains? cf/flags :login)
(ex/raise :type :restriction
:code :login-disabled
:hint "login is disabled in this instance"))
(letfn [(check-password [profile password]
(when (= (:password profile) "!")
(ex/raise :type :validation
:code :account-without-password
:hint "the current account does not have password"))
(:valid (verify-password password (:password profile))))
(validate-profile [profile]
(when-not (:is-active profile)
(ex/raise :type :validation
:code :wrong-credentials))
(when-not profile
(ex/raise :type :validation
:code :wrong-credentials))
(when-not (check-password profile password)
(ex/raise :type :validation
:code :wrong-credentials))
profile)]
(db/with-atomic [conn pool]
(let [profile (->> (profile/retrieve-profile-data-by-email conn email)
(validate-profile)
(profile/strip-private-attrs)
(profile/populate-additional-data conn)
(profile/decode-profile-row))
invitation (when-let [token (:invitation-token params)]
(tokens :verify {:token token :iss :team-invitation}))
;; If invitation member-id does not matches the profile-id, we just proceed to ignore the
;; invitation because invitations matches exactly; and user can't loging with other email and
;; accept invitation with other email
response (if (and (some? invitation) (= (:id profile) (:member-id invitation)))
{:invitation-token (:invitation-token params)}
profile)]
(with-meta response
{:transform-response ((:create session) (:id profile))
::audit/props (audit/profile->props profile)
::audit/profile-id (:id profile)})))))
(s/def ::login-with-password
(s/keys :req-un [::email ::password]
:opt-un [::invitation-token]))
(sv/defmethod ::login-with-password
"Performs authentication using penpot password."
{:auth false ::rlimit/permits (cf/get :rlimit-password)}
[cfg params]
(login-with-password cfg params))
;; ---- COMMAND: Logout
(s/def ::logout
(s/keys :opt-un [::profile-id]))
(sv/defmethod ::logout
"Clears the authentication cookie and logout the current session."
{:auth false}
[{:keys [session] :as cfg} _]
(with-meta {}
{:transform-response (:delete session)}))
;; ---- COMMAND: Recover Profile
(defn recover-profile
[{:keys [pool tokens] :as cfg} {:keys [token password]}]
(letfn [(validate-token [token]
(let [tdata (tokens :verify {:token token :iss :password-recovery})]
(:profile-id tdata)))
(update-password [conn profile-id]
(let [pwd (derive-password password)]
(db/update! conn :profile {:password pwd} {:id profile-id})))]
(db/with-atomic [conn pool]
(->> (validate-token token)
(update-password conn))
nil)))
(s/def ::token ::us/not-empty-string)
(s/def ::recover-profile
(s/keys :req-un [::token ::password]))
(sv/defmethod ::recover-profile
{:auth false ::rlimit/permits (cf/get :rlimit-password)}
[cfg params]
(recover-profile cfg params))
;; ---- COMMAND: Prepare Register
(defn prepare-register
[{:keys [pool tokens] :as cfg} params]
(when-not (contains? cf/flags :registration)
(if-not (contains? params :invitation-token)
(ex/raise :type :restriction
:code :registration-disabled)
(let [invitation (tokens :verify {:token (:invitation-token params) :iss :team-invitation})]
(when-not (= (:email params) (:member-email invitation))
(ex/raise :type :restriction
:code :email-does-not-match-invitation
:hint "email should match the invitation")))))
(when-let [domains (cf/get :registration-domain-whitelist)]
(when-not (email-domain-in-whitelist? domains (:email params))
(ex/raise :type :validation
:code :email-domain-is-not-allowed)))
;; Don't allow proceed in preparing registration if the profile is
;; already reported as spammer.
(when (eml/has-bounce-reports? pool (:email params))
(ex/raise :type :validation
:code :email-has-permanent-bounces
:hint "looks like the email has one or many bounces reported"))
(check-profile-existence! pool params)
(when (= (str/lower (:email params))
(str/lower (:password params)))
(ex/raise :type :validation
:code :email-as-password
:hint "you can't use your email as password"))
(let [params {:email (:email params)
:password (:password params)
:invitation-token (:invitation-token params)
:backend "penpot"
:iss :prepared-register
:exp (dt/in-future "48h")}
token (tokens :generate params)]
(with-meta {:token token}
{::audit/profile-id uuid/zero})))
(s/def ::prepare-register-profile
(s/keys :req-un [::email ::password]
:opt-un [::invitation-token]))
(sv/defmethod ::prepare-register-profile {:auth false}
[cfg params]
(prepare-register cfg params))
;; ---- COMMAND: Register Profile
(defn create-profile
"Create the profile entry on the database with limited input filling
all the other fields with defaults."
[conn params]
(let [id (or (:id params) (uuid/next))
props (-> (audit/extract-utm-params params)
(merge (:props params))
(db/tjson))
password (if-let [password (:password params)]
(derive-password password)
"!")
locale (:locale params)
locale (when (and (string? locale) (not (str/blank? locale)))
locale)
backend (:backend params "penpot")
is-demo (:is-demo params false)
is-muted (:is-muted params false)
is-active (:is-active params false)
email (str/lower (:email params))
params {:id id
:fullname (:fullname params)
:email email
:auth-backend backend
:lang locale
:password password
:deleted-at (:deleted-at params)
:props props
:is-active is-active
:is-muted is-muted
:is-demo is-demo}]
(try
(-> (db/insert! conn :profile params)
(profile/decode-profile-row))
(catch org.postgresql.util.PSQLException e
(let [state (.getSQLState e)]
(if (not= state "23505")
(throw e)
(ex/raise :type :validation
:code :email-already-exists
:cause e)))))))
(defn create-profile-relations
[conn profile]
(let [team (teams/create-team conn {:profile-id (:id profile)
:name "Default"
:is-default true})]
(-> profile
(profile/strip-private-attrs)
(assoc :default-team-id (:id team))
(assoc :default-project-id (:default-project-id team)))))
(defn register-profile
[{:keys [conn tokens session] :as cfg} {:keys [token] :as params}]
(let [claims (tokens :verify {:token token :iss :prepared-register})
params (merge params claims)]
(check-profile-existence! conn params)
(let [is-active (or (:is-active params)
(contains? cf/flags :insecure-register))
profile (->> (assoc params :is-active is-active)
(create-profile conn)
(create-profile-relations conn)
(profile/decode-profile-row))
invitation (when-let [token (:invitation-token params)]
(tokens :verify {:token token :iss :team-invitation}))]
(cond
;; If invitation token comes in params, this is because the user comes from team-invitation process;
;; in this case, regenerate token and send back to the user a new invitation token (and mark current
;; session as logged). This happens only if the invitation email matches with the register email.
(and (some? invitation) (= (:email profile) (:member-email invitation)))
(let [claims (assoc invitation :member-id (:id profile))
token (tokens :generate claims)
resp {:invitation-token token}]
(with-meta resp
{:transform-response ((:create session) (:id profile))
::audit/replace-props (audit/profile->props profile)
::audit/profile-id (:id profile)}))
;; If auth backend is different from "penpot" means user is
;; registering using third party auth mechanism; in this case
;; we need to mark this session as logged.
(not= "penpot" (:auth-backend profile))
(with-meta (profile/strip-private-attrs profile)
{:transform-response ((:create session) (:id profile))
::audit/replace-props (audit/profile->props profile)
::audit/profile-id (:id profile)})
;; If the `:enable-insecure-register` flag is set, we proceed
;; to sign in the user directly, without email verification.
(true? is-active)
(with-meta (profile/strip-private-attrs profile)
{:transform-response ((:create session) (:id profile))
::audit/replace-props (audit/profile->props profile)
::audit/profile-id (:id profile)})
;; In all other cases, send a verification email.
:else
(let [vtoken (tokens :generate
{:iss :verify-email
:exp (dt/in-future "48h")
:profile-id (:id profile)
:email (:email profile)})
ptoken (tokens :generate-predefined
{:iss :profile-identity
:profile-id (:id profile)})]
(eml/send! {::eml/conn conn
::eml/factory eml/register
:public-uri (:public-uri cfg)
:to (:email profile)
:name (:fullname profile)
:token vtoken
:extra-data ptoken})
(with-meta profile
{::audit/replace-props (audit/profile->props profile)
::audit/profile-id (:id profile)}))))))
(s/def ::register-profile
(s/keys :req-un [::token ::fullname]))
(sv/defmethod ::register-profile
{:auth false ::rlimit/permits (cf/get :rlimit-password)}
[{:keys [pool] :as cfg} params]
(db/with-atomic [conn pool]
(-> (assoc cfg :conn conn)
(register-profile params))))
;; ---- COMMAND: Request Profile Recovery
(defn request-profile-recovery
[{:keys [pool tokens] :as cfg} {:keys [email] :as params}]
(letfn [(create-recovery-token [{:keys [id] :as profile}]
(let [token (tokens :generate
{:iss :password-recovery
:exp (dt/in-future "15m")
:profile-id id})]
(assoc profile :token token)))
(send-email-notification [conn profile]
(let [ptoken (tokens :generate-predefined
{:iss :profile-identity
:profile-id (:id profile)})]
(eml/send! {::eml/conn conn
::eml/factory eml/password-recovery
:public-uri (:public-uri cfg)
:to (:email profile)
:token (:token profile)
:name (:fullname profile)
:extra-data ptoken})
nil))]
(db/with-atomic [conn pool]
(when-let [profile (profile/retrieve-profile-data-by-email conn email)]
(when-not (eml/allow-send-emails? conn profile)
(ex/raise :type :validation
:code :profile-is-muted
:hint "looks like the profile has reported repeatedly as spam or has permanent bounces."))
(when-not (:is-active profile)
(ex/raise :type :validation
:code :profile-not-verified
:hint "the user need to validate profile before recover password"))
(when (eml/has-bounce-reports? conn (:email profile))
(ex/raise :type :validation
:code :email-has-permanent-bounces
:hint "looks like the email you invite has been repeatedly reported as spam or permanent bounce"))
(->> profile
(create-recovery-token)
(send-email-notification conn))))))
(s/def ::request-profile-recovery
(s/keys :req-un [::email]))
(sv/defmethod ::request-profile-recovery {:auth false}
[cfg params]
(request-profile-recovery cfg params))

836
backend/src/app/rpc/commands/binfile.clj Normal file
View file

@ -0,0 +1,836 @@
;; 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) UXBOX Labs SL
(ns app.rpc.commands.binfile
(:refer-clojure :exclude [assert])
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.pages.migrations :as pmg]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.media :as media]
[app.rpc.queries.files :as files]
[app.rpc.queries.projects :as projects]
[app.storage :as sto]
[app.storage.tmp :as tmp]
[app.tasks.file-gc]
[app.util.blob :as blob]
[app.util.bytes :as bs]
[app.util.fressian :as fres]
[app.util.services :as sv]
[app.util.time :as dt]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[clojure.walk :as walk]
[cuerdas.core :as str]
[yetti.adapter :as yt])
(:import
java.io.DataInputStream
java.io.DataOutputStream
java.io.InputStream
java.io.OutputStream
java.lang.AutoCloseable))
(set! *warn-on-reflection* true)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; VARS & 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))
;; Represents the current processing file-id on
;; export process.
(def ^:dynamic *file-id*)
;; Stores all media file object references of
;; processed files on import process.
(def ^:dynamic *media*)
;; Stores the objects index on reamping subprocess
;; part of the import process.
(def ^:dynamic *index*)
;; Has the current connection used on the import
;; process.
(def ^:dynamic *conn*)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LOW LEVEL STREAM IO API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:const buffer-size (:xnio/buffer-size yt/defaults))
(def ^:const penpot-magic-number 800099563638710213)
(def ^:const max-object-size (* 1024 1024 100)) ; Only allow 100MiB max file size.
(def ^:dynamic *position* nil)
(defn get-mark
[id]
(case id
:header 1
:stream 2
:uuid 3
:label 4
:obj 5
(ex/raise :type :validation
:code :invalid-mark-id
:hint (format "invalid mark id %s" id))))
(defmacro assert
[expr hint]
`(when-not ~expr
(ex/raise :type :validation
:code :unexpected-condition
:hint ~hint)))
(defmacro assert-mark
[v type]
`(let [expected# (get-mark ~type)
val# (long ~v)]
(when (not= val# expected#)
(ex/raise :type :validation
:code :unexpected-mark
:hint (format "received mark %s, expected %s" val# expected#)))))
(defmacro assert-label
[expr label]
`(let [v# ~expr]
(when (not= v# ~label)
(ex/raise :type :assertion
:code :unexpected-label
:hint (format "received label %s, expected %s" v# ~label)))))
;; --- PRIMITIVE IO
(defn write-byte!
[^DataOutputStream output data]
(l/trace :fn "write-byte!" :data data :position @*position* ::l/async false)
(.writeByte output (byte data))
(swap! *position* inc))
(defn read-byte!
[^DataInputStream input]
(let [v (.readByte input)]
(l/trace :fn "read-byte!" :val v :position @*position* ::l/async false)
(swap! *position* inc)
v))
(defn write-long!
[^DataOutputStream output data]
(l/trace :fn "write-long!" :data data :position @*position* ::l/async false)
(.writeLong output (long data))
(swap! *position* + 8))
(defn read-long!
[^DataInputStream input]
(let [v (.readLong input)]
(l/trace :fn "read-long!" :val v :position @*position* ::l/async false)
(swap! *position* + 8)
v))
(defn write-bytes!
[^DataOutputStream output ^bytes data]
(let [size (alength data)]
(l/trace :fn "write-bytes!" :size size :position @*position* ::l/async false)
(.write output data 0 size)
(swap! *position* + size)))
(defn read-bytes!
[^InputStream input ^bytes buff]
(let [size (alength buff)
readed (.readNBytes input buff 0 size)]
(l/trace :fn "read-bytes!" :expected (alength buff) :readed readed :position @*position* ::l/async false)
(swap! *position* + readed)
readed))
;; --- COMPOSITE IO
(defn write-uuid!
[^DataOutputStream output id]
(l/trace :fn "write-uuid!" :position @*position* :WRITTEN? (.size output) ::l/async false)
(doto output
(write-byte! (get-mark :uuid))
(write-long! (uuid/get-word-high id))
(write-long! (uuid/get-word-low id))))
(defn read-uuid!
[^DataInputStream input]
(l/trace :fn "read-uuid!" :position @*position* ::l/async false)
(let [m (read-byte! input)]
(assert-mark m :uuid)
(let [a (read-long! input)
b (read-long! input)]
(uuid/custom a b))))
(defn write-obj!
[^DataOutputStream output data]
(l/trace :fn "write-obj!" :position @*position* ::l/async false)
(let [^bytes data (fres/encode data)]
(doto output
(write-byte! (get-mark :obj))
(write-long! (alength data))
(write-bytes! data))))
(defn read-obj!
[^DataInputStream input]
(l/trace :fn "read-obj!" :position @*position* ::l/async false)
(let [m (read-byte! input)]
(assert-mark m :obj)
(let [size (read-long! input)]
(assert (pos? size) "incorrect header size found on reading header")
(let [buff (byte-array size)]
(read-bytes! input buff)
(fres/decode buff)))))
(defn write-label!
[^DataOutputStream output label]
(l/trace :fn "write-label!" :label label :position @*position* ::l/async false)
(doto output
(write-byte! (get-mark :label))
(write-obj! label)))
(defn read-label!
[^DataInputStream input]
(l/trace :fn "read-label!" :position @*position* ::l/async false)
(let [m (read-byte! input)]
(assert-mark m :label)
(read-obj! input)))
(defn write-header!
[^DataOutputStream output & {:keys [version metadata]}]
(l/trace :fn "write-header!"
:version version
:metadata metadata
:position @*position*
::l/async false)
(doto output
(write-byte! (get-mark :header))
(write-long! penpot-magic-number)
(write-long! version)
(write-obj! metadata)))
(defn read-header!
[^DataInputStream input]
(l/trace :fn "read-header!" :position @*position* ::l/async false)
(let [mark (read-byte! input)
mnum (read-long! input)
vers (read-long! input)]
(when (or (not= mark (get-mark :header))
(not= mnum penpot-magic-number))
(ex/raise :type :validation
:code :invalid-penpot-file))
(-> (read-obj! input)
(assoc ::version vers))))
(defn copy-stream!
[^OutputStream output ^InputStream input ^long size]
(let [written (bs/copy! input output :size size)]
(l/trace :fn "copy-stream!" :position @*position* :size size :written written ::l/async false)
(swap! *position* + written)
written))
(defn write-stream!
[^DataOutputStream output stream size]
(l/trace :fn "write-stream!" :position @*position* ::l/async false :size size)
(doto output
(write-byte! (get-mark :stream))
(write-long! size))
(copy-stream! output stream size))
(defn read-stream!
[^DataInputStream input]
(l/trace :fn "read-stream!" :position @*position* ::l/async false)
(let [m (read-byte! input)
s (read-long! input)
p (tmp/tempfile :prefix "penpot.binfile.")]
(assert-mark m :stream)
(when (> s 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)
(with-open [^OutputStream output (io/output-stream p)]
(let [readed (bs/copy! input output :offset 0 :size s)]
(l/trace :fn "read-stream*!" :expected s :readed readed :position @*position* ::l/async false)
(swap! *position* + readed)
[s p]))
[s (bs/read-as-bytes input :size s)])))
(defmacro assert-read-label!
[input expected-label]
`(let [readed# (read-label! ~input)
expected# ~expected-label]
(when (not= readed# expected#)
(ex/raise :type :validation
:code :unexpected-label
:hint (format "unxpected label found: %s, expected: %s" readed# expected#)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- HELPERS
(defn- retrieve-file
[pool file-id]
(->> (db/query pool :file {:id file-id})
(map files/decode-row)
(first)))
(def ^:private sql:file-media-objects
"SELECT * FROM file_media_object WHERE id = ANY(?)")
(defn- retrieve-file-media
[pool {:keys [data] :as file}]
(with-open [^AutoCloseable conn (db/open pool)]
(let [ids (app.tasks.file-gc/collect-used-media data)
ids (db/create-array conn "uuid" ids)]
(db/exec! conn [sql:file-media-objects ids]))))
(def ^:private storage-object-id-xf
(comp
(mapcat (juxt :media-id :thumbnail-id))
(filter uuid?)))
(def ^:private sql:file-libraries
"WITH RECURSIVE libs AS (
SELECT fl.id, fl.deleted_at
FROM file AS fl
JOIN file_library_rel AS flr ON (flr.library_file_id = fl.id)
WHERE flr.file_id = ANY(?)
UNION
SELECT fl.id, fl.deleted_at
FROM file AS fl
JOIN file_library_rel AS flr ON (flr.library_file_id = fl.id)
JOIN libs AS l ON (flr.file_id = l.id)
)
SELECT DISTINCT l.id
FROM libs AS l
WHERE l.deleted_at IS NULL OR l.deleted_at > now();")
(defn- retrieve-libraries
[pool ids]
(with-open [^AutoCloseable conn (db/open pool)]
(let [ids (db/create-array conn "uuid" ids)]
(map :id (db/exec! pool [sql:file-libraries ids])))))
(def ^:private sql:file-library-rels
"SELECT * FROM file_library_rel
WHERE file_id = ANY(?)")
(defn- retrieve-library-relations
[pool ids]
(with-open [^AutoCloseable conn (db/open pool)]
(db/exec! conn [sql:file-library-rels (db/create-array conn "uuid" ids)])))
;; --- EXPORT WRITTER
(s/def ::output bs/output-stream?)
(s/def ::file-ids (s/every ::us/uuid :kind vector? :min-count 1))
(s/def ::include-libraries? (s/nilable ::us/boolean))
(s/def ::embed-assets? (s/nilable ::us/boolean))
(s/def ::write-export-options
(s/keys :req-un [::db/pool ::sto/storage]
:req [::output ::file-ids]
:opt [::include-libraries? ::embed-assets?]))
(defn write-export!
"Do the exportation of a speficied file in custom penpot binary
format. There are some options available for customize the output:
`::include-libraries?`: additionaly to the specified file, all the
linked libraries also will be included (including transitive
dependencies).
`::embed-assets?`: instead of including the libraryes, embedd in the
same file library all assets used from external libraries.
"
[{:keys [pool storage ::output ::file-ids ::include-libraries? ::embed-assets?] :as options}]
(us/assert! ::write-export-options options)
(us/verify!
:expr (not (and include-libraries? embed-assets?))
:hint "the `include-libraries?` and `embed-assets?` are mutally excluding options")
(letfn [(write-header [output files]
(let [sections [:v1/files :v1/rels :v1/sobjects]
mdata {:penpot-version (:full cf/version)
:sections sections
:files files}]
(write-header! output :version 1 :metadata mdata)))
(write-files [output files sids]
(l/debug :hint "write section" :section :v1/files :total (count files) ::l/async false)
(write-label! output :v1/files)
(doseq [file-id files]
(let [file (cond-> (retrieve-file pool file-id)
embed-assets? (update :data embed-file-assets file-id))
media (retrieve-file-media pool file)]
;; Collect all storage ids for later write them all under
;; specific storage objects section.
(vswap! sids into (sequence storage-object-id-xf media))
(l/trace :hint "write penpot file"
:id file-id
:media (count media)
::l/async false)
(doto output
(write-obj! file)
(write-obj! media)))))
(write-rels [output files]
(let [rels (when include-libraries? (retrieve-library-relations pool files))]
(l/debug :hint "write section" :section :v1/rels :total (count rels) ::l/async false)
(doto output
(write-label! :v1/rels)
(write-obj! rels))))
(write-sobjects [output sids]
(l/debug :hint "write section"
:section :v1/sobjects
:items (count sids)
::l/async false)
;; Write all collected storage objects
(doto output
(write-label! :v1/sobjects)
(write-obj! sids))
(let [storage (media/configure-assets-storage storage)]
(doseq [id sids]
(let [{:keys [size] :as obj} @(sto/get-object storage id)]
(l/trace :hint "write sobject" :id id ::l/async false)
(doto output
(write-uuid! id)
(write-obj! (meta obj)))
(with-open [^InputStream stream @(sto/get-object-data storage obj)]
(let [written (write-stream! output stream size)]
(when (not= written size)
(ex/raise :type :validation
:code :mismatch-readed-size
:hint (str/ffmt "found unexpected object size; size=% written=%" size written)))))))))
(embed-file-assets [data file-id]
(binding [*file-id* file-id]
(let [assets (volatile! [])]
(walk/postwalk #(cond-> % (map? %) (walk-map-form assets)) data)
(->> (deref assets)
(filter #(as-> (first %) $ (and (uuid? $) (not= $ file-id))))
(d/group-by first rest)
(reduce process-group-of-assets data)))))
(walk-map-form [form state]
(cond
(uuid? (:fill-color-ref-file form))
(do
(vswap! state conj [(:fill-color-ref-file form) :colors (:fill-color-ref-id form)])
(assoc form :fill-color-ref-file *file-id*))
(uuid? (:stroke-color-ref-file form))
(do
(vswap! state conj [(:stroke-color-ref-file form) :colors (:stroke-color-ref-id form)])
(assoc form :stroke-color-ref-file *file-id*))
(uuid? (:typography-ref-file form))
(do
(vswap! state conj [(:typography-ref-file form) :typographies (:typography-ref-id form)])
(assoc form :typography-ref-file *file-id*))
(uuid? (:component-file form))
(do
(vswap! state conj [(:component-file form) :components (:component-id form)])
(assoc form :component-file *file-id*))
:else
form))
(process-group-of-assets [data [lib-id items]]
;; NOTE: there are a posibility that shape refers to a not
;; existing file because the file was removed. In this
;; case we just ignore the asset.
(if-let [lib (retrieve-file pool lib-id)]
(reduce #(process-asset %1 lib %2) data items)
data))
(process-asset [data lib [bucket asset-id]]
(let [asset (get-in lib [:data bucket asset-id])
;; Add a special case for colors that need to have
;; correctly set the :file-id prop (pending of the
;; refactor that will remove it).
asset (cond-> asset
(= bucket :colors) (assoc :file-id *file-id*))]
(update data bucket assoc asset-id asset)))]
(with-open [output (bs/zstd-output-stream output :level 12)]
(with-open [output (bs/data-output-stream output)]
(let [libs (when include-libraries? (retrieve-libraries pool file-ids))
files (into file-ids libs)
sids (volatile! #{})]
;; Write header with metadata
(l/debug :hint "exportation summary"
:files (count files)
:embed-assets? embed-assets?
:include-libs? include-libraries?
::l/async false)
(write-header output files)
(write-files output files sids)
(write-rels output files)
(write-sobjects output (vec @sids)))))))
(s/def ::project-id ::us/uuid)
(s/def ::input bs/input-stream?)
(s/def ::overwrite? (s/nilable ::us/boolean))
(s/def ::migrate? (s/nilable ::us/boolean))
(s/def ::ignore-index-errors? (s/nilable ::us/boolean))
(s/def ::read-import-options
(s/keys :req-un [::db/pool ::sto/storage]
:req [::project-id ::input]
:opt [::overwrite? ::migrate? ::ignore-index-errors?]))
(defn read-import!
"Do the importation of the specified resource in penpot custom binary
format. There are some options for customize the importation
behavior:
`::overwrite?`: if true, instead of creating new files and remaping id references,
it reuses all ids and updates existing objects; defaults to `false`.
`::migrate?`: if true, applies the migration before persisting the
file data; defaults to `false`.
`::ignore-index-errors?`: if true, do not fail on index lookup errors, can
happen with broken files; defaults to: `false`.
"
[{:keys [pool storage ::project-id ::timestamp ::input ::overwrite? ::migrate? ::ignore-index-errors?]
:or {overwrite? false migrate? false timestamp (dt/now)}
:as options}]
(us/assert! ::read-import-options options)
(letfn [(lookup-index [id]
(if ignore-index-errors?
(or (get @*index* id) id)
(let [val (get @*index* id)]
(l/trace :fn "lookup-index" :id id :val val ::l/async false)
(when-not val
(ex/raise :type :validation
:code :incomplete-index
:hint "looks like index has missing data"))
val)))
(update-index [index coll]
(loop [items (seq coll)
index index]
(if-let [id (first items)]
(let [new-id (if overwrite? id (uuid/next))]
(l/trace :fn "update-index" :id id :new-id new-id ::l/async false)
(recur (rest items)
(assoc index id new-id)))
index)))
(process-map-form [form]
(cond-> form
;; Relink Image Shapes
(and (map? (:metadata form))
(= :image (:type form)))
(update-in [:metadata :id] lookup-index)
;; This covers old shapes and the new :fills.
(uuid? (:fill-color-ref-file form))
(update :fill-color-ref-file lookup-index)
;; This covers the old shapes and the new :strokes
(uuid? (:storage-color-ref-file form))
(update :stroke-color-ref-file lookup-index)
;; This covers all text shapes that have typography referenced
(uuid? (:typography-ref-file form))
(update :typography-ref-file lookup-index)
;; This covers the shadows and grids (they have directly
;; the :file-id prop)
(uuid? (:file-id form))
(update :file-id lookup-index)))
;; a function responsible to analyze all file data and
;; replace the old :component-file reference with the new
;; ones, using the provided file-index
(relink-shapes [data]
(walk/postwalk (fn [form]
(if (map? form)
(try
(process-map-form form)
(catch Throwable cause
(l/trace :hint "failed form" :form (pr-str form) ::l/async false)
(throw cause)))
form))
data))
;; A function responsible of process the :media attr of file
;; data and remap the old ids with the new ones.
(relink-media [media]
(reduce-kv (fn [res k v]
(let [id (lookup-index k)]
(if (uuid? id)
(-> res
(assoc id (assoc v :id id))
(dissoc k))
res)))
media
media))
(create-or-update-file [params]
(let [sql (str "INSERT INTO file (id, project_id, name, revn, is_shared, data, created_at, modified_at) "
"VALUES (?, ?, ?, ?, ?, ?, ?, ?) "
"ON CONFLICT (id) DO UPDATE SET data=?")]
(db/exec-one! *conn* [sql
(:id params)
(:project-id params)
(:name params)
(:revn params)
(:is-shared params)
(:data params)
(:created-at params)
(:modified-at params)
(:data params)])))
(read-files-section! [input expected-files]
(l/debug :hint "reading section" :section :v1/files ::l/async false)
(assert-read-label! input :v1/files)
;; Process/Read all file
(doseq [expected-file-id expected-files]
(let [file (read-obj! input)
media' (read-obj! input)
file-id (:id file)]
(when (not= file-id expected-file-id)
(ex/raise :type :validation
:code :inconsistent-penpot-file
:hint "the penpot file seems corrupt, found unexpected uuid (file-id)"))
;; Update index using with media
(l/trace :hint "update index with media" ::l/async false)
(vswap! *index* update-index (map :id media'))
;; Store file media for later insertion
(l/trace :hint "update media references" ::l/async false)
(vswap! *media* into (map #(update % :id lookup-index)) media')
(l/trace :hint "procesing file" :file-id file-id ::l/async false)
(let [file-id' (lookup-index file-id)
data (-> (:data file)
(assoc :id file-id')
(cond-> migrate? (pmg/migrate-data))
(update :pages-index relink-shapes)
(update :components relink-shapes)
(update :media relink-media))
params {:id file-id'
:project-id project-id
:name (str "Imported: " (:name file))
:revn (:revn file)
:is-shared (:is-shared file)
:data (blob/encode data)
:created-at timestamp
:modified-at timestamp}]
(l/trace :hint "create file" :id file-id' ::l/async false)
(if overwrite?
(create-or-update-file params)
(db/insert! *conn* :file params))
(when overwrite?
(db/delete! *conn* :file-thumbnail {:file-id file-id'}))))))
(read-rels-section! [input]
(l/debug :hint "reading section" :section :v1/rels ::l/async false)
(assert-read-label! input :v1/rels)
(let [rels (read-obj! input)]
;; Insert all file relations
(doseq [rel rels]
(let [rel (-> rel
(assoc :synced-at timestamp)
(update :file-id lookup-index)
(update :library-file-id lookup-index))]
(l/trace :hint "create file library link"
:file-id (:file-id rel)
:lib-id (:library-file-id rel)
::l/async false)
(db/insert! *conn* :file-library-rel rel)))))
(read-sobjects-section! [input]
(l/debug :hint "reading section" :section :v1/sobjects ::l/async false)
(assert-read-label! input :v1/sobjects)
(let [storage (media/configure-assets-storage storage)
ids (read-obj! input)]
;; Step 1: process all storage objects
(doseq [expected-storage-id ids]
(let [id (read-uuid! input)
mdata (read-obj! input)]
(when (not= id expected-storage-id)
(ex/raise :type :validation
:code :inconsistent-penpot-file
:hint "the penpot file seems corrupt, found unexpected uuid (storage-object-id)"))
(l/trace :hint "readed storage object" :id id ::l/async false)
(let [[size resource] (read-stream! input)
hash (sto/calculate-hash resource)
content (-> (sto/content resource size)
(sto/wrap-with-hash hash))
params (-> mdata
(assoc ::sto/deduplicate? true)
(assoc ::sto/content content)
(assoc ::sto/touched-at (dt/now)))
sobject @(sto/put-object! storage params)]
(l/trace :hint "persisted storage object" :id id :new-id (:id sobject) ::l/async false)
(vswap! *index* assoc id (:id sobject)))))
;; Step 2: insert all file-media-object rows with correct
;; storage-id reference.
(doseq [item @*media*]
(l/trace :hint "inserting file media objects" :id (:id item) ::l/async false)
(db/insert! *conn* :file-media-object
(-> item
(update :file-id lookup-index)
(d/update-when :media-id lookup-index)
(d/update-when :thumbnail-id lookup-index))
{:on-conflict-do-nothing overwrite?}))))]
(with-open [input (bs/zstd-input-stream input)]
(with-open [input (bs/data-input-stream input)]
(db/with-atomic [conn pool]
(db/exec-one! conn ["SET CONSTRAINTS ALL DEFERRED;"])
;; Verify that we received a proper .penpot file
(let [{:keys [sections files]} (read-header! input)]
(l/debug :hint "import verified" :files files :overwrite? overwrite?)
(binding [*index* (volatile! (update-index {} files))
*media* (volatile! [])
*conn* conn]
(doseq [section sections]
(case section
:v1/rels (read-rels-section! input)
:v1/files (read-files-section! input files)
:v1/sobjects (read-sobjects-section! input))))))))))
(defn export!
[cfg]
(let [path (tmp/tempfile :prefix "penpot.export.")
id (uuid/next)
ts (dt/now)
cs (volatile! nil)]
(try
(l/info :hint "start exportation" :export-id id)
(with-open [output (io/output-stream path)]
(binding [*position* (atom 0)]
(write-export! (assoc cfg ::output output))
path))
(catch Throwable cause
(vreset! cs cause)
(throw cause))
(finally
(l/info :hint "exportation finished" :export-id id
:elapsed (str (inst-ms (dt/diff ts (dt/now))) "ms")
:cause @cs)))))
(defn import!
[{:keys [::input] :as cfg}]
(let [id (uuid/next)
ts (dt/now)
cs (volatile! nil)]
(try
(l/info :hint "start importation" :import-id id)
(binding [*position* (atom 0)]
(with-open [input (io/input-stream input)]
(read-import! (assoc cfg ::input input))))
(catch Throwable cause
(vreset! cs cause)
(throw cause))
(finally
(l/info :hint "importation finished" :import-id id
:elapsed (str (inst-ms (dt/diff ts (dt/now))) "ms")
:error? (some? @cs)
:cause @cs)))))
;; --- Command: export-binfile
(s/def ::file-id ::us/uuid)
(s/def ::profile-id ::us/uuid)
(s/def ::include-libraries? ::us/boolean)
(s/def ::embed-assets? ::us/boolean)
(s/def ::export-binfile
(s/keys :req-un [::profile-id ::file-id ::include-libraries? ::embed-assets?]))
(sv/defmethod ::export-binfile
"Export a penpot file in a binary format."
[{:keys [pool] :as cfg} {:keys [profile-id file-id include-libraries? embed-assets?] :as params}]
(db/with-atomic [conn pool]
(files/check-read-permissions! conn profile-id file-id)
(let [path (export! (assoc cfg
::file-ids [file-id]
::embed-assets? embed-assets?
::include-libraries? include-libraries?))]
(with-meta {}
{:transform-response (fn [_ response]
(assoc response
:body (io/input-stream path)
:headers {"content-type" "application/octet-stream"}))}))))
(s/def ::file ::media/upload)
(s/def ::import-binfile
(s/keys :req-un [::profile-id ::project-id ::file]))
(sv/defmethod ::import-binfile
"Import a penpot file in a binary format."
[{:keys [pool] :as cfg} {:keys [profile-id project-id file] :as params}]
(db/with-atomic [conn pool]
(projects/check-read-permissions! conn profile-id project-id)
(import! (assoc cfg
::input (:path file)
::project-id project-id
::ignore-index-errors? true))))

8
backend/src/app/rpc/mutations/demo.clj → backend/src/app/rpc/commands/demo.clj
View file

@ -4,7 +4,7 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.rpc.mutations.demo
(ns app.rpc.commands.demo
"A demo specific mutations."
(:require
[app.common.exceptions :as ex]
@ -12,7 +12,7 @@
[app.config :as cf]
[app.db :as db]
[app.loggers.audit :as audit]
[app.rpc.mutations.profile :as profile]
[app.rpc.commands.auth :as cmd.auth]
[app.util.services :as sv]
[app.util.time :as dt]
[buddy.core.codecs :as bc]
@ -45,8 +45,8 @@
:hint "Demo users are disabled by config."))
(db/with-atomic [conn pool]
(->> (#'profile/create-profile conn params)
(#'profile/create-profile-relations conn))
(->> (cmd.auth/create-profile conn params)
(cmd.auth/create-profile-relations conn))
(with-meta {:email email
:password password}

75
backend/src/app/rpc/commands/ldap.clj Normal file
View file

@ -0,0 +1,75 @@
;; 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) UXBOX Labs SL
(ns app.rpc.commands.ldap
(:require
[app.auth.ldap :as ldap]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.db :as db]
[app.loggers.audit :as-alias audit]
[app.rpc.commands.auth :as cmd.auth]
[app.rpc.queries.profile :as profile]
[app.util.services :as sv]
[clojure.spec.alpha :as s]))
;; --- COMMAND: login-with-ldap
(declare login-or-register)
(s/def ::email ::us/email)
(s/def ::password ::us/string)
(s/def ::invitation-token ::us/string)
(s/def ::login-with-ldap
(s/keys :req-un [::email ::password]
:opt-un [::invitation-token]))
(sv/defmethod ::login-with-ldap {:auth false}
[{:keys [session tokens ldap] :as cfg} params]
(when-not ldap
(ex/raise :type :restriction
:code :ldap-not-initialized
:hide "ldap auth provider is not initialized"))
(let [info (ldap/authenticate ldap params)]
(when-not info
(ex/raise :type :validation
:code :wrong-credentials))
(let [profile (login-or-register cfg info)]
(if-let [token (:invitation-token params)]
;; If invitation token comes in params, this is because the
;; user comes from team-invitation process; in this case,
;; regenerate token and send back to the user a new invitation
;; token (and mark current session as logged).
(let [claims (tokens :verify {:token token :iss :team-invitation})
claims (assoc claims
:member-id (:id profile)
:member-email (:email profile))
token (tokens :generate claims)]
(with-meta {:invitation-token token}
{:transform-response ((:create session) (:id profile))
::audit/props (:props profile)
::audit/profile-id (:id profile)}))
(with-meta profile
{:transform-response ((:create session) (:id profile))
::audit/props (:props profile)
::audit/profile-id (:id profile)})))))
(defn- login-or-register
[{:keys [pool] :as cfg} info]
(db/with-atomic [conn pool]
(or (some->> (:email info)
(profile/retrieve-profile-data-by-email conn)
(profile/populate-additional-data conn)
(profile/decode-profile-row))
(->> (assoc info :is-active true :is-demo false)
(cmd.auth/create-profile conn)
(cmd.auth/create-profile-relations conn)
(profile/strip-private-attrs)))))

37
backend/src/app/rpc/mutations/comments.clj
View file

@ -26,19 +26,21 @@
(s/def ::page-id ::us/uuid)
(s/def ::file-id ::us/uuid)
(s/def ::share-id (s/nilable ::us/uuid))
(s/def ::profile-id ::us/uuid)
(s/def ::position ::gpt/point)
(s/def ::content ::us/string)
(s/def ::create-comment-thread
(s/keys :req-un [::profile-id ::file-id ::position ::content ::page-id]))
(s/keys :req-un [::profile-id ::file-id ::position ::content ::page-id]
:opt-un [::share-id]))
(sv/defmethod ::create-comment-thread
{::retry/max-retries 3
::retry/matches retry/conflict-db-insert?}
[{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
[{:keys [pool] :as cfg} {:keys [profile-id file-id share-id] :as params}]
(db/with-atomic [conn pool]
(files/check-read-permissions! conn profile-id file-id)
(files/check-comment-permissions! conn profile-id file-id share-id)
(create-comment-thread conn params)))
(defn- retrieve-next-seqn
@ -92,18 +94,20 @@
;; --- Mutation: Update Comment Thread Status
(s/def ::id ::us/uuid)
(s/def ::share-id (s/nilable ::us/uuid))
(s/def ::update-comment-thread-status
(s/keys :req-un [::profile-id ::id]))
(s/keys :req-un [::profile-id ::id]
:opt-un [::share-id]))
(sv/defmethod ::update-comment-thread-status
[{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
[{:keys [pool] :as cfg} {:keys [profile-id id share-id] :as params}]
(db/with-atomic [conn pool]
(let [cthr (db/get-by-id conn :comment-thread id {:for-update true})]
(when-not cthr
(ex/raise :type :not-found))
(files/check-read-permissions! conn profile-id (:file-id cthr))
(files/check-comment-permissions! conn profile-id (:file-id cthr) share-id)
(upsert-comment-thread-status! conn profile-id (:id cthr)))))
(def sql:upsert-comment-thread-status
@ -122,16 +126,17 @@
(s/def ::is-resolved ::us/boolean)
(s/def ::update-comment-thread
(s/keys :req-un [::profile-id ::id ::is-resolved]))
(s/keys :req-un [::profile-id ::id ::is-resolved]
:opt-un [::share-id]))
(sv/defmethod ::update-comment-thread
[{:keys [pool] :as cfg} {:keys [profile-id id is-resolved] :as params}]
[{:keys [pool] :as cfg} {:keys [profile-id id is-resolved share-id] :as params}]
(db/with-atomic [conn pool]
(let [thread (db/get-by-id conn :comment-thread id {:for-update true})]
(when-not thread
(ex/raise :type :not-found))
(files/check-read-permissions! conn profile-id (:file-id thread))
(files/check-comment-permissions! conn profile-id (:file-id thread) share-id)
(db/update! conn :comment-thread
{:is-resolved is-resolved}
@ -142,10 +147,11 @@
;; --- Mutation: Add Comment
(s/def ::add-comment
(s/keys :req-un [::profile-id ::thread-id ::content]))
(s/keys :req-un [::profile-id ::thread-id ::content]
:opt-un [::share-id]))
(sv/defmethod ::add-comment
[{:keys [pool] :as cfg} {:keys [profile-id thread-id content] :as params}]
[{:keys [pool] :as cfg} {:keys [profile-id thread-id content share-id] :as params}]
(db/with-atomic [conn pool]
(let [thread (-> (db/get-by-id conn :comment-thread thread-id {:for-update true})
(comments/decode-row))
@ -155,7 +161,7 @@
(when-not thread (ex/raise :type :not-found))
;; Permission Checks
(files/check-read-permissions! conn profile-id (:file-id thread))
(files/check-comment-permissions! conn profile-id (:file-id thread) share-id)
;; Update the page-name cachedattribute on comment thread table.
(when (not= pname (:page-name thread))
@ -199,10 +205,11 @@
;; --- Mutation: Update Comment
(s/def ::update-comment
(s/keys :req-un [::profile-id ::id ::content]))
(s/keys :req-un [::profile-id ::id ::content]
:opt-un [::share-id]))
(sv/defmethod ::update-comment
[{:keys [pool] :as cfg} {:keys [profile-id id content] :as params}]
[{:keys [pool] :as cfg} {:keys [profile-id id content share-id] :as params}]
(db/with-atomic [conn pool]
(let [comment (db/get-by-id conn :comment id {:for-update true})
_ (when-not comment (ex/raise :type :not-found))
@ -210,7 +217,7 @@
_ (when-not thread (ex/raise :type :not-found))
pname (retrieve-page-name conn thread)]
(files/check-read-permissions! conn profile-id (:file-id thread))
(files/check-comment-permissions! conn profile-id (:file-id thread) share-id)
;; Don't allow edit comments to not owners
(when-not (= (:owner-id thread) profile-id)

25
backend/src/app/rpc/mutations/files.clj
View file

@ -6,6 +6,7 @@
(ns app.rpc.mutations.files
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.pages :as cp]
[app.common.pages.migrations :as pmg]
@ -63,21 +64,23 @@
(db/insert! conn :file-profile-rel))))
(defn create-file
[conn {:keys [id name project-id is-shared data deleted-at revn]
:or {is-shared false
revn 0
deleted-at nil}
[conn {:keys [id name project-id is-shared data revn
modified-at deleted-at ignore-sync-until]
:or {is-shared false revn 0}
:as params}]
(let [id (or id (:id data) (uuid/next))
data (or data (cp/make-file-data id))
file (db/insert! conn :file
{:id id
:project-id project-id
:name name
:revn revn
:is-shared is-shared
:data (blob/encode data)
:deleted-at deleted-at})]
(d/without-nils
{:id id
:project-id project-id
:name name
:revn revn
:is-shared is-shared
:data (blob/encode data)
:ignore-sync-until ignore-sync-until
:modified-at modified-at
:deleted-at deleted-at}))]
(->> (assoc params :file-id id :role :owner)
(create-file-role conn))

6
backend/src/app/rpc/mutations/fonts.clj
View file

@ -71,9 +71,9 @@
data)
(persist-font-object [data mtype]
(when-let [fdata (get data mtype)]
(p/let [hash (calculate-hash fdata)
content (-> (sto/content fdata)
(when-let [resource (get data mtype)]
(p/let [hash (calculate-hash resource)
content (-> (sto/content resource)
(sto/wrap-with-hash hash))]
(sto/put-object! storage {::sto/content content
::sto/touched-at (dt/now)

140
backend/src/app/rpc/mutations/ldap.clj
View file

@ -1,140 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) UXBOX Labs SL
(ns app.rpc.mutations.ldap
(:require
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.config :as cfg]
[app.db :as db]
[app.loggers.audit :as audit]
[app.rpc.mutations.profile :as profile-m]
[app.rpc.queries.profile :as profile-q]
[app.util.services :as sv]
[clj-ldap.client :as ldap]
[clojure.spec.alpha :as s]
[clojure.string]))
(s/def ::fullname ::us/not-empty-string)
(s/def ::email ::us/email)
(s/def ::backend ::us/not-empty-string)
(s/def ::info-data
(s/keys :req-un [::fullname ::email ::backend]))
(defn ^java.lang.AutoCloseable connect
[]
(let [params {:ssl? (cfg/get :ldap-ssl)
:startTLS? (cfg/get :ldap-starttls)
:bind-dn (cfg/get :ldap-bind-dn)
:password (cfg/get :ldap-bind-password)
:host {:address (cfg/get :ldap-host)
:port (cfg/get :ldap-port)}}]
(try
(ldap/connect params)
(catch Exception e
(ex/raise :type :restriction
:code :ldap-disabled
:hint "ldap disabled or unable to connect"
:cause e)))))
;; --- Mutation: login-with-ldap
(declare authenticate)
(declare login-or-register)
(s/def ::email ::us/email)
(s/def ::password ::us/string)
(s/def ::invitation-token ::us/string)
(s/def ::login-with-ldap
(s/keys :req-un [::email ::password]
:opt-un [::invitation-token]))
(sv/defmethod ::login-with-ldap {:auth false}
[{:keys [pool session tokens] :as cfg} params]
(db/with-atomic [conn pool]
(let [info (authenticate params)
cfg (assoc cfg :conn conn)]
(when-not info
(ex/raise :type :validation
:code :wrong-credentials))
(when-not (s/valid? ::info-data info)
(let [explain (s/explain-str ::info-data info)]
(l/warn ::l/raw (str "invalid response from ldap, looks like ldap is not configured correctly\n" explain))
(ex/raise :type :restriction
:code :wrong-ldap-response
:reason explain)))
(let [profile (login-or-register cfg {:email (:email info)
:backend (:backend info)
:fullname (:fullname info)})]
(if-let [token (:invitation-token params)]
;; If invitation token comes in params, this is because the
;; user comes from team-invitation process; in this case,
;; regenerate token and send back to the user a new invitation
;; token (and mark current session as logged).
(let [claims (tokens :verify {:token token :iss :team-invitation})
claims (assoc claims
:member-id (:id profile)
:member-email (:email profile))
token (tokens :generate claims)]
(with-meta {:invitation-token token}
{:transform-response ((:create session) (:id profile))
::audit/props (:props profile)
::audit/profile-id (:id profile)}))
(with-meta profile
{:transform-response ((:create session) (:id profile))
::audit/props (:props profile)
::audit/profile-id (:id profile)}))))))
(defn- replace-several [s & {:as replacements}]
(reduce-kv clojure.string/replace s replacements))
(defn- get-ldap-user
[cpool {:keys [email] :as params}]
(let [query (-> (cfg/get :ldap-user-query)
(replace-several ":username" email))
attrs [(cfg/get :ldap-attrs-username)
(cfg/get :ldap-attrs-email)
(cfg/get :ldap-attrs-photo)
(cfg/get :ldap-attrs-fullname)]
base-dn (cfg/get :ldap-base-dn)
params {:filter query
:sizelimit 1
:attributes attrs}]
(first (ldap/search cpool base-dn params))))
(defn- authenticate
[{:keys [password email] :as params}]
(with-open [conn (connect)]
(when-let [{:keys [dn] :as luser} (get-ldap-user conn params)]
(when (ldap/bind? conn dn password)
{:photo (get luser (keyword (cfg/get :ldap-attrs-photo)))
:fullname (get luser (keyword (cfg/get :ldap-attrs-fullname)))
:email email
:backend "ldap"}))))
(defn- login-or-register
[{:keys [conn] :as cfg} info]
(or (some->> (:email info)
(profile-q/retrieve-profile-data-by-email conn)
(profile-q/populate-additional-data conn)
(profile-q/decode-profile-row))
(let [params (-> info
(assoc :is-active true)
(assoc :is-demo false))]
(->> params
(profile-m/create-profile conn)
(profile-m/create-profile-relations conn)
(profile-q/strip-private-attrs)))))

37
backend/src/app/rpc/mutations/media.clj
View file

@ -17,6 +17,8 @@
[app.rpc.queries.teams :as teams]
[app.rpc.rlimit :as rlimit]
[app.storage :as sto]
[app.storage.tmp :as tmp]
[app.util.bytes :as bs]
[app.util.services :as sv]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
@ -179,11 +181,12 @@
(* 1024 1024 100)) ; 100MiB
(defn- create-file-media-object-from-url
[{:keys [storage http-client] :as cfg} {:keys [url name] :as params}]
[{:keys [http-client] :as cfg} {:keys [url name] :as params}]
(letfn [(parse-and-validate-size [headers]
(let [size (some-> (get headers "content-length") d/parse-integer)
mtype (get headers "content-type")
format (cm/mtype->format mtype)]
(when-not size
(ex/raise :type :validation
:code :unknown-size
@ -203,24 +206,24 @@
:mtype mtype
:format format}))
(get-upload-object [sobj]
(p/let [path (sto/get-object-path storage sobj)
mdata (meta sobj)]
{:filename "tempfile"
:size (:size sobj)
:path path
:mtype (:content-type mdata)}))
(download-media [uri]
(p/let [{:keys [body headers]} (http-client {:method :get :uri uri} {:response-type :input-stream})
{:keys [size mtype]} (parse-and-validate-size headers)]
(-> (http-client {:method :get :uri uri} {:response-type :input-stream})
(p/then process-response)))
(-> (assoc storage :backend :tmp)
(sto/put-object! {::sto/content (sto/content body size)
::sto/expired-at (dt/in-future {:minutes 30})
:content-type mtype
:bucket "file-media-object"})
(p/then get-upload-object))))]
(process-response [{:keys [body headers] :as response}]
(let [{:keys [size mtype]} (parse-and-validate-size headers)
path (tmp/tempfile :prefix "penpot.media.download.")
written (bs/write-to-file! body path :size size)]
(when (not= written size)
(ex/raise :type :internal
:code :mismatch-write-size
:hint "unexpected state: unable to write to file"))
{:filename "tempfile"
:size size
:path path
:mtype mtype}))]
(p/let [content (download-media url)]
(->> (merge params {:content content :name (or name (:filename content))})

443
backend/src/app/rpc/mutations/profile.clj
View file

@ -9,19 +9,18 @@
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.emails :as eml]
[app.loggers.audit :as audit]
[app.media :as media]
[app.rpc.commands.auth :as cmd.auth]
[app.rpc.mutations.teams :as teams]
[app.rpc.queries.profile :as profile]
[app.rpc.rlimit :as rlimit]
[app.storage :as sto]
[app.util.services :as sv]
[app.util.time :as dt]
[buddy.hashers :as hashers]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[promesa.core :as p]
@ -37,310 +36,6 @@
(s/def ::password ::us/not-empty-string)
(s/def ::old-password ::us/not-empty-string)
(s/def ::theme ::us/string)
(s/def ::invitation-token ::us/not-empty-string)
(declare check-profile-existence!)
(declare create-profile)
(declare create-profile-relations)
(declare register-profile)
(defn email-domain-in-whitelist?
"Returns true if email's domain is in the given whitelist or if
given whitelist is an empty string."
[domains email]
(if (or (empty? domains)
(nil? domains))
true
(let [[_ candidate] (-> (str/lower email)
(str/split #"@" 2))]
(contains? domains candidate))))
(def ^:private sql:profile-existence
"select exists (select * from profile
where email = ?
and deleted_at is null) as val")
(defn check-profile-existence!
[conn {:keys [email] :as params}]
(let [email (str/lower email)
result (db/exec-one! conn [sql:profile-existence email])]
(when (:val result)
(ex/raise :type :validation
:code :email-already-exists))
params))
(defn derive-password
[password]
(hashers/derive password
{:alg :argon2id
:memory 16384
:iterations 20
:parallelism 2}))
(defn verify-password
[attempt password]
(try
(hashers/verify attempt password)
(catch Exception _e
{:update false
:valid false})))
(defn decode-profile-row
[{:keys [props] :as profile}]
(cond-> profile
(db/pgobject? props "jsonb")
(assoc :props (db/decode-transit-pgobject props))))
;; --- MUTATION: Prepare Register
(s/def ::prepare-register-profile
(s/keys :req-un [::email ::password]
:opt-un [::invitation-token]))
(sv/defmethod ::prepare-register-profile {:auth false}
[{:keys [pool tokens] :as cfg} params]
(when-not (contains? cf/flags :registration)
(if-not (contains? params :invitation-token)
(ex/raise :type :restriction
:code :registration-disabled)
(let [invitation (tokens :verify {:token (:invitation-token params) :iss :team-invitation})]
(when-not (= (:email params) (:member-email invitation))
(ex/raise :type :restriction
:code :email-does-not-match-invitation
:hint "email should match the invitation")))))
(when-let [domains (cf/get :registration-domain-whitelist)]
(when-not (email-domain-in-whitelist? domains (:email params))
(ex/raise :type :validation
:code :email-domain-is-not-allowed)))
;; Don't allow proceed in preparing registration if the profile is
;; already reported as spammer.
(when (eml/has-bounce-reports? pool (:email params))
(ex/raise :type :validation
:code :email-has-permanent-bounces
:hint "looks like the email has one or many bounces reported"))
(check-profile-existence! pool params)
(when (= (str/lower (:email params))
(str/lower (:password params)))
(ex/raise :type :validation
:code :email-as-password
:hint "you can't use your email as password"))
(let [params {:email (:email params)
:password (:password params)
:invitation-token (:invitation-token params)
:backend "penpot"
:iss :prepared-register
:exp (dt/in-future "48h")}
token (tokens :generate params)]
(with-meta {:token token}
{::audit/profile-id uuid/zero})))
;; --- MUTATION: Register Profile
(s/def ::token ::us/not-empty-string)
(s/def ::register-profile
(s/keys :req-un [::token ::fullname]))
(sv/defmethod ::register-profile
{:auth false ::rlimit/permits (cf/get :rlimit-password)}
[{:keys [pool] :as cfg} params]
(db/with-atomic [conn pool]
(-> (assoc cfg :conn conn)
(register-profile params))))
(defn register-profile
[{:keys [conn tokens session] :as cfg} {:keys [token] :as params}]
(let [claims (tokens :verify {:token token :iss :prepared-register})
params (merge params claims)]
(check-profile-existence! conn params)
(let [is-active (or (:is-active params)
(contains? cf/flags :insecure-register))
profile (->> (assoc params :is-active is-active)
(create-profile conn)
(create-profile-relations conn)
(decode-profile-row))
invitation (when-let [token (:invitation-token params)]
(tokens :verify {:token token :iss :team-invitation}))]
(cond
;; If invitation token comes in params, this is because the user comes from team-invitation process;
;; in this case, regenerate token and send back to the user a new invitation token (and mark current
;; session as logged). This happens only if the invitation email matches with the register email.
(and (some? invitation) (= (:email profile) (:member-email invitation)))
(let [claims (assoc invitation :member-id (:id profile))
token (tokens :generate claims)
resp {:invitation-token token}]
(with-meta resp
{:transform-response ((:create session) (:id profile))
::audit/replace-props (audit/profile->props profile)
::audit/profile-id (:id profile)}))
;; If auth backend is different from "penpot" means user is
;; registering using third party auth mechanism; in this case
;; we need to mark this session as logged.
(not= "penpot" (:auth-backend profile))
(with-meta (profile/strip-private-attrs profile)
{:transform-response ((:create session) (:id profile))
::audit/replace-props (audit/profile->props profile)
::audit/profile-id (:id profile)})
;; If the `:enable-insecure-register` flag is set, we proceed
;; to sign in the user directly, without email verification.
(true? is-active)
(with-meta (profile/strip-private-attrs profile)
{:transform-response ((:create session) (:id profile))
::audit/replace-props (audit/profile->props profile)
::audit/profile-id (:id profile)})
;; In all other cases, send a verification email.
:else
(let [vtoken (tokens :generate
{:iss :verify-email
:exp (dt/in-future "48h")
:profile-id (:id profile)
:email (:email profile)})
ptoken (tokens :generate-predefined
{:iss :profile-identity
:profile-id (:id profile)})]
(eml/send! {::eml/conn conn
::eml/factory eml/register
:public-uri (:public-uri cfg)
:to (:email profile)
:name (:fullname profile)
:token vtoken
:extra-data ptoken})
(with-meta profile
{::audit/replace-props (audit/profile->props profile)
::audit/profile-id (:id profile)}))))))
(defn create-profile
"Create the profile entry on the database with limited input filling
all the other fields with defaults."
[conn params]
(let [id (or (:id params) (uuid/next))
props (-> (audit/extract-utm-params params)
(merge (:props params))
(db/tjson))
password (if-let [password (:password params)]
(derive-password password)
"!")
locale (:locale params)
locale (when (and (string? locale) (not (str/blank? locale)))
locale)
backend (:backend params "penpot")
is-demo (:is-demo params false)
is-muted (:is-muted params false)
is-active (:is-active params false)
email (str/lower (:email params))
params {:id id
:fullname (:fullname params)
:email email
:auth-backend backend
:lang locale
:password password
:deleted-at (:deleted-at params)
:props props
:is-active is-active
:is-muted is-muted
:is-demo is-demo}]
(try
(-> (db/insert! conn :profile params)
(decode-profile-row))
(catch org.postgresql.util.PSQLException e
(let [state (.getSQLState e)]
(if (not= state "23505")
(throw e)
(ex/raise :type :validation
:code :email-already-exists
:cause e)))))))
(defn create-profile-relations
[conn profile]
(let [team (teams/create-team conn {:profile-id (:id profile)
:name "Default"
:is-default true})]
(-> profile
(profile/strip-private-attrs)
(assoc :default-team-id (:id team))
(assoc :default-project-id (:default-project-id team)))))
;; --- MUTATION: Login
(s/def ::email ::us/email)
(s/def ::scope ::us/string)
(s/def ::login
(s/keys :req-un [::email ::password]
:opt-un [::scope ::invitation-token]))
(sv/defmethod ::login
{:auth false ::rlimit/permits (cf/get :rlimit-password)}
[{:keys [pool session tokens] :as cfg} {:keys [email password] :as params}]
(when-not (contains? cf/flags :login)
(ex/raise :type :restriction
:code :login-disabled
:hint "login is disabled in this instance"))
(letfn [(check-password [profile password]
(when (= (:password profile) "!")
(ex/raise :type :validation
:code :account-without-password))
(:valid (verify-password password (:password profile))))
(validate-profile [profile]
(when-not (:is-active profile)
(ex/raise :type :validation
:code :wrong-credentials))
(when-not profile
(ex/raise :type :validation
:code :wrong-credentials))
(when-not (check-password profile password)
(ex/raise :type :validation
:code :wrong-credentials))
profile)]
(db/with-atomic [conn pool]
(let [profile (->> (profile/retrieve-profile-data-by-email conn email)
(validate-profile)
(profile/strip-private-attrs)
(profile/populate-additional-data conn)
(decode-profile-row))
invitation (when-let [token (:invitation-token params)]
(tokens :verify {:token token :iss :team-invitation}))
;; If invitation member-id does not matches the profile-id, we just proceed to ignore the
;; invitation because invitations matches exactly; and user can't loging with other email and
;; accept invitation with other email
response (if (and (some? invitation) (= (:id profile) (:member-id invitation)))
{:invitation-token (:invitation-token params)}
profile)]
(with-meta response
{:transform-response ((:create session) (:id profile))
::audit/props (audit/profile->props profile)
::audit/profile-id (:id profile)})))))
;; --- MUTATION: Logout
(s/def ::logout
(s/keys :opt-un [::profile-id]))
(sv/defmethod ::logout {:auth false}
[{:keys [session] :as cfg} _]
(with-meta {}
{:transform-response (:delete session)}))
;; --- MUTATION: Update Profile (own)
@ -414,7 +109,7 @@
(defn- validate-password!
[conn {:keys [profile-id old-password] :as params}]
(let [profile (db/get-by-id conn :profile profile-id)]
(when-not (:valid (verify-password old-password (:password profile)))
(when-not (:valid (cmd.auth/verify-password old-password (:password profile)))
(ex/raise :type :validation
:code :old-password-not-match))
profile))
@ -422,7 +117,7 @@
(defn update-profile-password!
[conn {:keys [id password] :as profile}]
(db/update! conn :profile
{:password (derive-password password)}
{:password (cmd.auth/derive-password password)}
{:id id}))
;; --- MUTATION: Update Photo
@ -481,7 +176,7 @@
(defn- change-email-immediately
[{:keys [conn]} {:keys [profile email] :as params}]
(when (not= email (:email profile))
(check-profile-existence! conn params))
(cmd.auth/check-profile-existence! conn params))
(db/update! conn :profile
{:email email}
{:id (:id profile)})
@ -499,7 +194,7 @@
:profile-id (:id profile)})]
(when (not= email (:email profile))
(check-profile-existence! conn params))
(cmd.auth/check-profile-existence! conn params))
(when-not (eml/allow-send-emails? conn profile)
(ex/raise :type :validation
@ -526,76 +221,6 @@
[conn id]
(db/get-by-id conn :profile id {:for-update true}))
;; --- MUTATION: Request Profile Recovery
(s/def ::request-profile-recovery
(s/keys :req-un [::email]))
(sv/defmethod ::request-profile-recovery {:auth false}
[{:keys [pool tokens] :as cfg} {:keys [email] :as params}]
(letfn [(create-recovery-token [{:keys [id] :as profile}]
(let [token (tokens :generate
{:iss :password-recovery
:exp (dt/in-future "15m")
:profile-id id})]
(assoc profile :token token)))
(send-email-notification [conn profile]
(let [ptoken (tokens :generate-predefined
{:iss :profile-identity
:profile-id (:id profile)})]
(eml/send! {::eml/conn conn
::eml/factory eml/password-recovery
:public-uri (:public-uri cfg)
:to (:email profile)
:token (:token profile)
:name (:fullname profile)
:extra-data ptoken})
nil))]
(db/with-atomic [conn pool]
(when-let [profile (profile/retrieve-profile-data-by-email conn email)]
(when-not (eml/allow-send-emails? conn profile)
(ex/raise :type :validation
:code :profile-is-muted
:hint "looks like the profile has reported repeatedly as spam or has permanent bounces."))
(when-not (:is-active profile)
(ex/raise :type :validation
:code :profile-not-verified
:hint "the user need to validate profile before recover password"))
(when (eml/has-bounce-reports? conn (:email profile))
(ex/raise :type :validation
:code :email-has-permanent-bounces
:hint "looks like the email you invite has been repeatedly reported as spam or permanent bounce"))
(->> profile
(create-recovery-token)
(send-email-notification conn))))))
;; --- MUTATION: Recover Profile
(s/def ::token ::us/not-empty-string)
(s/def ::recover-profile
(s/keys :req-un [::token ::password]))
(sv/defmethod ::recover-profile
{:auth false ::rlimit/permits (cf/get :rlimit-password)}
[{:keys [pool tokens] :as cfg} {:keys [token password]}]
(letfn [(validate-token [token]
(let [tdata (tokens :verify {:token token :iss :password-recovery})]
(:profile-id tdata)))
(update-password [conn profile-id]
(let [pwd (derive-password password)]
(db/update! conn :profile {:password pwd} {:id profile-id})))]
(db/with-atomic [conn pool]
(->> (validate-token token)
(update-password conn))
nil)))
;; --- MUTATION: Update Profile Props
@ -668,3 +293,61 @@
:code :owner-teams-with-people
:hint "The user need to transfer ownership of owned teams."
:context {:teams (mapv :team-id rows)}))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DEPRECATED METHODS (TO BE REMOVED ON 1.16.x)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- MUTATION: Login
(s/def ::login ::cmd.auth/login-with-password)
(sv/defmethod ::login
{:auth false ::rlimit/permits (cf/get :rlimit-password)}
[cfg params]
(cmd.auth/login-with-password cfg params))
;; --- MUTATION: Logout
(s/def ::logout ::cmd.auth/logout)
(sv/defmethod ::logout {:auth false}
[{:keys [session] :as cfg} _]
(with-meta {}
{:transform-response (:delete session)}))
;; --- MUTATION: Recover Profile
(s/def ::recover-profile ::cmd.auth/recover-profile)
(sv/defmethod ::recover-profile
{:auth false ::rlimit/permits (cf/get :rlimit-password)}
[cfg params]
(cmd.auth/recover-profile cfg params))
;; --- MUTATION: Prepare Register
(s/def ::prepare-register-profile ::cmd.auth/prepare-register-profile)
(sv/defmethod ::prepare-register-profile {:auth false}
[cfg params]
(cmd.auth/prepare-register cfg params))
;; --- MUTATION: Register Profile
(s/def ::register-profile ::cmd.auth/register-profile)
(sv/defmethod ::register-profile
{:auth false ::rlimit/permits (cf/get :rlimit-password)}
[{:keys [pool] :as cfg} params]
(db/with-atomic [conn pool]
(-> (assoc cfg :conn conn)
(cmd.auth/register-profile params))))
;; --- MUTATION: Request Profile Recovery
(s/def ::request-profile-recovery ::cmd.auth/request-profile-recovery)
(sv/defmethod ::request-profile-recovery {:auth false}
[cfg params]
(cmd.auth/request-profile-recovery cfg params))

20
backend/src/app/rpc/mutations/share_link.clj
View file

@ -19,7 +19,8 @@
(s/def ::id ::us/uuid)
(s/def ::profile-id ::us/uuid)
(s/def ::file-id ::us/uuid)
(s/def ::flags (s/every ::us/string :kind set?))
(s/def ::who-comment ::us/string)
(s/def ::who-inspect ::us/string)
(s/def ::pages (s/every ::us/uuid :kind set?))
;; --- Mutation: Create Share Link
@ -27,14 +28,13 @@
(declare create-share-link)
(s/def ::create-share-link
(s/keys :req-un [::profile-id ::file-id ::flags]
:opt-un [::pages]))
(s/keys :req-un [::profile-id ::file-id ::who-comment ::who-inspect ::pages]))
(sv/defmethod ::create-share-link
"Creates a share-link object.
Share links are resources that allows external users access to
specific files with specific permissions (flags)."
Share links are resources that allows external users access to specific
pages of a file with specific permissions (who-comment and who-inspect)."
[{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
(db/with-atomic [conn pool]
@ -42,19 +42,17 @@
(create-share-link conn params)))
(defn create-share-link
[conn {:keys [profile-id file-id pages flags]}]
[conn {:keys [profile-id file-id pages who-comment who-inspect]}]
(let [pages (db/create-array conn "uuid" pages)
flags (->> (map name flags)
(db/create-array conn "text"))
slink (db/insert! conn :share-link
{:id (uuid/next)
:file-id file-id
:flags flags
:who-comment who-comment
:who-inspect who-inspect
:pages pages
:owner-id profile-id})]
(-> slink
(update :pages db/decode-pgarray #{})
(update :flags db/decode-pgarray #{}))))
(update :pages db/decode-pgarray #{}))))
;; --- Mutation: Delete Share Link

10
backend/src/app/rpc/permissions.clj
View file

@ -53,6 +53,16 @@
([perms] (:can-read perms))
([conn & args] (check (apply qfn conn args)))))
(defn make-comment-predicate-fn
"A simple factory for comment permission predicate functions."
[qfn]
(us/assert fn? qfn)
(fn check
([perms]
(and (:is-logged perms) (= (:who-comment perms) "all")))
([conn & args]
(check (apply qfn conn args)))))
(defn make-check-fn
"Helper that converts a predicate permission function to a check
function (function that raises an exception)."

63
backend/src/app/rpc/queries/comments.clj
View file

@ -25,16 +25,16 @@
(s/def ::team-id ::us/uuid)
(s/def ::file-id ::us/uuid)
(s/def ::share-id (s/nilable ::us/uuid))
(s/def ::comment-threads
(s/and (s/keys :req-un [::profile-id]
:opt-un [::file-id ::team-id])
:opt-un [::file-id ::share-id ::team-id])
#(or (:file-id %) (:team-id %))))
(sv/defmethod ::comment-threads
[{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
[{:keys [pool] :as cfg} params]
(with-open [conn (db/open pool)]
(files/check-read-permissions! conn profile-id file-id)
(retrieve-comment-threads conn params)))
(def sql:comment-threads
@ -60,8 +60,8 @@
window w as (partition by c.thread_id order by c.created_at asc)")
(defn- retrieve-comment-threads
[conn {:keys [profile-id file-id]}]
(files/check-read-permissions! conn profile-id file-id)
[conn {:keys [profile-id file-id share-id]}]
(files/check-comment-permissions! conn profile-id file-id share-id)
(->> (db/exec! conn [sql:comment-threads profile-id file-id])
(into [] (map decode-row))))
@ -116,13 +116,15 @@
;; --- Query: Single Comment Thread
(s/def ::id ::us/uuid)
(s/def ::share-id (s/nilable ::us/uuid))
(s/def ::comment-thread
(s/keys :req-un [::profile-id ::file-id ::id]))
(s/keys :req-un [::profile-id ::file-id ::id]
:opt-un [::share-id]))
(sv/defmethod ::comment-thread
[{:keys [pool] :as cfg} {:keys [profile-id file-id id] :as params}]
[{:keys [pool] :as cfg} {:keys [profile-id file-id id share-id] :as params}]
(with-open [conn (db/open pool)]
(files/check-read-permissions! conn profile-id file-id)
(files/check-comment-permissions! conn profile-id file-id share-id)
(let [sql (str "with threads as (" sql:comment-threads ")"
"select * from threads where id = ?")]
(-> (db/exec-one! conn [sql profile-id file-id id])
@ -133,15 +135,17 @@
(declare retrieve-comments)
(s/def ::file-id ::us/uuid)
(s/def ::share-id (s/nilable ::us/uuid))
(s/def ::thread-id ::us/uuid)
(s/def ::comments
(s/keys :req-un [::profile-id ::thread-id]))
(s/keys :req-un [::profile-id ::thread-id]
:opt-un [::share-id]))
(sv/defmethod ::comments
[{:keys [pool] :as cfg} {:keys [profile-id thread-id] :as params}]
[{:keys [pool] :as cfg} {:keys [profile-id thread-id share-id] :as params}]
(with-open [conn (db/open pool)]
(let [thread (db/get-by-id conn :comment-thread thread-id)]
(files/check-read-permissions! conn profile-id (:file-id thread))
(files/check-comment-permissions! conn profile-id (:file-id thread) share-id)
(retrieve-comments conn thread-id))))
(def sql:comments
@ -153,3 +157,40 @@
[conn thread-id]
(->> (db/exec! conn [sql:comments thread-id])
(into [] (map decode-row))))
;; file-comments-users
(declare retrieve-file-comments-users)
(s/def ::file-id ::us/uuid)
(s/def ::share-id (s/nilable ::us/uuid))
(s/def ::file-comments-users
(s/keys :req-un [::profile-id ::file-id]
:opt-un [::share-id]))
(sv/defmethod ::file-comments-users
[{:keys [pool] :as cfg} {:keys [profile-id file-id share-id]}]
(with-open [conn (db/open pool)]
(files/check-comment-permissions! conn profile-id file-id share-id)
(retrieve-file-comments-users conn file-id profile-id)))
(def sql:file-comment-users
"select p.id,
p.email,
p.fullname as name,
p.fullname as fullname,
p.photo_id,
p.is_active
from profile p
where p.id in
(select owner_id from comment
where thread_id in
(select id from comment_thread
where file_id=?))
or p.id=?
") ;; all the users that had comment the file, plus the current user
(defn retrieve-file-comments-users
[conn file-id profile-id]
(db/exec! conn [sql:file-comment-users file-id profile-id]))

44
backend/src/app/rpc/queries/files.clj
View file

@ -9,6 +9,7 @@
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.geom.shapes :as gsh]
[app.common.pages.helpers :as cph]
[app.common.pages.migrations :as pmg]
[app.common.spec :as us]
@ -84,7 +85,8 @@
:is-owner is-owner
:is-admin (or is-owner is-admin)
:can-edit (or is-owner is-admin can-edit)
:can-read true})))
:can-read true
:is-logged (some? profile-id)})))
([conn profile-id file-id share-id]
(let [perms (get-permissions conn profile-id file-id)
ldata (retrieve-share-link conn file-id share-id)]
@ -97,7 +99,9 @@
(some? perms) perms
(some? ldata) {:type :share-link
:can-read true
:flags (:flags ldata)}))))
:is-logged (some? profile-id)
:who-comment (:who-comment ldata)
:who-inspect (:who-inspect ldata)}))))
(def has-edit-permissions?
(perms/make-edition-predicate-fn get-permissions))
@ -105,12 +109,26 @@
(def has-read-permissions?
(perms/make-read-predicate-fn get-permissions))
(def has-comment-permissions?
(perms/make-comment-predicate-fn get-permissions))
(def check-edition-permissions!
(perms/make-check-fn has-edit-permissions?))
(def check-read-permissions!
(perms/make-check-fn has-read-permissions?))
;; A user has comment permissions if she has read permissions, or comment permissions
(defn check-comment-permissions!
[conn profile-id file-id share-id]
(let [can-read (has-read-permissions? conn profile-id file-id)
can-comment (has-comment-permissions? conn profile-id file-id share-id)
]
(when-not (or can-read can-comment)
(ex/raise :type :not-found
:code :object-not-found
:hint "not found"))))
;; --- Query: Files search
;; TODO: this query need to a good refactor
@ -289,7 +307,7 @@
frame (-> page :objects cph/get-frames)]
(assoc frame :page-id (:id page)))))
;; function responsible to filter objects data strucuture of
;; function responsible to filter objects data structure of
;; all unneded shapes if a concrete frame is provided. If no
;; frame, the objects is returned untouched.
(filter-objects [objects frame-id]
@ -307,10 +325,24 @@
object-id (str page-id frame-id)
frame (if-let [thumb (get thumbnails object-id)]
(assoc frame :thumbnail thumb :shapes [])
(dissoc frame :thumbnail))]
(dissoc frame :thumbnail))
children-ids
(cph/get-children-ids objects frame-id)
bounds
(when (:show-content frame)
(gsh/selection-rect (concat [frame] (->> children-ids (map (d/getf objects))))))
frame
(cond-> frame
(some? bounds)
(assoc :children-bounds bounds))]
(if (:thumbnail frame)
(recur (-> (assoc objects frame-id frame)
(d/without-keys (cph/get-children-ids objects frame-id)))
(recur (-> objects
(assoc frame-id frame)
(d/without-keys children-ids))
(rest frames))
(recur (assoc objects frame-id frame)
(rest frames))))

1
backend/src/app/rpc/queries/share_link.clj
View file

@ -11,7 +11,6 @@
(defn decode-share-link-row
[row]
(-> row
(update :flags db/decode-pgarray #{})
(update :pages db/decode-pgarray #{})))
(defn retrieve-share-link

10
backend/src/app/rpc/queries/viewer.clj
View file

@ -9,9 +9,9 @@
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.db :as db]
[app.rpc.queries.comments :as comments]
[app.rpc.queries.files :as files]
[app.rpc.queries.share-link :as slnk]
[app.rpc.queries.teams :as teams]
[app.rpc.queries.share-link :as slnk]
[app.util.services :as sv]
[clojure.spec.alpha :as s]
[promesa.core :as p]))
@ -23,11 +23,11 @@
(db/get-by-id pool :project id {:columns [:id :name :team-id]}))
(defn- retrieve-bundle
[{:keys [pool] :as cfg} file-id]
[{:keys [pool] :as cfg} file-id profile-id]
(p/let [file (files/retrieve-file cfg file-id)
project (retrieve-project pool (:project-id file))
libs (files/retrieve-file-libraries cfg false file-id)
users (teams/retrieve-users pool (:team-id project))
users (comments/retrieve-file-comments-users pool file-id profile-id)
links (->> (db/query pool :share-link {:file-id file-id})
(mapv slnk/decode-share-link-row))
@ -54,7 +54,7 @@
(p/let [slink (slnk/retrieve-share-link pool file-id share-id)
perms (files/get-permissions pool profile-id file-id share-id)
thumbs (files/retrieve-object-thumbnails cfg file-id)
bundle (p/-> (retrieve-bundle cfg file-id)
bundle (p/-> (retrieve-bundle cfg file-id profile-id)
(assoc :permissions perms)
(assoc-in [:file :thumbnails] thumbs))]

2
backend/src/app/srepl/dev.clj
View file

@ -3,7 +3,7 @@
(:require
[app.db :as db]
[app.config :as cfg]
[app.rpc.mutations.profile :refer [derive-password]]
[app.rpc.commands.auth :refer [derive-password]]
[app.main :refer [system]]))
(defn reset-passwords

1
backend/src/app/srepl/main.clj
View file

@ -7,7 +7,6 @@
[app.common.logging :as l]
[app.common.pages :as cp]
[app.common.pages.migrations :as pmg]
[app.common.spec.file :as spec.file]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]

38
backend/src/app/storage.clj
View file

@ -14,7 +14,6 @@
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.db :as db]
[app.storage.db :as sdb]
[app.storage.fs :as sfs]
[app.storage.impl :as impl]
[app.storage.s3 :as ss3]
@ -32,14 +31,12 @@
(s/def ::s3 ::ss3/backend)
(s/def ::fs ::sfs/backend)
(s/def ::db ::sdb/backend)
(s/def ::backends
(s/map-of ::us/keyword
(s/nilable
(s/or :s3 ::ss3/backend
:fs ::sfs/backend
:db ::sdb/backend))))
:fs ::sfs/backend))))
(defmethod ig/pre-init-spec ::storage [_]
(s/keys :req-un [::db/pool ::wrk/executor ::backends]))
@ -84,13 +81,14 @@
" and backend = ?"
" and deleted_at is null"
" limit 1")]
(db/exec-one! conn [sql hash bucket (name backend)])))
(some-> (db/exec-one! conn [sql hash bucket (name backend)])
(update :metadata db/decode-transit-pgobject))))
(defn- create-database-object
[{:keys [conn backend executor]} {:keys [::content ::expired-at ::touched-at] :as params}]
(us/assert ::storage-content content)
(px/with-dispatch executor
(let [id (uuid/random)
(let [id (uuid/next)
mdata (cond-> (get-metadata params)
(satisfies? impl/IContentHash content)
@ -106,13 +104,15 @@
(get-database-object-by-hash conn backend (:bucket mdata) (:hash mdata)))
result (or result
(db/insert! conn :storage-object
{:id id
:size (count content)
:backend (name backend)
:metadata (db/tjson mdata)
:deleted-at expired-at
:touched-at touched-at}))]
(-> (db/insert! conn :storage-object
{:id id
:size (impl/get-size content)
:backend (name backend)
:metadata (db/tjson mdata)
:deleted-at expired-at
:touched-at touched-at})
(update :metadata db/decode-transit-pgobject)
(update :metadata assoc ::created? true)))]
(StorageObject. (:id result)
(:size result)
@ -120,7 +120,7 @@
(:deleted-at result)
(:touched-at result)
backend
mdata
(:metadata result)
nil))))
(def ^:private sql:retrieve-storage-object
@ -173,9 +173,10 @@
(p/let [storage (assoc storage :conn (or conn pool))
object (create-database-object storage params)]
;; Store the data finally on the underlying storage subsystem.
(-> (impl/resolve-backend storage backend)
(impl/put-object object content))
(when (::created? (meta object))
;; Store the data finally on the underlying storage subsystem.
(-> (impl/resolve-backend storage backend)
(impl/put-object object content)))
object))
@ -259,7 +260,8 @@
;; A task responsible to permanently delete already marked as deleted
;; storage files. The storage objects are practically never marked to
;; be deleted directly by the api call. The touched-gc is responsible
;; of collecting the usage of the object and mark it as deleted.
;; of collecting the usage of the object and mark it as deleted. Only
;; the TMP files are are created with expiration date in future.
(declare sql:retrieve-deleted-objects-chunk)

67
backend/src/app/storage/db.clj
View file

@ -1,67 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) UXBOX Labs SL
(ns app.storage.db
(:require
[app.common.spec :as us]
[app.db :as db]
[app.storage.impl :as impl]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[promesa.exec :as px])
(:import
java.io.ByteArrayInputStream))
;; --- BACKEND INIT
(defmethod ig/pre-init-spec ::backend [_]
(s/keys :opt-un [::db/pool]))
(defmethod ig/init-key ::backend
[_ cfg]
(assoc cfg :type :db))
(s/def ::type ::us/keyword)
(s/def ::backend
(s/keys :req-un [::type ::db/pool]))
;; --- API IMPL
(defmethod impl/put-object :db
[{:keys [conn executor] :as storage} {:keys [id] :as object} content]
(px/with-dispatch executor
(let [data (impl/slurp-bytes content)]
(db/insert! conn :storage-data {:id id :data data})
object)))
(defmethod impl/get-object-data :db
[{:keys [conn executor] :as backend} {:keys [id] :as object}]
(px/with-dispatch executor
(let [result (db/exec-one! conn ["select data from storage_data where id=?" id])]
(ByteArrayInputStream. (:data result)))))
(defmethod impl/get-object-bytes :db
[{:keys [conn executor] :as backend} {:keys [id] :as object}]
(px/with-dispatch executor
(let [result (db/exec-one! conn ["select data from storage_data where id=?" id])]
(:data result))))
(defmethod impl/get-object-url :db
[_ _]
(throw (UnsupportedOperationException. "not supported")))
(defmethod impl/del-object :db
[_ _]
;; NOOP: because deleting the row already deletes the file data from
;; the database.
nil)
(defmethod impl/del-objects-in-bulk :db
[_ _]
;; NOOP: because deleting the row already deletes the file data from
;; the database.
nil)

9
backend/src/app/storage/fs.clj
View file

@ -10,11 +10,13 @@
[app.common.spec :as us]
[app.common.uri :as u]
[app.storage.impl :as impl]
[app.util.bytes :as bs]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[datoteka.core :as fs]
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px])
(:import
java.io.InputStream
@ -72,9 +74,10 @@
(io/input-stream full))))
(defmethod impl/get-object-bytes :fs
[{:keys [executor] :as backend} object]
(px/with-dispatch executor
(fs/slurp-bytes (impl/get-object-data backend object))))
[backend object]
(p/let [input (impl/get-object-data backend object)]
(ex/with-always (bs/close! input)
(bs/read-as-bytes input))))
(defmethod impl/get-object-url :fs
[{:keys [uri executor] :as backend} {:keys [id] :as object} _]

119
backend/src/app/storage/impl.clj
View file

@ -9,18 +9,15 @@
(:require
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.uuid :as uuid]
[app.util.bytes :as bs]
[buddy.core.codecs :as bc]
[buddy.core.hash :as bh]
[clojure.java.io :as io])
(:import
java.nio.ByteBuffer
java.util.UUID
java.io.ByteArrayInputStream
java.io.InputStream
java.nio.file.Files
org.apache.commons.io.input.BoundedInputStream
))
java.nio.file.Path
java.util.UUID))
;; --- API Definition
@ -95,23 +92,23 @@
(defn coerce-id
[id]
(cond
(string? id) (uuid/uuid id)
(uuid? id) id
:else (ex/raise :type :internal
:code :invalid-id-type
:hint "id should be string or uuid")))
(string? id) (parse-uuid id)
(uuid? id) id
:else (ex/raise :type :internal
:code :invalid-id-type
:hint "id should be string or uuid")))
(defprotocol IContentObject
(size [_] "get object size"))
(get-size [_] "get object size"))
(defprotocol IContentHash
(get-hash [_] "get precalculated hash"))
(defn- make-content
[^InputStream is ^long size]
(defn- path->content
[^Path path ^long size]
(reify
IContentObject
(size [_] size)
(get-size [_] size)
io/IOFactory
(make-reader [this opts]
@ -119,47 +116,53 @@
(make-writer [_ _]
(throw (UnsupportedOperationException. "not implemented")))
(make-input-stream [_ _]
(doto (BoundedInputStream. is size)
(.setPropagateClose false)))
(-> (io/input-stream path)
(bs/bounded-input-stream size)))
(make-output-stream [_ _]
(throw (UnsupportedOperationException. "not implemented")))))
(defn- bytes->content
[^bytes data ^long size]
(reify
IContentObject
(get-size [_] size)
io/IOFactory
(make-reader [this opts]
(io/make-reader this opts))
(make-writer [_ _]
(throw (UnsupportedOperationException. "not implemented")))
clojure.lang.Counted
(count [_] size)
java.lang.AutoCloseable
(close [_]
(.close is))))
(make-input-stream [_ _]
(-> (bs/bytes-input-stream data)
(bs/bounded-input-stream size)))
(make-output-stream [_ _]
(throw (UnsupportedOperationException. "not implemented")))))
(defn content
([data] (content data nil))
([data size]
(cond
(instance? java.nio.file.Path data)
(make-content (io/input-stream data)
(Files/size data))
(path->content data (or size (Files/size data)))
(instance? java.io.File data)
(content (.toPath ^java.io.File data) nil)
(content (.toPath ^java.io.File data) size)
(instance? String data)
(let [data (.getBytes data "UTF-8")
bais (ByteArrayInputStream. ^bytes data)]
(make-content bais (alength data)))
(let [data (.getBytes data "UTF-8")]
(bytes->content data (alength data)))
(bytes? data)
(let [size (alength ^bytes data)
bais (ByteArrayInputStream. ^bytes data)]
(make-content bais size))
(bytes->content data (or size (alength ^bytes data)))
(instance? InputStream data)
(do
(when-not size
(throw (UnsupportedOperationException. "size should be provided on InputStream")))
(make-content data size))
;; (instance? InputStream data)
;; (do
;; (when-not size
;; (throw (UnsupportedOperationException. "size should be provided on InputStream")))
;; (make-content data size))
:else
(throw (UnsupportedOperationException. "type not supported")))))
(throw (IllegalArgumentException. "invalid argument type")))))
(defn wrap-with-hash
[content ^String hash]
@ -171,7 +174,7 @@
(reify
IContentObject
(size [_] (size content))
(get-size [_] (get-size content))
IContentHash
(get-hash [_] hash)
@ -184,43 +187,17 @@
(make-input-stream [_ opts]
(io/make-input-stream content opts))
(make-output-stream [_ opts]
(io/make-output-stream content opts))
clojure.lang.Counted
(count [_] (count content))
java.lang.AutoCloseable
(close [_]
(.close ^java.lang.AutoCloseable content))))
(io/make-output-stream content opts))))
(defn content?
[v]
(satisfies? IContentObject v))
(defn slurp-bytes
[content]
(with-open [input (io/input-stream content)
output (java.io.ByteArrayOutputStream. (count content))]
(io/copy input output)
(.toByteArray output)))
(defn calculate-hash
[path-or-stream]
(let [result (cond
(instance? InputStream path-or-stream)
(let [result (-> (bh/blake2b-256 path-or-stream)
(bc/bytes->hex))]
(.reset path-or-stream)
result)
(string? path-or-stream)
(-> (bh/blake2b-256 path-or-stream)
(bc/bytes->hex))
:else
(with-open [is (io/input-stream path-or-stream)]
(-> (bh/blake2b-256 is)
(bc/bytes->hex))))]
[resource]
(let [result (with-open [input (io/input-stream resource)]
(-> (bh/blake2b-256 input)
(bc/bytes->hex)))]
(str "blake2b:" result)))
(defn resolve-backend

66
backend/src/app/storage/s3.clj
View file

@ -12,14 +12,17 @@
[app.common.spec :as us]
[app.common.uri :as u]
[app.storage.impl :as impl]
[app.storage.tmp :as tmp]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[datoteka.core :as fs]
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px])
(:import
java.io.FilterInputStream
java.io.InputStream
java.nio.ByteBuffer
java.time.Duration
@ -30,6 +33,7 @@
org.reactivestreams.Subscription
software.amazon.awssdk.core.ResponseBytes
software.amazon.awssdk.core.async.AsyncRequestBody
software.amazon.awssdk.core.async.AsyncResponseTransformer
software.amazon.awssdk.core.client.config.ClientAsyncConfiguration
software.amazon.awssdk.core.client.config.SdkAdvancedAsyncClientOption
software.amazon.awssdk.http.nio.netty.NettyNioAsyncHttpClient
@ -68,9 +72,10 @@
(s/keys :opt-un [::region ::bucket ::prefix ::endpoint ::wrk/executor]))
(defmethod ig/prep-key ::backend
[_ {:keys [prefix] :as cfg}]
[_ {:keys [prefix region] :as cfg}]
(cond-> (d/without-nils cfg)
prefix (assoc :prefix prefix)))
(some? prefix) (assoc :prefix prefix)
(nil? region) (assoc :region :eu-central-1)))
(defmethod ig/init-key ::backend
[_ cfg]
@ -106,7 +111,16 @@
(defmethod impl/get-object-data :s3
[backend object]
(get-object-data backend object))
(letfn [(no-such-key? [cause]
(instance? software.amazon.awssdk.services.s3.model.NoSuchKeyException cause))
(handle-not-found [cause]
(ex/raise :type :not-found
:code :object-not-found
:hint "s3 object not found"
:cause cause))]
(-> (get-object-data backend object)
(p/catch no-such-key? handle-not-found))))
(defmethod impl/get-object-bytes :s3
[backend object]
@ -130,7 +144,8 @@
(def default-timeout
(dt/duration {:seconds 30}))
(defn- ^Region lookup-region
(defn- lookup-region
^Region
[region]
(Region/of (name region)))
@ -202,7 +217,7 @@
(reify
AsyncRequestBody
(contentLength [_]
(Optional/of (long (count content))))
(Optional/of (long (impl/get-size content))))
(^void subscribe [_ ^Subscriber s]
(let [thread (Thread. #(writer-fn s))]
@ -214,7 +229,6 @@
(cancel [_]
(.interrupt thread)
(.release sem 1))
(request [_ n]
(.release sem (int n))))))))))
@ -236,16 +250,31 @@
^AsyncRequestBody content))))
(defn get-object-data
[{:keys [client bucket prefix]} {:keys [id]}]
(p/let [gor (.. (GetObjectRequest/builder)
(bucket bucket)
(key (str prefix (impl/id->path id)))
(build))
obj (.getObject ^S3AsyncClient client ^GetObjectRequest gor)
;; rsp (.response ^ResponseInputStream obj)
;; len (.contentLength ^GetObjectResponse rsp)
]
(io/input-stream obj)))
[{:keys [client bucket prefix]} {:keys [id size]}]
(let [gor (.. (GetObjectRequest/builder)
(bucket bucket)
(key (str prefix (impl/id->path id)))
(build))]
;; If the file size is greater than 2MiB then stream the content
;; to the filesystem and then read with buffered inputstream; if
;; not, read the contento into memory using bytearrays.
(if (> size (* 1024 1024 2))
(p/let [path (tmp/tempfile :prefix "penpot.storage.s3.")
rxf (AsyncResponseTransformer/toFile path)
_ (.getObject ^S3AsyncClient client
^GetObjectRequest gor
^AsyncResponseTransformer rxf)]
(proxy [FilterInputStream] [(io/input-stream path)]
(close []
(fs/delete path)
(proxy-super close))))
(p/let [rxf (AsyncResponseTransformer/toBytes)
obj (.getObject ^S3AsyncClient client
^GetObjectRequest gor
^AsyncResponseTransformer rxf)]
(.asInputStream ^ResponseBytes obj)))))
(defn get-object-bytes
[{:keys [client bucket prefix]} {:keys [id]}]
@ -253,7 +282,10 @@
(bucket bucket)
(key (str prefix (impl/id->path id)))
(build))
obj (.getObjectAsBytes ^S3AsyncClient client ^GetObjectRequest gor)]
rxf (AsyncResponseTransformer/toBytes)
obj (.getObjectAsBytes ^S3AsyncClient client
^GetObjectRequest gor
^AsyncResponseTransformer rxf)]
(.asByteArray ^ResponseBytes obj)))
(def default-max-age

83
backend/src/app/storage/tmp.clj Normal file
View file

@ -0,0 +1,83 @@
;; 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) UXBOX Labs SL
(ns app.storage.tmp
"Temporal files service all created files will be tried to clean after
1 hour afrer creation. This is a best effort, if this process fails,
the operating system cleaning task should be responsible of
permanently delete these files (look at systemd-tempfiles)."
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.core.async :as a]
[clojure.spec.alpha :as s]
[datoteka.core :as fs]
[integrant.core :as ig]
[promesa.exec :as px]))
(declare remove-temp-file)
(defonce queue (a/chan 128))
(s/def ::min-age ::dt/duration)
(defmethod ig/pre-init-spec ::cleaner [_]
(s/keys :req-un [::min-age ::wrk/scheduler ::wrk/executor]))
(defmethod ig/prep-key ::cleaner
[_ cfg]
(merge {:min-age (dt/duration {:minutes 30})}
(d/without-nils cfg)))
(defmethod ig/init-key ::cleaner
[_ {:keys [scheduler executor min-age] :as cfg}]
(l/info :hint "starting tempfile cleaner service")
(let [cch (a/chan)]
(a/go-loop []
(let [[path port] (a/alts! [queue cch])]
(when (not= port cch)
(l/trace :hint "schedule tempfile deletion" :path path
:expires-at (dt/plus (dt/now) min-age))
(px/schedule! scheduler
(inst-ms min-age)
(partial remove-temp-file executor path))
(recur))))
cch))
(defmethod ig/halt-key! ::cleaner
[_ close-ch]
(l/info :hint "stoping tempfile cleaner service")
(some-> close-ch a/close!))
(defn- remove-temp-file
"Permanently delete tempfile"
[executor path]
(px/with-dispatch executor
(l/trace :hint "permanently delete tempfile" :path path)
(when (fs/exists? path)
(fs/delete path))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn tempfile
"Returns a tmpfile candidate (without creating it)"
[& {:keys [suffix prefix]
:or {prefix "penpot."
suffix ".tmp"}}]
(let [candidate (fs/tempfile :suffix suffix :prefix prefix)]
(a/offer! queue candidate)
candidate))
(defn create-tempfile
[& {:keys [suffix prefix]
:or {prefix "penpot."
suffix ".tmp"}}]
(let [path (fs/create-tempfile :suffix suffix :prefix prefix)]
(a/offer! queue path)
path))

2
backend/src/app/tasks/file_gc.clj
View file

@ -82,7 +82,7 @@
:kf first
:initk (dt/now)))))
(defn- collect-used-media
(defn collect-used-media
[data]
(let [xform (comp
(map :objects)

126
backend/src/app/util/bytes.clj Normal file
View file

@ -0,0 +1,126 @@
;; 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) UXBOX Labs SL
(ns app.util.bytes
"Bytes & Byte Streams helpers"
(:require
[clojure.java.io :as io]
[datoteka.core :as fs]
[yetti.adapter :as yt])
(:import
com.github.luben.zstd.ZstdInputStream
com.github.luben.zstd.ZstdOutputStream
java.io.ByteArrayInputStream
java.io.ByteArrayOutputStream
java.io.DataInputStream
java.io.DataOutputStream
java.io.OutputStream
java.io.InputStream
java.lang.AutoCloseable
org.apache.commons.io.IOUtils
org.apache.commons.io.input.BoundedInputStream))
(set! *warn-on-reflection* true)
(def ^:const default-buffer-size
(:xnio/buffer-size yt/defaults))
(defn input-stream?
[s]
(instance? InputStream s))
(defn output-stream?
[s]
(instance? OutputStream s))
(defn data-input-stream?
[s]
(instance? DataInputStream s))
(defn data-output-stream?
[s]
(instance? DataOutputStream s))
(defn copy!
[src dst & {:keys [offset size buffer-size]
:or {offset 0 buffer-size default-buffer-size}}]
(let [^bytes buff (byte-array buffer-size)]
(if size
(IOUtils/copyLarge ^InputStream src ^OutputStream dst (long offset) (long size) buff)
(IOUtils/copyLarge ^InputStream src ^OutputStream dst buff))))
(defn write-to-file!
[src dst & {:keys [size]}]
(with-open [^OutputStream output (io/output-stream dst)]
(cond
(bytes? src)
(if size
(with-open [^InputStream input (ByteArrayInputStream. ^bytes src)]
(with-open [^InputStream input (BoundedInputStream. input (or size (alength ^bytes src)))]
(copy! input output :size size)))
(do
(IOUtils/writeChunked ^bytes src output)
(.flush ^OutputStream output)
(alength ^bytes src)))
(instance? InputStream src)
(copy! src output :size size)
:else
(throw (IllegalArgumentException. "invalid arguments")))))
(defn read-as-bytes
"Read input stream as byte array."
[input & {:keys [size]}]
(cond
(instance? InputStream input)
(with-open [output (ByteArrayOutputStream. (or size (.available ^InputStream input)))]
(copy! input output :size size)
(.toByteArray output))
(fs/path? input)
(with-open [input (io/input-stream input)
output (ByteArrayOutputStream. (or size (.available input)))]
(copy! input output :size size)
(.toByteArray output))
:else
(throw (IllegalArgumentException. "invalid arguments"))))
(defn bytes-input-stream
"Creates an instance of ByteArrayInputStream."
[^bytes data]
(ByteArrayInputStream. data))
(defn bounded-input-stream
[input size & {:keys [close?] :or {close? true}}]
(doto (BoundedInputStream. ^InputStream input ^long size)
(.setPropagateClose close?)))
(defn zstd-input-stream
^InputStream
[input]
(ZstdInputStream. ^InputStream input))
(defn zstd-output-stream
^OutputStream
[output & {:keys [level] :or {level 0}}]
(ZstdOutputStream. ^OutputStream output (int level)))
(defn data-input-stream
^DataInputStream
[input]
(DataInputStream. ^InputStream input))
(defn data-output-stream
^DataOutputStream
[output]
(DataOutputStream. ^OutputStream output))
(defn close!
[^AutoCloseable stream]
(.close stream))

6
backend/src/app/util/emails.clj
View file

@ -30,7 +30,8 @@
[v]
(InternetAddress/parse ^String v))
(defn- ^Message$RecipientType resolve-recipient-type
(defn- resolve-recipient-type
^Message$RecipientType
[type]
(case type
:to Message$RecipientType/TO
@ -157,7 +158,8 @@
(.setDebug session debug)
session))
(defn ^MimeMessage smtp-message
(defn smtp-message
^MimeMessage
[cfg message]
(let [^Session session (smtp-session cfg)]
(build-message cfg session message)))

11
backend/src/app/util/services.clj
View file

@ -40,9 +40,14 @@
(comp
(d/domap require)
(map find-ns)
(mapcat ns-publics)
(map second)
(filter #(::spec (meta %)))))
(mapcat (fn [ns]
(->> (ns-publics ns)
(map second)
(filter #(::spec (meta %)))
(map (fn [fvar]
(with-meta (deref fvar)
(-> (meta fvar)
(assoc :ns (-> ns ns-name str)))))))))))
(defn scan-ns
[& nsyms]

210
backend/src/app/util/websocket.clj
View file

@ -10,9 +10,10 @@
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.transit :as t]
[app.metrics :as mtx]
[app.loggers.audit :refer [parse-client-ip]]
[app.util.time :as dt]
[clojure.core.async :as a]
[yetti.request :as yr]
[yetti.util :as yu]
[yetti.websocket :as yws])
(:import
@ -25,8 +26,10 @@
(declare process-output)
(declare ws-ping!)
(declare ws-send!)
(declare filter-options)
(def noop (constantly nil))
(def identity-3 (fn [_ _ o] o))
(defn handler
"A WebSocket upgrade handler factory. Returns a handler that can be
@ -39,94 +42,123 @@
It also accepts some options that allows you parametrize the
protocol behavior. The options map will be used as-as for the
initial data of the `ws` data structure"
([handle-message] (handler handle-message {}))
([handle-message {:keys [::input-buff-size
::output-buff-size
::idle-timeout
metrics]
:or {input-buff-size 64
output-buff-size 64
idle-timeout 30000}
:as options}]
(fn [{:keys [::yws/channel] :as request}]
(let [input-ch (a/chan input-buff-size)
output-ch (a/chan output-buff-size)
pong-ch (a/chan (a/sliding-buffer 6))
close-ch (a/chan)
[& {:keys [::on-rcv-message
::on-snd-message
::on-connect
::input-buff-size
::output-buff-size
::handler
::idle-timeout]
:or {input-buff-size 64
output-buff-size 64
idle-timeout 30000
on-connect noop
on-snd-message identity-3
on-rcv-message identity-3}
:as options}]
options (atom
(-> options
(assoc ::input-ch input-ch)
(assoc ::output-ch output-ch)
(assoc ::close-ch close-ch)
(assoc ::channel channel)
(dissoc ::metrics)))
(assert (fn? on-rcv-message) "'on-rcv-message' should be a function")
(assert (fn? on-snd-message) "'on-snd-message' should be a function")
(assert (fn? on-connect) "'on-connect' should be a function")
terminated (atom false)
created-at (dt/now)
(fn [{:keys [::yws/channel session-id] :as request}]
(let [input-ch (a/chan input-buff-size)
output-ch (a/chan output-buff-size)
pong-ch (a/chan (a/sliding-buffer 6))
close-ch (a/chan)
stop-ch (a/chan)
on-open
(fn [channel]
(mtx/run! metrics {:id :websocket-active-connections :inc 1})
(yws/idle-timeout! channel (dt/duration idle-timeout)))
ip-addr (parse-client-ip request)
uagent (yr/get-header request "user-agent")
id (inst-ms (dt/now))
on-terminate
(fn [& _args]
(when (compare-and-set! terminated false true)
(mtx/run! metrics {:id :websocket-active-connections :dec 1})
(mtx/run! metrics {:id :websocket-session-timing :val (/ (inst-ms (dt/diff created-at (dt/now))) 1000.0)})
options (-> (filter-options options)
(merge {::id id
::input-ch input-ch
::output-ch output-ch
::close-ch close-ch
::stop-ch stop-ch
::channel channel
::remote-addr ip-addr
::http-session-id session-id
::user-agent uagent})
(atom))
(a/close! close-ch)
(a/close! pong-ch)
(a/close! output-ch)
(a/close! input-ch)))
;; call the on-connect hook and memoize the on-terminate instance
on-terminate (on-connect options)
on-error
(fn [_ error]
(on-terminate)
;; TODO: properly log timeout exceptions
(when-not (or (instance? java.nio.channels.ClosedChannelException error)
(instance? java.net.SocketException error))
(l/error :hint (ex-message error) :cause error)))
on-ws-open
(fn [channel]
(l/trace :fn "on-ws-open" :conn-id id)
(yws/idle-timeout! channel (dt/duration idle-timeout)))
on-message
(fn [_ message]
(mtx/run! metrics {:id :websocket-messages-total :labels ["recv"] :inc 1})
(try
(let [message (t/decode-str message)]
(a/offer! input-ch message))
(catch Throwable e
(l/warn :hint "error on decoding incoming message from websocket"
:wsmsg (pr-str message)
:cause e)
(on-terminate))))
on-ws-terminate
(fn [_ code reason]
(l/trace :fn "on-ws-terminate" :conn-id id :code code :reason reason)
(a/close! close-ch))
on-pong
(fn [_ buffers]
(a/>!! pong-ch (yu/copy-many buffers)))]
on-ws-error
(fn [_ error]
(a/close! close-ch)
(when-not (or (instance? java.nio.channels.ClosedChannelException error)
(instance? java.net.SocketException error))
(l/error :hint (ex-message error) :cause error)))
;; launch heartbeat process
(-> @options
(assoc ::pong-ch pong-ch)
(assoc ::on-close on-terminate)
(process-heartbeat))
on-ws-message
(fn [_ message]
(try
(let [message (on-rcv-message options message)
message (t/decode-str message)]
(a/offer! input-ch message)
(swap! options assoc ::last-activity-at (dt/now)))
(catch Throwable e
(l/warn :hint "error on decoding incoming message from websocket"
:wsmsg (pr-str message)
:cause e)
(a/>! close-ch [8801 "decode error"])
(a/close! close-ch))))
;; Forward all messages from output-ch to the websocket
;; connection
(a/go-loop []
(when-let [val (a/<! output-ch)]
(mtx/run! metrics {:id :websocket-messages-total :labels ["send"] :inc 1})
(a/<! (ws-send! channel (t/encode-str val)))
(recur)))
on-ws-pong
(fn [_ buffers]
(a/>!! pong-ch (yu/copy-many buffers)))]
;; React on messages received from the client
(process-input options handle-message)
;; Launch heartbeat process
(-> @options
(assoc ::pong-ch pong-ch)
(process-heartbeat))
{:on-open on-open
:on-error on-error
:on-close on-terminate
:on-text on-message
:on-pong on-pong}))))
;; Wait a close signal
(a/go
(let [[code reason] (a/<! close-ch)]
(a/close! stop-ch)
(a/close! pong-ch)
(a/close! output-ch)
(a/close! input-ch)
(when (and code reason)
(l/trace :hint "close channel condition" :code code :reason reason)
(yws/close! channel code reason))
(when (fn? on-terminate)
(on-terminate))))
;; Forward all messages from output-ch to the websocket
;; connection
(a/go-loop []
(when-let [val (a/<! output-ch)]
(let [val (on-snd-message options val)]
(a/<! (ws-send! channel (t/encode-str val)))
(recur))))
;; React on messages received from the client
(process-input options handler)
{:on-open on-ws-open
:on-error on-ws-error
:on-close on-ws-terminate
:on-text on-ws-message
:on-pong on-ws-pong})))
(defn- ws-send!
[channel s]
@ -172,14 +204,14 @@
(defn- process-input
[wsp handler]
(let [{:keys [::input-ch ::output-ch ::close-ch]} @wsp
(let [{:keys [::input-ch ::output-ch ::stop-ch]} @wsp
handler (wrap-handler handler)]
(a/go
(a/<! (handler wsp {:type :connect}))
(a/<! (a/go-loop []
(when-let [message (a/<! input-ch)]
(let [[val port] (a/alts! [(handler wsp message) close-ch])]
(when-not (= port close-ch)
(let [[val port] (a/alts! [stop-ch (handler wsp message)] :priority true)]
(when-not (= port stop-ch)
(cond
(ex/ex-info? val)
(a/>! output-ch {:type :error :error (ex-data val)})
@ -193,19 +225,21 @@
(a/<! (handler wsp {:type :disconnect})))))
(defn- process-heartbeat
[{:keys [::channel ::close-ch ::on-close ::pong-ch
[{:keys [::channel ::stop-ch ::close-ch ::pong-ch
::heartbeat-interval ::max-missed-heartbeats]
:or {heartbeat-interval 2000
max-missed-heartbeats 4}}]
(let [beats (atom #{})]
(a/go-loop [i 0]
(let [[_ port] (a/alts! [close-ch (a/timeout heartbeat-interval)])]
(let [[_ port] (a/alts! [stop-ch (a/timeout heartbeat-interval)] :priority true)]
(when (and (yws/connected? channel)
(not= port close-ch))
(not= port stop-ch))
(a/<! (ws-ping! channel (encode-beat i)))
(let [issued (swap! beats conj (long i))]
(if (>= (count issued) max-missed-heartbeats)
(on-close channel -1 "heartbeat-timeout")
(do
(a/>! close-ch [8802 "heart-beat timeout"])
(a/close! close-ch))
(recur (inc i)))))))
(a/go-loop []
@ -213,3 +247,11 @@
(swap! beats disj (decode-beat buffer))
(recur)))))
(defn- filter-options
"Remove from options all namespace qualified keys that matches the
current namespace."
[options]
(into {}
(remove (fn [[key]]
(= (namespace key) "app.util.websocket")))
options))

30
backend/src/app/worker.clj
View file

@ -203,8 +203,7 @@
(instance? Exception val)
(do
(l/warn :cause val
:hint "unexpected error ocurried on polling the database (will resume in some instants)")
(l/warn :hint "unexpected error ocurried on polling the database (will resume in some instants)" :cause val)
(a/<! (a/timeout poll-ms))
(recur))
@ -377,7 +376,7 @@
[{:keys [tasks]} item]
(let [name (d/name (:name item))]
(try
(l/debug :action "execute task"
(l/trace :action "execute task"
:id (:id item)
:name name
:retry (:retry-num item))
@ -425,7 +424,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare schedule-cron-task)
(declare synchronize-cron-entries)
(declare synchronize-cron-entries!)
(s/def ::fn (s/or :var var? :fn fn?))
(s/def ::id keyword?)
@ -466,8 +465,8 @@
cfg (assoc cfg :entries entries :running running)]
(l/info :hint "cron started" :registred-tasks (count entries))
(synchronize-cron-entries cfg)
(l/info :hint "cron initialized" :tasks (count entries))
(synchronize-cron-entries! cfg)
(->> (filter some? entries)
(run! (partial schedule-cron-task cfg)))
@ -494,16 +493,12 @@
on conflict (id)
do update set cron_expr=?")
(defn- synchronize-cron-item
[conn {:keys [id cron]}]
(let [cron (str cron)]
(l/debug :action "initialize scheduled task" :id id :cron cron)
(db/exec-one! conn [sql:upsert-cron-task id cron cron])))
(defn- synchronize-cron-entries
[{:keys [pool schedule]}]
(defn- synchronize-cron-entries!
[{:keys [pool entries]}]
(db/with-atomic [conn pool]
(run! (partial synchronize-cron-item conn) schedule)))
(doseq [{:keys [id cron]} entries]
(l/trace :hint "register cron task" :id id :cron (str cron))
(db/exec-one! conn [sql:upsert-cron-task id (str cron) (str cron)]))))
(def sql:lock-cron-task
"select id from scheduled_task where id=? for update skip locked")
@ -512,7 +507,7 @@
[{:keys [executor pool] :as cfg} {:keys [id] :as task}]
(letfn [(run-task [conn]
(when (db/exec-one! conn [sql:lock-cron-task (d/name id)])
(l/debug :action "execute scheduled task" :id id)
(l/trace :hint "execute cron task" :id id)
((:fn task) task)))
(handle-task []
@ -567,9 +562,10 @@
(defmethod ig/init-key ::registry
[_ {:keys [metrics tasks]}]
(l/info :hint "registry initialized" :tasks (count tasks))
(reduce-kv (fn [res k v]
(let [tname (name k)]
(l/debug :hint "register task" :name tname)
(l/trace :hint "register task" :name tname)
(assoc res k (wrap-task-handler metrics tname v))))
{}
tasks))

7
backend/test/app/services_fonts_test.clj
View file

@ -11,6 +11,7 @@
[app.http :as http]
[app.storage :as sto]
[app.test-helpers :as th]
[app.util.bytes :as bs]
[clojure.java.io :as io]
[clojure.test :as t]
[datoteka.core :as fs]))
@ -25,7 +26,8 @@
font-id (uuid/custom 10 1)
ttfdata (-> (io/resource "app/test_files/font-1.ttf")
(fs/slurp-bytes))
io/input-stream
bs/read-as-bytes)
params {::th/type :create-font-variant
:profile-id (:id prof)
@ -60,7 +62,8 @@
font-id (uuid/custom 10 1)
data (-> (io/resource "app/test_files/font-1.woff")
(fs/slurp-bytes))
io/input-stream
bs/read-as-bytes)
params {::th/type :create-font-variant
:profile-id (:id prof)

8
backend/test/app/services_media_test.clj
View file

@ -46,7 +46,13 @@
(t/is (sto/storage-object? mobj1))
(t/is (sto/storage-object? mobj2))
(t/is (= 122785 (:size mobj1)))
(t/is (= 3303 (:size mobj2)))))
;; This is because in ubuntu 21.04 generates different
;; thumbnail that in ubuntu 22.04. This hack should be removed
;; when we all use the ubuntu 22.04 devenv image.
(t/is (or
(= 3302 (:size mobj2))
(= 3303 (:size mobj2))))))
))
(t/deftest media-object-upload

24
backend/test/app/services_profile_test.clj
View file

@ -10,6 +10,7 @@
[app.config :as cf]
[app.db :as db]
[app.rpc.mutations.profile :as profile]
[app.rpc.commands.auth :as cauth]
[app.test-helpers :as th]
[app.util.time :as dt]
[clojure.java.io :as io]
@ -27,11 +28,10 @@
;; Test with wrong credentials
(t/deftest profile-login-failed-1
(let [profile (th/create-profile* 1)
data {::th/type :login
data {::th/type :login-with-password
:email "profile1.test@nodomain.com"
:password "foobar"
:scope "foobar"}
out (th/mutation! data)]
:password "foobar"}
out (th/command! data)]
#_(th/print-result! out)
(let [error (:error out)]
@ -42,11 +42,10 @@
;; Test with good credentials but profile not activated.
(t/deftest profile-login-failed-2
(let [profile (th/create-profile* 1)
data {::th/type :login
data {::th/type :login-with-password
:email "profile1.test@nodomain.com"
:password "123123"
:scope "foobar"}
out (th/mutation! data)]
:password "123123"}
out (th/command! data)]
;; (th/print-result! out)
(let [error (:error out)]
(t/is (th/ex-info? error))
@ -58,8 +57,7 @@
(let [profile (th/create-profile* 1 {:is-active true})
data {::th/type :login
:email "profile1.test@nodomain.com"
:password "123123"
:scope "foobar"}
:password "123123"}
out (th/mutation! data)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
@ -161,11 +159,11 @@
(t/deftest registration-domain-whitelist
(let [whitelist #{"gmail.com" "hey.com" "ya.ru"}]
(t/testing "allowed email domain"
(t/is (true? (profile/email-domain-in-whitelist? whitelist "username@ya.ru")))
(t/is (true? (profile/email-domain-in-whitelist? #{} "username@somedomain.com"))))
(t/is (true? (cauth/email-domain-in-whitelist? whitelist "username@ya.ru")))
(t/is (true? (cauth/email-domain-in-whitelist? #{} "username@somedomain.com"))))
(t/testing "not allowed email domain"
(t/is (false? (profile/email-domain-in-whitelist? whitelist "username@somedomain.com"))))))
(t/is (false? (cauth/email-domain-in-whitelist? whitelist "username@somedomain.com"))))))
(t/deftest prepare-register-and-register-profile
(let [data {::th/type :prepare-register-profile

3
backend/test/app/services_viewer_test.clj
View file

@ -49,7 +49,8 @@
:profile-id (:id prof)
:file-id (:id file)
:pages #{(get-in file [:data :pages 0])}
:flags #{}}
:who-comment "team"
:who-inspect "all"}
out (th/mutation! data)]
;; (th/print-result! out)

10
backend/test/app/storage_test.clj
View file

@ -12,6 +12,7 @@
[app.storage :as sto]
[app.test-helpers :as th]
[app.util.time :as dt]
[app.util.bytes :as bs]
[clojure.java.io :as io]
[clojure.test :as t]
[cuerdas.core :as str]
@ -27,11 +28,11 @@
"Given storage map, returns a storage configured with the appropriate
backend for assets."
([storage]
(assoc storage :backend :tmp))
(assoc storage :backend :assets-fs))
([storage conn]
(-> storage
(assoc :conn conn)
(assoc :backend :tmp))))
(assoc :backend :assets-fs))))
(t/deftest put-and-retrieve-object
(let [storage (-> (:app.storage/storage th/*system*)
@ -43,7 +44,7 @@
(t/is (sto/storage-object? object))
(t/is (fs/path? @(sto/get-object-path storage object)))
(t/is (nil? (:expired-at object)))
(t/is (= :tmp (:backend object)))
(t/is (= :assets-fs (:backend object)))
(t/is (= "data" (:other (meta object))))
(t/is (= "text/plain" (:content-type (meta object))))
(t/is (= "content" (slurp @(sto/get-object-data storage object))))
@ -197,7 +198,8 @@
:is-shared false})
ttfdata (-> (io/resource "app/test_files/font-1.ttf")
(fs/slurp-bytes))
io/input-stream
bs/read-as-bytes)
mfile {:filename "sample.jpg"
:path (th/tempfile "app/test_files/sample.jpg")

41
backend/test/app/test_helpers.clj
View file

@ -9,14 +9,15 @@
[app.common.data :as d]
[app.common.flags :as flags]
[app.common.pages :as cp]
[app.common.pprint :as pp]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.common.pprint :as pp]
[app.config :as cf]
[app.db :as db]
[app.main :as main]
[app.media]
[app.migrations]
[app.rpc.commands.auth :as cmd.auth]
[app.rpc.mutations.files :as files]
[app.rpc.mutations.profile :as profile]
[app.rpc.mutations.projects :as projects]
@ -31,8 +32,8 @@
[expound.alpha :as expound]
[integrant.core :as ig]
[mockery.core :as mk]
[yetti.request :as yrq]
[promesa.core :as p])
[promesa.core :as p]
[yetti.request :as yrq])
(:import org.postgresql.ds.PGSimpleDataSource))
(def ^:dynamic *system* nil)
@ -59,10 +60,12 @@
:app.http/router
:app.http.awsns/handler
:app.http.session/updater
:app.http.oauth/google
:app.http.oauth/gitlab
:app.http.oauth/github
:app.http.oauth/all
:app.auth.oidc/google-provider
:app.auth.oidc/gitlab-provider
:app.auth.oidc/github-provider
:app.auth.oidc/generic-provider
:app.auth.oidc/routes
;; :app.auth.ldap/provider
:app.worker/executors-monitor
:app.http.oauth/handler
:app.notifications/handler
@ -81,9 +84,9 @@
(try
(binding [*system* system
*pool* (:app.db/pool system)]
(mk/with-mocks [mock1 {:target 'app.rpc.mutations.profile/derive-password
(mk/with-mocks [mock1 {:target 'app.rpc.commands.auth/derive-password
:return identity}
mock2 {:target 'app.rpc.mutations.profile/verify-password
mock2 {:target 'app.rpc.commands.auth/verify-password
:return (fn [a b] {:valid (= a b)})}]
(next)))
(finally
@ -140,8 +143,8 @@
:is-demo false}
params)]
(->> params
(#'profile/create-profile conn)
(#'profile/create-profile-relations conn)))))
(cmd.auth/create-profile conn)
(cmd.auth/create-profile-relations conn)))))
(defn create-project*
([i params] (create-project* *pool* i params))
@ -267,17 +270,21 @@
{:error (handle-error e#)
:result nil})))
(defn command!
[{:keys [::type] :as data}]
(let [method-fn (get-in *system* [:app.rpc/methods :commands type])]
;; (app.common.pprint/pprint (:app.rpc/methods *system*))
(try-on! (method-fn (dissoc data ::type)))))
(defn mutation!
[{:keys [::type] :as data}]
(let [method-fn (get-in *system* [:app.rpc/rpc :methods :mutation type])]
(try-on!
(method-fn (dissoc data ::type)))))
(let [method-fn (get-in *system* [:app.rpc/methods :mutations type])]
(try-on! (method-fn (dissoc data ::type)))))
(defn query!
[{:keys [::type] :as data}]
(let [method-fn (get-in *system* [:app.rpc/rpc :methods :query type])]
(try-on!
(method-fn (dissoc data ::type)))))
(let [method-fn (get-in *system* [:app.rpc/methods :queries type])]
(try-on! (method-fn (dissoc data ::type)))))
;; --- UTILS

14
common/deps.edn
View file

@ -1,9 +1,9 @@
{:deps
{org.clojure/clojure {:mvn/version "1.10.3"}
{org.clojure/clojure {:mvn/version "1.11.1"}
org.clojure/data.json {:mvn/version "2.4.0"}
org.clojure/tools.cli {:mvn/version "1.0.206"}
metosin/jsonista {:mvn/version "0.3.5"}
org.clojure/clojurescript {:mvn/version "1.11.4"}
metosin/jsonista {:mvn/version "0.3.6"}
org.clojure/clojurescript {:mvn/version "1.11.57"}
;; Logging
org.apache.logging.log4j/log4j-api {:mvn/version "2.17.2"}
@ -13,7 +13,7 @@
org.apache.logging.log4j/log4j-slf4j18-impl {:mvn/version "2.17.2"}
org.slf4j/slf4j-api {:mvn/version "2.0.0-alpha1"}
selmer/selmer {:mvn/version "1.12.50"}
selmer/selmer {:mvn/version "1.12.51"}
criterium/criterium {:mvn/version "0.4.6"}
expound/expound {:mvn/version "0.9.0"}
@ -22,7 +22,7 @@
java-http-clj/java-http-clj {:mvn/version "0.4.3"}
funcool/promesa {:mvn/version "8.0.450"}
funcool/cuerdas {:mvn/version "2022.03.27-397"}
funcool/cuerdas {:mvn/version "2022.06.16-403"}
lambdaisland/uri {:mvn/version "1.13.95"
:exclusions [org.clojure/data.json]}
@ -33,7 +33,7 @@
com.sun.mail/jakarta.mail {:mvn/version "2.0.1"}
;; exception printing
fipp/fipp {:mvn/version "0.6.25"}
fipp/fipp {:mvn/version "0.6.26"}
io.aviso/pretty {:mvn/version "1.1.1"}
environ/environ {:mvn/version "1.2.0"}}
:paths ["src"]
@ -42,7 +42,7 @@
{:extra-deps
{org.clojure/tools.namespace {:mvn/version "RELEASE"}
org.clojure/test.check {:mvn/version "RELEASE"}
thheller/shadow-cljs {:mvn/version "2.17.8"}
thheller/shadow-cljs {:mvn/version "2.19.5"}
com.bhauman/rebel-readline {:mvn/version "RELEASE"}
criterium/criterium {:mvn/version "RELEASE"}
mockery/mockery {:mvn/version "RELEASE"}}

2
common/package.json
View file

@ -13,7 +13,7 @@
"test": "yarn run compile-test && yarn run run-test"
},
"devDependencies": {
"shadow-cljs": "2.17.8",
"shadow-cljs": "2.19.5",
"source-map-support": "^0.5.19",
"ws": "^7.4.6"
}

3
common/src/app/common/data.cljc
View file

@ -23,6 +23,9 @@
#?(:clj
(:import linked.set.LinkedSet)))
(def boolean-or-nil?
(some-fn nil? boolean?))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Data Structures
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

6
common/src/app/common/exceptions.cljc
View file

@ -50,6 +50,12 @@
[& exprs]
`(try* (^:once fn* [] ~@exprs) identity))
(defn with-always
"A helper that evaluates an exptession independently if the body
raises exception or not."
[always-expr & body]
`(try ~@body (finally ~always-expr)))
(defn ex-info?
[v]
(instance? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core.ExceptionInfo) v))

16
common/src/app/common/file_builder.cljc
View file

@ -11,9 +11,9 @@
[app.common.geom.matrix :as gmt]
[app.common.geom.shapes :as gsh]
[app.common.pages.changes :as ch]
[app.common.pages.changes-spec :as pcs]
[app.common.pages.init :as init]
[app.common.spec :as us]
[app.common.spec.change :as spec.change]
[app.common.uuid :as uuid]
[cuerdas.core :as str]))
@ -44,9 +44,9 @@
:frame-id (:current-frame-id file)))]
(when fail-on-spec?
(us/verify ::spec.change/change change))
(us/verify ::pcs/change change))
(let [valid? (us/valid? ::spec.change/change change)]
(let [valid? (us/valid? ::pcs/change change)]
#?(:cljs
(when-not valid? (.warn js/console "Invalid shape" (clj->js change))))
@ -222,9 +222,13 @@
(defn close-artboard [file]
(assert (nil? (:current-component-id file)))
(-> file
(assoc :current-frame-id root-frame)
(update :parent-stack pop)))
(let [parent-id (-> file :parent-id peek)
parent (lookup-shape file parent-id)
current-frame-id (or (:frame-id parent) root-frame)]
(-> file
(assoc :current-frame-id current-frame-id)
(update :parent-stack pop))))
(defn add-group [file data]
(let [frame-id (:current-frame-id file)

9
common/src/app/common/geom/shapes.cljc
View file

@ -98,13 +98,6 @@
(defn distance-shapes [shape other]
(distance-selrect (:selrect shape) (:selrect other)))
(defn shape-stroke-margin
[shape stroke-width]
(if (= (:type shape) :path)
;; TODO: Calculate with the stroke offset (not implemented yet
(mth/sqrt (* 2 stroke-width stroke-width))
(- (mth/sqrt (* 2 stroke-width stroke-width)) stroke-width)))
(defn close-attrs?
"Compares two shapes attributes to see if they are equal or almost
equal (in case of numeric). Takes into account attributes that are
@ -159,6 +152,7 @@
(dm/export gtr/move)
(dm/export gtr/absolute-move)
(dm/export gtr/transform-matrix)
(dm/export gtr/transform-str)
(dm/export gtr/inverse-transform-matrix)
(dm/export gtr/transform-point-center)
(dm/export gtr/transform-rect)
@ -171,6 +165,7 @@
(dm/export gtr/merge-modifiers)
(dm/export gtr/transform-shape)
(dm/export gtr/transform-selrect)
(dm/export gtr/transform-selrect-matrix)
(dm/export gtr/transform-bounds)
(dm/export gtr/modifiers->transform)
(dm/export gtr/empty-modifiers?)

157
common/src/app/common/geom/shapes/bounds.cljc Normal file
View file

@ -0,0 +1,157 @@
;; 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) UXBOX Labs SL
(ns app.common.geom.shapes.bounds
(:require
[app.common.data :as d]
[app.common.geom.shapes.rect :as gsr]
[app.common.math :as mth]
[app.common.pages.helpers :as cph]))
(defn shape-stroke-margin
[shape stroke-width]
(if (= (:type shape) :path)
;; TODO: Calculate with the stroke offset (not implemented yet
(mth/sqrt (* 2 stroke-width stroke-width))
(- (mth/sqrt (* 2 stroke-width stroke-width)) stroke-width)))
(defn blur-filters [type value]
(->> [value]
(remove :hidden)
(filter #(= (:type %) type))
(map #(hash-map :id (str "filter_" (:id %))
:type (:type %)
:params %))))
(defn shadow-filters [type filters]
(->> filters
(remove :hidden)
(filter #(= (:style %) type))
(map #(hash-map :id (str "filter_" (:id %))
:type (:style %)
:params %))))
(defn shape->filters
[shape]
(d/concat-vec
[{:id "BackgroundImageFix" :type :image-fix}]
;; Background blur won't work in current SVG specification
;; We can revisit this in the future
#_(->> shape :blur (blur-filters :background-blur))
(->> shape :shadow (shadow-filters :drop-shadow))
[{:id "shape" :type :blend-filters}]
(->> shape :shadow (shadow-filters :inner-shadow))
(->> shape :blur (blur-filters :layer-blur))))
(defn calculate-filter-bounds [{:keys [x y width height]} filter-entry]
(let [{:keys [offset-x offset-y blur spread] :or {offset-x 0 offset-y 0 blur 0 spread 0}} (:params filter-entry)
filter-x (min x (+ x offset-x (- spread) (- blur) -5))
filter-y (min y (+ y offset-y (- spread) (- blur) -5))
filter-width (+ width (mth/abs offset-x) (* spread 2) (* blur 2) 10)
filter-height (+ height (mth/abs offset-y) (* spread 2) (* blur 2) 10)]
(gsr/make-selrect filter-x filter-y filter-width filter-height)))
(defn get-rect-filter-bounds
[selrect filters blur-value]
(let [filter-bounds (->> filters
(filter #(= :drop-shadow (:type %)))
(map (partial calculate-filter-bounds selrect))
(concat [selrect])
(gsr/join-selrects))
delta-blur (* blur-value 2)
result
(-> filter-bounds
(update :x - delta-blur)
(update :y - delta-blur)
(update :x1 - delta-blur)
(update :x1 - delta-blur)
(update :x2 + delta-blur)
(update :y2 + delta-blur)
(update :width + (* delta-blur 2))
(update :height + (* delta-blur 2)))]
result))
(defn get-shape-filter-bounds
([shape]
(let [svg-root? (and (= :svg-raw (:type shape)) (not= :svg (get-in shape [:content :tag])))]
(if svg-root?
(:selrect shape)
(let [filters (shape->filters shape)
blur-value (or (-> shape :blur :value) 0)]
(get-rect-filter-bounds (-> shape :points gsr/points->selrect) filters blur-value))))))
(defn calculate-padding
([shape]
(calculate-padding shape false))
([shape ignore-margin?]
(let [stroke-width (apply max 0 (map #(case (:stroke-alignment % :center)
:center (/ (:stroke-width % 0) 2)
:outer (:stroke-width % 0)
0) (:strokes shape)))
margin (if ignore-margin?
0
(apply max 0 (map #(shape-stroke-margin % stroke-width) (:strokes shape))))
shadow-width (apply max 0 (map #(case (:style % :drop-shadow)
:drop-shadow (+ (mth/abs (:offset-x %)) (* (:spread %) 2) (* (:blur %) 2) 10)
0) (:shadow shape)))
shadow-height (apply max 0 (map #(case (:style % :drop-shadow)
:drop-shadow (+ (mth/abs (:offset-y %)) (* (:spread %) 2) (* (:blur %) 2) 10)
0) (:shadow shape)))]
{:horizontal (+ stroke-width margin shadow-width)
:vertical (+ stroke-width margin shadow-height)})))
(defn- add-padding
[bounds padding]
(-> bounds
(update :x - (:horizontal padding))
(update :y - (:vertical padding))
(update :width + (* 2 (:horizontal padding)))
(update :height + (* 2 (:vertical padding)))))
(defn get-object-bounds
[objects shape]
(let [calculate-base-bounds
(fn [shape]
(-> (get-shape-filter-bounds shape)
(add-padding (calculate-padding shape true))))
bounds
(cph/reduce-objects
objects
(fn [shape]
(and (d/not-empty? (:shapes shape))
(or (not (cph/frame-shape? shape))
(:show-content shape))
(or (not (cph/group-shape? shape))
(not (:masked-group? shape)))))
(:id shape)
(fn [result shape]
(conj result (get-object-bounds objects shape)))
[(calculate-base-bounds shape)])
children-bounds (or (:children-bounds shape) (gsr/join-selrects bounds))
filters (shape->filters shape)
blur-value (or (-> shape :blur :value) 0)]
(get-rect-filter-bounds children-bounds filters blur-value)))

26
common/src/app/common/geom/shapes/transforms.cljc
View file

@ -7,6 +7,7 @@
(ns app.common.geom.shapes.transforms
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.common :as gco]
@ -143,16 +144,30 @@
([shape params]
(transform-matrix shape params (or (gco/center-shape shape) (gpt/point 0 0))))
([{:keys [flip-x flip-y] :as shape} {:keys [no-flip]} shape-center]
([{:keys [flip-x flip-y transform] :as shape} {:keys [no-flip]} shape-center]
(-> (gmt/matrix)
(gmt/translate shape-center)
(gmt/multiply (:transform shape (gmt/matrix)))
(cond-> (some? transform)
(gmt/multiply transform))
(cond->
(and (not no-flip) flip-x) (gmt/scale (gpt/point -1 1))
(and (not no-flip) flip-y) (gmt/scale (gpt/point 1 -1)))
(gmt/translate (gpt/negate shape-center)))))
(defn transform-str
([shape]
(transform-str shape nil))
([{:keys [transform flip-x flip-y] :as shape} {:keys [no-flip]}]
(if (and (some? shape)
(or (some? transform)
(and (not no-flip) flip-x)
(and (not no-flip) flip-y)))
(dm/str (transform-matrix shape))
"")))
(defn inverse-transform-matrix
([shape]
(let [shape-center (or (gco/center-shape shape)
@ -632,6 +647,13 @@
(transform-bounds center modifiers)
(gpr/points->selrect))))
(defn transform-selrect-matrix
[selrect mtx]
(-> selrect
(gpr/rect->points)
(gco/transform-points mtx)
(gpr/points->selrect)))
(defn selection-rect
"Returns a rect that contains all the shapes and is aware of the
rotation of each shape. Mainly used for multiple selection."

4
common/src/app/common/pages.cljc
View file

@ -26,8 +26,8 @@
(dm/export focus/is-in-focus?)
;; Indices
(dm/export indices/calculate-z-index)
(dm/export indices/update-z-index)
#_(dm/export indices/calculate-z-index)
#_(dm/export indices/update-z-index)
(dm/export indices/generate-child-all-parents-index)
(dm/export indices/generate-child-parent-index)
(dm/export indices/create-clip-index)

10
common/src/app/common/pages/changes.cljc
View file

@ -16,8 +16,8 @@
[app.common.pages.helpers :as cph]
[app.common.pages.init :as init]
[app.common.spec :as us]
[app.common.spec.change :as spec.change]
[app.common.spec.shape :as spec.shape]))
[app.common.pages.changes-spec :as pcs]
[app.common.types.shape :as cts]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Specific helpers
@ -49,7 +49,7 @@
;; When verify? false we spec the schema validation. Currently used to make just
;; 1 validation even if the changes are applied twice
(when verify?
(us/assert ::spec.change/changes items))
(us/assert ::pcs/changes items))
(let [result (reduce #(or (process-change %1 %2) %1) data items)]
;; Validate result shapes (only on the backend)
@ -59,7 +59,7 @@
(doseq [[id shape] (:objects page)]
(when-not (= shape (get-in data [:pages-index page-id :objects id]))
;; If object has change verify is correct
(us/verify ::spec.shape/shape shape))))))
(us/verify ::cts/shape shape))))))
result)))
@ -211,7 +211,7 @@
(let [invalid-targets (calculate-invalid-targets objects shape-id)]
(and (contains? objects shape-id)
(not (invalid-targets parent-id))
(cph/valid-frame-target? objects parent-id shape-id))))
#_(cph/valid-frame-target? objects parent-id shape-id))))
(insert-items [prev-shapes index shapes]
(let [prev-shapes (or prev-shapes [])]

36
common/src/app/common/spec/change.cljc → common/src/app/common/pages/changes_spec.cljc
View file

@ -4,14 +4,14 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.common.spec.change
(ns app.common.pages.changes-spec
(:require
[app.common.spec :as us]
[app.common.spec.color :as color]
[app.common.spec.file :as file]
[app.common.spec.page :as page]
[app.common.spec.shape :as shape]
[app.common.spec.typography :as typg]
[app.common.types.color :as ctc]
[app.common.types.file :as ctf]
[app.common.types.page :as ctp]
[app.common.types.shape :as cts]
[app.common.types.typography :as ctt]
[clojure.spec.alpha :as s]))
(s/def ::index integer?)
@ -52,7 +52,7 @@
(s/keys :req-un [:internal.changes.set-option/option
:internal.changes.set-option/value]))
(s/def :internal.changes.add-obj/obj ::shape/shape)
(s/def :internal.changes.add-obj/obj ::cts/shape)
(defn- valid-container-id-frame?
[o]
@ -89,18 +89,18 @@
valid-container-id?))
(defmethod change-spec :reg-objects [_]
(s/and (s/keys :req-un [::shape/shapes]
(s/and (s/keys :req-un [::cts/shapes]
:opt-un [::page-id ::component-id])
valid-container-id?))
(defmethod change-spec :mov-objects [_]
(s/and (s/keys :req-un [::parent-id ::shape/shapes]
(s/and (s/keys :req-un [::parent-id ::cts/shapes]
:opt-un [::page-id ::component-id ::index])
valid-container-id?))
(defmethod change-spec :add-page [_]
(s/or :empty (s/keys :req-un [::id ::name])
:complete (s/keys :req-un [::page/page])))
:complete (s/keys :req-un [::ctp/page])))
(defmethod change-spec :mod-page [_]
(s/keys :req-un [::id ::name]))
@ -112,21 +112,21 @@
(s/keys :req-un [::id ::index]))
(defmethod change-spec :add-color [_]
(s/keys :req-un [::color/color]))
(s/keys :req-un [::ctc/color]))
(defmethod change-spec :mod-color [_]
(s/keys :req-un [::color/color]))
(s/keys :req-un [::ctc/color]))
(defmethod change-spec :del-color [_]
(s/keys :req-un [::id]))
(s/def :internal.changes.add-recent-color/color ::color/recent-color)
(s/def :internal.changes.add-recent-color/color ::ctc/recent-color)
(defmethod change-spec :add-recent-color [_]
(s/keys :req-un [:internal.changes.add-recent-color/color]))
(s/def :internal.changes.add-media/object ::file/media-object)
(s/def :internal.changes.add-media/object ::ctf/media-object)
(defmethod change-spec :add-media [_]
(s/keys :req-un [:internal.changes.add-media/object]))
@ -149,7 +149,7 @@
(s/keys :req-un [::id]))
(s/def :internal.changes.add-component/shapes
(s/coll-of ::shape/shape))
(s/coll-of ::cts/shape))
(defmethod change-spec :add-component [_]
(s/keys :req-un [::id ::name :internal.changes.add-component/shapes]
@ -163,13 +163,13 @@
(s/keys :req-un [::id]))
(defmethod change-spec :add-typography [_]
(s/keys :req-un [::typg/typography]))
(s/keys :req-un [::ctt/typography]))
(defmethod change-spec :mod-typography [_]
(s/keys :req-un [::typg/typography]))
(s/keys :req-un [::ctt/typography]))
(defmethod change-spec :del-typography [_]
(s/keys :req-un [::typg/id]))
(s/keys :req-un [::ctt/id]))
(s/def ::change (s/multi-spec change-spec :type))
(s/def ::changes (s/coll-of ::change))

3
common/src/app/common/pages/common.cljc
View file

@ -80,8 +80,11 @@
:x :y
:rx :ry
:r1 :r2 :r3 :r4
:rotation
:selrect
:points
:show-content
:hide-in-viewer
:opacity
:blend-mode

16
common/src/app/common/pages/focus.cljc
View file

@ -8,26 +8,20 @@
(:require
[app.common.data :as d]
[app.common.pages.helpers :as cph]
[app.common.pages.indices :as cpi]
[app.common.uuid :as uuid]))
(defn focus-objects
[objects focus]
(let [[ids-with-children z-index]
(let [ids-with-children
(when (d/not-empty? focus)
[(into (conj focus uuid/zero)
(mapcat (partial cph/get-children-ids objects))
focus)
(cpi/calculate-z-index objects)])
sort-by-z-index
(fn [coll]
(->> coll (sort-by (fn [a b] (- (get z-index a) (get z-index b))))))]
(into (conj focus uuid/zero)
(mapcat (partial cph/get-children-ids objects))
focus))]
(cond-> objects
(some? ids-with-children)
(-> (select-keys ids-with-children)
(assoc-in [uuid/zero :shapes] (sort-by-z-index focus))))))
(assoc-in [uuid/zero :shapes] (cph/sort-z-index objects focus))))))
(defn filter-not-focus
[objects focus ids]

278
common/src/app/common/pages/helpers.cljc
View file

@ -9,23 +9,36 @@
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.geom.shapes :as gsh]
[app.common.math :as mth]
[app.common.spec :as us]
[app.common.spec.page :as spec.page]
[app.common.types.page :as ctp]
[app.common.uuid :as uuid]
[cuerdas.core :as str]))
(declare reduce-objects)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GENERIC SHAPE SELECTORS AND PREDICATES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn root-frame?
(defn root?
[{:keys [id type]}]
(and (= type :frame)
(= id uuid/zero)))
(and (= type :frame) (= id uuid/zero)))
(defn root-frame?
([objects id]
(root-frame? (get objects id)))
([{:keys [frame-id type]}]
(and (= type :frame)
(= frame-id uuid/zero))))
(defn frame-shape?
[{:keys [type]}]
(= type :frame))
([objects id]
(frame-shape? (get objects id)))
([{:keys [type]}]
(= type :frame)))
(defn group-shape?
[{:keys [type]}]
@ -39,6 +52,10 @@
[{:keys [type]}]
(= type :image))
(defn svg-raw-shape?
[{:keys [type]}]
(= type :svg-raw))
(defn unframed-shape?
"Checks if it's a non-frame shape in the top level."
[shape]
@ -47,7 +64,7 @@
(defn get-shape
[container shape-id]
(us/assert ::spec.page/container container)
(us/assert ::ctp/container container)
(us/assert ::us/uuid shape-id)
(-> container
(get :objects)
@ -93,9 +110,10 @@
"Returns a vector of parents of the specified shape."
[objects shape-id]
(loop [result [] id shape-id]
(if-let [parent-id (dm/get-in objects [id :parent-id])]
(recur (conj result parent-id) parent-id)
result)))
(let [parent-id (dm/get-in objects [id :parent-id])]
(if (and (some? parent-id) (not= parent-id id))
(recur (conj result parent-id) parent-id)
result))))
(defn get-frame
"Get the frame that contains the shape. If the shape is already a
@ -140,38 +158,146 @@
(:shapes)
(keep lookup)))))
(defn get-frames-ids
"Retrieves all frame objects as vector. It is not implemented in
function of `get-immediate-children` for performance reasons. This
function is executed in the render hot path."
[objects]
(let [lookup (d/getf objects)
xform (comp (keep lookup)
(filter frame-shape?)
(map :id))]
(->> (:shapes (lookup uuid/zero))
(into [] xform))))
(defn get-frames
"Retrieves all frame objects as vector"
[objects]
(if (contains? (meta objects) ::index-frames)
(::index-frames (meta objects))
(let [lookup (d/getf objects)
xform (comp (remove #(= uuid/zero %))
(keep lookup)
(filter frame-shape?))]
(->> (keys objects)
(into [] xform)))))
(defn get-frames-ids
"Retrieves all frame ids as vector"
[objects]
(->> (get-frames objects)
(mapv :id)))
(defn get-nested-frames
[objects frame-id]
(into #{}
(comp (filter frame-shape?)
(map :id))
(get-children objects frame-id)))
(defn get-root-frames-ids
"Retrieves all frame objects as vector. It is not implemented in
function of `get-immediate-children` for performance reasons. This
function is executed in the render hot path."
[objects]
(let [lookup (d/getf objects)
xform (comp (keep lookup)
(filter frame-shape?))]
(->> (:shapes (lookup uuid/zero))
(into [] xform))))
(let [add-frame
(fn [result shape]
(cond-> result
(frame-shape? shape)
(conj (:id shape))))]
(reduce-objects objects (complement frame-shape?) add-frame [])))
(defn get-root-objects
"Get all the objects under the root object"
[objects]
(let [add-shape
(fn [result shape]
(conj result shape))]
(reduce-objects objects (complement frame-shape?) add-shape [])))
(defn get-root-shapes
"Get all shapes that are not frames"
[objects]
(let [add-shape
(fn [result shape]
(cond-> result
(not (frame-shape? shape))
(conj shape)))]
(reduce-objects objects (complement frame-shape?) add-shape [])))
(defn get-root-shapes-ids
[objects]
(->> (get-root-shapes objects)
(mapv :id)))
(defn- get-base
[objects id-a id-b]
(let [parents-a (reverse (get-parents-seq objects id-a))
parents-b (reverse (get-parents-seq objects id-b))
[base base-child-a base-child-b]
(loop [parents-a (rest parents-a)
parents-b (rest parents-b)
base uuid/zero]
(cond
(not= (first parents-a) (first parents-b))
[base (first parents-a) (first parents-b)]
(or (empty? parents-a) (empty? parents-b))
[uuid/zero (first parents-a) (first parents-b)]
:else
(recur (rest parents-a) (rest parents-b) (first parents-a))))
index-base-a (when base-child-a (get-position-on-parent objects base-child-a))
index-base-b (when base-child-b (get-position-on-parent objects base-child-b))]
[base index-base-a index-base-b]))
(defn is-shape-over-shape?
[objects base-shape-id over-shape-id {:keys [top-frames?]}]
(let [[base index-a index-b] (get-base objects base-shape-id over-shape-id)]
(cond
(= base base-shape-id)
(and (not top-frames?)
(frame-shape? objects base-shape-id)
(root-frame? objects base-shape-id))
(= base over-shape-id)
(or top-frames?
(not (frame-shape? objects over-shape-id))
(not (root-frame? objects over-shape-id)))
:else
(< index-a index-b))))
(defn sort-z-index
([objects ids]
(sort-z-index objects ids nil))
([objects ids {:keys [bottom-frames?] :as options}]
(letfn [(comp [id-a id-b]
(let [type-a (dm/get-in objects [id-a :type])
type-b (dm/get-in objects [id-b :type])]
(cond
(and bottom-frames? (= :frame type-a) (not= :frame type-b))
1
(and bottom-frames? (not= :frame type-a) (= :frame type-b))
-1
(= id-a id-b)
0
(is-shape-over-shape? objects id-a id-b options)
1
:else
-1)))]
(sort comp ids))))
(defn frame-id-by-position
[objects position]
(let [frames (get-frames objects)]
(or
(->> frames
(reverse)
(d/seek #(and position (gsh/has-point? % position)))
:id)
uuid/zero)))
(let [top-frame
(->> (get-frames-ids objects)
(sort-z-index objects)
(d/seek #(and position (gsh/has-point? (get objects %) position))))]
(or top-frame uuid/zero)))
(defn frame-by-position
[objects position]
(let [frame-id (frame-id-by-position objects position)]
(get objects frame-id)))
(declare indexed-shapes)
@ -520,3 +646,87 @@
(-> (select-keys objects selected+parents)
(d/update-vals remove-children))))
(defn is-child?
[objects parent-id candidate-child-id]
(let [parents (get-parents-seq objects candidate-child-id)]
(some? (d/seek #(= % parent-id) parents))))
(defn reduce-objects
([objects reducer-fn init-val]
(reduce-objects objects nil reducer-fn init-val))
([objects check-children? reducer-fn init-val]
(reduce-objects objects check-children? uuid/zero reducer-fn init-val))
([objects check-children? root-id reducer-fn init-val]
(let [root-children (get-in objects [root-id :shapes])]
(if (empty? root-children)
init-val
(loop [current-val init-val
current-id (first root-children)
pending-ids (rest root-children)]
(let [current-shape (get objects current-id)
next-val (reducer-fn current-val current-shape)
next-pending-ids
(if (or (nil? check-children?) (check-children? current-shape))
(concat (or (:shapes current-shape) []) pending-ids)
pending-ids)]
(if (empty? next-pending-ids)
next-val
(recur next-val (first next-pending-ids) (rest next-pending-ids)))))))))
(defn selected-with-children
[objects selected]
(into selected
(mapcat #(get-children-ids objects %))
selected))
(defn get-shape-id-root-frame
[objects shape-id]
(->> (get-parents-seq objects shape-id)
(map (d/getf objects))
(d/seek #(and (= :frame (:type %))
(= uuid/zero (:frame-id %))))
:id))
(defn get-viewer-frames
([objects]
(get-viewer-frames objects nil))
([objects {:keys [all-frames?]}]
(into []
(comp (map (d/getf objects))
(if all-frames?
identity
(remove :hide-in-viewer)))
(sort-z-index objects (get-frames-ids objects) {:top-frames? true}))))
(defn start-page-index
[objects]
(with-meta objects {::index-frames (get-frames (with-meta objects nil))}))
(defn update-page-index
[objects]
(with-meta objects {::index-frames (get-frames (with-meta objects nil))}))
(defn start-object-indices
[file]
(letfn [(process-index [page-index page-id]
(update-in page-index [page-id :objects] start-page-index))]
(update file :pages-index #(reduce process-index % (keys %)))))
(defn update-object-indices
[file page-id]
(update-in file [:pages-index page-id :objects] update-page-index))
(defn rotated-frame?
[frame]
(not (mth/almost-zero? (:rotation frame 0))))

82
common/src/app/common/pages/indices.cljc
View file

@ -8,76 +8,7 @@
(:require
[app.common.data :as d]
[app.common.pages.helpers :as cph]
[app.common.uuid :as uuid]
[clojure.set :as set]))
(defn calculate-frame-z-index
[z-index frame-id base-idx objects]
(let [is-frame? (fn [id] (= :frame (get-in objects [id :type])))
children (or (get-in objects [frame-id :shapes]) [])]
(if (empty? children)
z-index
(loop [current (peek children)
pending (pop children)
current-idx base-idx
z-index z-index]
(let [children (get-in objects [current :shapes])
is-frame? (is-frame? current)
pending (if (not is-frame?)
(d/concat-vec pending children)
pending)]
(if (empty? pending)
(assoc z-index current current-idx)
(recur (peek pending)
(pop pending)
(dec current-idx)
(assoc z-index current current-idx))))))))
;; The z-index is really calculated per-frame. Every frame will have its own
;; internal z-index. To calculate the "final" z-index we add the shape z-index with
;; the z-index of its frame. This way we can update the z-index per frame without
;; the need of recalculate all the frames
(defn calculate-z-index
"Given a collection of shapes calculates their z-index. Greater index
means is displayed over other shapes with less index."
[objects]
(let [frames (cph/get-frames objects)
by-frame (cph/objects-by-frame objects)
frame-base-idx (d/update-vals by-frame count)
z-index (calculate-frame-z-index {} uuid/zero (get frame-base-idx uuid/zero) objects)]
(->> frames
(reduce
(fn [z-index {:keys [id]}]
(calculate-frame-z-index z-index id (get frame-base-idx id) objects)) z-index))))
(defn update-z-index
"Updates the z-index given a set of ids to change and the old and new objects
representations"
[z-index changed-ids old-objects new-objects]
(let [old-frames (into #{} (map #(get-in old-objects [% :frame-id])) changed-ids)
new-frames (into #{} (map #(get-in new-objects [% :frame-id])) changed-ids)
changed-frames (set/union old-frames new-frames)
frames (->> (cph/get-frames new-objects)
(map :id)
(filter #(contains? changed-frames %)))
by-frame (cph/objects-by-frame new-objects)
frame-base-idx (d/update-vals by-frame count)
z-index (calculate-frame-z-index z-index uuid/zero (get frame-base-idx uuid/zero) new-objects)]
(->> frames
(reduce (fn [z-index id]
(calculate-frame-z-index z-index id (get frame-base-idx id) new-objects)) z-index))))
[app.common.uuid :as uuid]))
(defn generate-child-parent-index
[objects]
@ -102,11 +33,16 @@
"Retrieves the mask information for an object"
[objects parents-index]
(let [retrieve-clips
(fn [_ parents]
(fn [parents]
(let [lookup-object (fn [id] (get objects id))
get-clip-parents
(fn [shape]
(cond-> []
(and (= :frame (:type shape))
(not (:show-content shape))
(not= uuid/zero (:id shape)))
(conj shape)
(:masked-group? shape)
(conj (get objects (->> shape :shapes first)))
@ -117,5 +53,5 @@
(comp (map lookup-object)
(mapcat get-clip-parents))
parents)))]
(->> parents-index
(d/mapm retrieve-clips))))
(-> parents-index
(d/update-vals retrieve-clips))))

4
common/src/app/common/path/shapes_to_path.cljc
View file

@ -15,7 +15,7 @@
[app.common.geom.shapes.path :as gsp]
[app.common.path.bool :as pb]
[app.common.path.commands :as pc]
[app.common.spec.radius :as ctr]))
[app.common.types.shape.radius :as ctsr]))
(def ^:const bezier-circle-c 0.551915024494)
@ -152,7 +152,7 @@
(defn rect->path
"Creates a bezier curve that approximates a rounded corner rectangle"
[{:keys [x y width height] :as shape}]
(case (ctr/radius-mode shape)
(case (ctsr/radius-mode shape)
:radius-1
(let [radius (gso/shape-corners-1 shape)]
(draw-rounded-rect-path x y width height radius))

19
common/src/app/common/pprint.cljc
View file

@ -7,21 +7,16 @@
(ns app.common.pprint
(:refer-clojure :exclude [prn])
(:require
[cuerdas.core :as str]
[fipp.edn :as fpp]))
(defn pprint-str
[expr]
(binding [*print-level* 8
*print-length* 25]
[expr & {:keys [width level length]
:or {width 110 level 8 length 25}}]
(binding [*print-level* level
*print-length* length]
(with-out-str
(fpp/pprint expr {:width 110}))))
(fpp/pprint expr {:width width}))))
(defn pprint
([expr]
(println (pprint-str expr)))
([label expr]
(println (str/concat "============ " label "============"))
(pprint expr)))
[expr & {:as opts}]
(println (pprint-str expr opts)))

128
common/src/app/common/spec.cljc
View file

@ -5,7 +5,7 @@
;; Copyright (c) UXBOX Labs SL
(ns app.common.spec
"Data manipulation and query helper functions."
"Data validation & assertion helpers."
(:refer-clojure :exclude [assert bytes?])
#?(:cljs (:require-macros [app.common.spec :refer [assert]]))
(:require
@ -31,8 +31,6 @@
(def max-safe-int (int 1e6))
(def min-safe-int (int -1e6))
(def valid? s/valid?)
;; --- Conformers
(defn uuid-conformer
@ -220,46 +218,102 @@
(fn [s]
(str/join "," s))))
;; --- Macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MACROS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn spec-assert*
[spec val hint ctx]
(if (s/valid? spec val)
val
(let [data (s/explain-data spec val)]
(ex/raise :type :assertion
:code :spec-validation
:hint hint
::ex/data (merge ctx data)))))
(defn explain-data
[spec value]
(s/explain-data spec value))
(defmacro assert
"Development only assertion macro."
[spec x]
(when *assert*
(let [nsdata (:ns &env)
context (if nsdata
{:ns (str (:name nsdata))
:name (pr-str spec)
:line (:line &env)
:file (:file (:meta nsdata))}
(let [mdata (meta &form)]
{:ns (str (ns-name *ns*))
:name (pr-str spec)
:line (:line mdata)}))
message (str "spec assert: '" (pr-str spec) "'")]
`(spec-assert* ~spec ~x ~message ~context))))
(defn valid?
[spec value]
(s/valid? spec value))
(defmacro verify
"Always active assertion macro (does not obey to :elide-asserts)"
[spec x]
(let [nsdata (:ns &env)
context (when nsdata
(defmacro assert-expr*
"Auxiliar macro for expression assertion."
[expr hint]
`(when-not ~expr
(ex/raise :type :assertion
:code :expr-validation
:hint ~hint)))
(defmacro assert-spec*
"Auxiliar macro for spec assertion."
[spec value hint]
(let [context (if-let [nsdata (:ns &env)]
{:ns (str (:name nsdata))
:name (pr-str spec)
:line (:line &env)
:file (:file (:meta nsdata))})
message (str "spec verify: '" (pr-str spec) "'")]
`(spec-assert* ~spec ~x ~message ~context)))
:file (:file (:meta nsdata))}
{:ns (str (ns-name *ns*))
:name (pr-str spec)
:line (:line (meta &form))})
hint (or hint (str "spec assert: " (pr-str spec)))]
`(if (valid? ~spec ~value)
~value
(let [data# (explain-data ~spec ~value)]
(ex/raise :type :assertion
:code :spec-validation
:hint ~hint
::ex/data (merge ~context data#))))))
(defmacro assert
"Is a spec specific assertion macro that only evaluates if *assert*
is true. DEPRECATED: it should be replaced by the new, general
purpose assert! macro."
[spec value]
(when *assert*
`(assert-spec* ~spec ~value nil)))
(defmacro verify
"Is a spec specific assertion macro that evaluates always,
independently of *assert* value. DEPRECATED: should be replaced by
the new, general purpose `verify!` macro."
[spec value]
`(assert-spec* ~spec ~value nil))
(defmacro assert!
"General purpose assertion macro."
[& params]
;; If we only receive two arguments, this means we use the simplified form
(let [pcnt (count params)]
(cond
;; When we have a single argument, this means a simplified form
;; of expr assertion
(= 1 pcnt)
(let [expr (first params)
hint (str "expr assert failed:" (pr-str expr))]
(when *assert*
`(assert-expr* ~expr ~hint)))
;; If we have two arguments, this can be spec or expr
;; assertion. The spec assertion is determined if the first
;; argument is a qualified keyword.
(= 2 pcnt)
(let [[spec-or-expr value-or-msg] params]
(if (qualified-keyword? spec-or-expr)
`(assert-spec* ~spec-or-expr ~value-or-msg nil)
`(assert-expr* ~spec-or-expr ~value-or-msg)))
(= 3 pcnt)
(let [[spec value hint] params]
`(assert-spec* ~spec ~value ~hint))
:else
(let [{:keys [spec expr hint always? val]} params]
(when (or always? *assert*)
(if spec
`(assert-spec* ~spec ~val ~hint)
`(assert-expr* ~expr ~hint)))))))
(defmacro verify!
"A variant of `assert!` macro that evaluates always, independently
of the *assert* value."
[& params]
(binding [*assert* true]
`(assert! ~@params)))
;; --- Public Api

2
common/src/app/common/spec/color.cljc → common/src/app/common/types/color.cljc
View file

@ -4,7 +4,7 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.common.spec.color
(ns app.common.types.color
(:require
[app.common.data :as d]
[app.common.spec :as us]

17
common/src/app/common/spec/file.cljc → common/src/app/common/types/file.cljc
View file

@ -4,12 +4,11 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.common.spec.file
(ns app.common.types.file
(:require
[app.common.spec :as us]
[app.common.spec.color :as color]
[app.common.spec.page :as page]
[app.common.spec.typography]
[app.common.types.color :as ctc]
[app.common.types.page :as ctp]
[clojure.spec.alpha :as s]))
(s/def :internal.media-object/name string?)
@ -31,13 +30,13 @@
:opt-un [:internal.media-object/path]))
(s/def ::colors
(s/map-of uuid? ::color/color))
(s/map-of uuid? ::ctc/color))
(s/def ::recent-colors
(s/coll-of ::color/recent-color :kind vector?))
(s/coll-of ::ctc/recent-color :kind vector?))
(s/def ::typographies
(s/map-of uuid? :app.common.spec.typography/typography))
(s/map-of uuid? :ctst/typography))
(s/def ::pages
(s/coll-of uuid? :kind vector?))
@ -46,10 +45,10 @@
(s/map-of uuid? ::media-object))
(s/def ::pages-index
(s/map-of uuid? ::page/page))
(s/map-of uuid? ::ctp/page))
(s/def ::components
(s/map-of uuid? ::page/container))
(s/map-of uuid? ::ctp/container))
(s/def ::data
(s/keys :req-un [::pages-index

6
common/src/app/common/spec/page.cljc → common/src/app/common/types/page.cljc
View file

@ -4,11 +4,11 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.common.spec.page
(ns app.common.types.page
(:require
[app.common.data :as d]
[app.common.spec :as us]
[app.common.spec.shape :as shape]
[app.common.types.shape :as cts]
[clojure.spec.alpha :as s]))
;; --- Grid options
@ -90,7 +90,7 @@
(s/def ::id uuid?)
(s/def ::name string?)
(s/def ::objects (s/map-of uuid? ::shape/shape))
(s/def ::objects (s/map-of uuid? ::cts/shape))
(s/def ::page
(s/keys :req-un [::id ::name ::objects ::options]))

47
common/src/app/common/spec/shape.cljc → common/src/app/common/types/shape.cljc
View file

@ -4,17 +4,17 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.common.spec.shape
(ns app.common.types.shape
(:require
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.spec :as us]
[app.common.spec.blur :as blur]
[app.common.spec.color :as color]
[app.common.spec.export :as export]
[app.common.spec.interactions :as cti]
[app.common.spec.radius :as radius]
[app.common.spec.shadow :as shadow]
[app.common.types.color :as ctc]
[app.common.types.shape.blur :as ctsb]
[app.common.types.shape.export :as ctse]
[app.common.types.shape.interactions :as ctsi]
[app.common.types.shape.radius :as ctsr]
[app.common.types.shape.shadow :as ctss]
[clojure.set :as set]
[clojure.spec.alpha :as s]))
@ -47,11 +47,13 @@
(s/def ::fill-color string?)
(s/def ::fill-opacity ::us/safe-number)
(s/def ::fill-color-gradient (s/nilable ::color/gradient))
(s/def ::fill-color-gradient (s/nilable ::ctc/gradient))
(s/def ::fill-color-ref-file (s/nilable uuid?))
(s/def ::fill-color-ref-id (s/nilable uuid?))
(s/def ::hide-fill-on-export boolean?)
(s/def ::show-content boolean?)
(s/def ::hide-in-viewer boolean?)
(s/def ::file-thumbnail boolean?)
(s/def ::masked-group? boolean?)
@ -67,7 +69,7 @@
(s/def ::proportion ::us/safe-number)
(s/def ::proportion-lock boolean?)
(s/def ::stroke-color string?)
(s/def ::stroke-color-gradient (s/nilable ::color/gradient))
(s/def ::stroke-color-gradient (s/nilable ::ctc/gradient))
(s/def ::stroke-color-ref-file (s/nilable uuid?))
(s/def ::stroke-color-ref-id (s/nilable uuid?))
(s/def ::stroke-opacity ::us/safe-number)
@ -100,7 +102,7 @@
(s/keys :req-un [::x ::y ::x1 ::y1 ::x2 ::y2 ::width ::height]))
(s/def ::exports
(s/coll-of ::export/export :kind vector?))
(s/coll-of ::ctse/export :kind vector?))
(s/def ::points
(s/every ::gpt/point :kind vector?))
@ -185,12 +187,12 @@
::constraints-h
::constraints-v
::fixed-scroll
::radius/rx
::radius/ry
::radius/r1
::radius/r2
::radius/r3
::radius/r4
::ctsr/rx
::ctsr/ry
::ctsr/r1
::ctsr/r2
::ctsr/r3
::ctsr/r4
::x
::y
::exports
@ -211,9 +213,9 @@
::width
::height
::masked-group?
::cti/interactions
::shadow/shadow
::blur/blur
::ctsi/interactions
::ctss/shadow
::ctsb/blur
::opacity
::blend-mode]))
@ -254,8 +256,7 @@
:internal.shape.text.position-data/rtl
:internal.shape.text.position-data/text
:internal.shape.text.position-data/text-decoration
:internal.shape.text.position-data/text-transform]
))
:internal.shape.text.position-data/text-transform]))
(s/def :internal.shape.text.position-data/x ::us/safe-number)
(s/def :internal.shape.text.position-data/y ::us/safe-number)
@ -303,7 +304,9 @@
(defmethod shape-spec :frame [_]
(s/and ::shape-attrs
(s/keys :opt-un [::file-thumbnail
::hide-fill-on-export])))
::hide-fill-on-export
::show-content
::hide-in-viewer])))
(s/def ::shape
(s/and (s/multi-spec shape-spec :type)

2
common/src/app/common/spec/blur.cljc → common/src/app/common/types/shape/blur.cljc
View file

@ -4,7 +4,7 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.common.spec.blur
(ns app.common.types.shape.blur
(:require
[app.common.spec :as us]
[clojure.spec.alpha :as s]))

4
common/src/app/common/spec/export.cljc → common/src/app/common/types/shape/export.cljc
View file

@ -4,12 +4,11 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.common.spec.export
(ns app.common.types.shape.export
(:require
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
(s/def ::suffix string?)
(s/def ::scale ::us/safe-number)
(s/def ::type keyword?)
@ -19,4 +18,3 @@
::suffix
::scale]))

2
common/src/app/common/spec/interactions.cljc → common/src/app/common/types/shape/interactions.cljc
View file

@ -4,7 +4,7 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.common.spec.interactions
(ns app.common.types.shape.interactions
(:require
[app.common.data :as d]
[app.common.geom.point :as gpt]

2
common/src/app/common/spec/radius.cljc → common/src/app/common/types/shape/radius.cljc
View file

@ -4,7 +4,7 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.common.spec.radius
(ns app.common.types.shape.radius
(:require
[app.common.pages.common :refer [editable-attrs]]
[app.common.spec :as us]

6
common/src/app/common/spec/shadow.cljc → common/src/app/common/types/shape/shadow.cljc
View file

@ -4,10 +4,10 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.common.spec.shadow
(ns app.common.types.shape.shadow
(:require
[app.common.spec :as us]
[app.common.spec.color :as color]
[app.common.types.color :as ctc]
[clojure.spec.alpha :as s]))
@ -24,7 +24,7 @@
(s/def ::color string?)
(s/def ::opacity ::us/safe-number)
(s/def ::gradient (s/nilable ::color/gradient))
(s/def ::gradient (s/nilable ::ctc/gradient))
(s/def ::file-id (s/nilable uuid?))
(s/def ::ref-id (s/nilable uuid?))

2
common/src/app/common/spec/typography.cljc → common/src/app/common/types/typography.cljc
View file

@ -4,7 +4,7 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.common.spec.typography
(ns app.common.types.typography
(:require
[clojure.spec.alpha :as s]))

3
common/src/app/common/uuid.cljc
View file

@ -48,3 +48,6 @@
#?(:clj
(dm/export impl/get-word-high))
#?(:clj
(dm/export impl/get-word-low))

290
common/test/app/common/spec_interactions_test.cljc
View file

@ -10,62 +10,62 @@
[clojure.pprint :refer [pprint]]
[app.common.exceptions :as ex]
[app.common.pages.init :as cpi]
[app.common.spec.interactions :as csi]
[app.common.types.shape.interactions :as ctsi]
[app.common.uuid :as uuid]
[app.common.geom.point :as gpt]))
(t/deftest set-event-type
(let [interaction csi/default-interaction
(let [interaction ctsi/default-interaction
shape (cpi/make-minimal-shape :rect)
frame (cpi/make-minimal-shape :frame)]
(t/testing "Set event type unchanged"
(let [new-interaction
(csi/set-event-type interaction :click shape)]
(ctsi/set-event-type interaction :click shape)]
(t/is (= :click (:event-type new-interaction)))))
(t/testing "Set event type changed"
(let [new-interaction
(csi/set-event-type interaction :mouse-press shape)]
(ctsi/set-event-type interaction :mouse-press shape)]
(t/is (= :mouse-press (:event-type new-interaction)))))
(t/testing "Set after delay on non-frame"
(let [result (ex/try
(csi/set-event-type interaction :after-delay shape))]
(ctsi/set-event-type interaction :after-delay shape))]
(t/is (ex/exception? result))))
(t/testing "Set after delay on frame"
(let [new-interaction
(csi/set-event-type interaction :after-delay frame)]
(ctsi/set-event-type interaction :after-delay frame)]
(t/is (= :after-delay (:event-type new-interaction)))
(t/is (= 600 (:delay new-interaction)))))
(t/testing "Set after delay with previous data"
(let [interaction (assoc interaction :delay 300)
new-interaction
(csi/set-event-type interaction :after-delay frame)]
(ctsi/set-event-type interaction :after-delay frame)]
(t/is (= :after-delay (:event-type new-interaction)))
(t/is (= 300 (:delay new-interaction)))))))
(t/deftest set-action-type
(let [interaction csi/default-interaction]
(let [interaction ctsi/default-interaction]
(t/testing "Set action type unchanged"
(let [new-interaction
(csi/set-action-type interaction :navigate)]
(ctsi/set-action-type interaction :navigate)]
(t/is (= :navigate (:action-type new-interaction)))))
(t/testing "Set action type changed"
(let [new-interaction
(csi/set-action-type interaction :prev-screen)]
(ctsi/set-action-type interaction :prev-screen)]
(t/is (= :prev-screen (:action-type new-interaction)))))
(t/testing "Set action type navigate"
(let [interaction {:event-type :click
:action-type :prev-screen}
new-interaction
(csi/set-action-type interaction :navigate)]
(ctsi/set-action-type interaction :navigate)]
(t/is (= :navigate (:action-type new-interaction)))
(t/is (nil? (:destination new-interaction)))
(t/is (= false (:preserve-scroll new-interaction)))))
@ -77,14 +77,14 @@
:destination destination
:preserve-scroll true}
new-interaction
(csi/set-action-type interaction :navigate)]
(ctsi/set-action-type interaction :navigate)]
(t/is (= :navigate (:action-type new-interaction)))
(t/is (= destination (:destination new-interaction)))
(t/is (= true (:preserve-scroll new-interaction)))))
(t/testing "Set action type open-overlay"
(let [new-interaction
(csi/set-action-type interaction :open-overlay)]
(ctsi/set-action-type interaction :open-overlay)]
(t/is (= :open-overlay (:action-type new-interaction)))
(t/is (= :center (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 0 0) (:overlay-position new-interaction)))))
@ -93,14 +93,14 @@
(let [interaction (assoc interaction :overlay-pos-type :top-left
:overlay-position (gpt/point 100 200))
new-interaction
(csi/set-action-type interaction :open-overlay)]
(ctsi/set-action-type interaction :open-overlay)]
(t/is (= :open-overlay (:action-type new-interaction)))
(t/is (= :top-left (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 100 200) (:overlay-position new-interaction)))))
(t/testing "Set action type toggle-overlay"
(let [new-interaction
(csi/set-action-type interaction :toggle-overlay)]
(ctsi/set-action-type interaction :toggle-overlay)]
(t/is (= :toggle-overlay (:action-type new-interaction)))
(t/is (= :center (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 0 0) (:overlay-position new-interaction)))))
@ -109,14 +109,14 @@
(let [interaction (assoc interaction :overlay-pos-type :top-left
:overlay-position (gpt/point 100 200))
new-interaction
(csi/set-action-type interaction :toggle-overlay)]
(ctsi/set-action-type interaction :toggle-overlay)]
(t/is (= :toggle-overlay (:action-type new-interaction)))
(t/is (= :top-left (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 100 200) (:overlay-position new-interaction)))))
(t/testing "Set action type close-overlay"
(let [new-interaction
(csi/set-action-type interaction :close-overlay)]
(ctsi/set-action-type interaction :close-overlay)]
(t/is (= :close-overlay (:action-type new-interaction)))
(t/is (nil? (:destination new-interaction)))))
@ -124,89 +124,89 @@
(let [destination (uuid/next)
interaction (assoc interaction :destination destination)
new-interaction
(csi/set-action-type interaction :close-overlay)]
(ctsi/set-action-type interaction :close-overlay)]
(t/is (= :close-overlay (:action-type new-interaction)))
(t/is (= destination (:destination new-interaction)))))
(t/testing "Set action type prev-screen"
(let [new-interaction
(csi/set-action-type interaction :prev-screen)]
(ctsi/set-action-type interaction :prev-screen)]
(t/is (= :prev-screen (:action-type new-interaction)))))
(t/testing "Set action type open-url"
(let [new-interaction
(csi/set-action-type interaction :open-url)]
(ctsi/set-action-type interaction :open-url)]
(t/is (= :open-url (:action-type new-interaction)))
(t/is (= "" (:url new-interaction)))))
(t/testing "Set action type open-url with previous data"
(let [interaction (assoc interaction :url "https://example.com")
new-interaction
(csi/set-action-type interaction :open-url)]
(ctsi/set-action-type interaction :open-url)]
(t/is (= :open-url (:action-type new-interaction)))
(t/is (= "https://example.com" (:url new-interaction)))))))
(t/deftest option-delay
(let [frame (cpi/make-minimal-shape :frame)
i1 csi/default-interaction
i2 (csi/set-event-type i1 :after-delay frame)]
i1 ctsi/default-interaction
i2 (ctsi/set-event-type i1 :after-delay frame)]
(t/testing "Has delay"
(t/is (not (csi/has-delay i1)))
(t/is (csi/has-delay i2)))
(t/is (not (ctsi/has-delay i1)))
(t/is (ctsi/has-delay i2)))
(t/testing "Set delay"
(let [new-interaction (csi/set-delay i2 1000)]
(let [new-interaction (ctsi/set-delay i2 1000)]
(t/is (= 1000 (:delay new-interaction)))))))
(t/deftest option-destination
(let [destination (uuid/next)
i1 csi/default-interaction
i2 (csi/set-action-type i1 :prev-screen)
i3 (csi/set-action-type i1 :open-overlay)]
i1 ctsi/default-interaction
i2 (ctsi/set-action-type i1 :prev-screen)
i3 (ctsi/set-action-type i1 :open-overlay)]
(t/testing "Has destination"
(t/is (csi/has-destination i1))
(t/is (not (csi/has-destination i2))))
(t/is (ctsi/has-destination i1))
(t/is (not (ctsi/has-destination i2))))
(t/testing "Set destination"
(let [new-interaction (csi/set-destination i1 destination)]
(let [new-interaction (ctsi/set-destination i1 destination)]
(t/is (= destination (:destination new-interaction)))
(t/is (nil? (:overlay-pos-type new-interaction)))
(t/is (nil? (:overlay-position new-interaction)))))
(t/testing "Set destination of overlay"
(let [new-interaction (csi/set-destination i3 destination)]
(let [new-interaction (ctsi/set-destination i3 destination)]
(t/is (= destination (:destination new-interaction)))
(t/is (= :center (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 0 0) (:overlay-position new-interaction)))))))
(t/deftest option-preserve-scroll
(let [i1 csi/default-interaction
i2 (csi/set-action-type i1 :prev-screen)]
(let [i1 ctsi/default-interaction
i2 (ctsi/set-action-type i1 :prev-screen)]
(t/testing "Has preserve-scroll"
(t/is (csi/has-preserve-scroll i1))
(t/is (not (csi/has-preserve-scroll i2))))
(t/is (ctsi/has-preserve-scroll i1))
(t/is (not (ctsi/has-preserve-scroll i2))))
(t/testing "Set preserve-scroll"
(let [new-interaction (csi/set-preserve-scroll i1 true)]
(let [new-interaction (ctsi/set-preserve-scroll i1 true)]
(t/is (= true (:preserve-scroll new-interaction)))))))
(t/deftest option-url
(let [i1 csi/default-interaction
i2 (csi/set-action-type i1 :open-url)]
(let [i1 ctsi/default-interaction
i2 (ctsi/set-action-type i1 :open-url)]
(t/testing "Has url"
(t/is (not (csi/has-url i1)))
(t/is (csi/has-url i2)))
(t/is (not (ctsi/has-url i1)))
(t/is (ctsi/has-url i2)))
(t/testing "Set url"
(let [new-interaction (csi/set-url i2 "https://example.com")]
(let [new-interaction (ctsi/set-url i2 "https://example.com")]
(t/is (= "https://example.com" (:url new-interaction)))))))
@ -220,35 +220,35 @@
objects {(:id base-frame) base-frame
(:id overlay-frame) overlay-frame}
i1 csi/default-interaction
i2 (csi/set-action-type i1 :open-overlay)
i1 ctsi/default-interaction
i2 (ctsi/set-action-type i1 :open-overlay)
i3 (-> i1
(csi/set-action-type :open-overlay)
(csi/set-destination (:id overlay-frame)))]
(ctsi/set-action-type :open-overlay)
(ctsi/set-destination (:id overlay-frame)))]
(t/testing "Has overlay options"
(t/is (not (csi/has-overlay-opts i1)))
(t/is (csi/has-overlay-opts i2)))
(t/is (not (ctsi/has-overlay-opts i1)))
(t/is (ctsi/has-overlay-opts i2)))
(t/testing "Set overlay-pos-type without destination"
(let [new-interaction (csi/set-overlay-pos-type i2 :top-right base-frame objects)]
(let [new-interaction (ctsi/set-overlay-pos-type i2 :top-right base-frame objects)]
(t/is (= :top-right (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 0 0) (:overlay-position new-interaction)))))
(t/testing "Set overlay-pos-type with destination and auto"
(let [new-interaction (csi/set-overlay-pos-type i3 :bottom-right base-frame objects)]
(let [new-interaction (ctsi/set-overlay-pos-type i3 :bottom-right base-frame objects)]
(t/is (= :bottom-right (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 0 0) (:overlay-position new-interaction)))))
(t/testing "Set overlay-pos-type with destination and manual"
(let [new-interaction (csi/set-overlay-pos-type i3 :manual base-frame objects)]
(let [new-interaction (ctsi/set-overlay-pos-type i3 :manual base-frame objects)]
(t/is (= :manual (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 35 40) (:overlay-position new-interaction)))))
(t/testing "Toggle overlay-pos-type"
(let [new-interaction (csi/toggle-overlay-pos-type i3 :center base-frame objects)
new-interaction-2 (csi/toggle-overlay-pos-type new-interaction :center base-frame objects)
new-interaction-3 (csi/toggle-overlay-pos-type new-interaction-2 :top-right base-frame objects)]
(let [new-interaction (ctsi/toggle-overlay-pos-type i3 :center base-frame objects)
new-interaction-2 (ctsi/toggle-overlay-pos-type new-interaction :center base-frame objects)
new-interaction-3 (ctsi/toggle-overlay-pos-type new-interaction-2 :top-right base-frame objects)]
(t/is (= :manual (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 35 40) (:overlay-position new-interaction)))
(t/is (= :center (:overlay-pos-type new-interaction-2)))
@ -257,73 +257,73 @@
(t/is (= (gpt/point 0 0) (:overlay-position new-interaction-3)))))
(t/testing "Set overlay-position"
(let [new-interaction (csi/set-overlay-position i3 (gpt/point 50 60))]
(let [new-interaction (ctsi/set-overlay-position i3 (gpt/point 50 60))]
(t/is (= :manual (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 50 60) (:overlay-position new-interaction)))))
(t/testing "Set close-click-outside"
(let [new-interaction (csi/set-close-click-outside i3 true)]
(let [new-interaction (ctsi/set-close-click-outside i3 true)]
(t/is (not (:close-click-outside i3)))
(t/is (:close-click-outside new-interaction))))
(t/testing "Set background-overlay"
(let [new-interaction (csi/set-background-overlay i3 true)]
(let [new-interaction (ctsi/set-background-overlay i3 true)]
(t/is (not (:background-overlay i3)))
(t/is (:background-overlay new-interaction))))))
(t/deftest animation-checks
(let [i1 csi/default-interaction
i2 (csi/set-action-type i1 :open-overlay)
i3 (csi/set-action-type i1 :toggle-overlay)
i4 (csi/set-action-type i1 :close-overlay)
i5 (csi/set-action-type i1 :prev-screen)
i6 (csi/set-action-type i1 :open-url)]
(let [i1 ctsi/default-interaction
i2 (ctsi/set-action-type i1 :open-overlay)
i3 (ctsi/set-action-type i1 :toggle-overlay)
i4 (ctsi/set-action-type i1 :close-overlay)
i5 (ctsi/set-action-type i1 :prev-screen)
i6 (ctsi/set-action-type i1 :open-url)]
(t/testing "Has animation?"
(t/is (csi/has-animation? i1))
(t/is (csi/has-animation? i2))
(t/is (csi/has-animation? i3))
(t/is (csi/has-animation? i4))
(t/is (not (csi/has-animation? i5)))
(t/is (not (csi/has-animation? i6))))
(t/is (ctsi/has-animation? i1))
(t/is (ctsi/has-animation? i2))
(t/is (ctsi/has-animation? i3))
(t/is (ctsi/has-animation? i4))
(t/is (not (ctsi/has-animation? i5)))
(t/is (not (ctsi/has-animation? i6))))
(t/testing "Valid push?"
(t/is (csi/allow-push? (:action-type i1)))
(t/is (not (csi/allow-push? (:action-type i2))))
(t/is (not (csi/allow-push? (:action-type i3))))
(t/is (not (csi/allow-push? (:action-type i4))))
(t/is (not (csi/allow-push? (:action-type i5))))
(t/is (not (csi/allow-push? (:action-type i6)))))))
(t/is (ctsi/allow-push? (:action-type i1)))
(t/is (not (ctsi/allow-push? (:action-type i2))))
(t/is (not (ctsi/allow-push? (:action-type i3))))
(t/is (not (ctsi/allow-push? (:action-type i4))))
(t/is (not (ctsi/allow-push? (:action-type i5))))
(t/is (not (ctsi/allow-push? (:action-type i6)))))))
(t/deftest set-animation-type
(let [i1 csi/default-interaction
i2 (csi/set-animation-type i1 :dissolve)]
(let [i1 ctsi/default-interaction
i2 (ctsi/set-animation-type i1 :dissolve)]
(t/testing "Set animation type nil"
(let [new-interaction
(csi/set-animation-type i1 nil)]
(ctsi/set-animation-type i1 nil)]
(t/is (nil? (-> new-interaction :animation :animation-type)))))
(t/testing "Set animation type unchanged"
(let [new-interaction
(csi/set-animation-type i2 :dissolve)]
(ctsi/set-animation-type i2 :dissolve)]
(t/is (= :dissolve (-> new-interaction :animation :animation-type)))))
(t/testing "Set animation type changed"
(let [new-interaction
(csi/set-animation-type i2 :slide)]
(ctsi/set-animation-type i2 :slide)]
(t/is (= :slide (-> new-interaction :animation :animation-type)))))
(t/testing "Set animation type reset"
(let [new-interaction
(csi/set-animation-type i2 nil)]
(ctsi/set-animation-type i2 nil)]
(t/is (nil? (-> new-interaction :animation)))))
(t/testing "Set animation type dissolve"
(let [new-interaction
(csi/set-animation-type i1 :dissolve)]
(ctsi/set-animation-type i1 :dissolve)]
(t/is (= :dissolve (-> new-interaction :animation :animation-type)))
(t/is (= 300 (-> new-interaction :animation :duration)))
(t/is (= :linear (-> new-interaction :animation :easing)))))
@ -336,14 +336,14 @@
:direction :left
:offset-effect true})
new-interaction
(csi/set-animation-type interaction :dissolve)]
(ctsi/set-animation-type interaction :dissolve)]
(t/is (= :dissolve (-> new-interaction :animation :animation-type)))
(t/is (= 1000 (-> new-interaction :animation :duration)))
(t/is (= :ease-out (-> new-interaction :animation :easing)))))
(t/testing "Set animation type slide"
(let [new-interaction
(csi/set-animation-type i1 :slide)]
(ctsi/set-animation-type i1 :slide)]
(t/is (= :slide (-> new-interaction :animation :animation-type)))
(t/is (= 300 (-> new-interaction :animation :duration)))
(t/is (= :linear (-> new-interaction :animation :easing)))
@ -359,7 +359,7 @@
:direction :left
:offset-effect true})
new-interaction
(csi/set-animation-type interaction :slide)]
(ctsi/set-animation-type interaction :slide)]
(t/is (= :slide (-> new-interaction :animation :animation-type)))
(t/is (= 1000 (-> new-interaction :animation :duration)))
(t/is (= :ease-out (-> new-interaction :animation :easing)))
@ -369,7 +369,7 @@
(t/testing "Set animation type push"
(let [new-interaction
(csi/set-animation-type i1 :push)]
(ctsi/set-animation-type i1 :push)]
(t/is (= :push (-> new-interaction :animation :animation-type)))
(t/is (= 300 (-> new-interaction :animation :duration)))
(t/is (= :linear (-> new-interaction :animation :easing)))
@ -383,7 +383,7 @@
:direction :left
:offset-effect true})
new-interaction
(csi/set-animation-type interaction :push)]
(ctsi/set-animation-type interaction :push)]
(t/is (= :push (-> new-interaction :animation :animation-type)))
(t/is (= 1000 (-> new-interaction :animation :duration)))
(t/is (= :ease-out (-> new-interaction :animation :easing)))
@ -391,9 +391,9 @@
(t/deftest allowed-animation
(let [i1 (csi/set-action-type csi/default-interaction :open-overlay)
i2 (csi/set-action-type csi/default-interaction :close-overlay)
i3 (csi/set-action-type csi/default-interaction :toggle-overlay)]
(let [i1 (ctsi/set-action-type ctsi/default-interaction :open-overlay)
i2 (ctsi/set-action-type ctsi/default-interaction :close-overlay)
i3 (ctsi/set-action-type ctsi/default-interaction :toggle-overlay)]
(t/testing "Cannot use animation push for an overlay action"
(let [bad-interaction-1 (assoc i1 :animation {:animation-type :push
@ -408,72 +408,72 @@
:duration 1000
:easing :ease-out
:direction :left})]
(t/is (not (csi/allowed-animation? (:action-type bad-interaction-1)
(t/is (not (ctsi/allowed-animation? (:action-type bad-interaction-1)
(-> bad-interaction-1 :animation :animation-type))))
(t/is (not (csi/allowed-animation? (:action-type bad-interaction-2)
(t/is (not (ctsi/allowed-animation? (:action-type bad-interaction-2)
(-> bad-interaction-1 :animation :animation-type))))
(t/is (not (csi/allowed-animation? (:action-type bad-interaction-3)
(t/is (not (ctsi/allowed-animation? (:action-type bad-interaction-3)
(-> bad-interaction-1 :animation :animation-type))))))
(t/testing "Remove animation if moving to an forbidden state"
(let [interaction (csi/set-animation-type csi/default-interaction :push)
new-interaction (csi/set-action-type interaction :open-overlay)]
(let [interaction (ctsi/set-animation-type ctsi/default-interaction :push)
new-interaction (ctsi/set-action-type interaction :open-overlay)]
(t/is (nil? (:animation new-interaction)))))))
(t/deftest option-duration
(let [i1 csi/default-interaction
i2 (csi/set-animation-type csi/default-interaction :dissolve)]
(let [i1 ctsi/default-interaction
i2 (ctsi/set-animation-type ctsi/default-interaction :dissolve)]
(t/testing "Has duration?"
(t/is (not (csi/has-duration? i1)))
(t/is (csi/has-duration? i2)))
(t/is (not (ctsi/has-duration? i1)))
(t/is (ctsi/has-duration? i2)))
(t/testing "Set duration"
(let [new-interaction (csi/set-duration i2 1000)]
(let [new-interaction (ctsi/set-duration i2 1000)]
(t/is (= 1000 (-> new-interaction :animation :duration)))))))
(t/deftest option-easing
(let [i1 csi/default-interaction
i2 (csi/set-animation-type csi/default-interaction :dissolve)]
(let [i1 ctsi/default-interaction
i2 (ctsi/set-animation-type ctsi/default-interaction :dissolve)]
(t/testing "Has easing?"
(t/is (not (csi/has-easing? i1)))
(t/is (csi/has-easing? i2)))
(t/is (not (ctsi/has-easing? i1)))
(t/is (ctsi/has-easing? i2)))
(t/testing "Set easing"
(let [new-interaction (csi/set-easing i2 :ease-in)]
(let [new-interaction (ctsi/set-easing i2 :ease-in)]
(t/is (= :ease-in (-> new-interaction :animation :easing)))))))
(t/deftest option-way
(let [i1 csi/default-interaction
i2 (csi/set-animation-type csi/default-interaction :slide)
i3 (csi/set-action-type i2 :open-overlay)]
(let [i1 ctsi/default-interaction
i2 (ctsi/set-animation-type ctsi/default-interaction :slide)
i3 (ctsi/set-action-type i2 :open-overlay)]
(t/testing "Has way?"
(t/is (not (csi/has-way? i1)))
(t/is (csi/has-way? i2))
(t/is (not (csi/has-way? i3)))
(t/is (not (ctsi/has-way? i1)))
(t/is (ctsi/has-way? i2))
(t/is (not (ctsi/has-way? i3)))
(t/is (some? (-> i3 :animation :way)))) ; <- it exists but is ignored
(t/testing "Set way"
(let [new-interaction (csi/set-way i2 :out)]
(let [new-interaction (ctsi/set-way i2 :out)]
(t/is (= :out (-> new-interaction :animation :way)))))))
(t/deftest option-direction
(let [i1 csi/default-interaction
i2 (csi/set-animation-type csi/default-interaction :push)
i3 (csi/set-animation-type csi/default-interaction :dissolve)]
(let [i1 ctsi/default-interaction
i2 (ctsi/set-animation-type ctsi/default-interaction :push)
i3 (ctsi/set-animation-type ctsi/default-interaction :dissolve)]
(t/testing "Has direction?"
(t/is (not (csi/has-direction? i1)))
(t/is (csi/has-direction? i2)))
(t/is (not (ctsi/has-direction? i1)))
(t/is (ctsi/has-direction? i2)))
(t/testing "Set direction"
(let [new-interaction (csi/set-direction i2 :left)]
(let [new-interaction (ctsi/set-direction i2 :left)]
(t/is (= :left (-> new-interaction :animation :direction)))))
(t/testing "Invert direction"
@ -483,12 +483,12 @@
a-up (assoc a-right :direction :up)
a-down (assoc a-right :direction :down)
a-nil' (csi/invert-direction nil)
a-none' (csi/invert-direction a-none)
a-right' (csi/invert-direction a-right)
a-left' (csi/invert-direction a-left)
a-up' (csi/invert-direction a-up)
a-down' (csi/invert-direction a-down)]
a-nil' (ctsi/invert-direction nil)
a-none' (ctsi/invert-direction a-none)
a-right' (ctsi/invert-direction a-right)
a-left' (ctsi/invert-direction a-left)
a-up' (ctsi/invert-direction a-up)
a-down' (ctsi/invert-direction a-down)]
(t/is (nil? a-nil'))
(t/is (nil? (:direction a-none')))
@ -499,44 +499,44 @@
(t/deftest option-offset-effect
(let [i1 csi/default-interaction
i2 (csi/set-animation-type csi/default-interaction :slide)
i3 (csi/set-action-type i2 :open-overlay)]
(let [i1 ctsi/default-interaction
i2 (ctsi/set-animation-type ctsi/default-interaction :slide)
i3 (ctsi/set-action-type i2 :open-overlay)]
(t/testing "Has offset-effect"
(t/is (not (csi/has-offset-effect? i1)))
(t/is (csi/has-offset-effect? i2))
(t/is (not (csi/has-offset-effect? i3)))
(t/is (not (ctsi/has-offset-effect? i1)))
(t/is (ctsi/has-offset-effect? i2))
(t/is (not (ctsi/has-offset-effect? i3)))
(t/is (some? (-> i3 :animation :offset-effect)))) ; <- it exists but is ignored
(t/testing "Set offset-effect"
(let [new-interaction (csi/set-offset-effect i2 true)]
(let [new-interaction (ctsi/set-offset-effect i2 true)]
(t/is (= true (-> new-interaction :animation :offset-effect)))))))
(t/deftest modify-interactions
(let [i1 (csi/set-action-type csi/default-interaction :open-overlay)
i2 (csi/set-action-type csi/default-interaction :close-overlay)
i3 (csi/set-action-type csi/default-interaction :prev-screen)
(let [i1 (ctsi/set-action-type ctsi/default-interaction :open-overlay)
i2 (ctsi/set-action-type ctsi/default-interaction :close-overlay)
i3 (ctsi/set-action-type ctsi/default-interaction :prev-screen)
interactions [i1 i2]]
(t/testing "Add interaction to nil"
(let [new-interactions (csi/add-interaction nil i3)]
(let [new-interactions (ctsi/add-interaction nil i3)]
(t/is (= (count new-interactions) 1))
(t/is (= (:action-type (last new-interactions)) :prev-screen))))
(t/testing "Add interaction to normal"
(let [new-interactions (csi/add-interaction interactions i3)]
(let [new-interactions (ctsi/add-interaction interactions i3)]
(t/is (= (count new-interactions) 3))
(t/is (= (:action-type (last new-interactions)) :prev-screen))))
(t/testing "Remove interaction"
(let [new-interactions (csi/remove-interaction interactions 0)]
(let [new-interactions (ctsi/remove-interaction interactions 0)]
(t/is (= (count new-interactions) 1))
(t/is (= (:action-type (last new-interactions)) :close-overlay))))
(t/testing "Update interaction"
(let [new-interactions (csi/update-interaction interactions 1 #(csi/set-action-type % :open-url))]
(let [new-interactions (ctsi/update-interaction interactions 1 #(ctsi/set-action-type % :open-url))]
(t/is (= (count new-interactions) 2))
(t/is (= (:action-type (last new-interactions)) :open-url))))))
@ -556,16 +556,16 @@
ids-map {(:id frame1) (:id frame4)
(:id frame2) (:id frame5)}
i1 (csi/set-destination csi/default-interaction (:id frame1))
i2 (csi/set-destination csi/default-interaction (:id frame2))
i3 (csi/set-destination csi/default-interaction (:id frame3))
i4 (csi/set-destination csi/default-interaction nil)
i5 (csi/set-destination csi/default-interaction (:id frame6))
i1 (ctsi/set-destination ctsi/default-interaction (:id frame1))
i2 (ctsi/set-destination ctsi/default-interaction (:id frame2))
i3 (ctsi/set-destination ctsi/default-interaction (:id frame3))
i4 (ctsi/set-destination ctsi/default-interaction nil)
i5 (ctsi/set-destination ctsi/default-interaction (:id frame6))
interactions [i1 i2 i3 i4 i5]]
(t/testing "Remap interactions"
(let [new-interactions (csi/remap-interactions interactions ids-map objects)]
(let [new-interactions (ctsi/remap-interactions interactions ids-map objects)]
(t/is (= (count new-interactions) 4))
(t/is (= (:id frame4) (:destination (get new-interactions 0))))
(t/is (= (:id frame5) (:destination (get new-interactions 1))))

8
common/yarn.lock
View file

@ -533,10 +533,10 @@ shadow-cljs-jar@1.3.2:
resolved "https://registry.yarnpkg.com/shadow-cljs-jar/-/shadow-cljs-jar-1.3.2.tgz#97273afe1747b6a2311917c1c88d9e243c81957b"
integrity sha512-XmeffAZHv8z7451kzeq9oKh8fh278Ak+UIOGGrapyqrFBB773xN8vMQ3O7J7TYLnb9BUwcqadKkmgaq7q6fhZg==
shadow-cljs@2.17.3:
version "2.17.3"
resolved "https://registry.yarnpkg.com/shadow-cljs/-/shadow-cljs-2.17.3.tgz#748e31f67cffdc401691c0cd1bf733a1da53ab5d"
integrity sha512-GxyczUuCtACq/uEOvdTc61wT/aDOZFy8G/AGc322uTX/oUiZaeTJrwpClXe+0+e7VKG9E9RCqP/cjuG3cAG0fw==
shadow-cljs@2.19.3:
version "2.19.3"
resolved "https://registry.yarnpkg.com/shadow-cljs/-/shadow-cljs-2.19.3.tgz#115a33917f8bca1495e0f815dca7ec3957f669af"
integrity sha512-9TsTCRlmR8m1g2ekwblgomRUgJpbifQI99VlRrlH9NMqEzklev3zYAD1dvy4d5h8BoAhgdxOOEg7ld2d45CWTA==
dependencies:
node-libs-browser "^2.2.1"
readline-sync "^1.4.7"

24
docker/devenv/Dockerfile
View file

@ -1,12 +1,12 @@
FROM ubuntu:20.04
FROM ubuntu:22.04
LABEL maintainer="Andrey Antukh <niwi@niwi.nz>"
ARG DEBIAN_FRONTEND=noninteractive
ENV NODE_VERSION=v16.14.2 \
CLOJURE_VERSION=1.11.0.1100 \
CLJKONDO_VERSION=2022.03.09 \
BABASHKA_VERSION=0.8.0 \
ENV NODE_VERSION=v16.15.1 \
CLOJURE_VERSION=1.11.1.1149 \
CLJKONDO_VERSION=2022.06.22 \
BABASHKA_VERSION=0.8.156 \
LANG=en_US.UTF-8 \
LC_ALL=en_US.UTF-8
@ -44,7 +44,6 @@ RUN set -ex; \
RUN set -ex; \
apt-get -qq update; \
apt-get -qqy install --no-install-recommends \
python \
build-essential \
imagemagick \
ghostscript \
@ -104,7 +103,7 @@ RUN set -ex; \
rm -rf /var/lib/apt/lists/*;
RUN set -ex; \
curl -LfsSo /tmp/openjdk.tar.gz https://github.com/adoptium/temurin18-binaries/releases/download/jdk-18%2B36/OpenJDK18U-jdk_x64_linux_hotspot_18_36.tar.gz; \
curl -LfsSo /tmp/openjdk.tar.gz https://github.com/adoptium/temurin18-binaries/releases/download/jdk-18.0.1%2B10/OpenJDK18U-jdk_x64_linux_hotspot_18.0.1_10.tar.gz; \
mkdir -p /usr/lib/jvm/openjdk; \
cd /usr/lib/jvm/openjdk; \
tar -xf /tmp/openjdk.tar.gz --strip-components=1; \
@ -120,7 +119,7 @@ RUN set -ex; \
RUN set -ex; \
curl https://www.postgresql.org/media/keys/ACCC4CF8.asc | sudo apt-key add -; \
echo "deb http://apt.postgresql.org/pub/repos/apt focal-pgdg main" >> /etc/apt/sources.list.d/postgresql.list; \
echo "deb http://apt.postgresql.org/pub/repos/apt jammy-pgdg main" >> /etc/apt/sources.list.d/postgresql.list; \
apt-get -qq update; \
apt-get -qqy install postgresql-client-13; \
rm -rf /var/lib/apt/lists/*;
@ -132,8 +131,8 @@ RUN set -ex; \
tar -xf /tmp/nodejs.tar.xz --strip-components=1; \
chown -R root /usr/local/nodejs; \
PATH="$PATH:/usr/local/nodejs/bin"; \
/usr/local/nodejs/bin/npm install -g yarn; \
/usr/local/nodejs/bin/npm install -g svgo; \
/usr/local/nodejs/bin/npm install --location=global yarn; \
/usr/local/nodejs/bin/npm install --location=global svgo; \
rm -rf /tmp/nodejs.tar.xz;
# Install clj-kondo
@ -143,7 +142,6 @@ RUN set -ex; \
unzip /tmp/clj-kondo.zip; \
rm /tmp/clj-kondo.zip;
# Install babashka
RUN set -ex; \
cd /tmp; \
curl -LfsSo /tmp/babashka.tar.gz https://github.com/babashka/babashka/releases/download/v$BABASHKA_VERSION/babashka-$BABASHKA_VERSION-linux-amd64.tar.gz; \
@ -151,8 +149,10 @@ RUN set -ex; \
tar -xf /tmp/babashka.tar.gz; \
rm -rf /tmp/babashka.tar.gz;
# Install minio client
RUN set -ex; \
curl -LfsSo /tmp/mc https://dl.min.io/client/mc/release/linux-amd64/mc --user-agent "Mozilla/5.0 (Macintosh; Intel Mac OS X 10_15_7) AppleWebKit/605.1.15 (KHTML, like Gecko) Version/14.1.1 Safari/605.1.15"; \
wget -O /tmp/mc https://dl.min.io/client/mc/release/linux-amd64/mc; \
mv /tmp/mc /usr/local/bin/; \
chmod +x /usr/local/bin/mc;

14
docker/images/Dockerfile.backend
View file

@ -1,4 +1,4 @@
FROM ubuntu:20.04
FROM ubuntu:22.04
LABEL maintainer="Andrey Antukh <niwi@niwi.nz>"
ENV LANG='en_US.UTF-8' LC_ALL='en_US.UTF-8'
@ -27,16 +27,16 @@ RUN set -eux; \
ARCH="$(dpkg --print-architecture)"; \
case "${ARCH}" in \
aarch64|arm64) \
ESUM='7217a9f9be3b0c8dfc78538f95fd2deb493eb651152d975062920566492b2574'; \
BINARY_URL='https://github.com/AdoptOpenJDK/openjdk16-binaries/releases/download/jdk-16%2B36/OpenJDK16-jdk_aarch64_linux_hotspot_16_36.tar.gz'; \
ESUM='37ceaf232a85cce46bcccfd71839854e8b14bf3160e7ef72a676b9cae45ee8af'; \
BINARY_URL='https://github.com/adoptium/temurin18-binaries/releases/download/jdk-18.0.1%2B10/OpenJDK18U-jdk_aarch64_linux_hotspot_18.0.1_10.tar.gz'; \
;; \
armhf|armv7l) \
ESUM='f1d32ba01a40c98889f31368c0e987d6bbda65a7c50b8c088623b48e3a90104a'; \
BINARY_URL='https://github.com/AdoptOpenJDK/openjdk16-binaries/releases/download/jdk-16%2B36/OpenJDK16-jdk_arm_linux_hotspot_16_36.tar.gz'; \
ESUM='0ddec3c165ab0b662a57a845db3fdaeb840660b493f164696b03df76aadf61c8'; \
BINARY_URL='https://github.com/adoptium/temurin18-binaries/releases/download/jdk-18.0.1%2B10/OpenJDK18U-jdk_arm_linux_hotspot_18.0.1_10.tar.gz'; \
;; \
amd64|x86_64) \
ESUM='2e031cf37018161c9e59b45fa4b98ff2ce4ce9297b824c512989d579a70f8422'; \
BINARY_URL='https://github.com/AdoptOpenJDK/openjdk16-binaries/releases/download/jdk-16%2B36/OpenJDK16-jdk_x64_linux_hotspot_16_36.tar.gz'; \
ESUM='16b1d9d75f22c157af04a1fd9c664324c7f4b5163c022b382a2f2e8897c1b0a2'; \
BINARY_URL='https://github.com/adoptium/temurin18-binaries/releases/download/jdk-18.0.1%2B10/OpenJDK18U-jdk_x64_linux_hotspot_18.0.1_10.tar.gz'; \
;; \
*) \
echo "Unsupported arch: ${ARCH}"; \

6
docker/images/Dockerfile.exporter
View file

@ -1,11 +1,11 @@
FROM ubuntu:20.04
FROM ubuntu:22.04
LABEL maintainer="Andrey Antukh <niwi@niwi.nz>"
ARG DEBIAN_FRONTEND=noninteractive
ENV LANG=en_US.UTF-8 \
LC_ALL=en_US.UTF-8 \
NODE_VERSION=v16.14.2
NODE_VERSION=v16.15.1
RUN set -ex; \
mkdir -p /etc/resolvconf/resolv.conf.d; \
@ -95,7 +95,7 @@ WORKDIR /opt/app
ADD ./bundle-exporter/ /opt/app/
RUN set -ex; \
yarn install; \
yarn; \
npx playwright install chromium;
CMD ["/usr/local/nodejs/bin/node", "app.js"]

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