Penpot/penpot
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-04-04 19:11:20 -05:00
Code Issues Activity

Merge branch 'staging' into main

Browse source
This commit is contained in:
Andrey Antukh 2021-03-01 17:18:38 +01:00
commit db49c54681
187 changed files with 8170 additions and 5179 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
.github/ISSUE_TEMPLATE/bug_report.md vendored
View file

@ -38,13 +38,13 @@ If applicable, add screenshots to help explain your problem.
- Version (e.g. 22)
**Environment (please complete the following information):**
Specify if using demo instance or self-hosted instance.
Specify if using SAAS (https://design.penpot.app) or self-hosted instance.
If self-hosted instance, add OS and runtime information to help explain your problem.
- OS Version: (e.g. Ubuntu 16.04)
Also provide Docker commands or docker-compose file if possible.
Also provide Docker commands or docker-compose file if possible and if proceed.x
- Docker / Docker-compose Version: (e.g. Docker version 18.03.0-ce, build 0520e24)
- Image (e.g. alpine)

57
CHANGES.md
View file

@ -1,15 +1,60 @@
# CHANGELOG #
## Next
## :rocket: Next
### New features
### :sparkles: New features
### Bugs fixed
### :bug: Bugs fixed
### :heart: Community contributions by (Thank you!)
## 1.3.0-alpha
### :sparkles: New features
- Add emailcatcher and ldap test containers to devenv. [#506](https://github.com/penpot/penpot/pull/506)
- Add major refactor of internal pubsub/redis code; improves scalability and performance [#640](https://github.com/penpot/penpot/pull/640)
- Add more chinese transtions [#687](https://github.com/penpot/penpot/pull/687)
- Add more presets for artboard [#654](https://github.com/penpot/penpot/pull/654)
- Add optional loki integration [#645](https://github.com/penpot/penpot/pull/645)
- Add proper http session lifecycle handling.
- Allow to set border radius of each rect corner individually
- Bounce & Complaint handling [#635](https://github.com/penpot/penpot/pull/635)
- Disable groups interactions when holding "Ctrl" key (deep selection)
- New action in context menu to "edit" some shapes (binded to key "Enter")
### :bug: Bugs fixed
- Add more improvements to french translation strings [#591](https://github.com/penpot/penpot/pull/591)
- Add some missing database indexes (mainly improves performance on large databases on file-update rpc method, and some background tasks).
- Disables filters in masking elements (problem with Firefox rendering)
- Drawing tool will have priority over resize/rotate handlers [Taiga #1225](https://tree.taiga.io/project/penpot/issue/1225)
- Fix broken bounding box on editing paths [Taiga #1254](https://tree.taiga.io/project/penpot/issue/1254)
- Fix corner cases on invitation/signup flows.
- Fix errors on onboarding file [Taiga #1287](https://tree.taiga.io/project/penpot/issue/1287)
- Fix infinite recursion on logout.
- Fix issues with frame selection [Taiga #1300](https://tree.taiga.io/project/penpot/issue/1300), [Taiga #1255](https://tree.taiga.io/project/penpot/issue/1255)
- Fix local fonts error [#691](https://github.com/penpot/penpot/issues/691)
- Fix problem width handoff code generation [Taiga #1204](https://tree.taiga.io/project/penpot/issue/1204)
- Fix problem with indices refreshing on page changes [#646](https://github.com/penpot/penpot/issues/646)
- Have language change notification written in the new language [Taiga #1205](https://tree.taiga.io/project/penpot/issue/1205)
- Hide register screen when registration is disabled [#598](https://github.com/penpot/penpot/issues/598)
- Properly handle errors on github, gitlab and ldap auth backends.
- Properly mark profile auth backend (on first register/ auth with 3rd party auth provider).
- Refactor LDAP auth backend.
### :heart: Community contributions by (Thank you!)
- girafic [#538](https://github.com/penpot/penpot/pull/654)
- arkhi [#591](https://github.com/penpot/penpot/pull/591)
## 1.2.0-alpha
### New features
### :sparkles: New features
- Add horizontal/vertical flip
- Add images lock proportions by default [#541](https://github.com/penpot/penpot/discussions/541), [#609](https://github.com/penpot/penpot/issues/609)
@ -22,7 +67,7 @@
- Fix behavior of select all command when there are objects outside frames [Taiga #1209](https://tree.taiga.io/project/penpot/issue/1209)
### Bugs fixed
### :bug: Bugs fixed
- Fix 404 when access shared link [#615](https://github.com/penpot/penpot/issues/615)
- Fix 500 when requestion password reset
@ -42,7 +87,7 @@
- Fix updates on collaborative editing not updating selection rectangles [Taiga #1127](https://tree.taiga.io/project/penpot/issue/1127)
- Make the team deletion deferred (in the same way other objects)
### Community contributions by (Thank you! :heart:)
### :heart: Community contributions by (Thank you!)
- abtinmo [#538](https://github.com/penpot/penpot/pull/538)
- kdrag0n [#585](https://github.com/penpot/penpot/pull/585)

6
backend/deps.edn
View file

@ -7,6 +7,7 @@
org.clojure/clojurescript {:mvn/version "1.10.773"}
org.clojure/data.json {:mvn/version "1.0.0"}
org.clojure/core.async {:mvn/version "1.3.610"}
org.clojure/tools.cli {:mvn/version "1.0.194"}
;; Logging
org.clojure/tools.logging {:mvn/version "1.1.0"}
@ -16,6 +17,8 @@
org.apache.logging.log4j/log4j-jul {:mvn/version "2.14.0"}
org.apache.logging.log4j/log4j-slf4j-impl {:mvn/version "2.14.0"}
org.slf4j/slf4j-api {:mvn/version "1.7.30"}
org.zeromq/jeromq {:mvn/version "0.5.2"}
org.graalvm.js/js {:mvn/version "20.3.0"}
com.taoensso/nippy {:mvn/version "3.1.1"}
@ -32,7 +35,7 @@
expound/expound {:mvn/version "0.8.7"}
com.cognitect/transit-clj {:mvn/version "1.0.324"}
io.lettuce/lettuce-core {:mvn/version "5.2.2.RELEASE"}
io.lettuce/lettuce-core {:mvn/version "6.0.2.RELEASE"}
java-http-clj/java-http-clj {:mvn/version "0.4.1"}
info.sunng/ring-jetty9-adapter {:mvn/version "0.14.2"}
@ -43,7 +46,6 @@
org.postgresql/postgresql {:mvn/version "42.2.18"}
com.zaxxer/HikariCP {:mvn/version "3.4.5"}
funcool/log4j2-clojure {:mvn/version "2020.11.23-1"}
funcool/datoteka {:mvn/version "1.2.0"}
funcool/promesa {:mvn/version "6.0.0"}
funcool/cuerdas {:mvn/version "2020.03.26-3"}

10
backend/dev/user.clj
View file

@ -9,24 +9,24 @@
(ns user
(:require
[app.common.exceptions :as ex]
[app.config :as cfg]
[app.main :as main]
[app.util.time :as dt]
[app.util.transit :as t]
[app.common.exceptions :as ex]
[taoensso.nippy :as nippy]
[clojure.data.json :as json]
[app.util.json :as json]
[clojure.java.io :as io]
[clojure.test :as test]
[clojure.pprint :refer [pprint]]
[clojure.repl :refer :all]
[clojure.spec.alpha :as s]
[clojure.spec.gen.alpha :as sgen]
[clojure.test :as test]
[clojure.test :as test]
[clojure.tools.namespace.repl :as repl]
[clojure.walk :refer [macroexpand-all]]
[criterium.core :refer [quick-bench bench with-progress-reporting]]
[integrant.core :as ig]))
[integrant.core :as ig]
[taoensso.nippy :as nippy]))
(repl/disable-reload! (find-ns 'integrant.core))

2
backend/resources/emails/feedback/en.subj
View file

@ -1 +1 @@
[FEEDBACK]: From {{ profile.email }}
[PENPOT FEEDBACK]: {{subject|abbreviate:19}} (from {{email}})

8
backend/resources/emails/feedback/en.txt
View file

@ -1,6 +1,8 @@
Feedback from: {{profile.fullname}} <{{profile.email}}>
Profile ID: {{profile.id}}
{% if profile %}
Feedback profile: {{profile.fullname}} <{{profile.email}}> / {{profile.id}}
{% else %}
Feedback from: {{email}}
{% endif %}
Subject: {{subject}}

56
backend/resources/error-report.tmpl
View file

@ -31,7 +31,7 @@
.table-key {
font-weight: 600;
width: 70px;
width: 60px;
padding: 4px;
}
@ -70,27 +70,43 @@
{% if user-agent %}
<div class="table-row">
<div class="table-key">UAGENT: </div>
<div class="table-key">UAGT: </div>
<div class="table-val">{{user-agent}}</div>
</div>
{% endif %}
{% if frontend-version %}
<div class="table-row">
<div class="table-key">FVERS: </div>
<div class="table-key">FVER: </div>
<div class="table-val">{{frontend-version}}</div>
</div>
{% endif %}
<div class="table-row">
<div class="table-key">BVERS: </div>
<div class="table-key">BVER: </div>
<div class="table-val">{{version}}</div>
</div>
{% if host %}
<div class="table-row">
<div class="table-key">HOST: </div>
<div class="table-val">{{host}}</div>
</div>
{% endif %}
{% if tenant %}
<div class="table-row">
<div class="table-key">ENV: </div>
<div class="table-val">{{tenant}}</div>
</div>
{% endif %}
{% if public-uri %}
<div class="table-row">
<div class="table-key">PURI: </div>
<div class="table-val">{{public-uri}}</div>
</div>
{% endif %}
{% if type %}
<div class="table-row">
@ -106,15 +122,19 @@
</div>
{% endif %}
{% if error %}
<div class="table-row">
<div class="table-key">CLASS: </div>
<div class="table-val">{{class}}</div>
<div class="table-key">CLSS: </div>
<div class="table-val">{{error.class}}</div>
</div>
{% endif %}
{% if error %}
<div class="table-row">
<div class="table-key">HINT: </div>
<div class="table-val">{{hint}}</div>
<div class="table-val">{{error.message}}</div>
</div>
{% endif %}
{% if method %}
<div class="table-row">
@ -123,8 +143,18 @@
</div>
{% endif %}
{% if explain %}
<div>(<a href="#explain">go to explain</a>)</div>
{% endif %}
{% if data %}
<div>(<a href="#edata">go to edata</a>)</div>
{% endif %}
{% if error %}
<div>(<a href="#trace">go to trace</a>)</div>
{% endif %}
{% if params %}
<div class="table-row multiline">
<div id="params" class="table-row multiline">
<div class="table-key">PARAMS: </div>
<div class="table-val">
<pre>{{params}}</pre>
@ -133,7 +163,7 @@
{% endif %}
{% if explain %}
<div class="table-row multiline">
<div id="explain" class="table-row multiline">
<div class="table-key">EXPLAIN: </div>
<div class="table-val">
<pre>{{explain}}</pre>
@ -142,7 +172,7 @@
{% endif %}
{% if data %}
<div class="table-row multiline">
<div id="edata" class="table-row multiline">
<div class="table-key">EDATA: </div>
<div class="table-val">
<pre>{{data}}</pre>
@ -150,12 +180,14 @@
</div>
{% endif %}
<div class="table-row multiline">
{% if error %}
<div id="trace" class="table-row multiline">
<div class="table-key">TRACE:</div>
<div class="table-val">
<pre>{{message}}</pre>
<pre>{{error.trace}}</pre>
</div>
</div>
{% endif %}
</div>
</body>
</html>

13
backend/resources/log4j2-bundle.xml
View file

@ -7,20 +7,15 @@
</Appenders>
<Loggers>
<Logger name="com.zaxxer.hikari" level="error" additivity="false">
<AppenderRef ref="console"/>
</Logger>
<Logger name="org.eclipse.jetty" level="info" additivity="false">
<AppenderRef ref="console"/>
</Logger>
<Logger name="com.zaxxer.hikari" level="error" />
<Logger name="org.eclipse.jetty" level="error" />
<Logger name="app" level="debug" additivity="false">
<AppenderRef ref="console"/>
<AppenderRef ref="console" />
</Logger>
<Root level="info">
<AppenderRef ref="console"/>
<AppenderRef ref="console" />
</Root>
</Loggers>
</Configuration>

24
backend/resources/log4j2.xml
View file

@ -13,27 +13,33 @@
<DefaultRolloverStrategy max="9"/>
</RollingFile>
<CljFn name="error-reporter" ns="app.error-reporter" fn="queue-fn">
<PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] [%t] %level{length=1} %logger{36} - %msg%n"/>
</CljFn>
<JeroMQ name="zmq">
<Property name="endpoint">tcp://localhost:45556</Property>
<JsonLayout complete="false" compact="true" includeTimeMillis="true" stacktraceAsString="true" properties="true" />
</JeroMQ>
</Appenders>
<Loggers>
<Logger name="com.zaxxer.hikari" level="error" additivity="false" />
<Logger name="org.eclipse.jetty" level="error" additivity="false" />
<Logger name="io.lettuce" level="error" additivity="false" />
<Logger name="com.zaxxer.hikari" level="error"/>
<Logger name="io.lettuce" level="error" />
<Logger name="org.eclipse.jetty" level="error" />
<Logger name="app.cli" level="debug" additivity="false">
<AppenderRef ref="console"/>
</Logger>
<Logger name="app.error-reporter" level="debug" additivity="false">
<Logger name="app.loggers" level="debug" additivity="false">
<AppenderRef ref="main" level="debug" />
</Logger>
<Logger name="app" level="debug" additivity="false">
<AppenderRef ref="main" level="debug" />
<AppenderRef ref="error-reporter" level="error" />
<AppenderRef ref="main" level="trace" />
<AppenderRef ref="zmq" level="debug" />
</Logger>
<Logger name="user" level="trace" additivity="false">
<AppenderRef ref="main" level="trace" />
<AppenderRef ref="zmq" level="debug" />
</Logger>
<Root level="info">

30
backend/scripts/build.sh
View file

@ -25,12 +25,8 @@ echo $NEWCP > ./target/dist/classpath;
tee -a ./target/dist/run.sh >> /dev/null <<EOF
#!/usr/bin/env bash
CP="$NEWCP"
# Exports
# Find java executable
set +e
JAVA_CMD=\$(type -p java)
@ -52,4 +48,30 @@ set -x
exec \$JAVA_CMD \$JVM_OPTS -classpath \$CP -Dlog4j.configurationFile=./log4j2.xml "\$@" clojure.main -m app.main
EOF
tee -a ./target/dist/manage.sh >> /dev/null <<EOF
#!/usr/bin/env bash
CP="$NEWCP"
set +e
JAVA_CMD=\$(type -p java)
set -e
if [[ ! -n "\$JAVA_CMD" ]]; then
if [[ -n "\$JAVA_HOME" ]] && [[ -x "\$JAVA_HOME/bin/java" ]]; then
JAVA_CMD="\$JAVA_HOME/bin/java"
else
>&2 echo "Couldn't find 'java'. Please set JAVA_HOME."
exit 1
fi
fi
if [ -f ./environ ]; then
source ./environ
fi
exec \$JAVA_CMD \$JVM_OPTS -classpath \$CP -Dlog4j.configurationFile=./log4j2.xml clojure.main -m app.cli.manage "\$@"
EOF
chmod +x ./target/dist/run.sh
chmod +x ./target/dist/manage.sh

7
backend/scripts/repl
View file

@ -2,6 +2,9 @@
export PENPOT_ASSERTS_ENABLED=true
export OPTIONS="-A:jmx-remote:dev -J-Dclojure.tools.logging.factory=clojure.tools.logging.impl/log4j2-factory -J-Xms512m -J-Xmx512m"
export OPTIONS_EVAL="nil"
# export OPTIONS_EVAL="(set! *warn-on-reflection* true)"
set -ex
# clojure -Ojmx-remote -A:dev -e "(set! *warn-on-reflection* true)" -m rebel-readline.main
clojure -A:jmx-remote:dev -J-Xms512m -J-Xmx512m -M -m rebel-readline.main
exec clojure $OPTIONS -M -e "$OPTIONS_EVAL" -m rebel-readline.main

4
backend/src/app/cli/fixtures.clj
View file

@ -81,7 +81,7 @@
{:id id
:fullname (str "Profile " index)
:password "123123"
:demo? true
:is-demo true
:email (str "profile" index "@example.com")})
team-id (:default-team-id prof)
owner-id id]
@ -237,6 +237,6 @@
(try
(run-in-system system preset)
(catch Exception e
(log/errorf e "Unhandled exception."))
(log/errorf e "unhandled exception"))
(finally
(ig/halt! system)))))

173
backend/src/app/cli/manage.clj Normal file
View file

@ -0,0 +1,173 @@
;; 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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2021 UXBOX Labs SL
(ns app.cli.manage
"A manage cli api."
(:require
[app.config :as cfg]
[app.db :as db]
[app.main :as main]
[app.rpc.mutations.profile :as profile]
[app.rpc.queries.profile :refer [retrieve-profile-data-by-email]]
[clojure.string :as str]
[clojure.tools.cli :refer [parse-opts]]
[clojure.tools.logging :as log]
[integrant.core :as ig])
(:import
java.io.Console))
;; --- IMPL
(defn init-system
[]
(let [data (-> (main/build-system-config cfg/config)
(select-keys [:app.db/pool :app.metrics/metrics])
(assoc :app.migrations/all {}))]
(-> data ig/prep ig/init)))
(defn- read-from-console
[{:keys [label type] :or {type :text}}]
(let [^Console console (System/console)]
(when-not console
(log/error "no console found, can proceed")
(System/exit 1))
(binding [*out* (.writer console)]
(print label " ")
(.flush *out*))
(case type
:text (.readLine console)
:password (String. (.readPassword console)))))
(defn create-profile
[options]
(let [system (init-system)
email (or (:email options)
(read-from-console {:label "Email:"}))
fullname (or (:fullname options)
(read-from-console {:label "Full Name:"}))
password (or (:password options)
(read-from-console {:label "Password:"
:type :password}))]
(try
(db/with-atomic [conn (:app.db/pool system)]
(->> (profile/create-profile conn
{:fullname fullname
:email email
:password password
:is-active true
:is-demo false})
(profile/create-profile-relations conn)))
(when (pos? (:verbosity options))
(println "User created successfully."))
(System/exit 0)
(catch Exception _e
(when (pos? (:verbosity options))
(println "Unable to create user, already exists."))
(System/exit 1)))))
(defn reset-password
[options]
(let [system (init-system)]
(try
(db/with-atomic [conn (:app.db/pool system)]
(let [email (or (:email options)
(read-from-console {:label "Email:"}))
profile (retrieve-profile-data-by-email conn email)]
(when-not profile
(when (pos? (:verbosity options))
(println "Profile does not exists."))
(System/exit 1))
(let [password (or (:password options)
(read-from-console {:label "Password:"
:type :password}))]
(profile/update-profile-password! conn (assoc profile :password password))
(when (pos? (:verbosity options))
(println "Password changed successfully.")))))
(System/exit 0)
(catch Exception e
(when (pos? (:verbosity options))
(println "Unable to change password."))
(when (= 2 (:verbosity options))
(.printStackTrace e))
(System/exit 1)))))
;; --- CLI PARSE
(def cli-options
;; An option with a required argument
[["-u" "--email EMAIL" "Email Address"]
["-p" "--password PASSWORD" "Password"]
["-n" "--name FULLNAME" "Full Name"
:id :fullname]
["-v" nil "Verbosity level"
:id :verbosity
:default 1
:update-fn inc]
["-q" nil "Dont' print to console"
:id :verbosity
:update-fn (constantly 0)]
["-h" "--help"]])
(defn usage
[options-summary]
(->> ["Penpot CLI management."
""
"Usage: manage [options] action"
""
"Options:"
options-summary
""
"Actions:"
" create-profile Create new profile."
" reset-password Reset profile password."
""]
(str/join \newline)))
(defn error-msg [errors]
(str "The following errors occurred while parsing your command:\n\n"
(str/join \newline errors)))
(defn validate-args
"Validate command line arguments. Either return a map indicating the program
should exit (with a error message, and optional ok status), or a map
indicating the action the program should take and the options provided."
[args]
(let [{:keys [options arguments errors summary] :as opts} (parse-opts args cli-options)]
;; (pp/pprint opts)
(cond
(:help options) ; help => exit OK with usage summary
{:exit-message (usage summary) :ok? true}
errors ; errors => exit with description of errors
{:exit-message (error-msg errors)}
;; custom validation on arguments
:else
(let [action (first arguments)]
(if (#{"create-profile" "reset-password"} action)
{:action (first arguments) :options options}
{:exit-message (usage summary)})))))
(defn exit [status msg]
(println msg)
(System/exit status))
(defn -main
[& args]
(let [{:keys [action options exit-message ok?]} (validate-args args)]
(if exit-message
(exit (if ok? 0 1) exit-message)
(case action
"create-profile" (create-profile options)
"reset-password" (reset-password options)))))

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

@ -5,27 +5,32 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.config
"A configuration management."
(:refer-clojure :exclude [get])
(:require
[app.common.spec :as us]
[app.common.version :as v]
[app.util.time :as dt]
[clojure.core :as c]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[environ.core :refer [env]]))
(def defaults
{:http-server-port 6060
:host "devenv"
:tenant "dev"
:database-uri "postgresql://127.0.0.1/penpot"
:database-username "penpot"
:database-password "penpot"
:default-blob-version 1
:loggers-zmq-uri "tcp://localhost:45556"
:asserts-enabled false
:public-uri "http://localhost:3449"
@ -52,6 +57,12 @@
:smtp-default-reply-to "Penpot <no-reply@example.com>"
:smtp-default-from "Penpot <no-reply@example.com>"
:profile-complaint-max-age (dt/duration {:days 7})
:profile-complaint-threshold 2
:profile-bounce-max-age (dt/duration {:days 7})
:profile-bounce-threshold 10
:allow-demo-users true
:registration-enabled true
:registration-domain-whitelist ""
@ -59,100 +70,89 @@
:telemetry-enabled false
:telemetry-uri "https://telemetry.penpot.app/"
;; LDAP auth disabled by default. Set ldap-auth-host to enable
;:ldap-auth-host "ldap.mysupercompany.com"
;:ldap-auth-port 389
;:ldap-bind-dn "cn=admin,dc=ldap,dc=mysupercompany,dc=com"
;:ldap-bind-password "verysecure"
;:ldap-auth-ssl false
;:ldap-auth-starttls false
;:ldap-auth-base-dn "ou=People,dc=ldap,dc=mysupercompany,dc=com"
:ldap-user-query "(|(uid=$username)(mail=$username))"
:ldap-attrs-username "uid"
:ldap-attrs-email "mail"
:ldap-attrs-fullname "cn"
:ldap-attrs-photo "jpegPhoto"
:ldap-auth-user-query "(|(uid=$username)(mail=$username))"
:ldap-auth-username-attribute "uid"
:ldap-auth-email-attribute "mail"
:ldap-auth-fullname-attribute "displayName"
:ldap-auth-avatar-attribute "jpegPhoto"
;; :initial-data-file "resources/initial-data.json"
;; :initial-data-project-name "Penpot Oboarding"
;; a server prop key where initial project is stored.
:initial-project-skey "initial-project"
})
(s/def ::http-server-port ::us/integer)
(s/def ::database-username (s/nilable ::us/string))
(s/def ::allow-demo-users ::us/boolean)
(s/def ::asserts-enabled ::us/boolean)
(s/def ::assets-path ::us/string)
(s/def ::database-password (s/nilable ::us/string))
(s/def ::database-uri ::us/string)
(s/def ::redis-uri ::us/string)
(s/def ::storage-backend ::us/keyword)
(s/def ::storage-fs-directory ::us/string)
(s/def ::assets-path ::us/string)
(s/def ::storage-s3-region ::us/keyword)
(s/def ::storage-s3-bucket ::us/string)
(s/def ::media-uri ::us/string)
(s/def ::media-directory ::us/string)
(s/def ::asserts-enabled ::us/boolean)
(s/def ::feedback-enabled ::us/boolean)
(s/def ::feedback-destination ::us/string)
(s/def ::database-username (s/nilable ::us/string))
(s/def ::default-blob-version ::us/integer)
(s/def ::error-report-webhook ::us/string)
(s/def ::smtp-enabled ::us/boolean)
(s/def ::smtp-default-reply-to ::us/string)
(s/def ::smtp-default-from ::us/string)
(s/def ::smtp-host ::us/string)
(s/def ::smtp-port ::us/integer)
(s/def ::smtp-username (s/nilable ::us/string))
(s/def ::smtp-password (s/nilable ::us/string))
(s/def ::smtp-tls ::us/boolean)
(s/def ::smtp-ssl ::us/boolean)
(s/def ::allow-demo-users ::us/boolean)
(s/def ::registration-enabled ::us/boolean)
(s/def ::registration-domain-whitelist ::us/string)
(s/def ::public-uri ::us/string)
(s/def ::srepl-host ::us/string)
(s/def ::srepl-port ::us/integer)
(s/def ::rlimits-password ::us/integer)
(s/def ::rlimits-image ::us/integer)
(s/def ::google-client-id ::us/string)
(s/def ::google-client-secret ::us/string)
(s/def ::gitlab-client-id ::us/string)
(s/def ::gitlab-client-secret ::us/string)
(s/def ::gitlab-base-uri ::us/string)
(s/def ::feedback-destination ::us/string)
(s/def ::feedback-enabled ::us/boolean)
(s/def ::feedback-reply-to ::us/email)
(s/def ::feedback-token ::us/string)
(s/def ::github-client-id ::us/string)
(s/def ::github-client-secret ::us/string)
(s/def ::ldap-auth-host ::us/string)
(s/def ::ldap-auth-port ::us/integer)
(s/def ::gitlab-base-uri ::us/string)
(s/def ::gitlab-client-id ::us/string)
(s/def ::gitlab-client-secret ::us/string)
(s/def ::google-client-id ::us/string)
(s/def ::google-client-secret ::us/string)
(s/def ::host ::us/string)
(s/def ::http-server-port ::us/integer)
(s/def ::http-session-cookie-name ::us/string)
(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)
(s/def ::ldap-bind-password ::us/string)
(s/def ::ldap-auth-ssl ::us/boolean)
(s/def ::ldap-auth-starttls ::us/boolean)
(s/def ::ldap-auth-base-dn ::us/string)
(s/def ::ldap-auth-user-query ::us/string)
(s/def ::ldap-auth-username-attribute ::us/string)
(s/def ::ldap-auth-email-attribute ::us/string)
(s/def ::ldap-auth-fullname-attribute ::us/string)
(s/def ::ldap-auth-avatar-attribute ::us/string)
(s/def ::ldap-host ::us/string)
(s/def ::ldap-port ::us/integer)
(s/def ::ldap-ssl ::us/boolean)
(s/def ::ldap-starttls ::us/boolean)
(s/def ::ldap-user-query ::us/string)
(s/def ::loggers-loki-uri ::us/string)
(s/def ::loggers-zmq-uri ::us/string)
(s/def ::media-directory ::us/string)
(s/def ::media-uri ::us/string)
(s/def ::profile-bounce-max-age ::dt/duration)
(s/def ::profile-bounce-threshold ::us/integer)
(s/def ::profile-complaint-max-age ::dt/duration)
(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/string)
(s/def ::registration-enabled ::us/boolean)
(s/def ::rlimits-image ::us/integer)
(s/def ::rlimits-password ::us/integer)
(s/def ::smtp-default-from ::us/string)
(s/def ::smtp-default-reply-to ::us/string)
(s/def ::smtp-enabled ::us/boolean)
(s/def ::smtp-host ::us/string)
(s/def ::smtp-password (s/nilable ::us/string))
(s/def ::smtp-port ::us/integer)
(s/def ::smtp-ssl ::us/boolean)
(s/def ::smtp-tls ::us/boolean)
(s/def ::smtp-username (s/nilable ::us/string))
(s/def ::srepl-host ::us/string)
(s/def ::srepl-port ::us/integer)
(s/def ::storage-backend ::us/keyword)
(s/def ::storage-fs-directory ::us/string)
(s/def ::storage-s3-bucket ::us/string)
(s/def ::storage-s3-region ::us/keyword)
(s/def ::telemetry-enabled ::us/boolean)
(s/def ::telemetry-with-taiga ::us/boolean)
(s/def ::telemetry-uri ::us/string)
(s/def ::telemetry-server-enabled ::us/boolean)
(s/def ::telemetry-server-port ::us/integer)
(s/def ::initial-data-file ::us/string)
(s/def ::initial-data-project-name ::us/string)
(s/def ::default-blob-version ::us/integer)
(s/def ::telemetry-uri ::us/string)
(s/def ::telemetry-with-taiga ::us/boolean)
(s/def ::tenant ::us/string)
(s/def ::config
(s/keys :opt-un [::allow-demo-users
@ -162,8 +162,10 @@
::database-username
::default-blob-version
::error-report-webhook
::feedback-enabled
::feedback-destination
::feedback-enabled
::feedback-reply-to
::feedback-token
::github-client-id
::github-client-secret
::gitlab-base-uri
@ -171,25 +173,37 @@
::gitlab-client-secret
::google-client-id
::google-client-secret
::host
::http-server-port
::ldap-auth-avatar-attribute
::ldap-auth-base-dn
::ldap-auth-email-attribute
::ldap-auth-fullname-attribute
::ldap-auth-host
::ldap-auth-port
::ldap-auth-ssl
::ldap-auth-starttls
::ldap-auth-user-query
::ldap-auth-username-attribute
::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
::ldap-bind-password
::ldap-host
::ldap-port
::ldap-ssl
::ldap-starttls
::ldap-user-query
::local-assets-uri
::loggers-loki-uri
::loggers-zmq-uri
::profile-bounce-max-age
::profile-bounce-threshold
::profile-complaint-max-age
::profile-complaint-threshold
::public-uri
::redis-uri
::registration-domain-whitelist
::registration-enabled
::rlimits-password
::rlimits-image
::rlimits-password
::smtp-default-from
::smtp-default-reply-to
::smtp-enabled
@ -199,20 +213,18 @@
::smtp-ssl
::smtp-tls
::smtp-username
::storage-backend
::storage-fs-directory
::srepl-host
::srepl-port
::local-assets-uri
::storage-backend
::storage-fs-directory
::storage-s3-bucket
::storage-s3-region
::telemetry-enabled
::telemetry-with-taiga
::telemetry-server-enabled
::telemetry-server-port
::telemetry-uri
::initial-data-file
::initial-data-project-name]))
::telemetry-with-taiga
::tenant]))
(defn- env->config
[env]
@ -247,3 +259,10 @@
(def deletion-delay
(dt/duration {:days 7}))
(defn get
"A configuration getter. Helps code be more testable."
([key]
(c/get config key))
([key default]
(c/get config key default)))

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

@ -13,12 +13,14 @@
[app.common.geom.point :as gpt]
[app.common.spec :as us]
[app.db.sql :as sql]
[app.metrics :as mtx]
[app.util.json :as json]
[app.util.migrations :as mg]
[app.util.time :as dt]
[app.util.transit :as t]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]
[next.jdbc :as jdbc]
[next.jdbc.date-time :as jdbc-dt])
@ -26,6 +28,7 @@
com.zaxxer.hikari.HikariConfig
com.zaxxer.hikari.HikariDataSource
com.zaxxer.hikari.metrics.prometheus.PrometheusMetricsTrackerFactory
java.lang.AutoCloseable
java.sql.Connection
java.sql.Savepoint
org.postgresql.PGConnection
@ -43,21 +46,24 @@
;; Initialization
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare instrument-jdbc!)
(s/def ::uri ::us/not-empty-string)
(s/def ::name ::us/not-empty-string)
(s/def ::min-pool-size ::us/integer)
(s/def ::max-pool-size ::us/integer)
(s/def ::migrations map?)
(s/def ::metrics map?)
(defmethod ig/pre-init-spec ::pool [_]
(s/keys :req-un [::uri ::name ::min-pool-size ::max-pool-size ::migrations]))
(s/keys :req-un [::uri ::name ::min-pool-size ::max-pool-size ::migrations ::mtx/metrics]))
(defmethod ig/init-key ::pool
[_ {:keys [migrations] :as cfg}]
[_ {:keys [migrations metrics] :as cfg}]
(log/infof "initialize connection pool '%s' with uri '%s'" (:name cfg) (:uri cfg))
(instrument-jdbc! (:registry metrics))
(let [pool (create-pool cfg)]
(when (seq migrations)
(with-open [conn (open pool)]
(with-open [conn ^AutoCloseable (open pool)]
(mg/setup! conn)
(doseq [[mname steps] migrations]
(mg/migrate! conn {:name (name mname) :steps steps}))))
@ -67,12 +73,22 @@
[_ pool]
(.close ^HikariDataSource pool))
(defn- instrument-jdbc!
[registry]
(mtx/instrument-vars!
[#'next.jdbc/execute-one!
#'next.jdbc/execute!]
{:registry registry
:type :counter
:name "database_query_count"
:help "An absolute counter of database queries."}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; API & Impl
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def initsql
(str "SET statement_timeout = 60000;\n"
(str "SET statement_timeout = 120000;\n"
"SET idle_in_transaction_session_timeout = 120000;"))
(defn- create-datasource-config
@ -162,7 +178,7 @@
[& args]
`(jdbc/with-transaction ~@args))
(defn open
(defn ^Connection open
[pool]
(jdbc/get-connection pool))
@ -184,11 +200,6 @@
(sql/insert table params opts)
(assoc opts :return-keys true))))
(defn insert-multi!
[ds table param-list]
(doseq [params param-list]
(insert! ds table params)))
(defn update!
([ds table params where] (update! ds table params where nil))
([ds table params where opts]
@ -286,7 +297,7 @@
(pginterval data)
(dt/duration? data)
(->> (/ (.toMillis data) 1000.0)
(->> (/ (.toMillis ^java.time.Duration data) 1000.0)
(format "%s seconds")
(pginterval))

117
backend/src/app/db/profile_initial_data.clj
View file

@ -1,117 +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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.db.profile-initial-data
(:require
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.rpc.mutations.projects :as projects]
[app.util.transit :as tr]
[clojure.java.io :as io]
[datoteka.core :as fs]))
(def sql:file
"select * from file where project_id = ?")
(def sql:file-library-rel
"with file_ids as (select id from file where project_id = ?)
select *
from file_library_rel
where file_id in (select id from file_ids)")
(def sql:file-media-object
"with file_ids as (select id from file where project_id = ?)
select *
from file_media_object
where file_id in (select id from file_ids)")
(defn change-ids
"Given a collection and a map from ID to ID. Changes all the `keys` properties
so they point to the new ID existing in `map-ids`"
[map-ids coll keys]
(let [generate-id
(fn [map-ids {:keys [id]}]
(assoc map-ids id (uuid/next)))
remap-key
(fn [obj map-ids key]
(cond-> obj
(contains? obj key)
(assoc key (get map-ids (get obj key) (get obj key)))))
change-id
(fn [map-ids obj]
(reduce #(remap-key %1 map-ids %2) obj keys))
new-map-ids (reduce generate-id map-ids coll)]
[new-map-ids (map (partial change-id new-map-ids) coll)]))
(defn create-initial-data-dump
[conn project-id output-path]
(let [ ;; Retrieve data from templates
opath (fs/path output-path)
file (db/exec! conn [sql:file, project-id])
file-library-rel (db/exec! conn [sql:file-library-rel, project-id])
file-media-object (db/exec! conn [sql:file-media-object, project-id])
data {:file file
:file-library-rel file-library-rel
:file-media-object file-media-object}]
(with-open [output (io/output-stream opath)]
(tr/encode-stream data output)
nil)))
(defn read-initial-data
[path]
(when (fs/exists? path)
(with-open [input (io/input-stream (fs/path path))]
(tr/decode-stream input))))
(defn create-profile-initial-data
([conn profile]
(when-let [initial-data-path (:initial-data-file cfg/config)]
(create-profile-initial-data conn initial-data-path profile)))
([conn file profile]
(when-let [{:keys [file file-library-rel file-media-object]} (read-initial-data file)]
(let [sample-project-name (:initial-data-project-name cfg/config "Penpot Onboarding")
proj (projects/create-project conn {:profile-id (:id profile)
:team-id (:default-team-id profile)
:name sample-project-name})
map-ids {}
;; Create new ID's and change the references
[map-ids file] (change-ids map-ids file #{:id})
[map-ids file-library-rel] (change-ids map-ids file-library-rel #{:file-id :library-file-id})
[_ file-media-object] (change-ids map-ids file-media-object #{:id :file-id :media-id :thumbnail-id})
file (map #(assoc % :project-id (:id proj)) file)
file-profile-rel (map #(array-map :file-id (:id %)
:profile-id (:id profile)
:is-owner true
:is-admin true
:can-edit true)
file)]
(projects/create-project-profile conn {:project-id (:id proj)
:profile-id (:id profile)})
(projects/create-team-project-profile conn {:team-id (:default-team-id profile)
:project-id (:id proj)
:profile-id (:id profile)})
;; Re-insert into the database
(db/insert-multi! conn :file file)
(db/insert-multi! conn :file-profile-rel file-profile-rel)
(db/insert-multi! conn :file-library-rel file-library-rel)
(db/insert-multi! conn :file-media-object file-media-object)))))

52
backend/src/app/emails.clj
View file

@ -5,13 +5,15 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.emails
"Main api for send emails."
(:require
[app.common.spec :as us]
[app.config :as cfg]
[app.db :as db]
[app.db.sql :as sql]
[app.tasks :as tasks]
[app.util.emails :as emails]
[clojure.spec.alpha :as s]))
@ -41,6 +43,54 @@
:priority 200
:props email})))
(def sql:profile-complaint-report
"select (select count(*)
from profile_complaint_report
where type = 'complaint'
and profile_id = ?
and created_at > now() - ?::interval) as complaints,
(select count(*)
from profile_complaint_report
where type = 'bounce'
and profile_id = ?
and created_at > now() - ?::interval) as bounces;")
(defn allow-send-emails?
[conn profile]
(when-not (:is-muted profile false)
(let [complaint-threshold (cfg/get :profile-complaint-threshold)
complaint-max-age (cfg/get :profile-complaint-max-age)
bounce-threshold (cfg/get :profile-bounce-threshold)
bounce-max-age (cfg/get :profile-bounce-max-age)
{:keys [complaints bounces] :as result}
(db/exec-one! conn [sql:profile-complaint-report
(:id profile)
(db/interval complaint-max-age)
(:id profile)
(db/interval bounce-max-age)])]
(and (< complaints complaint-threshold)
(< bounces bounce-threshold)))))
(defn has-complaint-reports?
([conn email] (has-complaint-reports? conn email nil))
([conn email {:keys [threshold] :or {threshold 1}}]
(let [reports (db/exec! conn (sql/select :global-complaint-report
{:email email :type "complaint"}
{:limit 10}))]
(>= (count reports) threshold))))
(defn has-bounce-reports?
([conn email] (has-bounce-reports? conn email nil))
([conn email {:keys [threshold] :or {threshold 1}}]
(let [reports (db/exec! conn (sql/select :global-complaint-report
{:email email :type "bounce"}
{:limit 10}))]
(>= (count reports) threshold))))
;; --- Emails
(s/def ::subject ::us/string)

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

@ -12,7 +12,6 @@
[app.common.data :as d]
[app.common.spec :as us]
[app.config :as cfg]
[app.http.auth :as auth]
[app.http.errors :as errors]
[app.http.middleware :as middleware]
[app.metrics :as mtx]
@ -43,7 +42,7 @@
(defmethod ig/init-key ::server
[_ {:keys [handler ws port name metrics] :as opts}]
(log/infof "Starting %s server on port %s." name port)
(log/infof "starting '%s' server on port %s." name port)
(let [pre-start (fn [^Server server]
(let [handler (doto (ErrorHandler.)
(.setShowStacks true)
@ -69,7 +68,7 @@
(defmethod ig/halt-key! ::server
[_ {:keys [server name port] :as opts}]
(log/infof "Stoping %s server on port %s." name port)
(log/infof "stoping '%s' server on port %s." name port)
(jetty/stop-server server))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -81,14 +80,13 @@
(s/def ::rpc map?)
(s/def ::session map?)
(s/def ::metrics map?)
(s/def ::google-auth map?)
(s/def ::gitlab-auth map?)
(s/def ::ldap-auth fn?)
(s/def ::oauth map?)
(s/def ::storage map?)
(s/def ::assets map?)
(s/def ::feedback fn?)
(defmethod ig/pre-init-spec ::router [_]
(s/keys :req-un [::rpc ::session ::metrics ::google-auth ::gitlab-auth ::storage ::assets]))
(s/keys :req-un [::rpc ::session ::metrics ::oauth ::storage ::assets ::feedback]))
(defmethod ig/init-key ::router
[_ cfg]
@ -105,16 +103,16 @@
(try
(let [cdata (errors/get-error-context request e)]
(update-thread-context! cdata)
(log/errorf e "Unhandled exception: %s (id: %s)" (ex-message e) (str (:id cdata)))
(log/errorf e "unhandled exception: %s (id: %s)" (ex-message e) (str (:id cdata)))
{:status 500
:body "internal server error"})
(catch Throwable e
(log/errorf e "Unhandled exception: %s" (ex-message e))
(log/errorf e "unhandled exception: %s" (ex-message e))
{:status 500
:body "internal server error"})))))))
(defn- create-router
[{:keys [session rpc google-auth gitlab-auth github-auth metrics ldap-auth svgparse assets] :as cfg}]
[{:keys [session rpc oauth metrics svgparse assets feedback] :as cfg}]
(rr/router
[["/metrics" {:get (:handler metrics)}]
@ -127,6 +125,9 @@
["/dbg"
["/error-by-id/:id" {:get (:error-report-handler cfg)}]]
["/webhooks"
["/sns" {:post (:sns-webhook cfg)}]]
["/api" {:middleware [[middleware/format-response-body]
[middleware/params]
[middleware/multipart-params]
@ -136,21 +137,18 @@
[middleware/cookies]]}
["/svg" {:post svgparse}]
["/feedback" {:middleware [(:middleware session)]
:post feedback}]
["/oauth"
["/google" {:post (:auth-handler google-auth)}]
["/google/callback" {:get (:callback-handler google-auth)}]
["/google" {:post (get-in oauth [:google :handler])}]
["/google/callback" {:get (get-in oauth [:google :callback-handler])}]
["/gitlab" {:post (:auth-handler gitlab-auth)}]
["/gitlab/callback" {:get (:callback-handler gitlab-auth)}]
["/gitlab" {:post (get-in oauth [:gitlab :handler])}]
["/gitlab/callback" {:get (get-in oauth [:gitlab :callback-handler])}]
["/github" {:post (:auth-handler github-auth)}]
["/github/callback" {:get (:callback-handler github-auth)}]]
["/login" {:post #(auth/login-handler cfg %)}]
["/logout" {:post #(auth/logout-handler cfg %)}]
["/login-ldap" {:post ldap-auth}]
["/github" {:post (get-in oauth [:github :handler])}]
["/github/callback" {:get (get-in oauth [:github :callback-handler])}]]
["/rpc" {:middleware [(:middleware session)]}
["/query/:type" {:get (:query-handler rpc)}]

31
backend/src/app/http/auth.clj
View file

@ -1,31 +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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.http.auth
(:require
[app.http.session :as session]))
(defn login-handler
[{:keys [session rpc] :as cfg} request]
(let [data (:params request)
uagent (get-in request [:headers "user-agent"])
method (get-in rpc [:methods :mutation :login])
profile (method data)
id (session/create! session {:profile-id (:id profile)
:user-agent uagent})]
{:status 200
:cookies (session/cookies session {:value id})
:body profile}))
(defn logout-handler
[{:keys [session] :as cfg} request]
(session/delete! cfg request)
{:status 204
:cookies (session/cookies session {:value "" :max-age -1})
:body ""})

171
backend/src/app/http/auth/github.clj
View file

@ -1,171 +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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.http.auth.github
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.config :as cfg]
[app.http.session :as session]
[app.util.http :as http]
[app.util.time :as dt]
[clojure.data.json :as json]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]
[lambdaisland.uri :as u]))
(def base-github-uri
(u/uri "https://github.com"))
(def base-api-github-uri
(u/uri "https://api.github.com"))
(def authorize-uri
(assoc base-github-uri :path "/login/oauth/authorize"))
(def token-url
(assoc base-github-uri :path "/login/oauth/access_token"))
(def user-info-url
(assoc base-api-github-uri :path "/user"))
(def scope "user:email")
(defn- build-redirect-url
[cfg]
(let [public (u/uri (:public-uri cfg))]
(str (assoc public :path "/api/oauth/github/callback"))))
(defn- get-access-token
[cfg state code]
(let [params {:client_id (:client-id cfg)
:client_secret (:client-secret cfg)
:code code
:state state
:redirect_uri (build-redirect-url cfg)}
req {:method :post
:headers {"content-type" "application/x-www-form-urlencoded"
"accept" "application/json"}
:uri (str token-url)
:body (u/map->query-string params)}
res (http/send! req)]
(when (not= 200 (:status res))
(ex/raise :type :internal
:code :invalid-response-from-github
:context {:status (:status res)
:body (:body res)}))
(try
(let [data (json/read-str (:body res))]
(get data "access_token"))
(catch Throwable e
(log/error "unexpected error on parsing response body from github access token request" e)
nil))))
(defn- get-user-info
[token]
(let [req {:uri (str user-info-url)
:headers {"authorization" (str "token " token)}
:method :get}
res (http/send! req)]
(when (not= 200 (:status res))
(ex/raise :type :internal
:code :invalid-response-from-github
:context {:status (:status res)
:body (:body res)}))
(try
(let [data (json/read-str (:body res))]
{:email (get data "email")
:fullname (get data "name")})
(catch Throwable e
(log/error "unexpected error on parsing response body from github access token request" e)
nil))))
(defn auth
[{:keys [tokens] :as cfg} _request]
(let [state (tokens :generate
{:iss :github-oauth
:exp (dt/in-future "15m")})
params {:client_id (:client-id cfg/config)
:redirect_uri (build-redirect-url cfg)
:state state
:scope scope}
query (u/map->query-string params)
uri (-> authorize-uri
(assoc :query query))]
{:status 200
:body {:redirect-uri (str uri)}}))
(defn callback
[{:keys [tokens rpc session] :as cfg} request]
(let [state (get-in request [:params :state])
_ (tokens :verify {:token state :iss :github-oauth})
info (some->> (get-in request [:params :code])
(get-access-token cfg state)
(get-user-info))]
(when-not info
(ex/raise :type :authentication
:code :unable-to-authenticate-with-github))
(let [method-fn (get-in rpc [:methods :mutation :login-or-register])
profile (method-fn {:email (:email info)
:fullname (:fullname info)})
uagent (get-in request [:headers "user-agent"])
token (tokens :generate
{:iss :auth
:exp (dt/in-future "15m")
:profile-id (:id profile)})
uri (-> (u/uri (:public-uri cfg/config))
(assoc :path "/#/auth/verify-token")
(assoc :query (u/map->query-string {:token token})))
sid (session/create! session {:profile-id (:id profile)
:user-agent uagent})]
{:status 302
:headers {"location" (str uri)}
:cookies (session/cookies session/cookies {:value sid})
:body ""})))
;; --- ENTRY POINT
(s/def ::client-id ::us/not-empty-string)
(s/def ::client-secret ::us/not-empty-string)
(s/def ::public-uri ::us/not-empty-string)
(s/def ::session map?)
(s/def ::tokens fn?)
(defmethod ig/pre-init-spec :app.http.auth/github [_]
(s/keys :req-un [::public-uri
::session
::tokens]
:opt-un [::client-id
::client-secret]))
(defn- default-handler
[_]
(ex/raise :type :not-found))
(defmethod ig/init-key :app.http.auth/github
[_ cfg]
(if (and (:client-id cfg)
(:client-secret cfg))
{:auth-handler #(auth cfg %)
:callback-handler #(callback cfg %)}
{:auth-handler default-handler
:callback-handler default-handler}))

179
backend/src/app/http/auth/gitlab.clj
View file

@ -1,179 +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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.http.auth.gitlab
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.http.session :as session]
[app.util.http :as http]
[app.util.time :as dt]
[clojure.data.json :as json]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]
[lambdaisland.uri :as uri]))
(def scope "read_user")
(defn- build-redirect-url
[cfg]
(let [public (uri/uri (:public-uri cfg))]
(str (assoc public :path "/api/oauth/gitlab/callback"))))
(defn- build-oauth-uri
[cfg]
(let [base-uri (uri/uri (:base-uri cfg))]
(assoc base-uri :path "/oauth/authorize")))
(defn- build-token-url
[cfg]
(let [base-uri (uri/uri (:base-uri cfg))]
(str (assoc base-uri :path "/oauth/token"))))
(defn- build-user-info-url
[cfg]
(let [base-uri (uri/uri (:base-uri cfg))]
(str (assoc base-uri :path "/api/v4/user"))))
(defn- get-access-token
[cfg code]
(let [params {:client_id (:client-id cfg)
:client_secret (:client-secret cfg)
:code code
:grant_type "authorization_code"
:redirect_uri (build-redirect-url cfg)}
req {:method :post
:headers {"content-type" "application/x-www-form-urlencoded"}
:uri (build-token-url cfg)
:body (uri/map->query-string params)}
res (http/send! req)]
(when (not= 200 (:status res))
(ex/raise :type :internal
:code :invalid-response-from-gitlab
:context {:status (:status res)
:body (:body res)}))
(try
(let [data (json/read-str (:body res))]
(get data "access_token"))
(catch Throwable e
(log/error "unexpected error on parsing response body from gitlab access token request" e)
nil))))
(defn- get-user-info
[cfg token]
(let [req {:uri (build-user-info-url cfg)
:headers {"Authorization" (str "Bearer " token)}
:method :get}
res (http/send! req)]
(when (not= 200 (:status res))
(ex/raise :type :internal
:code :invalid-response-from-gitlab
:context {:status (:status res)
:body (:body res)}))
(try
(let [data (json/read-str (:body res))]
;; (clojure.pprint/pprint data)
{:email (get data "email")
:fullname (get data "name")})
(catch Throwable e
(log/error "unexpected error on parsing response body from gitlab access token request" e)
nil))))
(defn auth
[{:keys [tokens] :as cfg} _request]
(let [token (tokens :generate {:iss :gitlab-oauth
:exp (dt/in-future "15m")})
params {:client_id (:client-id cfg)
:redirect_uri (build-redirect-url cfg)
:response_type "code"
:state token
:scope scope}
query (uri/map->query-string params)
uri (-> (build-oauth-uri cfg)
(assoc :query query))]
{:status 200
:body {:redirect-uri (str uri)}}))
(defn callback
[{:keys [tokens rpc session] :as cfg} request]
(let [token (get-in request [:params :state])
_ (tokens :verify {:token token :iss :gitlab-oauth})
info (some->> (get-in request [:params :code])
(get-access-token cfg)
(get-user-info cfg))]
(when-not info
(ex/raise :type :authentication
:code :unable-to-authenticate-with-gitlab))
(let [method-fn (get-in rpc [:methods :mutation :login-or-register])
profile (method-fn {:email (:email info)
:fullname (:fullname info)})
uagent (get-in request [:headers "user-agent"])
token (tokens :generate {:iss :auth
:exp (dt/in-future "15m")
:profile-id (:id profile)})
uri (-> (uri/uri (:public-uri cfg))
(assoc :path "/#/auth/verify-token")
(assoc :query (uri/map->query-string {:token token})))
sid (session/create! session {:profile-id (:id profile)
:user-agent uagent})]
{:status 302
:headers {"location" (str uri)}
:cookies (session/cookies session {:value sid})
:body ""})))
(s/def ::client-id ::us/not-empty-string)
(s/def ::client-secret ::us/not-empty-string)
(s/def ::base-uri ::us/not-empty-string)
(s/def ::public-uri ::us/not-empty-string)
(s/def ::session map?)
(s/def ::tokens fn?)
(defmethod ig/pre-init-spec :app.http.auth/gitlab [_]
(s/keys :req-un [::public-uri
::session
::tokens]
:opt-un [::base-uri
::client-id
::client-secret]))
(defmethod ig/prep-key :app.http.auth/gitlab
[_ cfg]
(d/merge {:base-uri "https://gitlab.com"}
(d/without-nils cfg)))
(defn- default-handler
[_]
(ex/raise :type :not-found))
(defmethod ig/init-key :app.http.auth/gitlab
[_ cfg]
(if (and (:client-id cfg)
(:client-secret cfg))
{:auth-handler #(auth cfg %)
:callback-handler #(callback cfg %)}
{:auth-handler default-handler
:callback-handler default-handler}))

149
backend/src/app/http/auth/google.clj
View file

@ -1,149 +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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.http.auth.google
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.http.session :as session]
[app.util.http :as http]
[app.util.time :as dt]
[clojure.data.json :as json]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]
[lambdaisland.uri :as uri]))
(def base-goauth-uri "https://accounts.google.com/o/oauth2/v2/auth")
(def scope
(str "email profile "
"https://www.googleapis.com/auth/userinfo.email "
"https://www.googleapis.com/auth/userinfo.profile "
"openid"))
(defn- build-redirect-url
[cfg]
(let [public (uri/uri (:public-uri cfg))]
(str (assoc public :path "/api/oauth/google/callback"))))
(defn- get-access-token
[cfg code]
(try
(let [params {:code code
:client_id (:client-id cfg)
:client_secret (:client-secret cfg)
:redirect_uri (build-redirect-url cfg)
:grant_type "authorization_code"}
req {:method :post
:headers {"content-type" "application/x-www-form-urlencoded"}
:uri "https://oauth2.googleapis.com/token"
:body (uri/map->query-string params)}
res (http/send! req)]
(when (= 200 (:status res))
(-> (json/read-str (:body res))
(get "access_token"))))
(catch Exception e
(log/error e "unexpected error on get-access-token")
nil)))
(defn- get-user-info
[token]
(try
(let [req {:uri "https://openidconnect.googleapis.com/v1/userinfo"
:headers {"Authorization" (str "Bearer " token)}
:method :get}
res (http/send! req)]
(when (= 200 (:status res))
(let [data (json/read-str (:body res))]
{:email (get data "email")
:fullname (get data "name")})))
(catch Exception e
(log/error e "unexpected exception on get-user-info")
nil)))
(defn- auth
[{:keys [tokens] :as cfg} _req]
(let [token (tokens :generate {:iss :google-oauth :exp (dt/in-future "15m")})
params {:scope scope
:access_type "offline"
:include_granted_scopes true
:state token
:response_type "code"
:redirect_uri (build-redirect-url cfg)
:client_id (:client-id cfg)}
query (uri/map->query-string params)
uri (-> (uri/uri base-goauth-uri)
(assoc :query query))]
{:status 200
:body {:redirect-uri (str uri)}}))
(defn- callback
[{:keys [tokens rpc session] :as cfg} request]
(try
(let [token (get-in request [:params :state])
_ (tokens :verify {:token token :iss :google-oauth})
info (some->> (get-in request [:params :code])
(get-access-token cfg)
(get-user-info))
_ (when-not info
(ex/raise :type :internal
:code :unable-to-auth))
method-fn (get-in rpc [:methods :mutation :login-or-register])
profile (method-fn {:email (:email info)
:fullname (:fullname info)})
uagent (get-in request [:headers "user-agent"])
token (tokens :generate {:iss :auth
:exp (dt/in-future "15m")
:profile-id (:id profile)})
uri (-> (uri/uri (:public-uri cfg))
(assoc :path "/#/auth/verify-token")
(assoc :query (uri/map->query-string {:token token})))
sid (session/create! session {:profile-id (:id profile)
:user-agent uagent})]
{:status 302
:headers {"location" (str uri)}
:cookies (session/cookies session {:value sid})
:body ""})
(catch Exception _e
(let [uri (-> (uri/uri (:public-uri cfg))
(assoc :path "/#/auth/login")
(assoc :query (uri/map->query-string {:error "unable-to-auth"})))]
{:status 302
:headers {"location" (str uri)}
:body ""}))))
(s/def ::client-id ::us/not-empty-string)
(s/def ::client-secret ::us/not-empty-string)
(s/def ::public-uri ::us/not-empty-string)
(s/def ::session map?)
(s/def ::tokens fn?)
(defmethod ig/pre-init-spec :app.http.auth/google [_]
(s/keys :req-un [::public-uri
::session
::tokens]
:opt-un [::client-id
::client-secret]))
(defn- default-handler
[_]
(ex/raise :type :not-found))
(defmethod ig/init-key :app.http.auth/google
[_ cfg]
(if (and (:client-id cfg)
(:client-secret cfg))
{:auth-handler #(auth cfg %)
:callback-handler #(callback cfg %)}
{:auth-handler default-handler
:callback-handler default-handler}))

129
backend/src/app/http/auth/ldap.clj
View file

@ -1,129 +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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.http.auth.ldap
(:require
[app.common.exceptions :as ex]
[app.config :as cfg]
[app.http.session :as session]
[clj-ldap.client :as client]
[clojure.set :as set]
[clojure.spec.alpha :as s]
[clojure.string ]
[clojure.tools.logging :as log]
[integrant.core :as ig]))
(declare authenticate)
(declare create-connection)
(declare replace-several)
(s/def ::host ::cfg/ldap-auth-host)
(s/def ::port ::cfg/ldap-auth-port)
(s/def ::ssl ::cfg/ldap-auth-ssl)
(s/def ::starttls ::cfg/ldap-auth-starttls)
(s/def ::user-query ::cfg/ldap-auth-user-query)
(s/def ::base-dn ::cfg/ldap-auth-base-dn)
(s/def ::username-attribute ::cfg/ldap-auth-username-attribute)
(s/def ::email-attribute ::cfg/ldap-auth-email-attribute)
(s/def ::fullname-attribute ::cfg/ldap-auth-fullname-attribute)
(s/def ::avatar-attribute ::cfg/ldap-auth-avatar-attribute)
(s/def ::rpc map?)
(s/def ::session map?)
(defmethod ig/pre-init-spec :app.http.auth/ldap
[_]
(s/keys
:req-un [::rpc ::session]
:opt-un [::host
::port
::ssl
::starttls
::username-attribute
::base-dn
::username-attribute
::email-attribute
::fullname-attribute
::avatar-attribute]))
(defmethod ig/init-key :app.http.auth/ldap
[_ {:keys [session rpc] :as cfg}]
(let [conn (create-connection cfg)]
(with-meta
(fn [request]
(let [data (:body-params request)]
(when-some [info (authenticate (assoc cfg
:conn conn
:username (:email data)
:password (:password data)))]
(let [method-fn (get-in rpc [:methods :mutation :login-or-register])
profile (method-fn {:email (:email info)
:fullname (:fullname info)})
uagent (get-in request [:headers "user-agent"])
sid (session/create! session {:profile-id (:id profile)
:user-agent uagent})]
{:status 200
:cookies (session/cookies session {:value sid})
:body profile}))))
{::conn conn})))
(defmethod ig/halt-key! ::client
[_ handler]
(let [{:keys [::conn]} (meta handler)]
(when (realized? conn)
(.close @conn))))
(defn- replace-several [s & {:as replacements}]
(reduce-kv clojure.string/replace s replacements))
(defn- create-connection
[cfg]
(let [params (merge {:host {:address (:host cfg)
:port (:port cfg)}}
(-> cfg
(select-keys [:ssl
:starttls
:ldap-bind-dn
:ldap-bind-password])
(set/rename-keys {:ssl :ssl?
:starttls :startTLS?
:ldap-bind-dn :bind-dn
:ldap-bind-password :password})))]
(delay
(try
(client/connect params)
(catch Exception e
(log/errorf e "Cannot connect to LDAP %s:%s"
(:host cfg) (:port cfg)))))))
(defn- authenticate
[{:keys [conn username password] :as cfg}]
(when-some [conn (some-> conn deref)]
(let [user-search-query (replace-several (:user-query cfg) "$username" username)
user-attributes (-> cfg
(select-keys [:username-attribute
:email-attribute
:fullname-attribute
:avatar-attribute])
vals)]
(when-some [user-entry (-> conn
(client/search (:base-dn cfg)
{:filter user-search-query
:sizelimit 1
:attributes user-attributes})
(first))]
(when-not (client/bind? conn (:dn user-entry) password)
(ex/raise :type :authentication
:code :wrong-credentials))
(set/rename-keys user-entry {(keyword (:avatar-attribute cfg)) :photo
(keyword (:fullname-attribute cfg)) :fullname
(keyword (:email-attribute cfg)) :email})))))

207
backend/src/app/http/awsns.clj Normal file
View file

@ -0,0 +1,207 @@
;; 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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 Andrey Antukh <niwi@niwi.nz>
(ns app.http.awsns
"AWS SNS webhook handler for bounces."
(:require
[app.common.exceptions :as ex]
[app.db :as db]
[app.db.sql :as sql]
[app.util.http :as http]
[clojure.pprint :refer [pprint]]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[cuerdas.core :as str]
[integrant.core :as ig]
[jsonista.core :as j]))
(declare parse-json)
(declare parse-notification)
(declare process-report)
(defn- pprint-report
[message]
(binding [clojure.pprint/*print-right-margin* 120]
(with-out-str (pprint message))))
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::db/pool]))
(defmethod ig/init-key ::handler
[_ cfg]
(fn [request]
(let [body (parse-json (slurp (:body request)))
mtype (get body "Type")]
(cond
(= mtype "SubscriptionConfirmation")
(let [surl (get body "SubscribeURL")
stopic (get body "TopicArn")]
(log/infof "subscription received (topic=%s, url=%s)" stopic surl)
(http/send! {:uri surl :method :post :timeout 10000}))
(= mtype "Notification")
(when-let [message (parse-json (get body "Message"))]
;; (log/infof "Received: %s" (pr-str message))
(let [notification (parse-notification cfg message)]
(process-report cfg notification)))
:else
(log/warn (str "unexpected data received\n"
(pprint-report body))))
{:status 200 :body ""})))
(defn- parse-bounce
[data]
{:type "bounce"
:kind (str/lower (get data "bounceType"))
:category (str/lower (get data "bounceSubType"))
:feedback-id (get data "feedbackId")
:timestamp (get data "timestamp")
:recipients (->> (get data "bouncedRecipients")
(mapv (fn [item]
{:email (str/lower (get item "emailAddress"))
:status (get item "status")
:action (get item "action")
:dcode (get item "diagnosticCode")})))})
(defn- parse-complaint
[data]
{:type "complaint"
:user-agent (get data "userAgent")
:kind (get data "complaintFeedbackType")
:category (get data "complaintSubType")
:timestamp (get data "arrivalDate")
:feedback-id (get data "feedbackId")
:recipients (->> (get data "complainedRecipients")
(mapv #(get % "emailAddress"))
(mapv str/lower))})
(defn- extract-headers
[mail]
(reduce (fn [acc item]
(let [key (get item "name")
val (get item "value")]
(assoc acc (str/lower key) val)))
{}
(get mail "headers")))
(defn- extract-identity
[{:keys [tokens] :as cfg} headers]
(let [tdata (get headers "x-penpot-data")]
(when-not (str/empty? tdata)
(let [result (tokens :verify {:token tdata :iss :profile-identity})]
(:profile-id result)))))
(defn- parse-notification
[cfg message]
(let [type (get message "notificationType")
data (case type
"Bounce" (parse-bounce (get message "bounce"))
"Complaint" (parse-complaint (get message "complaint"))
{:type (keyword (str/lower type))
:message message})]
(when data
(let [mail (get message "mail")]
(when-not mail
(ex/raise :type :internal
:code :incomplete-notification
:hint "no email data received, please enable full headers report"))
(let [headers (extract-headers mail)
mail {:destination (get mail "destination")
:source (get mail "source")
:timestamp (get mail "timestamp")
:subject (get-in mail ["commonHeaders" "subject"])
:headers headers}]
(assoc data
:mail mail
:profile-id (extract-identity cfg headers)))))))
(defn- parse-json
[v]
(ex/ignoring
(j/read-value v)))
(defn- register-bounce-for-profile
[{:keys [pool]} {:keys [type kind profile-id] :as report}]
(when (= kind "permanent")
(db/with-atomic [conn pool]
(db/insert! conn :profile-complaint-report
{:profile-id profile-id
:type (name type)
:content (db/tjson report)})
;; TODO: maybe also try to find profiles by mail and if exists
;; register profile reports for them?
(doseq [recipient (:recipients report)]
(db/insert! conn :global-complaint-report
{:email (:email recipient)
:type (name type)
:content (db/tjson report)}))
(let [profile (db/exec-one! conn (sql/select :profile {:id profile-id}))]
(when (some #(= (:email profile) (:email %)) (:recipients report))
;; If the report matches the profile email, this means that
;; the report is for itself, can be caused when a user
;; registers with an invalid email or the user email is
;; permanently rejecting receiving the email. In this case we
;; have no option to mark the user as muted (and in this case
;; the profile will be also inactive.
(db/update! conn :profile
{:is-muted true}
{:id profile-id}))))))
(defn- register-complaint-for-profile
[{:keys [pool]} {:keys [type profile-id] :as report}]
(db/with-atomic [conn pool]
(db/insert! conn :profile-complaint-report
{:profile-id profile-id
:type (name type)
:content (db/tjson report)})
;; TODO: maybe also try to find profiles by email and if exists
;; register profile reports for them?
(doseq [email (:recipients report)]
(db/insert! conn :global-complaint-report
{:email email
:type (name type)
:content (db/tjson report)}))
(let [profile (db/exec-one! conn (sql/select :profile {:id profile-id}))]
(when (some #(= % (:email profile)) (:recipients report))
;; If the report matches the profile email, this means that
;; the report is for itself, rare case but can happen; In this
;; case just mark profile as muted (very rare case).
(db/update! conn :profile
{:is-muted true}
{:id profile-id})))))
(defn- process-report
[cfg {:keys [type profile-id] :as report}]
(log/trace (str "procesing report:\n" (pprint-report report)))
(cond
;; In this case we receive a bounce/complaint notification without
;; confirmed identity, we just emit a warning but do nothing about
;; it because this is not a normal case. All notifications should
;; come with profile identity.
(nil? profile-id)
(log/warn (str "a notification without identity recevied from AWS\n"
(pprint-report report)))
(= "bounce" type)
(register-bounce-for-profile cfg report)
(= "complaint" type)
(register-complaint-for-profile cfg report)
:else
(log/warn (str "unrecognized report received from AWS\n"
(pprint-report report)))))

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

@ -11,7 +11,6 @@
"A errors handling for the http server."
(:require
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.util.log4j :refer [update-thread-context!]]
[clojure.tools.logging :as log]
[cuerdas.core :as str]
@ -30,16 +29,10 @@
:path (:uri request)
:method (:request-method request)
:params (:params request)
:version (:full cfg/version)
:host (:public-uri cfg/config)
:class (.getCanonicalName ^java.lang.Class (class error))
:hint (ex-message error)
:data edata}
(let [headers (:headers request)]
{:user-agent (get headers "user-agent")
:frontend-version (get headers "x-frontend-version" "unknown")})
(when (and (map? edata) (:data edata))
{:explain (explain-error edata)}))))
@ -53,6 +46,11 @@
[err _]
{:status 401 :body (ex-data err)})
(defmethod handle-exception :restriction
[err _]
{:status 400 :body (ex-data err)})
(defmethod handle-exception :validation
[err req]
(let [header (get-in req [:headers "accept"])
@ -75,7 +73,7 @@
(let [edata (ex-data error)
cdata (get-error-context request error)]
(update-thread-context! cdata)
(log/errorf error "Internal error: assertion (id: %s)" (str (:id cdata)))
(log/errorf error "internal error: assertion (id: %s)" (str (:id cdata)))
{:status 500
:body {:type :server-error
:data (-> edata
@ -90,7 +88,7 @@
[error request]
(let [cdata (get-error-context request error)]
(update-thread-context! cdata)
(log/errorf error "Internal error: %s (id: %s)"
(log/errorf error "internal error: %s (id: %s)"
(ex-message error)
(str (:id cdata)))
{:status 500

73
backend/src/app/http/feedback.clj Normal file
View file

@ -0,0 +1,73 @@
;; 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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2021 UXBOX Labs SL
(ns app.http.feedback
"A general purpose feedback module."
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.config :as cfg]
[app.db :as db]
[app.emails :as emails]
[app.rpc.queries.profile :as profile]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(declare send-feedback)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::db/pool]))
(defmethod ig/init-key ::handler
[_ {:keys [pool] :as scfg}]
(let [ftoken (cfg/get :feedback-token ::no-token)
enabled (cfg/get :feedback-enabled)]
(fn [{:keys [profile-id] :as request}]
(let [token (get-in request [:headers "x-feedback-token"])
params (d/merge (:params request)
(:body-params request))]
(when-not enabled
(ex/raise :type :validation
:code :feedback-disabled
:hint "feedback module is disabled"))
(cond
(uuid? profile-id)
(let [profile (profile/retrieve-profile-data pool profile-id)
params (assoc params :from (:email profile))]
(when-not (:is-muted profile)
(send-feedback pool profile params)))
(= token ftoken)
(send-feedback scfg nil params))
{:status 204 :body ""}))))
(s/def ::content ::us/string)
(s/def ::from ::us/email)
(s/def ::subject ::us/string)
(s/def ::feedback
(s/keys :req-un [::from ::subject ::content]))
(defn send-feedback
[pool profile params]
(let [params (us/conform ::feedback params)
destination (cfg/get :feedback-destination)
reply-to (cfg/get :feedback-reply-to)]
(emails/send! pool emails/feedback
{:to destination
:profile profile
:reply-to (:from params)
:email (:from params)
:subject (:subject params)
:content (:content params)})
nil))

159
backend/src/app/http/oauth/github.clj Normal file
View file

@ -0,0 +1,159 @@
;; 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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.http.oauth.github
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.config :as cfg]
[app.http.oauth.google :as gg]
[app.util.http :as http]
[app.util.time :as dt]
[clojure.data.json :as json]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]
[lambdaisland.uri :as u]))
(def base-github-uri
(u/uri "https://github.com"))
(def base-api-github-uri
(u/uri "https://api.github.com"))
(def authorize-uri
(assoc base-github-uri :path "/login/oauth/authorize"))
(def token-url
(assoc base-github-uri :path "/login/oauth/access_token"))
(def user-info-url
(assoc base-api-github-uri :path "/user"))
(def scope "user:email")
(defn- build-redirect-url
[cfg]
(let [public (u/uri (:public-uri cfg))]
(str (assoc public :path "/api/oauth/github/callback"))))
(defn- get-access-token
[cfg state code]
(try
(let [params {:client_id (:client-id cfg)
:client_secret (:client-secret cfg)
:code code
:state state
:redirect_uri (build-redirect-url cfg)}
req {:method :post
:headers {"content-type" "application/x-www-form-urlencoded"
"accept" "application/json"}
:uri (str token-url)
:timeout 6000
:body (u/map->query-string params)}
res (http/send! req)]
(when (= 200 (:status res))
(-> (json/read-str (:body res))
(get "access_token"))))
(catch Exception e
(log/error e "unexpected error on get-access-token")
nil)))
(defn- get-user-info
[_ token]
(try
(let [req {:uri (str user-info-url)
:headers {"authorization" (str "token " token)}
:timeout 6000
:method :get}
res (http/send! req)]
(when (= 200 (:status res))
(let [data (json/read-str (:body res))]
{:email (get data "email")
:backend "github"
:fullname (get data "name")})))
(catch Exception e
(log/error e "unexpected exception on get-user-info")
nil)))
(defn- retrieve-info
[{:keys [tokens] :as cfg} request]
(let [token (get-in request [:params :state])
state (tokens :verify {:token token :iss :github-oauth})
info (some->> (get-in request [:params :code])
(get-access-token cfg state)
(get-user-info cfg))]
(when-not info
(ex/raise :type :internal
:code :unable-to-auth))
(cond-> info
(some? (:invitation-token state))
(assoc :invitation-token (:invitation-token state)))))
(defn auth-handler
[{:keys [tokens] :as cfg} request]
(let [invitation (get-in request [:params :invitation-token])
state (tokens :generate {:iss :github-oauth
:invitation-token invitation
:exp (dt/in-future "15m")})
params {:client_id (:client-id cfg/config)
:redirect_uri (build-redirect-url cfg)
:state state
:scope scope}
query (u/map->query-string params)
uri (-> authorize-uri
(assoc :query query))]
{:status 200
:body {:redirect-uri (str uri)}}))
(defn- callback-handler
[{:keys [session] :as cfg} request]
(try
(let [info (retrieve-info cfg request)
profile (gg/register-profile cfg info)
uri (gg/generate-redirect-uri cfg profile)
sxf ((:create session) (:id profile))]
(->> (gg/redirect-response uri)
(sxf request)))
(catch Exception _e
(-> (gg/generate-error-redirect-uri cfg)
(gg/redirect-response)))))
;; --- ENTRY POINT
(s/def ::client-id ::us/not-empty-string)
(s/def ::client-secret ::us/not-empty-string)
(s/def ::public-uri ::us/not-empty-string)
(s/def ::session map?)
(s/def ::tokens fn?)
(defmethod ig/pre-init-spec :app.http.oauth/github [_]
(s/keys :req-un [::public-uri
::session
::tokens]
:opt-un [::client-id
::client-secret]))
(defn- default-handler
[_]
(ex/raise :type :not-found))
(defmethod ig/init-key :app.http.oauth/github
[_ cfg]
(if (and (:client-id cfg)
(:client-secret cfg))
{:handler #(auth-handler cfg %)
:callback-handler #(callback-handler cfg %)}
{:handler default-handler
:callback-handler default-handler}))

167
backend/src/app/http/oauth/gitlab.clj Normal file
View file

@ -0,0 +1,167 @@
;; 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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.http.oauth.gitlab
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.http.oauth.google :as gg]
[app.util.http :as http]
[app.util.time :as dt]
[clojure.data.json :as json]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]
[lambdaisland.uri :as u]))
(def scope "read_user")
(defn- build-redirect-url
[cfg]
(let [public (u/uri (:public-uri cfg))]
(str (assoc public :path "/api/oauth/gitlab/callback"))))
(defn- build-oauth-uri
[cfg]
(let [base-uri (u/uri (:base-uri cfg))]
(assoc base-uri :path "/oauth/authorize")))
(defn- build-token-url
[cfg]
(let [base-uri (u/uri (:base-uri cfg))]
(str (assoc base-uri :path "/oauth/token"))))
(defn- build-user-info-url
[cfg]
(let [base-uri (u/uri (:base-uri cfg))]
(str (assoc base-uri :path "/api/v4/user"))))
(defn- get-access-token
[cfg code]
(try
(let [params {:client_id (:client-id cfg)
:client_secret (:client-secret cfg)
:code code
:grant_type "authorization_code"
:redirect_uri (build-redirect-url cfg)}
req {:method :post
:headers {"content-type" "application/x-www-form-urlencoded"}
:uri (build-token-url cfg)
:body (u/map->query-string params)}
res (http/send! req)]
(when (= 200 (:status res))
(-> (json/read-str (:body res))
(get "access_token"))))
(catch Exception e
(log/error e "unexpected error on get-access-token")
nil)))
(defn- get-user-info
[cfg token]
(try
(let [req {:uri (build-user-info-url cfg)
:headers {"Authorization" (str "Bearer " token)}
:timeout 6000
:method :get}
res (http/send! req)]
(when (= 200 (:status res))
(let [data (json/read-str (:body res))]
{:email (get data "email")
:backend "gitlab"
:fullname (get data "name")})))
(catch Exception e
(log/error e "unexpected exception on get-user-info")
nil)))
(defn- retrieve-info
[{:keys [tokens] :as cfg} request]
(let [token (get-in request [:params :state])
state (tokens :verify {:token token :iss :gitlab-oauth})
info (some->> (get-in request [:params :code])
(get-access-token cfg)
(get-user-info cfg))]
(when-not info
(ex/raise :type :internal
:code :unable-to-auth))
(cond-> info
(some? (:invitation-token state))
(assoc :invitation-token (:invitation-token state)))))
(defn- auth-handler
[{:keys [tokens] :as cfg} request]
(let [invitation (get-in request [:params :invitation-token])
state (tokens :generate
{:iss :gitlab-oauth
:invitation-token invitation
:exp (dt/in-future "15m")})
params {:client_id (:client-id cfg)
:redirect_uri (build-redirect-url cfg)
:response_type "code"
:state state
:scope scope}
query (u/map->query-string params)
uri (-> (build-oauth-uri cfg)
(assoc :query query))]
{:status 200
:body {:redirect-uri (str uri)}}))
(defn- callback-handler
[{:keys [session] :as cfg} request]
(try
(let [info (retrieve-info cfg request)
profile (gg/register-profile cfg info)
uri (gg/generate-redirect-uri cfg profile)
sxf ((:create session) (:id profile))]
(->> (gg/redirect-response uri)
(sxf request)))
(catch Exception _e
(-> (gg/generate-error-redirect-uri cfg)
(gg/redirect-response)))))
(s/def ::client-id ::us/not-empty-string)
(s/def ::client-secret ::us/not-empty-string)
(s/def ::base-uri ::us/not-empty-string)
(s/def ::public-uri ::us/not-empty-string)
(s/def ::session map?)
(s/def ::tokens fn?)
(defmethod ig/pre-init-spec :app.http.oauth/gitlab [_]
(s/keys :req-un [::public-uri
::session
::tokens]
:opt-un [::base-uri
::client-id
::client-secret]))
(defmethod ig/prep-key :app.http.oauth/gitlab
[_ cfg]
(d/merge {:base-uri "https://gitlab.com"}
(d/without-nils cfg)))
(defn- default-handler
[_]
(ex/raise :type :not-found))
(defmethod ig/init-key :app.http.oauth/gitlab
[_ cfg]
(if (and (:client-id cfg)
(:client-secret cfg))
{:handler #(auth-handler cfg %)
:callback-handler #(callback-handler cfg %)}
{:handler default-handler
:callback-handler default-handler}))

182
backend/src/app/http/oauth/google.clj Normal file
View file

@ -0,0 +1,182 @@
;; 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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.http.oauth.google
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.util.http :as http]
[app.util.time :as dt]
[clojure.data.json :as json]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]
[lambdaisland.uri :as u]))
(def base-goauth-uri "https://accounts.google.com/o/oauth2/v2/auth")
(def scope
(str "email profile "
"https://www.googleapis.com/auth/userinfo.email "
"https://www.googleapis.com/auth/userinfo.profile "
"openid"))
(defn- build-redirect-url
[cfg]
(let [public (u/uri (:public-uri cfg))]
(str (assoc public :path "/api/oauth/google/callback"))))
(defn- get-access-token
[cfg code]
(try
(let [params {:code code
:client_id (:client-id cfg)
:client_secret (:client-secret cfg)
:redirect_uri (build-redirect-url cfg)
:grant_type "authorization_code"}
req {:method :post
:headers {"content-type" "application/x-www-form-urlencoded"}
:uri "https://oauth2.googleapis.com/token"
:timeout 6000
:body (u/map->query-string params)}
res (http/send! req)]
(when (= 200 (:status res))
(-> (json/read-str (:body res))
(get "access_token"))))
(catch Exception e
(log/error e "unexpected error on get-access-token")
nil)))
(defn- get-user-info
[_ token]
(try
(let [req {:uri "https://openidconnect.googleapis.com/v1/userinfo"
:headers {"Authorization" (str "Bearer " token)}
:timeout 6000
:method :get}
res (http/send! req)]
(when (= 200 (:status res))
(let [data (json/read-str (:body res))]
{:email (get data "email")
:backend "google"
:fullname (get data "name")})))
(catch Exception e
(log/error e "unexpected exception on get-user-info")
nil)))
(defn- retrieve-info
[{:keys [tokens] :as cfg} request]
(let [token (get-in request [:params :state])
state (tokens :verify {:token token :iss :google-oauth})
info (some->> (get-in request [:params :code])
(get-access-token cfg)
(get-user-info cfg))]
(when-not info
(ex/raise :type :internal
:code :unable-to-auth))
(cond-> info
(some? (:invitation-token state))
(assoc :invitation-token (:invitation-token state)))))
(defn register-profile
[{:keys [rpc] :as cfg} info]
(let [method-fn (get-in rpc [:methods :mutation :login-or-register])
profile (method-fn {:email (:email info)
:backend (:backend info)
:fullname (:fullname info)})]
(cond-> profile
(some? (:invitation-token info))
(assoc :invitation-token (:invitation-token info)))))
(defn generate-redirect-uri
[{:keys [tokens] :as cfg} profile]
(let [token (or (:invitation-token profile)
(tokens :generate {:iss :auth
:exp (dt/in-future "15m")
:profile-id (:id profile)}))]
(-> (u/uri (:public-uri cfg))
(assoc :path "/#/auth/verify-token")
(assoc :query (u/map->query-string {:token token})))))
(defn generate-error-redirect-uri
[cfg]
(-> (u/uri (:public-uri cfg))
(assoc :path "/#/auth/login")
(assoc :query (u/map->query-string {:error "unable-to-auth"}))))
(defn redirect-response
[uri]
{:status 302
:headers {"location" (str uri)}
:body ""})
(defn- auth-handler
[{:keys [tokens] :as cfg} request]
(let [invitation (get-in request [:params :invitation-token])
state (tokens :generate
{:iss :google-oauth
:invitation-token invitation
:exp (dt/in-future "15m")})
params {:scope scope
:access_type "offline"
:include_granted_scopes true
:state state
:response_type "code"
:redirect_uri (build-redirect-url cfg)
:client_id (:client-id cfg)}
query (u/map->query-string params)
uri (-> (u/uri base-goauth-uri)
(assoc :query query))]
{:status 200
:body {:redirect-uri (str uri)}}))
(defn- callback-handler
[{:keys [session] :as cfg} request]
(try
(let [info (retrieve-info cfg request)
profile (register-profile cfg info)
uri (generate-redirect-uri cfg profile)
sxf ((:create session) (:id profile))]
(->> (redirect-response uri)
(sxf request)))
(catch Exception _e
(-> (generate-error-redirect-uri cfg)
(redirect-response)))))
(s/def ::client-id ::us/not-empty-string)
(s/def ::client-secret ::us/not-empty-string)
(s/def ::public-uri ::us/not-empty-string)
(s/def ::session map?)
(s/def ::tokens fn?)
(defmethod ig/pre-init-spec :app.http.oauth/google [_]
(s/keys :req-un [::public-uri
::session
::tokens]
:opt-un [::client-id
::client-secret]))
(defn- default-handler
[_]
(ex/raise :type :not-found))
(defmethod ig/init-key :app.http.oauth/google
[_ cfg]
(if (and (:client-id cfg)
(:client-secret cfg))
{:handler #(auth-handler cfg %)
:callback-handler #(callback-handler cfg %)}
{:handler default-handler
:callback-handler default-handler}))

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

@ -9,21 +9,32 @@
(ns app.http.session
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.config :as cfg]
[app.db :as db]
[app.metrics :as mtx]
[app.util.async :as aa]
[app.util.log4j :refer [update-thread-context!]]
[app.util.time :as dt]
[app.worker :as wrk]
[buddy.core.codecs :as bc]
[buddy.core.nonce :as bn]
[clojure.core.async :as a]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]))
(defn next-session-id
;; --- IMPL
(defn- next-session-id
([] (next-session-id 96))
([n]
(-> (bn/random-nonce n)
(bc/bytes->b64u)
(bc/bytes->str))))
(defn create!
(defn- create
[{:keys [conn] :as cfg} {:keys [profile-id user-agent]}]
(let [id (next-session-id)]
(db/insert! conn :http-session {:id id
@ -31,44 +42,177 @@
:user-agent user-agent})
id))
(defn delete!
[{:keys [conn cookie-name] :as cfg} request]
(when-let [token (get-in request [:cookies cookie-name :value])]
(defn- delete
[{:keys [conn cookie-name] :as cfg} {:keys [cookies] :as request}]
(when-let [token (get-in cookies [cookie-name :value])]
(db/delete! conn :http-session {:id token}))
nil)
(defn retrieve
(defn- retrieve
[{:keys [conn] :as cfg} token]
(when token
(-> (db/exec-one! conn ["select profile_id from http_session where id = ?" token])
(:profile-id))))
(db/exec-one! conn ["select id, profile_id from http_session where id = ?" token])))
(defn retrieve-from-request
[{:keys [cookie-name] :as cfg} request]
(->> (get-in request [:cookies cookie-name :value])
(defn- retrieve-from-request
[{:keys [cookie-name] :as cfg} {:keys [cookies] :as request}]
(->> (get-in cookies [cookie-name :value])
(retrieve cfg)))
(defn cookies
(defn- cookies
[{:keys [cookie-name] :as cfg} vals]
{cookie-name (merge vals {:path "/" :http-only true})})
(defn middleware
(defn- middleware
[cfg handler]
(fn [request]
(if-let [profile-id (retrieve-from-request cfg request)]
(do
(if-let [{:keys [id profile-id] :as session} (retrieve-from-request cfg request)]
(let [ech (::events-ch cfg)]
(a/>!! ech id)
(update-thread-context! {:profile-id profile-id})
(handler (assoc request :profile-id profile-id)))
(handler request))))
;; --- STATE INIT: SESSION
(s/def ::cookie-name ::cfg/http-session-cookie-name)
(defmethod ig/pre-init-spec ::session [_]
(s/keys :req-un [::db/pool]))
(s/keys :req-un [::db/pool]
:opt-un [::cookie-name]))
(defmethod ig/prep-key ::session
[_ cfg]
(merge {:cookie-name "auth-token"} cfg))
(merge {:cookie-name "auth-token"
:buffer-size 64}
(d/without-nils cfg)))
(defmethod ig/init-key ::session
[_ {:keys [pool] :as cfg}]
(let [cfg (assoc cfg :conn pool)]
(merge cfg {:middleware #(middleware cfg %)})))
(let [events (a/chan (a/dropping-buffer (:buffer-size cfg)))
cfg (assoc cfg
:conn pool
::events-ch events)]
(-> cfg
(assoc :middleware #(middleware cfg %))
(assoc :create (fn [profile-id]
(fn [request response]
(let [uagent (get-in request [:headers "user-agent"])
value (create cfg {:profile-id profile-id :user-agent uagent})]
(assoc response :cookies (cookies cfg {:value value}))))))
(assoc :delete (fn [request response]
(delete cfg request)
(assoc response
:status 204
:body ""
:cookies (cookies cfg {:value "" :max-age -1})))))))
(defmethod ig/halt-key! ::session
[_ data]
(a/close! (::events-ch data)))
;; --- STATE INIT: SESSION UPDATER
(declare batch-events)
(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}]
(log/infof "initialize session updater (max-batch-age=%s, max-batch-size=%s)"
(str (:max-batch-age cfg))
(str (:max-batch-size cfg)))
(let [input (batch-events cfg (::events-ch session))
mcnt (mtx/create
{:name "http_session_updater_count"
:help "A counter of session update batch events."
:registry (:registry metrics)
:type :counter})]
(a/go-loop []
(when-let [[reason batch] (a/<! input)]
(let [result (a/<! (update-sessions cfg batch))]
(mcnt :inc)
(if (ex/exception? result)
(log/error result "updater: unexpected error on update sessions")
(log/tracef "updater: updated %s sessions (reason: %s)." result (name reason)))
(recur))))))
(defn- timeout-chan
[cfg]
(a/timeout (inst-ms (:max-batch-age cfg))))
(defn- batch-events
[cfg in]
(let [out (a/chan)]
(a/go-loop [tch (timeout-chan cfg)
buf #{}]
(let [[val port] (a/alts! [tch in])]
(cond
(identical? port tch)
(if (empty? buf)
(recur (timeout-chan cfg) buf)
(do
(a/>! out [:timeout buf])
(recur (timeout-chan cfg) #{})))
(nil? val)
(a/close! out)
(identical? port in)
(let [buf (conj buf val)]
(if (>= (count buf) (:max-batch-size cfg))
(do
(a/>! out [:size buf])
(recur (timeout-chan cfg) #{}))
(recur tch buf))))))
out))
(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)))
;; --- STATE INIT: SESSION GC
(declare sql:delete-expired)
(s/def ::max-age ::dt/duration)
(defmethod ig/pre-init-spec ::gc-task [_]
(s/keys :req-un [::db/pool]
:opt-un [::max-age]))
(defmethod ig/prep-key ::gc-task
[_ cfg]
(merge {:max-age (dt/duration {:days 2})}
(d/without-nils cfg)))
(defmethod ig/init-key ::gc-task
[_ {: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-expired interval])
result (:next.jdbc/update-count result)]
(log/debugf "gc-task: removed %s rows from http-session table" result)
result))))
(def ^:private
sql:delete-expired
"delete from http_session
where updated_at < now() - ?::interval")

92
backend/src/app/loggers/loki.clj Normal file
View file

@ -0,0 +1,92 @@
;; 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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.loggers.loki
"A Loki integration."
(:require
[app.common.spec :as us]
[app.config :as cfg]
[app.util.async :as aa]
[app.util.http :as http]
[app.util.json :as json]
[app.worker :as wrk]
[clojure.core.async :as a]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]))
(declare handle-event)
(s/def ::uri ::us/string)
(s/def ::receiver fn?)
(defmethod ig/pre-init-spec ::reporter [_]
(s/keys :req-un [::wrk/executor ::receiver]
:opt-un [::uri]))
(defmethod ig/init-key ::reporter
[_ {:keys [receiver uri] :as cfg}]
(when uri
(log/info "intializing loki reporter")
(let [output (a/chan (a/sliding-buffer 1024))]
(receiver :sub output)
(a/go-loop []
(let [msg (a/<! output)]
(if (nil? msg)
(log/info "stoping error reporting loop")
(do
(a/<! (handle-event cfg msg))
(recur)))))
output)))
(defmethod ig/halt-key! ::reporter
[_ output]
(when output
(a/close! output)))
(defn- prepare-payload
[event]
(let [labels {:host (cfg/get :host)
:tenant (cfg/get :tenant)
:version (:full cfg/version)
:logger (:logger event)
:level (:level event)}]
{:streams
[{:stream labels
:values [[(str (* (inst-ms (:created-at event)) 1000000))
(str (:message event)
(when-let [error (:error event)]
(str "\n" (:trace error))))]]}]}))
(defn- send-log
[uri payload i]
(try
(let [response (http/send! {:uri uri
:timeout 6000
:method :post
:headers {"content-type" "application/json"}
:body (json/encode payload)})]
(if (= (:status response) 204)
true
(do
(log/errorf "error on sending log to loki (try %s)\n%s" i (pr-str response))
false)))
(catch Exception e
(log/errorf e "error on sending message to loki (try %s)" i)
false)))
(defn- handle-event
[{:keys [executor uri]} event]
(aa/with-thread executor
(let [payload (prepare-payload event)]
(loop [i 1]
(when (and (not (send-log uri payload i)) (< i 20))
(Thread/sleep (* i 2000))
(recur (inc i)))))))

120
backend/src/app/error_reporter.clj → backend/src/app/loggers/mattermost.clj
View file

@ -5,9 +5,9 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.error-reporter
(ns app.loggers.mattermost
"A mattermost integration for error reporting."
(:require
[app.common.exceptions :as ex]
@ -15,6 +15,7 @@
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.util.async :as aa]
[app.util.http :as http]
[app.util.json :as json]
[app.util.template :as tmpl]
@ -24,11 +25,7 @@
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[cuerdas.core :as str]
[integrant.core :as ig]
[promesa.exec :as px])
(:import
org.apache.logging.log4j.core.LogEvent
org.apache.logging.log4j.util.ReadOnlyStringMap))
[integrant.core :as ig]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Error Listener
@ -37,76 +34,51 @@
(declare handle-event)
(defonce enabled-mattermost (atom true))
(defonce queue (a/chan (a/sliding-buffer 64)))
(defonce queue-fn (fn [event] (a/>!! queue event)))
(s/def ::uri ::us/string)
(defmethod ig/pre-init-spec ::reporter [_]
(s/keys :req-un [::wrk/executor ::db/pool]
(s/keys :req-un [::wrk/executor ::db/pool ::receiver]
:opt-un [::uri]))
(defmethod ig/init-key ::reporter
[_ {:keys [executor] :as cfg}]
(log/info "Intializing error reporter.")
(let [close-ch (a/chan 1)]
[_ {:keys [receiver] :as cfg}]
(log/info "intializing mattermost error reporter")
(let [output (a/chan (a/sliding-buffer 128)
(filter #(= (:level %) "error")))]
(receiver :sub output)
(a/go-loop []
(let [[val port] (a/alts! [close-ch queue])]
(cond
(= port close-ch)
(log/info "Stoping error reporting loop.")
(nil? val)
(log/info "Stoping error reporting loop.")
:else
(let [msg (a/<! output)]
(if (nil? msg)
(log/info "stoping error reporting loop")
(do
(px/run! executor #(handle-event cfg val))
(a/<! (handle-event cfg msg))
(recur)))))
close-ch))
output))
(defmethod ig/halt-key! ::reporter
[_ close-ch]
(a/close! close-ch))
(defn- get-context-data
[event]
(let [^LogEvent levent (deref event)
^ReadOnlyStringMap rosm (.getContextData levent)]
(into {:message (str event)
:id (uuid/next)} ; set default uuid for cases when it not comes.
(comp
(map (fn [[key val]]
(cond
(= "id" key) [:id (uuid/uuid val)]
(= "profile-id" key) [:profile-id (uuid/uuid val)]
(str/blank? val) nil
(string? key) [(keyword key) val]
:else [key val])))
(filter some?))
(.toMap rosm))))
[_ output]
(a/close! output))
(defn- send-mattermost-notification!
[cfg {:keys [message host version id] :as cdata}]
[cfg {:keys [host version id error] :as cdata}]
(try
(let [uri (:uri cfg)
prefix (str "Unhandled exception (@channel):\n"
"- detail: " (:public-uri cfg/config) "/dbg/error-by-id/" id "\n"
"- host: `" host "`\n"
"- version: `" version "`\n")
text (str prefix "```\n" message "\n```")
(let [uri (:uri cfg)
text (str "Unhandled exception (@channel):\n"
"- detail: " (:public-uri cfg/config) "/dbg/error-by-id/" id "\n"
"- host: `" host "`\n"
"- version: `" version "`\n"
(when error
(str "```\n" (:trace error) "\n```")))
rsp (http/send! {:uri uri
:method :post
:headers {"content-type" "application/json"}
:body (json/encode-str {:text text})})]
(when (not= (:status rsp) 200)
(log/warnf "Error reporting webhook replying with unexpected status: %s\n%s"
(:status rsp)
(pr-str rsp))))
(log/errorf "error on sending data to mattermost\n%s" (pr-str rsp))))
(catch Exception e
(log/warnf e "Unexpected exception on error reporter."))))
(log/error e "unexpected exception on error reporter"))))
(defn- persist-on-database!
[{:keys [pool] :as cfg} {:keys [id] :as cdata}]
@ -114,15 +86,37 @@
(db/insert! conn :server-error-report
{:id id :content (db/tjson cdata)})))
(defn- parse-context
[event]
(reduce-kv
(fn [acc k v]
(cond
(= k :id) (assoc acc k (uuid/uuid v))
(= k :profile-id) (assoc acc k (uuid/uuid v))
(str/blank? v) acc
:else (assoc acc k v)))
{:id (uuid/next)}
(:context event)))
(defn- parse-event
[event]
(-> (parse-context event)
(merge (dissoc event :context))
(assoc :tenant (cfg/get :tenant))
(assoc :host (cfg/get :host))
(assoc :public-uri (cfg/get :public-uri))
(assoc :version (:full cfg/version))))
(defn handle-event
[cfg event]
(try
(let [cdata (get-context-data event)]
(when (and (:uri cfg) @enabled-mattermost)
(send-mattermost-notification! cfg cdata))
(persist-on-database! cfg cdata))
(catch Exception e
(log/warnf e "Unexpected exception on error reporter."))))
[{:keys [executor] :as cfg} event]
(aa/with-thread executor
(try
(let [cdata (parse-event event)]
(when (and (:uri cfg) @enabled-mattermost)
(send-mattermost-notification! cfg cdata))
(persist-on-database! cfg cdata))
(catch Exception e
(log/error e "unexpected exception on error reporter")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Http Handler

92
backend/src/app/loggers/zmq.clj Normal file
View file

@ -0,0 +1,92 @@
;; 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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.loggers.zmq
"A generic ZMQ listener."
(:require
[app.common.data :as d]
[app.common.spec :as us]
[app.util.json :as json]
[app.util.time :as dt]
[clojure.core.async :as a]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[cuerdas.core :as str]
[integrant.core :as ig])
(:import
org.zeromq.SocketType
org.zeromq.ZMQ$Socket
org.zeromq.ZContext))
(declare prepare)
(declare start-rcv-loop)
(s/def ::endpoint ::us/string)
(defmethod ig/pre-init-spec ::receiver [_]
(s/keys :opt-un [::endpoint]))
(defmethod ig/init-key ::receiver
[_ {:keys [endpoint] :as cfg}]
(log/infof "intializing ZMQ receiver on '%s'" endpoint)
(let [buffer (a/chan 1)
output (a/chan 1 (comp (filter map?)
(map prepare)))
mult (a/mult output)]
(when endpoint
(a/thread (start-rcv-loop {:out buffer :endpoint endpoint})))
(a/pipe buffer output)
(with-meta
(fn [cmd ch]
(case cmd
:sub (a/tap mult ch)
:unsub (a/untap mult ch))
ch)
{::output output
::buffer buffer
::mult mult})))
(defmethod ig/halt-key! ::receiver
[_ f]
(a/close! (::buffer (meta f))))
(defn- start-rcv-loop
([] (start-rcv-loop nil))
([{:keys [out endpoint] :or {endpoint "tcp://localhost:5556"}}]
(let [out (or out (a/chan 1))
zctx (ZContext.)
socket (.. zctx (createSocket SocketType/SUB))]
(.. socket (connect ^String endpoint))
(.. socket (subscribe ""))
(.. socket (setReceiveTimeOut 5000))
(loop []
(let [msg (.recv ^ZMQ$Socket socket)
msg (json/decode msg)
msg (if (nil? msg) :empty msg)]
(if (a/>!! out msg)
(recur)
(do
(.close ^java.lang.AutoCloseable socket)
(.close ^java.lang.AutoCloseable zctx))))))))
(defn- prepare
[event]
(d/merge
{:logger (:loggerName event)
:level (str/lower (:level event))
:thread (:thread event)
:created-at (dt/instant (:timeMillis event))
:message (:message event)}
(when-let [ctx (:contextMap event)]
{:context ctx})
(when-let [thrown (:thrown event)]
{:error
{:class (:name thrown)
:message (:message thrown)
:trace (:extendedStackTrace thrown)}})))

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

@ -37,11 +37,19 @@
:max-pool-size 20}
:app.metrics/metrics
{}
{:definitions
{:profile-register
{:name "actions_profile_register_count"
:help "A global counter of user registrations."
:type :counter}
:profile-activation
{:name "actions_profile_activation_count"
:help "A global counter of profile activations"
:type :counter}}}
:app.migrations/all
{:main (ig/ref :app.migrations/migrations)
:telemetry (ig/ref :app.telemetry/migrations)}
{:main (ig/ref :app.migrations/migrations)
:telemetry (ig/ref :app.telemetry/migrations)}
:app.migrations/migrations
{}
@ -49,11 +57,11 @@
:app.telemetry/migrations
{}
:app.redis/redis
:app.msgbus/msgbus
{:uri (:redis-uri config)}
:app.tokens/tokens
{:sprops (ig/ref :app.sprops/props)}
{:sprops (ig/ref :app.setup/props)}
:app.storage/gc-deleted-task
{:pool (ig/ref :app.db/pool)
@ -69,7 +77,23 @@
:app.http.session/session
{:pool (ig/ref :app.db/pool)
:cookie-name "auth-token"}
:cookie-name (:http-session-cookie-name config)}
:app.http.session/gc-task
{:pool (ig/ref :app.db/pool)
:max-age (:http-session-idle-max-age config)}
:app.http.session/updater
{:pool (ig/ref :app.db/pool)
:metrics (ig/ref :app.metrics/metrics)
:executor (ig/ref :app.worker/executor)
:session (ig/ref :app.http.session/session)
:max-batch-age (:http-session-updater-batch-max-age config)
:max-batch-size (:http-session-updater-batch-max-size config)}
:app.http.awsns/handler
{:tokens (ig/ref :app.tokens/tokens)
:pool (ig/ref :app.db/pool)}
:app.http/server
{:port (:http-server-port config)
@ -83,14 +107,13 @@
:tokens (ig/ref :app.tokens/tokens)
:public-uri (:public-uri config)
:metrics (ig/ref :app.metrics/metrics)
:google-auth (ig/ref :app.http.auth/google)
:gitlab-auth (ig/ref :app.http.auth/gitlab)
:github-auth (ig/ref :app.http.auth/github)
:ldap-auth (ig/ref :app.http.auth/ldap)
:oauth (ig/ref :app.http.oauth/all)
:assets (ig/ref :app.http.assets/handlers)
:svgparse (ig/ref :app.svgparse/handler)
:storage (ig/ref :app.storage/storage)
:error-report-handler (ig/ref :app.error-reporter/handler)}
:sns-webhook (ig/ref :app.http.awsns/handler)
:feedback (ig/ref :app.http.feedback/handler)
:error-report-handler (ig/ref :app.loggers.mattermost/handler)}
:app.http.assets/handlers
{:metrics (ig/ref :app.metrics/metrics)
@ -99,7 +122,15 @@
:cache-max-age (dt/duration {:hours 24})
:signature-max-age (dt/duration {:hours 24 :minutes 5})}
:app.http.auth/google
:app.http.feedback/handler
{:pool (ig/ref :app.db/pool)}
:app.http.oauth/all
{:google (ig/ref :app.http.oauth/google)
:gitlab (ig/ref :app.http.oauth/gitlab)
:github (ig/ref :app.http.oauth/github)}
:app.http.oauth/google
{:rpc (ig/ref :app.rpc/rpc)
:session (ig/ref :app.http.session/session)
:tokens (ig/ref :app.tokens/tokens)
@ -107,7 +138,7 @@
:client-id (:google-client-id config)
:client-secret (:google-client-secret config)}
:app.http.auth/github
:app.http.oauth/github
{:rpc (ig/ref :app.rpc/rpc)
:session (ig/ref :app.http.session/session)
:tokens (ig/ref :app.tokens/tokens)
@ -115,7 +146,7 @@
:client-id (:github-client-id config)
:client-secret (:github-client-secret config)}
:app.http.auth/gitlab
:app.http.oauth/gitlab
{:rpc (ig/ref :app.rpc/rpc)
:session (ig/ref :app.http.session/session)
:tokens (ig/ref :app.tokens/tokens)
@ -124,20 +155,6 @@
:client-id (:gitlab-client-id config)
:client-secret (:gitlab-client-secret config)}
:app.http.auth/ldap
{:host (:ldap-auth-host config)
:port (:ldap-auth-port config)
:ssl (:ldap-auth-ssl config)
:starttls (:ldap-auth-starttls config)
:user-query (:ldap-auth-user-query config)
:username-attribute (:ldap-auth-username-attribute config)
:email-attribute (:ldap-auth-email-attribute config)
:fullname-attribute (:ldap-auth-fullname-attribute config)
:avatar-attribute (:ldap-auth-avatar-attribute config)
:base-dn (:ldap-auth-base-dn config)
:session (ig/ref :app.http.session/session)
:rpc (ig/ref :app.rpc/rpc)}
:app.svgparse/svgc
{:metrics (ig/ref :app.metrics/metrics)}
@ -165,15 +182,16 @@
:tokens (ig/ref :app.tokens/tokens)
:metrics (ig/ref :app.metrics/metrics)
:storage (ig/ref :app.storage/storage)
:redis (ig/ref :app.redis/redis)
:msgbus (ig/ref :app.msgbus/msgbus)
:rlimits (ig/ref :app.rlimits/all)
:svgc (ig/ref :app.svgparse/svgc)}
:app.notifications/handler
{:redis (ig/ref :app.redis/redis)
:pool (ig/ref :app.db/pool)
:session (ig/ref :app.http.session/session)
:metrics (ig/ref :app.metrics/metrics)}
{:msgbus (ig/ref :app.msgbus/msgbus)
:pool (ig/ref :app.db/pool)
:session (ig/ref :app.http.session/session)
:metrics (ig/ref :app.metrics/metrics)
:executor (ig/ref :app.worker/executor)}
:app.worker/executor
{:name "worker"}
@ -181,46 +199,61 @@
:app.worker/worker
{:executor (ig/ref :app.worker/executor)
:pool (ig/ref :app.db/pool)
:tasks (ig/ref :app.tasks/all)}
:tasks (ig/ref :app.tasks/registry)}
:app.worker/scheduler
{:executor (ig/ref :app.worker/executor)
:pool (ig/ref :app.db/pool)
:tasks (ig/ref :app.tasks/registry)
:schedule
[{:id "file-media-gc"
:cron #app/cron "0 0 0 */1 * ? *" ;; daily
:fn (ig/ref :app.tasks.file-media-gc/handler)}
:task :file-media-gc}
{:id "file-xlog-gc"
:cron #app/cron "0 0 */1 * * ?" ;; hourly
:fn (ig/ref :app.tasks.file-xlog-gc/handler)}
:task :file-xlog-gc}
{:id "storage-deleted-gc"
:cron #app/cron "0 0 1 */1 * ?" ;; daily (1 hour shift)
:fn (ig/ref :app.storage/gc-deleted-task)}
:task :storage-deleted-gc}
{:id "storage-touched-gc"
:cron #app/cron "0 0 2 */1 * ?" ;; daily (2 hour shift)
:fn (ig/ref :app.storage/gc-touched-task)}
:task :storage-touched-gc}
{:id "session-gc"
:cron #app/cron "0 0 3 */1 * ?" ;; daily (3 hour shift)
:task :session-gc}
{:id "storage-recheck"
:cron #app/cron "0 0 */1 * * ?" ;; hourly
:fn (ig/ref :app.storage/recheck-task)}
:task :storage-recheck}
{:id "tasks-gc"
:cron #app/cron "0 0 0 */1 * ?" ;; daily
:fn (ig/ref :app.tasks.tasks-gc/handler)}
:task :tasks-gc}
(when (:telemetry-enabled config)
{:id "telemetry"
:cron #app/cron "0 0 */6 * * ?" ;; every 6h
:uri (:telemetry-uri config)
:fn (ig/ref :app.tasks.telemetry/handler)})]}
:task :telemetry})]}
:app.tasks/all
{"sendmail" (ig/ref :app.tasks.sendmail/handler)
"delete-object" (ig/ref :app.tasks.delete-object/handler)
"delete-profile" (ig/ref :app.tasks.delete-profile/handler)}
:app.tasks/registry
{:metrics (ig/ref :app.metrics/metrics)
:tasks
{:sendmail (ig/ref :app.tasks.sendmail/handler)
:delete-object (ig/ref :app.tasks.delete-object/handler)
:delete-profile (ig/ref :app.tasks.delete-profile/handler)
:file-media-gc (ig/ref :app.tasks.file-media-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-recheck (ig/ref :app.storage/recheck-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)}}
:app.tasks.sendmail/handler
{:host (:smtp-host config)
@ -266,21 +299,30 @@
{:pool (ig/ref :app.db/pool)
:version (:full cfg/version)
:uri (:telemetry-uri config)
:sprops (ig/ref :app.sprops/props)}
:sprops (ig/ref :app.setup/props)}
:app.srepl/server
{:port (:srepl-port config)
:host (:srepl-host config)}
:app.sprops/props
:app.setup/props
{:pool (ig/ref :app.db/pool)}
:app.error-reporter/reporter
:app.loggers.zmq/receiver
{:endpoint (:loggers-zmq-uri config)}
:app.loggers.loki/reporter
{:uri (:loggers-loki-uri config)
:receiver (ig/ref :app.loggers.zmq/receiver)
:executor (ig/ref :app.worker/executor)}
:app.loggers.mattermost/reporter
{:uri (:error-report-webhook config)
:receiver (ig/ref :app.loggers.zmq/receiver)
:pool (ig/ref :app.db/pool)
:executor (ig/ref :app.worker/executor)}
:app.error-reporter/handler
:app.loggers.mattermost/handler
{:pool (ig/ref :app.db/pool)}
:app.storage/storage
@ -333,7 +375,7 @@
(-> system-config
(ig/prep)
(ig/init))))
(log/infof "Welcome to penpot! Version: '%s'."
(log/infof "welcome to penpot (version: '%s')"
(:full cfg/version))))
(defn stop

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

@ -77,7 +77,7 @@
(assoc params
:format format
:mtype (cm/format->mtype format)
:size (alength thumbnail-data)
:size (alength ^bytes thumbnail-data)
:data (ByteArrayInputStream. thumbnail-data)))))
(defmulti process :cmd)
@ -89,7 +89,7 @@
(.addImage)
(.autoOrient)
(.strip)
(.thumbnail (int width) (int height) ">")
(.thumbnail ^Integer (int width) ^Integer (int height) ">")
(.quality (double quality))
(.addImage))]
(generic-process (assoc params :operation op))))
@ -101,7 +101,7 @@
(.addImage)
(.autoOrient)
(.strip)
(.thumbnail (int width) (int height) "^")
(.thumbnail ^Integer (int width) ^Integer (int height) "^")
(.gravity "center")
(.extent (int width) (int height))
(.quality (double quality))

120
backend/src/app/metrics.clj
View file

@ -10,17 +10,15 @@
(ns app.metrics
(:require
[app.common.exceptions :as ex]
[app.util.time :as dt]
[app.worker]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]
[next.jdbc :as jdbc])
[integrant.core :as ig])
(:import
io.prometheus.client.CollectorRegistry
io.prometheus.client.Counter
io.prometheus.client.Gauge
io.prometheus.client.Summary
io.prometheus.client.Histogram
io.prometheus.client.exporter.common.TextFormat
io.prometheus.client.hotspot.DefaultExports
io.prometheus.client.jetty.JettyStatisticsCollector
@ -30,41 +28,12 @@
(declare instrument-vars!)
(declare instrument)
(declare create-registry)
(declare create)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Entry Point
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- instrument-jdbc!
[registry]
(instrument-vars!
[#'next.jdbc/execute-one!
#'next.jdbc/execute!]
{:registry registry
:type :counter
:name "database_query_counter"
:help "An absolute counter of database queries."}))
(defn- instrument-workers!
[registry]
(instrument-vars!
[#'app.worker/run-task]
{:registry registry
:type :summary
:name "worker_task_checkout_millis"
:help "Latency measured between scheduld_at and execution time."
:wrap (fn [rootf mobj]
(let [mdata (meta rootf)
origf (::original mdata rootf)]
(with-meta
(fn [tasks item]
(let [now (inst-ms (dt/now))
sat (inst-ms (:scheduled-at item))]
(mobj :observe (- now sat))
(origf tasks item)))
{::original origf})))}))
(defn- handler
[registry _request]
(let [samples (.metricFamilySamples ^CollectorRegistry registry)
@ -73,13 +42,24 @@
{:headers {"content-type" TextFormat/CONTENT_TYPE_004}
:body (.toString writer)}))
(s/def ::definitions
(s/map-of keyword? map?))
(defmethod ig/pre-init-spec ::metrics [_]
(s/keys :opt-un [::definitions]))
(defmethod ig/init-key ::metrics
[_ _cfg]
[_ {:keys [definitions] :as cfg}]
(log/infof "Initializing prometheus registry and instrumentation.")
(let [registry (create-registry)]
(instrument-workers! registry)
(instrument-jdbc! registry)
(let [registry (create-registry)
definitions (reduce-kv (fn [res k v]
(->> (assoc v :registry registry)
(create)
(assoc res k)))
{}
definitions)]
{:handler (partial handler registry)
:definitions definitions
:registry registry}))
(s/def ::handler fn?)
@ -87,7 +67,6 @@
(s/def ::metrics
(s/keys :req-un [::registry ::handler]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -126,7 +105,7 @@
(invoke [_ cmd labels]
(.. ^Counter instance
(labels labels)
(labels (into-array String labels))
(inc))))))
(defn make-gauge
@ -150,19 +129,27 @@
:dec (.dec ^Gauge instance)))
(invoke [_ cmd labels]
(case cmd
:inc (.. ^Gauge instance (labels labels) (inc))
:dec (.. ^Gauge instance (labels labels) (dec)))))))
(let [labels (into-array String [labels])]
(case cmd
:inc (.. ^Gauge instance (labels labels) (inc))
:dec (.. ^Gauge instance (labels labels) (dec))))))))
(def default-quantiles
[[0.75 0.02]
[0.99 0.001]])
(defn make-summary
[{:keys [name help registry reg labels max-age] :or {max-age 3600} :as props}]
[{:keys [name help registry reg labels max-age quantiles buckets]
:or {max-age 3600 buckets 6 quantiles default-quantiles} :as props}]
(let [registry (or registry reg)
instance (doto (Summary/build)
(.name name)
(.help help)
(.maxAgeSeconds max-age)
(.quantile 0.75 0.02)
(.quantile 0.99 0.001))
(.help help))
_ (when (seq quantiles)
(.maxAgeSeconds ^Summary instance max-age)
(.ageBuckets ^Summary instance buckets))
_ (doseq [[q e] quantiles]
(.quantile ^Summary instance q e))
_ (when (seq labels)
(.labelNames instance (into-array String labels)))
instance (.register instance registry)]
@ -176,7 +163,34 @@
(invoke [_ cmd val labels]
(.. ^Summary instance
(labels labels)
(labels (into-array String labels))
(observe val))))))
(def default-histogram-buckets
[1 5 10 25 50 75 100 250 500 750 1000 2500 5000 7500])
(defn make-histogram
[{:keys [name help registry reg labels buckets]
:or {buckets default-histogram-buckets}}]
(let [registry (or registry reg)
instance (doto (Histogram/build)
(.name name)
(.help help)
(.buckets (into-array Double/TYPE buckets)))
_ (when (seq labels)
(.labelNames instance (into-array String labels)))
instance (.register instance registry)]
(reify
clojure.lang.IDeref
(deref [_] instance)
clojure.lang.IFn
(invoke [_ cmd val]
(.observe ^Histogram instance val))
(invoke [_ cmd val labels]
(.. ^Histogram instance
(labels (into-array String labels))
(observe val))))))
(defn create
@ -184,7 +198,8 @@
(case type
:counter (make-counter props)
:gauge (make-gauge props)
:summary (make-summary props)))
:summary (make-summary props)
:histogram (make-histogram props)))
(defn wrap-counter
([rootf mobj]
@ -204,7 +219,6 @@
(assoc mdata ::original origf))))
([rootf mobj labels]
(let [mdata (meta rootf)
labels (into-array String labels)
origf (::original mdata rootf)]
(with-meta
(fn
@ -241,7 +255,6 @@
([rootf mobj labels]
(let [mdata (meta rootf)
labels (into-array String labels)
origf (::original mdata rootf)]
(with-meta
(fn
@ -284,6 +297,9 @@
(instance? Summary @obj)
((or wrap wrap-summary) f obj)
(instance? Histogram @obj)
((or wrap wrap-summary) f obj)
:else
(ex/raise :type :not-implemented))))

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

@ -148,6 +148,21 @@
{:name "0045-add-index-to-file-change-table"
:fn (mg/resource "app/migrations/sql/0045-add-index-to-file-change-table.sql")}
{:name "0046-add-profile-complaint-table"
:fn (mg/resource "app/migrations/sql/0046-add-profile-complaint-table.sql")}
{:name "0047-mod-file-change-table"
:fn (mg/resource "app/migrations/sql/0047-mod-file-change-table.sql")}
{:name "0048-mod-storage-tables"
:fn (mg/resource "app/migrations/sql/0048-mod-storage-tables.sql")}
{:name "0049-mod-http-session-table"
:fn (mg/resource "app/migrations/sql/0049-mod-http-session-table.sql")}
{:name "0050-mod-server-prop-table"
:fn (mg/resource "app/migrations/sql/0050-mod-server-prop-table.sql")}
])

11
backend/src/app/migrations/sql/0035-add-storage-tables.sql
View file

@ -10,11 +10,17 @@ CREATE TABLE storage_object (
metadata jsonb NULL DEFAULT NULL
);
CREATE INDEX storage_object__id__deleted_at__idx
ON storage_object(id, deleted_at)
WHERE deleted_at IS NOT null;
CREATE TABLE storage_data (
id uuid PRIMARY KEY REFERENCES storage_object (id) ON DELETE CASCADE,
data bytea NOT NULL
);
CREATE INDEX storage_data__id__idx ON storage_data(id);
-- Table used for store inflight upload ids, for later recheck and
-- delete possible staled files that exists on the phisical storage
-- but does not exists in the 'storage_object' table.
@ -28,8 +34,3 @@ CREATE TABLE storage_pending (
PRIMARY KEY (created_at, id)
);
CREATE INDEX storage_data__id__idx ON storage_data(id);
CREATE INDEX storage_object__id__deleted_at__idx
ON storage_object(id, deleted_at)
WHERE deleted_at IS NOT null;

3
backend/src/app/migrations/sql/0044-add-storage-refcount.sql
View file

@ -5,9 +5,6 @@ CREATE INDEX storage_object__id_touched_at__idx
ON storage_object (touched_at, id)
WHERE touched_at IS NOT NULL;
-- DROP TRIGGER file_media_object__on_delete__tgr ON file_media_object CASCADE;
-- DROP FUNCTION on_delete_file_media_object () ;
CREATE OR REPLACE FUNCTION on_delete_file_media_object()
RETURNS TRIGGER AS $func$
BEGIN

45
backend/src/app/migrations/sql/0046-add-profile-complaint-table.sql Normal file
View file

@ -0,0 +1,45 @@
CREATE TABLE profile_complaint_report (
profile_id uuid NOT NULL REFERENCES profile(id) ON DELETE CASCADE,
created_at timestamptz NOT NULL DEFAULT now(),
type text NOT NULL,
content jsonb,
PRIMARY KEY (profile_id, created_at)
);
ALTER TABLE profile_complaint_report
ALTER COLUMN type SET STORAGE external,
ALTER COLUMN content SET STORAGE external;
ALTER TABLE profile
ADD COLUMN is_muted boolean DEFAULT false,
ADD COLUMN auth_backend text NULL;
ALTER TABLE profile
ALTER COLUMN auth_backend SET STORAGE external;
UPDATE profile
SET auth_backend = 'google'
WHERE password = '!';
UPDATE profile
SET auth_backend = 'penpot'
WHERE password != '!';
-- Table storing a permanent complaint table for register all
-- permanent bounces and spam reports (complaints) and avoid sending
-- more emails there.
CREATE TABLE global_complaint_report (
email text NOT NULL,
created_at timestamptz NOT NULL DEFAULT now(),
type text NOT NULL,
content jsonb,
PRIMARY KEY (email, created_at)
);
ALTER TABLE global_complaint_report
ALTER COLUMN type SET STORAGE external,
ALTER COLUMN content SET STORAGE external;

16
backend/src/app/migrations/sql/0047-mod-file-change-table.sql Normal file
View file

@ -0,0 +1,16 @@
--- Helps on the lagged changes query on update-file rpc
CREATE INDEX file_change__file_id__revn__idx ON file_change (file_id, revn);
--- Drop redundant index
DROP INDEX page_change_file_id_idx;
--- Add profile_id field.
ALTER TABLE file_change
ADD COLUMN profile_id uuid NULL REFERENCES profile (id) ON DELETE SET NULL;
CREATE INDEX file_change__profile_id__idx
ON file_change (profile_id)
WHERE profile_id IS NOT NULL;
--- Fix naming
ALTER INDEX file_change__created_at_idx RENAME TO file_change__created_at__idx;

9
backend/src/app/migrations/sql/0048-mod-storage-tables.sql Normal file
View file

@ -0,0 +1,9 @@
--- Drop redundant index already covered by primary key
DROP INDEX storage_data__id__idx;
--- Replace not efficient index with more efficient one
DROP INDEX storage_object__id__deleted_at__idx;
CREATE INDEX storage_object__id__deleted_at__idx
ON storage_object(deleted_at, id)
WHERE deleted_at IS NOT NULL;

6
backend/src/app/migrations/sql/0049-mod-http-session-table.sql Normal file
View file

@ -0,0 +1,6 @@
ALTER TABLE http_session
ADD COLUMN updated_at timestamptz NULL;
CREATE INDEX http_session__updated_at__idx
ON http_session (updated_at)
WHERE updated_at IS NOT NULL;

4
backend/src/app/migrations/sql/0050-mod-server-prop-table.sql Normal file
View file

@ -0,0 +1,4 @@
ALTER TABLE server_prop
ADD COLUMN preload boolean DEFAULT false;
UPDATE server_prop SET preload = true;

249
backend/src/app/msgbus.clj Normal file
View file

@ -0,0 +1,249 @@
;; 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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2021 UXBOX Labs SL
(ns app.msgbus
"The msgbus abstraction implemented using redis as underlying backend."
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.config :as cfg]
[app.util.blob :as blob]
[app.util.time :as dt]
[clojure.core.async :as a]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]
[promesa.core :as p])
(:import
java.time.Duration
io.lettuce.core.RedisClient
io.lettuce.core.RedisURI
io.lettuce.core.api.StatefulRedisConnection
io.lettuce.core.api.async.RedisAsyncCommands
io.lettuce.core.codec.ByteArrayCodec
io.lettuce.core.codec.RedisCodec
io.lettuce.core.codec.StringCodec
io.lettuce.core.pubsub.RedisPubSubListener
io.lettuce.core.pubsub.StatefulRedisPubSubConnection
io.lettuce.core.pubsub.api.async.RedisPubSubAsyncCommands))
(declare impl-publish-loop)
(declare impl-redis-pub)
(declare impl-redis-sub)
(declare impl-redis-unsub)
(declare impl-subscribe-loop)
;; --- STATE INIT: Publisher
(s/def ::uri ::us/string)
(s/def ::buffer-size ::us/integer)
(defmethod ig/pre-init-spec ::msgbus [_]
(s/keys :req-un [::uri]
:opt-un [::buffer-size]))
(defmethod ig/prep-key ::msgbus
[_ cfg]
(merge {:buffer-size 128} cfg))
(defmethod ig/init-key ::msgbus
[_ {:keys [uri buffer-size] :as cfg}]
(let [codec (RedisCodec/of StringCodec/UTF8 ByteArrayCodec/INSTANCE)
uri (RedisURI/create uri)
rclient (RedisClient/create ^RedisURI uri)
snd-conn (.connect ^RedisClient rclient ^RedisCodec codec)
rcv-conn (.connectPubSub ^RedisClient rclient ^RedisCodec codec)
;; Channel used for receive publications from the application.
pub-chan (a/chan (a/dropping-buffer buffer-size))
;; Channel used for receive data from redis
rcv-chan (a/chan (a/dropping-buffer buffer-size))
;; Channel used for receive subscription requests.
sub-chan (a/chan)
cch (a/chan 1)]
(.setTimeout ^StatefulRedisConnection snd-conn ^Duration (dt/duration {:seconds 10}))
(.setTimeout ^StatefulRedisPubSubConnection rcv-conn ^Duration (dt/duration {:seconds 10}))
(log/debugf "initializing msgbus (uri: '%s')" (str uri))
;; Start the sending (publishing) loop
(impl-publish-loop snd-conn pub-chan cch)
;; Start the receiving (subscribing) loop
(impl-subscribe-loop rcv-conn rcv-chan sub-chan cch)
(with-meta
(fn run
([command] (run command nil))
([command params]
(a/go
(case command
:pub (a/>! pub-chan params)
:sub (a/>! sub-chan params)))))
{::snd-conn snd-conn
::rcv-conn rcv-conn
::cch cch
::pub-chan pub-chan
::rcv-chan rcv-chan})))
(defmethod ig/halt-key! ::msgbus
[_ f]
(let [mdata (meta f)]
(.close ^StatefulRedisConnection (::snd-conn mdata))
(.close ^StatefulRedisPubSubConnection (::rcv-conn mdata))
(a/close! (::cch mdata))
(a/close! (::pub-chan mdata))
(a/close! (::rcv-chan mdata))))
(defn- impl-publish-loop
[conn pub-chan cch]
(let [rac (.async ^StatefulRedisConnection conn)]
(a/go-loop []
(let [[val _] (a/alts! [cch pub-chan] :priority true)]
(when (some? val)
(let [result (a/<! (impl-redis-pub rac val))]
(when (ex/exception? result)
(log/error result "unexpected error on publish message to redis")))
(recur))))))
(defn- impl-subscribe-loop
[conn rcv-chan sub-chan cch]
;; Add a unique listener to connection
(.addListener conn (reify RedisPubSubListener
(message [it pattern topic message])
(message [it topic message]
;; There are no back pressure, so we use a slidding
;; buffer for cases when the pubsub broker sends
;; more messages that we can process.
(let [val {:topic topic :message (blob/decode message)}]
(when-not (a/offer! rcv-chan val)
(log/warn "dropping message on subscription loop"))))
(psubscribed [it pattern count])
(punsubscribed [it pattern count])
(subscribed [it topic count])
(unsubscribed [it topic count])))
(let [chans (agent {} :error-handler #(log/error % "unexpected error on agent"))
tprefix (str (cfg/get :tenant) ".")
subscribe-to-single-topic
(fn [nsubs topic chan]
(let [nsubs (if (nil? nsubs) #{chan} (conj nsubs chan))]
(when (= 1 (count nsubs))
(let [result (a/<!! (impl-redis-sub conn topic))]
(log/tracef "opening subscription to %s" topic)
(when (ex/exception? result)
(log/errorf result "unexpected exception on subscribing to '%s'" topic))))
nsubs))
subscribe-to-topics
(fn [state topics chan]
(let [state (update state :chans assoc chan topics)]
(reduce (fn [state topic]
(update-in state [:topics topic] subscribe-to-single-topic topic chan))
state
topics)))
unsubscribe-from-single-topic
(fn [nsubs topic chan]
(let [nsubs (disj nsubs chan)]
(when (empty? nsubs)
(let [result (a/<!! (impl-redis-unsub conn topic))]
(log/tracef "closing subscription to %s" topic)
(when (ex/exception? result)
(log/errorf result "unexpected exception on unsubscribing from '%s'" topic))))
nsubs))
unsubscribe-channels
(fn [state pending]
(reduce (fn [state ch]
(let [topics (get-in state [:chans ch])
state (update state :chans dissoc ch)]
(reduce (fn [state topic]
(update-in state [:topics topic] unsubscribe-from-single-topic topic ch))
state
topics)))
state
pending))]
;; Asynchronous subscription loop; terminates when sub-chan is
;; closed.
(a/go-loop []
(when-let [{:keys [topics chan]} (a/<! sub-chan)]
(let [topics (into #{} (map #(str tprefix %)) topics)]
(send-off chans subscribe-to-topics topics chan)
(recur))))
(a/go-loop []
(let [[val port] (a/alts! [cch rcv-chan])]
(cond
;; Stop condition; close all underlying subscriptions and
;; exit. The close operation is performed asynchronously.
(= port cch)
(send-off chans (fn [state]
(log/tracef "close")
(->> (vals state)
(mapcat identity)
(filter some?)
(run! a/close!))))
;; This means we receive data from redis and we need to
;; forward it to the underlying subscriptions.
(= port rcv-chan)
(let [topic (:topic val) ; topic is already string
pending (loop [chans (seq (get-in @chans [:topics topic]))
pending #{}]
(if-let [ch (first chans)]
(if (a/>! ch (:message val))
(recur (rest chans) pending)
(recur (rest chans) (conj pending ch)))
pending))]
;; (log/tracef "received message => pending: %s" (pr-str pending))
(some->> (seq pending)
(send-off chans unsubscribe-channels))
(recur)))))))
(defn- impl-redis-pub
[rac {:keys [topic message]}]
(let [topic (str (cfg/get :tenant) "." topic)
message (blob/encode message)
res (a/chan 1)]
(-> (.publish ^RedisAsyncCommands rac ^String topic ^bytes message)
(p/finally (fn [_ e]
(when e (a/>!! res e))
(a/close! res))))
res))
(defn impl-redis-sub
[conn topic]
(let [^RedisPubSubAsyncCommands cmd (.async ^StatefulRedisPubSubConnection conn)
res (a/chan 1)]
(-> (.subscribe cmd (into-array String [topic]))
(p/finally (fn [_ e]
(when e (a/>!! res e))
(a/close! res))))
res))
(defn impl-redis-unsub
[conn topic]
(let [^RedisPubSubAsyncCommands cmd (.async ^StatefulRedisPubSubConnection conn)
res (a/chan 1)]
(-> (.unsubscribe cmd (into-array String [topic]))
(p/finally (fn [_ e]
(when e (a/>!! res e))
(a/close! res))))
res))

236
backend/src/app/notifications.clj
View file

@ -13,9 +13,10 @@
[app.common.spec :as us]
[app.db :as db]
[app.metrics :as mtx]
[app.redis :as rd]
[app.util.async :as aa]
[app.util.time :as dt]
[app.util.transit :as t]
[app.worker :as wrk]
[clojure.core.async :as a]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
@ -23,7 +24,9 @@
[ring.adapter.jetty9 :as jetty]
[ring.middleware.cookies :refer [wrap-cookies]]
[ring.middleware.keyword-params :refer [wrap-keyword-params]]
[ring.middleware.params :refer [wrap-params]]))
[ring.middleware.params :refer [wrap-params]])
(:import
org.eclipse.jetty.websocket.api.WebSocketAdapter))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Http Handler
@ -34,9 +37,10 @@
(declare handler)
(s/def ::session map?)
(s/def ::msgbus fn?)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::rd/redis ::db/pool ::session ::mtx/metrics]))
(s/keys :req-un [::msgbus ::db/pool ::session ::mtx/metrics ::wrk/executor]))
(defmethod ig/init-key ::handler
[_ {:keys [session metrics] :as cfg}]
@ -44,29 +48,32 @@
mtx-active-connections
(mtx/create
{:name "websocket_notifications_active_connections"
{:name "websocket_active_connections"
:registry (:registry metrics)
:type :gauge
:help "Active websocket connections on notifications service."})
:help "Active websocket connections."})
mtx-message-recv
mtx-messages
(mtx/create
{:name "websocket_notifications_message_recv_timing"
{:name "websocket_message_count"
:registry (:registry metrics)
:type :summary
:help "Message receive summary timing (ms)."})
:labels ["op"]
:type :counter
:help "Counter of processed messages."})
mtx-message-send
mtx-sessions
(mtx/create
{:name "websocket_notifications_message_send_timing"
{:name "websocket_session_timing"
:registry (:registry metrics)
:type :summary
:help "Message receive summary timing (ms)."})
:quantiles []
:help "Websocket session timing (seconds)."
:type :summary})
cfg (assoc cfg
:mtx-active-connections mtx-active-connections
:mtx-message-recv mtx-message-recv
:mtx-message-send mtx-message-send)]
:mtx-messages mtx-messages
:mtx-sessions mtx-sessions
)]
(-> #(handler cfg %)
(wrap-session)
(wrap-keyword-params)
@ -109,14 +116,10 @@
(db/exec-one! conn [sql:retrieve-file id]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; WebSocket Http Handler
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- WEBSOCKET INIT
(declare handle-connect)
(defrecord WebSocket [conn in out sub])
(defn- ws-send
[conn data]
(try
@ -127,109 +130,120 @@
false)))
(defn websocket
[{:keys [file-id team-id redis] :as cfg}]
(let [in (a/chan 32)
out (a/chan 32)
mtx-active-connections (:mtx-active-connections cfg)
mtx-message-send (:mtx-message-send cfg)
mtx-message-recv (:mtx-message-recv cfg)
ws-send (mtx/wrap-summary ws-send mtx-message-send)]
[{:keys [file-id team-id msgbus executor] :as cfg}]
(let [rcv-ch (a/chan 32)
out-ch (a/chan 32)
mtx-aconn (:mtx-active-connections cfg)
mtx-messages (:mtx-messages cfg)
mtx-sessions (:mtx-sessions cfg)
created-at (dt/now)
ws-send (mtx/wrap-counter ws-send mtx-messages ["send"])]
(letfn [(on-connect [conn]
(mtx-active-connections :inc)
(let [sub (rd/subscribe redis {:xform (map t/decode-str)
:topics [file-id team-id]})
ws (WebSocket. conn in out sub nil cfg)]
(mtx-aconn :inc)
;; A subscription channel should use a lossy buffer
;; because we can't penalize normal clients when one
;; slow client is connected to the room.
(let [sub-ch (a/chan (a/dropping-buffer 128))
cfg (assoc cfg
:conn conn
:rcv-ch rcv-ch
:out-ch out-ch
:sub-ch sub-ch)]
;; message forwarding loop
(log/tracef "on-connect %s" (:session-id cfg))
;; Forward all messages from out-ch to the websocket
;; connection
(a/go-loop []
(let [val (a/<! out)]
(when-not (nil? val)
(when (ws-send conn (t/encode-str val))
(let [val (a/<! out-ch)]
(when (some? val)
(when (a/<! (aa/thread-call executor #(ws-send conn (t/encode-str val))))
(recur)))))
(a/go
(a/<! (handle-connect ws))
(a/close! sub))))
;; Subscribe to corresponding topics
(a/<! (msgbus :sub {:topics [file-id team-id] :chan sub-ch}))
(a/<! (handle-connect cfg))
(a/close! sub-ch))))
(on-error [_conn _e]
(a/close! out)
(a/close! in))
(on-error [_conn e]
(mtx-aconn :dec)
(mtx-sessions :observe (/ (inst-ms (dt/duration-between created-at (dt/now))) 1000.0))
(log/tracef "on-error %s (%s)" (:session-id cfg) (ex-message e))
(a/close! out-ch)
(a/close! rcv-ch))
(on-close [_conn _status _reason]
(mtx-active-connections :dec)
(a/close! out)
(a/close! in))
(mtx-aconn :dec)
(mtx-sessions :observe (/ (inst-ms (dt/duration-between created-at (dt/now))) 1000.0))
(log/tracef "on-close %s" (:session-id cfg))
(a/close! out-ch)
(a/close! rcv-ch))
(on-message [_ws message]
(let [message (t/decode-str message)]
(a/>!! in message)))]
(when-not (a/offer! rcv-ch message)
(log/warn "droping ws input message, channe full"))))]
{:on-connect on-connect
:on-error on-error
:on-close on-close
:on-text (mtx/wrap-summary on-message mtx-message-recv)
:on-text (mtx/wrap-counter on-message mtx-messages ["recv"])
:on-bytes (constantly nil)})))
;; --- CONNECTION INIT
(declare handle-message)
(declare start-loop!)
(defn- handle-connect
[{:keys [conn] :as ws}]
[{:keys [conn] :as cfg}]
(a/go
(try
(aa/<? (handle-message ws {:type :connect}))
(aa/<? (start-loop! ws))
(aa/<? (handle-message ws {:type :disconnect}))
(aa/<? (handle-message cfg {:type :connect}))
(aa/<? (start-loop! cfg))
(aa/<? (handle-message cfg {:type :disconnect}))
(catch Throwable err
(log/errorf err "Unexpected exception on websocket handler.")
(let [session (.getSession conn)]
(log/errorf err "unexpected exception on websocket handler")
(let [session (.getSession ^WebSocketAdapter conn)]
(when session
(.disconnect session)))))))
(defn- start-loop!
[{:keys [in out sub session-id] :as ws}]
[{:keys [rcv-ch out-ch sub-ch session-id] :as cfg}]
(aa/go-try
(loop []
(let [timeout (a/timeout 30000)
[val port] (a/alts! [in sub timeout])]
;; (prn "alts" val "from" (cond (= port in) "input"
;; (= port sub) "redis"
;; :else "timeout"))
(let [timeout (a/timeout 30000)
[val port] (a/alts! [rcv-ch sub-ch timeout])]
(cond
;; Process message coming from connected client
(and (= port in) (not (nil? val)))
(and (= port rcv-ch) (some? val))
(do
(aa/<? (handle-message ws val))
(aa/<? (handle-message cfg val))
(recur))
;; Forward message to the websocket
(and (= port sub) (not (nil? val)))
;; If message comes from subscription channel; we just need
;; to foreward it to the output channel.
(and (= port sub-ch) (some? val))
(do
(when-not (= (:session-id val) session-id)
(a/>! out val))
(a/>! out-ch val))
(recur))
;; Timeout channel signaling
;; When timeout channel is signaled, we need to send a ping
;; message to the output channel. TODO: we need to make this
;; more smart.
(= port timeout)
(do
(a/>! out {:type :ping})
(a/>! out-ch {:type :ping})
(recur))
:else
nil)))))
;; Incoming Messages Handling
(defn- publish
[redis channel message]
(aa/go-try
(let [message (t/encode-str message)]
(aa/<? (rd/run redis :publish {:channel (str channel)
:message message})))))
;; --- PRESENCE HANDLING API
(def ^:private
sql:retrieve-presence
@ -237,12 +251,6 @@
where file_id=?
and (clock_timestamp() - updated_at) < '5 min'::interval")
(defn- retrieve-presence
[pool file-id]
(aa/thread-try
(let [rows (db/exec! pool [sql:retrieve-presence file-id])]
(mapv (juxt :session-id :profile-id) rows))))
(def ^:private
sql:update-presence
"insert into presence (file_id, session_id, profile_id, updated_at)
@ -250,51 +258,71 @@
on conflict (file_id, session_id, profile_id)
do update set updated_at=clock_timestamp()")
(defn- retrieve-presence
[{:keys [pool file-id] :as cfg}]
(let [rows (db/exec! pool [sql:retrieve-presence file-id])]
(mapv (juxt :session-id :profile-id) rows)))
(defn- retrieve-presence*
[{:keys [executor] :as cfg}]
(aa/with-thread executor
(retrieve-presence cfg)))
(defn- update-presence
[conn file-id session-id profile-id]
(aa/thread-try
(let [sql [sql:update-presence file-id session-id profile-id]]
(db/exec-one! conn sql))))
[{:keys [pool file-id session-id profile-id] :as cfg}]
(let [sql [sql:update-presence file-id session-id profile-id]]
(db/exec-one! pool sql)))
(defn- update-presence*
[{:keys [executor] :as cfg}]
(aa/with-thread executor
(update-presence cfg)))
(defn- delete-presence
[pool file-id session-id profile-id]
(aa/thread-try
(db/delete! pool :presence {:file-id file-id
:profile-id profile-id
:session-id session-id})))
[{:keys [pool file-id session-id profile-id] :as cfg}]
(db/delete! pool :presence {:file-id file-id
:profile-id profile-id
:session-id session-id}))
(defn- delete-presence*
[{:keys [executor] :as cfg}]
(aa/with-thread executor
(delete-presence cfg)))
;; --- INCOMING MSG PROCESSING
(defmulti handle-message
(fn [_ message] (:type message)))
;; TODO: check permissions for join a file-id channel (probably using
;; single use token for avoid explicit database query).
(defmethod handle-message :connect
[{:keys [file-id profile-id session-id pool redis] :as ws} _message]
[{:keys [file-id msgbus] :as cfg} _message]
;; (log/debugf "profile '%s' is connected to file '%s'" profile-id file-id)
(aa/go-try
(aa/<? (update-presence pool file-id session-id profile-id))
(let [members (aa/<? (retrieve-presence pool file-id))]
(aa/<? (publish redis file-id {:type :presence :sessions members})))))
(aa/<? (update-presence* cfg))
(let [members (aa/<? (retrieve-presence* cfg))
val {:topic file-id :message {:type :presence :sessions members}}]
(a/<! (msgbus :pub val)))))
(defmethod handle-message :disconnect
[{:keys [profile-id file-id session-id redis pool] :as ws} _message]
[{:keys [file-id msgbus] :as cfg} _message]
;; (log/debugf "profile '%s' is disconnected from '%s'" profile-id file-id)
(aa/go-try
(aa/<? (delete-presence pool file-id session-id profile-id))
(let [members (aa/<? (retrieve-presence pool file-id))]
(aa/<? (publish redis file-id {:type :presence :sessions members})))))
(aa/<? (delete-presence* cfg))
(let [members (aa/<? (retrieve-presence* cfg))
val {:topic file-id :message {:type :presence :sessions members}}]
(a/<! (msgbus :pub val)))))
(defmethod handle-message :keepalive
[{:keys [profile-id file-id session-id pool] :as ws} _message]
(update-presence pool file-id session-id profile-id))
[cfg _message]
(update-presence* cfg))
(defmethod handle-message :pointer-update
[{:keys [profile-id file-id session-id redis] :as ws} message]
[{:keys [profile-id file-id session-id msgbus] :as cfg} message]
(let [message (assoc message
:profile-id profile-id
:session-id session-id)]
(publish redis file-id message)))
(msgbus :pub {:topic file-id
:message message})))
(defmethod handle-message :default
[_ws message]

58
backend/src/app/redis.clj
View file

@ -1,58 +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) 2019 Andrey Antukh <niwi@niwi.nz>
(ns app.redis
(:refer-clojure :exclude [run!])
(:require
[app.common.spec :as us]
[app.util.redis :as redis]
[clojure.spec.alpha :as s]
[integrant.core :as ig])
(:import
java.lang.AutoCloseable))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; State
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod ig/pre-init-spec ::redis [_]
(s/keys :req-un [::uri]))
(defmethod ig/init-key ::redis
[_ cfg]
(let [client (redis/client (:uri cfg "redis://redis/0"))
conn (redis/connect client)]
{::client client
::conn conn}))
(defmethod ig/halt-key! ::redis
[_ {:keys [::client ::conn]}]
(.close ^AutoCloseable conn)
(.close ^AutoCloseable client))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::client some?)
(s/def ::conn some?)
(s/def ::redis (s/keys :req [::client ::conn]))
(defn subscribe
[client opts]
(us/assert ::redis client)
(redis/subscribe (::client client) opts))
(defn run!
[client cmd params]
(us/assert ::redis client)
(redis/run! (::conn client) cmd params))
(defn run
[client cmd params]
(us/assert ::redis client)
(redis/run (::conn client) cmd params))

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

@ -25,6 +25,11 @@
[_]
(ex/raise :type :not-found))
(defn- run-hook
[hook-fn response]
(ex/ignoring (hook-fn))
response)
(defn- rpc-query-handler
[methods {:keys [profile-id] :as request}]
(let [type (keyword (get-in request [:path-params :type]))
@ -50,7 +55,11 @@
result ((get methods type default-handler) data)
mdata (meta result)]
(cond->> {:status 200 :body result}
(fn? (:transform-response mdata)) ((:transform-response mdata) request))))
(fn? (:transform-response mdata))
((:transform-response mdata) request)
(fn? (:before-complete mdata))
(run-hook (:before-complete mdata)))))
(defn- wrap-with-metrics
[cfg f mdata]
@ -66,7 +75,7 @@
(ex/raise :type :internal
:code :rlimit-not-configured
:hint (str/fmt "%s rlimit not configured" key)))
(log/tracef "Adding rlimit to '%s' rpc handler." (::sv/name mdata))
(log/tracef "adding rlimit to '%s' rpc handler" (::sv/name mdata))
(fn [cfg params]
(rlm/execute rlinst (f cfg params))))
f))
@ -76,7 +85,7 @@
(let [f (wrap-with-rlimits cfg f mdata)
f (wrap-with-metrics cfg f mdata)
spec (or (::sv/spec mdata) (s/spec any?))]
(log/tracef "Registering '%s' command to rpc service." (::sv/name mdata))
(log/tracef "registering '%s' command to rpc service" (::sv/name mdata))
(fn [params]
(when (and (:auth mdata true) (not (uuid? (:profile-id params))))
(ex/raise :type :authentication
@ -96,7 +105,7 @@
{:name "rpc_query_timing"
:labels ["name"]
:registry (get-in cfg [:metrics :registry])
:type :summary
:type :histogram
:help "Timing of query services."})
cfg (assoc cfg ::mobj mobj)]
(->> (sv/scan-ns 'app.rpc.queries.projects
@ -115,7 +124,7 @@
{:name "rpc_mutation_timing"
:labels ["name"]
:registry (get-in cfg [:metrics :registry])
:type :summary
:type :histogram
:help "Timing of mutation services."})
cfg (assoc cfg ::mobj mobj)]
(->> (sv/scan-ns 'app.rpc.mutations.demo
@ -126,7 +135,7 @@
'app.rpc.mutations.projects
'app.rpc.mutations.viewer
'app.rpc.mutations.teams
'app.rpc.mutations.feedback
'app.rpc.mutations.ldap
'app.rpc.mutations.verify-token)
(map (partial process-method cfg))
(into {}))))

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

@ -5,7 +5,7 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.rpc.mutations.demo
"A demo specific mutations."
@ -14,8 +14,8 @@
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.db.profile-initial-data :refer [create-profile-initial-data]]
[app.rpc.mutations.profile :as profile]
[app.setup.initial-data :as sid]
[app.tasks :as tasks]
[app.util.services :as sv]
[buddy.core.codecs :as bc]
@ -36,7 +36,7 @@
params {:id id
:email email
:fullname fullname
:demo? true
:is-demo true
:password password
:props {:onboarding-viewed true}}]
@ -48,7 +48,7 @@
(db/with-atomic [conn pool]
(->> (#'profile/create-profile conn params)
(#'profile/create-profile-relations conn)
(create-profile-initial-data conn))
(sid/load-initial-project! conn))
;; Schedule deletion of the demo profile
(tasks/submit! conn {:name "delete-profile"

41
backend/src/app/rpc/mutations/feedback.clj
View file

@ -1,41 +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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2021 UXBOX Labs SL
(ns app.rpc.mutations.feedback
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.config :as cfg]
[app.db :as db]
[app.emails :as emails]
[app.rpc.queries.profile :as profile]
[app.util.services :as sv]
[clojure.spec.alpha :as s]))
(s/def ::subject ::us/string)
(s/def ::content ::us/string)
(s/def ::send-profile-feedback
(s/keys :req-un [::profile-id ::subject ::content]))
(sv/defmethod ::send-profile-feedback
[{:keys [pool] :as cfg} {:keys [profile-id subject content] :as params}]
(when-not (:feedback-enabled cfg/config)
(ex/raise :type :validation
:code :feedback-disabled
:hint "feedback module is disabled"))
(db/with-atomic [conn pool]
(let [profile (profile/retrieve-profile-data conn profile-id)]
(emails/send! conn emails/feedback
{:to (:feedback-destination cfg/config)
:profile profile
:subject subject
:content content})
nil)))

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

@ -16,14 +16,12 @@
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.redis :as rd]
[app.rpc.queries.files :as files]
[app.rpc.queries.projects :as proj]
[app.tasks :as tasks]
[app.util.blob :as blob]
[app.util.services :as sv]
[app.util.time :as dt]
[app.util.transit :as t]
[clojure.spec.alpha :as s]))
;; --- Helpers & Specs
@ -157,6 +155,7 @@
:hint "A file cannot be linked to itself"))
(db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id file-id)
(files/check-edition-permissions! conn profile-id library-id)
(link-file-to-library conn params)))
(def sql:link-file-to-library
@ -252,19 +251,22 @@
:reg-objects :mov-objects} (:type change))
(some? (:component-id change)))))
(declare update-file)
(declare retrieve-lagged-changes)
(declare insert-change)
(declare retrieve-lagged-changes)
(declare retrieve-team-id)
(declare send-notifications)
(declare update-file)
(sv/defmethod ::update-file
[{:keys [pool] :as cfg} {:keys [id profile-id] :as params}]
(db/with-atomic [conn pool]
(let [{:keys [id] :as file} (db/get-by-id conn :file id {:for-update true})]
(files/check-edition-permissions! conn profile-id id)
(update-file (assoc cfg :conn conn) file params))))
(update-file (assoc cfg :conn conn)
(assoc params :file file)))))
(defn- update-file
[{:keys [conn redis]} file params]
[{:keys [conn] :as cfg} {:keys [file changes session-id profile-id] :as params}]
(when (> (:revn params)
(:revn file))
(ex/raise :type :validation
@ -272,64 +274,70 @@
:hint "The incoming revision number is greater that stored version."
:context {:incoming-revn (:revn params)
:stored-revn (:revn file)}))
(let [sid (:session-id params)
changes (:changes params)
file (-> file
(update :data blob/decode)
(update :data assoc :id (:id file))
(update :data pmg/migrate-data)
(update :data cp/process-changes changes)
(update :data blob/encode)
(update :revn inc)
(assoc :changes (blob/encode changes)
:session-id sid))
_ (insert-change conn file)
msg {:type :file-change
:profile-id (:profile-id params)
:file-id (:id file)
:session-id sid
:revn (:revn file)
:changes changes}
library-changes (filter library-change? changes)]
@(rd/run! redis :publish {:channel (str (:id file))
:message (t/encode-str msg)})
(when (and (:is-shared file) (seq library-changes))
(let [{:keys [team-id] :as project}
(db/get-by-id conn :project (:project-id file))
msg {:type :library-change
:profile-id (:profile-id params)
(let [file (-> file
(update :revn inc)
(update :data (fn [data]
(-> data
(blob/decode)
(assoc :id (:id file))
(pmg/migrate-data)
(cp/process-changes changes)
(blob/encode)))))]
;; Insert change to the xlog
(db/insert! conn :file-change
{:id (uuid/next)
:session-id session-id
:profile-id profile-id
:file-id (:id file)
:session-id sid
:revn (:revn file)
:modified-at (dt/now)
:changes library-changes}]
@(rd/run! redis :publish {:channel (str team-id)
:message (t/encode-str msg)})))
:data (:data file)
:changes (blob/encode changes)})
;; Update file
(db/update! conn :file
{:revn (:revn file)
:data (:data file)}
:data (:data file)
:has-media-trimmed false}
{:id (:id file)})
(retrieve-lagged-changes conn params)))
(let [params (assoc params :file file)]
;; Send asynchronous notifications
(send-notifications cfg params)
(defn- insert-change
[conn {:keys [revn data changes session-id] :as file}]
(let [id (uuid/next)
file-id (:id file)]
(db/insert! conn :file-change
{:id id
:session-id session-id
:file-id file-id
:revn revn
:data data
:changes changes})))
;; Retrieve and return lagged data
(retrieve-lagged-changes conn params))))
(defn- send-notifications
[{:keys [msgbus conn] :as cfg} {:keys [file changes session-id] :as params}]
(let [lchanges (filter library-change? changes)]
;; Asynchronously publish message to the msgbus
(msgbus :pub {:topic (:id file)
:message
{:type :file-change
:profile-id (:profile-id params)
:file-id (:id file)
:session-id (:session-id params)
:revn (:revn file)
:changes changes}})
(when (and (:is-shared file) (seq lchanges))
(let [team-id (retrieve-team-id conn (:project-id file))]
;; Asynchronously publish message to the msgbus
(msgbus :pub {:topic team-id
:message
{:type :library-change
:profile-id (:profile-id params)
:file-id (:id file)
:session-id session-id
:revn (:revn file)
:modified-at (dt/now)
:changes lchanges}})))))
(defn- retrieve-team-id
[conn project-id]
(:team-id (db/get-by-id conn :project project-id {:columns [:team-id]})))
(def ^:private
sql:lagged-changes

105
backend/src/app/rpc/mutations/ldap.clj Normal file
View file

@ -0,0 +1,105 @@
;; 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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.rpc.mutations.ldap
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.config :as cfg]
[app.rpc.mutations.profile :refer [login-or-register]]
[app.util.services :as sv]
[clj-ldap.client :as ldap]
[clojure.spec.alpha :as s]
[clojure.string]
[clojure.tools.logging :as log]))
(def cpool
(delay
(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
(log/errorf e "cannot connect to LDAP %s:%s"
(get-in params [:host :address])
(get-in params [:host :port])))))))
;; --- Mutation: login-with-ldap
(declare authenticate)
(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 :rlimit :password}
[{:keys [pool session tokens] :as cfg} {:keys [email password invitation-token] :as params}]
(when-not @cpool
(ex/raise :type :restriction
:code :ldap-disabled
:hint "ldap disabled or unable to connect"))
(let [info (authenticate @cpool params)
cfg (assoc cfg :conn pool)]
(when-not info
(ex/raise :type :validation
:code :wrong-credentials))
(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))}))
(with-meta profile
{:transform-response ((:create session) (: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
[cpool {:keys [password] :as params}]
(when-let [{:keys [dn] :as luser} (get-ldap-user cpool params)]
(when (ldap/bind? cpool dn password)
{:photo (get luser (keyword (cfg/get :ldap-attrs-photo)))
:fullname (get luser (keyword (cfg/get :ldap-attrs-fullname)))
:email (get luser (keyword (cfg/get :ldap-attrs-email)))
:backend "ldap"})))

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

@ -14,28 +14,25 @@
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.db.profile-initial-data :refer [create-profile-initial-data]]
[app.emails :as emails]
[app.http.session :as session]
[app.media :as media]
[app.rpc.mutations.projects :as projects]
[app.rpc.mutations.teams :as teams]
[app.rpc.mutations.verify-token :refer [process-token]]
[app.rpc.queries.profile :as profile]
[app.setup.initial-data :as sid]
[app.storage :as sto]
[app.tasks :as tasks]
[app.util.services :as sv]
[app.util.time :as dt]
[buddy.hashers :as hashers]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[cuerdas.core :as str]))
;; --- Helpers & Specs
(s/def ::email ::us/email)
(s/def ::fullname ::us/not-empty-string)
(s/def ::lang ::us/not-empty-string)
(s/def ::lang (s/nilable ::us/not-empty-string))
(s/def ::path ::us/string)
(s/def ::profile-id ::us/uuid)
(s/def ::password ::us/not-empty-string)
@ -44,79 +41,88 @@
;; --- Mutation: Register Profile
(declare annotate-profile-register)
(declare check-profile-existence!)
(declare create-profile)
(declare create-profile-relations)
(declare email-domain-in-whitelist?)
(declare register-profile)
(s/def ::token ::us/not-empty-string)
(s/def ::invitation-token ::us/not-empty-string)
(s/def ::register-profile
(s/keys :req-un [::email ::password ::fullname]
:opt-un [::token]))
:opt-un [::invitation-token]))
(sv/defmethod ::register-profile {:auth false :rlimit :password}
[{:keys [pool tokens session] :as cfg} {:keys [token] :as params}]
(when-not (:registration-enabled cfg/config)
[{:keys [pool tokens session] :as cfg} params]
(when-not (cfg/get :registration-enabled)
(ex/raise :type :restriction
:code :registration-disabled))
(when-not (email-domain-in-whitelist? (:registration-domain-whitelist cfg/config)
(:email params))
(when-not (email-domain-in-whitelist? (cfg/get :registration-domain-whitelist) (:email params))
(ex/raise :type :validation
:code :email-domain-is-not-allowed))
(db/with-atomic [conn pool]
(check-profile-existence! conn params)
(let [profile (->> (create-profile conn params)
(create-profile-relations conn))]
(create-profile-initial-data conn profile)
(let [cfg (assoc cfg :conn conn)]
(register-profile cfg params))))
(if token
;; If token comes in params, this is because the user comes
;; from team-invitation process; in this case we revalidate
;; the token and process the token claims again with the new
;; profile data.
(let [claims (tokens :verify {:token token :iss :team-invitation})
claims (assoc claims :member-id (:id profile))
params (assoc params :profile-id (:id profile))
cfg (assoc cfg :conn conn)]
(defn- annotate-profile-register
"A helper for properly increase the profile-register metric once the
transaction is completed."
[metrics profile]
(fn []
(when (::created profile)
((get-in metrics [:definitions :profile-register]) :inc))))
(process-token cfg params claims)
(defn- register-profile
[{:keys [conn tokens session metrics] :as cfg} params]
(check-profile-existence! conn params)
(let [profile (->> (create-profile conn params)
(create-profile-relations conn))
profile (assoc profile ::created true)]
;; Automatically mark the created profile as active because
;; we already have the verification of email with the
;; team-invitation token.
(db/update! conn :profile
{:is-active true}
{:id (:id profile)})
(sid/load-initial-project! conn profile)
;; Return profile data and create http session for
;; automatically login the profile.
(with-meta (assoc profile
:is-active true
:claims claims)
{:transform-response
(fn [request response]
(let [uagent (get-in request [:headers "user-agent"])
id (session/create! session {:profile-id (:id profile)
:user-agent uagent})]
(assoc response
:cookies (session/cookies session {:value id}))))}))
(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)
resp {:invitation-token token}]
(with-meta resp
{:transform-response ((:create session) (:id profile))
:before-complete (annotate-profile-register metrics profile)}))
;; If no token is provided, send a verification email
(let [token (tokens :generate
{:iss :verify-email
:exp (dt/in-future "48h")
:profile-id (:id profile)
:email (:email profile)})]
;; If no token is provided, send a verification email
(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)})]
(emails/send! conn emails/register
{:to (:email profile)
:name (:fullname profile)
:token token})
profile)))))
;; Don't allow proceed in register page if the email is
;; already reported as permanent bounced
(when (emails/has-bounce-reports? conn (:email profile))
(ex/raise :type :validation
:code :email-has-permanent-bounces
:hint "looks like the email has one or many bounces reported"))
(emails/send! conn emails/register
{:to (:email profile)
:name (:fullname profile)
:token vtoken
:extra-data ptoken})
(with-meta profile
{:before-complete (annotate-profile-register metrics profile)})))))
(defn email-domain-in-whitelist?
"Returns true if email's domain is in the given whitelist or if given
@ -154,31 +160,30 @@
[attempt password]
(try
(hashers/verify attempt password)
(catch Exception e
(log/warnf e "Error on verify password (only informative, nothing affected to user).")
(catch Exception _e
{:update false
:valid false})))
(defn- create-profile
(defn create-profile
"Create the profile entry on the database with limited input
filling all the other fields with defaults."
[conn {:keys [id fullname email password demo? props is-active]
:or {is-active false}
:as params}]
(let [id (or id (uuid/next))
demo? (if (boolean? demo?) demo? false)
active? (if demo? true is-active)
props (db/tjson (or props {}))
password (derive-password password)]
[conn {:keys [id fullname email password props is-active is-muted is-demo opts]
:or {is-active false is-muted false is-demo false}}]
(let [id (or id (uuid/next))
is-active (if is-demo true is-active)
props (db/tjson (or props {}))
password (derive-password password)
params {:id id
:fullname fullname
:email (str/lower email)
:auth-backend "penpot"
:password password
:props props
:is-active is-active
:is-muted is-muted
:is-demo is-demo}]
(try
(-> (db/insert! conn :profile
{:id id
:fullname fullname
:email (str/lower email)
:password password
:props props
:is-active active?
:is-demo demo?})
(-> (db/insert! conn :profile params opts)
(update :props db/decode-transit-pgobject))
(catch org.postgresql.util.PSQLException e
(let [state (.getSQLState e)]
@ -189,7 +194,7 @@
:cause e)))))))
(defn- create-profile-relations
(defn create-profile-relations
[conn profile]
(let [team (teams/create-team conn {:profile-id (:id profile)
:name "Default"
@ -214,10 +219,10 @@
(s/def ::login
(s/keys :req-un [::email ::password]
:opt-un [::scope]))
:opt-un [::scope ::invitation-token]))
(sv/defmethod ::login {:auth false :rlimit :password}
[{:keys [pool] :as cfg} {:keys [email password scope] :as params}]
[{:keys [pool session tokens] :as cfg} {:keys [email password scope] :as params}]
(letfn [(check-password [profile password]
(when (= (:password profile) "!")
(ex/raise :type :validation
@ -237,29 +242,63 @@
profile)]
(db/with-atomic [conn pool]
(let [prof (-> (profile/retrieve-profile-data-by-email conn email)
(validate-profile)
(profile/strip-private-attrs))
addt (profile/retrieve-additional-data conn (:id prof))]
(merge prof addt)))))
(let [profile (->> (profile/retrieve-profile-data-by-email conn email)
(validate-profile)
(profile/strip-private-attrs)
(profile/populate-additional-data conn))]
(if-let [token (:invitation-token params)]
;; If the request comes with an invitation token, this means
;; that user wants to accept it with different user. A very
;; strange case but still can happen. In this case, we
;; proceed in the same way as in register: regenerate the
;; invitation token and return it to the user for proper
;; invitation acceptation.
(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))}))
(with-meta profile
{:transform-response ((:create session) (:id profile))}))))))
;; --- Mutation: Logout
(s/def ::logout
(s/keys :req-un [::profile-id]))
(sv/defmethod ::logout
[{:keys [pool session] :as cfg} {:keys [profile-id] :as params}]
(with-meta {}
{:transform-response (:delete session)}))
;; --- Mutation: Register if not exists
(declare login-or-register)
(s/def ::backend ::us/string)
(s/def ::login-or-register
(s/keys :req-un [::email ::fullname]))
(s/keys :req-un [::email ::fullname ::backend]))
(sv/defmethod ::login-or-register {:auth false}
[{:keys [pool] :as cfg} {:keys [email fullname] :as params}]
(letfn [(populate-additional-data [conn profile]
(let [data (profile/retrieve-additional-data conn (:id profile))]
(merge profile data)))
[{:keys [pool metrics] :as cfg} params]
(db/with-atomic [conn pool]
(let [profile (-> (assoc cfg :conn conn)
(login-or-register params))]
(with-meta profile
{:before-complete (annotate-profile-register metrics profile)}))))
(create-profile [conn {:keys [fullname email]}]
(defn login-or-register
[{:keys [conn] :as cfg} {:keys [email backend] :as params}]
(letfn [(create-profile [conn {:keys [fullname email]}]
(db/insert! conn :profile
{:id (uuid/next)
:fullname fullname
:email (str/lower email)
:auth-backend backend
:is-active true
:password "!"
:is-demo false}))
@ -267,15 +306,14 @@
(register-profile [conn params]
(let [profile (->> (create-profile conn params)
(create-profile-relations conn))]
(create-profile-initial-data conn profile)
profile))]
(sid/load-initial-project! conn profile)
(assoc profile ::created true)))]
(db/with-atomic [conn pool]
(let [profile (profile/retrieve-profile-data-by-email conn email)
profile (if profile
(populate-additional-data conn profile)
(register-profile conn params))]
(profile/strip-private-attrs profile)))))
(let [profile (profile/retrieve-profile-data-by-email conn email)
profile (if profile
(profile/populate-additional-data conn profile)
(register-profile conn params))]
(profile/strip-private-attrs profile))))
;; --- Mutation: Update Profile (own)
@ -300,12 +338,8 @@
;; --- Mutation: Update Password
(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)))
(ex/raise :type :validation
:code :old-password-not-match))))
(declare validate-password!)
(declare update-profile-password!)
(s/def ::update-profile-password
(s/keys :req-un [::profile-id ::password ::old-password]))
@ -313,12 +347,23 @@
(sv/defmethod ::update-profile-password {:rlimit :password}
[{:keys [pool] :as cfg} {:keys [password profile-id] :as params}]
(db/with-atomic [conn pool]
(validate-password! conn params)
(db/update! conn :profile
{:password (derive-password password)}
{:id profile-id})
nil))
(let [profile (validate-password! conn params)]
(update-profile-password! conn (assoc profile :password password))
nil)))
(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)))
(ex/raise :type :validation
:code :old-password-not-match))
profile))
(defn update-profile-password!
[conn {:keys [id password] :as profile}]
(db/update! conn :profile
{:password (derive-password password)}
{:id id}))
;; --- Mutation: Update Photo
@ -352,31 +397,68 @@
{:id profile-id})
nil)
;; --- Mutation: Request Email Change
(declare request-email-change)
(declare change-email-inmediatelly)
(s/def ::request-email-change
(s/keys :req-un [::email]))
(sv/defmethod ::request-email-change
[{:keys [pool tokens] :as cfg} {:keys [profile-id email] :as params}]
[{:keys [pool] :as cfg} {:keys [profile-id email] :as params}]
(db/with-atomic [conn pool]
(let [email (str/lower email)
profile (db/get-by-id conn :profile profile-id)
token (tokens :generate
{:iss :change-email
:exp (dt/in-future "15m")
:profile-id profile-id
:email email})]
(let [profile (db/get-by-id conn :profile profile-id)
cfg (assoc cfg :conn conn)
params (assoc params
:profile profile
:email (str/lower email))]
(if (cfg/get :smtp-enabled)
(request-email-change cfg params)
(change-email-inmediatelly cfg params)))))
(when (not= email (:email profile))
(check-profile-existence! conn params))
(defn- change-email-inmediatelly
[{:keys [conn]} {:keys [profile email] :as params}]
(when (not= email (:email profile))
(check-profile-existence! conn params))
(db/update! conn :profile
{:email email}
{:id (:id profile)})
{:changed true})
(defn- request-email-change
[{:keys [conn tokens]} {:keys [profile email] :as params}]
(let [token (tokens :generate
{:iss :change-email
:exp (dt/in-future "15m")
:profile-id (:id profile)
:email email})
ptoken (tokens :generate-predefined
{:iss :profile-identity
:profile-id (:id profile)})]
(when (not= email (:email profile))
(check-profile-existence! conn params))
(when-not (emails/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 (emails/has-bounce-reports? conn email)
(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"))
(emails/send! conn emails/change-email
{:to (:email profile)
:name (:fullname profile)
:pending-email email
:token token
:extra-data ptoken})
nil))
(emails/send! conn emails/change-email
{:to (:email profile)
:name (:fullname profile)
:pending-email email
:token token})
nil)))
(defn select-profile-for-update
[conn id]
@ -397,18 +479,33 @@
(assoc profile :token token)))
(send-email-notification [conn profile]
(emails/send! conn emails/password-recovery
{:to (:email profile)
:token (:token profile)
:name (:fullname profile)})
nil)]
(let [ptoken (tokens :generate-predefined
{:iss :profile-identity
:profile-id (:id profile)})]
(emails/send! conn emails/password-recovery
{: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 (emails/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 (emails/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))))))
@ -480,11 +577,7 @@
{:id profile-id})
(with-meta {}
{:transform-response
(fn [request response]
(session/delete! session request)
(assoc response
:cookies (session/cookies session {:value "" :max-age -1})))})))
{:transform-response (:delete session)})))
(def sql:owned-teams
"with owner_teams as (

11
backend/src/app/rpc/mutations/projects.clj
View file

@ -14,6 +14,7 @@
[app.config :as cfg]
[app.db :as db]
[app.rpc.queries.projects :as proj]
[app.rpc.queries.teams :as teams]
[app.tasks :as tasks]
[app.util.services :as sv]
[app.util.time :as dt]
@ -38,13 +39,14 @@
:opt-un [::id]))
(sv/defmethod ::create-project
[{:keys [pool] :as cfg} params]
[{:keys [pool] :as cfg} {:keys [profile-id team-id] :as params}]
(db/with-atomic [conn pool]
(let [proj (create-project conn params)
params (assoc params :project-id (:id proj))]
(teams/check-edition-permissions! conn profile-id team-id)
(let [project (create-project conn params)
params (assoc params :project-id (:id project))]
(create-project-profile conn params)
(create-team-project-profile conn params)
(assoc proj :is-pinned true))))
(assoc project :is-pinned true))))
(defn create-project
[conn {:keys [id team-id name default?] :as params}]
@ -92,6 +94,7 @@
(sv/defmethod ::update-project-pin
[{:keys [pool] :as cfg} {:keys [id profile-id team-id is-pinned] :as params}]
(db/with-atomic [conn pool]
(proj/check-edition-permissions! conn profile-id id)
(db/exec-one! conn [sql:update-project-pin team-id id profile-id is-pinned is-pinned])
nil))

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

@ -146,7 +146,7 @@
nil)))
;; --- Mutation: Tean Update Role
;; --- Mutation: Team Update Role
(declare retrieve-team-member)
(declare role->params)
@ -218,7 +218,7 @@
:viewer {:is-owner false :is-admin false :can-edit false}))
;; --- Mutation: Team Update Role
;; --- Mutation: Delete Team Member
(s/def ::delete-team-member
(s/keys :req-un [::profile-id ::team-id ::member-id]))
@ -227,8 +227,8 @@
[{:keys [pool] :as cfg} {:keys [team-id profile-id member-id] :as params}]
(db/with-atomic [conn pool]
(let [perms (teams/check-read-permissions! conn profile-id team-id)]
(when-not (or (:is-owner perms)
(:is-admin perms))
(when-not (or (some :is-owner perms)
(some :is-admin perms))
(ex/raise :type :validation
:code :insufficient-permissions))
@ -297,26 +297,48 @@
(sv/defmethod ::invite-team-member
[{:keys [pool tokens] :as cfg} {:keys [profile-id team-id email role] :as params}]
(db/with-atomic [conn pool]
(let [perms (teams/check-edition-permissions! conn profile-id team-id)
profile (db/get-by-id conn :profile profile-id)
member (profile/retrieve-profile-data-by-email conn email)
team (db/get-by-id conn :team team-id)
token (tokens :generate
{:iss :team-invitation
:exp (dt/in-future "24h")
:profile-id (:id profile)
:role role
:team-id team-id
:member-email (:email member email)
:member-id (:id member)})]
(let [perms (teams/check-edition-permissions! conn profile-id team-id)
profile (db/get-by-id conn :profile profile-id)
member (profile/retrieve-profile-data-by-email conn email)
team (db/get-by-id conn :team team-id)
itoken (tokens :generate
{:iss :team-invitation
:exp (dt/in-future "6h")
:profile-id (:id profile)
:role role
:team-id team-id
:member-email (:email member email)
:member-id (:id member)})
ptoken (tokens :generate-predefined
{:iss :profile-identity
:profile-id (:id profile)})]
(when-not (some :is-admin perms)
(ex/raise :type :validation
:code :insufficient-permissions))
;; First check if the current profile is allowed to send emails.
(when-not (emails/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 (and member (not (emails/allow-send-emails? conn member)))
(ex/raise :type :validation
:code :member-is-muted
:hint "looks like the profile has reported repeatedly as spam or has permanent bounces"))
;; Secondly check if the invited member email is part of the
;; global spam/bounce report.
(when (emails/has-bounce-reports? conn email)
(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"))
(emails/send! conn emails/invite-to-team
{:to email
:invited-by (:fullname profile)
:team (:name team)
:token token})
:token itoken
:extra-data ptoken})
nil)))

111
backend/src/app/rpc/mutations/verify_token.clj
View file

@ -5,14 +5,13 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.rpc.mutations.verify-token
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.db :as db]
[app.http.session :as session]
[app.rpc.mutations.teams :as teams]
[app.rpc.queries.profile :as profile]
[app.util.services :as sv]
@ -41,8 +40,15 @@
{:id profile-id})
claims)
(defn- annotate-profile-activation
"A helper for properly increase the profile-activation metric once the
transaction is completed."
[metrics]
(fn []
((get-in metrics [:definitions :profile-activation]) :inc)))
(defmethod process-token :verify-email
[{:keys [conn session] :as cfg} _params {:keys [profile-id] :as claims}]
[{:keys [conn session metrics] :as cfg} _ {:keys [profile-id] :as claims}]
(let [profile (profile/retrieve-profile conn profile-id)
claims (assoc claims :profile profile)]
@ -57,14 +63,8 @@
{:id (:id profile)}))
(with-meta claims
{:transform-response
(fn [request response]
(let [uagent (get-in request [:headers "user-agent"])
id (session/create! session {:profile-id profile-id
:user-agent uagent})]
(assoc response
:cookies (session/cookies session {:value id}))))})))
{:transform-response ((:create session) profile-id)
:before-complete (annotate-profile-activation metrics)})))
(defmethod process-token :auth
[{:keys [conn] :as cfg} _params {:keys [profile-id] :as claims}]
@ -91,47 +91,78 @@
:internal.tokens.team-invitation/member-email]
:opt-un [:internal.tokens.team-invitation/member-id]))
(defn- accept-invitation
[{:keys [conn] :as cfg} {:keys [member-id team-id role] :as claims}]
(let [params (merge {:team-id team-id
:profile-id member-id}
(teams/role->params role))
member (profile/retrieve-profile conn member-id)]
;; Insert the invited member to the team
(db/insert! conn :team-profile-rel params {:on-conflict-do-nothing true})
;; If profile is not yet verified, mark it as verified because
;; accepting an invitation link serves as verification.
(when-not (:is-active member)
(db/update! conn :profile
{:is-active true}
{:id member-id}))
(assoc member :is-active true)))
(defmethod process-token :team-invitation
[{:keys [conn session] :as cfg} {:keys [profile-id token]} {:keys [member-id team-id role] :as claims}]
[{:keys [session] :as cfg} {:keys [profile-id token]} {:keys [member-id] :as claims}]
(us/assert ::team-invitation-claims claims)
(if (uuid? member-id)
(let [params (merge {:team-id team-id
:profile-id member-id}
(teams/role->params role))
claims (assoc claims :state :created)]
(db/insert! conn :team-profile-rel params
{:on-conflict-do-nothing true})
(if (and (uuid? profile-id)
(= member-id profile-id))
(cond
;; This happens when token is filled with member-id and current
;; user is already logged in with some account.
(and (uuid? profile-id)
(uuid? member-id))
(do
(accept-invitation cfg claims)
(if (= member-id profile-id)
;; If the current session is already matches the invited
;; member, then just return the token and leave the frontend
;; app redirect to correct team.
claims
(assoc claims :state :created)
;; If the session does not matches the invited member id,
;; replace the session with a new one matching the invited
;; member. This techinique should be considered secure because
;; the user clicking the link he already has access to the
;; email account.
(with-meta claims
{:transform-response
(fn [request response]
(let [uagent (get-in request [:headers "user-agent"])
id (session/create! session {:profile-id member-id
:user-agent uagent})]
(assoc response
:cookies (session/cookies session {:value id}))))})))
;; If the session does not matches the invited member, replace
;; the session with a new one matching the invited member.
;; This techinique should be considered secure because the
;; user clicking the link he already has access to the email
;; account.
(with-meta
(assoc claims :state :created)
{:transform-response ((:create session) member-id)})))
;; This happens when member-id is not filled in the invitation but
;; the user already has an account (probably with other mail) and
;; is already logged-in.
(and (uuid? profile-id)
(nil? member-id))
(do
(accept-invitation cfg (assoc claims :member-id profile-id))
(assoc claims :state :created))
;; This happens when member-id is filled but the accessing user is
;; not logged-in. In this case we proceed to accept invitation and
;; leave the user logged-in.
(and (nil? profile-id)
(uuid? member-id))
(do
(accept-invitation cfg claims)
(with-meta
(assoc claims :state :created)
{:transform-response ((:create session) member-id)}))
;; In this case, we wait until frontend app redirect user to
;; registeration page, the user is correctly registered and the
;; register mutation call us again with the same token to finally
;; create the corresponding team-profile relation from the first
;; condition of this if.
(assoc claims
:token token
:state :pending)))
:else
{:invitation-token token
:iss :team-invitation
:state :pending}))
;; --- Default

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

@ -256,12 +256,11 @@
;; --- Helpers
(defn decode-row
[{:keys [pages data changes] :as row}]
[{:keys [data changes] :as row}]
(when row
(cond-> row
changes (assoc :changes (blob/decode changes))
data (assoc :data (blob/decode data))
pages (assoc :pages (vec (.getArray pages))))))
data (assoc :data (blob/decode data)))))
(def decode-row-xf
(comp (map decode-row)

25
backend/src/app/rpc/queries/profile.clj
View file

@ -13,6 +13,7 @@
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.db :as db]
[app.db.sql :as sql]
[app.util.services :as sv]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]))
@ -71,6 +72,10 @@
{:default-team-id (:id team)
:default-project-id (:id project)}))
(defn populate-additional-data
[conn profile]
(merge profile (retrieve-additional-data conn (:id profile))))
(defn decode-profile-row
[{:keys [props] :as row}]
(cond-> row
@ -83,27 +88,21 @@
(defn retrieve-profile
[conn id]
(let [profile (some-> (retrieve-profile-data conn id)
(strip-private-attrs)
(merge (retrieve-additional-data conn id)))]
(let [profile (some->> (retrieve-profile-data conn id)
(strip-private-attrs)
(populate-additional-data conn))]
(when (nil? profile)
(ex/raise :type :not-found
:hint "Object doest not exists."))
profile))
(def sql:profile-by-email
"select * from profile
where email=?
and deleted_at is null")
(defn retrieve-profile-data-by-email
[conn email]
(let [email (str/lower email)]
(-> (db/exec-one! conn [sql:profile-by-email email])
(decode-profile-row))))
(let [sql (sql/select :profile {:email (str/lower email)})
data (db/exec-one! conn sql)]
(when (and data (nil? (:deleted-at data)))
(decode-profile-row data))))
;; --- Attrs Helpers

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

@ -41,5 +41,3 @@
(teams/check-read-permissions! conn profile-id team-id)
(let [files (db/exec! conn [sql:recent-files team-id])]
(into [] decode-row-xf files))))

47
backend/src/app/sprops.clj → backend/src/app/setup.clj
View file

@ -7,8 +7,8 @@
;;
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.sprops
"Server props module."
(ns app.setup
"Initial data setup of instance."
(:require
[app.common.uuid :as uuid]
[app.db :as db]
@ -17,42 +17,45 @@
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(declare initialize)
(declare initialize-instance-id!)
(declare initialize-secret-key!)
(declare retrieve-all)
(defmethod ig/pre-init-spec ::props [_]
(s/keys :req-un [::db/pool]))
(defmethod ig/init-key ::props
[_ cfg]
(initialize cfg))
[_ {:keys [pool] :as cfg}]
(db/with-atomic [conn pool]
(let [cfg (assoc cfg :conn conn)]
(initialize-secret-key! cfg)
(initialize-instance-id! cfg)
(retrieve-all cfg))))
(defn- initialize-secret-key
(defn- initialize-secret-key!
[{:keys [conn] :as cfg}]
(let [key (-> (bn/random-bytes 64)
(bc/bytes->b64u)
(bc/bytes->str))]
(db/exec-one! conn ["insert into server_prop (id, content)
values ('secret-key', ?) on conflict do nothing"
(db/tjson key)])))
(db/insert! conn :server-prop
{:id "secret-key"
:preload true
:content (db/tjson key)}
{:on-conflict-do-nothing true})))
(defn- initialize-instance-id
(defn- initialize-instance-id!
[{:keys [conn] :as cfg}]
(let [iid (uuid/random)]
(db/exec-one! conn ["insert into server_prop (id, content)
values ('instance-id', ?::jsonb) on conflict do nothing"
(db/tjson iid)])))
(db/insert! conn :server-prop
{:id "instance-id"
:preload true
:content (db/tjson iid)}
{:on-conflict-do-nothing true})))
(defn- retrieve-all
[{:keys [conn] :as cfg}]
(reduce (fn [acc row]
(assoc acc (keyword (:id row)) (db/decode-transit-pgobject (:content row))))
{}
(db/exec! conn ["select * from server_prop;"])))
(defn- initialize
[{:keys [pool] :as cfg}]
(db/with-atomic [conn pool]
(let [cfg (assoc cfg :conn conn)]
(initialize-secret-key cfg)
(initialize-instance-id cfg)
(retrieve-all cfg))))
(db/query conn :server-prop {:preload true})))

193
backend/src/app/setup/initial_data.clj Normal file
View file

@ -0,0 +1,193 @@
;; 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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2021 UXBOX Labs SL
(ns app.setup.initial-data
(:refer-clojure :exclude [load])
(:require
[app.common.data :as d]
[app.common.pages.migrations :as pmg]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.rpc.mutations.projects :as projects]
[app.rpc.queries.profile :as profile]
[app.util.blob :as blob]
[app.util.time :as dt]
[clojure.walk :as walk]))
;; --- DUMP GENERATION
(def sql:file
"select * from file where project_id = ?")
(def sql:file-library-rel
"with file_ids as (select id from file where project_id = ?)
select *
from file_library_rel
where file_id in (select id from file_ids)")
(def sql:file-media-object
"with file_ids as (select id from file where project_id = ?)
select *
from file_media_object
where file_id in (select id from file_ids)")
(defn dump
([system project-id] (dump system project-id nil))
([system project-id {:keys [skey project-name]
:or {project-name "Penpot Onboarding"}}]
(db/with-atomic [conn (:app.db/pool system)]
(let [skey (or skey (cfg/get :initial-project-skey))
files (db/exec! conn [sql:file project-id])
flibs (db/exec! conn [sql:file-library-rel project-id])
fmeds (db/exec! conn [sql:file-media-object project-id])
data {:project-name project-name
:files files
:flibs flibs
:fmeds fmeds}]
(db/delete! conn :server-prop {:id skey})
(db/insert! conn :server-prop
{:id skey
:preload false
:content (db/tjson data)})
skey))))
;; --- DUMP LOADING
(defn- process-file
[file index]
(letfn [(process-form [form]
(cond-> form
;; Relink Components
(and (map? form)
(uuid? (:component-file form)))
(update :component-file #(get index % %))
;; Relink Image Shapes
(and (map? form)
(map? (:metadata form))
(= :image (:type form)))
(update-in [:metadata :id] #(get index % %))))
;; A function responsible to analize all file data and
;; replace the old :component-file reference with the new
;; ones, using the provided file-index
(relink-shapes [data]
(walk/postwalk process-form data))
;; A function responsible of process the :media attr of file
;; data and remap the old ids with the new ones.
(relink-media [media]
(reduce-kv (fn [res k v]
(let [id (get index k)]
(if (uuid? id)
(-> res
(assoc id (assoc v :id id))
(dissoc k))
res)))
media
media))]
(update file :data
(fn [data]
(-> data
(blob/decode)
(assoc :id (:id file))
(pmg/migrate-data)
(update :pages-index relink-shapes)
(update :components relink-shapes)
(update :media relink-media)
(d/without-nils)
(blob/encode))))))
(defn- remap-id
[item index key]
(cond-> item
(contains? item key)
(assoc key (get index (get item key) (get item key)))))
(defn- retrieve-data
[conn skey]
(when-let [row (db/exec-one! conn ["select content from server_prop where id = ?" skey])]
(when-let [content (:content row)]
(when (db/pgobject? content)
(db/decode-transit-pgobject content)))))
(defn load-initial-project!
([conn profile] (load-initial-project! conn profile nil))
([conn profile opts]
(let [skey (or (:skey opts) (cfg/get :initial-project-skey))
data (retrieve-data conn skey)]
(when data
(let [project (projects/create-project conn {:profile-id (:id profile)
:team-id (:default-team-id profile)
:name (:project-name data)})
now (dt/now)
ignore (dt/plus now (dt/duration {:seconds 5}))
index (as-> {} index
(reduce #(assoc %1 (:id %2) (uuid/next)) index (:files data))
(reduce #(assoc %1 (:id %2) (uuid/next)) index (:fmeds data)))
flibs (->> (:flibs data)
(map #(remap-id % index :file-id))
(map #(remap-id % index :library-file-id))
(map #(assoc % :synced-at now))
(map #(assoc % :created-at now)))
files (->> (:files data)
(map #(assoc % :id (get index (:id %))))
(map #(assoc % :project-id (:id project)))
(map #(assoc % :created-at now))
(map #(assoc % :modified-at now))
(map #(assoc % :ignore-sync-until ignore))
(map #(process-file % index)))
fmeds (->> (:fmeds data)
(map #(assoc % :id (get index (:id %))))
(map #(assoc % :created-at now))
(map #(remap-id % index :file-id)))
fprofs (map #(array-map :file-id (:id %)
:profile-id (:id profile)
:is-owner true
:is-admin true
:can-edit true) files)]
(projects/create-project-profile conn {:project-id (:id project)
:profile-id (:id profile)})
(projects/create-team-project-profile conn {:team-id (:default-team-id profile)
:project-id (:id project)
:profile-id (:id profile)})
;; Re-insert into the database
(doseq [params files]
(db/insert! conn :file params))
(doseq [params fprofs]
(db/insert! conn :file-profile-rel params))
(doseq [params flibs]
(db/insert! conn :file-library-rel params))
(doseq [params fmeds]
(db/insert! conn :file-media-object params)))))))
(defn load
[system {:keys [email] :as opts}]
(db/with-atomic [conn (:app.db/pool system)]
(when-let [profile (some->> email
(profile/retrieve-profile-data-by-email conn)
(profile/populate-additional-data conn))]
(load-initial-project! conn profile opts)
true)))

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

@ -6,7 +6,6 @@
[app.common.pages.migrations :as pmg]
[app.config :as cfg]
[app.db :as db]
[app.db.profile-initial-data :as pid]
[app.main :refer [system]]
[app.rpc.queries.profile :as prof]
[app.srepl.dev :as dev]
@ -53,27 +52,6 @@
;; (fn [{:keys [data] :as file}]
;; (update-in data [:pages-index #uuid "878278c0-3ef0-11eb-9d67-8551e7624f43" :objects] dissoc nil))))
(def default-project-id #uuid "5761a890-3b81-11eb-9e7d-556a2f641513")
(defn initial-data-dump
([system file] (initial-data-dump system default-project-id file))
([system project-id path]
(db/with-atomic [conn (:app.db/pool system)]
(pid/create-initial-data-dump conn project-id path))))
(defn load-data-into-user
([system user-email]
(if-let [file (:initial-data-file cfg/config)]
(load-data-into-user system file user-email)
(prn "Data file not found in configuration")))
([system file user-email]
(db/with-atomic [conn (:app.db/pool system)]
(let [profile (prof/retrieve-profile-data-by-email conn user-email)
profile (merge profile (prof/retrieve-additional-data conn (:id profile)))]
(pid/create-profile-initial-data conn file profile)))))
;; Migrate
(defn update-file-data-blob-format

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

@ -308,7 +308,7 @@
(if-let [[groups total] (retrieve-deleted-objects conn)]
(do
(run! (partial delete-in-bulk conn) groups)
(recur (+ n total)))
(recur (+ n ^long total)))
(do
(log/infof "gc-deleted: processed %s items" n)
{:deleted n})))))))

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

@ -165,7 +165,7 @@
(string->content data)
(bytes? data)
(input-stream->content (ByteArrayInputStream. ^bytes data) (alength data))
(input-stream->content (ByteArrayInputStream. ^bytes data) (alength ^bytes data))
(instance? InputStream data)
(do

2
backend/src/app/svgparse.clj
View file

@ -124,7 +124,7 @@
(try
(with-open [istream (IOUtils/toInputStream data "UTF-8")]
(xml/parse istream))
(catch org.xml.sax.SAXParseException _e
(catch Exception _e
(ex/raise :type :validation
:code :invalid-svg-file))))

75
backend/src/app/tasks.clj
View file

@ -5,17 +5,19 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.tasks
(:require
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.db :as db]
;; [app.metrics :as mtx]
[app.metrics :as mtx]
[app.util.time :as dt]
[app.worker]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]))
[clojure.tools.logging :as log]
[integrant.core :as ig]))
(s/def ::name ::us/string)
(s/def ::delay
@ -41,11 +43,68 @@
interval (db/interval duration)
props (db/tjson props)
id (uuid/next)]
(log/infof "Submit task '%s' to be executed in '%s'." name (str duration))
(log/debugf "submit task '%s' to be executed in '%s'" name (str duration))
(db/exec-one! conn [sql:insert-new-task id name props queue priority max-retries interval])
id))
;; (mtx/instrument-with-counter!
;; {:var #'submit!
;; :id "tasks__submit_counter"
;; :help "Absolute task submit counter."})
(defn- instrument!
[registry]
(mtx/instrument-vars!
[#'submit!]
{:registry registry
:type :counter
:labels ["name"]
:name "tasks_submit_counter"
:help "An absolute counter of task submissions."
:wrap (fn [rootf mobj]
(let [mdata (meta rootf)
origf (::original mdata rootf)]
(with-meta
(fn [conn params]
(let [tname (:name params)]
(mobj :inc [tname])
(origf conn params)))
{::original origf})))})
(mtx/instrument-vars!
[#'app.worker/run-task]
{:registry registry
:type :summary
:quantiles []
:name "tasks_checkout_timing"
:help "Latency measured between scheduld_at and execution time."
:wrap (fn [rootf mobj]
(let [mdata (meta rootf)
origf (::original mdata rootf)]
(with-meta
(fn [tasks item]
(let [now (inst-ms (dt/now))
sat (inst-ms (:scheduled-at item))]
(mobj :observe (- now sat))
(origf tasks item)))
{::original origf})))}))
;; --- STATE INIT: REGISTRY
(s/def ::tasks
(s/map-of keyword? fn?))
(defmethod ig/pre-init-spec ::registry [_]
(s/keys :req-un [::mtx/metrics ::tasks]))
(defmethod ig/init-key ::registry
[_ {:keys [metrics tasks]}]
(instrument! (:registry metrics))
(let [mobj (mtx/create
{:registry (:registry metrics)
:type :summary
:labels ["name"]
:quantiles []
:name "tasks_timing"
:help "Background task execution timing."})]
(reduce-kv (fn [res k v]
(let [tname (name k)]
(log/debugf "registring task '%s'" tname)
(assoc res tname (mtx/wrap-summary v mobj [tname]))))
{}
tasks)))

24
backend/src/app/tasks/delete_object.clj
View file

@ -12,42 +12,32 @@
(:require
[app.common.spec :as us]
[app.db :as db]
[app.metrics :as mtx]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]))
(declare handler)
(declare handle-deletion)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::db/pool ::mtx/metrics]))
(s/keys :req-un [::db/pool]))
(defmethod ig/init-key ::handler
[_ {:keys [metrics] :as cfg}]
(let [handler #(handler cfg %)]
(->> {:registry (:registry metrics)
:type :summary
:name "task_delete_object_timing"
:help "delete object task timing"}
(mtx/instrument handler))))
[_ {:keys [pool] :as cfg}]
(fn [{:keys [props] :as task}]
(us/verify ::props props)
(db/with-atomic [conn pool]
(handle-deletion conn props))))
(s/def ::type ::us/keyword)
(s/def ::id ::us/uuid)
(s/def ::props (s/keys :req-un [::id ::type]))
(defn- handler
[{:keys [pool]} {:keys [props] :as task}]
(us/verify ::props props)
(db/with-atomic [conn pool]
(handle-deletion conn props)))
(defmulti handle-deletion
(fn [_ props] (:type props)))
(defmethod handle-deletion :default
[_conn {:keys [type]}]
(log/warnf "no handler found for %s" type))
(log/warnf "no handler found for '%s'" type))
(defmethod handle-deletion :file
[conn {:keys [id] :as props}]

36
backend/src/app/tasks/delete_profile.clj
View file

@ -13,27 +13,16 @@
[app.common.spec :as us]
[app.db :as db]
[app.db.sql :as sql]
[app.metrics :as mtx]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]))
(declare delete-profile-data)
(declare handler)
;; --- INIT
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::db/pool ::mtx/metrics]))
(defmethod ig/init-key ::handler
[_ {:keys [metrics] :as cfg}]
(let [handler #(handler cfg %)]
(->> {:registry (:registry metrics)
:type :summary
:name "task_delete_profile_timing"
:help "delete profile task timing"}
(mtx/instrument handler))))
(s/keys :req-un [::db/pool]))
;; This task is responsible to permanently delete a profile with all
;; the dependent data. As step (1) we delete all owned teams of the
@ -48,16 +37,17 @@
(s/def ::profile-id ::us/uuid)
(s/def ::props (s/keys :req-un [::profile-id]))
(defn handler
[{:keys [pool]} {:keys [props] :as task}]
(us/verify ::props props)
(db/with-atomic [conn pool]
(let [id (:profile-id props)
profile (db/exec-one! conn (sql/select :profile {:id id} {:for-update true}))]
(if (or (:is-demo profile)
(:deleted-at profile))
(delete-profile-data conn id)
(log/warnf "Profile %s does not match constraints for deletion" id)))))
(defmethod ig/init-key ::handler
[_ {:keys [pool] :as cfg}]
(fn [{:keys [props] :as task}]
(us/verify ::props props)
(db/with-atomic [conn pool]
(let [id (:profile-id props)
profile (db/exec-one! conn (sql/select :profile {:id id} {:for-update true}))]
(if (or (:is-demo profile)
(:deleted-at profile))
(delete-profile-data conn id)
(log/warnf "profile '%s' does not match constraints for deletion" id))))))
;; --- IMPL
@ -80,7 +70,7 @@
(defn- delete-profile-data
[conn profile-id]
(log/infof "Proceding to delete all data related to profile id = %s" profile-id)
(log/debugf "proceding to delete all data related to profile '%s'" profile-id)
(delete-teams conn profile-id)
(delete-profile conn profile-id)
true)

42
backend/src/app/tasks/file_media_gc.clj
View file

@ -5,7 +5,7 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.tasks.file-media-gc
"A maintenance task that is responsible to purge the unused media
@ -14,44 +14,34 @@
(:require
[app.common.pages.migrations :as pmg]
[app.db :as db]
[app.metrics :as mtx]
[app.util.blob :as blob]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]))
(declare handler)
(declare process-file)
(declare retrieve-candidates)
(s/def ::max-age ::dt/duration)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::db/pool ::mtx/metrics ::max-age]))
(s/keys :req-un [::db/pool ::max-age]))
(defmethod ig/init-key ::handler
[_ {:keys [metrics] :as cfg}]
(let [handler #(handler cfg %)]
(->> {:registry (:registry metrics)
:type :summary
:name "task_file_media_gc_timing"
:help "file media garbage collection task timing"}
(mtx/instrument handler))))
(defn- handler
[{:keys [pool] :as cfg} _]
(db/with-atomic [conn pool]
(let [cfg (assoc cfg :conn conn)]
(loop [n 0]
(let [files (retrieve-candidates cfg)]
(if (seq files)
(do
(run! (partial process-file cfg) files)
(recur (+ n (count files))))
(do
(log/infof "finalized with total of %s processed files" n)
{:processed n})))))))
[_ {:keys [pool] :as cfg}]
(fn [_]
(db/with-atomic [conn pool]
(let [cfg (assoc cfg :conn conn)]
(loop [n 0]
(let [files (retrieve-candidates cfg)]
(if (seq files)
(do
(run! (partial process-file cfg) files)
(recur (+ n (count files))))
(do
(log/debugf "finalized with total of %s processed files" n)
{:processed n}))))))))
(def ^:private
sql:retrieve-candidates-chunk
@ -98,7 +88,7 @@
unused (->> (db/query conn :file-media-object {:file-id id})
(remove #(contains? used (:id %))))]
(log/infof "processing file: id='%s' age='%s' to-delete=%s" id age (count unused))
(log/debugf "processing file: id='%s' age='%s' to-delete=%s" id age (count unused))
;; Mark file as trimmed
(db/update! conn :file

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

@ -5,45 +5,36 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.tasks.file-xlog-gc
"A maintenance task that performs a garbage collection of the file
change (transaction) log."
(:require
[app.db :as db]
[app.metrics :as mtx]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]))
(declare handler)
(declare sql:delete-files-xlog)
(s/def ::max-age ::dt/duration)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::db/pool ::mtx/metrics ::max-age]))
(s/keys :req-un [::db/pool ::max-age]))
(defmethod ig/init-key ::handler
[_ {:keys [metrics] :as cfg}]
(let [handler #(handler cfg %)]
(->> {:registry (:registry metrics)
:type :summary
:name "task_file_xlog_gc_timing"
:help "file changes garbage collection task timing"}
(mtx/instrument 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)]
(log/debugf "removed %s rows from file-change table" result)
result))))
(def ^:private
sql:delete-files-xlog
"delete from file_change
where created_at < now() - ?::interval")
(defn- handler
[{:keys [pool max-age]} _]
(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)]
(log/infof "removed %s rows from file_change table" result)
nil)))

23
backend/src/app/tasks/sendmail.clj
View file

@ -10,13 +10,12 @@
(ns app.tasks.sendmail
(:require
[app.config :as cfg]
[app.metrics :as mtx]
[app.util.emails :as emails]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]))
(declare handler)
(declare send-console!)
(s/def ::username ::cfg/smtp-username)
(s/def ::password ::cfg/smtp-password)
@ -29,7 +28,7 @@
(s/def ::enabled ::cfg/smtp-enabled)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::enabled ::mtx/metrics]
(s/keys :req-un [::enabled]
:opt-un [::username
::password
::tls
@ -40,13 +39,11 @@
::default-reply-to]))
(defmethod ig/init-key ::handler
[_ {:keys [metrics] :as cfg}]
(let [handler #(handler cfg %)]
(->> {:registry (:registry metrics)
:type :summary
:name "task_sendmail_timing"
:help "sendmail task timing"}
(mtx/instrument handler))))
[_ cfg]
(fn [{:keys [props] :as task}]
(if (:enabled cfg)
(emails/send! cfg props)
(send-console! cfg props))))
(defn- send-console!
[cfg email]
@ -59,9 +56,3 @@
(println (.toString baos))
(println "******** end email "(:id email) "**********"))]
(log/info out))))
(defn handler
[cfg {:keys [props] :as task}]
(if (:enabled cfg)
(emails/send! cfg props)
(send-console! cfg props)))

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

@ -5,46 +5,36 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
;; Copyright (c) 2020-2021 UXBOX Labs SL
(ns app.tasks.tasks-gc
"A maintenance task that performs a cleanup of already executed tasks
from the database table."
(:require
[app.db :as db]
[app.metrics :as mtx]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[integrant.core :as ig]))
(declare handler)
(declare sql:delete-completed-tasks)
(s/def ::max-age ::dt/duration)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::db/pool ::mtx/metrics ::max-age]))
(s/keys :req-un [::db/pool ::max-age]))
(defmethod ig/init-key ::handler
[_ {:keys [metrics] :as cfg}]
(let [handler #(handler cfg %)]
(->> {:registry (:registry metrics)
:type :summary
:name "task_tasks_gc_timing"
:help "tasks garbage collection task timing"}
(mtx/instrument 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)]
(log/debugf "removed %s rows from tasks-completed table" result)
result))))
(def ^:private
sql:delete-completed-tasks
"delete from task_completed
where scheduled_at < now() - ?::interval")
(defn- handler
[{:keys [pool max-age]} _]
(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)]
(log/infof "removed %s rows from tasks_completed table" result)
nil)))

4
backend/src/app/telemetry.clj
View file

@ -88,7 +88,7 @@
(catch Exception e
;; We don't want notify user of a error, just log it for posible
;; future investigation.
(log/warn e (str "Unexpected error on telemetry:\n"
(log/warn e (str "unexpected error on telemetry:\n"
(when-let [edata (ex-data e)]
(str "ex-data: \n"
(with-out-str (pprint edata))))
@ -118,4 +118,4 @@
data
data])))
(catch Exception e
(log/errorf e "Error on procesing request."))))
(log/errorf e "error on procesing request"))))

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

@ -60,11 +60,25 @@
(defmethod ig/pre-init-spec ::tokens [_]
(s/keys :req-un [::sprops]))
(defn- generate-predefined
[cfg {:keys [iss profile-id] :as params}]
(case iss
:profile-identity
(do
(us/verify uuid? profile-id)
(generate cfg (assoc params
:exp (dt/in-future {:days 30}))))
(ex/raise :type :internal
:code :not-implemented
:hint "no predefined token")))
(defmethod ig/init-key ::tokens
[_ {:keys [sprops] :as cfg}]
(let [secret (derive-tokens-secret (:secret-key sprops))
cfg (assoc cfg ::secret secret)]
(fn [action params]
(case action
:generate-predefined (generate-predefined cfg params)
:verify (verify cfg params)
:generate (generate cfg params)))))

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

@ -46,8 +46,7 @@
(fn []
(try
(let [ret (try (f) (catch Exception e e))]
(when-not (nil? ret)
(a/>!! c ret)))
(when (some? ret) (a/>!! c ret)))
(finally
(a/close! c)))))
c

4
backend/src/app/util/blob.clj
View file

@ -37,7 +37,7 @@
(defn encode
([data] (encode data nil))
([data {:keys [version] :or {version default-version}}]
(case version
(case (long version)
1 (encode-v1 data)
2 (encode-v2 data)
(throw (ex-info "unsupported version" {:version version})))))
@ -81,7 +81,7 @@
(defn- encode-v2
[data]
(let [data (n/fast-freeze data)
dlen (alength data)
dlen (alength ^bytes data)
mlen (Zstd/compressBound dlen)
cdata (byte-array mlen)
clen (Zstd/compressByteArray ^bytes cdata 0 mlen

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

@ -161,7 +161,7 @@
(.setDebug session debug)
session))
(defn smtp-message
(defn ^MimeMessage smtp-message
[cfg message]
(let [^Session session (smtp-session cfg)]
(build-message cfg session message)))

8
backend/src/app/util/json.clj
View file

@ -16,10 +16,18 @@
[v]
(j/write-value-as-string v j/keyword-keys-object-mapper))
(defn encode
[v]
(j/write-value-as-bytes v j/keyword-keys-object-mapper))
(defn decode-str
[v]
(j/read-value v j/keyword-keys-object-mapper))
(defn decode
[v]
(j/read-value v j/keyword-keys-object-mapper))
(defn read
[v]
(j/read-value v j/keyword-keys-object-mapper))

166
backend/src/app/util/redis.clj
View file

@ -1,166 +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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.util.redis
"Asynchronous posgresql client."
(:refer-clojure :exclude [run!])
(:require
[clojure.core.async :as a]
[promesa.core :as p])
(:import
io.lettuce.core.RedisClient
io.lettuce.core.RedisURI
io.lettuce.core.codec.StringCodec
io.lettuce.core.api.async.RedisAsyncCommands
io.lettuce.core.api.StatefulRedisConnection
io.lettuce.core.pubsub.RedisPubSubListener
io.lettuce.core.pubsub.StatefulRedisPubSubConnection
io.lettuce.core.pubsub.api.sync.RedisPubSubCommands
))
(defrecord Client [^RedisClient inner
^RedisURI uri]
clojure.lang.IDeref
(deref [_] inner)
java.lang.AutoCloseable
(close [_]
(.shutdown inner)))
(defrecord Connection [^StatefulRedisConnection inner
^RedisAsyncCommands cmd]
clojure.lang.IDeref
(deref [_] inner)
java.lang.AutoCloseable
(close [_]
(.close ^StatefulRedisConnection inner)))
(defn client
[uri]
(->Client (RedisClient/create)
(RedisURI/create uri)))
(defn connect
[{:keys [uri] :as client}]
(let [conn (.connect ^RedisClient @client StringCodec/UTF8 ^RedisURI uri)]
(->Connection conn (.async ^StatefulRedisConnection conn))))
(defn- impl-subscribe
[topics xform ^StatefulRedisPubSubConnection conn]
(let [cmd (.sync conn)
output (a/chan 1 (comp (filter string?) xform))
buffer (a/chan (a/sliding-buffer 64))
sub (reify RedisPubSubListener
(message [it pattern channel message])
(message [it channel message]
;; There are no back pressure, so we use a slidding
;; buffer for cases when the pubsub broker sends
;; more messages that we can process.
(a/put! buffer message))
(psubscribed [it pattern count])
(punsubscribed [it pattern count])
(subscribed [it channel count])
(unsubscribed [it channel count]))]
;; Start message event-loop (with keepalive mechanism)
(a/go-loop []
(let [[val port] (a/alts! [buffer (a/timeout 5000)])
message (if (= port buffer) val ::keepalive)]
(if (a/>! output message)
(recur)
(do
(a/close! buffer)
(.removeListener conn sub)
(when (.isOpen conn)
(.close conn))))))
;; Synchronously subscribe to topics
(.addListener conn sub)
(.subscribe ^RedisPubSubCommands cmd topics)
;; Return the output channel
output))
(defn subscribe
[{:keys [uri] :as client} {:keys [topics xform]}]
(let [topics (if (vector? topics)
(into-array String (map str topics))
(into-array String [(str topics)]))]
(->> (.connectPubSub ^RedisClient @client StringCodec/UTF8 ^RedisURI uri)
(impl-subscribe topics xform))))
(defn- resolve-to-bool
[v]
(if (= v 1)
true
false))
(defmulti impl-run (fn [_ cmd _] cmd))
(defn run!
[conn cmd params]
(let [^RedisAsyncCommands conn (:cmd conn)]
(impl-run conn cmd params)))
(defn run
[conn cmd params]
(let [res (a/chan 1)]
(if (instance? Connection conn)
(-> (run! conn cmd params)
(p/finally (fn [v e]
(if e
(a/offer! res e)
(a/offer! res v)))))
(a/close! res))
res))
(defmethod impl-run :get
[conn _ {:keys [key]}]
(.get ^RedisAsyncCommands conn ^String key))
(defmethod impl-run :set
[conn _ {:keys [key val]}]
(.set ^RedisAsyncCommands conn ^String key ^String val))
(defmethod impl-run :smembers
[conn _ {:keys [key]}]
(-> (.smembers ^RedisAsyncCommands conn ^String key)
(p/then' #(into #{} %))))
(defmethod impl-run :sadd
[conn _ {:keys [key val]}]
(let [keys (into-array String [val])]
(-> (.sadd ^RedisAsyncCommands conn ^String key ^"[S;" keys)
(p/then resolve-to-bool))))
(defmethod impl-run :srem
[conn _ {:keys [key val]}]
(let [keys (into-array String [val])]
(-> (.srem ^RedisAsyncCommands conn ^String key ^"[S;" keys)
(p/then resolve-to-bool))))
(defmethod impl-run :publish
[conn _ {:keys [channel message]}]
(-> (.publish ^RedisAsyncCommands conn ^String channel ^String message)
(p/then resolve-to-bool)))
(defmethod impl-run :hset
[^RedisAsyncCommands conn _ {:keys [key field value]}]
(.hset conn key field value))
(defmethod impl-run :hgetall
[^RedisAsyncCommands conn _ {:keys [key]}]
(.hgetall conn key))
(defmethod impl-run :hdel
[^RedisAsyncCommands conn _ {:keys [key field]}]
(let [fields (into-array String [field])]
(.hdel conn key fields)))

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

@ -21,7 +21,7 @@
::spec sname
::name (name sname))
sym (symbol (str "service-method-" (name sname)))]
sym (symbol (str "sm$" (name sname)))]
`(do
(def ~sym (fn ~args ~@body))
(reset-meta! (var ~sym) ~mdata))))

101
backend/src/app/util/svg.clj
View file

@ -1,101 +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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.util.svg
"Icons SVG parsing helpers."
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[clojure.spec.alpha :as s]
[cuerdas.core :as str])
(:import
org.jsoup.Jsoup
org.jsoup.nodes.Attribute
org.jsoup.nodes.Element
org.jsoup.nodes.Document))
(s/def ::content string?)
(s/def ::width ::us/number)
(s/def ::height ::us/number)
(s/def ::name string?)
(s/def ::view-box (s/coll-of ::us/number :min-count 4 :max-count 4))
(s/def ::svg-entity
(s/keys :req-un [::content ::width ::height ::view-box]
:opt-un [::name]))
;; --- Implementation
(defn- parse-double
[data]
(s/assert ::us/string data)
(Double/parseDouble data))
(defn- parse-viewbox
[data]
(s/assert ::us/string data)
(mapv parse-double (str/split data #"\s+")))
(defn- parse-attrs
[^Element element]
(persistent!
(reduce (fn [acc ^Attribute attr]
(let [key (.getKey attr)
val (.getValue attr)]
(case key
"width" (assoc! acc :width (parse-double val))
"height" (assoc! acc :height (parse-double val))
"viewbox" (assoc! acc :view-box (parse-viewbox val))
"sodipodi:docname" (assoc! acc :name val)
acc)))
(transient {})
(.attributes element))))
(defn- impl-parse
[data]
(try
(let [document (Jsoup/parse ^String data)
element (some-> (.body ^Document document)
(.getElementsByTag "svg")
(first))
content (.html element)
attrs (parse-attrs element)]
(assoc attrs :content content))
(catch java.lang.IllegalArgumentException _e
(ex/raise :type :validation
:code ::invalid-input
:message "Input does not seems to be a valid svg."))
(catch java.lang.NullPointerException _e
(ex/raise :type :validation
:code ::invalid-input
:message "Input does not seems to be a valid svg."))
(catch org.jsoup.UncheckedIOException _e
(ex/raise :type :validation
:code ::invalid-input
:message "Input does not seems to be a valid svg."))
(catch Exception _e
(ex/raise :type :internal
:code ::unexpected))))
;; --- Public Api
(defn parse-string
"Parse SVG from a string."
[data]
(s/assert ::us/string data)
(let [result (impl-parse data)]
(if (s/valid? ::svg-entity result)
result
(ex/raise :type :validation
:code ::invalid-result
:message "The result does not conform valid svg entity."))))
(defn parse
[data]
(parse-string (slurp data)))

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

@ -93,6 +93,10 @@
[t1 t2]
(Duration/between t1 t2))
(defn instant
[ms]
(Instant/ofEpochMilli ms))
(defn parse-duration
[s]
(Duration/parse s))

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

@ -10,9 +10,9 @@
(ns app.worker
"Async tasks abstraction (impl)."
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.util.async :as aa]
[app.util.log4j :refer [update-thread-context!]]
@ -20,6 +20,7 @@
[clojure.core.async :as a]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[cuerdas.core :as str]
[integrant.core :as ig]
[promesa.exec :as px])
(:import
@ -73,7 +74,7 @@
(s/def ::queue ::us/string)
(s/def ::parallelism ::us/integer)
(s/def ::batch-size ::us/integer)
(s/def ::tasks (s/map-of string? ::us/fn))
(s/def ::tasks (s/map-of string? fn?))
(s/def ::poll-interval ::dt/duration)
(defmethod ig/pre-init-spec ::worker [_]
@ -95,7 +96,7 @@
(defmethod ig/init-key ::worker
[_ {:keys [pool poll-interval name queue] :as cfg}]
(log/infof "Starting worker '%s' on queue '%s'." name queue)
(log/infof "starting worker '%s' on queue '%s'" name queue)
(let [cch (a/chan 1)
poll-ms (inst-ms poll-interval)]
(a/go-loop []
@ -104,30 +105,30 @@
;; Terminate the loop if close channel is closed or
;; event-loop-fn returns nil.
(or (= port cch) (nil? val))
(log/infof "Stop condition found. Shutdown worker: '%s'" name)
(log/infof "stop condition found; shutdown worker: '%s'" name)
(db/pool-closed? pool)
(do
(log/info "Worker eventloop is aborted because pool is closed.")
(log/info "worker eventloop is aborted because pool is closed")
(a/close! cch))
(and (instance? java.sql.SQLException val)
(contains? #{"08003" "08006" "08001" "08004"} (.getSQLState ^java.sql.SQLException val)))
(do
(log/error "Connection error, trying resume in some instants.")
(log/error "connection error, trying resume in some instants")
(a/<! (a/timeout poll-interval))
(recur))
(and (instance? java.sql.SQLException val)
(= "40001" (.getSQLState ^java.sql.SQLException val)))
(do
(log/debug "Serialization failure (retrying in some instants).")
(log/debug "serialization failure (retrying in some instants)")
(a/<! (a/timeout poll-ms))
(recur))
(instance? Exception val)
(do
(log/errorf val "Unexpected error ocurried on polling the database (will resume in some instants).")
(log/errorf val "unexpected error ocurried on polling the database (will resume in some instants)")
(a/<! (a/timeout poll-ms))
(recur))
@ -203,17 +204,13 @@
(let [task-fn (get tasks name)]
(if task-fn
(task-fn item)
(log/warn "no task handler found for" (pr-str name)))
(log/warnf "no task handler found for '%s'" (pr-str name)))
{:status :completed :task item}))
(defn get-error-context
[error item]
(let [edata (ex-data error)]
{:id (uuid/next)
:version (:full cfg/version)
:host (:public-uri cfg/config)
:class (.getCanonicalName ^java.lang.Class (class error))
:hint (ex-message error)
:data edata
:params item}))
@ -232,7 +229,7 @@
(let [cdata (get-error-context error item)]
(update-thread-context! cdata)
(log/errorf error "Unhandled exception on task (id: %s)" (:id cdata))
(log/errorf error "unhandled exception on task (id: '%s')" (:id cdata))
(if (>= (:retry-num item) (:max-retries item))
{:status :failed :task item :error error}
{:status :retry :task item :error error})))))
@ -240,12 +237,12 @@
(defn- run-task
[{:keys [tasks]} item]
(try
(log/debugf "Started task '%s/%s/%s'." (:name item) (:id item) (:retry-num item))
(log/debugf "started task '%s/%s/%s'" (:name item) (:id item) (:retry-num item))
(handle-task tasks item)
(catch Exception e
(handle-exception e item))
(finally
(log/debugf "Finished task '%s/%s/%s'." (:name item) (:id item) (:retry-num item)))))
(log/debugf "finished task '%s/%s/%s'" (:name item) (:id item) (:retry-num item)))))
(def sql:select-next-tasks
"select * from task as t
@ -294,21 +291,31 @@
(s/def ::id ::us/string)
(s/def ::cron dt/cron?)
(s/def ::props (s/nilable map?))
(s/def ::task keyword?)
(s/def ::scheduled-task-spec
(s/keys :req-un [::id ::cron ::fn]
(s/keys :req-un [::id ::cron ::task]
:opt-un [::props]))
(s/def ::schedule
(s/coll-of (s/nilable ::scheduled-task-spec)))
(s/def ::schedule (s/coll-of (s/nilable ::scheduled-task-spec)))
(defmethod ig/pre-init-spec ::scheduler [_]
(s/keys :req-un [::executor ::db/pool ::schedule]))
(s/keys :req-un [::executor ::db/pool ::schedule ::tasks]))
(defmethod ig/init-key ::scheduler
[_ {:keys [schedule] :as cfg}]
[_ {:keys [schedule tasks] :as cfg}]
(let [scheduler (Executors/newScheduledThreadPool (int 1))
schedule (filter some? schedule)
schedule (->> schedule
(filter some?)
(map (fn [{:keys [task] :as item}]
(let [f (get tasks (name task))]
(when-not f
(ex/raise :type :internal
:code :task-not-found
:hint (str/fmt "task %s not configured" task)))
(-> item
(dissoc :task)
(assoc :fn f))))))
cfg (assoc cfg
:scheduler scheduler
:schedule schedule)]
@ -335,7 +342,7 @@
(defn- synchronize-schedule-item
[conn {:keys [id cron]}]
(let [cron (str cron)]
(log/debugf "initialize scheduled task '%s' (cron: '%s')." id cron)
(log/infof "initialize scheduled task '%s' (cron: '%s')" id cron)
(db/exec-one! conn [sql:upsert-scheduled-task id cron cron])))
(defn- synchronize-schedule
@ -356,27 +363,16 @@
(letfn [(run-task [conn]
(try
(when (db/exec-one! conn [sql:lock-scheduled-task id])
(log/info "Executing scheduled task" id)
(log/debugf "executing scheduled task '%s'" id)
((:fn task) task))
(catch Exception e
(catch Throwable e
e)))
(handle-task* [conn]
(let [result (run-task conn)]
(if (instance? Throwable result)
(do
(log/warnf result "unhandled exception on scheduled task '%s'" id)
(db/insert! conn :scheduled-task-history
{:id (uuid/next)
:task-id id
:is-error true
:reason (exception->string result)}))
(db/insert! conn :scheduled-task-history
{:id (uuid/next)
:task-id id}))))
(handle-task []
(db/with-atomic [conn pool]
(handle-task* conn)))]
(let [result (run-task conn)]
(when (ex/exception? result)
(log/errorf result "unhandled exception on scheduled task '%s'" id)))))]
(try
(px/run! executor handle-task)

140
backend/tests/app/tests/helpers.clj
View file

@ -31,15 +31,23 @@
[environ.core :refer [env]]
[expound.alpha :as expound]
[integrant.core :as ig]
[mockery.core :as mk]
[promesa.core :as p])
(:import org.postgresql.ds.PGSimpleDataSource))
(def ^:dynamic *system* nil)
(def ^:dynamic *pool* nil)
(def config
(merge {:redis-uri "redis://redis/1"
:database-uri "postgresql://postgres/penpot_test"
:storage-fs-directory "/tmp/app/storage"
:migrations-verbose false}
cfg/config))
(defn state-init
[next]
(let [config (-> (main/build-system-config cfg/test-config)
(let [config (-> (main/build-system-config config)
(dissoc :app.srepl/server
:app.http/server
:app.http/router
@ -99,48 +107,7 @@
[prefix & args]
(uuid/namespaced uuid/zero (apply str prefix args)))
(defn create-profile
[conn i]
(let [params {:id (mk-uuid "profile" i)
:fullname (str "Profile " i)
:email (str "profile" i ".test@nodomain.com")
:password "123123"
:demo? true}]
(->> (#'profile/create-profile conn params)
(#'profile/create-profile-relations conn))))
(defn create-team
[conn profile-id i]
(let [id (mk-uuid "team" i)
team (#'teams/create-team conn {:id id
:profile-id profile-id
:name (str "team" i)})]
(#'teams/create-team-profile conn
{:team-id id
:profile-id profile-id
:is-owner true
:is-admin true
:can-edit true})
team))
(defn create-project
[conn profile-id team-id i]
(#'projects/create-project conn {:id (mk-uuid "project" i)
:profile-id profile-id
:team-id team-id
:name (str "project" i)}))
(defn create-file
[conn profile-id project-id is-shared i]
(#'files/create-file conn {:id (mk-uuid "file" i)
:profile-id profile-id
:project-id project-id
:is-shared is-shared
:name (str "file" i)}))
;; --- NEW HELPERS
;; --- FACTORIES
(defn create-profile*
([i] (create-profile* *pool* i {}))
@ -150,7 +117,7 @@
:fullname (str "Profile " i)
:email (str "profile" i ".test@nodomain.com")
:password "123123"
:demo? false}
:is-demo false}
params)]
(->> (#'profile/create-profile conn params)
(#'profile/create-profile-relations conn)))))
@ -193,6 +160,60 @@
:can-edit true})
team)))
(defn link-file-to-library*
([params] (link-file-to-library* *pool* params))
([conn {:keys [file-id library-id] :as params}]
(#'files/link-file-to-library conn {:file-id file-id :library-id library-id})))
(defn create-complaint-for
[conn {:keys [id created-at type]}]
(db/insert! conn :profile-complaint-report
{:profile-id id
:created-at (or created-at (dt/now))
:type (name type)
:content (db/tjson {})}))
(defn create-global-complaint-for
[conn {:keys [email type created-at]}]
(db/insert! conn :global-complaint-report
{:email email
:type (name type)
:created-at (or created-at (dt/now))
:content (db/tjson {})}))
(defn create-team-permission*
([params] (create-team-permission* *pool* params))
([conn {:keys [team-id profile-id is-owner is-admin can-edit]
:or {is-owner true is-admin true can-edit true}}]
(db/insert! conn :team-profile-rel {:team-id team-id
:profile-id profile-id
:is-owner is-owner
:is-admin is-admin
:can-edit can-edit})))
(defn create-project-permission*
([params] (create-project-permission* *pool* params))
([conn {:keys [project-id profile-id is-owner is-admin can-edit]
:or {is-owner true is-admin true can-edit true}}]
(db/insert! conn :project-profile-rel {:project-id project-id
:profile-id profile-id
:is-owner is-owner
:is-admin is-admin
:can-edit can-edit})))
(defn create-file-permission*
([params] (create-file-permission* *pool* params))
([conn {:keys [file-id profile-id is-owner is-admin can-edit]
:or {is-owner true is-admin true can-edit true}}]
(db/insert! conn :project-profile-rel {:file-id file-id
:profile-id profile-id
:is-owner is-owner
:is-admin is-admin
:can-edit can-edit})))
;; --- RPC HELPERS
(defn handle-error
[^Throwable err]
@ -200,14 +221,6 @@
(handle-error (.getCause err))
err))
(defmacro try-on
[expr]
`(try
(let [result# (deref ~expr)]
[nil result#])
(catch Exception e#
[(handle-error e#) nil])))
(defmacro try-on!
[expr]
`(try
@ -217,16 +230,6 @@
{:error (handle-error e#)
:result nil})))
(defmacro try!
[expr]
`(try
{:error nil
:result ~expr}
(catch Exception e#
{:error (handle-error e#)
:result nil})))
(defn mutation!
[{:keys [::type] :as data}]
(let [method-fn (get-in *system* [:app.rpc/rpc :methods :mutation type])]
@ -239,7 +242,7 @@
(try-on!
(method-fn (dissoc data ::type)))))
;; --- Utils
;; --- UTILS
(defn print-error!
[error]
@ -300,3 +303,14 @@
(defn sleep
[ms]
(Thread/sleep ms))
(defn mock-config-get-with
"Helper for mock app.config/get"
[data]
(fn
([key] (get (merge config data) key))
([key default] (get (merge config data) key default))))
(defn reset-mock!
[m]
(reset! m @(mk/make-mock {})))

316
backend/tests/app/tests/test_bounces_handling.clj Normal file
View file

@ -0,0 +1,316 @@
;; 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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2021 UXBOX Labs SL
(ns app.tests.test-bounces-handling
(:require
[clojure.pprint :refer [pprint]]
[app.http.awsns :as awsns]
[app.emails :as emails]
[app.tests.helpers :as th]
[app.db :as db]
[app.util.time :as dt]
[mockery.core :refer [with-mocks]]
[clojure.test :as t]))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
;; (with-mocks [mock {:target 'app.tasks/submit! :return nil}]
;; Right now we have many different scenarios what can cause a
;; bounce/complain report.
(defn- decode-row
[{:keys [content] :as row}]
(cond-> row
(db/pgobject? content)
(assoc :content (db/decode-transit-pgobject content))))
(defn bounce-report
[{:keys [token email] :or {email "user@example.com"}}]
{"notificationType" "Bounce",
"bounce" {"feedbackId""010701776d7dd251-c08d280d-9f47-41aa-b959-0094fec779d9-000000",
"bounceType" "Permanent",
"bounceSubType" "General",
"bouncedRecipients" [{"emailAddress" email,
"action" "failed",
"status" "5.1.1",
"diagnosticCode" "smtp; 550 5.1.1 user unknown"}]
"timestamp" "2021-02-04T14:41:38.000Z",
"remoteMtaIp" "22.22.22.22",
"reportingMTA" "dsn; b224-13.smtp-out.eu-central-1.amazonses.com"}
"mail" {"timestamp" "2021-02-04T14:41:37.020Z",
"source" "no-reply@penpot.app",
"sourceArn" "arn:aws:ses:eu-central-1:1111111111:identity/penpot.app",
"sourceIp" "22.22.22.22",
"sendingAccountId" "1111111111",
"messageId" "010701776d7dccfc-3c0094e7-01d7-458d-8100-893320186028-000000",
"destination" [email],
"headersTruncated" false,
"headers" [{"name" "Received","value" "from app-pre"},
{"name" "Date","value" "Thu, 4 Feb 2021 14:41:36 +0000 (UTC)"},
{"name" "From","value" "Penpot <no-reply@penpot.app>"},
{"name" "Reply-To","value" "Penpot <no-reply@penpot.app>"},
{"name" "To","value" email},
{"name" "Message-ID","value" "<2054501.5.1612449696846@penpot.app>"},
{"name" "Subject","value" "test"},
{"name" "MIME-Version","value" "1.0"},
{"name" "Content-Type","value" "multipart/mixed; boundary=\"----=_Part_3_1150363050.1612449696845\""},
{"name" "X-Penpot-Data","value" token}],
"commonHeaders" {"from" ["Penpot <no-reply@penpot.app>"],
"replyTo" ["Penpot <no-reply@penpot.app>"],
"date" "Thu, 4 Feb 2021 14:41:36 +0000 (UTC)",
"to" [email],
"messageId" "<2054501.5.1612449696846@penpot.app>",
"subject" "test"}}})
(defn complaint-report
[{:keys [token email] :or {email "user@example.com"}}]
{"notificationType" "Complaint",
"complaint" {"feedbackId" "0107017771528618-dcf4d61f-c889-4c8b-a6ff-6f0b6553b837-000000",
"complaintSubType" nil,
"complainedRecipients" [{"emailAddress" email}],
"timestamp" "2021-02-05T08:32:49.000Z",
"userAgent" "Yahoo!-Mail-Feedback/2.0",
"complaintFeedbackType" "abuse",
"arrivalDate" "2021-02-05T08:31:15.000Z"},
"mail" {"timestamp" "2021-02-05T08:31:13.715Z",
"source" "no-reply@penpot.app",
"sourceArn" "arn:aws:ses:eu-central-1:111111111:identity/penpot.app",
"sourceIp" "22.22.22.22",
"sendingAccountId" "11111111111",
"messageId" "0107017771510f33-a0696d28-859c-4f08-9211-8392d1b5c226-000000",
"destination" ["user@yahoo.com"],
"headersTruncated" false,
"headers" [{"name" "Received","value" "from smtp"},
{"name" "Date","value" "Fri, 5 Feb 2021 08:31:13 +0000 (UTC)"},
{"name" "From","value" "Penpot <no-reply@penpot.app>"},
{"name" "Reply-To","value" "Penpot <no-reply@penpot.app>"},
{"name" "To","value" email},
{"name" "Message-ID","value" "<1833063698.279.1612513873536@penpot.app>"},
{"name" "Subject","value" "Verify email."},
{"name" "MIME-Version","value" "1.0"},
{"name" "Content-Type","value" "multipart/mixed; boundary=\"----=_Part_276_1174403980.1612513873535\""},
{"name" "X-Penpot-Data","value" token}],
"commonHeaders" {"from" ["Penpot <no-reply@penpot.app>"],
"replyTo" ["Penpot <no-reply@penpot.app>"],
"date" "Fri, 5 Feb 2021 08:31:13 +0000 (UTC)",
"to" [email],
"messageId" "<1833063698.279.1612513873536@penpot.app>",
"subject" "Verify email."}}})
(t/deftest test-parse-bounce-report
(let [profile (th/create-profile* 1)
tokens (:app.tokens/tokens th/*system*)
cfg {:tokens tokens}
report (bounce-report {:token (tokens :generate-predefined
{:iss :profile-identity
:profile-id (:id profile)})})
result (#'awsns/parse-notification cfg report)]
;; (pprint result)
(t/is (= "bounce" (:type result)))
(t/is (= "permanent" (:kind result)))
(t/is (= "general" (:category result)))
(t/is (= ["user@example.com"] (mapv :email (:recipients result))))
(t/is (= (:id profile) (:profile-id result)))
))
(t/deftest test-parse-complaint-report
(let [profile (th/create-profile* 1)
tokens (:app.tokens/tokens th/*system*)
cfg {:tokens tokens}
report (complaint-report {:token (tokens :generate-predefined
{:iss :profile-identity
:profile-id (:id profile)})})
result (#'awsns/parse-notification cfg report)]
;; (pprint result)
(t/is (= "complaint" (:type result)))
(t/is (= "abuse" (:kind result)))
(t/is (= nil (:category result)))
(t/is (= ["user@example.com"] (into [] (:recipients result))))
(t/is (= (:id profile) (:profile-id result)))
))
(t/deftest test-parse-complaint-report-without-token
(let [tokens (:app.tokens/tokens th/*system*)
cfg {:tokens tokens}
report (complaint-report {:token ""})
result (#'awsns/parse-notification cfg report)]
(t/is (= "complaint" (:type result)))
(t/is (= "abuse" (:kind result)))
(t/is (= nil (:category result)))
(t/is (= ["user@example.com"] (into [] (:recipients result))))
(t/is (= nil (:profile-id result)))
))
(t/deftest test-process-bounce-report
(let [profile (th/create-profile* 1)
tokens (:app.tokens/tokens th/*system*)
pool (:app.db/pool th/*system*)
cfg {:tokens tokens :pool pool}
report (bounce-report {:token (tokens :generate-predefined
{:iss :profile-identity
:profile-id (:id profile)})})
report (#'awsns/parse-notification cfg report)]
(#'awsns/process-report cfg report)
(let [rows (->> (db/query pool :profile-complaint-report {:profile-id (:id profile)})
(mapv decode-row))]
(t/is (= 1 (count rows)))
(t/is (= "bounce" (get-in rows [0 :type])))
(t/is (= "2021-02-04T14:41:38.000Z" (get-in rows [0 :content :timestamp]))))
(let [rows (->> (db/query pool :global-complaint-report :all)
(mapv decode-row))]
(t/is (= 1 (count rows)))
(t/is (= "bounce" (get-in rows [0 :type])))
(t/is (= "user@example.com" (get-in rows [0 :email]))))
(let [prof (db/get-by-id pool :profile (:id profile))]
(t/is (false? (:is-muted prof))))
))
(t/deftest test-process-complaint-report
(let [profile (th/create-profile* 1)
tokens (:app.tokens/tokens th/*system*)
pool (:app.db/pool th/*system*)
cfg {:tokens tokens :pool pool}
report (complaint-report {:token (tokens :generate-predefined
{:iss :profile-identity
:profile-id (:id profile)})})
report (#'awsns/parse-notification cfg report)]
(#'awsns/process-report cfg report)
(let [rows (->> (db/query pool :profile-complaint-report {:profile-id (:id profile)})
(mapv decode-row))]
(t/is (= 1 (count rows)))
(t/is (= "complaint" (get-in rows [0 :type])))
(t/is (= "2021-02-05T08:31:15.000Z" (get-in rows [0 :content :timestamp]))))
(let [rows (->> (db/query pool :global-complaint-report :all)
(mapv decode-row))]
(t/is (= 1 (count rows)))
(t/is (= "complaint" (get-in rows [0 :type])))
(t/is (= "user@example.com" (get-in rows [0 :email]))))
(let [prof (db/get-by-id pool :profile (:id profile))]
(t/is (false? (:is-muted prof))))
))
(t/deftest test-process-bounce-report-to-self
(let [profile (th/create-profile* 1)
tokens (:app.tokens/tokens th/*system*)
pool (:app.db/pool th/*system*)
cfg {:tokens tokens :pool pool}
report (bounce-report {:email (:email profile)
:token (tokens :generate-predefined
{:iss :profile-identity
:profile-id (:id profile)})})
report (#'awsns/parse-notification cfg report)]
(#'awsns/process-report cfg report)
(let [rows (db/query pool :profile-complaint-report {:profile-id (:id profile)})]
(t/is (= 1 (count rows))))
(let [rows (db/query pool :global-complaint-report :all)]
(t/is (= 1 (count rows))))
(let [prof (db/get-by-id pool :profile (:id profile))]
(t/is (true? (:is-muted prof))))))
(t/deftest test-process-complaint-report-to-self
(let [profile (th/create-profile* 1)
tokens (:app.tokens/tokens th/*system*)
pool (:app.db/pool th/*system*)
cfg {:tokens tokens :pool pool}
report (complaint-report {:email (:email profile)
:token (tokens :generate-predefined
{:iss :profile-identity
:profile-id (:id profile)})})
report (#'awsns/parse-notification cfg report)]
(#'awsns/process-report cfg report)
(let [rows (db/query pool :profile-complaint-report {:profile-id (:id profile)})]
(t/is (= 1 (count rows))))
(let [rows (db/query pool :global-complaint-report :all)]
(t/is (= 1 (count rows))))
(let [prof (db/get-by-id pool :profile (:id profile))]
(t/is (true? (:is-muted prof))))))
(t/deftest test-allow-send-messages-predicate-with-bounces
(with-mocks [mock {:target 'app.config/get
:return (th/mock-config-get-with
{:profile-bounce-threshold 3
:profile-complaint-threshold 2})}]
(let [profile (th/create-profile* 1)
pool (:app.db/pool th/*system*)]
(th/create-complaint-for pool {:type :bounce :id (:id profile) :created-at (dt/in-past {:days 8})})
(th/create-complaint-for pool {:type :bounce :id (:id profile)})
(th/create-complaint-for pool {:type :bounce :id (:id profile)})
(t/is (true? (emails/allow-send-emails? pool profile)))
(t/is (= 4 (:call-count (deref mock))))
(th/create-complaint-for pool {:type :bounce :id (:id profile)})
(t/is (false? (emails/allow-send-emails? pool profile))))))
(t/deftest test-allow-send-messages-predicate-with-complaints
(with-mocks [mock {:target 'app.config/get
:return (th/mock-config-get-with
{:profile-bounce-threshold 3
:profile-complaint-threshold 2})}]
(let [profile (th/create-profile* 1)
pool (:app.db/pool th/*system*)]
(th/create-complaint-for pool {:type :bounce :id (:id profile) :created-at (dt/in-past {:days 8})})
(th/create-complaint-for pool {:type :bounce :id (:id profile) :created-at (dt/in-past {:days 8})})
(th/create-complaint-for pool {:type :bounce :id (:id profile)})
(th/create-complaint-for pool {:type :bounce :id (:id profile)})
(th/create-complaint-for pool {:type :complaint :id (:id profile)})
(t/is (true? (emails/allow-send-emails? pool profile)))
(t/is (= 4 (:call-count (deref mock))))
(th/create-complaint-for pool {:type :complaint :id (:id profile)})
(t/is (false? (emails/allow-send-emails? pool profile))))))
(t/deftest test-has-complaint-reports-predicate
(let [profile (th/create-profile* 1)
pool (:app.db/pool th/*system*)]
(t/is (false? (emails/has-complaint-reports? pool (:email profile))))
(th/create-global-complaint-for pool {:type :bounce :email (:email profile)})
(t/is (false? (emails/has-complaint-reports? pool (:email profile))))
(th/create-global-complaint-for pool {:type :complaint :email (:email profile)})
(t/is (true? (emails/has-complaint-reports? pool (:email profile))))))
(t/deftest test-has-bounce-reports-predicate
(let [profile (th/create-profile* 1)
pool (:app.db/pool th/*system*)]
(t/is (false? (emails/has-bounce-reports? pool (:email profile))))
(th/create-global-complaint-for pool {:type :complaint :email (:email profile)})
(t/is (false? (emails/has-bounce-reports? pool (:email profile))))
(th/create-global-complaint-for pool {:type :bounce :email (:email profile)})
(t/is (true? (emails/has-bounce-reports? pool (:email profile))))))

1
backend/tests/app/tests/test_emails.clj
View file

@ -11,7 +11,6 @@
(:require
[clojure.test :as t]
[promesa.core :as p]
[mockery.core :refer [with-mock]]
[app.db :as db]
[app.emails :as emails]
[app.tests.helpers :as th]))

277
backend/tests/app/tests/test_services_files.clj
View file

@ -120,102 +120,209 @@
(t/is (= 0 (count result))))))
))
(defn- create-file-media-object
[{:keys [profile-id file-id]}]
(let [mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/tests/_files/sample.jpg")
:content-type "image/jpeg"
:size 312043}
params {::th/type :upload-file-media-object
:profile-id profile-id
:file-id file-id
:is-local true
:name "testfile"
:content mfile}
out (th/mutation! params)]
(t/is (nil? (:error out)))
(:result out)))
(defn- update-file
[{:keys [profile-id file-id changes revn] :or {revn 0}}]
(let [params {::th/type :update-file
:id file-id
:session-id (uuid/random)
:profile-id profile-id
:revn revn
:changes changes}
out (th/mutation! params)]
(t/is (nil? (:error out)))
(:result out)))
(t/deftest file-media-gc-task
(let [task (:app.tasks.file-media-gc/handler th/*system*)
storage (:app.storage/storage th/*system*)
(letfn [(create-file-media-object [{:keys [profile-id file-id]}]
(let [mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/tests/_files/sample.jpg")
:content-type "image/jpeg"
:size 312043}
params {::th/type :upload-file-media-object
:profile-id profile-id
:file-id file-id
:is-local true
:name "testfile"
:content mfile}
out (th/mutation! params)]
(t/is (nil? (:error out)))
(:result out)))
prof (th/create-profile* 1)
proj (th/create-project* 1 {:profile-id (:id prof)
:team-id (:default-team-id prof)})
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof)
:is-shared false})
(update-file [{:keys [profile-id file-id changes revn] :or {revn 0}}]
(let [params {::th/type :update-file
:id file-id
:session-id (uuid/random)
:profile-id profile-id
:revn revn
:changes changes}
out (th/mutation! params)]
(t/is (nil? (:error out)))
(:result out)))]
fmo1 (create-file-media-object {:profile-id (:id prof)
:file-id (:id file)})
fmo2 (create-file-media-object {:profile-id (:id prof)
:file-id (:id file)})
shid (uuid/random)
(let [storage (:app.storage/storage th/*system*)
ures (update-file
{:file-id (:id file)
:profile-id (:id prof)
:revn 0
:changes
[{:type :add-obj
:page-id (first (get-in file [:data :pages]))
:id shid
:parent-id uuid/zero
:frame-id uuid/zero
:obj {:id shid
:name "image"
:frame-id uuid/zero
:parent-id uuid/zero
:type :image
:metadata {:id (:id fmo1)}}}]})]
profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})
;; run the task inmediatelly
(let [res (task {})]
(t/is (= 0 (:processed res))))
fmo1 (create-file-media-object {:profile-id (:id profile)
:file-id (:id file)})
fmo2 (create-file-media-object {:profile-id (:id profile)
:file-id (:id file)})
shid (uuid/random)
;; make the file ellegible for GC waiting 300ms
(th/sleep 300)
ures (update-file
{:file-id (:id file)
:profile-id (:id profile)
:revn 0
:changes
[{:type :add-obj
:page-id (first (get-in file [:data :pages]))
:id shid
:parent-id uuid/zero
:frame-id uuid/zero
:obj {:id shid
:name "image"
:frame-id uuid/zero
:parent-id uuid/zero
:type :image
:metadata {:id (:id fmo1)}}}]})]
;; run the task again
(let [res (task {})]
(t/is (= 1 (:processed res))))
;; run the task inmediatelly
(let [task (:app.tasks.file-media-gc/handler th/*system*)
res (task {})]
(t/is (= 0 (:processed res))))
;; Retrieve file and check trimmed attribute
(let [row (db/exec-one! th/*pool* ["select * from file where id = ?" (:id file)])]
(t/is (:has-media-trimmed row)))
;; make the file ellegible for GC waiting 300ms (configured
;; timeout for testing)
(th/sleep 300)
;; check file media objects
(let [fmos (db/exec! th/*pool* ["select * from file_media_object where file_id = ?" (:id file)])]
(t/is (= 1 (count fmos))))
;; run the task again
(let [task (:app.tasks.file-media-gc/handler th/*system*)
res (task {})]
(t/is (= 1 (:processed res))))
;; The underlying storage objects are still available.
(t/is (some? (sto/get-object storage (:media-id fmo2))))
(t/is (some? (sto/get-object storage (:thumbnail-id fmo2))))
(t/is (some? (sto/get-object storage (:media-id fmo1))))
(t/is (some? (sto/get-object storage (:thumbnail-id fmo1))))
;; retrieve file and check trimmed attribute
(let [row (db/exec-one! th/*pool* ["select * from file where id = ?" (:id file)])]
(t/is (true? (:has-media-trimmed row))))
;; but if we pass the touched gc task two of them should disappear
(let [task (:app.storage/gc-touched-task th/*system*)
res (task {})]
(t/is (= 0 (:freeze res)))
(t/is (= 2 (:delete res)))
;; check file media objects
(let [rows (db/exec! th/*pool* ["select * from file_media_object where file_id = ?" (:id file)])]
(t/is (= 1 (count rows))))
(t/is (nil? (sto/get-object storage (:media-id fmo2))))
(t/is (nil? (sto/get-object storage (:thumbnail-id fmo2))))
;; The underlying storage objects are still available.
(t/is (some? (sto/get-object storage (:media-id fmo2))))
(t/is (some? (sto/get-object storage (:thumbnail-id fmo2))))
(t/is (some? (sto/get-object storage (:media-id fmo1))))
(t/is (some? (sto/get-object storage (:thumbnail-id fmo1)))))
(t/is (some? (sto/get-object storage (:thumbnail-id fmo1))))
;; but if we pass the touched gc task two of them should disappear
(let [task (:app.storage/gc-touched-task th/*system*)
res (task {})]
(t/is (= 0 (:freeze res)))
(t/is (= 2 (:delete res)))
(t/is (nil? (sto/get-object storage (:media-id fmo2))))
(t/is (nil? (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/deftest permissions-checks-creating-file
(let [profile1 (th/create-profile* 1)
profile2 (th/create-profile* 2)
data {::th/type :create-file
:profile-id (:id profile2)
:project-id (:default-project-id profile1)
:name "foobar"
:is-shared false}
out (th/mutation! data)
error (:error out)]
;; (th/print-result! out)
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :not-found))))
(t/deftest permissions-checks-rename-file
(let [profile1 (th/create-profile* 1)
profile2 (th/create-profile* 2)
file (th/create-file* 1 {:project-id (:default-project-id profile1)
:profile-id (:id profile1)})
data {::th/type :rename-file
:id (:id file)
:profile-id (:id profile2)
:name "foobar"}
out (th/mutation! data)
error (:error out)]
;; (th/print-result! out)
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :not-found))))
(t/deftest permissions-checks-delete-file
(let [profile1 (th/create-profile* 1)
profile2 (th/create-profile* 2)
file (th/create-file* 1 {:project-id (:default-project-id profile1)
:profile-id (:id profile1)})
data {::th/type :delete-file
:profile-id (:id profile2)
:id (:id file)}
out (th/mutation! data)
error (:error out)]
;; (th/print-result! out)
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :not-found))))
(t/deftest permissions-checks-set-file-shared
(let [profile1 (th/create-profile* 1)
profile2 (th/create-profile* 2)
file (th/create-file* 1 {:project-id (:default-project-id profile1)
:profile-id (:id profile1)})
data {::th/type :set-file-shared
:profile-id (:id profile2)
:id (:id file)
:is-shared true}
out (th/mutation! data)
error (:error out)]
;; (th/print-result! out)
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :not-found))))
(t/deftest permissions-checks-link-to-library-1
(let [profile1 (th/create-profile* 1)
profile2 (th/create-profile* 2)
file1 (th/create-file* 1 {:project-id (:default-project-id profile1)
:profile-id (:id profile1)
:is-shared true})
file2 (th/create-file* 2 {:project-id (:default-project-id profile1)
:profile-id (:id profile1)})
data {::th/type :link-file-to-library
:profile-id (:id profile2)
:file-id (:id file2)
:library-id (:id file1)}
out (th/mutation! data)
error (:error out)]
;; (th/print-result! out)
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :not-found))))
(t/deftest permissions-checks-link-to-library-2
(let [profile1 (th/create-profile* 1)
profile2 (th/create-profile* 2)
file1 (th/create-file* 1 {:project-id (:default-project-id profile1)
:profile-id (:id profile1)
:is-shared true})
file2 (th/create-file* 2 {:project-id (:default-project-id profile2)
:profile-id (:id profile2)})
data {::th/type :link-file-to-library
:profile-id (:id profile2)
:file-id (:id file2)
:library-id (:id file1)}
out (th/mutation! data)
error (:error out)]
;; (th/print-result! out)
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :not-found))))
))

202
backend/tests/app/tests/test_services_profile.clj
View file

@ -18,6 +18,9 @@
[app.rpc.mutations.profile :as profile]
[app.tests.helpers :as th]))
;; TODO: profile deletion with teams
;; TODO: profile deletion with owner teams
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
@ -187,7 +190,198 @@
(t/testing "not allowed email domain"
(t/is (false? (profile/email-domain-in-whitelist? whitelist "username@somedomain.com"))))))
;; TODO: profile deletion with teams
;; TODO: profile deletion with owner teams
;; TODO: profile registration
;; TODO: profile password recovery
(t/deftest test-register-when-registration-disabled
(with-mocks [mock {:target 'app.config/get
:return (th/mock-config-get-with
{:registration-enabled false})}]
(let [data {::th/type :register-profile
:email "user@example.com"
:password "foobar"
:fullname "foobar"}
out (th/mutation! data)
error (:error out)
edata (ex-data error)]
(t/is (th/ex-info? error))
(t/is (= (:type edata) :restriction))
(t/is (= (:code edata) :registration-disabled)))))
(t/deftest test-register-existing-profile
(let [profile (th/create-profile* 1)
data {::th/type :register-profile
:email (:email profile)
:password "foobar"
:fullname "foobar"}
out (th/mutation! data)
error (:error out)
edata (ex-data error)]
(t/is (th/ex-info? error))
(t/is (= (:type edata) :validation))
(t/is (= (:code edata) :email-already-exists))))
(t/deftest test-register-profile
(with-mocks [mock {:target 'app.emails/send!
:return nil}]
(let [pool (:app.db/pool th/*system*)
data {::th/type :register-profile
:email "user@example.com"
:password "foobar"
:fullname "foobar"}
out (th/mutation! data)]
;; (th/print-result! out)
(let [mock (deref mock)
[_ _ params] (:call-args mock)]
;; (clojure.pprint/pprint params)
(t/is (:called? mock))
(t/is (= (:email data) (:to params)))
(t/is (contains? params :extra-data))
(t/is (contains? params :token)))
(let [result (:result out)]
(t/is (false? (:is-demo result)))
(t/is (= (:email data) (:email result)))
(t/is (= "penpot" (:auth-backend result)))
(t/is (= "foobar" (:fullname result)))
(t/is (not (contains? result :password)))))))
(t/deftest test-register-profile-with-bounced-email
(with-mocks [mock {:target 'app.emails/send!
:return nil}]
(let [pool (:app.db/pool th/*system*)
data {::th/type :register-profile
:email "user@example.com"
:password "foobar"
:fullname "foobar"}
_ (th/create-global-complaint-for pool {:type :bounce :email "user@example.com"})
out (th/mutation! data)]
;; (th/print-result! out)
(let [mock (deref mock)]
(t/is (false? (:called? mock))))
(let [error (:error out)
edata (ex-data error)]
(t/is (th/ex-info? error))
(t/is (= (:type edata) :validation))
(t/is (= (:code edata) :email-has-permanent-bounces))))))
(t/deftest test-register-profile-with-complained-email
(with-mocks [mock {:target 'app.emails/send! :return nil}]
(let [pool (:app.db/pool th/*system*)
data {::th/type :register-profile
:email "user@example.com"
:password "foobar"
:fullname "foobar"}
_ (th/create-global-complaint-for pool {:type :complaint :email "user@example.com"})
out (th/mutation! data)]
(let [mock (deref mock)]
(t/is (true? (:called? mock))))
(let [result (:result out)]
(t/is (= (:email data) (:email result)))))))
(t/deftest test-email-change-request
(with-mocks [email-send-mock {:target 'app.emails/send! :return nil}
cfg-get-mock {:target 'app.config/get
:return (th/mock-config-get-with
{:smtp-enabled true})}]
(let [profile (th/create-profile* 1)
pool (:app.db/pool th/*system*)
data {::th/type :request-email-change
:profile-id (:id profile)
:email "user1@example.com"}]
;; without complaints
(let [out (th/mutation! data)]
;; (th/print-result! out)
(t/is (nil? (:result out)))
(let [mock (deref email-send-mock)]
(t/is (= 1 (:call-count mock)))
(t/is (true? (:called? mock)))))
;; with complaints
(th/create-global-complaint-for pool {:type :complaint :email (:email data)})
(let [out (th/mutation! data)]
;; (th/print-result! out)
(t/is (nil? (:result out)))
(t/is (= 2 (:call-count (deref email-send-mock)))))
;; with bounces
(th/create-global-complaint-for pool {:type :bounce :email (:email data)})
(let [out (th/mutation! data)
error (:error out)]
;; (th/print-result! out)
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :validation))
(t/is (th/ex-of-code? error :email-has-permanent-bounces))
(t/is (= 2 (:call-count (deref email-send-mock))))))))
(t/deftest test-email-change-request-without-smtp
(with-mocks [email-send-mock {:target 'app.emails/send! :return nil}
cfg-get-mock {:target 'app.config/get
:return (th/mock-config-get-with
{:smtp-enabled false})}]
(let [profile (th/create-profile* 1)
pool (:app.db/pool th/*system*)
data {::th/type :request-email-change
:profile-id (:id profile)
:email "user1@example.com"}]
;; without complaints
(let [out (th/mutation! data)
res (:result out)]
(t/is (= {:changed true} res))
(let [mock (deref email-send-mock)]
(t/is (false? (:called? mock))))))))
(t/deftest test-request-profile-recovery
(with-mocks [mock {:target 'app.emails/send! :return nil}]
(let [profile1 (th/create-profile* 1)
profile2 (th/create-profile* 2 {:is-active true})
pool (:app.db/pool th/*system*)
data {::th/type :request-profile-recovery}]
;; with invalid email
(let [data (assoc data :email "foo@bar.com")
out (th/mutation! data)]
(t/is (nil? (:result out)))
(t/is (= 0 (:call-count (deref mock)))))
;; with valid email inactive user
(let [data (assoc data :email (:email profile1))
out (th/mutation! data)
error (:error out)]
(t/is (= 0 (:call-count (deref mock))))
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :validation))
(t/is (th/ex-of-code? error :profile-not-verified)))
;; with valid email and active user
(let [data (assoc data :email (:email profile2))
out (th/mutation! data)]
;; (th/print-result! out)
(t/is (nil? (:result out)))
(t/is (= 1 (:call-count (deref mock)))))
;; with valid email and active user with global complaints
(th/create-global-complaint-for pool {:type :complaint :email (:email profile2)})
(let [data (assoc data :email (:email profile2))
out (th/mutation! data)]
;; (th/print-result! out)
(t/is (nil? (:result out)))
(t/is (= 2 (:call-count (deref mock)))))
;; with valid email and active user with global bounce
(th/create-global-complaint-for pool {:type :bounce :email (:email profile2)})
(let [data (assoc data :email (:email profile2))
out (th/mutation! data)
error (:error out)]
;; (th/print-result! out)
(t/is (= 2 (:call-count (deref mock))))
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :validation))
(t/is (th/ex-of-code? error :email-has-permanent-bounces)))
)))

83
backend/tests/app/tests/test_services_projects.clj
View file

@ -19,15 +19,15 @@
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
(t/deftest projects-crud
(let [prof (th/create-profile* 1)
team (th/create-team* 1 {:profile-id (:id prof)})
(t/deftest projects-simple-crud
(let [profile (th/create-profile* 1)
team (th/create-team* 1 {:profile-id (:id profile)})
project-id (uuid/next)]
;; crate project
(let [data {::th/type :create-project
:id project-id
:profile-id (:id prof)
:profile-id (:id profile)
:team-id (:id team)
:name "test project"}
out (th/mutation! data)]
@ -40,7 +40,7 @@
;; query a list of projects
(let [data {::th/type :projects
:team-id (:id team)
:profile-id (:id prof)}
:profile-id (:id profile)}
out (th/query! data)]
;; (th/print-result! out)
@ -54,7 +54,7 @@
(let [data {::th/type :rename-project
:id project-id
:name "renamed project"
:profile-id (:id prof)}
:profile-id (:id profile)}
out (th/mutation! data)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
@ -63,7 +63,7 @@
;; retrieve project
(let [data {::th/type :project
:id project-id
:profile-id (:id prof)}
:profile-id (:id profile)}
out (th/query! data)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
@ -73,7 +73,7 @@
;; delete project
(let [data {::th/type :delete-project
:id project-id
:profile-id (:id prof)}
:profile-id (:id profile)}
out (th/mutation! data)]
;; (th/print-result! out)
@ -83,10 +83,75 @@
;; query a list of projects after delete"
(let [data {::th/type :projects
:team-id (:id team)
:profile-id (:id prof)}
:profile-id (:id profile)}
out (th/query! data)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(let [result (:result out)]
(t/is (= 0 (count result)))))
))
(t/deftest permissions-checks-create-project
(let [profile1 (th/create-profile* 1)
profile2 (th/create-profile* 2)
data {::th/type :create-project
:profile-id (:id profile2)
:team-id (:default-team-id profile1)
:name "test project"}
out (th/mutation! data)
error (:error out)]
;; (th/print-result! out)
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :not-found))))
(t/deftest permissions-checks-rename-project
(let [profile1 (th/create-profile* 1)
profile2 (th/create-profile* 2)
project (th/create-project* 1 {:team-id (:default-team-id profile1)
:profile-id (:id profile1)})
data {::th/type :rename-project
:id (:id project)
:profile-id (:id profile2)
:name "foobar"}
out (th/mutation! data)
error (:error out)]
;; (th/print-result! out)
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :not-found))))
(t/deftest permissions-checks-delete-project
(let [profile1 (th/create-profile* 1)
profile2 (th/create-profile* 2)
project (th/create-project* 1 {:team-id (:default-team-id profile1)
:profile-id (:id profile1)})
data {::th/type :delete-project
:id (:id project)
:profile-id (:id profile2)}
out (th/mutation! data)
error (:error out)]
;; (th/print-result! out)
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :not-found))))
(t/deftest permissions-checks-delete-project
(let [profile1 (th/create-profile* 1)
profile2 (th/create-profile* 2)
project (th/create-project* 1 {:team-id (:default-team-id profile1)
:profile-id (:id profile1)})
data {::th/type :update-project-pin
:id (:id project)
:team-id (:default-team-id profile1)
:profile-id (:id profile2)
:is-pinned true}
out (th/mutation! data)
error (:error out)]
;; (th/print-result! out)
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :not-found))))

88
backend/tests/app/tests/test_services_teams.clj Normal file
View file

@ -0,0 +1,88 @@
;; 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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.tests.test-services-teams
(:require
[app.common.uuid :as uuid]
[app.db :as db]
[app.http :as http]
[app.storage :as sto]
[app.tests.helpers :as th]
[mockery.core :refer [with-mocks]]
[clojure.test :as t]
[datoteka.core :as fs]))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
(t/deftest test-invite-team-member
(with-mocks [mock {:target 'app.emails/send! :return nil}]
(let [profile1 (th/create-profile* 1 {:is-active true})
profile2 (th/create-profile* 2 {:is-active true})
profile3 (th/create-profile* 3 {:is-active true :is-muted true})
team (th/create-team* 1 {:profile-id (:id profile1)})
pool (:app.db/pool th/*system*)
data {::th/type :invite-team-member
:team-id (:id team)
:role :editor
:profile-id (:id profile1)}]
;; (th/print-result! out)
;; invite external user without complaints
(let [data (assoc data :email "foo@bar.com")
out (th/mutation! data)]
(t/is (nil? (:result out)))
(t/is (= 1 (:call-count (deref mock)))))
;; invite internal user without complaints
(th/reset-mock! mock)
(let [data (assoc data :email (:email profile2))
out (th/mutation! data)]
(t/is (nil? (:result out)))
(t/is (= 1 (:call-count (deref mock)))))
;; invite user with complaint
(th/create-global-complaint-for pool {:type :complaint :email "foo@bar.com"})
(th/reset-mock! mock)
(let [data (assoc data :email "foo@bar.com")
out (th/mutation! data)]
(t/is (nil? (:result out)))
(t/is (= 1 (:call-count (deref mock)))))
;; invite user with bounce
(th/reset-mock! mock)
(th/create-global-complaint-for pool {:type :bounce :email "foo@bar.com"})
(let [data (assoc data :email "foo@bar.com")
out (th/mutation! data)
error (:error out)]
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :validation))
(t/is (th/ex-of-code? error :email-has-permanent-bounces))
(t/is (= 0 (:call-count (deref mock)))))
;; invite internal user that is muted
(th/reset-mock! mock)
(let [data (assoc data :email (:email profile3))
out (th/mutation! data)
error (:error out)]
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :validation))
(t/is (th/ex-of-code? error :member-is-muted))
(t/is (= 0 (:call-count (deref mock)))))
)))

62
backend/tests/app/tests/test_util_svg.clj
View file

@ -1,62 +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/.
;;
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.tests.test-util-svg
(:require
[clojure.test :as t]
[clojure.java.io :as io]
[app.http :as http]
[app.util.svg :as svg]
[app.tests.helpers :as th]))
(t/deftest parse-svg-1
(let [result (-> (io/resource "app/tests/_files/sample1.svg")
(svg/parse))]
(t/is (contains? result :width))
(t/is (contains? result :height))
(t/is (contains? result :view-box))
(t/is (contains? result :name))
(t/is (contains? result :content))
(t/is (= 500.0 (:width result)))
(t/is (= 500.0 (:height result)))
(t/is (= [0.0 0.0 500.00001 500.00001] (:view-box result)))
(t/is (= "lock.svg" (:name result)))))
(t/deftest parse-svg-2
(let [result (-> (io/resource "app/tests/_files/sample2.svg")
(svg/parse))]
(t/is (contains? result :width))
(t/is (contains? result :height))
(t/is (contains? result :view-box))
(t/is (contains? result :name))
(t/is (contains? result :content))
(t/is (= 500.0 (:width result)))
(t/is (= 500.0 (:height result)))
(t/is (= [0.0 0.0 500.0 500.00001] (:view-box result)))
(t/is (= "play.svg" (:name result)))))
(t/deftest parse-invalid-svg-1
(let [image (io/resource "app/tests/_files/sample.jpg")
out (th/try! (svg/parse image))]
(let [error (:error out)]
(t/is (th/ex-info? error))
(t/is (th/ex-of-code? error ::svg/invalid-input)))))
(t/deftest parse-invalid-svg-2
(let [out (th/try! (svg/parse-string ""))]
(let [error (:error out)]
(t/is (th/ex-info? error))
(t/is (th/ex-of-code? error ::svg/invalid-input)))))
(t/deftest parse-invalid-svg-3
(let [out (th/try! (svg/parse-string "<svg></svg>"))]
(let [error (:error out)]
(t/is (th/ex-info? error))
(t/is (th/ex-of-code? error ::svg/invalid-result)))))

4
common/app/common/exceptions.cljc
View file

@ -52,3 +52,7 @@
(defn ex-info?
[v]
(instance? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core.ExceptionInfo) v))
(defn exception?
[v]
(instance? #?(:clj java.lang.Throwable :cljs js/Error) v))

6
common/app/common/pages/common.cljc
View file

@ -11,7 +11,7 @@
(:require
[app.common.uuid :as uuid]))
(def file-version 5)
(def file-version 6)
(def default-color "#b1b2b5") ;; $color-gray-20
(def root uuid/zero)
@ -42,6 +42,10 @@
:stroke-alignment :stroke-group
:rx :radius-group
:ry :radius-group
:r1 :radius-group
:r2 :radius-group
:r3 :radius-group
:r4 :radius-group
:selrect :geometry-group
:points :geometry-group
:locked :geometry-group

1
common/app/common/pages/helpers.cljc
View file

@ -353,6 +353,7 @@
(let [frames (select-frames objects)]
(or
(->> frames
(reverse)
(d/seek #(and position (gsh/has-point? % position)))
:id)
uuid/zero)))

29
common/app/common/pages/migrations.cljc
View file

@ -13,6 +13,7 @@
[app.common.geom.shapes :as gsh]
[app.common.geom.shapes.path :as gsp]
[app.common.geom.matrix :as gmt]
[app.common.math :as mth]
[app.common.uuid :as uuid]
[app.common.data :as d]))
@ -137,3 +138,31 @@
(update data :pages-index #(d/mapm update-page %))))
(defn fix-line-paths
"Fixes issues with selrect/points for shapes with width/height = 0 (line-like paths)"
[_ shape]
(if (= (:type shape) :path)
(let [{:keys [width height]} (gsh/points->rect (:points shape))]
(if (or (mth/almost-zero? width) (mth/almost-zero? height))
(let [selrect (gsh/content->selrect (:content shape))
points (gsh/rect->points selrect)
transform (gmt/matrix)
transform-inv (gmt/matrix)]
(assoc shape
:selrect selrect
:points points
:transform transform
:transform-inverse transform-inv))
shape))
shape))
(defmethod migrate 6
[data]
(letfn [(update-container [_ container]
(-> container
(update :objects #(d/mapm fix-line-paths %))))]
(-> data
(update :components #(d/mapm update-container %))
(update :pages-index #(d/mapm update-container %)))))

8
common/app/common/pages/spec.cljc
View file

@ -220,6 +220,10 @@
(s/def :internal.shape/proportion-lock boolean?)
(s/def :internal.shape/rx ::safe-number)
(s/def :internal.shape/ry ::safe-number)
(s/def :internal.shape/r1 ::safe-number)
(s/def :internal.shape/r2 ::safe-number)
(s/def :internal.shape/r3 ::safe-number)
(s/def :internal.shape/r4 ::safe-number)
(s/def :internal.shape/stroke-color string?)
(s/def :internal.shape/stroke-color-gradient (s/nilable ::gradient))
(s/def :internal.shape/stroke-color-ref-file (s/nilable uuid?))
@ -296,6 +300,10 @@
:internal.shape/proportion-lock
:internal.shape/rx
:internal.shape/ry
:internal.shape/r1
:internal.shape/r2
:internal.shape/r3
:internal.shape/r4
:internal.shape/x
:internal.shape/y
:internal.shape/exports

46
docker/devenv/docker-compose.yaml
View file

@ -43,6 +43,29 @@ services:
- PENPOT_DATABASE_PASSWORD=penpot
- PENPOT_REDIS_URI=redis://redis/0
- EXTERNAL_UID=${CURRENT_USER_ID}
# STMP setup
- PENPOT_SMTP_ENABLED=true
- PENPOT_SMTP_DEFAULT_FROM=no-reply@example.com
- PENPOT_SMTP_DEFAULT_REPLY_TO=no-reply@example.com
- PENPOT_SMTP_HOST=mailer
- PENPOT_SMTP_PORT=1025
- PENPOT_SMTP_USERNAME=
- PENPOT_SMTP_PASSWORD=
- PENPOT_SMTP_SSL=false
- PENPOT_SMTP_TLS=false
# LDAP setup
- PENPOT_LDAP_HOST=ldap
- PENPOT_LDAP_PORT=10389
- PENPOT_LDAP_SSL=false
- PENPOT_LDAP_STARTTLS=false
- PENPOT_LDAP_BASE_DN=ou=people,dc=planetexpress,dc=com
- PENPOT_LDAP_BIND_DN=cn=admin,dc=planetexpress,dc=com
- PENPOT_LDAP_BIND_PASSWORD=GoodNewsEveryone
- PENPOT_LDAP_ATTRS_USERNAME=uid
- PENPOT_LDAP_ATTRS_EMAIL=mail
- PENPOT_LDAP_ATTRS_FULLNAME=cn
- PENPOT_LDAP_ATTRS_PHOTO=jpegPhoto
postgres:
image: postgres:13
@ -61,7 +84,28 @@ services:
- postgres_data:/var/lib/postgresql/data
redis:
image: redis:6
image: redis:5.0.7
hostname: "penpot-devenv-redis"
container_name: "penpot-devenv-redis"
restart: always
mailer:
image: sj26/mailcatcher:latest
hostname: mautic-mailer
container_name: mautic-mailer
restart: always
expose:
- '1025'
ports:
- "1080:1080"
ldap:
image: rroemhild/test-openldap:2.1
container_name: mautic-ldap
hostname: mautic-ldap
expose:
- '10389'
- '10636'
ports:
- "10389:10389"
- "10636:10636"

4
docker/devenv/files/nginx.conf
View file

@ -99,6 +99,10 @@ http {
proxy_pass http://127.0.0.1:6060/api;
}
location /webhooks {
proxy_pass http://127.0.0.1:6060/webhooks;
}
location /dbg {
proxy_pass http://127.0.0.1:6060/dbg;
}

1
docker/images/files/config.js
View file

@ -7,3 +7,4 @@
//var penpotGitlabClientID = "<gitlab-client-id-here>";
//var penpotGithubClientID = "<github-client-id-here>";
//var penpotLoginWithLDAP = <true|false>;
//var penpotRegistrationEnabled = <true|false>;

11
docker/images/files/nginx-entrypoint.sh
View file

@ -79,6 +79,16 @@ update_login_with_ldap() {
fi
}
update_registration_enabled() {
if [ -n "$PENPOT_REGISTRATION_ENABLED" ]; then
log "Updating Registration Enabled: $PENPOT_REGISTRATION_ENABLED"
sed -i \
-e "s|^//var penpotRegistrationEnabled = .*;|var penpotRegistrationEnabled = $PENPOT_REGISTRATION_ENABLED;|g" \
"$1"
fi
}
update_public_uri /var/www/app/js/config.js
update_demo_warning /var/www/app/js/config.js
update_allow_demo_users /var/www/app/js/config.js
@ -86,5 +96,6 @@ update_google_client_id /var/www/app/js/config.js
update_gitlab_client_id /var/www/app/js/config.js
update_github_client_id /var/www/app/js/config.js
update_login_with_ldap /var/www/app/js/config.js
update_registration_enabled /var/www/app/js/config.js
exec "$@";

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