3pp-mirror/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-07-16 15:35:16 +02:00
Code Issues Projects Releases Packages Wiki Activity

Merge remote-tracking branch 'origin/staging'

Browse source
This commit is contained in:
Alejandro Alonso 2022-08-24 08:11:22 +02:00
commit 8d8e4c5e22
478 changed files with 18827 additions and 441795 deletions
Download patch file Download diff file Expand all files Collapse all files

51
.clj-kondo/hooks/export.clj
View file

@ -53,24 +53,37 @@
[{:keys [:node]}]
(let [[rnode rtype ?meta & other] (:children node)
rsym (gensym (name (:k rtype)))
result (api/list-node
[(api/token-node (symbol "do"))
(api/list-node
[(api/token-node (symbol "declare"))
(api/token-node rsym)])
(if (= :map (:tag ?meta))
(api/list-node
[(api/token-node (symbol "reset-meta!"))
(api/token-node rsym)
?meta])
(api/list-node
[(api/token-node (symbol "comment"))
(api/token-node rsym)]))
(api/list-node
(into [(api/token-node (symbol "defmethod"))
(api/token-node rsym)
rtype]
(cons ?meta other)))])]
;; (prn "==============" rtype (into {} ?meta))
[?docs other] (if (api/string-node? ?meta)
[?meta other]
[nil (cons ?meta other)])
[?meta other] (let [?meta (first other)]
(if (api/map-node? ?meta)
[?meta (rest other)]
[nil other]))
nodes [(api/token-node (symbol "do"))
(api/list-node
[(api/token-node (symbol "declare"))
(api/token-node rsym)])
(when ?docs
(api/list-node
[(api/token-node (symbol "comment")) ?docs]))
(when ?meta
(api/list-node
[(api/token-node (symbol "reset-meta!"))
(api/token-node rsym)
?meta]))
(api/list-node
(into [(api/token-node (symbol "defmethod"))
(api/token-node rsym)
rtype]
other))]
result (api/list-node (filterv some? nodes))]
;; (prn "=====>" rtype)
;; (prn (api/sexpr result))
{:node result}))

1
.gitignore vendored
View file

@ -23,6 +23,7 @@
/backend/resources/public/assets
/backend/resources/public/media
/backend/target/
/backend/builtin-templates
/bundle*
/cd.md
/clj-profiler/

61
CHANGES.md
View file

@ -1,5 +1,66 @@
# CHANGELOG
## 1.15.0-beta
### :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)
- Comments positioning [Taiga #2007](https://tree.taiga.io/project/penpot/us/2007)
- Select all inside a group select only the objects at this group level [Taiga #2382](https://tree.taiga.io/project/penpot/issue/2382)
- Make the media maximum upload size configurable
### :bug: Bugs fixed
- Fix hide html options on handoff [Taiga 3533](https://tree.taiga.io/project/penpot/issue/3533)
- Fix share prototypes overlay and stroke [Taiga #3994](https://tree.taiga.io/project/penpot/issue/3994)
- Fix border radious on boolean operations [Taiga #3959](https://tree.taiga.io/project/penpot/issue/3959)
- Fix inconsistent representation of rectangles [Taiga #3977](https://tree.taiga.io/project/penpot/issue/3977)
- Fix recent fonts info [Taiga #3953](https://tree.taiga.io/project/penpot/issue/3953)
- Fix clipped elements affect boards and centering [Taiga #3666](https://tree.taiga.io/project/penpot/issue/3666)
- Fix intro action in multi input [Taiga #3541](https://tree.taiga.io/project/penpot/issue/3541)
- Fix team default image [Taiga #3919](https://tree.taiga.io/project/penpot/issue/3919)
- Fix problem with group coordinates [#2008](https://github.com/penpot/penpot/issues/2008)
- Fix problem with line-height and texts [Taiga #3578](https://tree.taiga.io/project/penpot/issue/3578)
- Fix moving frame-guides outside frames [Taiga #3839](https://tree.taiga.io/project/penpot/issue/3839)
- Fix problem with 180 degree rotations [#2082](https://github.com/penpot/penpot/issues/2082)
- Fix font rendering on grid thumbnails [Taiga #3473](https://tree.taiga.io/project/penpot/issue/3473)
- Fix Drag and drop font assets in groups [Taiga #3763](https://tree.taiga.io/project/penpot/issue/3763)
- Fix copy and paste layers order [Taiga #1617](https://tree.taiga.io/project/penpot/issue/1617)
- Fix unexpected removal of guides on copy&paste frames [Taiga #3887](https://tree.taiga.io/project/penpot/issue/3887) by @andrewzhurov
- Fix props preserving on copy&paste texts [Taiga #3629](https://tree.taiga.io/project/penpot/issue/3629) by @andrewzhurov
- Fix unexpected layers ungrouping on moving it [Taiga #3932](https://tree.taiga.io/project/penpot/issue/3932) by @andrewzhurov
- Fix unexpected exception and behavior on colorpicker with gradients [Taiga #3448](https://tree.taiga.io/project/penpot/issue/3448)
- Fix multiselection with shift not working inside a library group [Taiga #3532](https://tree.taiga.io/project/penpot/issue/3532)
### :arrow_up: Deps updates
### :heart: Community contributions by (Thank you!)
## 1.14.2-beta
### :bug: Bugs fixed

26
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,25 +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.8" :git/sha "fbe1d7d"
: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.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"}
@ -44,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
@ -65,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

114
backend/dev/script-fix-sobjects.clj Normal file
View file

@ -0,0 +1,114 @@
;; 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
;; This is an example on how it can be executed:
;; clojure -Scp $(cat classpath) -M dev/script-fix-sobjects.clj
(require
'[app.common.logging :as l]
'[app.common.data :as d]
'[app.common.pprint]
'[app.db :as db]
'[app.storage :as sto]
'[app.storage.impl :as impl]
'[app.util.time :as dt]
'[integrant.core :as ig])
;; --- HELPERS
(l/info :hint "initializing script" :args *command-line-args*)
(def noop? (some #(= % "noop") *command-line-args*))
(def chunk-size 10)
(def sql:retrieve-sobjects-chunk
"SELECT * FROM storage_object
WHERE created_at < ? AND deleted_at is NULL
ORDER BY created_at desc LIMIT ?")
(defn get-chunk
[conn cursor]
(let [rows (db/exec! conn [sql:retrieve-sobjects-chunk cursor chunk-size])]
[(some->> rows peek :created-at) (seq rows)]))
(defn get-candidates
[conn]
(->> (d/iteration (partial get-chunk conn)
:vf second
:kf first
:initk (dt/now))
(sequence cat)))
(def modules
[:app.db/pool
:app.storage/storage
[:app.main/default :app.worker/executor]
[:app.main/assets :app.storage.s3/backend]
[:app.main/assets :app.storage.fs/backend]])
(def system
(let [config (select-keys app.main/system-config modules)
config (-> config
(assoc :app.migrations/all {})
(assoc :app.metrics/metrics nil))]
(ig/load-namespaces config)
(-> config ig/prep ig/init)))
(defn update-fn
[{:keys [conn] :as storage} {:keys [id backend] :as row}]
(cond
(= backend "s3")
(do
(l/info :hint "rename storage object backend"
:id id
:from-backend backend
:to-backend :assets-s3)
(assoc row :backend "assets-s3"))
(= backend "assets-s3")
(do
(l/info :hint "ignoring storage object" :id id :backend backend)
nil)
(or (= backend "fs")
(= backend "assets-fs"))
(let [sobj (sto/row->storage-object row)
path (-> (sto/get-object-path storage sobj) deref)]
(l/info :hint "change storage object backend"
:id id
:from-backend backend
:to-backend :assets-s3)
(when-not noop?
(-> (impl/resolve-backend storage :assets-s3)
(impl/put-object sobj (sto/content path))
(deref)))
(assoc row :backend "assets-s3"))
:else
(throw (IllegalArgumentException. "unexpected backend found"))))
(try
(db/with-atomic [conn (:app.db/pool system)]
(let [storage (:app.storage/storage system)
storage (assoc storage :conn conn)]
(loop [items (get-candidates conn)]
(when-let [item (first items)]
(when-let [{:keys [id] :as row} (update-fn storage item)]
(db/update! conn :storage-object (dissoc row :id) {:id (:id item)}))
(recur (rest items))))
(when noop?
(throw (ex-info "explicit rollback" {})))))
(catch Throwable cause
(cond
(= "explicit rollback" (ex-message cause))
(l/warn :hint "transaction aborted")
:else
(l/error :hint "unexpected exception" :cause cause))))
(ig/halt! system)
(System/exit 0)

54
backend/resources/api-doc-entry.tmpl Normal file
View file

@ -0,0 +1,54 @@
<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">
{% if item.deprecated %}
<span class="tag">
<span>Deprecated:</span>
<span>since v{{item.deprecated}}</span>,
</span>
{% endif %}
<span class="tag">
<span>Auth:</span>
<span>{% if item.auth %}YES{% else %}NO{% endif %}</span>
</span>
</div>
</div>
<div class="rpc-row-detail hidden">
<h3>DOCSTRING:</h3>
<section class="padded-section">
{% if item.added %}
<p class="small"><strong>Added:</strong> on v{{item.added}}</p>
{% endif %}
{% if item.deprecated %}
<p class="small"><strong>Deprecated:</strong> since v{{item.deprecated}}</p>
{% endif %}
{% if item.docs %}
<p class="docstring"> {{item.docs}}</p>
{% endif %}
</section>
{% if item.changes %}
<h3>CHANGES:</h3>
<section class="padded-section">
<ul class="changes">
{% for change in item.changes %}
<li><strong>{{change.0}}</strong> - {{change.1}}</li>
{% endfor %}
</ul>
</section>
{% endif %}
<h3>SPEC EXPLAIN:</h3>
<section class="padded-section">
<pre class="spec-explain">{{item.spec}}</pre>
</section>
</div>
</li>

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

@ -53,7 +53,7 @@ header {
.rpc-item {
/* border: 1px solid red; */
cursor: pointer;
/* cursor: pointer; */
display: flex;
flex-direction: column;
}
@ -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 {
@ -99,3 +109,37 @@ header {
padding: 5px 10px;
padding-bottom: 20px;
}
.rpc-row-detail p {
font-weight: 200;
}
.rpc-row-detail p.small {
margin-top: 2px;
margin-bottom: 2px;
font-size: 10px;
}
.rpc-row-detail p.small {
margin-top: 2px;
margin-bottom: 2px;
font-size: 10px;
}
.rpc-row-detail strong {
font-weight: 500;
}
.rpc-row-detail .changes {
font-weight: 200;
list-style: none;
padding: 0px;
}
.rpc-row-detail .padded-section {
padding: 0px 10px;
}
p.small strong {
font-size: 10px;
}

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

@ -5,7 +5,10 @@
<meta name="robots" content="noindex,nofollow">
<meta http-equiv="x-ua-compatible" content="ie=edge" />
<title>Builtin API Documentation - Penpot</title>
<link rel="stylesheet" href="https://fonts.googleapis.com/css2?family=JetBrains+Mono">
<link rel="preconnect" href="https://fonts.googleapis.com">
<link rel="preconnect" href="https://fonts.gstatic.com" crossorigin>
<link href="https://fonts.googleapis.com/css2?family=JetBrains+Mono:wght@200;300;400;500;700&display=swap" rel="stylesheet">
<style>
{% include "api-doc.css" %}
</style>
@ -16,61 +19,28 @@
<body>
<main>
<header>
<h1>Penpot API Documentation</h1>
<h1>Penpot API Documentation (v{{version}})</h1>
</header>
<section class="rpc-doc-content">
<h2>RPC COMMAND METHODS:</h2>
<ul class="rpc-items">
{% for item in command-methods %}
{% include "api-doc-entry.tmpl" with item=item %}
{% 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="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>
{% include "api-doc-entry.tmpl" with item=item %}
{% endfor %}
</ul>
<h2>RPC MUTATION METHODS:</h2>
<ul class="rpc-items">
{% for item in mutation-methods %}
<li class="rpc-item">
<div class="rpc-row-info">
{# <div class="type">{{item.type}}</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>
{% include "api-doc-entry.tmpl" with item=item %}
{% endfor %}
</ul>
</section>

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="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.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>

9
backend/resources/log4j2.xml
View file

@ -7,14 +7,11 @@
</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" level="debug" additivity="false">
<AppenderRef ref="console" />
</Logger>
<Logger name="penpot" level="fatal" additivity="false">
<Logger name="app" level="info" additivity="false">
<AppenderRef ref="console" />
</Logger>

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."))

51
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]
@ -41,8 +42,7 @@
data))
(def defaults
{
:database-uri "postgresql://postgres/penpot"
{:database-uri "postgresql://postgres/penpot"
:database-username "penpot"
:database-password "penpot"
@ -79,24 +79,20 @@
: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)
;; DEPRECATED PROPERTIES
(s/def ::registration-enabled ::us/boolean)
(s/def ::smtp-enabled ::us/boolean)
(s/def ::media-max-file-size ::us/integer)
(s/def ::flags ::us/vec-of-valid-keywords)
(s/def ::telemetry-enabled ::us/boolean)
(s/def ::asserts-enabled ::us/boolean)
;; END DEPRECATED
(s/def ::audit-log-archive-uri ::us/string)
(s/def ::audit-log-gc-max-age ::dt/duration)
(s/def ::admins ::us/set-of-str)
(s/def ::admins ::us/set-of-non-empty-strings)
(s/def ::file-change-snapshot-every ::us/integer)
(s/def ::file-change-snapshot-timeout ::dt/duration)
@ -104,10 +100,14 @@
(s/def ::blocking-executor-parallelism ::us/integer)
(s/def ::worker-executor-parallelism ::us/integer)
(s/def ::authenticated-cookie-domain ::us/string)
(s/def ::authenticated-cookie-name ::us/string)
(s/def ::auth-token-cookie-name ::us/string)
(s/def ::auth-token-cookie-max-age ::dt/duration)
(s/def ::secret-key ::us/string)
(s/def ::allow-demo-users ::us/boolean)
(s/def ::assets-path ::us/string)
(s/def ::authenticated-cookie-domain ::us/string)
(s/def ::database-password (s/nilable ::us/string))
(s/def ::database-uri ::us/string)
(s/def ::database-username (s/nilable ::us/string))
@ -131,8 +131,8 @@
(s/def ::oidc-token-uri ::us/string)
(s/def ::oidc-auth-uri ::us/string)
(s/def ::oidc-user-uri ::us/string)
(s/def ::oidc-scopes ::us/set-of-str)
(s/def ::oidc-roles ::us/set-of-str)
(s/def ::oidc-scopes ::us/set-of-non-empty-strings)
(s/def ::oidc-roles ::us/set-of-non-empty-strings)
(s/def ::oidc-roles-attr ::us/keyword)
(s/def ::oidc-email-attr ::us/keyword)
(s/def ::oidc-name-attr ::us/keyword)
@ -143,13 +143,9 @@
(s/def ::http-server-max-multipart-body-size ::us/integer)
(s/def ::http-server-io-threads ::us/integer)
(s/def ::http-server-worker-threads ::us/integer)
(s/def ::http-session-idle-max-age ::dt/duration)
(s/def ::http-session-updater-batch-max-age ::dt/duration)
(s/def ::http-session-updater-batch-max-size ::us/integer)
(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)
@ -169,7 +165,7 @@
(s/def ::profile-complaint-threshold ::us/integer)
(s/def ::public-uri ::us/string)
(s/def ::redis-uri ::us/string)
(s/def ::registration-domain-whitelist ::us/set-of-str)
(s/def ::registration-domain-whitelist ::us/set-of-non-empty-strings)
(s/def ::rlimit-font ::us/integer)
(s/def ::rlimit-file-update ::us/integer)
(s/def ::rlimit-image ::us/integer)
@ -210,6 +206,9 @@
::allow-demo-users
::audit-log-archive-uri
::audit-log-gc-max-age
::auth-token-cookie-name
::auth-token-cookie-max-age
::authenticated-cookie-name
::authenticated-cookie-domain
::database-password
::database-uri
@ -250,13 +249,9 @@
::http-server-max-multipart-body-size
::http-server-io-threads
::http-server-worker-threads
::http-session-idle-max-age
::http-session-updater-batch-max-age
::http-session-updater-batch-max-size
::initial-project-skey
::ldap-attrs-email
::ldap-attrs-fullname
::ldap-attrs-photo
::ldap-attrs-username
::ldap-base-dn
::ldap-bind-dn
@ -269,6 +264,7 @@
::local-assets-uri
::loggers-loki-uri
::loggers-zmq-uri
::media-max-file-size
::profile-bounce-max-age
::profile-bounce-threshold
::profile-complaint-max-age
@ -276,7 +272,6 @@
::public-uri
::redis-uri
::registration-domain-whitelist
::registration-enabled
::rlimit-font
::rlimit-file-update
::rlimit-image
@ -287,7 +282,6 @@
::sentry-trace-sample-rate
::smtp-default-from
::smtp-default-reply-to
::smtp-enabled
::smtp-host
::smtp-password
::smtp-port
@ -314,6 +308,7 @@
(def default-flags
[:enable-backend-api-doc
:enable-backend-worker
:enable-secure-session-cookies])
(defn- parse-flags
@ -354,8 +349,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}))

80
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))
@ -311,9 +323,9 @@
(and (pgarray? v) (= "uuid" (.getBaseTypeName ^PgArray v))))
(defn decode-pgarray
([v] (into [] (.getArray ^PgArray v)))
([v in] (into in (.getArray ^PgArray v)))
([v in xf] (into in xf (.getArray ^PgArray v))))
([v] (some->> ^PgArray v .getArray vec))
([v in] (some->> ^PgArray v .getArray (into in)))
([v in xf] (some->> ^PgArray v .getArray (into in xf))))
(defn pgarray->set
[v]

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}}]]]]]))

2
backend/src/app/http/assets.clj
View file

@ -29,7 +29,7 @@
(defn coerce-id
[id]
(let [res (us/uuid-conformer id)]
(let [res (parse-uuid id)]
(when-not (uuid? res)
(ex/raise :type :not-found
:hint "object not found"))

7
backend/src/app/http/awsns.clj
View file

@ -16,6 +16,7 @@
[integrant.core :as ig]
[jsonista.core :as j]
[promesa.exec :as px]
[yetti.request :as yrq]
[yetti.response :as yrs]))
(declare parse-json)
@ -31,9 +32,9 @@
(defmethod ig/init-key ::handler
[_ {:keys [executor] :as cfg}]
(fn [request respond _]
(let [data (slurp (:body request))]
(px/run! executor #(handle-request cfg data))
(respond (yrs/response 200)))))
(let [data (-> request yrq/body slurp)]
(px/run! executor #(handle-request cfg data)))
(respond (yrs/response 200))))
(defn handle-request
[{:keys [http-client] :as cfg} data]

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

@ -5,36 +5,38 @@
;; 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.spec :as us]
[app.common.pprint :as pp]
[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 +44,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 +69,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 +79,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 +96,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,47 +160,51 @@
(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])
id (us/uuid-conformer id)]
id (parse-uuid id)]
(when (uuid? id)
id)))
@ -176,9 +216,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 +245,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 +258,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 +357,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}]])

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

@ -1,54 +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.http.doc
"API autogenerated documentation."
(:require
[app.common.data :as d]
[app.config :as cf]
[app.util.services :as sv]
[app.util.template :as tmpl]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[pretty-spec.core :as ps]
[yetti.response :as yrs]))
(defn get-spec-str
[k]
(with-out-str
(ps/pprint (s/form k)
{:ns-aliases {"clojure.spec.alpha" "s"
"clojure.core.specs.alpha" "score"
"clojure.core" nil}})))
(defn prepare-context
[rpc]
(letfn [(gen-doc [type [name f]]
(let [mdata (meta f)]
;; (prn name mdata)
{:type (d/name type)
:name (d/name name)
: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)
(fn [_ respond _]
(respond (yrs/response 200 (-> (io/resource "api-doc.tmpl")
(tmpl/render context)))))
(fn [_ respond _]
(respond (yrs/response 404))))))

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)]

24
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]
@ -35,14 +37,14 @@
(let [header (yrq/get-header request "content-type")]
(cond
(str/starts-with? header "application/transit+json")
(with-open [is (-> request yrq/body yrq/body-stream)]
(with-open [is (yrq/body request)]
(let [params (t/read! (t/reader is))]
(-> request
(assoc :body-params params)
(update :params merge params))))
(str/starts-with? header "application/json")
(with-open [is (-> request yrq/body yrq/body-stream)]
(with-open [is (yrq/body request)]
(let [params (json/read is)]
(-> request
(assoc :body-params params)
@ -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)))))})

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

@ -7,33 +7,35 @@
(ns app.http.session
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.config :as cfg]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as sql]
[app.metrics :as mtx]
[app.util.async :as aa]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.core.async :as a]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px]
[yetti.request :as yrq]))
;; A default cookie name for storing the session. We don't allow to configure it.
(def token-cookie-name "auth-token")
;; A default cookie name for storing the session.
(def default-auth-token-cookie-name "auth-token")
;; A cookie that we can use to check from other sites of the same domain if a user
;; is registered. Is not intended for on premise installations, although nothing
;; prevents using it if some one wants to.
(def authenticated-cookie-name "authenticated")
;; A cookie that we can use to check from other sites of the same
;; domain if a user is authenticated.
(def default-authenticated-cookie-name "authenticated")
;; Default value for cookie max-age
(def default-cookie-max-age (dt/duration {:days 7}))
;; Default age for automatic session renewal
(def default-renewal-max-age (dt/duration {:hours 6}))
(defprotocol ISessionStore
(read-session [store key])
(write-session [store key data])
(update-session [store data])
(delete-session [store key]))
(defn- make-database-store
@ -47,18 +49,25 @@
(px/with-dispatch executor
(let [profile-id (:profile-id data)
user-agent (:user-agent data)
created-at (or (:created-at data) (dt/now))
token (tokens :generate {:iss "authentication"
:iat (dt/now)
:iat created-at
:uid profile-id})
now (dt/now)
params {:user-agent user-agent
:profile-id profile-id
:created-at now
:updated-at now
:created-at created-at
:updated-at created-at
:id token}]
(db/insert! pool :http-session params)
token)))
(db/insert! pool :http-session params))))
(update-session [_ data]
(let [updated-at (dt/now)]
(px/with-dispatch executor
(db/update! pool :http-session
{:updated-at updated-at}
{:id (:id data)})
(assoc data :updated-at updated-at))))
(delete-session [_ token]
(px/with-dispatch executor
@ -76,15 +85,23 @@
(p/do
(let [profile-id (:profile-id data)
user-agent (:user-agent data)
created-at (or (:created-at data) (dt/now))
token (tokens :generate {:iss "authentication"
:iat (dt/now)
:iat created-at
:uid profile-id})
params {:user-agent user-agent
:created-at created-at
:updated-at created-at
:profile-id profile-id
:id token}]
(swap! cache assoc token params)
token)))
params)))
(update-session [_ data]
(let [updated-at (dt/now)]
(swap! cache update (:id data) assoc :updated-at updated-at)
(assoc data :updated-at updated-at)))
(delete-session [_ token]
(p/do
@ -107,76 +124,123 @@
;; --- IMPL
(defn- create-session!
[store request profile-id]
(let [params {:user-agent (yrq/get-header request "user-agent")
[store profile-id user-agent]
(let [params {:user-agent user-agent
:profile-id profile-id}]
(write-session store nil params)))
(defn- update-session!
[store session]
(update-session store session))
(defn- delete-session!
[store {:keys [cookies] :as request}]
(when-let [token (get-in cookies [token-cookie-name :value])]
(delete-session store token)))
(let [name (cf/get :auth-token-cookie-name default-auth-token-cookie-name)]
(when-let [token (get-in cookies [name :value])]
(delete-session store token))))
(defn- retrieve-session
[store request]
(when-let [cookie (yrq/get-cookie request token-cookie-name)]
(-> (read-session store (:value cookie))
(p/then (fn [session]
(when session
{:session-id (:id session)
:profile-id (:profile-id session)}))))))
(let [cookie-name (cf/get :auth-token-cookie-name default-auth-token-cookie-name)]
(when-let [cookie (yrq/get-cookie request cookie-name)]
(read-session store (:value cookie)))))
(defn- add-cookies
[response token]
(let [cors? (contains? cfg/flags :cors)
secure? (contains? cfg/flags :secure-session-cookies)
authenticated-cookie-domain (cfg/get :authenticated-cookie-domain)]
(update response :cookies
(fn [cookies]
(cond-> cookies
:always
(assoc token-cookie-name {:path "/"
:http-only true
:value token
:same-site (if cors? :none :lax)
:secure secure?})
(defn assign-auth-token-cookie
[response {token :id updated-at :updated-at}]
(let [max-age (cf/get :auth-token-cookie-max-age default-cookie-max-age)
created-at (or updated-at (dt/now))
renewal (dt/plus created-at default-renewal-max-age)
expires (dt/plus created-at max-age)
secure? (contains? cf/flags :secure-session-cookies)
cors? (contains? cf/flags :cors)
name (cf/get :auth-token-cookie-name default-auth-token-cookie-name)
comment (str "Renewal at: " (dt/format-instant renewal :rfc1123))
cookie {:path "/"
:http-only true
:expires expires
:value token
:comment comment
:same-site (if cors? :none :lax)
:secure secure?}]
(update response :cookies assoc name cookie)))
(some? authenticated-cookie-domain)
(assoc authenticated-cookie-name {:domain authenticated-cookie-domain
:path "/"
:value true
:same-site :strict
:secure secure?}))))))
(defn assign-authenticated-cookie
[response {updated-at :updated-at}]
(let [max-age (cf/get :auth-token-cookie-max-age default-cookie-max-age)
created-at (or updated-at (dt/now))
renewal (dt/plus created-at default-renewal-max-age)
expires (dt/plus created-at max-age)
comment (str "Renewal at: " (dt/format-instant renewal :rfc1123))
secure? (contains? cf/flags :secure-session-cookies)
domain (cf/get :authenticated-cookie-domain)
name (cf/get :authenticated-cookie-name "authenticated")
cookie {:domain domain
:expires expires
:path "/"
:comment comment
:value true
:same-site :strict
:secure secure?}]
(cond-> response
(string? domain)
(update :cookies assoc name cookie))))
(defn- clear-cookies
(defn clear-auth-token-cookie
[response]
(let [authenticated-cookie-domain (cfg/get :authenticated-cookie-domain)]
(assoc response :cookies
{token-cookie-name {:path "/"
:value ""
:max-age -1}
authenticated-cookie-name {:domain authenticated-cookie-domain
:path "/"
:value ""
:max-age -1}})))
(let [name (cf/get :auth-token-cookie-name default-auth-token-cookie-name)]
(update response :cookies assoc name {:path "/" :value "" :max-age -1})))
(defn- clear-authenticated-cookie
[response]
(let [name (cf/get :authenticated-cookie-name default-authenticated-cookie-name)
domain (cf/get :authenticated-cookie-domain)]
(cond-> response
(string? domain)
(update :cookies assoc name {:domain domain :path "/" :value "" :max-age -1}))))
(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
(when-let [session-id (:session-id request)]
(a/offer! events-ch session-id))
(handler request respond raise))))))
(catch Throwable cause
(raise cause)))))})
[{:keys [store] :as cfg}]
(letfn [;; Check if time reached for automatic session renewal
(renew-session? [{:keys [updated-at] :as session}]
(and (dt/instant? updated-at)
(let [elapsed (dt/diff updated-at (dt/now))]
(neg? (compare default-renewal-max-age elapsed)))))
;; Wrap respond with session renewal code
(wrap-respond [respond session]
(fn [response]
(p/let [session (update-session! store session)]
(-> response
(assign-auth-token-cookie session)
(assign-authenticated-cookie session)
(respond)))))]
{:name :session
:compile (fn [& _]
(fn [handler]
(fn [request respond raise]
(try
(-> (retrieve-session store request)
(p/finally (fn [session cause]
(cond
(some? cause)
(raise cause)
(nil? session)
(handler request respond raise)
:else
(let [request (-> request
(assoc :profile-id (:profile-id session))
(assoc :session-id (:id session)))
respond (cond-> respond
(renew-session? session)
(wrap-respond session))]
(handler request respond raise))))))
(catch Throwable cause
(raise cause))))))}))
;; --- STATE INIT: SESSION
@ -193,77 +257,23 @@
(defmethod ig/init-key :app.http/session
[_ {:keys [store] :as cfg}]
(let [events-ch (a/chan (a/dropping-buffer (:buffer-size cfg)))
cfg (assoc cfg ::events-ch events-ch)]
(-> cfg
(assoc :middleware (make-middleware cfg))
(assoc :create (fn [profile-id]
(fn [request response]
(p/let [token (create-session! store request profile-id)]
(add-cookies response token)))))
(assoc :delete (fn [request response]
(p/do
(delete-session! store request)
(-> cfg
(assoc :middleware (make-middleware cfg))
(assoc :create (fn [profile-id]
(fn [request response]
(p/let [uagent (yrq/get-header request "user-agent")
session (create-session! store profile-id uagent)]
(-> response
(assoc :status 204)
(assoc :body nil)
(clear-cookies))))))))
(defmethod ig/halt-key! :app.http/session
[_ data]
(a/close! (::events-ch data)))
;; --- STATE INIT: SESSION UPDATER
(declare update-sessions)
(s/def ::session map?)
(s/def ::max-batch-age ::cfg/http-session-updater-batch-max-age)
(s/def ::max-batch-size ::cfg/http-session-updater-batch-max-size)
(defmethod ig/pre-init-spec ::updater [_]
(s/keys :req-un [::db/pool ::wrk/executor ::mtx/metrics ::session]
:opt-un [::max-batch-age ::max-batch-size]))
(defmethod ig/prep-key ::updater
[_ cfg]
(merge {:max-batch-age (dt/duration {:minutes 5})
:max-batch-size 200}
(d/without-nils cfg)))
(defmethod ig/init-key ::updater
[_ {:keys [session metrics] :as cfg}]
(l/info :action "initialize session updater"
:max-batch-age (str (:max-batch-age cfg))
:max-batch-size (str (:max-batch-size cfg)))
(let [input (aa/batch (::events-ch session)
{:max-batch-size (:max-batch-size cfg)
:max-batch-age (inst-ms (:max-batch-age cfg))})]
(a/go-loop []
(when-let [[reason batch] (a/<! input)]
(let [result (a/<! (update-sessions cfg batch))]
(mtx/run! metrics {:id :session-update-total :inc 1})
(cond
(ex/exception? result)
(l/error :task "updater"
:hint "unexpected error on update sessions"
:cause result)
(= :size reason)
(l/debug :task "updater"
:hint "update sessions"
:reason (name reason)
:count result))
(recur))))))
(defn- update-sessions
[{:keys [pool executor]} ids]
(aa/with-thread executor
(db/exec-one! pool ["update http_session set updated_at=now() where id = ANY(?)"
(into-array String ids)])
(count ids)))
(assign-auth-token-cookie session)
(assign-authenticated-cookie session))))))
(assoc :delete (fn [request response]
(p/do
(delete-session! store request)
(-> response
(assoc :status 204)
(assoc :body nil)
(clear-auth-token-cookie)
(clear-authenticated-cookie)))))))
;; --- STATE INIT: SESSION GC
@ -277,7 +287,7 @@
(defmethod ig/prep-key ::gc-task
[_ cfg]
(merge {:max-age (dt/duration {:days 15})}
(merge {:max-age default-cookie-max-age}
(d/without-nils cfg)))
(defmethod ig/init-key ::gc-task

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)))))))

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

@ -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

240
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,11 +72,14 @@
: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)
:executor (ig/ref [::worker :app.worker/executor])
:min-age (dt/duration {:hours 2})}
:executor (ig/ref [::worker :app.worker/executor])}
:app.storage/gc-touched-task
{:pool (ig/ref :app.db/pool)}
@ -93,15 +97,7 @@
:app.http.session/gc-task
{:pool (ig/ref :app.db/pool)
:max-age (cf/get :http-session-idle-max-age)}
:app.http.session/updater
{:pool (ig/ref :app.db/pool)
:metrics (ig/ref :app.metrics/metrics)
:executor (ig/ref [::worker :app.worker/executor])
:session (ig/ref :app.http/session)
:max-batch-age (cf/get :http-session-updater-batch-max-age)
:max-batch-size (cf/get :http-session-updater-batch-max-size)}
:max-age (cf/get :auth-token-cookie-max-age)}
:app.http.awsns/handler
{:tokens (ig/ref :app.tokens/tokens)
@ -119,25 +115,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.rpc.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 +215,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,56 +224,15 @@
: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.worker/worker
{:executor (ig/ref [::worker :app.worker/executor])
:tasks (ig/ref :app.worker/registry)
:metrics (ig/ref :app.metrics/metrics)
:pool (ig/ref :app.db/pool)}
:app.rpc.doc/routes
{:methods (ig/ref :app.rpc/methods)}
:app.worker/cron
{:executor (ig/ref [::worker :app.worker/executor])
:scheduler (ig/ref :app.worker/scheduler)
:tasks (ig/ref :app.worker/registry)
:pool (ig/ref :app.db/pool)
:entries
[{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :file-gc}
{:cron #app/cron "0 0 * * * ?" ;; hourly
:task :file-xlog-gc}
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :storage-deleted-gc}
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :storage-touched-gc}
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :session-gc}
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :objects-gc}
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :tasks-gc}
{:cron #app/cron "0 30 */3,23 * * ?"
:task :telemetry}
(when (cf/get :fdata-storage-backed)
{:cron #app/cron "0 0 * * * ?" ;; hourly
:task :file-offload})
(when (contains? cf/flags :audit-log-archive)
{:cron #app/cron "0 */5 * * * ?" ;; every 5m
:task :audit-log-archive})
(when (contains? cf/flags :audit-log-gc)
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :audit-log-gc})]}
:app.rpc/routes
{:methods (ig/ref :app.rpc/methods)}
:app.worker/registry
{:metrics (ig/ref :app.metrics/metrics)
@ -233,12 +241,11 @@
:objects-gc (ig/ref :app.tasks.objects-gc/handler)
:file-gc (ig/ref :app.tasks.file-gc/handler)
:file-xlog-gc (ig/ref :app.tasks.file-xlog-gc/handler)
:storage-deleted-gc (ig/ref :app.storage/gc-deleted-task)
:storage-touched-gc (ig/ref :app.storage/gc-touched-task)
:storage-gc-deleted (ig/ref :app.storage/gc-deleted-task)
:storage-gc-touched (ig/ref :app.storage/gc-touched-task)
:tasks-gc (ig/ref :app.tasks.tasks-gc/handler)
:telemetry (ig/ref :app.tasks.telemetry/handler)
:session-gc (ig/ref :app.http.session/gc-task)
:file-offload (ig/ref :app.tasks.file-offload/handler)
:audit-log-archive (ig/ref :app.loggers.audit/archive-task)
:audit-log-gc (ig/ref :app.loggers.audit/gc-task)}}
@ -259,22 +266,13 @@
:app.tasks.objects-gc/handler
{:pool (ig/ref :app.db/pool)
:storage (ig/ref :app.storage/storage)
:max-age cf/deletion-delay}
:storage (ig/ref :app.storage/storage)}
:app.tasks.file-gc/handler
{:pool (ig/ref :app.db/pool)
:max-age cf/deletion-delay}
{:pool (ig/ref :app.db/pool)}
:app.tasks.file-xlog-gc/handler
{:pool (ig/ref :app.db/pool)
:max-age (dt/duration {:hours 72})}
:app.tasks.file-offload/handler
{:pool (ig/ref :app.db/pool)
:max-age (dt/duration {:seconds 5})
:storage (ig/ref :app.storage/storage)
:backend (cf/get :fdata-storage-backed :fdata-s3)}
{:pool (ig/ref :app.db/pool)}
:app.tasks.telemetry/handler
{:pool (ig/ref :app.db/pool)
@ -336,23 +334,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,21 +348,64 @@
[::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 worker-config
{ :app.worker/cron
{:executor (ig/ref [::worker :app.worker/executor])
:scheduler (ig/ref :app.worker/scheduler)
:tasks (ig/ref :app.worker/registry)
:pool (ig/ref :app.db/pool)
:entries
[{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :file-gc}
{:cron #app/cron "0 0 * * * ?" ;; hourly
:task :file-xlog-gc}
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :storage-gc-deleted}
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :storage-gc-touched}
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :session-gc}
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :objects-gc}
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :tasks-gc}
{:cron #app/cron "0 30 */3,23 * * ?"
:task :telemetry}
(when (contains? cf/flags :audit-log-archive)
{:cron #app/cron "0 */5 * * * ?" ;; every 5m
:task :audit-log-archive})
(when (contains? cf/flags :audit-log-gc)
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :audit-log-gc})]}
:app.worker/worker
{:executor (ig/ref [::worker :app.worker/executor])
:tasks (ig/ref :app.worker/registry)
:metrics (ig/ref :app.metrics/metrics)
:pool (ig/ref :app.db/pool)}})
(def system nil)
(defn start
[]
(ig/load-namespaces system-config)
(ig/load-namespaces (merge system-config worker-config))
(alter-var-root #'system (fn [sys]
(when sys (ig/halt! sys))
(-> system-config
(cond-> (contains? cf/flags :backend-worker)
(merge worker-config))
(ig/prep)
(ig/init))))
(l/info :msg "welcome to penpot"

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))))

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

@ -6,7 +6,7 @@
(ns app.migrations
(:require
[app.migrations.migration-0023 :as mg0023]
[app.migrations.clj.migration-0023 :as mg0023]
[app.util.migrations :as mg]
[integrant.core :as ig]))
@ -226,6 +226,24 @@
{: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")}
{:name "0076-mod-storage-object-table"
:fn (mg/resource "app/migrations/sql/0076-mod-storage-object-table.sql")}
{:name "0077-mod-comment-thread-table"
:fn (mg/resource "app/migrations/sql/0077-mod-comment-thread-table.sql")}
{:name "0078-mod-file-media-object-table-drop-cascade"
:fn (mg/resource "app/migrations/sql/0078-mod-file-media-object-table-drop-cascade.sql")}
])

2
backend/src/app/migrations/migration_0023.clj → backend/src/app/migrations/clj/migration_0023.clj
View file

@ -4,7 +4,7 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.migrations.migration-0023
(ns app.migrations.clj.migration-0023
(:require
[app.db :as db]
[app.util.blob :as blob]))

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

10
backend/src/app/migrations/sql/0076-mod-storage-object-table.sql Normal file
View file

@ -0,0 +1,10 @@
-- Renames the old, already deprecated backend name with new one on
-- all storage object rows.
UPDATE storage_object
SET backend = 'assets-fs'
WHERE backend = 'fs';
UPDATE storage_object
SET backend = 'assets-s3'
WHERE backend = 's3';

3
backend/src/app/migrations/sql/0077-mod-comment-thread-table.sql Normal file
View file

@ -0,0 +1,3 @@
--- Add frame_id field.
ALTER TABLE comment_thread
ADD COLUMN frame_id uuid NULL DEFAULT '00000000-0000-0000-0000-000000000000';

9
backend/src/app/migrations/sql/0078-mod-file-media-object-table-drop-cascade.sql Normal file
View file

@ -0,0 +1,9 @@
ALTER TABLE file_media_object
DROP CONSTRAINT file_media_object_media_id_fkey,
ADD CONSTRAINT file_media_object_media_id_fkey
FOREIGN KEY (media_id) REFERENCES storage_object(id) ON DELETE NO ACTION DEFERRABLE;
ALTER TABLE file_media_object
DROP CONSTRAINT file_media_object_thumbnail_id_fkey,
ADD CONSTRAINT file_media_object_thumbnail_id_fkey
FOREIGN KEY (thumbnail_id) REFERENCES storage_object(id) ON DELETE NO ACTION DEFERRABLE;

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))

106
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]
@ -162,7 +186,7 @@
spec (or (::sv/spec mdata) (s/spec any?))
auth? (:auth mdata true)]
(l/trace :action "register" :name (::sv/name mdata))
(l/debug :hint "register method" :name (::sv/name mdata))
(with-meta
(fn [{:keys [::request] :as params}]
;; Raise authentication error when rpc method requires auth but
@ -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,82 @@
(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.comments
'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}}]]])

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

@ -0,0 +1,428 @@
;; 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.doc :as-alias doc]
[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)
::doc/added "1.15"}
[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
::doc/added "1.15"}
[{: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)
::doc/added "1.15"}
[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
::doc/added "1.15"}
[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)
::doc/added "1.15"}
[{: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
::doc/added "1.15"}
[cfg params]
(request-profile-recovery cfg params))

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

@ -0,0 +1,868 @@
;; 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.doc :as-alias doc]
[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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DEFAULTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Threshold in MiB when we pass from using
;; in-memory byte-array's to use temporal files.
(def temp-file-threshold
(* 1024 1024 2))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LOW LEVEL STREAM IO API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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!
[^OutputStream output version]
(l/trace :fn "write-header!"
:version version
:position @*position*
::l/async false)
(let [vers (-> version name (subs 1) parse-long)
output (bs/data-output-stream output)]
(doto output
(write-byte! (get-mark :header))
(write-long! penpot-magic-number)
(write-long! vers))))
(defn read-header!
[^InputStream input]
(l/trace :fn "read-header!" :position @*position* ::l/async false)
(let [input (bs/data-input-stream input)
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
:hint "invalid penpot file"))
(keyword (str "v" 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 id] :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)]
;; We assoc the file-id again to the file-media-object row
;; because there are cases that used objects refer to other
;; files and we need to ensure in the exportation process that
;; all ids matches
(->> (db/exec! conn [sql:file-media-objects ids])
(mapv #(assoc % :file-id id))))))
(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)])))
(defn- create-or-update-file
[conn 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)])))
;; --- GENERAL PURPOSE DYNAMIC VARS
(def ^:dynamic *state*)
(def ^:dynamic *options*)
;; --- EXPORT WRITTER
(defn- embed-file-assets
[data conn file-id]
(letfn [(walk-map-form [form state]
(cond
(uuid? (:fill-color-ref-file form))
(do
(vswap! state conj [(:fill-color-ref-file form) :colors (:fill-color-ref-id form)])
(assoc form :fill-color-ref-file file-id))
(uuid? (:stroke-color-ref-file form))
(do
(vswap! state conj [(:stroke-color-ref-file form) :colors (:stroke-color-ref-id form)])
(assoc form :stroke-color-ref-file file-id))
(uuid? (:typography-ref-file form))
(do
(vswap! state conj [(:typography-ref-file form) :typographies (:typography-ref-id form)])
(assoc form :typography-ref-file file-id))
(uuid? (:component-file form))
(do
(vswap! state conj [(:component-file form) :components (:component-id form)])
(assoc form :component-file file-id))
:else
form))
(process-group-of-assets [data [lib-id items]]
;; NOTE: there 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 conn lib-id)]
(reduce (partial process-asset lib) data items)
data))
(process-asset [lib data [bucket asset-id]]
(let [asset (get-in lib [:data bucket asset-id])
;; Add a special case for colors that need to have
;; correctly set the :file-id prop (pending of the
;; refactor that will remove it).
asset (cond-> asset
(= bucket :colors) (assoc :file-id file-id))]
(update data bucket assoc asset-id asset)))]
(let [assets (volatile! [])]
(walk/postwalk #(cond-> % (map? %) (walk-map-form assets)) data)
(->> (deref assets)
(filter #(as-> (first %) $ (and (uuid? $) (not= $ file-id))))
(d/group-by first rest)
(reduce (partial process-group-of-assets) data)))))
(defmulti write-export ::version)
(defmulti write-section ::section)
(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 [::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")
(write-export options))
(defmethod write-export :default
[{:keys [::output] :as options}]
(write-header! output :v1)
(with-open [output (bs/zstd-output-stream output :level 12)]
(with-open [output (bs/data-output-stream output)]
(binding [*state* (volatile! {})]
(run! (fn [section]
(l/debug :hint "write section" :section section ::l/async false)
(write-label! output section)
(let [options (-> options
(assoc ::output output)
(assoc ::section section))]
(binding [*options* options]
(write-section options))))
[:v1/metadata :v1/files :v1/rels :v1/sobjects])))))
(defmethod write-section :v1/metadata
[{:keys [pool ::output ::file-ids ::include-libraries?]}]
(let [libs (when include-libraries?
(retrieve-libraries pool file-ids))
files (into file-ids libs)]
(write-obj! output {:version cf/version :files files})
(vswap! *state* assoc :files files)))
(defmethod write-section :v1/files
[{:keys [pool ::output ::embed-assets?]}]
;; Initialize SIDS with empty vector
(vswap! *state* assoc :sids [])
(doseq [file-id (-> *state* deref :files)]
(let [file (cond-> (retrieve-file pool file-id)
embed-assets?
(update :data embed-file-assets pool file-id))
media (retrieve-file-media pool file)]
(l/debug :hint "write penpot file"
:id file-id
:media (count media)
::l/async false)
(doto output
(write-obj! file)
(write-obj! media))
(vswap! *state* update :sids into storage-object-id-xf media))))
(defmethod write-section :v1/rels
[{:keys [pool ::output ::include-libraries?]}]
(let [rels (when include-libraries?
(retrieve-library-relations pool (-> *state* deref :files)))]
(l/debug :hint "found rels" :total (count rels) ::l/async false)
(write-obj! output rels)))
(defmethod write-section :v1/sobjects
[{:keys [storage ::output]}]
(let [sids (-> *state* deref :sids)
storage (media/configure-assets-storage storage)]
(l/debug :hint "found sobjects"
:items (count sids)
::l/async false)
;; Write all collected storage objects
(write-obj! output sids)
(doseq [id sids]
(let [{:keys [size] :as obj} @(sto/get-object storage id)]
(l/debug :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)))))))))
;; --- EXPORT READER
(declare lookup-index)
(declare update-index)
(declare relink-media)
(declare relink-shapes)
(defmulti read-import ::version)
(defmulti read-section ::section)
(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 [::input ::timestamp] :or {timestamp (dt/now)} :as options}]
(us/verify! ::read-import-options options)
(let [version (read-header! input)]
(read-import (assoc options ::version version ::timestamp timestamp))))
(defmethod read-import :v1
[{:keys [pool ::input] :as options}]
(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;"])
(binding [*state* (volatile! {:media [] :index {}})]
(run! (fn [section]
(l/debug :hint "reading section" :section section ::l/async false)
(assert-read-label! input section)
(let [options (-> options
(assoc ::section section)
(assoc ::input input)
(assoc :conn conn))]
(binding [*options* options]
(read-section options))))
[:v1/metadata :v1/files :v1/rels :v1/sobjects])
;; Knowing that the ids of the created files are in
;; index, just lookup them and return it as a set
(let [files (-> *state* deref :files)]
(into #{} (keep #(get-in @*state* [:index %])) files)))))))
(defmethod read-section :v1/metadata
[{:keys [::input]}]
(let [{:keys [version files]} (read-obj! input)]
(l/debug :hint "metadata readed" :version (:full version) :files files ::l/async false)
(vswap! *state* update :index update-index files)
(vswap! *state* assoc :version version :files files)))
(defmethod read-section :v1/files
[{:keys [conn ::input ::migrate? ::project-id ::timestamp ::overwrite?]}]
(doseq [expected-file-id (-> *state* deref :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/debug :hint "update index with media" ::l/async false)
(vswap! *state* update :index update-index (map :id media'))
;; Store file media for later insertion
(l/debug :hint "update media references" ::l/async false)
(vswap! *state* update :media into (map #(update % :id lookup-index)) media')
(l/debug :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/debug :hint "create file" :id file-id' ::l/async false)
(if overwrite?
(create-or-update-file conn params)
(db/insert! conn :file params))
(when overwrite?
(db/delete! conn :file-thumbnail {:file-id file-id'}))))))
(defmethod read-section :v1/rels
[{:keys [conn ::input ::timestamp]}]
(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/debug :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)))))
(defmethod read-section :v1/sobjects
[{:keys [storage conn ::input ::overwrite?]}]
(let [storage (media/configure-assets-storage storage)
ids (read-obj! input)]
(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/debug :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))
(assoc :bucket "file-media-object"))
sobject @(sto/put-object! storage params)]
(l/debug :hint "persisted storage object" :id id :new-id (:id sobject) ::l/async false)
(vswap! *state* update :index assoc id (:id sobject)))))
(doseq [item (:media @*state*)]
(l/debug :hint "inserting file media object"
:id (:id item)
:file-id (:file-id item)
::l/async false)
(let [file-id (lookup-index (:file-id item))]
(if (= file-id (:file-id item))
(l/warn :hint "ignoring file media object" :file-id (:file-id item) ::l/async false)
(db/insert! conn :file-media-object
(-> item
(assoc :file-id file-id)
(d/update-when :media-id lookup-index)
(d/update-when :thumbnail-id lookup-index))
{:on-conflict-do-nothing overwrite?}))))))
(defn- lookup-index
[id]
(let [val (get-in @*state* [:index id])]
(l/trace :fn "lookup-index" :id id :val val ::l/async false)
(when (and (not (::ignore-index-errors? *options*)) (not val))
(ex/raise :type :validation
:code :incomplete-index
:hint "looks like index has missing data"))
(or val id)))
(defn- update-index
[index coll]
(loop [items (seq coll)
index index]
(if-let [id (first items)]
(let [new-id (if (::overwrite? *options*) id (uuid/next))]
(l/trace :fn "update-index" :id id :new-id new-id ::l/async false)
(recur (rest items)
(assoc index id new-id)))
index)))
(defn- relink-shapes
"A function responsible to analyze all file data and
replace the old :component-file reference with the new
ones, using the provided file-index."
[data]
(letfn [(process-map-form [form]
(cond-> form
;; Relink image shapes
(and (map? (:metadata form))
(= :image (:type form)))
(update-in [:metadata :id] lookup-index)
;; Relink paths with fill image
(and (map? (:fill-image form))
(= :path (:type form)))
(update-in [:fill-image :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)))]
(walk/postwalk (fn [form]
(if (map? form)
(try
(process-map-form form)
(catch Throwable cause
(l/warn :hint "failed form" :form (pr-str form) ::l/async false)
(throw cause)))
form))
data)))
(defn- relink-media
"A function responsible of process the :media attr of file data and
remap the old ids with the new ones."
[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))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HIGH LEVEL API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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."
{::doc/added "1.15"}
[{: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."
{::doc/added "1.15"}
[{: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))))

534
backend/src/app/rpc/commands/comments.clj Normal file
View file

@ -0,0 +1,534 @@
;; 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.comments
(:require
[app.common.exceptions :as ex]
[app.common.geom.point :as gpt]
[app.common.spec :as us]
[app.db :as db]
[app.rpc.doc :as-alias doc]
[app.rpc.queries.files :as files]
[app.rpc.queries.teams :as teams]
[app.rpc.retry :as retry]
[app.util.blob :as blob]
[app.util.services :as sv]
[app.util.time :as dt]
[clojure.spec.alpha :as s]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; QUERY COMMANDS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn decode-row
[{:keys [participants position] :as row}]
(cond-> row
(db/pgpoint? position) (assoc :position (db/decode-pgpoint position))
(db/pgobject? participants) (assoc :participants (db/decode-transit-pgobject participants))))
;; --- COMMAND: Get Comment Threads
(declare retrieve-comment-threads)
(s/def ::team-id ::us/uuid)
(s/def ::file-id ::us/uuid)
(s/def ::share-id (s/nilable ::us/uuid))
(s/def ::get-comment-threads
(s/and (s/keys :req-un [::profile-id]
:opt-un [::file-id ::share-id ::team-id])
#(or (:file-id %) (:team-id %))))
(sv/defmethod ::get-comment-threads
[{:keys [pool] :as cfg} params]
(with-open [conn (db/open pool)]
(retrieve-comment-threads conn params)))
(def sql:comment-threads
"select distinct on (ct.id)
ct.*,
f.name as file_name,
f.project_id as project_id,
first_value(c.content) over w as content,
(select count(1)
from comment as c
where c.thread_id = ct.id) as count_comments,
(select count(1)
from comment as c
where c.thread_id = ct.id
and c.created_at >= coalesce(cts.modified_at, ct.created_at)) as count_unread_comments
from comment_thread as ct
inner join comment as c on (c.thread_id = ct.id)
inner join file as f on (f.id = ct.file_id)
left join comment_thread_status as cts
on (cts.thread_id = ct.id and
cts.profile_id = ?)
where ct.file_id = ?
window w as (partition by c.thread_id order by c.created_at asc)")
(defn retrieve-comment-threads
[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))))
;; --- COMMAND: Get Unread Comment Threads
(declare retrieve-unread-comment-threads)
(s/def ::team-id ::us/uuid)
(s/def ::get-unread-comment-threads
(s/keys :req-un [::profile-id ::team-id]))
(sv/defmethod ::get-unread-comment-threads
[{:keys [pool] :as cfg} {:keys [profile-id team-id] :as params}]
(with-open [conn (db/open pool)]
(teams/check-read-permissions! conn profile-id team-id)
(retrieve-unread-comment-threads conn params)))
(def sql:comment-threads-by-team
"select distinct on (ct.id)
ct.*,
f.name as file_name,
f.project_id as project_id,
first_value(c.content) over w as content,
(select count(1)
from comment as c
where c.thread_id = ct.id) as count_comments,
(select count(1)
from comment as c
where c.thread_id = ct.id
and c.created_at >= coalesce(cts.modified_at, ct.created_at)) as count_unread_comments
from comment_thread as ct
inner join comment as c on (c.thread_id = ct.id)
inner join file as f on (f.id = ct.file_id)
inner join project as p on (p.id = f.project_id)
left join comment_thread_status as cts
on (cts.thread_id = ct.id and
cts.profile_id = ?)
where p.team_id = ?
window w as (partition by c.thread_id order by c.created_at asc)")
(def sql:unread-comment-threads-by-team
(str "with threads as (" sql:comment-threads-by-team ")"
"select * from threads where count_unread_comments > 0"))
(defn retrieve-unread-comment-threads
[conn {:keys [profile-id team-id]}]
(->> (db/exec! conn [sql:unread-comment-threads-by-team profile-id team-id])
(into [] (map decode-row))))
;; --- COMMAND: Get Single Comment Thread
(s/def ::id ::us/uuid)
(s/def ::share-id (s/nilable ::us/uuid))
(s/def ::get-comment-thread
(s/keys :req-un [::profile-id ::file-id ::id]
:opt-un [::share-id]))
(sv/defmethod ::get-comment-thread
[{:keys [pool] :as cfg} {:keys [profile-id file-id id share-id] :as params}]
(with-open [conn (db/open pool)]
(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])
(decode-row)))))
(defn get-comment-thread
[conn {:keys [profile-id file-id id] :as params}]
(let [sql (str "with threads as (" sql:comment-threads ")"
"select * from threads where id = ?")]
(-> (db/exec-one! conn [sql profile-id file-id id])
(decode-row))))
;; --- COMMAND: Retrieve Comments
(declare get-comments)
(s/def ::file-id ::us/uuid)
(s/def ::share-id (s/nilable ::us/uuid))
(s/def ::thread-id ::us/uuid)
(s/def ::get-comments
(s/keys :req-un [::profile-id ::thread-id]
:opt-un [::share-id]))
(sv/defmethod ::get-comments
[{: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-comment-permissions! conn profile-id (:file-id thread) share-id))
(get-comments conn thread-id)))
(def sql:comments
"select c.* from comment as c
where c.thread_id = ?
order by c.created_at asc")
(defn get-comments
[conn thread-id]
(->> (db/query conn :comment
{:thread-id thread-id}
{:order-by [[:created-at :asc]]})
(into [] (map decode-row))))
;; --- COMMAND: Get file comments users
(declare get-file-comments-users)
(s/def ::file-id ::us/uuid)
(s/def ::share-id (s/nilable ::us/uuid))
(s/def ::get-profiles-for-file-comments
(s/keys :req-un [::profile-id ::file-id]
:opt-un [::share-id]))
(sv/defmethod ::get-profiles-for-file-comments
"Retrieves a list of profiles with limited set of properties of all
participants on comment threads of the file."
{::doc/added "1.15"
::doc/changes ["1.15" "Imported from queries and renamed."]}
[{: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)
(get-file-comments-users conn file-id profile-id)))
;; All the profiles that had comment the file, plus the current
;; profile.
(def sql:file-comment-users
"WITH available_profiles AS (
SELECT DISTINCT owner_id AS id
FROM comment
WHERE thread_id IN (SELECT id FROM comment_thread WHERE file_id=?)
)
SELECT p.id,
p.email,
p.fullname AS name,
p.fullname AS fullname,
p.photo_id,
p.is_active
FROM profile AS p
WHERE p.id IN (SELECT id FROM available_profiles) OR p.id=?")
(defn get-file-comments-users
[conn file-id profile-id]
(db/exec! conn [sql:file-comment-users file-id profile-id]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MUTATION COMMANDS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- COMMAND: Create Comment Thread
(declare upsert-comment-thread-status!)
(declare create-comment-thread)
(declare retrieve-page-name)
(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 ::frame-id ::us/uuid)
(s/def ::create-comment-thread
(s/keys :req-un [::profile-id ::file-id ::position ::content ::page-id ::frame-id]
:opt-un [::share-id]))
(sv/defmethod ::create-comment-thread
{::retry/max-retries 3
::retry/matches retry/conflict-db-insert?
::doc/added "1.15"}
[{:keys [pool] :as cfg} {:keys [profile-id file-id share-id] :as params}]
(db/with-atomic [conn pool]
(files/check-comment-permissions! conn profile-id file-id share-id)
(create-comment-thread conn params)))
(defn- retrieve-next-seqn
[conn file-id]
(let [sql "select (f.comment_thread_seqn + 1) as next_seqn from file as f where f.id = ?"
res (db/exec-one! conn [sql file-id])]
(:next-seqn res)))
(defn create-comment-thread
[conn {:keys [profile-id file-id page-id position content frame-id] :as params}]
(let [seqn (retrieve-next-seqn conn file-id)
now (dt/now)
pname (retrieve-page-name conn params)
thread (db/insert! conn :comment-thread
{:file-id file-id
:owner-id profile-id
:participants (db/tjson #{profile-id})
:page-name pname
:page-id page-id
:created-at now
:modified-at now
:seqn seqn
:position (db/pgpoint position)
:frame-id frame-id})]
;; Create a comment entry
(db/insert! conn :comment
{:thread-id (:id thread)
:owner-id profile-id
:created-at now
:modified-at now
:content content})
;; Make the current thread as read.
(upsert-comment-thread-status! conn profile-id (:id thread))
;; Optimistic update of current seq number on file.
(db/update! conn :file
{:comment-thread-seqn seqn}
{:id file-id})
(select-keys thread [:id :file-id :page-id])))
(defn- retrieve-page-name
[conn {:keys [file-id page-id]}]
(let [{:keys [data]} (db/get-by-id conn :file file-id)
data (blob/decode data)]
(get-in data [:pages-index page-id :name])))
;; --- COMMAND: 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]
:opt-un [::share-id]))
(sv/defmethod ::update-comment-thread-status
{::doc/added "1.15"}
[{: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-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
"insert into comment_thread_status (thread_id, profile_id)
values (?, ?)
on conflict (thread_id, profile_id)
do update set modified_at = clock_timestamp()
returning modified_at;")
(defn upsert-comment-thread-status!
[conn profile-id thread-id]
(db/exec-one! conn [sql:upsert-comment-thread-status thread-id profile-id]))
;; --- COMMAND: Update Comment Thread
(s/def ::is-resolved ::us/boolean)
(s/def ::update-comment-thread
(s/keys :req-un [::profile-id ::id ::is-resolved]
:opt-un [::share-id]))
(sv/defmethod ::update-comment-thread
{::doc/added "1.15"}
[{: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-comment-permissions! conn profile-id (:file-id thread) share-id)
(db/update! conn :comment-thread
{:is-resolved is-resolved}
{:id id})
nil)))
;; --- COMMAND: Add Comment
(declare create-comment)
(s/def ::create-comment
(s/keys :req-un [::profile-id ::thread-id ::content]
:opt-un [::share-id]))
(sv/defmethod ::create-comment
{::doc/added "1.15"}
[{:keys [pool] :as cfg} params]
(db/with-atomic [conn pool]
(create-comment conn params)))
(defn create-comment
[conn {:keys [profile-id thread-id content share-id] :as params}]
(let [thread (-> (db/get-by-id conn :comment-thread thread-id {:for-update true})
(decode-row))
pname (retrieve-page-name conn thread)]
;; Standard Checks
(when-not thread (ex/raise :type :not-found))
;; Permission Checks
(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))
(db/update! conn :comment-thread
{:page-name pname}
{:id thread-id}))
;; NOTE: is important that all timestamptz related fields are
;; created or updated on the database level for avoid clock
;; inconsistencies (some user sees something read that is not
;; read, etc...)
(let [ppants (:participants thread #{})
comment (db/insert! conn :comment
{:thread-id thread-id
:owner-id profile-id
:content content})]
;; NOTE: this is done in SQL instead of using db/update!
;; helper because currently the helper does not allow pass raw
;; function call parameters to the underlying prepared
;; statement; in a future when we fix/improve it, this can be
;; changed to use the helper.
;; Update thread modified-at attribute and assoc the current
;; profile to the participant set.
(let [ppants (conj ppants profile-id)
sql "update comment_thread
set modified_at = clock_timestamp(),
participants = ?
where id = ?"]
(db/exec-one! conn [sql (db/tjson ppants) thread-id]))
;; Update the current profile status in relation to the
;; current thread.
(upsert-comment-thread-status! conn profile-id thread-id)
;; Return the created comment object.
comment)))
;; --- COMMAND: Update Comment
(declare update-comment)
(s/def ::update-comment
(s/keys :req-un [::profile-id ::id ::content]
:opt-un [::share-id]))
(sv/defmethod ::update-comment
{::doc/added "1.15"}
[{:keys [pool] :as cfg} params]
(db/with-atomic [conn pool]
(update-comment conn params)))
(defn update-comment
[conn {:keys [profile-id id content share-id] :as params}]
(let [comment (db/get-by-id conn :comment id {:for-update true})
_ (when-not comment (ex/raise :type :not-found))
thread (db/get-by-id conn :comment-thread (:thread-id comment) {:for-update true})
_ (when-not thread (ex/raise :type :not-found))
pname (retrieve-page-name conn 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)
(ex/raise :type :validation
:code :not-allowed))
(db/update! conn :comment
{:content content
:modified-at (dt/now)}
{:id (:id comment)})
(db/update! conn :comment-thread
{:modified-at (dt/now)
:page-name pname}
{:id (:id thread)})
nil))
;; --- COMMAND: Delete Comment Thread
(s/def ::delete-comment-thread
(s/keys :req-un [::profile-id ::id]))
(sv/defmethod ::delete-comment-thread
{::doc/added "1.15"}
[{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
(db/with-atomic [conn pool]
(let [thread (db/get-by-id conn :comment-thread id {:for-update true})]
(when-not (= (:owner-id thread) profile-id)
(ex/raise :type :validation
:code :not-allowed))
(db/delete! conn :comment-thread {:id id})
nil)))
;; --- COMMAND: Delete comment
(s/def ::delete-comment
(s/keys :req-un [::profile-id ::id]))
(sv/defmethod ::delete-comment
{::doc/added "1.15"}
[{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
(db/with-atomic [conn pool]
(let [comment (db/get-by-id conn :comment id {:for-update true})]
(when-not (= (:owner-id comment) profile-id)
(ex/raise :type :validation
:code :not-allowed))
(db/delete! conn :comment {:id id}))))
;; --- COMMAND: Update comment thread position
(s/def ::update-comment-thread-position
(s/keys :req-un [::profile-id ::id ::position ::frame-id]))
(sv/defmethod ::update-comment-thread-position
{::doc/added "1.15"}
[{:keys [pool] :as cfg} {:keys [profile-id id position frame-id] :as params}]
(db/with-atomic [conn pool]
(let [thread (db/get-by-id conn :comment-thread id {:for-update true})]
(when-not (= (:owner-id thread) profile-id)
(ex/raise :type :validation
:code :not-allowed))
(db/update! conn :comment-thread
{:modified-at (dt/now)
:position (db/pgpoint position)
:frame-id frame-id}
{:id (:id thread)})
nil)))
;; --- COMMAND: Update comment frame
(s/def ::update-comment-thread-frame
(s/keys :req-un [::profile-id ::id ::frame-id]))
(sv/defmethod ::update-comment-thread-frame
{::doc/added "1.15"}
[{:keys [pool] :as cfg} {:keys [profile-id id frame-id] :as params}]
(db/with-atomic [conn pool]
(let [thread (db/get-by-id conn :comment-thread id {:for-update true})]
(when-not (= (:owner-id thread) profile-id)
(ex/raise :type :validation
:code :not-allowed))
(db/update! conn :comment-thread
{:modified-at (dt/now)
:frame-id frame-id}
{:id (:id thread)})
nil)))

17
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,8 @@
[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.rpc.doc :as-alias doc]
[app.util.services :as sv]
[app.util.time :as dt]
[buddy.core.codecs :as bc]
@ -21,7 +22,13 @@
(s/def ::create-demo-profile any?)
(sv/defmethod ::create-demo-profile {:auth false}
(sv/defmethod ::create-demo-profile
"A command that is responsible of creating a demo purpose
profile. It only works if the `demo-users` flag is inabled in the
configuration."
{:auth false
::doc/added "1.15"
::doc/changes ["1.15" "This methos is migrated from mutations to commands."]}
[{:keys [pool] :as cfg} _]
(let [id (uuid/next)
sem (System/currentTimeMillis)
@ -45,8 +52,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}

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

@ -0,0 +1,80 @@
;; 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.doc :as-alias doc]
[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
"Performs the authentication using LDAP backend. Only works if LDAP
is properly configured and enabled with `login-with-ldap` flag."
{:auth false
::doc/added "1.15"}
[{: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)))))

77
backend/src/app/rpc/doc.clj Normal file
View file

@ -0,0 +1,77 @@
;; 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.doc
"API autogenerated documentation."
(: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
[k]
(with-out-str
(ps/pprint (s/form k)
{:ns-aliases {"clojure.spec.alpha" "s"
"clojure.core.specs.alpha" "score"
"clojure.core" nil}})))
(defn- prepare-context
[methods]
(letfn [(gen-doc [type [name f]]
(let [mdata (meta f)]
{:type (d/name type)
:name (d/name name)
:module (-> (:ns mdata) (str/split ".") last)
:auth (:auth mdata true)
:docs (::sv/docstring mdata)
:deprecated (::deprecated mdata)
:added (::added mdata)
:changes (some->> (::changes mdata) (partition-all 2) (map vec))
:spec (get-spec-str (::sv/spec mdata))}))]
{:version (:main cf/version)
: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)))))
(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}}])

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

@ -7,132 +7,61 @@
(ns app.rpc.mutations.comments
(:require
[app.common.exceptions :as ex]
[app.common.geom.point :as gpt]
[app.common.spec :as us]
[app.db :as db]
[app.rpc.queries.comments :as comments]
[app.rpc.commands.comments :as cmd.comments]
[app.rpc.doc :as-alias doc]
[app.rpc.queries.files :as files]
[app.rpc.retry :as retry]
[app.util.blob :as blob]
[app.util.services :as sv]
[app.util.time :as dt]
[clojure.spec.alpha :as s]))
;; --- Mutation: Create Comment Thread
(declare upsert-comment-thread-status!)
(declare create-comment-thread)
(declare retrieve-page-name)
(s/def ::page-id ::us/uuid)
(s/def ::file-id ::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/def ::create-comment-thread ::cmd.comments/create-comment-thread)
(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}]
::retry/matches retry/conflict-db-insert?
::doc/added "1.0"
::doc/deprecated "1.15"}
[{: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)
(create-comment-thread conn params)))
(defn- retrieve-next-seqn
[conn file-id]
(let [sql "select (f.comment_thread_seqn + 1) as next_seqn from file as f where f.id = ?"
res (db/exec-one! conn [sql file-id])]
(:next-seqn res)))
(defn- create-comment-thread
[conn {:keys [profile-id file-id page-id position content] :as params}]
(let [seqn (retrieve-next-seqn conn file-id)
now (dt/now)
pname (retrieve-page-name conn params)
thread (db/insert! conn :comment-thread
{:file-id file-id
:owner-id profile-id
:participants (db/tjson #{profile-id})
:page-name pname
:page-id page-id
:created-at now
:modified-at now
:seqn seqn
:position (db/pgpoint position)})]
;; Create a comment entry
(db/insert! conn :comment
{:thread-id (:id thread)
:owner-id profile-id
:created-at now
:modified-at now
:content content})
;; Make the current thread as read.
(upsert-comment-thread-status! conn profile-id (:id thread))
;; Optimistic update of current seq number on file.
(db/update! conn :file
{:comment-thread-seqn seqn}
{:id file-id})
(select-keys thread [:id :file-id :page-id])))
(defn- retrieve-page-name
[conn {:keys [file-id page-id]}]
(let [{:keys [data]} (db/get-by-id conn :file file-id)
data (blob/decode data)]
(get-in data [:pages-index page-id :name])))
(files/check-comment-permissions! conn profile-id file-id share-id)
(cmd.comments/create-comment-thread conn params)))
;; --- 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/def ::update-comment-thread-status ::cmd.comments/update-comment-thread-status)
(sv/defmethod ::update-comment-thread-status
[{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
{::doc/added "1.0"
::doc/deprecated "1.15"}
[{: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))
(upsert-comment-thread-status! conn profile-id (:id cthr)))))
(def sql:upsert-comment-thread-status
"insert into comment_thread_status (thread_id, profile_id)
values (?, ?)
on conflict (thread_id, profile_id)
do update set modified_at = clock_timestamp()
returning modified_at;")
(defn- upsert-comment-thread-status!
[conn profile-id thread-id]
(db/exec-one! conn [sql:upsert-comment-thread-status thread-id profile-id]))
(when-not cthr (ex/raise :type :not-found))
(files/check-comment-permissions! conn profile-id (:file-id cthr) share-id)
(cmd.comments/upsert-comment-thread-status! conn profile-id (:id cthr)))))
;; --- Mutation: Update Comment Thread
(s/def ::is-resolved ::us/boolean)
(s/def ::update-comment-thread
(s/keys :req-un [::profile-id ::id ::is-resolved]))
(s/def ::update-comment-thread ::cmd.comments/update-comment-thread)
(sv/defmethod ::update-comment-thread
[{:keys [pool] :as cfg} {:keys [profile-id id is-resolved] :as params}]
{::doc/added "1.0"
::doc/deprecated "1.15"}
[{: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}
{:id id})
@ -141,121 +70,54 @@
;; --- Mutation: Add Comment
(s/def ::add-comment
(s/keys :req-un [::profile-id ::thread-id ::content]))
(s/def ::add-comment ::cmd.comments/create-comment)
(sv/defmethod ::add-comment
[{:keys [pool] :as cfg} {:keys [profile-id thread-id content] :as params}]
{::doc/added "1.0"
::doc/deprecated "1.15"}
[{:keys [pool] :as cfg} params]
(db/with-atomic [conn pool]
(let [thread (-> (db/get-by-id conn :comment-thread thread-id {:for-update true})
(comments/decode-row))
pname (retrieve-page-name conn thread)]
;; Standard Checks
(when-not thread (ex/raise :type :not-found))
;; Permission Checks
(files/check-read-permissions! conn profile-id (:file-id thread))
;; Update the page-name cachedattribute on comment thread table.
(when (not= pname (:page-name thread))
(db/update! conn :comment-thread
{:page-name pname}
{:id thread-id}))
;; NOTE: is important that all timestamptz related fields are
;; created or updated on the database level for avoid clock
;; inconsistencies (some user sees something read that is not
;; read, etc...)
(let [ppants (:participants thread #{})
comment (db/insert! conn :comment
{:thread-id thread-id
:owner-id profile-id
:content content})]
;; NOTE: this is done in SQL instead of using db/update!
;; helper because currently the helper does not allow pass raw
;; function call parameters to the underlying prepared
;; statement; in a future when we fix/improve it, this can be
;; changed to use the helper.
;; Update thread modified-at attribute and assoc the current
;; profile to the participant set.
(let [ppants (conj ppants profile-id)
sql "update comment_thread
set modified_at = clock_timestamp(),
participants = ?
where id = ?"]
(db/exec-one! conn [sql (db/tjson ppants) thread-id]))
;; Update the current profile status in relation to the
;; current thread.
(upsert-comment-thread-status! conn profile-id thread-id)
;; Return the created comment object.
comment))))
(cmd.comments/create-comment conn params)))
;; --- Mutation: Update Comment
(s/def ::update-comment
(s/keys :req-un [::profile-id ::id ::content]))
(s/def ::update-comment ::cmd.comments/update-comment)
(sv/defmethod ::update-comment
[{:keys [pool] :as cfg} {:keys [profile-id id content] :as params}]
{::doc/added "1.0"
::doc/deprecated "1.15"}
[{:keys [pool] :as cfg} 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))
thread (db/get-by-id conn :comment-thread (:thread-id comment) {:for-update true})
_ (when-not thread (ex/raise :type :not-found))
pname (retrieve-page-name conn thread)]
(files/check-read-permissions! conn profile-id (:file-id thread))
;; Don't allow edit comments to not owners
(when-not (= (:owner-id thread) profile-id)
(ex/raise :type :validation
:code :not-allowed))
(db/update! conn :comment
{:content content
:modified-at (dt/now)}
{:id (:id comment)})
(db/update! conn :comment-thread
{:modified-at (dt/now)
:page-name pname}
{:id (:id thread)})
nil)))
(cmd.comments/update-comment conn params)))
;; --- Mutation: Delete Comment Thread
(s/def ::delete-comment-thread
(s/keys :req-un [::profile-id ::id]))
(s/def ::delete-comment-thread ::cmd.comments/delete-comment-thread)
(sv/defmethod ::delete-comment-thread
{::doc/added "1.0"
::doc/deprecated "1.15"}
[{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
(db/with-atomic [conn pool]
(let [thread (db/get-by-id conn :comment-thread id {:for-update true})]
(when-not (= (:owner-id thread) profile-id)
(ex/raise :type :validation
:code :not-allowed))
(ex/raise :type :validation :code :not-allowed))
(db/delete! conn :comment-thread {:id id})
nil)))
;; --- Mutation: Delete comment
(s/def ::delete-comment
(s/keys :req-un [::profile-id ::id]))
(s/def ::delete-comment ::cmd.comments/delete-comment)
(sv/defmethod ::delete-comment
{::doc/added "1.0"
::doc/deprecated "1.15"}
[{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
(db/with-atomic [conn pool]
(let [comment (db/get-by-id conn :comment id {:for-update true})]
(when-not (= (:owner-id comment) profile-id)
(ex/raise :type :validation
:code :not-allowed))
(ex/raise :type :validation :code :not-allowed))
(db/delete! conn :comment {:id 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))

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

@ -13,6 +13,7 @@
[app.config :as cf]
[app.db :as db]
[app.media :as media]
[app.rpc.doc :as-alias doc]
[app.rpc.queries.teams :as teams]
[app.rpc.rlimit :as rlimit]
[app.storage :as sto]
@ -71,9 +72,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)
@ -151,6 +152,7 @@
(s/keys :req-un [::profile-id ::team-id ::id]))
(sv/defmethod ::delete-font-variant
{::doc/added "1.3"}
[{:keys [pool] :as cfg} {:keys [id team-id profile-id] :as params}]
(db/with-atomic [conn pool]
(teams/check-edition-permissions! conn profile-id team-id)

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)))))

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

@ -17,12 +17,17 @@
[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]
[cuerdas.core :as str]
[promesa.core :as p]
[promesa.exec :as px]))
(def default-max-file-size (* 1024 1024 10)) ; 10 MiB
(def thumbnail-options
{:width 100
:height 100
@ -49,10 +54,20 @@
(sv/defmethod ::upload-file-media-object
{::rlimit/permits (cf/get :rlimit-image)}
[{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
[{:keys [pool] :as cfg} {:keys [profile-id file-id content] :as params}]
(let [file (select-file pool file-id)
cfg (update cfg :storage media/configure-assets-storage)]
(teams/check-edition-permissions! pool profile-id (:team-id file))
(media/validate-media-type! content)
(when (> (:size content) (cf/get :media-max-file-size default-max-file-size))
(ex/raise :type :restriction
:code :media-max-file-size-reached
:hint (str/ffmt "the uploaded file size % is greater than the maximum %"
(:size content)
default-max-file-size)))
(create-file-media-object cfg params)))
(defn- big-enough-for-thumbnail?
@ -92,8 +107,6 @@
(defn create-file-media-object
[{:keys [storage pool executors] :as cfg} {:keys [id file-id is-local name content] :as params}]
(media/validate-media-type! content)
(letfn [;; Function responsible to retrieve the file information, as
;; it is synchronous operation it should be wrapped into
;; with-dispatch macro.
@ -132,7 +145,7 @@
:bucket "file-media-object"}))))
(create-image [info]
(p/let [data (cond-> (:path info) (= (:mtype info) "image/svg+xml") slurp)
(p/let [data (:path info)
hash (calculate-hash data)
content (-> (sto/content data)
(sto/wrap-with-hash hash))]
@ -175,52 +188,53 @@
(teams/check-edition-permissions! pool profile-id (:team-id file))
(create-file-media-object-from-url cfg params)))
(def max-download-file-size
(* 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)]
(let [size (some-> (get headers "content-length") d/parse-integer)
mtype (get headers "content-type")
format (cm/mtype->format mtype)
max-size (cf/get :media-max-file-size default-max-file-size)]
(when-not size
(ex/raise :type :validation
:code :unknown-size
:hint "Seems like the url points to resource with unknown size"))
:hint "seems like the url points to resource with unknown size"))
(when (> size max-download-file-size)
(when (> size max-size)
(ex/raise :type :validation
:code :file-too-large
:hint "Seems like the url points to resource with size greater than 100MiB"))
:hint (str/ffmt "the file size % is greater than the maximum %"
size
default-max-file-size)))
(when (nil? format)
(ex/raise :type :validation
:code :media-type-not-allowed
:hint "Seems like the url points to an invalid media object"))
:hint "seems like the url points to an invalid media object"))
{:size size
: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

4
backend/src/app/rpc/mutations/teams.clj
View file

@ -353,7 +353,7 @@
(declare create-team-invitation)
(s/def ::email ::us/email)
(s/def ::emails ::us/set-of-emails)
(s/def ::emails ::us/set-of-valid-emails)
(s/def ::invite-team-member
(s/keys :req-un [::profile-id ::team-id ::role]
:opt-un [::email ::emails]))
@ -443,7 +443,7 @@
;; --- Mutation: Create Team & Invite Members
(s/def ::emails ::us/set-of-emails)
(s/def ::emails ::us/set-of-valid-emails)
(s/def ::create-team-and-invite-members
(s/and ::create-team (s/keys :req-un [::emails ::role])))

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)."

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

@ -6,8 +6,9 @@
(ns app.rpc.queries.comments
(:require
[app.common.spec :as us]
[app.db :as db]
[app.rpc.commands.comments :as cmd.comments]
[app.rpc.doc :as-alias doc]
[app.rpc.queries.files :as files]
[app.rpc.queries.teams :as teams]
[app.util.services :as sv]
@ -19,137 +20,63 @@
(db/pgpoint? position) (assoc :position (db/decode-pgpoint position))
(db/pgobject? participants) (assoc :participants (db/decode-transit-pgobject participants))))
;; --- Query: Comment Threads
;; --- QUERY: Comment Threads
(declare retrieve-comment-threads)
(s/def ::team-id ::us/uuid)
(s/def ::file-id ::us/uuid)
(s/def ::comment-threads
(s/and (s/keys :req-un [::profile-id]
:opt-un [::file-id ::team-id])
#(or (:file-id %) (:team-id %))))
(s/def ::comment-threads ::cmd.comments/get-comment-threads)
(sv/defmethod ::comment-threads
[{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
{::doc/added "1.0"
::doc/deprecated "1.15"}
[{: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)))
(cmd.comments/retrieve-comment-threads conn params)))
(def sql:comment-threads
"select distinct on (ct.id)
ct.*,
f.name as file_name,
f.project_id as project_id,
first_value(c.content) over w as content,
(select count(1)
from comment as c
where c.thread_id = ct.id) as count_comments,
(select count(1)
from comment as c
where c.thread_id = ct.id
and c.created_at >= coalesce(cts.modified_at, ct.created_at)) as count_unread_comments
from comment_thread as ct
inner join comment as c on (c.thread_id = ct.id)
inner join file as f on (f.id = ct.file_id)
left join comment_thread_status as cts
on (cts.thread_id = ct.id and
cts.profile_id = ?)
where ct.file_id = ?
window w as (partition by c.thread_id order by c.created_at asc)")
;; --- QUERY: Unread Comment Threads
(defn- retrieve-comment-threads
[conn {:keys [profile-id file-id]}]
(files/check-read-permissions! conn profile-id file-id)
(->> (db/exec! conn [sql:comment-threads profile-id file-id])
(into [] (map decode-row))))
;; --- Query: Unread Comment Threads
(declare retrieve-unread-comment-threads)
(s/def ::team-id ::us/uuid)
(s/def ::unread-comment-threads
(s/keys :req-un [::profile-id ::team-id]))
(s/def ::unread-comment-threads ::cmd.comments/get-unread-comment-threads)
(sv/defmethod ::unread-comment-threads
{::doc/added "1.0"
::doc/deprecated "1.15"}
[{:keys [pool] :as cfg} {:keys [profile-id team-id] :as params}]
(with-open [conn (db/open pool)]
(teams/check-read-permissions! conn profile-id team-id)
(retrieve-unread-comment-threads conn params)))
(cmd.comments/retrieve-unread-comment-threads conn params)))
(def sql:comment-threads-by-team
"select distinct on (ct.id)
ct.*,
f.name as file_name,
f.project_id as project_id,
first_value(c.content) over w as content,
(select count(1)
from comment as c
where c.thread_id = ct.id) as count_comments,
(select count(1)
from comment as c
where c.thread_id = ct.id
and c.created_at >= coalesce(cts.modified_at, ct.created_at)) as count_unread_comments
from comment_thread as ct
inner join comment as c on (c.thread_id = ct.id)
inner join file as f on (f.id = ct.file_id)
inner join project as p on (p.id = f.project_id)
left join comment_thread_status as cts
on (cts.thread_id = ct.id and
cts.profile_id = ?)
where p.team_id = ?
window w as (partition by c.thread_id order by c.created_at asc)")
;; --- QUERY: Single Comment Thread
(def sql:unread-comment-threads-by-team
(str "with threads as (" sql:comment-threads-by-team ")"
"select * from threads where count_unread_comments > 0"))
(defn retrieve-unread-comment-threads
[conn {:keys [profile-id team-id]}]
(->> (db/exec! conn [sql:unread-comment-threads-by-team profile-id team-id])
(into [] (map decode-row))))
;; --- Query: Single Comment Thread
(s/def ::id ::us/uuid)
(s/def ::comment-thread
(s/keys :req-un [::profile-id ::file-id ::id]))
(s/def ::comment-thread ::cmd.comments/get-comment-thread)
(sv/defmethod ::comment-thread
[{:keys [pool] :as cfg} {:keys [profile-id file-id id] :as params}]
{::doc/added "1.0"
::doc/deprecated "1.15"}
[{:keys [pool] :as cfg} {:keys [profile-id file-id share-id] :as params}]
(with-open [conn (db/open pool)]
(files/check-read-permissions! conn profile-id file-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])
(decode-row)))))
(files/check-comment-permissions! conn profile-id file-id share-id)
(cmd.comments/get-comment-thread conn params)))
;; --- Query: Comments
;; --- QUERY: Comments
(declare retrieve-comments)
(s/def ::file-id ::us/uuid)
(s/def ::thread-id ::us/uuid)
(s/def ::comments
(s/keys :req-un [::profile-id ::thread-id]))
(s/def ::comments ::cmd.comments/get-comments)
(sv/defmethod ::comments
[{:keys [pool] :as cfg} {:keys [profile-id thread-id] :as params}]
{::doc/added "1.0"
::doc/deprecated "1.15"}
[{: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))
(retrieve-comments conn thread-id))))
(files/check-comment-permissions! conn profile-id (:file-id thread) share-id))
(cmd.comments/get-comments conn thread-id)))
(def sql:comments
"select c.* from comment as c
where c.thread_id = ?
order by c.created_at asc")
(defn- retrieve-comments
[conn thread-id]
(->> (db/exec! conn [sql:comments thread-id])
(into [] (map decode-row))))
;; --- QUERY: Get file comments users
(s/def ::file-comments-users ::cmd.comments/get-profiles-for-file-comments)
(sv/defmethod ::file-comments-users
{::doc/deprecated "1.15"
::doc/added "1.13"}
[{: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)
(cmd.comments/get-file-comments-users conn 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))))

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

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

8
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.commands.comments :as comments]
[app.rpc.queries.files :as files]
[app.rpc.queries.share-link :as slnk]
[app.rpc.queries.teams :as teams]
[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/get-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))]

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

@ -1,14 +0,0 @@
(ns app.srepl.dev
#_:clj-kondo/ignore
(:require
[app.db :as db]
[app.config :as cfg]
[app.rpc.mutations.profile :refer [derive-password]]
[app.main :refer [system]]))
(defn reset-passwords
[system]
(db/with-atomic [conn (:app.db/pool system)]
(let [password (derive-password "123123")]
(db/exec! conn ["update profile set password=?" password]))))

43
backend/src/app/srepl/fixes.clj Normal file
View file

@ -0,0 +1,43 @@
;; 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.srepl.fixes
"A collection of adhoc fixes scripts."
(:require
[app.common.logging :as l]
[app.common.uuid :as uuid]
[app.srepl.helpers :as h]))
(defn repair-orphaned-shapes
"There are some shapes whose parent has been deleted. This function
detects them and puts them as children of the root node."
([data]
(letfn [(is-orphan? [shape objects]
(and (some? (:parent-id shape))
(nil? (get objects (:parent-id shape)))))
(update-page [page]
(let [objects (:objects page)
orphans (into #{} (filter #(is-orphan? % objects)) (vals objects))]
(if (seq orphans)
(do
(l/info :hint "found a file with orphans" :file-id (:id data) :broken-shapes (count orphans))
(-> page
(h/update-shapes (fn [shape]
(if (contains? orphans shape)
(assoc shape :parent-id uuid/zero)
shape)))
(update-in [:objects uuid/zero :shapes] into (map :id) orphans)))
page)))]
(h/update-pages data update-page)))
;; special arity for to be called from h/analyze-files to search for
;; files with possible issues
([file state]
(repair-orphaned-shapes (:data file))
(update state :total (fnil inc 0))))

135
backend/src/app/srepl/helpers.clj Normal file
View file

@ -0,0 +1,135 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) UXBOX Labs SL
(ns app.srepl.helpers
"A main namespace for server repl."
#_:clj-kondo/ignore
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.pages :as cp]
[app.common.pages.migrations :as pmg]
[app.common.pprint :refer [pprint]]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.db.sql :as sql]
[app.main :refer [system]]
[app.rpc.commands.auth :refer [derive-password]]
[app.rpc.queries.profile :as prof]
[app.util.blob :as blob]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[clojure.walk :as walk]
[cuerdas.core :as str]
[expound.alpha :as expound]))
(defn reset-password!
"Reset a password to a specific one for a concrete user or all users
if email is `:all` keyword."
[system & {:keys [email password] :or {password "123123"} :as params}]
(us/verify! (contains? params :email) "`email` parameter is mandatory")
(db/with-atomic [conn (:app.db/pool system)]
(let [password (derive-password password)]
(if (= email :all)
(db/exec! conn ["update profile set password=?" password])
(let [email (str/lower email)]
(db/exec! conn ["update profile set password=? where email=?" password email]))))))
(defn reset-file-data!
"Hardcode replace of the data of one file."
[system id data]
(db/with-atomic [conn (:app.db/pool system)]
(db/update! conn :file
{:data data}
{:id id})))
(defn get-file
"Get the migrated data of one file."
[system id]
(-> (:app.db/pool system)
(db/get-by-id :file id)
(update :data blob/decode)
(update :data pmg/migrate-data)))
(defn update-file!
"Apply a function to the data of one file. Optionally save the changes or not.
The function receives the decoded and migrated file data."
[system & {:keys [update-fn id save? migrate? inc-revn?]
:or {save? false migrate? true inc-revn? true}}]
(db/with-atomic [conn (:app.db/pool system)]
(let [file (db/get-by-id conn :file id {:for-update true})
file (-> file
(update :data blob/decode)
(cond-> migrate? (update :data pmg/migrate-data))
(update :data update-fn)
(update :data blob/encode)
(cond-> inc-revn? (update :revn inc)))]
(when save?
(db/update! conn :file
{:data (:data file)
:revn (:revn file)}
{:id (:id file)}))
(update file :data blob/decode))))
(def ^:private sql:retrieve-files-chunk
"SELECT id, name, modified_at, data FROM file
WHERE created_at < ? AND deleted_at is NULL
ORDER BY created_at desc LIMIT ?")
(defn analyze-files
"Apply a function to all files in the database, reading them in
batches. Do not change data.
The `on-file` parameter should be a function that receives the file
and the previous state and returns the new state."
[system & {:keys [chunk-size on-file] :or {chunk-size 10}}]
(letfn [(get-chunk [conn cursor]
(let [rows (db/exec! conn [sql:retrieve-files-chunk cursor chunk-size])]
[(some->> rows peek :created-at) (seq rows)]))
(get-candidates [conn]
(->> (d/iteration (partial get-chunk conn)
:vf second
:kf first
:initk (dt/now))
(sequence cat)
(map #(update % :data blob/decode))))]
(db/with-atomic [conn (:app.db/pool system)]
(loop [state {}
files (get-candidates conn)]
(if-let [file (first files)]
(let [state (on-file file state)]
(recur state (rest files)))
state)))))
(defn analyze-file-data
[system & {:keys [id on-form on-data]}]
(let [file (get-file system id)]
(cond
(fn? on-data)
(on-data (:data file))
(fn? on-form)
(walk/postwalk (fn [form]
(on-form form)
form)
(:data file)))
nil))
(defn update-pages
"Apply a function to all pages of one file. The function receives a page and returns an updated page."
[data f]
(update data :pages-index d/update-vals f))
(defn update-shapes
"Apply a function to all shapes of one page The function receives a shape and returns an updated shape"
[page f]
(update page :objects d/update-vals f))

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

@ -1,204 +1,32 @@
;; 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.srepl.main
"A main namespace for server repl."
"A collection of adhoc fixes scripts."
#_:clj-kondo/ignore
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[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]
[app.db.sql :as sql]
[app.main :refer [system]]
[app.rpc.queries.profile :as prof]
[app.srepl.dev :as dev]
[app.util.blob :as blob]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[clojure.walk :as walk]
[cuerdas.core :as str]
[expound.alpha :as expound]
[fipp.edn :refer [pprint]]))
[app.common.pprint :as p]
[app.srepl.fixes :as f]
[app.srepl.helpers :as h]
[clojure.pprint :refer [pprint]]))
;; ==== Utility functions
;; Empty namespace as main entry point for Server REPL
(defn reset-file-data
"Hardcode replace of the data of one file."
[system id data]
(db/with-atomic [conn (:app.db/pool system)]
(db/update! conn :file
{:data data}
{:id id})))
(defn get-file
"Get the migrated data of one file."
[system id]
(-> (:app.db/pool system)
(db/get-by-id :file id)
(update :data app.util.blob/decode)
(update :data pmg/migrate-data)))
(defn duplicate-file
"This is a raw version of duplication of file just only for forensic analysis."
[system file-id email]
(db/with-atomic [conn (:app.db/pool system)]
(when-let [profile (some->> (prof/retrieve-profile-data-by-email conn (str/lower email))
(prof/populate-additional-data conn))]
(when-let [file (db/exec-one! conn (sql/select :file {:id file-id}))]
(let [params (assoc file
:id (uuid/next)
:project-id (:default-project-id profile))]
(db/insert! conn :file params)
(:id file))))))
(defn update-file
"Apply a function to the data of one file. Optionally save the changes or not.
The function receives the decoded and migrated file data."
([system id f] (update-file system id f false))
([system id f save?]
(db/with-atomic [conn (:app.db/pool system)]
(let [file (db/get-by-id conn :file id {:for-update true})
file (-> file
(update :data app.util.blob/decode)
(update :data pmg/migrate-data)
(update :data f)
(update :data blob/encode)
(update :revn inc))]
(when save?
(db/update! conn :file
{:data (:data file)}
{:id (:id file)}))
(update file :data blob/decode)))))
(defn analyze-files
"Apply a function to all files in the database, reading them in batches. Do not change data.
The function receives an object with some properties of the file and the decoded data, and
an empty atom where it may accumulate statistics, if desired."
[system {:keys [sleep chunk-size max-chunks on-file]
:or {sleep 1000 chunk-size 10 max-chunks ##Inf}}]
(let [stats (atom {})]
(letfn [(retrieve-chunk [conn cursor]
(let [sql (str "select id, name, modified_at, data from file "
" where modified_at < ? and deleted_at is null "
" order by modified_at desc limit ?")]
(->> (db/exec! conn [sql cursor chunk-size])
(map #(update % :data blob/decode)))))
(process-chunk [chunk]
(loop [files chunk]
(when-let [file (first files)]
(on-file file stats)
(recur (rest files)))))]
(db/with-atomic [conn (:app.db/pool system)]
(loop [cursor (dt/now)
chunks 0]
(when (< chunks max-chunks)
(let [chunk (retrieve-chunk conn cursor)]
(when-not (empty? chunk)
(let [cursor (-> chunk last :modified-at)]
(process-chunk chunk)
(Thread/sleep (inst-ms (dt/duration sleep)))
(recur cursor (inc chunks)))))))
@stats))))
(defn update-pages
"Apply a function to all pages of one file. The function receives a page and returns an updated page."
[data f]
(update data :pages-index d/update-vals f))
(defn update-shapes
"Apply a function to all shapes of one page The function receives a shape and returns an updated shape"
[page f]
(update page :objects d/update-vals f))
(defn print-available-tasks
[system]
(let [tasks (:app.worker/registry system)]
(p/pprint (keys tasks) :level 200)))
;; ==== Specific fixes
(defn repair-orphaned-shapes
"There are some shapes whose parent has been deleted. This
function detects them and puts them as children of the root node."
([file _] ; to be called from analyze-files to search for files with the problem
(repair-orphaned-shapes (:data file)))
([data]
(let [is-orphan? (fn [shape objects]
(and (some? (:parent-id shape))
(nil? (get objects (:parent-id shape)))))
update-page (fn [page]
(let [objects (:objects page)
orphans (set (filter #(is-orphan? % objects) (vals objects)))]
(if (seq orphans)
(do
(prn (:id data) "file has" (count orphans) "broken shapes")
(-> page
(update-shapes (fn [shape]
(if (orphans shape)
(assoc shape :parent-id uuid/zero)
shape)))
(update-in [:objects uuid/zero :shapes]
(fn [shapes] (into shapes (map :id orphans))))))
page)))]
(update-pages data update-page))))
;; DO NOT DELETE already used scripts, could be taken as templates for easyly writing new ones
;; -------------------------------------------------------------------------------------------
;; (defn repair-orphaned-components
;; "We have detected some cases of component instances that are not nested, but
;; however they have not the :component-root? attribute (so the system considers
;; them nested). This script fixes this adding them the attribute.
;;
;; Use it with the update-file function above."
;; [data]
;; (let [update-page
;; (fn [page]
;; (prn "================= Page:" (:name page))
;; (letfn [(is-nested? [object]
;; (and (some? (:component-id object))
;; (nil? (:component-root? object))))
;;
;; (is-instance? [object]
;; (some? (:shape-ref object)))
;;
;; (get-parent [object]
;; (get (:objects page) (:parent-id object)))
;;
;; (update-object [object]
;; (if (and (is-nested? object)
;; (not (is-instance? (get-parent object))))
;; (do
;; (prn "Orphan:" (:name object))
;; (assoc object :component-root? true))
;; object))]
;;
;; (update page :objects d/update-vals update-object)))]
;;
;; (update data :pages-index d/update-vals update-page)))
;; (defn check-image-shapes
;; [{:keys [data] :as file} stats]
;; (println "=> analizing file:" (:name file) (:id file))
;; (swap! stats update :total-files (fnil inc 0))
;; (let [affected? (atom false)]
;; (walk/prewalk (fn [obj]
;; (when (and (map? obj) (= :image (:type obj)))
;; (when-let [fcolor (some-> obj :fill-color str/upper)]
;; (when (or (= fcolor "#B1B2B5")
;; (= fcolor "#7B7D85"))
;; (reset! affected? true)
;; (swap! stats update :affected-shapes (fnil inc 0))
;; (println "--> image shape:" ((juxt :id :name :fill-color :fill-opacity) obj)))))
;; obj)
;; data)
;; (when @affected?
;; (swap! stats update :affected-files (fnil inc 0)))))
(defn run-task!
([system name]
(run-task! system name {}))
([system name params]
(let [tasks (:app.worker/registry system)]
(if-let [task-fn (get tasks name)]
(task-fn params)
(l/warn :hint "no task found" :name name)))))

134
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)
@ -268,39 +270,48 @@
(defmethod ig/pre-init-spec ::gc-deleted-task [_]
(s/keys :req-un [::storage ::db/pool ::min-age ::wrk/executor]))
(defmethod ig/prep-key ::gc-deleted-task
[_ cfg]
(merge {:min-age (dt/duration {:hours 2})}
(d/without-nils cfg)))
(defmethod ig/init-key ::gc-deleted-task
[_ {:keys [pool storage min-age] :as cfg}]
(letfn [(retrieve-deleted-objects-chunk [conn cursor]
[_ {:keys [pool storage] :as cfg}]
(letfn [(retrieve-deleted-objects-chunk [conn min-age cursor]
(let [min-age (db/interval min-age)
rows (db/exec! conn [sql:retrieve-deleted-objects-chunk min-age cursor])]
[(some-> rows peek :created-at)
(some->> (seq rows) (d/group-by #(-> % :backend keyword) :id #{}) seq)]))
(retrieve-deleted-objects [conn]
(->> (d/iteration (fn [cursor]
(retrieve-deleted-objects-chunk conn cursor))
(retrieve-deleted-objects [conn min-age]
(->> (d/iteration (partial retrieve-deleted-objects-chunk conn min-age)
:initk (dt/now)
:vf second
:kf first)
(sequence cat)))
(delete-in-bulk [conn backend ids]
(let [backend (impl/resolve-backend storage backend)
(delete-in-bulk [conn backend-name ids]
(let [backend (impl/resolve-backend storage backend-name)
backend (assoc backend :conn conn)]
(doseq [id ids]
(l/debug :hint "permanently delete storage object" :task "gc-deleted" :backend backend-name :id id))
@(impl/del-objects-in-bulk backend ids)))]
(fn [_]
(db/with-atomic [conn pool]
(loop [total 0
groups (retrieve-deleted-objects conn)]
(if-let [[backend ids] (first groups)]
(do
(delete-in-bulk conn backend ids)
(recur (+ total (count ids))
(rest groups)))
(do
(l/info :task "gc-deleted" :count total)
{:deleted total})))))))
(fn [params]
(let [min-age (or (:min-age params) (:min-age cfg))]
(db/with-atomic [conn pool]
(loop [total 0
groups (retrieve-deleted-objects conn min-age)]
(if-let [[backend ids] (first groups)]
(do
(delete-in-bulk conn backend ids)
(recur (+ total (count ids))
(rest groups)))
(do
(l/info :hint "task finished" :min-age (dt/format-duration min-age) :task "gc-deleted" :total total)
{:deleted total}))))))))
(def sql:retrieve-deleted-objects-chunk
"with items_part as (
@ -343,14 +354,14 @@
(defmethod ig/init-key ::gc-touched-task
[_ {:keys [pool] :as cfg}]
(letfn [(has-team-font-variant-nrefs? [conn id]
(-> (db/exec-one! conn [sql:retrieve-team-font-variant-nrefs id id id id]) :nrefs pos?))
(letfn [(get-team-font-variant-nrefs [conn id]
(-> (db/exec-one! conn [sql:retrieve-team-font-variant-nrefs id id id id]) :nrefs))
(has-file-media-object-nrefs? [conn id]
(-> (db/exec-one! conn [sql:retrieve-file-media-object-nrefs id id]) :nrefs pos?))
(get-file-media-object-nrefs [conn id]
(-> (db/exec-one! conn [sql:retrieve-file-media-object-nrefs id id]) :nrefs))
(has-profile-nrefs? [conn id]
(-> (db/exec-one! conn [sql:retrieve-profile-nrefs id id]) :nrefs pos?))
(get-profile-nrefs [conn id]
(-> (db/exec-one! conn [sql:retrieve-profile-nrefs id id]) :nrefs))
(mark-freeze-in-bulk [conn ids]
(db/exec-one! conn ["update storage_object set touched_at=null where id = ANY(?)"
@ -393,15 +404,23 @@
:kf first)
(sequence cat)))
(process-objects! [conn pred-fn ids]
(process-objects! [conn get-fn ids bucket]
(loop [to-freeze #{}
to-delete #{}
ids (seq ids)]
(if-let [id (first ids)]
(if (pred-fn conn id)
(recur (conj to-freeze id) to-delete (rest ids))
(recur to-freeze (conj to-delete id) (rest ids)))
(let [nrefs (get-fn conn id)]
(if (pos? nrefs)
(do
(l/debug :hint "processing storage object"
:task "gc-touched" :id id :status "freeze"
:bucket bucket :refs nrefs)
(recur (conj to-freeze id) to-delete (rest ids)))
(do
(l/debug :hint "processing storage object"
:task "gc-touched" :id id :status "delete"
:bucket bucket :refs nrefs)
(recur to-freeze (conj to-delete id) (rest ids)))))
(do
(some->> (seq to-freeze) (mark-freeze-in-bulk conn))
(some->> (seq to-delete) (mark-delete-in-bulk conn))
@ -415,9 +434,9 @@
groups (retrieve-touched conn)]
(if-let [[bucket ids] (first groups)]
(let [[f d] (case bucket
"file-media-object" (process-objects! conn has-file-media-object-nrefs? ids)
"team-font-variant" (process-objects! conn has-team-font-variant-nrefs? ids)
"profile" (process-objects! conn has-profile-nrefs? ids)
"file-media-object" (process-objects! conn get-file-media-object-nrefs ids bucket)
"team-font-variant" (process-objects! conn get-team-font-variant-nrefs ids bucket)
"profile" (process-objects! conn get-profile-nrefs ids bucket)
(ex/raise :type :internal
:code :unexpected-unknown-reference
:hint (dm/fmt "unknown reference %" bucket)))]
@ -425,15 +444,16 @@
(+ to-delete d)
(rest groups)))
(do
(l/info :task "gc-touched" :to-freeze to-freeze :to-delete to-delete)
(l/info :hint "task finished" :task "gc-touched" :to-freeze to-freeze :to-delete to-delete)
{:freeze to-freeze :delete to-delete})))))))
(def sql:retrieve-touched-objects-chunk
"select so.* from storage_object as so
where so.touched_at is not null
and so.created_at < ?
order by so.created_at desc
limit 500;")
"SELECT so.*
FROM storage_object AS so
WHERE so.touched_at IS NOT NULL
AND so.created_at < ?
ORDER by so.created_at DESC
LIMIT 500;")
(def sql:retrieve-file-media-object-nrefs
"select ((select count(*) from file_media_object where media_id = ?) +

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))

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

@ -14,6 +14,7 @@
[app.common.logging :as l]
[app.common.pages.helpers :as cph]
[app.common.pages.migrations :as pmg]
[app.config :as cf]
[app.db :as db]
[app.util.blob :as blob]
[app.util.time :as dt]
@ -29,16 +30,22 @@
;; HANDLER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::max-age ::dt/duration)
(s/def ::min-age ::dt/duration)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::db/pool ::max-age]))
(s/keys :req-un [::db/pool ::min-age]))
(defmethod ig/prep-key ::handler
[_ cfg]
(merge {:min-age cf/deletion-delay}
(d/without-nils cfg)))
(defmethod ig/init-key ::handler
[_ {:keys [pool] :as cfg}]
(fn [_]
(fn [params]
(db/with-atomic [conn pool]
(let [cfg (assoc cfg :conn conn)]
(let [min-age (or (:min-age params) (:min-age cfg))
cfg (assoc cfg :min-age min-age :conn conn)]
(loop [total 0
files (retrieve-candidates cfg)]
(if-let [file (first files)]
@ -47,7 +54,12 @@
(recur (inc total)
(rest files)))
(do
(l/debug :msg "finished processing files" :processed total)
(l/info :hint "task finished" :min-age (dt/format-duration min-age) :total total)
;; Allow optional rollback passed by params
(when (:rollback? params)
(db/rollback! conn))
{:processed total})))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -69,20 +81,22 @@
for update skip locked")
(defn- retrieve-candidates
[{:keys [conn max-age] :as cfg}]
(let [interval (db/interval max-age)
[{:keys [conn min-age id] :as cfg}]
(if id
(do
(l/warn :hint "explicit file id passed on params" :id id)
(db/query conn :file {:id id}))
(let [interval (db/interval min-age)
get-chunk (fn [cursor]
(let [rows (db/exec! conn [sql:retrieve-candidates-chunk interval cursor])]
[(some->> rows peek :modified-at) (seq rows)]))]
get-chunk
(fn [cursor]
(let [rows (db/exec! conn [sql:retrieve-candidates-chunk interval cursor])]
[(some->> rows peek :modified-at) (seq rows)]))]
(sequence cat (d/iteration get-chunk
:vf second
:kf first
:initk (dt/now))))))
(sequence cat (d/iteration get-chunk
:vf second
:kf first
:initk (dt/now)))))
(defn- collect-used-media
(defn collect-used-media
[data]
(let [xform (comp
(map :objects)
@ -142,14 +156,14 @@
"delete from file_object_thumbnail "
" where file_id=? and object_id=ANY(?)")
res (db/exec-one! conn [sql file-id (db/create-array conn "text" unused)])]
(l/debug :hint "delete object thumbnails" :total (:next.jdbc/update-count res))))))
(l/debug :hint "delete file object thumbnails" :file-id file-id :total (:next.jdbc/update-count res))))))
(defn- clean-file-thumbnails!
[conn file-id revn]
(let [sql (str "delete from file_thumbnail "
" where file_id=? and revn < ?")
res (db/exec-one! conn [sql file-id revn])]
(l/debug :hint "delete file thumbnails" :total (:next.jdbc/update-count res))))
(l/debug :hint "delete file thumbnails" :file-id file-id :total (:next.jdbc/update-count res))))
(defn- process-file
[{:keys [conn] :as cfg} {:keys [id data revn modified-at] :as file}]

63
backend/src/app/tasks/file_offload.clj
View file

@ -1,63 +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.tasks.file-offload
"A maintenance task that offloads file data to an external storage (S3)."
(:require
[app.common.logging :as l]
[app.common.spec :as us]
[app.db :as db]
[app.storage :as sto]
[app.storage.impl :as simpl]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(def sql:offload-candidates-chunk
"select f.id, f.data from file as f
where f.data is not null
and f.modified_at < now() - ?::interval
order by f.modified_at
limit 10")
(defn- retrieve-candidates
[{:keys [conn max-age]}]
(db/exec! conn [sql:offload-candidates-chunk max-age]))
(defn- offload-candidate
[{:keys [storage conn backend] :as cfg} {:keys [id data] :as file}]
(l/debug :hint "offload file data" :id id)
(let [backend (simpl/resolve-backend storage backend)]
(->> (simpl/content data)
(simpl/put-object backend file))
(db/update! conn :file
{:data nil
:data-backend (name (:id backend))}
{:id id})))
;; ---- STATE INIT
(s/def ::max-age ::dt/duration)
(s/def ::backend ::us/keyword)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::db/pool ::max-age ::sto/storage ::backend]))
(defmethod ig/init-key ::handler
[_ {:keys [pool max-age] :as cfg}]
(fn [_]
(db/with-atomic [conn pool]
(let [max-age (db/interval max-age)
cfg (-> cfg
(assoc :conn conn)
(assoc :max-age max-age))]
(loop [n 0]
(let [candidates (retrieve-candidates cfg)]
(if (seq candidates)
(do
(run! (partial offload-candidate cfg) candidates)
(recur (+ n (count candidates))))
(l/debug :hint "offload summary" :count n))))))))

33
backend/src/app/tasks/file_xlog_gc.clj
View file

@ -8,6 +8,7 @@
"A maintenance task that performs a garbage collection of the file
change (transaction) log."
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.db :as db]
[app.util.time :as dt]
@ -16,21 +17,31 @@
(declare sql:delete-files-xlog)
(s/def ::max-age ::dt/duration)
(s/def ::min-age ::dt/duration)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::db/pool ::max-age]))
(s/keys :req-un [::db/pool]
:opt-un [::min-age]))
(defmethod ig/prep-key ::handler
[_ cfg]
(merge {:min-age (dt/duration {:hours 72})}
(d/without-nils cfg)))
(defmethod ig/init-key ::handler
[_ {:keys [pool max-age] :as cfg}]
(fn [_]
(db/with-atomic [conn pool]
(let [interval (db/interval max-age)
result (db/exec-one! conn [sql:delete-files-xlog interval])
result (:next.jdbc/update-count result)]
(l/info :hint "remove old file changes"
:removed result)
result))))
[_ {:keys [pool] :as cfg}]
(fn [params]
(let [min-age (or (:min-age params) (:min-age cfg))]
(db/with-atomic [conn pool]
(let [interval (db/interval min-age)
result (db/exec-one! conn [sql:delete-files-xlog interval])
result (:next.jdbc/update-count result)]
(l/info :hint "task finished" :min-age (dt/format-duration min-age) :total result)
(when (:rollback? params)
(db/rollback! conn))
result)))))
(def ^:private
sql:delete-files-xlog

76
backend/src/app/tasks/objects_gc.clj
View file

@ -8,7 +8,9 @@
"A maintenance task that performs a general purpose garbage collection
of deleted objects."
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.config :as cf]
[app.db :as db]
[app.media :as media]
[app.storage :as sto]
@ -41,38 +43,38 @@
;; --- IMPL: generic object deletion
(defmethod delete-objects :default
[{:keys [conn max-age table] :as cfg}]
[{:keys [conn min-age table] :as cfg}]
(let [sql (str/fmt sql:delete-objects
{:table table :limit 50})
result (db/exec! conn [sql max-age])]
result (db/exec! conn [sql min-age])]
(doseq [{:keys [id] :as item} result]
(l/trace :hint "delete object" :table table :id id))
(l/debug :hint "permanently delete object" :table table :id id))
(count result)))
;; --- IMPL: file deletion
(defmethod delete-objects "file"
[{:keys [conn max-age table] :as cfg}]
[{:keys [conn min-age table] :as cfg}]
(let [sql (str/fmt sql:delete-objects {:table table :limit 50})
result (db/exec! conn [sql max-age])]
result (db/exec! conn [sql min-age])]
(doseq [{:keys [id] :as item} result]
(l/trace :hint "delete object" :table table :id id))
(l/debug :hint "permanently delete object" :table table :id id))
(count result)))
;; --- IMPL: team-font-variant deletion
(defmethod delete-objects "team_font_variant"
[{:keys [conn max-age storage table] :as cfg}]
[{:keys [conn min-age storage table] :as cfg}]
(let [sql (str/fmt sql:delete-objects
{:table table :limit 50})
fonts (db/exec! conn [sql max-age])
fonts (db/exec! conn [sql min-age])
storage (media/configure-assets-storage storage conn)]
(doseq [{:keys [id] :as font} fonts]
(l/trace :hint "delete object" :table table :id id)
(l/debug :hint "permanently delete object" :table table :id id)
(some->> (:woff1-file-id font) (sto/touch-object! storage) deref)
(some->> (:woff2-file-id font) (sto/touch-object! storage) deref)
(some->> (:otf-file-id font) (sto/touch-object! storage) deref)
@ -82,14 +84,14 @@
;; --- IMPL: team deletion
(defmethod delete-objects "team"
[{:keys [conn max-age storage table] :as cfg}]
[{:keys [conn min-age storage table] :as cfg}]
(let [sql (str/fmt sql:delete-objects
{:table table :limit 50})
teams (db/exec! conn [sql max-age])
teams (db/exec! conn [sql min-age])
storage (assoc storage :conn conn)]
(doseq [{:keys [id] :as team} teams]
(l/trace :hint "delete object" :table table :id id)
(l/debug :hint "permanently delete object" :table table :id id)
(some->> (:photo-id team) (sto/touch-object! storage) deref))
(count teams)))
@ -115,17 +117,17 @@
where id in (select id from owned)")
(defmethod delete-objects "profile"
[{:keys [conn max-age storage table] :as cfg}]
[{:keys [conn min-age storage table] :as cfg}]
(let [sql (str/fmt sql:retrieve-deleted-profiles {:limit 50})
profiles (db/exec! conn [sql max-age])
profiles (db/exec! conn [sql min-age])
storage (assoc storage :conn conn)]
(doseq [{:keys [id] :as profile} profiles]
(l/trace :hint "delete object" :table table :id id)
(l/debug :hint "permanently delete object" :table table :id id)
;; Mark the owned teams as deleted; this enables them to be processed
;; in the same transaction in the "team" table step.
(db/exec-one! conn [sql:mark-owned-teams-deleted id max-age])
(db/exec-one! conn [sql:mark-owned-teams-deleted id min-age])
;; Mark as deleted the storage object related with the photo-id
;; field.
@ -144,22 +146,40 @@
(let [res (delete-objects cfg)]
(if (pos? res)
(recur (+ n res))
(l/debug :hint "table gc summary" :table table :deleted n)))))
(do
(l/debug :hint "delete summary" :table table :total n)
n)))))
(s/def ::max-age ::dt/duration)
(s/def ::min-age ::dt/duration)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::db/pool ::sto/storage ::max-age]))
(s/keys :req-un [::db/pool ::sto/storage]
:opt-un [::min-age]))
(defmethod ig/prep-key ::handler
[_ cfg]
(merge {:min-age cf/deletion-delay}
(d/without-nils cfg)))
(defmethod ig/init-key ::handler
[_ {:keys [pool max-age] :as cfg}]
(fn [task]
[_ {:keys [pool] :as cfg}]
(fn [params]
;; Checking first on task argument allows properly testing it.
(let [max-age (get task :max-age max-age)]
(let [min-age (or (:min-age params) (:min-age cfg))]
(db/with-atomic [conn pool]
(let [max-age (db/interval max-age)
cfg (-> cfg
(assoc :max-age max-age)
(assoc :conn conn))]
(doseq [table target-tables]
(process-table (assoc cfg :table table))))))))
(let [cfg (-> cfg
(assoc :min-age (db/interval min-age))
(assoc :conn conn))]
(loop [tables (seq target-tables)
total 0]
(if-let [table (first tables)]
(recur (rest tables)
(+ total (process-table (assoc cfg :table table))))
(do
(l/info :hint "task finished" :min-age (dt/format-duration min-age) :total total)
(when (:rollback? params)
(db/rollback! conn))
{:processed total}))))))))

33
backend/src/app/tasks/tasks_gc.clj
View file

@ -8,7 +8,9 @@
"A maintenance task that performs a cleanup of already executed tasks
from the database table."
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.config :as cf]
[app.db :as db]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
@ -16,20 +18,31 @@
(declare sql:delete-completed-tasks)
(s/def ::max-age ::dt/duration)
(s/def ::min-age ::dt/duration)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::db/pool ::max-age]))
(s/keys :req-un [::db/pool]
:opt-un [::min-age]))
(defmethod ig/prep-key ::handler
[_ cfg]
(merge {:min-age cf/deletion-delay}
(d/without-nils cfg)))
(defmethod ig/init-key ::handler
[_ {:keys [pool max-age] :as cfg}]
(fn [_]
(db/with-atomic [conn pool]
(let [interval (db/interval max-age)
result (db/exec-one! conn [sql:delete-completed-tasks interval])
result (:next.jdbc/update-count result)]
(l/debug :hint "trim completed tasks table" :removed result)
result))))
[_ {:keys [pool] :as cfg}]
(fn [params]
(let [min-age (or (:min-age params) (:min-age cfg))]
(db/with-atomic [conn pool]
(let [interval (db/interval min-age)
result (db/exec-one! conn [sql:delete-completed-tasks interval])
result (:next.jdbc/update-count result)]
(l/debug :hint "task finished" :total result)
(when (:rollback? params)
(db/rollback! conn))
result)))))
(def ^:private
sql:delete-completed-tasks

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

@ -18,7 +18,10 @@
(defn- generate
[cfg claims]
(let [payload (-> claims d/without-nils t/encode)]
(let [payload (-> claims
(assoc :iat (dt/now))
(d/without-nils)
(t/encode))]
(jwe/encrypt payload (::secret cfg) {:alg :a256kw :enc :a256gcm})))
(defn- verify

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)))

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

@ -27,7 +27,7 @@
(throw (IllegalArgumentException. "Missing arguments on `defmethod` macro.")))
(let [mdata (assoc mdata
::docs (some-> docs str/<<-)
::docstring (some-> docs str/<<-)
::spec sname
::name (name sname))
@ -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]

3
backend/src/app/util/time.clj
View file

@ -116,6 +116,9 @@
Duration
(-edn [o] (pr-str o)))
(defn format-duration
[o]
(str/lower (subs (str o) 2)))
;; --- INSTANT

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))

28
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))
@ -225,7 +224,7 @@
:name (d/name name)
:queue (d/name queue))
(do
(l/info :hint "worker started"
(l/info :hint "worker initialized"
:name (d/name name)
:queue (d/name queue))
(event-loop cfg)))
@ -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
(defn- synchronize-cron-entries!
[{:keys [pool entries]}]
(db/with-atomic [conn pool]
(run! (partial synchronize-cron-item conn) entries)))
(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,6 +562,7 @@
(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)

65
backend/test/app/services_files_test.clj
View file

@ -187,23 +187,18 @@
;; freeze because of the deduplication (we have uploaded 2 times
;; 2 two same files).
(let [task (:app.storage/gc-touched-task th/*system*)
res (task {})]
res (task {:min-age (dt/duration 0)})]
(t/is (= 2 (:freeze res)))
(t/is (= 0 (:delete res))))
;; run the task immediately
;; run the file-gc task immediately without forced min-age
(let [task (:app.tasks.file-gc/handler th/*system*)
res (task {})]
(t/is (= 0 (:processed res))))
;; make the file eligible for GC waiting 300ms (configured
;; timeout for testing)
(th/sleep 300)
;; run the task again
(let [task (:app.tasks.file-gc/handler th/*system*)
res (task {})]
res (task {:min-age (dt/duration 0)})]
(t/is (= 1 (:processed res))))
;; retrieve file and check trimmed attribute
@ -220,22 +215,36 @@
(t/is (some? @(sto/get-object storage (:media-id fmo1))))
(t/is (some? @(sto/get-object storage (:thumbnail-id fmo1))))
;; now, we have deleted the unused file-media-object, if we
;; execute the touched-gc task, we should see that two of them
;; are marked to be deleted.
;; proceed to remove usage of the file
(update-file {:file-id (:id file)
:profile-id (:id profile)
:revn 0
:changes [{:type :del-obj
:page-id (first (get-in file [:data :pages]))
:id shid}]})
;; Now, we have deleted the usag of pointers to the
;; file-media-objects, if we pase file-gc, they should be marked
;; as deleted.
(let [task (:app.tasks.file-gc/handler th/*system*)
res (task {:min-age (dt/duration 0)})]
(t/is (= 1 (:processed res))))
;; Now that file-gc have deleted the file-media-object usage,
;; lets execute the touched-gc task, we should see that two of
;; them are marked to be deleted.
(let [task (:app.storage/gc-touched-task th/*system*)
res (task {})]
(t/is (= 2 (:freeze res)))
(t/is (= 0 (:delete res))))
res (task {:min-age (dt/duration 0)})]
(t/is (= 0 (:freeze res)))
(t/is (= 2 (:delete res))))
;; Finally, check that some of the objects that are marked as
;; deleted we are unable to retrieve them using standard storage
;; public api.
(t/is (some? @(sto/get-object storage (:media-id fmo2))))
(t/is (some? @(sto/get-object storage (:thumbnail-id fmo2))))
(t/is (some? @(sto/get-object storage (:media-id fmo1))))
(t/is (some? @(sto/get-object storage (:thumbnail-id fmo1))))
(t/is (nil? @(sto/get-object storage (:media-id fmo2))))
(t/is (nil? @(sto/get-object storage (:thumbnail-id fmo2))))
(t/is (nil? @(sto/get-object storage (:media-id fmo1))))
(t/is (nil? @(sto/get-object storage (:thumbnail-id fmo1))))
)))
(t/deftest permissions-checks-creating-file
@ -353,8 +362,8 @@
:profile-id (:id profile1)})]
;; file is not deleted because it does not meet all
;; conditions to be deleted.
(let [result (task {:max-age (dt/duration 0)})]
(t/is (nil? result)))
(let [result (task {:min-age (dt/duration 0)})]
(t/is (= 0 (:processed result))))
;; query the list of files
(let [data {::th/type :project-files
@ -384,8 +393,8 @@
(t/is (= 0 (count result)))))
;; run permanent deletion (should be noop)
(let [result (task {:max-age (dt/duration {:minutes 1})})]
(t/is (nil? result)))
(let [result (task {:min-age (dt/duration {:minutes 1})})]
(t/is (= 0 (:processed result))))
;; query the list of file libraries of a after hard deletion
(let [data {::th/type :file-libraries
@ -398,8 +407,8 @@
(t/is (= 0 (count result)))))
;; run permanent deletion
(let [result (task {:max-age (dt/duration 0)})]
(t/is (nil? result)))
(let [result (task {:min-age (dt/duration 0)})]
(t/is (= 1 (:processed result))))
;; query the list of file libraries of a after hard deletion
(let [data {::th/type :file-libraries
@ -590,7 +599,7 @@
;; run the task again
(let [task (:app.tasks.file-gc/handler th/*system*)
res (task {})]
res (task {:min-age (dt/duration 0)})]
(t/is (= 1 (:processed res))))
;; check that object thumbnails are still here
@ -617,7 +626,7 @@
;; run the task again
(let [task (:app.tasks.file-gc/handler th/*system*)
res (task {})]
res (task {:min-age (dt/duration 0)})]
(t/is (= 1 (:processed res))))
;; check that the unknown frame thumbnail is deleted
@ -701,7 +710,7 @@
;; run the task again
(let [task (:app.tasks.file-gc/handler th/*system*)
res (task {})]
res (task {:min-age (dt/duration 0)})]
(t/is (= 1 (:processed res))))
;; Then query the specific revn

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)

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

@ -46,9 +46,11 @@
(t/is (sto/storage-object? mobj1))
(t/is (sto/storage-object? mobj2))
(t/is (= 122785 (:size mobj1)))
;; 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))))))
))
(= 3303 (:size mobj2))))))))
(t/deftest media-object-upload
(let [prof (th/create-profile* 1)

32
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)))
@ -128,8 +126,8 @@
;; profile is not deleted because it does not meet all
;; conditions to be deleted.
(let [result (task {:max-age (dt/duration 0)})]
(t/is (nil? result)))
(let [result (task {:min-age (dt/duration 0)})]
(t/is (= 0 (:processed result))))
;; Request profile to be deleted
(let [params {::th/type :delete-profile
@ -147,8 +145,8 @@
(t/is (= 1 (count (:result out)))))
;; execute permanent deletion task
(let [result (task {:max-age (dt/duration "-1m")})]
(t/is (nil? result)))
(let [result (task {:min-age (dt/duration "-1m")})]
(t/is (= 1 (:processed result))))
;; query profile after delete
(let [params {::th/type :profile
@ -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

12
backend/test/app/services_projects_test.clj
View file

@ -179,8 +179,8 @@
;; project is not deleted because it does not meet all
;; conditions to be deleted.
(let [result (task {:max-age (dt/duration 0)})]
(t/is (nil? result)))
(let [result (task {:min-age (dt/duration 0)})]
(t/is (= 0 (:processed result))))
;; query the list of projects
(let [data {::th/type :projects
@ -210,8 +210,8 @@
(t/is (= 1 (count result)))))
;; run permanent deletion (should be noop)
(let [result (task {:max-age (dt/duration {:minutes 1})})]
(t/is (nil? result)))
(let [result (task {:min-age (dt/duration {:minutes 1})})]
(t/is (= 0 (:processed result))))
;; query the list of files of a after soft deletion
(let [data {::th/type :project-files
@ -224,8 +224,8 @@
(t/is (= 0 (count result)))))
;; run permanent deletion
(let [result (task {:max-age (dt/duration 0)})]
(t/is (nil? result)))
(let [result (task {:min-age (dt/duration 0)})]
(t/is (= 1 (:processed result))))
;; query the list of files of a after hard deletion
(let [data {::th/type :project-files

12
backend/test/app/services_teams_test.clj
View file

@ -99,8 +99,8 @@
;; team is not deleted because it does not meet all
;; conditions to be deleted.
(let [result (task {:max-age (dt/duration 0)})]
(t/is (nil? result)))
(let [result (task {:min-age (dt/duration 0)})]
(t/is (= 0 (:processed result))))
;; query the list of teams
(let [data {::th/type :teams
@ -132,8 +132,8 @@
(t/is (= (:default-team-id profile1) (get-in result [0 :id])))))
;; run permanent deletion (should be noop)
(let [result (task {:max-age (dt/duration {:minutes 1})})]
(t/is (nil? result)))
(let [result (task {:min-age (dt/duration {:minutes 1})})]
(t/is (= 0 (:processed result))))
;; query the list of projects after hard deletion
(let [data {::th/type :projects
@ -147,8 +147,8 @@
(t/is (= (:type error-data) :not-found))))
;; run permanent deletion
(let [result (task {:max-age (dt/duration 0)})]
(t/is (nil? result)))
(let [result (task {:min-age (dt/duration 0)})]
(t/is (= 1 (:processed result))))
;; query the list of projects of a after hard deletion
(let [data {::th/type :projects

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")

BIN
backend/test/app/test_files/template.penpot Normal file
View file

Binary file not shown.

46
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)
@ -50,6 +51,7 @@
(defn state-init
[next]
(let [config (-> main/system-config
(merge main/worker-config)
(assoc-in [:app.msgbus/msgbus :redis-uri] (:redis-uri config))
(assoc-in [:app.db/pool :uri] (:database-uri config))
(assoc-in [:app.db/pool :username] (:database-username config))
@ -59,10 +61,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
@ -72,18 +76,16 @@
:app.loggers.database/reporter
:app.loggers.zmq/receiver
:app.worker/cron
:app.worker/worker)
(d/deep-merge
{:app.tasks.file-gc/handler {:max-age (dt/duration 300)}}))
:app.worker/worker))
_ (ig/load-namespaces config)
system (-> (ig/prep config)
(ig/init))]
(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 +142,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 +269,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.8"}
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.8",
"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)

19
common/src/app/common/geom/matrix.cljc
View file

@ -14,6 +14,8 @@
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
(def precision 3)
;; --- Matrix Impl
(defrecord Matrix [^double a
@ -24,7 +26,13 @@
^double f]
Object
(toString [_]
(str "matrix(" a "," b "," c "," d "," e "," f ")")))
(str "matrix("
(mth/precision a precision) ","
(mth/precision b precision) ","
(mth/precision c precision) ","
(mth/precision d precision) ","
(mth/precision e precision) ","
(mth/precision f precision) ")")))
(defn matrix?
"Return true if `v` is Matrix instance."
@ -66,6 +74,15 @@
(mth/close? (.-e m1) (.-e m2))
(mth/close? (.-f m1) (.-f m2))))
(defn unit? [m1]
(and (some? m1)
(mth/close? (.-a m1) 1)
(mth/close? (.-b m1) 0)
(mth/close? (.-c m1) 0)
(mth/close? (.-d m1) 1)
(mth/close? (.-e m1) 0)
(mth/close? (.-f m1) 0)))
(defn multiply
([^Matrix m1 ^Matrix m2]
(let [m1a (.-a m1)

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?)

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

@ -0,0 +1,158 @@
;; 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 (if (cph/frame-shape? shape)
[(calculate-base-bounds shape)]
(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 (cond->> (gsr/join-selrects bounds)
(not (cph/frame-shape? shape)) (or (:children-bounds shape)))
filters (shape->filters shape)
blur-value (or (-> shape :blur :value) 0)]
(get-rect-filter-bounds children-bounds filters blur-value)))

36
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)
@ -236,11 +251,6 @@
(gmt/rotate-matrix (- rotation-angle)))]
[stretch-matrix stretch-matrix-inverse rotation-angle])))
(defn is-rotated?
[[a b _c _d]]
;; true if either a-b or c-d are parallel to the axis
(not (mth/close? (:y a) (:y b))))
(defn- adjust-rotated-transform
[{:keys [transform transform-inverse flip-x flip-y]} points]
(let [center (gco/center-points points)
@ -272,12 +282,9 @@
points (gco/transform-points points' transform-mtx)
bool? (= (:type shape) :bool)
path? (= (:type shape) :path)
rotated? (is-rotated? points)
[selrect transform transform-inverse]
(if (not rotated?)
[(gpr/points->selrect points) nil nil]
(adjust-rotated-transform shape points))
(adjust-rotated-transform shape points)
base-rotation (or (:rotation shape) 0)
modif-rotation (or (get-in shape [:modifiers :rotation]) 0)
@ -632,6 +639,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."

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