Penpot/penpot
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-04-12 15:01:28 -05:00
Code Issues Activity

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

Browse source
This commit is contained in:
Andrey Antukh 2020-12-11 15:46:01 +01:00
commit 4903d26038
345 changed files with 14058 additions and 8649 deletions

29
.clj-kondo/config.edn Normal file
View file

@ -0,0 +1,29 @@
{:lint-as {potok.core/reify clojure.core/reify
promesa.core/let clojure.core/let
app.db/with-atomic clojure.core/with-open}
:output
{:exclude-files ["data_readers.clj"]}
:linters
{:unsorted-required-namespaces
{:level :warning}
:unresolved-namespace
{:level :warning
:exclude [data_readers]}
:single-key-in
{:level :warning}
:unused-binding
{:exclude-destructured-as true
:exclude-destructured-keys-in-fn-args false
}
:unresolved-symbol
{:exclude ['(app.services.mutations/defmutation)
'(app.services.queries/defquery)
'(app.util.dispatcher/defservice)
'(mount.core/defstate)
]}}}

4
.gitignore vendored
View file

@ -25,8 +25,10 @@ node_modules
/frontend/resources/public/*
/exporter/target
/exporter/.shadow-cljs
/docker/testenv/bundle
/docker/images/bundle
/.clj-kondo/.cache
/bundle*
/media
/deploy
/web
/_dump

2
README.md
View file

@ -8,7 +8,7 @@
# PENPOT #
We’re excited to share that Uxbox is now Penpot! We’re changing the name, but keeping the same project essence. Stay in the loop for more news comming early 2021. Alpha release is close!
We’re excited to share that Uxbox is now Penpot! We’re changing the name, but keeping the same project essence. Stay in the loop for more news coming early 2021. Alpha release is close!
![PENPOT](https://raw.githubusercontent.com/penpot/penpot/develop/docs/screenshot.png)

9
backend/deps.edn
View file

@ -4,6 +4,7 @@
"jcenter" {:url "https://jcenter.bintray.com/"}}
:deps
{org.clojure/clojure {:mvn/version "1.10.1"}
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"}
@ -33,14 +34,14 @@
org.postgresql/postgresql {:mvn/version "42.2.16"}
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 "5.1.0"}
funcool/cuerdas {:mvn/version "2020.03.26-3"}
buddy/buddy-core {:mvn/version "1.8.0"}
buddy/buddy-hashers {:mvn/version "1.6.0"}
buddy/buddy-sign {:mvn/version "3.2.0"}
buddy/buddy-core {:mvn/version "1.9.0"}
buddy/buddy-hashers {:mvn/version "1.7.0"}
buddy/buddy-sign {:mvn/version "3.3.0"}
lambdaisland/uri {:mvn/version "1.4.54"
:exclusions [org.clojure/data.json]}

8
backend/resources/emails-mjml/change-email/en.mjml
View file

@ -45,10 +45,10 @@
<mj-section padding="0">
<mj-column>
<mj-social icon-size="24px" mode="horizontal">
<mj-social-element src="{{ public-uri }}/images/email/logo-uxbox.png" href="https://uxbox.io/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-twitter.png" href="https://twitter.com/penpot" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-github.png" href="https://github.com/uxbox/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-instagram.png" href="https://instagram.com/uxbox/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-uxbox.png" href="https://penpot.app/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-twitter.png" href="https://twitter.com/penpotapp" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-github.png" href="https://github.com/penpot/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-instagram.png" href="https://instagram.com/penpotapp/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-taiga.png" href="https://tree.taiga.io/project/uxbox" padding="0 8px" />
</mj-social>
</mj-column>

8
backend/resources/emails-mjml/invite-to-team/en.mjml
View file

@ -38,10 +38,10 @@
<mj-section padding="0">
<mj-column>
<mj-social icon-size="24px" mode="horizontal">
<mj-social-element src="{{ public-uri }}/images/email/logo-uxbox.png" href="https://uxbox.io/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-twitter.png" href="https://twitter.com/penpot" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-github.png" href="https://github.com/uxbox/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-instagram.png" href="https://instagram.com/uxbox/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-uxbox.png" href="https://penpot.app/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-twitter.png" href="https://twitter.com/penpotapp" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-github.png" href="https://github.com/penpot/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-instagram.png" href="https://instagram.com/penpotapp/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-taiga.png" href="https://tree.taiga.io/project/uxbox" padding="0 8px" />
</mj-social>
</mj-column>

8
backend/resources/emails-mjml/password-recovery/en.mjml
View file

@ -47,10 +47,10 @@
<mj-section padding="0">
<mj-column>
<mj-social icon-size="24px" mode="horizontal">
<mj-social-element src="{{ public-uri }}/images/email/logo-uxbox.png" href="https://uxbox.io/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-twitter.png" href="https://twitter.com/penpot" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-github.png" href="https://github.com/uxbox/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-instagram.png" href="https://instagram.com/uxbox/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-uxbox.png" href="https://penpot.app/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-twitter.png" href="https://twitter.com/penpotapp" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-github.png" href="https://github.com/penpot/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-instagram.png" href="https://instagram.com/penpotapp/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-taiga.png" href="https://tree.taiga.io/project/uxbox" padding="0 8px" />
</mj-social>
</mj-column>

8
backend/resources/emails-mjml/register/en.mjml
View file

@ -44,10 +44,10 @@
<mj-section padding="0">
<mj-column>
<mj-social icon-size="24px" mode="horizontal">
<mj-social-element src="{{ public-uri }}/images/email/logo-uxbox.png" href="https://uxbox.io/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-twitter.png" href="https://twitter.com/penpot" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-github.png" href="https://github.com/uxbox/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-instagram.png" href="https://instagram.com/uxbox/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-uxbox.png" href="https://penpot.app/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-twitter.png" href="https://twitter.com/penpotapp" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-github.png" href="https://github.com/penpot/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-instagram.png" href="https://instagram.com/penpotapp/" padding="0 8px" />
<mj-social-element src="{{ public-uri }}/images/email/logo-taiga.png" href="https://tree.taiga.io/project/uxbox" padding="0 8px" />
</mj-social>
</mj-column>

4
backend/resources/emails/change-email/en.html
View file

@ -330,7 +330,7 @@
<table border="0" cellpadding="0" cellspacing="0" role="presentation" style="border-radius:3px;width:24px;">
<tr>
<td style="font-size:0;height:24px;vertical-align:middle;width:24px;">
<a href="https://twitter.com/penpot" target="_blank">
<a href="https://twitter.com/penpotapp" target="_blank">
<img height="24" src="{{ public-uri }}/images/email/logo-twitter.png" style="border-radius:3px;display:block;" width="24" />
</a>
</td>
@ -370,7 +370,7 @@
<table border="0" cellpadding="0" cellspacing="0" role="presentation" style="border-radius:3px;width:24px;">
<tr>
<td style="font-size:0;height:24px;vertical-align:middle;width:24px;">
<a href="https://instagram.com/penpot/" target="_blank">
<a href="https://instagram.com/penpotapp/" target="_blank">
<img height="24" src="{{ public-uri }}/images/email/logo-instagram.png" style="border-radius:3px;display:block;" width="24" />
</a>
</td>

4
backend/resources/emails/invite-to-team/en.html
View file

@ -320,7 +320,7 @@
<table border="0" cellpadding="0" cellspacing="0" role="presentation" style="border-radius:3px;width:24px;">
<tr>
<td style="font-size:0;height:24px;vertical-align:middle;width:24px;">
<a href="https://twitter.com/penpot" target="_blank">
<a href="https://twitter.com/penpotapp" target="_blank">
<img height="24" src="{{ public-uri }}/images/email/logo-twitter.png" style="border-radius:3px;display:block;" width="24" />
</a>
</td>
@ -360,7 +360,7 @@
<table border="0" cellpadding="0" cellspacing="0" role="presentation" style="border-radius:3px;width:24px;">
<tr>
<td style="font-size:0;height:24px;vertical-align:middle;width:24px;">
<a href="https://instagram.com/penpot/" target="_blank">
<a href="https://instagram.com/penpotapp/" target="_blank">
<img height="24" src="{{ public-uri }}/images/email/logo-instagram.png" style="border-radius:3px;display:block;" width="24" />
</a>
</td>

4
backend/resources/emails/password-recovery/en.html
View file

@ -325,7 +325,7 @@
<table border="0" cellpadding="0" cellspacing="0" role="presentation" style="border-radius:3px;width:24px;">
<tr>
<td style="font-size:0;height:24px;vertical-align:middle;width:24px;">
<a href="https://twitter.com/penpot" target="_blank">
<a href="https://twitter.com/penpotapp" target="_blank">
<img height="24" src="{{ public-uri }}/images/email/logo-twitter.png" style="border-radius:3px;display:block;" width="24" />
</a>
</td>
@ -365,7 +365,7 @@
<table border="0" cellpadding="0" cellspacing="0" role="presentation" style="border-radius:3px;width:24px;">
<tr>
<td style="font-size:0;height:24px;vertical-align:middle;width:24px;">
<a href="https://instagram.com/penpot/" target="_blank">
<a href="https://instagram.com/penpotapp/" target="_blank">
<img height="24" src="{{ public-uri }}/images/email/logo-instagram.png" style="border-radius:3px;display:block;" width="24" />
</a>
</td>

4
backend/resources/emails/register/en.html
View file

@ -320,7 +320,7 @@
<table border="0" cellpadding="0" cellspacing="0" role="presentation" style="border-radius:3px;width:24px;">
<tr>
<td style="font-size:0;height:24px;vertical-align:middle;width:24px;">
<a href="https://twitter.com/penpot" target="_blank">
<a href="https://twitter.com/penpotapp" target="_blank">
<img height="24" src="{{ public-uri }}/images/email/logo-twitter.png" style="border-radius:3px;display:block;" width="24" />
</a>
</td>
@ -360,7 +360,7 @@
<table border="0" cellpadding="0" cellspacing="0" role="presentation" style="border-radius:3px;width:24px;">
<tr>
<td style="font-size:0;height:24px;vertical-align:middle;width:24px;">
<a href="https://instagram.com/penpot/" target="_blank">
<a href="https://instagram.com/penpotapp/" target="_blank">
<img height="24" src="{{ public-uri }}/images/email/logo-instagram.png" style="border-radius:3px;display:block;" width="24" />
</a>
</td>

10
backend/resources/log4j2.xml
View file

@ -12,6 +12,10 @@
</Policies>
<DefaultRolloverStrategy max="9"/>
</RollingFile>
<CljFn name="error-reporter" ns="app.error-reporter" fn="enqueue">
<PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] [%t] %level{length=1} %logger{36} - %msg%n"/>
</CljFn>
</Appenders>
<Loggers>
@ -23,13 +27,17 @@
<AppenderRef ref="console"/>
</Logger>
<Logger name="app.error-reporter" level="debug" additivity="false">
<AppenderRef ref="console"/>
</Logger>
<Logger name="app" level="debug" additivity="false">
<AppenderRef ref="main" level="debug" />
<AppenderRef ref="error-reporter" level="error" />
</Logger>
<Root level="info">
<AppenderRef ref="main" />
<!-- <AppenderRef ref="console" /> -->
</Root>
</Loggers>
</Configuration>

2
backend/scripts/build.sh
View file

@ -47,7 +47,7 @@ if [ -f ./environ ]; then
fi
set -x
exec \$JAVA_CMD \$JVM_OPTS -classpath \$CP -Dlog4j.configurationFile=./log4j2.xml "\$@" clojure.main -m app.main
exec \$JAVA_CMD \$JVM_OPTS -Dapp.enable-asserts=false -classpath \$CP -Dlog4j.configurationFile=./log4j2.xml "\$@" clojure.main -m app.main
EOF
chmod +x ./target/dist/run.sh

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

@ -10,17 +10,16 @@
(ns app.cli.fixtures
"A initial fixtures."
(:require
[clojure.tools.logging :as log]
[mount.core :as mount]
[buddy.hashers :as hashers]
[app.common.data :as d]
[app.common.pages :as cp]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.migrations]
[app.services.mutations.profile :as profile]
[app.util.blob :as blob]))
[app.util.blob :as blob]
[buddy.hashers :as hashers]
[clojure.tools.logging :as log]
[mount.core :as mount]))
(defn- mk-uuid
[prefix & args]

30
backend/src/app/cli/media_loader.clj
View file

@ -5,27 +5,27 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2016-2020 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.cli.media-loader
"Media libraries importer (command line helper)."
(:require
[clojure.tools.logging :as log]
[clojure.spec.alpha :as s]
[clojure.java.io :as io]
[mount.core :as mount]
[datoteka.core :as fs]
[app.config]
#_(:require
[app.common.spec :as us]
[app.db :as db]
[app.media]
[app.media-storage]
[app.migrations]
[app.common.uuid :as uuid]
[app.services.mutations.projects :as projects]
[app.config]
[app.db :as db]
[app.media-storage]
[app.media]
[app.migrations]
[app.services.mutations.files :as files]
[app.services.mutations.media :as media])
(:import
[app.services.mutations.media :as media]
[app.services.mutations.projects :as projects]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[datoteka.core :as fs]
[mount.core :as mount])
#_(:import
java.io.PushbackReader))
;; --- Constants & Helpers

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

@ -10,14 +10,13 @@
(ns app.config
"A configuration management."
(:require
[app.common.spec :as us]
[app.common.version :as v]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[cuerdas.core :as str]
[environ.core :refer [env]]
[mount.core :refer [defstate]]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.util.time :as dt]))
[mount.core :refer [defstate]]))
(def defaults
{:http-server-port 6060
@ -41,6 +40,8 @@
:smtp-default-reply-to "no-reply@example.com"
:smtp-default-from "no-reply@example.com"
:host "devenv"
:allow-demo-users true
:registration-enabled true
:registration-domain-whitelist ""
@ -50,7 +51,7 @@
;; modification in order to make the file ellegible for
;; trimming. The value only supports s(econds) m(inutes) and
;; h(ours) as time unit.
:file-trimming-max-age "72h"
:file-trimming-threshold "72h"
;; LDAP auth disabled by default. Set ldap-auth-host to enable
;:ldap-auth-host "ldap.mysupercompany.com"
@ -79,6 +80,9 @@
(s/def ::media-uri ::us/string)
(s/def ::media-directory ::us/string)
(s/def ::secret-key ::us/string)
(s/def ::host ::us/string)
(s/def ::error-report-webhook ::us/string)
(s/def ::smtp-enabled ::us/boolean)
(s/def ::smtp-default-reply-to ::us/email)
(s/def ::smtp-default-from ::us/email)
@ -94,7 +98,9 @@
(s/def ::debug-humanize-transit ::us/boolean)
(s/def ::public-uri ::us/string)
(s/def ::backend-uri ::us/string)
(s/def ::image-process-max-threads ::us/integer)
(s/def ::file-trimming-threshold ::dt/duration)
(s/def ::google-client-id ::us/string)
(s/def ::google-client-secret ::us/string)
@ -115,7 +121,6 @@
(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 ::file-trimming-threshold ::dt/duration)
(s/def ::config
(s/keys :opt-un [::http-server-cors
@ -135,6 +140,7 @@
::assets-uri
::media-directory
::media-uri
::error-report-webhook
::secret-key
::smtp-default-from
::smtp-default-reply-to
@ -145,7 +151,8 @@
::smtp-password
::smtp-tls
::smtp-ssl
::file-trimming-max-age
::host
::file-trimming-threshold
::debug-humanize-transit
::allow-demo-users
::registration-enabled
@ -198,6 +205,9 @@
(def default-deletion-delay
(dt/duration {:hours 48}))
(def version
(delay (v/parse "%version%")))
(defn smtp
[cfg]
{:host (:smtp-host cfg "localhost")

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

@ -13,19 +13,15 @@
[app.common.geom.point :as gpt]
[app.config :as cfg]
[app.metrics :as mtx]
[app.util.data :as data]
[app.util.time :as dt]
[app.util.transit :as t]
[clojure.data.json :as json]
[clojure.spec.alpha :as s]
[clojure.string :as str]
[clojure.tools.logging :as log]
[lambdaisland.uri :refer [uri]]
[mount.core :as mount :refer [defstate]]
[next.jdbc :as jdbc]
[next.jdbc.date-time :as jdbc-dt]
[next.jdbc.optional :as jdbc-opt]
[next.jdbc.result-set :as jdbc-rs]
[next.jdbc.sql :as jdbc-sql]
[next.jdbc.sql.builder :as jdbc-bld])
(:import
@ -34,8 +30,8 @@
com.zaxxer.hikari.metrics.prometheus.PrometheusMetricsTrackerFactory
java.sql.Connection
java.sql.Savepoint
org.postgresql.jdbc.PgArray
org.postgresql.geometric.PGpoint
org.postgresql.jdbc.PgArray
org.postgresql.util.PGInterval
org.postgresql.util.PGobject))
@ -83,6 +79,8 @@
(jdbc-dt/read-as-instant)
(HikariDataSource. dsc)))
(declare pool)
(defstate pool
:start (create-pool cfg/config)
:stop (.close pool))
@ -221,15 +219,6 @@
:else
(ex/raise :type :not-implemented)))
(defn decode-pgobject
[^PGobject obj]
(let [typ (.getType obj)
val (.getValue obj)]
(if (or (= typ "json")
(= typ "jsonb"))
(json/read-str val)
val)))
(defn decode-json-pgobject
[^PGobject o]
(let [typ (.getType o)

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

@ -10,14 +10,11 @@
(ns app.emails
"Main api for send emails."
(:require
[clojure.spec.alpha :as s]
[promesa.core :as p]
[app.config :as cfg]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.db :as db]
[app.config :as cfg]
[app.tasks :as tasks]
[app.util.emails :as emails]))
[app.util.emails :as emails]
[clojure.spec.alpha :as s]))
;; --- Defaults

83
backend/src/app/error_reporter.clj Normal file
View file

@ -0,0 +1,83 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; 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.error-reporter
"A mattermost integration for error reporting."
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.config :as cfg]
[app.db :as db]
[app.tasks :as tasks]
[app.util.async :as aa]
[app.worker :as wrk]
[app.util.http :as http]
[clojure.core.async :as a]
[clojure.data.json :as json]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[cuerdas.core :as str]
[mount.core :as mount :refer [defstate]]
[promesa.exec :as px]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Public API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defonce enqueue identity)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- send-to-mattermost!
[log-event]
(try
(let [text (str/fmt "Unhandled exception: `host='%s'`, `version=%s`.\n@channel ⇊\n```%s\n```"
(:host cfg/config)
(:full @cfg/version)
(str log-event))
rsp (http/send! {:uri (:error-reporter-webhook cfg/config)
:method :post
:headers {"content-type" "application/json"}
:body (json/write-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))))
(catch Exception e
(log/warnf e "Unexpected exception on error reporter."))))
(defn- send!
[val]
(aa/thread-call wrk/executor (partial send-to-mattermost! val)))
(defn- start
[]
(let [qch (a/chan (a/sliding-buffer 128))]
(log/info "Starting error reporter loop.")
;; Only enable when a valid URL is provided.
(when (:error-reporter-webhook cfg/config)
(alter-var-root #'enqueue (constantly #(a/>!! qch %)))
(a/go-loop []
(let [val (a/<! qch)]
(if (nil? val)
(do
(log/info "Closing error reporting loop.")
(alter-var-root #'enqueue (constantly identity)))
(do
(a/<! (send! val))
(recur))))))
qch))
(defstate reporter
:start (start)
:stop (a/close! reporter))

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

@ -9,31 +9,29 @@
(ns app.http
(:require
[clojure.tools.logging :as log]
[mount.core :as mount :refer [defstate]]
[reitit.ring :as rring]
[ring.adapter.jetty9 :as jetty]
[app.config :as cfg]
[app.http.auth :as auth]
[app.http.auth.gitlab :as gitlab]
[app.http.auth.google :as google]
[app.http.auth.ldap :as ldap]
[app.http.debug :as debug]
[app.http.errors :as errors]
[app.http.handlers :as handlers]
[app.http.middleware :as middleware]
[app.http.session :as session]
[app.http.ws :as ws]
[app.metrics :as mtx]
[app.services.notifications :as usn]))
[clojure.tools.logging :as log]
[mount.core :as mount :refer [defstate]]
[reitit.ring :as rring]
[ring.adapter.jetty9 :as jetty]))
(defn- create-router
[]
(rring/router
[["/metrics" {:get mtx/dump}]
["/api" {:middleware [[middleware/format-response-body]
[middleware/errors errors/handle]
[middleware/parse-request-body]
[middleware/errors errors/handle]
[middleware/params]
[middleware/multipart-params]
[middleware/keyword-params]

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

@ -9,20 +9,18 @@
(ns app.http.auth
(:require
[app.common.exceptions :as ex]
[app.common.uuid :as uuid]
[app.http.session :as session]
[app.services.mutations :as sm]))
(defn login-handler
[req]
(let [data (:body-params req)
uagent (get-in req [:headers "user-agent"])]
(let [profile (sm/handle (assoc data ::sm/type :login))
id (session/create (:id profile) uagent)]
{:status 200
:cookies (session/cookies id)
:body profile})))
(let [data (:body-params req)
uagent (get-in req [:headers "user-agent"])
profile (sm/handle (assoc data ::sm/type :login))
id (session/create (:id profile) uagent)]
{:status 200
:cookies (session/cookies id)
:body profile}))
(defn logout-handler
[req]

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

@ -11,7 +11,6 @@
(:require
[app.common.exceptions :as ex]
[app.config :as cfg]
[app.db :as db]
[app.http.session :as session]
[app.services.mutations :as sm]
[app.services.tokens :as tokens]
@ -21,7 +20,6 @@
[clojure.tools.logging :as log]
[lambdaisland.uri :as uri]))
(def default-base-gitlab-uri "https://gitlab.com")
(def scope "read_user")
@ -100,7 +98,7 @@
nil))))
(defn auth
[req]
[_req]
(let [token (tokens/generate
{:iss :gitlab-oauth
:exp (dt/in-future "15m")})
@ -119,7 +117,7 @@
(defn callback
[req]
(let [token (get-in req [:params :state])
tdata (tokens/verify token {:iss :gitlab-oauth})
_ (tokens/verify token {:iss :gitlab-oauth})
info (some-> (get-in req [:params :code])
(get-access-token)
(get-user-info))]

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

@ -11,7 +11,6 @@
(:require
[app.common.exceptions :as ex]
[app.config :as cfg]
[app.db :as db]
[app.http.session :as session]
[app.services.mutations :as sm]
[app.services.tokens :as tokens]
@ -84,9 +83,8 @@
nil))))
(defn auth
[req]
(let [token (tokens/generate {:iss :google-oauth
:exp (dt/in-future "15m")})
[_req]
(let [token (tokens/generate {:iss :google-oauth :exp (dt/in-future "15m")})
params {:scope scope
:access_type "offline"
:include_granted_scopes true
@ -104,7 +102,7 @@
(defn callback
[req]
(let [token (get-in req [:params :state])
tdata (tokens/verify token {:iss :google-oauth})
_ (tokens/verify token {:iss :google-oauth})
info (some-> (get-in req [:params :code])
(get-access-token)
(get-user-info))]

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

@ -1,18 +1,29 @@
;; 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
[clj-ldap.client :as client]
[clojure.set :as set]
[mount.core :refer [defstate]]
[app.common.exceptions :as ex]
[app.config :as cfg]
[app.services.mutations :as sm]
[app.http.session :as session]
[clojure.tools.logging :as log]))
[app.common.exceptions :as ex]
[app.config :as cfg]
[app.http.session :as session]
[app.services.mutations :as sm]
[clj-ldap.client :as client]
[clojure.set :as set]
[clojure.string]
[clojure.tools.logging :as log]
[mount.core :refer [defstate]]))
(defn replace-several [s & {:as replacements}]
(reduce-kv clojure.string/replace s replacements))
(declare *ldap-pool)
(defstate *ldap-pool
:start (delay
(try

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

@ -1,24 +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.http.debug
"Debug related handlers."
(:require
[clojure.tools.logging :as log]
[promesa.core :as p]
[app.http.errors :as errors]
[app.http.session :as session]
[app.common.uuid :as uuid]))
(defn emails-list
[req]
{:status 200
:body "Hello world\n"})
(defn email
[req]
{:status 200
:body "Hello world\n"})

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

@ -2,43 +2,55 @@
;; 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) 2016-2019 Andrey Antukh <niwi@niwi.nz>
;; 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.errors
"A errors handling for the http server."
(:require
[app.common.exceptions :as ex]
[clojure.tools.logging :as log]
[cuerdas.core :as str]
[app.metrics :as mtx]
[io.aviso.exception :as e]))
[expound.alpha :as expound]))
(defmulti handle-exception
(fn [err & rest]
(:type (ex-data err))))
(fn [err & _rest]
(let [edata (ex-data err)]
(or (:type edata)
(class err)))))
(defmethod handle-exception :authorization
[err _]
{:status 403
:body (ex-data err)})
(defmethod handle-exception :validation
[err req]
(let [header (get-in req [:headers "accept"])
response (ex-data err)]
edata (ex-data err)]
(cond
(and (str/starts-with? header "text/html")
(= :spec-validation (:code response)))
(= :spec-validation (:code edata)))
{:status 400
:headers {"content-type" "text/html"}
:body (str "<pre style='font-size:16px'>" (:explain response) "</pre>\n")}
:body (str "<pre style='font-size:16px'>"
(with-out-str
(:data edata))
"</pre>\n")}
:else
{:status 400
:body response})))
:body edata})))
(defmethod handle-exception :ratelimit
[err req]
[_ _]
{:status 429
:headers {"retry-after" 1000}
:body ""})
(defmethod handle-exception :not-found
[err req]
[err _]
(let [response (ex-data err)]
{:status 404
:body response}))
@ -48,16 +60,43 @@
(handle-exception (.getCause ^Throwable err) req))
(defmethod handle-exception :parse
[err req]
[err _]
{:status 400
:body {:type :parse
:message (ex-message err)}})
(defn get-context-string
[err request]
(str
"=| uri: " (pr-str (:uri request)) "\n"
"=| method: " (pr-str (:request-method request)) "\n"
"=| path-params: " (pr-str (:path-params request)) "\n"
"=| query-params: " (pr-str (:query-params request)) "\n"
(when-let [bparams (:body-params request)]
(str "=| body-params: " (pr-str bparams) "\n"))
(when (ex/ex-info? err)
(str "=| ex-data: " (pr-str (ex-data err)) "\n"))
"\n"))
(defmethod handle-exception :assertion
[err request]
(let [{:keys [data] :as edata} (ex-data err)]
(log/errorf err
(str "Assertion error\n"
(get-context-string err request)
(with-out-str (expound/printer data))))
{:status 500
:body {:type :internal-error
:message "Assertion error"
:data (ex-data err)}}))
(defmethod handle-exception :default
[err req]
(log/error "Unhandled exception on request:" (:path req) "\n"
(with-out-str
(.printStackTrace ^Throwable err (java.io.PrintWriter. *out*))))
[err request]
(log/errorf err (str "Internal Error\n" (get-context-string err request)))
{:status 500
:body {:type :internal-error
:message (ex-message err)

45
backend/src/app/http/handlers.clj
View file

@ -9,6 +9,7 @@
(ns app.http.handlers
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.emails :as emails]
[app.http.session :as session]
@ -28,36 +29,40 @@
:login})
(defn query-handler
[req]
(let [type (keyword (get-in req [:path-params :type]))
data (merge (:params req)
{::sq/type type})
data (cond-> data
(:profile-id req) (assoc :profile-id (:profile-id req)))]
(if (or (:profile-id req) (contains? unauthorized-services type))
[{:keys [profile-id] :as request}]
(let [type (keyword (get-in request [:path-params :type]))
data (assoc (:params request) ::sq/type type)
data (if profile-id
(assoc data :profile-id profile-id)
(dissoc data :profile-id))]
(if (or (uuid? profile-id)
(contains? unauthorized-services type))
{:status 200
:body (sq/handle (with-meta data {:req req}))}
:body (sq/handle (with-meta data {:req request}))}
{:status 403
:body {:type :authentication
:code :unauthorized}})))
(defn mutation-handler
[req]
(let [type (keyword (get-in req [:path-params :type]))
data (merge (:params req)
(:body-params req)
(:uploads req)
{::sm/type type})
data (cond-> data
(:profile-id req) (assoc :profile-id (:profile-id req)))]
(if (or (:profile-id req) (contains? unauthorized-services type))
(let [result (sm/handle (with-meta data {:req req}))
[{:keys [profile-id] :as request}]
(let [type (keyword (get-in request [:path-params :type]))
data (d/merge (:params request)
(:body-params request)
(:uploads request)
{::sm/type type})
data (if profile-id
(assoc data :profile-id profile-id)
(dissoc data :profile-id))]
(if (or (uuid? profile-id)
(contains? unauthorized-services type))
(let [result (sm/handle (with-meta data {:req request}))
mdata (meta result)
resp {:status (if (nil? (seq result)) 204 200)
:body result}]
(cond->> resp
(:transform-response mdata) ((:transform-response mdata) req)))
(:transform-response mdata) ((:transform-response mdata) request)))
{:status 403
:body {:type :authentication
:code :unauthorized}})))

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

@ -5,20 +5,19 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2019-2020 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.http.middleware
(:require
[clojure.tools.logging :as log]
[app.common.exceptions :as ex]
[app.config :as cfg]
[app.metrics :as mtx]
[app.util.transit :as t]
[ring.middleware.cookies :refer [wrap-cookies]]
[ring.middleware.keyword-params :refer [wrap-keyword-params]]
[ring.middleware.multipart-params :refer [wrap-multipart-params]]
[ring.middleware.params :refer [wrap-params]]
[ring.middleware.resource :refer [wrap-resource]]
[app.metrics :as mtx]
[app.common.exceptions :as ex]
[app.config :as cfg]
[app.util.transit :as t]))
[ring.middleware.resource :refer [wrap-resource]]))
(defn- wrap-parse-request-body
[handler]
@ -126,13 +125,13 @@
(def development-cors
{:name ::development-cors
:compile (fn [& args]
:compile (fn [& _args]
(when *assert*
wrap-development-cors))})
(def development-resources
{:name ::development-resources
:compile (fn [& args]
:compile (fn [& _args]
(when *assert*
#(wrap-resource % "public")))})

12
backend/src/app/http/ws.clj
View file

@ -10,16 +10,14 @@
(ns app.http.ws
"Web Socket handlers"
(:require
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[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]]
[app.common.spec :as us]
[app.db :as db]
[app.http.session :refer [wrap-session]]
[app.services.notifications :as nf]))
[app.services.notifications :as nf]
[clojure.spec.alpha :as s]
[ring.middleware.cookies :refer [wrap-cookies]]
[ring.middleware.keyword-params :refer [wrap-keyword-params]]
[ring.middleware.params :refer [wrap-params]]))
(s/def ::file-id ::us/uuid)
(s/def ::session-id ::us/uuid)

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

@ -9,6 +9,8 @@
(ns app.main
(:require
[app.config :as cfg]
[clojure.tools.logging :as log]
[mount.core :as mount]))
(defn- enable-asserts
@ -25,16 +27,16 @@
;; --- Entry point
(defn run
[params]
(require 'app.config
[_params]
(require 'app.srepl.server
'app.services
'app.migrations
'app.worker
'app.media
'app.http)
(mount/start))
(mount/start)
(log/infof "Welcome to penpot! Version: '%s'." (:full @cfg/version)))
(defn -main
[& args]
[& _args]
(run {}))

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

@ -10,14 +10,11 @@
(ns app.media
"Media postprocessing."
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.media :as cm]
[app.common.spec :as us]
[app.config :as cfg]
[app.media-storage :as mst]
[app.util.http :as http]
[app.util.storage :as ust]
[clojure.core.async :as a]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
@ -25,11 +22,12 @@
[mount.core :refer [defstate]])
(:import
java.io.ByteArrayInputStream
java.io.InputStream
java.util.concurrent.Semaphore
org.im4java.core.ConvertCmd
org.im4java.core.Info
org.im4java.core.IMOperation))
org.im4java.core.IMOperation
org.im4java.core.Info))
(declare semaphore)
(defstate semaphore
:start (Semaphore. (:image-process-max-threads cfg/config 1)))
@ -73,7 +71,7 @@
;; http://www.imagemagick.org/Usage/thumbnails/
(defn- generic-process
[{:keys [input format quality operation] :as params}]
[{:keys [input format operation] :as params}]
(let [{:keys [path mtype]} input
format (or (cm/mtype->format mtype) format)
ext (cm/format->extension format)
@ -160,35 +158,6 @@
;; --- Utility functions
(defn resolve-urls
[row src dst]
(s/assert map? row)
(if (and src dst)
(let [src (if (vector? src) src [src])
dst (if (vector? dst) dst [dst])
value (get-in row src)]
(if (empty? value)
row
(let [url (ust/public-uri mst/media-storage value)]
(assoc-in row dst (str url)))))
row))
(defn- resolve-uri
[storage row src dst]
(let [src (if (vector? src) src [src])
dst (if (vector? dst) dst [dst])
value (get-in row src)]
(if (empty? value)
row
(let [url (ust/public-uri mst/media-storage value)]
(assoc-in row dst (str url))))))
(defn resolve-media-uris
[row & pairs]
(us/assert map? row)
(us/assert (s/coll-of vector?) pairs)
(reduce #(resolve-uri mst/media-storage %1 (nth %2 0) (nth %2 1)) row pairs))
(defn validate-media-type
[media-type]
(when-not (cm/valid-media-types media-type)
@ -196,6 +165,11 @@
:code :media-type-not-allowed
:hint "Seems like you are uploading an invalid media object")))
;; TODO: rewrite using jetty http client instead of jvm
;; builtin (because builtin http client uses a lot of memory for the
;; same operation.
(defn download-media-object
[url]
(let [result (http/get! url {:as :byte-array})

13
backend/src/app/media_storage.clj
View file

@ -5,24 +5,25 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2017-2020 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.media-storage
"A media storage impl for app."
(:require
[mount.core :refer [defstate]]
[clojure.java.io :as io]
[cuerdas.core :as str]
[datoteka.core :as fs]
[app.config :refer [config]]
[app.util.storage :as ust]
[app.config :refer [config]]))
[mount.core :refer [defstate]]))
;; --- State
(declare assets-storage)
(defstate assets-storage
:start (ust/create {:base-path (:assets-directory config)
:base-uri (:assets-uri config)}))
(declare media-storage)
(defstate media-storage
:start (ust/create {:base-path (:media-directory config)
:base-uri (:media-uri config)

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

@ -8,9 +8,6 @@
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.metrics
(:require
[clojure.tools.logging :as log]
[cuerdas.core :as str])
(:import
io.prometheus.client.CollectorRegistry
io.prometheus.client.Counter
@ -172,7 +169,7 @@
(assoc mdata ::summary-original original)))))))
(defn dump
[& args]
[& _args]
(let [samples (.metricFamilySamples ^CollectorRegistry registry)
writer (StringWriter.)]
(TextFormat/write004 writer samples)

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

@ -9,11 +9,10 @@
(ns app.migrations
(:require
[mount.core :as mount :refer [defstate]]
[app.db :as db]
[app.config :as cfg]
[app.migrations.migration-0023 :as mg0023]
[app.util.migrations :as mg]))
[app.util.migrations :as mg]
[mount.core :as mount :refer [defstate]]))
(def +migrations+
{:name "uxbox-main"
@ -110,6 +109,15 @@
{:name "0031-add-conversation-related-tables"
:fn (mg/resource "app/migrations/sql/0031-add-conversation-related-tables.sql")}
{:name "0032-del-unused-tables"
:fn (mg/resource "app/migrations/sql/0032-del-unused-tables.sql")}
{:name "0033-mod-comment-thread-table"
:fn (mg/resource "app/migrations/sql/0033-mod-comment-thread-table.sql")}
{:name "0034-mod-profile-table-add-props-field"
:fn (mg/resource "app/migrations/sql/0034-mod-profile-table-add-props-field.sql")}
]})
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

3
backend/src/app/migrations/sql/0032-del-unused-tables.sql Normal file
View file

@ -0,0 +1,3 @@
DROP TABLE color;
DROP TABLE page_change;
DROP TABLE page_version;

2
backend/src/app/migrations/sql/0033-mod-comment-thread-table.sql Normal file
View file

@ -0,0 +1,2 @@
ALTER TABLE comment_thread
ADD COLUMN page_name text NULL;

1
backend/src/app/migrations/sql/0034-mod-profile-table-add-props-field.sql Normal file
View file

@ -0,0 +1 @@
ALTER TABLE profile ADD COLUMN props jsonb NULL DEFAULT NULL;

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

@ -7,13 +7,9 @@
(ns app.redis
(:refer-clojure :exclude [run!])
(:require
[clojure.tools.logging :as log]
[lambdaisland.uri :refer [uri]]
[mount.core :as mount :refer [defstate]]
[app.common.exceptions :as ex]
[app.config :as cfg]
[app.util.data :as data]
[app.util.redis :as redis])
[app.util.redis :as redis]
[mount.core :as mount :refer [defstate]])
(:import
java.lang.AutoCloseable))
@ -24,10 +20,14 @@
(let [uri (:redis-uri config "redis://redis/0")]
(redis/client uri)))
(declare client)
(defstate client
:start (create-client cfg/config)
:stop (.close ^AutoCloseable client))
(declare conn)
(defstate conn
:start (redis/connect client)
:stop (.close ^AutoCloseable conn))

43
backend/src/app/services.clj Normal file
View file

@ -0,0 +1,43 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; 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.services
"A initialization of services."
(:require
[app.services.middleware :as middleware]
[app.util.dispatcher :as uds]
[mount.core :as mount :refer [defstate]]))
;; --- Initialization
(defn- load-query-services
[]
(require 'app.services.queries.projects)
(require 'app.services.queries.files)
(require 'app.services.queries.comments)
(require 'app.services.queries.profile)
(require 'app.services.queries.recent-files)
(require 'app.services.queries.viewer))
(defn- load-mutation-services
[]
(require 'app.services.mutations.demo)
(require 'app.services.mutations.media)
(require 'app.services.mutations.projects)
(require 'app.services.mutations.files)
(require 'app.services.mutations.comments)
(require 'app.services.mutations.profile)
(require 'app.services.mutations.viewer)
(require 'app.services.mutations.verify-token))
(defstate query-services
:start (load-query-services))
(defstate mutation-services
:start (load-mutation-services))

32
backend/src/app/services/init.clj
View file

@ -7,34 +7,4 @@
;;
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.services.init
"A initialization of services."
(:require
[mount.core :as mount :refer [defstate]]))
(defn- load-query-services
[]
(require 'app.services.queries.media)
(require 'app.services.queries.projects)
(require 'app.services.queries.files)
(require 'app.services.queries.comments)
(require 'app.services.queries.profile)
(require 'app.services.queries.recent-files)
(require 'app.services.queries.viewer))
(defn- load-mutation-services
[]
(require 'app.services.mutations.demo)
(require 'app.services.mutations.media)
(require 'app.services.mutations.projects)
(require 'app.services.mutations.files)
(require 'app.services.mutations.comments)
(require 'app.services.mutations.profile)
(require 'app.services.mutations.viewer)
(require 'app.services.mutations.verify-token))
(defstate query-services
:start (load-query-services))
(defstate mutation-services
:start (load-mutation-services))
(ns app.services.init)

10
backend/src/app/services/middleware.clj
View file

@ -10,13 +10,11 @@
(ns app.services.middleware
"Common middleware for services."
(:require
[clojure.tools.logging :as log]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[expound.alpha :as expound]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.metrics :as mtx]))
[app.metrics :as mtx]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]))
(defn wrap-spec
[handler]
@ -45,7 +43,7 @@
(defn- get-prefix
[nsname]
(let [[a b c] (str/split nsname ".")]
(let [[_ _ c] (str/split nsname ".")]
c))
(defn wrap-metrics

82
backend/src/app/services/mutations/comments.clj
View file

@ -9,32 +9,27 @@
(ns app.services.mutations.comments
(:require
[clojure.spec.alpha :as s]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.services.mutations :as sm]
[app.services.queries.projects :as proj]
[app.services.queries.files :as files]
[app.services.queries.comments :as comments]
[app.tasks :as tasks]
[app.services.queries.files :as files]
[app.util.blob :as blob]
[app.util.storage :as ust]
[app.util.transit :as t]
[app.util.time :as dt]))
[app.util.time :as dt]
[clojure.spec.alpha :as s]))
;; --- Mutation: Create Comment Thread
(declare upsert-comment-thread-status!)
(declare create-comment-thread)
(declare retrieve-page-name)
(s/def ::page-id ::us/uuid)
(s/def ::file-id ::us/uuid)
(s/def ::profile-id ::us/uuid)
(s/def ::position ::us/point)
(s/def ::content ::us/string)
(s/def ::page-id ::us/uuid)
(s/def ::create-comment-thread
(s/keys :req-un [::profile-id ::file-id ::position ::content ::page-id]))
@ -53,25 +48,28 @@
(defn- create-comment-thread*
[conn {:keys [profile-id file-id page-id position content] :as params}]
(let [seqn (retrieve-next-seqn conn file-id)
now (dt/now)
(let [seqn (retrieve-next-seqn conn file-id)
now (dt/now)
pname (retrieve-page-name conn params)
thread (db/insert! conn :comment-thread
{:file-id file-id
:owner-id profile-id
:participants (db/tjson #{profile-id})
:page-name pname
:page-id page-id
:created-at now
:modified-at now
:seqn seqn
:position (db/pgpoint position)})
;; Create a comment entry
comment (db/insert! conn :comment
{:thread-id (:id thread)
:owner-id profile-id
:created-at now
:modified-at now
:content content})]
:position (db/pgpoint position)})]
;; Create a comment entry
(db/insert! conn :comment
{:thread-id (:id thread)
:owner-id profile-id
:created-at now
:modified-at now
:content content})
;; Make the current thread as read.
(upsert-comment-thread-status! conn profile-id (:id thread))
@ -81,10 +79,7 @@
{:comment-thread-seqn seqn}
{:id file-id})
(-> (assoc thread
:content content
:comment comment)
(comments/decode-row))))
(select-keys thread [:id :file-id :page-id])))
(defn- create-comment-thread
[conn params]
@ -104,6 +99,12 @@
:else res))))
(defn- retrieve-page-name
[conn {:keys [file-id page-id]}]
(let [{:keys [data]} (db/get-by-id conn :file file-id)
data (blob/decode data)]
(get-in data [:pages-index page-id :name])))
;; --- Mutation: Update Comment Thread Status
@ -164,14 +165,21 @@
[{:keys [profile-id thread-id content] :as params}]
(db/with-atomic [conn db/pool]
(let [thread (-> (db/get-by-id conn :comment-thread thread-id {:for-update true})
(comments/decode-row))]
(comments/decode-row))
pname (retrieve-page-name conn thread)]
;; Standard Checks
(when-not thread
(ex/raise :type :not-found))
(when-not thread (ex/raise :type :not-found))
;; Permission Checks
(files/check-read-permissions! conn profile-id (:file-id thread))
;; Update the page-name cachedattribute on comment thread table.
(when (not= pname (:page-name thread))
(db/update! conn :comment-thread
{:page-name pname}
{:id thread-id}))
;; NOTE: is important that all timestamptz related fields are
;; created or updated on the database level for avoid clock
;; inconsistencies (some user sees something read that is not
@ -216,15 +224,24 @@
(let [comment (db/get-by-id conn :comment id {:for-update true})
_ (when-not comment (ex/raise :type :not-found))
thread (db/get-by-id conn :comment-thread (:thread-id comment) {:for-update true})
_ (when-not thread (ex/raise :type :not-found))]
_ (when-not thread (ex/raise :type :not-found))
pname (retrieve-page-name conn thread)]
(files/check-read-permissions! conn profile-id (:file-id thread))
;; Don't allow edit comments to not owners
(when-not (= (:owner-id thread) profile-id)
(ex/raise :type :validation
:code :not-allowed))
(db/update! conn :comment
{:content content
:modified-at (dt/now)}
{:id (:id comment)})
(db/update! conn :comment-thread
{:modified-at (dt/now)}
{:modified-at (dt/now)
:page-name pname}
{:id (:id thread)})
nil)))
@ -237,13 +254,14 @@
(sm/defmutation ::delete-comment-thread
[{:keys [profile-id id] :as params}]
(db/with-atomic [conn db/pool]
(let [cthr (db/get-by-id conn :comment-thread id {:for-update true})]
(when-not (= (:owner-id cthr) profile-id)
(let [thread (db/get-by-id conn :comment-thread id {:for-update true})]
(when-not (= (:owner-id thread) profile-id)
(ex/raise :type :validation
:code :not-allowed))
(db/delete! conn :comment-thread {:id id})
nil)))
;; --- Mutation: Delete comment
(s/def ::delete-comment

9
backend/src/app/services/mutations/demo.clj
View file

@ -10,17 +10,14 @@
(ns app.services.mutations.demo
"A demo specific mutations."
(:require
[clojure.spec.alpha :as s]
[buddy.core.codecs :as bc]
[buddy.core.nonce :as bn]
[app.common.exceptions :as ex]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.services.mutations :as sm]
[app.services.mutations.profile :as profile]
[app.tasks :as tasks]
[app.common.uuid :as uuid]
[app.util.time :as tm]))
[buddy.core.codecs :as bc]
[buddy.core.nonce :as bn]))
(sm/defmutation ::create-demo-profile
[_]

31
backend/src/app/services/mutations/files.clj
View file

@ -9,25 +9,22 @@
(ns app.services.mutations.files
(:require
[clojure.spec.alpha :as s]
[datoteka.core :as fs]
[promesa.core :as p]
[app.common.exceptions :as ex]
[app.common.pages :as cp]
[app.common.pages-migrations :as pmg]
[app.common.pages.migrations :as pmg]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.redis :as redis]
[app.services.mutations :as sm]
[app.services.queries.projects :as proj]
[app.services.queries.files :as files]
[app.services.queries.projects :as proj]
[app.tasks :as tasks]
[app.util.blob :as blob]
[app.util.storage :as ust]
[app.util.time :as dt]
[app.util.transit :as t]
[app.util.time :as dt]))
[clojure.spec.alpha :as s]))
;; --- Helpers & Specs
@ -62,7 +59,7 @@
:can-edit true}))
(defn create-file
[conn {:keys [id profile-id name project-id is-shared]
[conn {:keys [id name project-id is-shared]
:or {is-shared false}
:as params}]
(let [id (or id (uuid/next))
@ -162,11 +159,14 @@
(files/check-edition-permissions! conn profile-id file-id)
(link-file-to-library conn params)))
(def sql:link-file-to-library
"insert into file_library_rel (file_id, library_file_id)
values (?, ?)
on conflict do nothing;")
(defn- link-file-to-library
[conn {:keys [file-id library-id] :as params}]
(db/insert! conn :file-library-rel
{:file-id file-id
:library-file-id library-id}))
(db/exec-one! conn [sql:link-file-to-library file-id library-id]))
;; --- Mutation: Unlink file from library
@ -248,7 +248,8 @@
:add-media :mod-media :del-media
:add-component :mod-component :del-component
:add-typography :mod-typography :del-typography} (:type change))
(and (= (:type change) :mod-obj)
(and (#{:add-obj :mod-obj :del-obj
:reg-objects :mov-objects} (:type change))
(some? (:component-id change)))))
(declare update-file)
@ -282,7 +283,7 @@
(assoc :changes (blob/encode changes)
:session-id sid))
chng (insert-change conn file)
_ (insert-change conn file)
msg {:type :file-change
:profile-id (:profile-id params)
:file-id (:id file)
@ -315,7 +316,7 @@
:data (:data file)}
{:id (:id file)})
(retrieve-lagged-changes conn chng params)))
(retrieve-lagged-changes conn params)))
(defn- insert-change
[conn {:keys [revn data changes session-id] :as file}]
@ -339,7 +340,7 @@
order by s.created_at asc")
(defn- retrieve-lagged-changes
[conn snapshot params]
[conn params]
(->> (db/exec! conn [sql:lagged-changes (:id params) (:revn params)])
(mapv files/decode-row)))

71
backend/src/app/services/mutations/media.clj
View file

@ -9,21 +9,18 @@
(ns app.services.mutations.media
(:require
[clojure.spec.alpha :as s]
[datoteka.core :as fs]
[app.common.media :as cm]
[app.common.exceptions :as ex]
[app.common.media :as cm]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.media :as media]
[app.media-storage :as mst]
[app.services.mutations :as sm]
[app.services.queries.teams :as teams]
[app.tasks :as tasks]
[app.media-storage :as mst]
[app.util.storage :as ust]
[app.util.time :as dt]))
[clojure.spec.alpha :as s]
[datoteka.core :as fs]))
(def thumbnail-options
{:width 100
@ -38,7 +35,6 @@
(s/def ::team-id ::us/uuid)
(s/def ::url ::us/url)
;; --- Create Media object (Upload and create from url)
(declare create-media-object)
@ -51,20 +47,20 @@
(s/def ::add-media-object-from-url
(s/keys :req-un [::profile-id ::file-id ::is-local ::url]
:opt-un [::id]))
:opt-un [::id ::name]))
(s/def ::upload-media-object
(s/keys :req-un [::profile-id ::file-id ::is-local ::name ::content]
:opt-un [::id]))
(sm/defmutation ::add-media-object-from-url
[{:keys [profile-id file-id url] :as params}]
[{:keys [profile-id file-id url name] :as params}]
(db/with-atomic [conn db/pool]
(let [file (select-file-for-update conn file-id)]
(teams/check-edition-permissions! conn profile-id (:team-id file))
(let [content (media/download-media-object url)
params' (merge params {:content content
:name (:filename content)})]
:name (or name (:filename content))})]
(create-media-object conn params')))))
(sm/defmutation ::upload-media-object
@ -147,56 +143,3 @@
(-> thumb
(dissoc :data :input)
(assoc :path path))))
;; --- Mutation: Rename Media object
(declare select-media-object-for-update)
(s/def ::rename-media-object
(s/keys :req-un [::id ::profile-id ::name]))
(sm/defmutation ::rename-media-object
[{:keys [id profile-id name] :as params}]
(db/with-atomic [conn db/pool]
(let [obj (select-media-object-for-update conn id)]
(teams/check-edition-permissions! conn profile-id (:team-id obj))
(db/update! conn :media-object
{:name name}
{:id id}))))
(def ^:private sql:select-media-object-for-update
"select obj.*,
p.team_id as team_id
from media_object as obj
inner join file as f on (f.id = obj.file_id)
inner join project as p on (p.id = f.project_id)
where obj.id = ?
for update of obj")
(defn- select-media-object-for-update
[conn id]
(let [row (db/exec-one! conn [sql:select-media-object-for-update id])]
(when-not row
(ex/raise :type :not-found))
row))
;; --- Delete Media object
(s/def ::delete-media-object
(s/keys :req-un [::id ::profile-id]))
(sm/defmutation ::delete-media-object
[{:keys [profile-id id] :as params}]
(db/with-atomic [conn db/pool]
(let [obj (select-media-object-for-update conn id)]
(teams/check-edition-permissions! conn profile-id (:team-id obj))
;; Schedule object deletion
(tasks/submit! conn {:name "delete-object"
:delay cfg/default-deletion-delay
:props {:id id :type :media-object}})
(db/update! conn :media-object
{:deleted-at (dt/now)}
{:id id})
nil)))

55
backend/src/app/services/mutations/profile.clj
View file

@ -10,27 +10,24 @@
(ns app.services.mutations.profile
(:require
[app.common.exceptions :as ex]
[app.common.media :as cm]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.emails :as emails]
[app.media :as media]
[app.media-storage :as mst]
[app.http.session :as session]
[app.media :as media]
[app.services.mutations :as sm]
[app.services.mutations.projects :as projects]
[app.services.mutations.teams :as teams]
[app.services.mutations.verify-token :refer [process-token]]
[app.services.queries.profile :as profile]
[app.services.tokens :as tokens]
[app.services.mutations.verify-token :refer [process-token]]
[app.tasks :as tasks]
[app.util.blob :as blob]
[app.util.storage :as ust]
[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
@ -142,11 +139,20 @@
(defn- derive-password
[password]
(hashers/derive password {:alg :bcrypt+sha512}))
(hashers/derive password
{:alg :argon2id
:memory 16384
:iterations 20
:parallelism 2}))
(defn- verify-password
[attempt password]
(hashers/verify attempt password))
(try
(hashers/verify attempt password)
(catch Exception e
(log/warnf e "Error on verify password (only informative, nothing affected to user).")
{:update false
:valid false})))
(defn- create-profile
"Create the profile entry on the database with limited input
@ -274,7 +280,7 @@
(defn- validate-password!
[conn {:keys [profile-id old-password] :as params}]
(let [profile (profile/retrieve-profile-data conn profile-id)]
(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))))
@ -304,7 +310,7 @@
[{:keys [profile-id file] :as params}]
(media/validate-media-type (:content-type file))
(db/with-atomic [conn db/pool]
(let [profile (profile/retrieve-profile conn profile-id)
(let [profile (db/get-by-id conn :profile profile-id)
_ (media/run {:cmd :info :input {:path (:tempfile file)
:mtype (:content-type file)}})
photo (teams/upload-photo conn params)]
@ -361,7 +367,7 @@
(sm/defmutation ::request-profile-recovery
[{:keys [email] :as params}]
(letfn [(create-recovery-token [conn {:keys [id] :as profile}]
(letfn [(create-recovery-token [{:keys [id] :as profile}]
(let [token (tokens/generate
{:iss :password-recovery
:exp (dt/in-future "15m")
@ -377,7 +383,7 @@
(db/with-atomic [conn db/pool]
(some->> email
(profile/retrieve-profile-data-by-email conn)
(create-recovery-token conn)
(create-recovery-token)
(send-email-notification conn))
nil)))
@ -390,7 +396,7 @@
(sm/defmutation ::recover-profile
[{:keys [token password]}]
(letfn [(validate-token [conn token]
(letfn [(validate-token [token]
(let [tdata (tokens/verify token {:iss :password-recovery})]
(:profile-id tdata)))
@ -399,10 +405,31 @@
(db/update! conn :profile {:password pwd} {:id profile-id})))]
(db/with-atomic [conn db/pool]
(->> (validate-token conn token)
(->> (validate-token token)
(update-password conn))
nil)))
;; --- Mutation: Update Profile Props
(s/def ::props map?)
(s/def ::update-profile-props
(s/keys :req-un [::profile-id ::props]))
(sm/defmutation ::update-profile-props
[{:keys [profile-id props]}]
(db/with-atomic [conn db/pool]
(let [profile (profile/retrieve-profile-data conn profile-id)
props (reduce-kv (fn [props k v]
(if (nil? v)
(dissoc props k)
(assoc props k v)))
(:props profile)
props)]
(db/update! conn :profile
{:props (db/tjson props)}
{:id profile-id})
nil)))
;; --- Mutation: Delete Profile

19
backend/src/app/services/mutations/projects.clj
View file

@ -5,12 +5,10 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2019-2020 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.services.mutations.projects
(:require
[clojure.spec.alpha :as s]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cfg]
@ -18,7 +16,7 @@
[app.services.mutations :as sm]
[app.services.queries.projects :as proj]
[app.tasks :as tasks]
[app.util.blob :as blob]))
[clojure.spec.alpha :as s]))
;; --- Helpers & Specs
@ -48,7 +46,7 @@
(assoc proj :is-pinned true))))
(defn create-project
[conn {:keys [id profile-id team-id name default?] :as params}]
[conn {:keys [id team-id name default?] :as params}]
(let [id (or id (uuid/next))
default? (if (boolean? default?) default? false)]
(db/insert! conn :project
@ -107,11 +105,10 @@
(sm/defmutation ::rename-project
[{:keys [id profile-id name] :as params}]
(db/with-atomic [conn db/pool]
(let [project (db/get-by-id conn :project id {:for-update true})]
(proj/check-edition-permissions! conn profile-id id)
(db/update! conn :project
{:name name}
{:id id}))))
(proj/check-edition-permissions! conn profile-id id)
(db/update! conn :project
{:name name}
{:id id})))
;; --- Mutation: Delete Project
@ -139,6 +136,6 @@
returning id")
(defn mark-project-deleted
[conn {:keys [id profile-id] :as params}]
[conn {:keys [id] :as params}]
(db/exec! conn [sql:mark-project-deleted id])
nil)

6
backend/src/app/services/mutations/teams.clj
View file

@ -20,9 +20,9 @@
[app.media-storage :as mst]
[app.services.mutations :as sm]
[app.services.mutations.projects :as projects]
[app.services.queries.profile :as profile]
[app.services.queries.teams :as teams]
[app.services.tokens :as tokens]
[app.services.queries.profile :as profile]
[app.tasks :as tasks]
[app.util.storage :as ust]
[app.util.time :as dt]
@ -58,7 +58,7 @@
team)))
(defn create-team
[conn {:keys [id profile-id name default?] :as params}]
[conn {:keys [id name default?] :as params}]
(let [id (or id (uuid/next))
default? (if (boolean? default?) default? false)]
(db/insert! conn :team
@ -268,7 +268,7 @@
(assoc team :photo (str photo)))))
(defn upload-photo
[conn {:keys [file profile-id]}]
[_conn {:keys [file]}]
(let [prefix (-> (bn/random-bytes 8)
(bc/bytes->b64u)
(bc/bytes->str))

39
backend/src/app/services/mutations/verify_token.clj
View file

@ -10,28 +10,16 @@
(ns app.services.mutations.verify-token
(:require
[app.common.exceptions :as ex]
[app.common.media :as cm]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.emails :as emails]
[app.http.session :as session]
[app.media :as media]
[app.media-storage :as mst]
[app.services.mutations :as sm]
[app.services.mutations.teams :as teams]
[app.services.queries.profile :as profile]
[app.services.tokens :as tokens]
[app.tasks :as tasks]
[app.util.blob :as blob]
[app.util.storage :as ust]
[app.util.time :as dt]
[buddy.hashers :as hashers]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]))
[clojure.spec.alpha :as s]))
(defmulti process-token (fn [conn params claims] (:iss claims)))
(defmulti process-token (fn [_ _ claims] (:iss claims)))
(s/def ::verify-token
(s/keys :req-un [::token]
@ -44,18 +32,17 @@
(process-token conn params claims))))
(defmethod process-token :change-email
[conn params {:keys [profile-id email] :as claims}]
(let [profile (db/get-by-id conn :profile profile-id {:for-update true})]
(when (profile/retrieve-profile-data-by-email conn email)
(ex/raise :type :validation
:code :email-already-exists))
(db/update! conn :profile
{:email email}
{:id profile-id})
claims))
[conn _params {:keys [profile-id email] :as claims}]
(when (profile/retrieve-profile-data-by-email conn email)
(ex/raise :type :validation
:code :email-already-exists))
(db/update! conn :profile
{:email email}
{:id profile-id})
claims)
(defmethod process-token :verify-email
[conn params {:keys [profile-id] :as claims}]
[conn _params {:keys [profile-id] :as claims}]
(let [profile (db/get-by-id conn :profile profile-id {:for-update true})]
(when (:is-active profile)
(ex/raise :type :validation
@ -71,7 +58,7 @@
claims))
(defmethod process-token :auth
[conn params {:keys [profile-id] :as claims}]
[conn _params {:keys [profile-id] :as claims}]
(let [profile (profile/retrieve-profile conn profile-id)]
(assoc claims :profile profile)))
@ -137,7 +124,7 @@
;; --- Default
(defmethod process-token :default
[conn params claims]
[_ _ _]
(ex/raise :type :validation
:code :invalid-token))

3
backend/src/app/services/mutations/viewer.clj
View file

@ -9,10 +9,7 @@
(ns app.services.mutations.viewer
(:require
[app.common.exceptions :as ex]
[app.common.pages :as cp]
[app.common.spec :as us]
[app.config :as cfg]
[app.db :as db]
[app.services.mutations :as sm]
[app.services.queries.files :as files]

27
backend/src/app/services/notifications.clj
View file

@ -10,17 +10,13 @@
(ns app.services.notifications
"A websocket based notifications mechanism."
(:require
[app.common.exceptions :as ex]
[app.common.uuid :as uuid]
[app.db :as db]
[app.metrics :as mtx]
[app.redis :as redis]
[app.util.async :as aa]
[app.util.time :as dt]
[app.util.transit :as t]
[clojure.core.async :as a]
[clojure.tools.logging :as log]
[promesa.core :as p]
[ring.adapter.jetty9 :as jetty]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -40,7 +36,7 @@
:help "A total number of messages handled by the notifications service."}))
(defn websocket
[{:keys [file-id team-id profile-id] :as params}]
[{:keys [file-id team-id] :as params}]
(let [in (a/chan 32)
out (a/chan 32)]
{:on-connect
@ -62,18 +58,18 @@
(a/close! sub))))
:on-error
(fn [conn e]
(fn [_conn _e]
(a/close! out)
(a/close! in))
:on-close
(fn [conn status-code reason]
(fn [_conn _status _reason]
(metrics-active-connections :dec)
(a/close! out)
(a/close! in))
:on-text
(fn [ws message]
(fn [_ws message]
(metrics-message-counter :inc)
(let [message (t/decode-str message)]
(a/>!! in message)))
@ -165,8 +161,7 @@
(defn- update-presence
[file-id session-id profile-id]
(aa/thread-try
(let [now (dt/now)
sql [sql:update-presence file-id session-id profile-id]]
(let [sql [sql:update-presence file-id session-id profile-id]]
(db/exec-one! db/pool sql))))
(defn- delete-presence
@ -177,13 +172,13 @@
:session-id session-id})))
(defmulti handle-message
(fn [ws message] (:type 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 output] :as ws} message]
[{:keys [file-id profile-id session-id] :as ws} _message]
(log/debugf "profile '%s' is connected to file '%s'" profile-id file-id)
(aa/go-try
(aa/<? (update-presence file-id session-id profile-id))
@ -191,7 +186,7 @@
(aa/<? (publish file-id {:type :presence :sessions members})))))
(defmethod handle-message :disconnect
[{:keys [profile-id file-id session-id] :as ws} message]
[{:keys [profile-id file-id session-id] :as ws} _message]
(log/debugf "profile '%s' is disconnected from '%s'" profile-id file-id)
(aa/go-try
(aa/<? (delete-presence file-id session-id profile-id))
@ -199,7 +194,7 @@
(aa/<? (publish file-id {:type :presence :sessions members})))))
(defmethod handle-message :keepalive
[{:keys [profile-id file-id session-id] :as ws} message]
[{:keys [profile-id file-id session-id] :as ws} _message]
(update-presence file-id session-id profile-id))
(defmethod handle-message :pointer-update
@ -210,6 +205,6 @@
(publish file-id message)))
(defmethod handle-message :default
[ws message]
[_ws message]
(a/go
(log/warnf "received unexpected message: " message)))
(log/warnf "received unexpected message: %s" message)))

68
backend/src/app/services/queries/comments.clj
View file

@ -9,18 +9,12 @@
(ns app.services.queries.comments
(: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.services.queries :as sq]
[app.services.queries.files :as files]
[app.util.time :as dt]
[app.util.transit :as t]
[clojure.spec.alpha :as s]
[datoteka.core :as fs]
[promesa.core :as p]))
[app.services.queries.teams :as teams]
[clojure.spec.alpha :as s]))
(defn decode-row
[{:keys [participants position] :as row}]
@ -32,9 +26,13 @@
(declare retrieve-comment-threads)
(s/def ::team-id ::us/uuid)
(s/def ::file-id ::us/uuid)
(s/def ::comment-threads
(s/keys :req-un [::profile-id ::file-id]))
(s/and (s/keys :req-un [::profile-id]
:opt-un [::file-id ::team-id])
#(or (:file-id %) (:team-id %))))
(sq/defquery ::comment-threads
[{:keys [profile-id file-id] :as params}]
@ -45,6 +43,8 @@
(def sql:comment-threads
"select distinct on (ct.id)
ct.*,
f.name as file_name,
f.project_id as project_id,
first_value(c.content) over w as content,
(select count(1)
from comment as c
@ -55,6 +55,7 @@
and c.created_at >= coalesce(cts.modified_at, ct.created_at)) as count_unread_comments
from comment_thread as ct
inner join comment as c on (c.thread_id = ct.id)
inner join file as f on (f.id = ct.file_id)
left join comment_thread_status as cts
on (cts.thread_id = ct.id and
cts.profile_id = ?)
@ -63,9 +64,58 @@
(defn- retrieve-comment-threads
[conn {:keys [profile-id file-id]}]
(files/check-read-permissions! conn profile-id file-id)
(->> (db/exec! conn [sql:comment-threads profile-id file-id])
(into [] (map decode-row))))
;; --- Query: Unread Comment Threads
(declare retrieve-unread-comment-threads)
(s/def ::team-id ::us/uuid)
(s/def ::unread-comment-threads
(s/keys :req-un [::profile-id ::team-id]))
(sq/defquery ::unread-comment-threads
[{:keys [profile-id team-id] :as params}]
(with-open [conn (db/open)]
(teams/check-read-permissions! conn profile-id team-id)
(retrieve-unread-comment-threads conn params)))
(def sql:comment-threads-by-team
"select distinct on (ct.id)
ct.*,
f.name as file_name,
f.project_id as project_id,
first_value(c.content) over w as content,
(select count(1)
from comment as c
where c.thread_id = ct.id) as count_comments,
(select count(1)
from comment as c
where c.thread_id = ct.id
and c.created_at >= coalesce(cts.modified_at, ct.created_at)) as count_unread_comments
from comment_thread as ct
inner join comment as c on (c.thread_id = ct.id)
inner join file as f on (f.id = ct.file_id)
inner join project as p on (p.id = f.project_id)
left join comment_thread_status as cts
on (cts.thread_id = ct.id and
cts.profile_id = ?)
where p.team_id = ?
window w as (partition by c.thread_id order by c.created_at asc)")
(def sql:unread-comment-threads-by-team
(str "with threads as (" sql:comment-threads-by-team ")"
"select * from threads where count_unread_comments > 0"))
(defn retrieve-unread-comment-threads
[conn {:keys [profile-id team-id]}]
(->> (db/exec! conn [sql:unread-comment-threads-by-team profile-id team-id])
(into [] (map decode-row))))
;; --- Query: Single Comment Thread
(s/def ::id ::us/uuid)

49
backend/src/app/services/queries/files.clj
View file

@ -5,20 +5,18 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2019-2020 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.services.queries.files
(:require
[clojure.spec.alpha :as s]
[promesa.core :as p]
[app.common.pages-migrations :as pmg]
[app.common.exceptions :as ex]
[app.common.pages.migrations :as pmg]
[app.common.spec :as us]
[app.db :as db]
[app.media :as media]
[app.services.queries :as sq]
[app.services.queries.projects :as projects]
[app.util.blob :as blob]))
[app.util.blob :as blob]
[clojure.spec.alpha :as s]))
(declare decode-row)
(declare decode-row-xf)
@ -185,48 +183,11 @@
(let [file (retrieve-file conn file-id)]
(get-in file [:data :pages-index id]))))
;; --- Query: File users
(def ^:private sql:file-users
"select pf.id, pf.fullname, pf.photo
from profile as pf
inner join file_profile_rel as fpr on (fpr.profile_id = pf.id)
where fpr.file_id = ?
union
select pf.id, pf.fullname, pf.photo
from profile as pf
inner join team_profile_rel as tpr on (tpr.profile_id = pf.id)
inner join project as p on (tpr.team_id = p.team_id)
inner join file as f on (p.id = f.project_id)
where f.id = ?")
(defn retrieve-file-users
[conn id]
(->> (db/exec! conn [sql:file-users id id])
(mapv #(media/resolve-media-uris % [:photo :photo-uri]))))
(s/def ::file-users
(s/keys :req-un [::profile-id ::id]))
(sq/defquery ::file-users
[{:keys [profile-id id] :as params}]
(db/with-atomic [conn db/pool]
(check-edition-permissions! conn profile-id id)
(retrieve-file-users conn id)))
;; --- Query: Shared Library Files
;; TODO: remove the counts, because they are no longer needed.
(def ^:private sql:shared-files
"select f.*,
(select count(*) from color as c
where c.file_id = f.id
and c.deleted_at is null) as colors_count,
(select count(*) from media_object as m
where m.file_id = f.id
and m.is_local = false
and m.deleted_at is null) as graphics_count
"select f.*
from file as f
inner join project as p on (p.id = f.project_id)
where f.is_shared = true

109
backend/src/app/services/queries/media.clj
View file

@ -1,109 +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) 2019-2020 Andrey Antukh <niwi@niwi.nz>
(ns app.services.queries.media
(:require
[clojure.spec.alpha :as s]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.db :as db]
[app.media :as media]
[app.services.queries :as sq]
[app.services.queries.teams :as teams]))
(s/def ::id ::us/uuid)
(s/def ::name ::us/string)
(s/def ::profile-id ::us/uuid)
(s/def ::team-id ::us/uuid)
(s/def ::file-id ::us/uuid)
;; --- Query: Media objects (by file)
(declare retrieve-media-objects)
(declare retrieve-file)
(s/def ::is-local ::us/boolean)
(s/def ::media-objects
(s/keys :req-un [::profile-id ::file-id ::is-local]))
;; TODO: check if we can resolve url with transducer for reduce
;; garbage generation for each request
(sq/defquery ::media-objects
[{:keys [profile-id file-id is-local] :as params}]
(db/with-atomic [conn db/pool]
(let [file (retrieve-file conn file-id)]
(teams/check-read-permissions! conn profile-id (:team-id file))
(->> (retrieve-media-objects conn file-id is-local)
(mapv #(media/resolve-urls % :path :uri))
(mapv #(media/resolve-urls % :thumb-path :thumb-uri))))))
(def ^:private sql:media-objects
"select obj.*,
thumb.path as thumb_path
from media_object as obj
inner join media_thumbnail as thumb on obj.id = thumb.media_object_id
where obj.deleted_at is null
and obj.file_id = ?
and obj.is_local = ?
order by obj.created_at desc")
(defn retrieve-media-objects
[conn file-id is-local]
(db/exec! conn [sql:media-objects file-id is-local]))
(def ^:private sql:retrieve-file
"select file.*,
project.team_id as team_id
from file
inner join project on (project.id = file.project_id)
where file.id = ?")
(defn- retrieve-file
[conn id]
(let [row (db/exec-one! conn [sql:retrieve-file id])]
(when-not row
(ex/raise :type :not-found))
row))
;; --- Query: Media object (by ID)
(declare retrieve-media-object)
(s/def ::id ::us/uuid)
(s/def ::media-object
(s/keys :req-un [::profile-id ::id]))
(sq/defquery ::media-object
[{:keys [profile-id id] :as params}]
(db/with-atomic [conn db/pool]
(let [media-object (retrieve-media-object conn id)]
(teams/check-read-permissions! conn profile-id (:team-id media-object))
(-> media-object
(media/resolve-urls :path :uri)))))
(def ^:private sql:media-object
"select obj.*,
p.team_id as team_id
from media_object as obj
inner join file as f on (f.id = obj.file_id)
inner join project as p on (p.id = f.project_id)
where obj.deleted_at is null
and obj.id = ?
order by created_at desc")
(defn retrieve-media-object
[conn id]
(let [row (db/exec-one! conn [sql:media-object id])]
(when-not row
(ex/raise :type :not-found))
row))

23
backend/src/app/services/queries/profile.clj
View file

@ -9,15 +9,13 @@
(ns app.services.queries.profile
(:require
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.db :as db]
[app.media :as media]
[app.services.queries :as sq]
[app.common.uuid :as uuid]
[app.util.blob :as blob]))
[app.db :as db]
[app.services.queries :as sq]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]))
;; --- Helpers & Specs
@ -25,7 +23,6 @@
(s/def ::email ::us/email)
(s/def ::fullname ::us/string)
(s/def ::metadata any?)
(s/def ::old-password ::us/string)
(s/def ::password ::us/string)
(s/def ::path ::us/string)
@ -75,14 +72,19 @@
{:default-team-id (:id team)
:default-project-id (:id project)}))
(defn decode-profile-row
[{:keys [props] :as row}]
(cond-> row
(db/pgobject? props) (assoc :props (db/decode-transit-pgobject props))))
(defn retrieve-profile-data
[conn id]
(db/get-by-id conn :profile id))
(-> (db/get-by-id conn :profile id)
(decode-profile-row)))
(defn retrieve-profile
[conn id]
(let [profile (some-> (retrieve-profile-data conn id)
(media/resolve-urls :photo :photo-uri)
(strip-private-attrs)
(merge (retrieve-additional-data conn id)))]
(when (nil? profile)
@ -100,7 +102,8 @@
(defn retrieve-profile-data-by-email
[conn email]
(let [email (str/lower email)]
(db/exec-one! conn [sql:profile-by-email email])))
(-> (db/exec-one! conn [sql:profile-by-email email])
(decode-profile-row))))
;; --- Attrs Helpers

6
backend/src/app/services/queries/projects.clj
View file

@ -9,12 +9,12 @@
(ns app.services.queries.projects
(:require
[clojure.spec.alpha :as s]
[app.common.spec :as us]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.db :as db]
[app.services.queries :as sq]
[app.services.queries.teams :as teams]))
[app.services.queries.teams :as teams]
[clojure.spec.alpha :as s]))
;; --- Check Project Permissions

10
backend/src/app/services/queries/recent_files.clj
View file

@ -5,18 +5,16 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2019-2020 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.services.queries.recent-files
(:require
[clojure.spec.alpha :as s]
[promesa.core :as p]
[app.db :as db]
[app.common.spec :as us]
[app.db :as db]
[app.services.queries :as sq]
[app.services.queries.files :refer [decode-row-xf]]
[app.services.queries.teams :as teams]
[app.services.queries.projects :as projects :refer [retrieve-projects]]
[app.services.queries.files :refer [decode-row-xf]]))
[clojure.spec.alpha :as s]))
(def sql:recent-files
"with recent_files as (

88
backend/src/app/services/queries/teams.clj
View file

@ -5,18 +5,16 @@
;; 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 UXBOX Labs SL
(ns app.services.queries.teams
(:require
[clojure.spec.alpha :as s]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.db :as db]
[app.services.queries :as sq]
[app.services.queries.profile :as profile]
[app.util.blob :as blob]))
[clojure.spec.alpha :as s]))
;; --- Team Edition Permissions
@ -130,3 +128,85 @@
(defn retrieve-team-members
[conn team-id]
(db/exec! conn [sql:team-members team-id]))
;; --- Query: Team Users
(declare retrieve-users)
(declare retrieve-team-for-file)
(s/def ::file-id ::us/uuid)
(s/def ::team-users
(s/and (s/keys :req-un [::profile-id]
:opt-un [::team-id ::file-id])
#(or (:team-id %) (:file-id %))))
(sq/defquery ::team-users
[{:keys [profile-id team-id file-id]}]
(with-open [conn (db/open)]
(if team-id
(do
(check-edition-permissions! conn profile-id team-id)
(retrieve-users conn team-id))
(let [{team-id :id} (retrieve-team-for-file conn file-id)]
(check-edition-permissions! conn profile-id team-id)
(retrieve-users conn team-id)))))
;; This is a similar query to team members but can contain more data
;; because some user can be explicitly added to project or file (not
;; implemented in UI)
(def sql:team-users
"select pf.id, pf.fullname, pf.photo
from profile as pf
inner join team_profile_rel as tpr on (tpr.profile_id = pf.id)
where tpr.team_id = ?
union
select pf.id, pf.fullname, pf.photo
from profile as pf
inner join project_profile_rel as ppr on (ppr.profile_id = pf.id)
inner join project as p on (ppr.project_id = p.id)
where p.team_id = ?
union
select pf.id, pf.fullname, pf.photo
from profile as pf
inner join file_profile_rel as fpr on (fpr.profile_id = pf.id)
inner join file as f on (fpr.file_id = f.id)
inner join project as p on (f.project_id = p.id)
where p.team_id = ?")
(def sql:team-by-file
"select p.team_id as id
from project as p
join file as f on (p.id = f.project_id)
where f.id = ?")
(defn retrieve-users
[conn team-id]
(db/exec! conn [sql:team-users team-id team-id team-id]))
(defn retrieve-team-for-file
[conn file-id]
(->> [sql:team-by-file file-id]
(db/exec-one! conn)))
;; --- Query: Team Stats
(declare retrieve-team-stats)
(s/def ::team-stats
(s/keys :req-un [::profile-id ::team-id]))
(sq/defquery ::team-stats
[{:keys [profile-id team-id]}]
(with-open [conn (db/open)]
(check-read-permissions! conn profile-id team-id)
(retrieve-team-stats conn team-id)))
(def sql:team-stats
"select (select count(*) from project where team_id = ?) as projects,
(select count(*) from file as f join project as p on (p.id = f.project_id) where p.team_id = ?) as files")
(defn retrieve-team-stats
[conn team-id]
(db/exec-one! conn [sql:team-stats team-id team-id]))

42
backend/src/app/services/queries/viewer.clj
View file

@ -14,6 +14,7 @@
[app.db :as db]
[app.services.queries :as sq]
[app.services.queries.files :as files]
[app.services.queries.teams :as teams]
[clojure.spec.alpha :as s]))
;; --- Query: Viewer Bundle (by Page ID)
@ -23,7 +24,7 @@
(def ^:private
sql:project
"select p.id, p.name
"select p.id, p.name, p.team_id
from project as p
where p.id = ?
and p.deleted_at is null")
@ -35,40 +36,43 @@
(s/def ::id ::us/uuid)
(s/def ::file-id ::us/uuid)
(s/def ::page-id ::us/uuid)
(s/def ::share-token ::us/string)
(s/def ::token ::us/string)
(s/def ::viewer-bundle
(s/keys :req-un [::file-id ::page-id]
:opt-un [::profile-id ::share-token]))
:opt-un [::profile-id ::token]))
(sq/defquery ::viewer-bundle
[{:keys [profile-id file-id page-id share-token] :as params}]
[{:keys [profile-id file-id page-id token] :as params}]
(db/with-atomic [conn db/pool]
(let [file (files/retrieve-file conn file-id)
project (retrieve-project conn (:project-id file))
page (get-in file [:data :pages-index page-id])
file (merge (dissoc file :data)
(select-keys (:data file) [:colors :media :typographies]))
libs (files/retrieve-file-libraries conn false file-id)
users (teams/retrieve-users conn (:team-id project))
file-library (select-keys (:data file) [:colors :media :typographies])
bundle {:file (-> (dissoc file :data)
(merge file-library))
:page (get-in file [:data :pages-index page-id])
:project project}
]
(if (string? share-token)
bundle {:file file
:page page
:users users
:project project
:libraries libs}]
(if (string? token)
(do
(check-shared-token! conn file-id page-id share-token)
(assoc bundle :share-token share-token))
(let [token (retrieve-shared-token conn file-id page-id)]
(files/check-edition-permissions! conn profile-id file-id)
(assoc bundle :share-token token))))))
(check-shared-token! conn file-id page-id token)
(assoc bundle :token token))
(let [stoken (retrieve-shared-token conn file-id page-id)]
(files/check-read-permissions! conn profile-id file-id)
(assoc bundle :token (:token stoken)))))))
(defn check-shared-token!
[conn file-id page-id token]
(let [sql "select exists(select 1 from file_share_token where file_id=? and page_id=? and token=?) as exists"]
(when-not (:exists (db/exec-one! conn [sql file-id page-id token]))
(ex/raise :type :validation
:code :not-authorized))))
(ex/raise :type :authorization
:code :unauthorized-token))))
(defn retrieve-shared-token
[conn file-id page-id]

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

@ -10,16 +10,11 @@
(ns app.services.tokens
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.config :as cfg]
[app.db :as db]
[app.util.time :as dt]
[app.util.transit :as t]
[buddy.core.codecs :as bc]
[buddy.core.kdf :as bk]
[buddy.core.nonce :as bn]
[buddy.sign.jwe :as jwe]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]))
(defn- derive-tokens-secret

6
backend/src/app/srepl/main.clj Normal file
View file

@ -0,0 +1,6 @@
(ns app.srepl.main
"A main namespace for server repl."
#_:clj-kondo/ignore
(:require
[clojure.pprint :refer [pprint]]
[app.db :as db]))

38
backend/src/app/srepl/server.clj Normal file
View file

@ -0,0 +1,38 @@
;; 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.srepl.server
"Server Repl."
(:require
[app.srepl.main]
[clojure.core.server :as ccs]
[clojure.main :as cm]
[mount.core :as mount :refer [defstate]]))
(defn- repl-init
[]
(ccs/repl-init)
(in-ns 'app.srepl.main))
(defn repl
[]
(cm/repl
:init repl-init
:read ccs/repl-read))
(defstate server
:start (ccs/start-server
{:address "127.0.0.1"
:port 6062
:name "main"
:accept 'app.srepl.server/repl})
:stop (ccs/stop-server "main"))

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

@ -11,7 +11,6 @@
(:require
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.metrics :as mtx]
[app.util.time :as dt]

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

@ -10,13 +10,11 @@
(ns app.tasks.delete-object
"Generic task for permanent deletion of objects."
(:require
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.db :as db]
[app.metrics :as mtx]
[app.util.storage :as ust]))
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]))
(s/def ::type keyword?)
(s/def ::id ::us/uuid)
@ -24,10 +22,10 @@
(s/def ::props
(s/keys :req-un [::id ::type]))
(defmulti handle-deletion (fn [conn props] (:type props)))
(defmulti handle-deletion (fn [_ props] (:type props)))
(defmethod handle-deletion :default
[conn {:keys [type id] :as props}]
[_conn {:keys [type]}]
(log/warn "no handler found for" type))
(defn handler
@ -55,13 +53,3 @@
[conn {:keys [id] :as props}]
(let [sql "delete from media_object where id=? and deleted_at is not null"]
(db/exec-one! conn [sql id])))
(defmethod handle-deletion :color
[conn {:keys [id] :as props}]
(let [sql "delete from color where id=? and deleted_at is not null"]
(db/exec-one! conn [sql id])))
(defmethod handle-deletion :page
[conn {:keys [id] :as props}]
(let [sql "delete from page where id=? and deleted_at is not null"]
(db/exec-one! conn [sql id])))

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

@ -10,13 +10,11 @@
(ns app.tasks.delete-profile
"Task for permanent deletion of profiles."
(:require
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.db :as db]
[app.metrics :as mtx]
[app.util.storage :as ust]))
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]))
(declare delete-profile-data)
(declare delete-teams)
@ -51,11 +49,6 @@
(delete-files conn profile-id)
(delete-profile conn profile-id))
(def ^:private sql:select-profile
"select id, is_demo, deleted_at
from profile
where id=? for update")
(def ^:private sql:remove-owned-teams
"with teams as (
select distinct

5
backend/src/app/tasks/maintenance.clj
View file

@ -10,8 +10,6 @@
(ns app.tasks.maintenance
(:require
[app.common.spec :as us]
[app.common.exceptions :as ex]
[app.config :as cfg]
[app.db :as db]
[app.metrics :as mtx]
[app.util.time :as dt]
@ -22,6 +20,9 @@
;; Task: Delete Executed Tasks
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This tasks perform a cleanup of already executed tasks from the
;; database.
(s/def ::max-age ::dt/duration)
(s/def ::delete-completed-tasks
(s/keys :req-un [::max-age]))

8
backend/src/app/tasks/remove_media.clj
View file

@ -22,6 +22,10 @@
;; Task: Remove Media
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Task responsible of explicit action of removing a media from file
;; system. Mainly used for profile photo change; when we really know
;; that the previous photo becomes unused.
(s/def ::path ::us/not-empty-string)
(s/def ::props
(s/keys :req-un [::path]))
@ -69,10 +73,10 @@
returning *")
(defn trim-media-storage
[{:keys [props] :as task}]
[_task]
(letfn [(decode-row [{:keys [data] :as row}]
(cond-> row
(db/pgobject? data) (assoc :data (db/decode-pgobject data))))
(db/pgobject? data) (assoc :data (db/decode-json-pgobject data))))
(retrieve-items [conn]
(->> (db/exec! conn [sql:retrieve-peding-to-delete 10])
(map decode-row)

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

@ -9,12 +9,10 @@
(ns app.tasks.sendmail
(:require
[clojure.tools.logging :as log]
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.util.emails :as emails]
[app.config :as cfg]
[app.metrics :as mtx]))
[app.metrics :as mtx]
[app.util.emails :as emails]
[clojure.tools.logging :as log]))
(defn- send-console!
[config email]

68
backend/src/app/tasks/trim_file.clj
View file

@ -9,15 +9,13 @@
(ns app.tasks.trim-file
(:require
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.pages.migrations :as pmg]
[app.config :as cfg]
[app.db :as db]
[app.tasks :as tasks]
[app.util.blob :as blob]
[app.util.time :as dt]))
[app.util.time :as dt]
[clojure.tools.logging :as log]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Task: Trim File
@ -27,54 +25,62 @@
;; associated with file but not used by any page.
(defn decode-row
[{:keys [data metadata changes] :as row}]
[{:keys [data] :as row}]
(cond-> row
(bytes? data) (assoc :data (blob/decode data))))
(def sql:retrieve-files-to-trim
"select id from file as f
"select f.id, f.data
from file as f
where f.has_media_trimmed is false
and f.modified_at < now() - ?::interval
order by f.modified_at asc
limit 10")
(defn retrieve-candidates
"Retrieves a list of ids of files that are candidates to be trimed. A
file is considered candidate when some time passes whith no
modification."
[conn]
(let [interval (:file-trimming-max-age cfg/config)]
(->> (db/exec! conn [sql:retrieve-files-to-trim interval])
(map :id))))
(let [threshold (:file-trimming-threshold cfg/config)
interval (db/interval threshold)]
(db/exec! conn [sql:retrieve-files-to-trim interval])))
(def collect-media-xf
(comp
(map :objects)
(mapcat vals)
(filter #(= :image (:type %)))
(map :metadata)
(map :id)))
(defn collect-used-media
[pages]
(let [xf (comp (filter #(= :image (:type %)))
(map :metadata)
(map :id))]
(reduce conj #{} (->> pages
(map :data)
(map :objects)
(mapcat vals)
(filter #(= :image (:type %)))
(map :metadata)
(map :id)))))
[data]
(-> #{}
(into collect-media-xf (vals (:pages-index data)))
(into collect-media-xf (vals (:components data)))
(into (keys (:media data)))))
(defn process-file
[file-id]
(log/debugf "Processing file: '%s'." file-id)
[{:keys [id data] :as file}]
(log/debugf "Processing file: '%s'." id)
(db/with-atomic [conn db/pool]
(let [mobjs (db/query conn :media-object {:file-id file-id})
pages (->> (db/query conn :page {:file-id file-id})
(map decode-row))
used (collect-used-media pages)
unused (into #{} (comp (map :id)
(remove #(contains? used %))) mobjs)]
(let [mobjs (map :id (db/query conn :media-object {:file-id id}))
data (-> (blob/decode data)
(pmg/migrate-data))
used (collect-used-media data)
unused (into #{} (remove #(contains? used %)) mobjs)]
(log/debugf "Collected media ids: '%s'." (pr-str used))
(log/debugf "Unused media ids: '%s'." (pr-str unused))
(db/update! conn :file
{:has-media-trimmed true}
{:id file-id})
{:id id})
(doseq [id unused]
;; TODO: add task batching
(tasks/submit! conn {:name "delete-object"
;; :delay cfg/default-deletion-delay
:delay 10000
@ -86,7 +92,7 @@
nil)))
(defn handler
[{:keys [props] :as task}]
[_task]
(log/debug "Running 'trim-file' task.")
(loop []
(let [files (retrieve-candidates db/pool)]

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

@ -6,9 +6,8 @@
(ns app.util.async
(:require
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[clojure.core.async :as a])
[clojure.core.async :as a]
[clojure.spec.alpha :as s])
(:import
java.util.concurrent.Executor))

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

@ -12,7 +12,7 @@
;; TODO: move to app.common.helpers
(defn dissoc-in
[m [k & ks :as keys]]
[m [k & ks]]
(if ks
(if-let [nextmap (get m k)]
(let [newmap (dissoc-in nextmap ks)]

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

@ -8,14 +8,11 @@
"A generic service dispatcher implementation."
(:refer-clojure :exclude [defmethod])
(:require
[clojure.spec.alpha :as s]
[expound.alpha :as expound]
[app.common.exceptions :as ex])
[app.common.exceptions :as ex]
[clojure.spec.alpha :as s])
(:import
clojure.lang.IDeref
clojure.lang.MapEntry
java.util.Map
java.util.HashMap))
java.util.HashMap
java.util.Map))
(definterface IDispatcher
(^void add [key f]))

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

@ -5,27 +5,25 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2019-2020 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.util.emails
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.util.template :as tmpl]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[app.common.spec :as us]
[app.common.exceptions :as ex]
[app.util.template :as tmpl])
[cuerdas.core :as str])
(:import
java.util.Properties
javax.mail.Message
javax.mail.Transport
javax.mail.Message$RecipientType
javax.mail.PasswordAuthentication
javax.mail.Session
javax.mail.Transport
javax.mail.internet.InternetAddress
javax.mail.internet.MimeMultipart
javax.mail.internet.MimeBodyPart
javax.mail.internet.MimeMessage))
javax.mail.internet.MimeMessage
javax.mail.internet.MimeMultipart))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Email Building
@ -205,8 +203,7 @@
(defn- build-email-template
[id context]
(let [lang (:lang context :en)
subj (render-email-template-part :subj id context)
(let [subj (render-email-template-part :subj id context)
text (render-email-template-part :txt id context)
html (render-email-template-part :html id context)]
(when (or (not subj)

10
backend/src/app/util/http.clj
View file

@ -2,14 +2,16 @@
;; 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>
;; 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.http
"Http client abstraction layer."
(:require
[promesa.core :as p]
[promesa.exec :as px]
[java-http-clj.core :as http]))
[java-http-clj.core :as http]
[promesa.exec :as px]))
(def default-client
(delay (http/build-client {:executor @px/default-executor})))

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

@ -2,13 +2,16 @@
;; 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>
;; 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.migrations
(:require
[clojure.tools.logging :as log]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[clojure.tools.logging :as log]
[cuerdas.core :as str]
[next.jdbc :as jdbc]))
@ -45,7 +48,7 @@
((:fn migration) pool))))
(defn- impl-migrate
[conn migrations {:keys [fake] :or {fake false}}]
[conn migrations _opts]
(s/assert ::migrations migrations)
(let [mname (:name migrations)
steps (:steps migrations)]

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

@ -2,14 +2,17 @@
;; 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>
;; 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
[promesa.core :as p]
[clojure.core.async :as a])
[clojure.core.async :as a]
[promesa.core :as p])
(:import
io.lettuce.core.RedisClient
io.lettuce.core.RedisURI
@ -18,7 +21,6 @@
io.lettuce.core.api.StatefulRedisConnection
io.lettuce.core.pubsub.RedisPubSubListener
io.lettuce.core.pubsub.StatefulRedisPubSubConnection
io.lettuce.core.pubsub.api.async.RedisPubSubAsyncCommands
io.lettuce.core.pubsub.api.sync.RedisPubSubCommands
))
@ -87,7 +89,7 @@
output))
(defn subscribe
[{:keys [uri] :as client} {:keys [topic topics xform]}]
[{:keys [uri] :as client} {:keys [topics xform]}]
(let [topics (if (vector? topics)
(into-array String (map str topics))
(into-array String [(str topics)]))]
@ -100,7 +102,7 @@
true
false))
(defmulti impl-run (fn [conn cmd parmas] cmd))
(defmulti impl-run (fn [_ cmd _] cmd))
(defn run!
[conn cmd params]

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

@ -164,7 +164,7 @@
(defn- process-param-tokens
[sql]
(let [cnt (java.util.concurrent.atomic.AtomicInteger. 1)]
(str/replace sql #"\?" (fn [& args]
(str/replace sql #"\?" (fn [& _args]
(str "$" (.getAndIncrement cnt))))))
(def ^:private select-formatters

13
backend/src/app/util/storage.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 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.util.storage
"A local filesystem storage implementation."
@ -16,17 +16,14 @@
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[datoteka.core :as fs]
[datoteka.proto :as fp])
[datoteka.core :as fs])
(:import
java.io.ByteArrayInputStream
java.io.InputStream
java.io.OutputStream
java.net.URI
java.nio.file.Files
java.nio.file.NoSuchFileException
java.nio.file.Path
java.security.MessageDigest))
java.nio.file.Path))
(defn uri
[v]
@ -54,7 +51,7 @@
(defn- transform-path
[storage ^Path path]
(if-let [xf (::xf storage)]
((xf (fn [a b] b)) nil path)
((xf (fn [_ b] b)) nil path)
path))
(defn blob
@ -89,7 +86,7 @@
(normalize-path (::base-path storage))
(fs/delete))
true
(catch java.nio.file.NoSuchFileException e
(catch NoSuchFileException _e
false)))
(defn clear!

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

@ -2,21 +2,23 @@
;; 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) 2016-2019 Andrey Antukh <niwi@niwi.nz>
;; 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
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.exceptions :as ex])
[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
java.io.InputStream))
org.jsoup.nodes.Document))
(s/def ::content string?)
(s/def ::width ::us/number)
@ -65,19 +67,19 @@
content (.html element)
attrs (parse-attrs element)]
(assoc attrs :content content))
(catch java.lang.IllegalArgumentException e
(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
(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
(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
(catch Exception _e
(ex/raise :type :internal
:code ::unexpected))))

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

@ -2,18 +2,17 @@
;; 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) 2016-2019 Andrey Antukh <niwi@niwi.nz>
;; 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.template
"A lightweight abstraction over mustache.java template engine.
The documentation can be found: http://mustache.github.io/mustache.5.html"
(:require
[clojure.tools.logging :as log]
[clojure.walk :as walk]
[clojure.java.io :as io]
[cuerdas.core :as str]
[selmer.parser :as sp]
[app.common.exceptions :as ex]))
[app.common.exceptions :as ex]
[selmer.parser :as sp]))
;; (sp/cache-off!)

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

@ -5,12 +5,12 @@
;; This Source Code Form is "Incompatible With Secondary Licenses", as
;; defined by the Mozilla Public License, v. 2.0.
;;
;; Copyright (c) 2016-2020 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2020 UXBOX Labs SL
(ns app.util.time
(:require
[clojure.spec.alpha :as s]
[app.common.exceptions :as ex]
[clojure.spec.alpha :as s]
[cognitect.transit :as t])
(:import
java.time.Instant
@ -103,10 +103,11 @@
(letfn [(conformer [v]
(cond
(duration? v) v
(string? v)
(try
(parse-duration v)
(catch java.time.format.DateTimeParseException e
(duration v)
(catch java.time.format.DateTimeParseException _e
::s/invalid))
:else

10
backend/src/app/util/transit.clj
View file

@ -9,13 +9,11 @@
(ns app.util.transit
(:require
[cognitect.transit :as t]
[clojure.java.io :as io]
[linked.core :as lk]
[app.util.time :as dt]
[app.util.data :as data]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.matrix :as gmt])
[app.util.time :as dt]
[cognitect.transit :as t]
[linked.core :as lk])
(:import
linked.set.LinkedSet
java.io.ByteArrayInputStream

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

@ -15,12 +15,11 @@
[app.db :as db]
[app.tasks.delete-object]
[app.tasks.delete-profile]
[app.tasks.remove-media]
[app.tasks.maintenance]
[app.tasks.remove-media]
[app.tasks.sendmail]
[app.tasks.trim-file]
[app.util.async :as aa]
[app.util.blob :as blob]
[app.util.time :as dt]
[clojure.core.async :as a]
[clojure.spec.alpha :as s]
@ -31,10 +30,7 @@
org.eclipse.jetty.util.thread.QueuedThreadPool
java.util.concurrent.ExecutorService
java.util.concurrent.Executors
java.util.concurrent.Executor
java.time.Duration
java.time.Instant
java.util.Date))
java.time.Instant))
(declare start-scheduler-worker!)
(declare start-worker!)
@ -61,19 +57,18 @@
:fn #'app.tasks.trim-file/handler}
{:id "maintenance/delete-executed-tasks"
:cron #app/cron "0 0 */1 * * ?" ;; hourly
:cron #app/cron "0 0 0 */1 * ?" ;; daily
:fn #'app.tasks.maintenance/delete-executed-tasks
:props {:max-age #app/duration "48h"}}
:props {:max-age #app/duration "24h"}}
{:id "maintenance/delete-old-files-xlog"
:cron #app/cron "0 0 */1 * * ?" ;; hourly
:cron #app/cron "0 0 0 */1 * ?" ;; daily
:fn #'app.tasks.maintenance/delete-old-files-xlog
:props {:max-age #app/duration "8h"}}
:props {:max-age #app/duration "12h"}}
])
(defstate executor
:start (thread-pool {:idle-timeout 10000
:min-threads 0
:start (thread-pool {:min-threads 0
:max-threads 256})
:stop (stop! executor))
@ -149,7 +144,7 @@
nil))))
(defn- run-task
[{:keys [tasks conn]} item]
[{:keys [tasks]} item]
(try
(log/debugf "Started task '%s/%s/%s'." (:name item) (:id item) (:retry-num item))
(handle-task tasks item)
@ -187,7 +182,7 @@
for update skip locked")
(defn- event-loop-fn*
[{:keys [tasks executor batch-size] :as opts}]
[{:keys [executor batch-size] :as opts}]
(db/with-atomic [conn db/pool]
(let [queue (:queue opts "default")
items (->> (db/exec! conn [sql:select-next-tasks queue batch-size])
@ -222,7 +217,7 @@
:opt-un [::poll-interval]))
(defn start-worker!
[{:keys [poll-interval executor]
[{:keys [poll-interval]
:or {poll-interval 5000}
:as opts}]
(us/assert ::start-worker-params opts)
@ -290,7 +285,7 @@
do update set cron_expr=?")
(defn- synchronize-schedule-item
[conn {:keys [id cron] :as item}]
[conn {:keys [id cron]}]
(let [cron (str cron)]
(log/debugf "Initialize scheduled task '%s' (cron: '%s')." id cron)
(db/exec-one! conn [sql:upsert-scheduled-task id cron cron])))
@ -311,7 +306,7 @@
(.printStackTrace ^Throwable error (java.io.PrintWriter. *out*))))
(defn- execute-scheduled-task
[{:keys [scheduler executor] :as opts} {:keys [id cron] :as task}]
[{:keys [executor] :as opts} {:keys [id] :as task}]
(letfn [(run-task [conn]
(try
(when (db/exec-one! conn [sql:lock-scheduled-task id])
@ -384,8 +379,8 @@
(defn thread-pool
([] (thread-pool {}))
([{:keys [min-threads max-threads idle-timeout name]
:or {min-threads 0 max-threads 128 idle-timeout 60000}}]
([{:keys [min-threads max-threads name]
:or {min-threads 0 max-threads 256}}]
(let [executor (QueuedThreadPool. max-threads min-threads)]
(.setName executor (or name "default-tp"))
(.start executor)

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

@ -17,7 +17,7 @@
[mount.core :as mount]
[environ.core :refer [env]]
[app.common.pages :as cp]
[app.services.init]
[app.services]
[app.services.mutations.profile :as profile]
[app.services.mutations.projects :as projects]
[app.services.mutations.teams :as teams]
@ -36,9 +36,9 @@
[]
(doto (PGSimpleDataSource.)
(.setServerName "postgres")
(.setDatabaseName "uxbox_test")
(.setUser "uxbox")
(.setPassword "uxbox")))
(.setDatabaseName "penpot_test")
(.setUser "penpot")
(.setPassword "penpot")))
(defn state-init
[next]
@ -50,8 +50,8 @@
#'app.redis/client
#'app.redis/conn
#'app.media/semaphore
#'app.services.init/query-services
#'app.services.init/mutation-services
#'app.services/query-services
#'app.services/mutation-services
#'app.migrations/migrations
#'app.media-storage/assets-storage
#'app.media-storage/media-storage})
@ -91,7 +91,8 @@
(let [params {:id (mk-uuid "profile" i)
:fullname (str "Profile " i)
:email (str "profile" i ".test@nodomain.com")
:password "123123"}]
:password "123123"
:demo? true}]
(->> (#'profile/create-profile conn params)
(#'profile/create-profile-relations conn))))

94
backend/tests/app/tests/test_common_geom.clj Normal file
View file

@ -0,0 +1,94 @@
;; 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_common_geom
(:require
[clojure.test :as t]
[app.common.geom.point :as gpt]
[app.common.geom.matrix :as gmt]))
(t/deftest point-constructors-test
(t/testing "Create point with both coordinates"
(let [p (gpt/point 1 2)]
(t/is (= (:x p) 1))
(t/is (= (:y p) 2))))
(t/testing "Create point with single coordinate"
(let [p (gpt/point 1)]
(t/is (= (:x p) 1))
(t/is (= (:y p) 1))))
(t/testing "Create empty point"
(let [p (gpt/point)]
(t/is (= (:x p) 0))
(t/is (= (:y p) 0)))))
(t/deftest point-add-test
(t/testing "Adds two points together"
(let [p1 (gpt/point 1 1)
p2 (gpt/point 2 2)
p3 (gpt/add p1 p2)]
(t/is (= (:x p3) 3))
(t/is (= (:y p3) 3)))))
(t/deftest point-subtract-test
(t/testing "Point substraction"
(let [p1 (gpt/point 3 3)
p2 (gpt/point 2 2)
p3 (gpt/subtract p1 p2)]
(t/is (= (:x p3) 1))
(t/is (= (:y p3) 1)))))
(t/deftest point-distance-test
(let [p1 (gpt/point 0 0)
p2 (gpt/point 10 0)
d (gpt/distance p1 p2)]
(t/is (number? d))
(t/is (= d 10.0))))
(t/deftest point-length-test
(let [p1 (gpt/point 10 0)
ln (gpt/length p1)]
(t/is (number? ln))
(t/is (= ln 10.0))))
(t/deftest point-angle-test
(t/testing "Get angle a 90 degree angle"
(let [p1 (gpt/point 0 10)
angle (gpt/angle p1)]
(t/is (number? angle))
(t/is (= angle 90.0))))
(t/testing "Get 45 degree angle"
(let [p1 (gpt/point 0 10)
p2 (gpt/point 10 10)
angle (gpt/angle-with-other p1 p2)]
(t/is (number? angle))
(t/is (= angle 45.0)))))
(t/deftest matrix-constructors-test
(let [m (gmt/matrix)]
(t/is (= (str m) "matrix(1,0,0,1,0,0)")))
(let [m (gmt/matrix 1 1 1 2 2 2)]
(t/is (= (str m) "matrix(1,1,1,2,2,2)"))))
(t/deftest matrix-translate-test
(let [m (-> (gmt/matrix)
(gmt/translate (gpt/point 2 10)))]
(t/is (= (str m) "matrix(1,0,0,1,2,10)"))))
(t/deftest matrix-scale-test
(let [m (-> (gmt/matrix)
(gmt/scale (gpt/point 2)))]
(t/is (= (str m) "matrix(2,0,0,2,0,0)"))))
(t/deftest matrix-rotate-test
(let [m (-> (gmt/matrix)
(gmt/rotate 10))]
(t/is (= (str m) "matrix(0.984807753012208,0.17364817766693033,-0.17364817766693033,0.984807753012208,0,0)"))))

179
backend/tests/app/tests/test_common_geom_shapes.clj Normal file
View file

@ -0,0 +1,179 @@
;; 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-common-geom-shapes
(:require
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.shapes :as gsh]
[app.common.pages :refer [make-minimal-shape]]
[clojure.test :as t]))
(def default-path [{:command :move-to :params {:x 0 :y 0}}
{:command :line-to :params {:x 20 :y 20}}
{:command :line-to :params {:x 30 :y 30}}
{:command :curve-to :params {:x 40 :y 40 :c1x 35 :c1y 35 :c2x 45 :c2y 45}}
{:command :close-path}])
(defn add-path-data [shape]
(let [content (:content shape default-path)
selrect (gsh/content->selrect content)
points (gsh/rect->points selrect)]
(assoc shape
:content content
:selrect selrect
:points points)))
(defn add-rect-data [shape]
(let [selrect (gsh/rect->selrect shape)
points (gsh/rect->points selrect)]
(assoc shape
:selrect selrect
:points points)))
(defn create-test-shape
([type] (create-test-shape type {}))
([type params]
(-> (make-minimal-shape type)
(merge params)
(cond->
(= type :path) (add-path-data)
(not= type :path) (add-rect-data)))))
(t/deftest transform-shape-tests
(t/testing "Shape without modifiers should stay the same"
(t/are [type]
(let [shape-before (create-test-shape type)
shape-after (gsh/transform-shape shape-before)]
(= shape-before shape-after))
:rect :path))
(t/testing "Transform shape with translation modifiers"
(t/are [type]
(let [modifiers {:displacement (gmt/translate-matrix (gpt/point 10 -10))}]
(let [shape-before (create-test-shape type {:modifiers modifiers})
shape-after (gsh/transform-shape shape-before)]
(t/is (not= shape-before shape-after))
(t/is (== (get-in shape-before [:selrect :x])
(- 10 (get-in shape-after [:selrect :x]))))
(t/is (== (get-in shape-before [:selrect :y])
(+ 10 (get-in shape-after [:selrect :y]))))
(t/is (== (get-in shape-before [:selrect :width])
(get-in shape-after [:selrect :width])))
(t/is (== (get-in shape-before [:selrect :height])
(get-in shape-after [:selrect :height])))))
:rect :path))
(t/testing "Transform with empty translation"
(t/are [type]
(let [modifiers {:displacement (gmt/matrix)}
shape-before (create-test-shape type {:modifiers modifiers})
shape-after (gsh/transform-shape shape-before)]
(t/are [prop]
(t/is (== (get-in shape-before [:selrect prop])
(get-in shape-after [:selrect prop])))
:x :y :width :height :x1 :y1 :x2 :y2))
:rect :path))
(t/testing "Transform shape with resize modifiers"
(t/are [type]
(let [modifiers {:resize-origin (gpt/point 0 0)
:resize-vector (gpt/point 2 2)
:resize-transform (gmt/matrix)}
shape-before (create-test-shape type {:modifiers modifiers})
shape-after (gsh/transform-shape shape-before)]
(t/is (not= shape-before shape-after))
(t/is (== (get-in shape-before [:selrect :x])
(get-in shape-after [:selrect :x])))
(t/is (== (get-in shape-before [:selrect :y])
(get-in shape-after [:selrect :y])))
(t/is (== (* 2 (get-in shape-before [:selrect :width]))
(get-in shape-after [:selrect :width])))
(t/is (== (* 2 (get-in shape-before [:selrect :height]))
(get-in shape-after [:selrect :height]))))
:rect :path))
(t/testing "Transform with empty resize"
(t/are [type]
(let [modifiers {:resize-origin (gpt/point 0 0)
:resize-vector (gpt/point 1 1)
:resize-transform (gmt/matrix)}
shape-before (create-test-shape type {:modifiers modifiers})
shape-after (gsh/transform-shape shape-before)]
(t/are [prop]
(t/is (== (get-in shape-before [:selrect prop])
(get-in shape-after [:selrect prop])))
:x :y :width :height :x1 :y1 :x2 :y2))
:rect :path))
(t/testing "Transform with resize=0"
(t/are [type]
(let [modifiers {:resize-origin (gpt/point 0 0)
:resize-vector (gpt/point 0 0)
:resize-transform (gmt/matrix)}
shape-before (create-test-shape type {:modifiers modifiers})
shape-after (gsh/transform-shape shape-before)]
(t/is (> (get-in shape-before [:selrect :width])
(get-in shape-after [:selrect :width])))
(t/is (> (get-in shape-after [:selrect :width]) 0))
(t/is (> (get-in shape-before [:selrect :height])
(get-in shape-after [:selrect :height])))
(t/is (> (get-in shape-after [:selrect :height]) 0)))
:rect :path))
(t/testing "Transform shape with rotation modifiers"
(t/are [type]
(let [modifiers {:rotation 30}
shape-before (create-test-shape type {:modifiers modifiers})
shape-after (gsh/transform-shape shape-before)]
(t/is (not= shape-before shape-after))
(t/is (not (== (get-in shape-before [:selrect :x])
(get-in shape-after [:selrect :x]))))
(t/is (not (== (get-in shape-before [:selrect :y])
(get-in shape-after [:selrect :y])))))
:rect :path))
(t/testing "Transform shape with rotation = 0 should leave equal selrect"
(t/are [type]
(let [modifiers {:rotation 0}
shape-before (create-test-shape type {:modifiers modifiers})
shape-after (gsh/transform-shape shape-before)]
(t/are [prop]
(t/is (== (get-in shape-before [:selrect prop])
(get-in shape-after [:selrect prop])))
:x :y :width :height :x1 :y1 :x2 :y2))
:rect :path))
(t/testing "Transform shape with invalid selrect fails gracefuly"
(t/are [type selrect]
(let [modifiers {:displacement (gmt/matrix)}
shape-before (-> (create-test-shape type {:modifiers modifiers})
(assoc :selrect selrect))
shape-after (gsh/transform-shape shape-before)]
(= (:selrect shape-before) (:selrect shape-after)))
:rect {:x 0 :y 0 :width ##Inf :height ##Inf}
:path {:x 0 :y 0 :width ##Inf :height ##Inf}
:rect nil
:path nil)))

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

@ -23,10 +23,10 @@
(let [result (emails/render emails/register {:to "example@app.io" :name "foo"})]
(t/is (map? result))
(t/is (contains? result :subject))
(t/is (contains? result :content))
(t/is (contains? result :body))
(t/is (contains? result :to))
(t/is (contains? result :reply-to))
(t/is (vector? (:content result)))))
#_(t/is (contains? result :reply-to))
(t/is (vector? (:body result)))))
;; (t/deftest email-sending-and-sendmail-job
;; (let [res @(emails/send! emails/register {:to "example@app.io" :name "foo"})]

12
backend/tests/app/tests/test_services_media.clj
View file

@ -78,13 +78,13 @@
(t/is (string? (get-in out [:result :path])))
(t/is (string? (get-in out [:result :thumb-path])))))
(t/testing "list media objects by file"
#_(t/testing "list media objects by file"
(let [data {::sq/type :media-objects
:profile-id (:id prof)
:file-id (:id file)
:is-local true}
out (th/try-on! (sq/handle data))]
;; (th/print-result! out)
(th/print-result! out)
;; Result is ordered by creation date descendent
(t/is (= object-id-2 (get-in out [:result 0 :id])))
@ -96,7 +96,7 @@
(t/is (string? (get-in out [:result 0 :path])))
(t/is (string? (get-in out [:result 0 :thumb-path])))))
(t/testing "single media object"
#_(t/testing "single media object"
(let [data {::sq/type :media-object
:profile-id (:id prof)
:id object-id-2}
@ -111,7 +111,7 @@
(t/is (string? (get-in out [:result :path])))))
(t/testing "delete media objects"
#_(t/testing "delete media objects"
(let [data {::sm/type :delete-media-object
:profile-id (:id prof)
:id object-id-1}
@ -121,7 +121,7 @@
(t/is (nil? (:error out)))
(t/is (nil? (:result out)))))
(t/testing "query media object after delete"
#_(t/testing "query media object after delete"
(let [data {::sq/type :media-object
:profile-id (:id prof)
:id object-id-1}
@ -136,7 +136,7 @@
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :not-found)))))
(t/testing "query media objects after delete"
#_(t/testing "query media objects after delete"
(let [data {::sq/type :media-objects
:profile-id (:id prof)
:file-id (:id file)

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

@ -40,7 +40,7 @@
(let [error (ex-cause (:error out))]
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :validation))
(t/is (th/ex-of-code? error :app.services.mutations.profile/wrong-credentials)))))
(t/is (th/ex-of-code? error :wrong-credentials)))))
(t/testing "success"
(let [event {::sm/type :login

9
backend/tests/app/tests/test_services_viewer.clj
View file

@ -43,7 +43,7 @@
(t/is (nil? (:error out)))
(let [result (:result out)]
(t/is (contains? result :share-token))
(t/is (contains? result :token))
(t/is (contains? result :page))
(t/is (contains? result :file))
(t/is (contains? result :project)))))
@ -78,12 +78,13 @@
(let [error (ex-cause (:error out))
error-data (ex-data error)]
(t/is (th/ex-info? error))
(t/is (= (:type error-data) :not-found)))))
(t/is (= (:type error-data) :validation))
(t/is (= (:code error-data) :not-authorized)))))
(t/testing "authenticated with token & profile"
(let [data {::sq/type :viewer-bundle
:profile-id (:id prof2)
:share-token @token
:token @token
:file-id (:id file)
:page-id (get-in file [:data :pages 0])}
out (th/try-on! (sq/handle data))]
@ -97,7 +98,7 @@
(t/testing "authenticated with token"
(let [data {::sq/type :viewer-bundle
:share-token @token
:token @token
:file-id (:id file)
:page-id (get-in file [:data :pages 0])}
out (th/try-on! (sq/handle data))]

71
common/app/common/attrs.cljc Normal file
View file

@ -0,0 +1,71 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; 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.common.attrs)
(defn get-attrs-multi
[shapes attrs]
;; Extract some attributes of a list of shapes.
;; For each attribute, if the value is the same in all shapes,
;; wll take this value. If there is any shape that is different,
;; the value of the attribute will be the keyword :multiple.
;;
;; If some shape has the value nil in any attribute, it's
;; considered a different value. If the shape does not contain
;; the attribute, it's ignored in the final result.
;;
;; Example:
;; (def shapes [{:stroke-color "#ff0000"
;; :stroke-width 3
;; :fill-color "#0000ff"
;; :x 1000 :y 2000 :rx nil}
;; {:stroke-width "#ff0000"
;; :stroke-width 5
;; :x 1500 :y 2000}])
;;
;; (get-attrs-multi shapes [:stroke-color
;; :stroke-width
;; :fill-color
;; :rx
;; :ry])
;; >>> {:stroke-color "#ff0000"
;; :stroke-width :multiple
;; :fill-color "#0000ff"
;; :rx nil
;; :ry nil}
;;
(let [defined-shapes (filter some? shapes)
combine-value (fn [v1 v2] (cond
(= v1 v2) v1
(= v1 :undefined) v2
(= v2 :undefined) v1
:else :multiple))
combine-values (fn [attrs shape values]
(map #(combine-value (get shape % :undefined)
(get values % :undefined)) attrs))
select-attrs (fn [shape attrs]
(zipmap attrs (map #(get shape % :undefined) attrs)))
reducer (fn [result shape]
(zipmap attrs (combine-values attrs shape result)))
combined (reduce reducer
(select-attrs (first defined-shapes) attrs)
(rest defined-shapes))
cleanup-value (fn [value]
(if (= value :undefined) nil value))
cleanup (fn [result]
(zipmap attrs (map #(cleanup-value (get result %)) attrs)))]
(cleanup combined)))

93
common/app/common/data.cljc
View file

@ -6,13 +6,17 @@
(ns app.common.data
"Data manipulation and query helper functions."
(:refer-clojure :exclude [concat read-string hash-map])
(:require [clojure.set :as set]
[linked.set :as lks]
#?(:cljs [cljs.reader :as r]
:clj [clojure.edn :as r])
#?(:cljs [cljs.core :as core]
:clj [clojure.core :as core]))
(:refer-clojure :exclude [concat read-string hash-map merge])
#?(:cljs
(:require-macros [app.common.data]))
(:require
[linked.set :as lks]
[app.common.math :as mth]
#?(:clj [cljs.analyzer.api :as aapi])
#?(:cljs [cljs.reader :as r]
:clj [clojure.edn :as r])
#?(:cljs [cljs.core :as core]
:clj [clojure.core :as core]))
#?(:clj
(:import linked.set.LinkedSet)))
@ -35,7 +39,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn dissoc-in
[m [k & ks :as keys]]
[m [k & ks]]
(if ks
(if-let [nextmap (get m k)]
(let [newmap (dissoc-in nextmap ks)]
@ -85,7 +89,7 @@
(defn index-of-pred
[coll pred]
(loop [c (first coll)
(loop [c (first coll)
coll (rest coll)
index 0]
(if (nil? c)
@ -206,6 +210,17 @@
(assoc m key v)
m)))
(defn merge
"A faster merge."
[& maps]
(loop [res (transient (or (first maps) {}))
maps (next maps)]
(if (nil? maps)
(persistent! res)
(recur (reduce-kv assoc! res (first maps))
(next maps)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Data Parsing / Conversion
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -219,7 +234,7 @@
#?(:cljs (js/parseInt v 10)
:clj (try
(Integer/parseInt v)
(catch Throwable e
(catch Throwable _
nil))))
(defn- impl-parse-double
@ -227,7 +242,7 @@
#?(:cljs (js/parseFloat v)
:clj (try
(Double/parseDouble v)
(catch Throwable e
(catch Throwable _
nil))))
(defn parse-integer
@ -261,3 +276,59 @@
(defn coalesce
[val default]
(or val default))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Data Parsing / Conversion
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn nilf
"Returns a new function that if you pass nil as any argument will
return nil"
[f]
(fn [& args]
(if (some nil? args)
nil
(apply f args))))
(defn check-num
"Function that checks if a number is nil or nan. Will return 0 when not
valid and the number otherwise."
[v]
(if (or (not v) (mth/nan? v)) 0 v))
(defmacro export
"A helper macro that allows reexport a var in a current namespace."
[v]
(if (boolean (:ns &env))
;; Code for ClojureScript
(let [mdata (aapi/resolve &env v)
arglists (second (get-in mdata [:meta :arglists]))
sym (symbol (name v))
andsym (symbol "&")
procarg #(if (= % andsym) % (gensym "param"))]
(if (pos? (count arglists))
`(def
~(with-meta sym (:meta mdata))
(fn ~@(for [args arglists]
(let [args (map procarg args)]
(if (some #(= andsym %) args)
(let [[sargs dargs] (split-with #(not= andsym %) args)]
`([~@sargs ~@dargs] (apply ~v ~@sargs ~@(rest dargs))))
`([~@args] (~v ~@args)))))))
`(def ~(with-meta sym (:meta mdata)) ~v)))
;; Code for Clojure
(let [vr (resolve v)
m (meta vr)
n (:name m)
n (with-meta n
(cond-> {}
(:dynamic m) (assoc :dynamic true)
(:protocol m) (assoc :protocol (:protocol m))))]
`(let [m# (meta ~vr)]
(def ~n (deref ~vr))
(alter-meta! (var ~n) merge (dissoc m# :name))
;; (when (:macro m#)
;; (.setMacro (var ~n)))
~vr))))

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

@ -6,6 +6,8 @@
(ns app.common.exceptions
"A helpers for work with exceptions."
#?(:cljs
(:require-macros [app.common.exceptions]))
(:require [clojure.spec.alpha :as s]))
(s/def ::type keyword?)
@ -22,7 +24,7 @@
::cause]))
(defn error
[& {:keys [type code message hint cause] :as params}]
[& {:keys [message hint cause] :as params}]
(s/assert ::error-params params)
(let [message (or message hint "")
payload (dissoc params :cause)]
@ -46,3 +48,7 @@
(defmacro try
[& exprs]
`(try* (^:once fn* [] ~@exprs) identity))
(defn ex-info?
[v]
(instance? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core.ExceptionInfo) v))

151
common/app/common/geom/align.cljc Normal file
View file

@ -0,0 +1,151 @@
;; 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.common.geom.align
(:require
[clojure.spec.alpha :as s]
[app.common.geom.shapes :as gsh]
[app.common.data :as d]))
;; --- Alignment
(s/def ::align-axis #{:hleft :hcenter :hright :vtop :vcenter :vbottom})
(declare calc-align-pos)
;; Duplicated from pages/helpers to remove cyclic dependencies
(defn- get-children [id objects]
(let [shapes (vec (get-in objects [id :shapes]))]
(if shapes
(d/concat shapes (mapcat #(get-children % objects) shapes))
[])))
(defn- recursive-move
"Move the shape and all its recursive children."
[shape dpoint objects]
(let [children-ids (get-children (:id shape) objects)
children (map #(get objects %) children-ids)]
(map #(gsh/move % dpoint) (cons shape children))))
(defn align-to-rect
"Move the shape so that it is aligned with the given rectangle
in the given axis. Take account the form of the shape and the
possible rotation. What is aligned is the rectangle that wraps
the shape with the given rectangle. If the shape is a group,
move also all of its recursive children."
[shape rect axis objects]
(let [wrapper-rect (gsh/selection-rect [shape])
align-pos (calc-align-pos wrapper-rect rect axis)
delta {:x (- (:x align-pos) (:x wrapper-rect))
:y (- (:y align-pos) (:y wrapper-rect))}]
(recursive-move shape delta objects)))
(defn calc-align-pos
[wrapper-rect rect axis]
(case axis
:hleft (let [left (:x rect)]
{:x left
:y (:y wrapper-rect)})
:hcenter (let [center (+ (:x rect) (/ (:width rect) 2))]
{:x (- center (/ (:width wrapper-rect) 2))
:y (:y wrapper-rect)})
:hright (let [right (+ (:x rect) (:width rect))]
{:x (- right (:width wrapper-rect))
:y (:y wrapper-rect)})
:vtop (let [top (:y rect)]
{:x (:x wrapper-rect)
:y top})
:vcenter (let [center (+ (:y rect) (/ (:height rect) 2))]
{:x (:x wrapper-rect)
:y (- center (/ (:height wrapper-rect) 2))})
:vbottom (let [bottom (+ (:y rect) (:height rect))]
{:x (:x wrapper-rect)
:y (- bottom (:height wrapper-rect))})))
;; --- Distribute
(s/def ::dist-axis #{:horizontal :vertical})
(defn distribute-space
"Distribute equally the space between shapes in the given axis. If
there is no space enough, it does nothing. It takes into account
the form of the shape and the rotation, what is distributed is
the wrapping recangles of the shapes. If any shape is a group,
move also all of its recursive children."
[shapes axis objects]
(let [coord (if (= axis :horizontal) :x :y)
other-coord (if (= axis :horizontal) :y :x)
size (if (= axis :horizontal) :width :height)
; The rectangle that wraps the whole selection
wrapper-rect (gsh/selection-rect shapes)
; Sort shapes by the center point in the given axis
sorted-shapes (sort-by #(coord (gsh/center-shape %)) shapes)
; Each shape wrapped in its own rectangle
wrapped-shapes (map #(gsh/selection-rect [%]) sorted-shapes)
; The total space between shapes
space (reduce - (size wrapper-rect) (map size wrapped-shapes))]
(if (<= space 0)
shapes
(let [unit-space (/ space (- (count wrapped-shapes) 1))
; Calculate the distance we need to move each shape.
; The new position of each one is the position of the
; previous one plus its size plus the unit space.
deltas (loop [shapes' wrapped-shapes
start-pos (coord wrapper-rect)
deltas []]
(let [first-shape (first shapes')
delta (- start-pos (coord first-shape))
new-pos (+ start-pos (size first-shape) unit-space)]
(if (= (count shapes') 1)
(conj deltas delta)
(recur (rest shapes')
new-pos
(conj deltas delta)))))]
(mapcat #(recursive-move %1 {coord %2 other-coord 0} objects)
sorted-shapes deltas)))))
;; Adjusto to viewport
(defn adjust-to-viewport
([viewport srect] (adjust-to-viewport viewport srect nil))
([viewport srect {:keys [padding] :or {padding 0}}]
(let [gprop (/ (:width viewport) (:height viewport))
srect (-> srect
(update :x #(- % padding))
(update :y #(- % padding))
(update :width #(+ % padding padding))
(update :height #(+ % padding padding)))
width (:width srect)
height (:height srect)
lprop (/ width height)]
(cond
(> gprop lprop)
(let [width' (* (/ width lprop) gprop)
padding (/ (- width' width) 2)]
(-> srect
(update :x #(- % padding))
(assoc :width width')))
(< gprop lprop)
(let [height' (/ (* height lprop) gprop)
padding (/ (- height' height) 2)]
(-> srect
(update :y #(- % padding))
(assoc :height height')))
:else srect))))

21
common/app/common/geom/matrix.cljc
View file

@ -9,7 +9,6 @@
(ns app.common.geom.matrix
(:require
[cuerdas.core :as str]
[app.common.math :as mth]
[app.common.geom.point :as gpt]))
@ -21,8 +20,8 @@
(str "matrix(" a "," b "," c "," d "," e "," f ")")))
(defn multiply
([{m1a :a m1b :b m1c :c m1d :d m1e :e m1f :f :as m1}
{m2a :a m2b :b m2c :c m2d :d m2e :e m2f :f :as m2}]
([{m1a :a m1b :b m1c :c m1d :d m1e :e m1f :f}
{m2a :a m2b :b m2c :c m2d :d m2e :e m2f :f}]
(Matrix.
(+ (* m1a m2a) (* m1c m2b))
(+ (* m1b m2a) (* m1d m2b))
@ -34,8 +33,8 @@
(reduce multiply (multiply m1 m2) others)))
(defn substract
[{m1a :a m1b :b m1c :c m1d :d m1e :e m1f :f :as m1}
{m2a :a m2b :b m2c :c m2d :d m2e :e m2f :f :as m2}]
[{m1a :a m1b :b m1c :c m1d :d m1e :e m1f :f}
{m2a :a m2b :b m2c :c m2d :d m2e :e m2f :f}]
(Matrix.
(- m1a m2a) (- m1b m2b) (- m1c m2c)
(- m1d m2d) (- m1e m2e) (- m1f m2f)))
@ -88,7 +87,7 @@
(defn skew-matrix
([angle-x angle-y point]
(multiply (translate-matrix point)
(skew-matrix angle-y angle-y)
(skew-matrix angle-x angle-y)
(translate-matrix (gpt/negate point))))
([angle-x angle-y]
(let [m1 (mth/tan (mth/radians angle-x))
@ -121,3 +120,13 @@
([m angle-x angle-y p]
(multiply m (skew-matrix angle-x angle-y p))))
(defn m-equal [m1 m2 threshold]
(let [th-eq (fn [a b] (<= (mth/abs (- a b)) threshold))
{m1a :a m1b :b m1c :c m1d :d m1e :e m1f :f} m1
{m2a :a m2b :b m2c :c m2d :d m2e :e m2f :f} m2]
(and (th-eq m1a m2a)
(th-eq m1b m2b)
(th-eq m1c m2c)
(th-eq m1d m2d)
(th-eq m1e m2e)
(th-eq m1f m2f))))

44
common/app/common/geom/point.cljc
View file

@ -12,7 +12,6 @@
(:require
#?(:cljs [cljs.core :as c]
:clj [clojure.core :as c])
[cuerdas.core :as str]
[app.common.math :as mth]))
;; --- Point Impl
@ -26,6 +25,14 @@
[v]
(instance? Point v))
(defn ^boolean point-like?
[{:keys [x y] :as v}]
(and (map? v)
(not (nil? x))
(not (nil? y))
(number? x)
(number? y)))
(defn point
"Create a Point instance."
([] (Point. 0 0))
@ -37,9 +44,20 @@
(number? v)
(Point. v v)
(point-like? v)
(Point. (:x v) (:y v))
:else
(throw (ex-info "Invalid arguments" {:v v}))))
([x y] (Point. x y)))
([x y]
;;(assert (not (nil? x)))
;;(assert (not (nil? y)))
(Point. x y)))
(defn angle->point [{:keys [x y]} angle distance]
(point
(+ x (* distance (mth/cos angle)))
(- y (* distance (mth/sin angle)))))
(defn add
"Returns the addition of the supplied value to both
@ -134,14 +152,18 @@
(assert (point? p))
(assert (point? other))
(let [a (/ (+ (* x ox)
(* y oy))
(* (length p)
(length other)))
a (mth/acos (if (< a -1) -1 (if (> a 1) 1 a)))
d (-> (mth/degrees a)
(mth/precision 6))]
(if (mth/nan? d) 0 d)))
(let [length-p (length p)
length-other (length other)]
(if (or (mth/almost-zero? length-p)
(mth/almost-zero? length-other))
0
(let [a (/ (+ (* x ox)
(* y oy))
(* length-p length-other))
a (mth/acos (if (< a -1) -1 (if (> a 1) 1 a)))
d (-> (mth/degrees a)
(mth/precision 6))]
(if (mth/nan? d) 0 d)))))
(defn update-angle
@ -173,7 +195,7 @@
(defn transform
"Transform a point applying a matrix transfomation."
[{:keys [x y] :as p} {:keys [a b c d e f] :as m}]
[{:keys [x y] :as p} {:keys [a b c d e f]}]
(assert (point? p))
(Point. (+ (* x a) (* y c) e)
(+ (* x b) (* y d) f)))

52
common/app/common/geom/proportions.cljc Normal file
View file

@ -0,0 +1,52 @@
;; 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.common.geom.proportions)
;; --- Proportions
(declare assign-proportions-path)
(declare assign-proportions-rect)
(defn assign-proportions
[{:keys [type] :as shape}]
(case type
:path (assign-proportions-path shape)
(assign-proportions-rect shape)))
(defn- assign-proportions-rect
[{:keys [width height] :as shape}]
(assoc shape :proportion (/ width height)))
;; --- Setup Proportions
(declare setup-proportions-const)
(declare setup-proportions-image)
(defn setup-proportions
[shape]
(case (:type shape)
:icon (setup-proportions-image shape)
:image (setup-proportions-image shape)
:text shape
(setup-proportions-const shape)))
(defn setup-proportions-image
[{:keys [metadata] :as shape}]
(let [{:keys [width height]} metadata]
(assoc shape
:proportion (/ width height)
:proportion-lock false)))
(defn setup-proportions-const
[shape]
(assoc shape
:proportion 1
:proportion-lock false))

907
common/app/common/geom/shapes.cljc
View file

@ -9,67 +9,26 @@
(ns app.common.geom.shapes
(:require
[clojure.spec.alpha :as s]
[app.common.spec :as us]
[app.common.data :as d]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.math :as mth]
[app.common.data :as d]))
(defn- nilf
"Returns a new function that if you pass nil as any argument will
return nil"
[f]
(fn [& args]
(if (some nil? args)
nil
(apply f args))))
[app.common.geom.shapes.common :as gco]
[app.common.geom.shapes.path :as gsp]
[app.common.geom.shapes.rect :as gpr]
[app.common.geom.shapes.transforms :as gtr]
[app.common.spec :as us]))
;; --- Relative Movement
(declare move-rect)
(declare move-path)
(defn -chk
"Function that checks if a number is nil or nan. Will return 0 when not
valid and the number otherwise."
[v]
(if (or (not v) (mth/nan? v)) 0 v))
(defn move
"Move the shape relativelly to its current
position applying the provided delta."
[shape {dx :x dy :y}]
(let [inc-x (nilf (fn [x] (+ (-chk x) (-chk dx))))
inc-y (nilf (fn [y] (+ (-chk y) (-chk dy))))
inc-point (nilf (fn [p] (-> p
(update :x inc-x)
(update :y inc-y))))]
(let [dx (d/check-num dx)
dy (d/check-num dy)]
(-> shape
(update :x inc-x)
(update :y inc-y)
(update-in [:selrect :x] inc-x)
(update-in [:selrect :x1] inc-x)
(update-in [:selrect :x2] inc-x)
(update-in [:selrect :y] inc-y)
(update-in [:selrect :y1] inc-y)
(update-in [:selrect :y2] inc-y)
(update :points #(mapv inc-point %))
(update :segments #(mapv inc-point %)))))
;; Duplicated from pages-helpers to remove cyclic dependencies
(defn get-children [id objects]
(let [shapes (vec (get-in objects [id :shapes]))]
(if shapes
(d/concat shapes (mapcat #(get-children % objects) shapes))
[])))
(defn recursive-move
"Move the shape and all its recursive children."
[shape dpoint objects]
(let [children-ids (get-children (:id shape) objects)
children (map #(get objects %) children-ids)]
(map #(move % dpoint) (cons shape children))))
(assoc-in [:modifiers :displacement] (gmt/translate-matrix (gpt/point dx dy)))
(gtr/transform-shape))))
;; --- Absolute Movement
@ -77,116 +36,35 @@
(defn absolute-move
"Move the shape to the exactly specified position."
[shape position]
(case (:type shape)
(:curve :path) shape
(absolute-move-rect shape position)))
(defn- absolute-move-rect
"A specialized function for absolute moviment
for rect-like shapes."
[shape {:keys [x y] :as pos}]
(let [dx (if x (- (-chk x) (-chk (:x shape))) 0)
dy (if y (- (-chk y) (-chk (:y shape))) 0)]
[shape {:keys [x y]}]
(let [dx (- (d/check-num x) (-> shape :selrect :x))
dy (- (d/check-num y) (-> shape :selrect :y))]
(move shape (gpt/point dx dy))))
;; --- Center
(declare center-rect)
(declare center-path)
(defn center
"Calculate the center of the shape."
[shape]
(case (:type shape)
:curve (center-path shape)
:path (center-path shape)
(center-rect shape)))
(defn- center-rect
[{:keys [x y width height] :as shape}]
(gpt/point (+ x (/ width 2)) (+ y (/ height 2))))
(defn- center-path
[{:keys [segments] :as shape}]
(let [minx (apply min (map :x segments))
miny (apply min (map :y segments))
maxx (apply max (map :x segments))
maxy (apply max (map :y segments))]
(gpt/point (/ (+ minx maxx) 2) (/ (+ miny maxy) 2))))
(defn center->rect
"Creates a rect given a center and a width and height"
[center width height]
{:x (- (:x center) (/ width 2))
:y (- (:y center) (/ height 2))
:width width
:height height})
;; --- Proportions
(declare assign-proportions-path)
(declare assign-proportions-rect)
(defn assign-proportions
[{:keys [type] :as shape}]
(case type
:path (assign-proportions-path shape)
(assign-proportions-rect shape)))
(defn- assign-proportions-rect
[{:keys [width height] :as shape}]
(assoc shape :proportion (/ width height)))
;; --- Paths
(defn update-path-point
"Update a concrete point in the path.
The point should exists before, this function
does not adds it automatically."
[shape index point]
(assoc-in shape [:segments index] point))
;; --- Setup Proportions
(declare setup-proportions-const)
(declare setup-proportions-image)
(defn setup-proportions
[shape]
(case (:type shape)
:icon (setup-proportions-image shape)
:image (setup-proportions-image shape)
:text shape
(setup-proportions-const shape)))
(defn setup-proportions-image
[{:keys [metadata] :as shape}]
(let [{:keys [width height]} metadata]
(assoc shape
:proportion (/ width height)
:proportion-lock false)))
(defn setup-proportions-const
[shape]
(assoc shape
:proportion 1
:proportion-lock false))
;; --- Resize (Dimensions)
(defn resize
[shape width height]
(us/assert map? shape)
(us/assert number? width)
(us/assert number? height)
(-> shape
(assoc :width width :height height)
(update :selrect (fn [selrect]
(assoc selrect
:x2 (+ (:x1 selrect) width)
:y2 (+ (:y1 selrect) height))))))
(let [shape-transform (:transform shape (gmt/matrix))
shape-transform-inv (:transform-inverse shape (gmt/matrix))
shape-center (gco/center-shape shape)
{sr-width :width sr-height :height} (:selrect shape)
origin (-> (gpt/point (:selrect shape))
(gtr/transform-point-center shape-center shape-transform))
scalev (gpt/divide (gpt/point width height)
(gpt/point sr-width sr-height))]
(-> shape
(update :modifiers assoc
:resize-vector scalev
:resize-origin origin
:resize-transform shape-transform
:resize-transform-inverse shape-transform-inv)
(gtr/transform-shape))))
(defn resize-rect
[shape attr value]
@ -207,9 +85,29 @@
(resize shape (:width new-size) (:height new-size))))
;; --- Setup (Initialize)
;; FIXME: Is this the correct place for these functions?
(declare setup-rect)
(declare setup-image)
(defn- setup-rect
"A specialized function for setup rect-like shapes."
[shape {:keys [x y width height]}]
(let [rect {:x x :y y :width width :height height}
points (gpr/rect->points rect)
selrect (gpr/points->selrect points)]
(assoc shape
:x x
:y y
:width width
:height height
:points points
:selrect selrect)))
(defn- setup-image
[{:keys [metadata] :as shape} props]
(-> (setup-rect shape props)
(assoc
:proportion (/ (:width metadata)
(:height metadata))
:proportion-lock true)))
(defn setup
"A function that initializes the first coordinates for
@ -219,324 +117,45 @@
:image (setup-image shape props)
(setup-rect shape props)))
(declare shape->points)
(declare points->selrect)
(defn- setup-rect
"A specialized function for setup rect-like shapes."
[shape {:keys [x y width height]}]
(as-> shape $
(assoc $ :x x
:y y
:width width
:height height)
(assoc $ :points (shape->points $))
(assoc $ :selrect (points->selrect (:points $)))))
(defn- setup-image
[{:keys [metadata] :as shape} {:keys [x y width height] :as props}]
(-> (setup-rect shape props)
(assoc
:proportion (/ (:width metadata)
(:height metadata))
:proportion-lock true)))
;; --- Coerce to Rect-like shape.
(declare path->rect-shape)
(declare group->rect-shape)
(declare rect->rect-shape)
;; TODO: completly remove
(defn shape->rect-shape
"Coerce shape to rect like shape."
[{:keys [type] :as shape}]
(case type
(:curve :path) (path->rect-shape shape)
(rect->rect-shape shape)))
;; -- Points
(declare transform-shape-point)
(defn shape->points [shape]
(let [points (case (:type shape)
(:curve :path) (:segments shape)
(let [{:keys [x y width height]} shape]
[(gpt/point x y)
(gpt/point (+ x width) y)
(gpt/point (+ x width) (+ y height))
(gpt/point x (+ y height))]))]
(->> points
(map #(transform-shape-point % shape (:transform shape (gmt/matrix))))
(map gpt/round)
(vec))))
(defn points->selrect [points]
(let [minx (transduce (map :x) min ##Inf points)
miny (transduce (map :y) min ##Inf points)
maxx (transduce (map :x) max ##-Inf points)
maxy (transduce (map :y) max ##-Inf points)]
{:x1 minx
:y1 miny
:x2 maxx
:y2 maxy
:x minx
:y miny
:width (- maxx minx)
:height (- maxy miny)
:type :rect}))
;; Shape->PATH
(declare rect->path)
(defn shape->path
[shape]
(case (:type shape)
(:curve :path) shape
(rect->path shape)))
(defn rect->path
[{:keys [x y width height] :as shape}]
(let [points [(gpt/point x y)
(gpt/point (+ x width) y)
(gpt/point (+ x width) (+ y height))
(gpt/point x (+ y height))
(gpt/point x y)]]
(-> shape
(assoc :type :path)
(assoc :segments points))))
;; --- SHAPE -> RECT
(defn- rect->rect-shape
[{:keys [x y width height] :as shape}]
(assoc shape
:x1 x
:y1 y
:x2 (+ x width)
:y2 (+ y height)))
(defn- path->rect-shape
[{:keys [segments] :as shape}]
(merge shape
{:type :rect}
(:selrect shape)))
;; --- Resolve Shape
(declare resolve-rect-shape)
(declare translate-from-frame)
(declare translate-to-frame)
(defn resolve-shape
[objects shape]
(case (:type shape)
:rect (resolve-rect-shape objects shape)
:group (resolve-rect-shape objects shape)
:frame (resolve-rect-shape objects shape)))
(defn- resolve-rect-shape
[objects {:keys [parent] :as shape}]
(loop [pobj (get objects parent)]
(if (= :frame (:type pobj))
(translate-from-frame shape pobj)
(recur (get objects (:parent pobj))))))
;; --- Transform Shape
(declare transform-rect)
(declare transform-path)
(defn transform
"Apply the matrix transformation to shape."
[{:keys [type] :as shape} xfmt]
(if (gmt/matrix? xfmt)
(case type
:path (transform-path shape xfmt)
:curve (transform-path shape xfmt)
(transform-rect shape xfmt))
shape))
(defn center-transform [shape matrix]
(let [shape-center (center shape)]
(-> shape
(transform
(-> (gmt/matrix)
(gmt/translate shape-center)
(gmt/multiply matrix)
(gmt/translate (gpt/negate shape-center)))))))
(defn- transform-rect
[{:keys [x y width height] :as shape} mx]
(let [tl (gpt/transform (gpt/point x y) mx)
tr (gpt/transform (gpt/point (+ x width) y) mx)
bl (gpt/transform (gpt/point x (+ y height)) mx)
br (gpt/transform (gpt/point (+ x width) (+ y height)) mx)
;; TODO: replace apply with transduce (performance)
minx (apply min (map :x [tl tr bl br]))
maxx (apply max (map :x [tl tr bl br]))
miny (apply min (map :y [tl tr bl br]))
maxy (apply max (map :y [tl tr bl br]))]
(assoc shape
:x minx
:y miny
:width (- maxx minx)
:height (- maxy miny))))
(defn- transform-path
[{:keys [segments] :as shape} xfmt]
(let [segments (mapv #(gpt/transform % xfmt) segments)]
(assoc shape :segments segments)))
;; --- Outer Rect
(defn selection-rect
"Returns a rect that contains all the shapes and is aware of the
rotation of each shape. Mainly used for multiple selection."
[shapes]
(let [shapes (map :selrect shapes)
minx (transduce (map :x1) min ##Inf shapes)
miny (transduce (map :y1) min ##Inf shapes)
maxx (transduce (map :x2) max ##-Inf shapes)
maxy (transduce (map :y2) max ##-Inf shapes)]
{:x1 minx
:y1 miny
:x2 maxx
:y2 maxy
:x minx
:y miny
:width (- maxx minx)
:height (- maxy miny)
:points [(gpt/point minx miny)
(gpt/point maxx miny)
(gpt/point maxx maxy)
(gpt/point minx maxy)]
:type :rect}))
(->> shapes
(gtr/transform-shape)
(map (comp gpr/points->selrect :points))
(gpr/join-selrects)))
(defn translate-to-frame
[shape {:keys [x y] :as frame}]
[shape {:keys [x y]}]
(move shape (gpt/point (- x) (- y))))
(defn translate-from-frame
[shape {:keys [x y] :as frame}]
[shape {:keys [x y]}]
(move shape (gpt/point x y)))
;; --- Alignment
(s/def ::align-axis #{:hleft :hcenter :hright :vtop :vcenter :vbottom})
(declare calc-align-pos)
(defn align-to-rect
"Move the shape so that it is aligned with the given rectangle
in the given axis. Take account the form of the shape and the
possible rotation. What is aligned is the rectangle that wraps
the shape with the given rectangle. If the shape is a group,
move also all of its recursive children."
[shape rect axis objects]
(let [wrapper-rect (selection-rect [shape])
align-pos (calc-align-pos wrapper-rect rect axis)
delta {:x (- (:x align-pos) (:x wrapper-rect))
:y (- (:y align-pos) (:y wrapper-rect))}]
(recursive-move shape delta objects)))
(defn calc-align-pos
[wrapper-rect rect axis]
(case axis
:hleft (let [left (:x rect)]
{:x left
:y (:y wrapper-rect)})
:hcenter (let [center (+ (:x rect) (/ (:width rect) 2))]
{:x (- center (/ (:width wrapper-rect) 2))
:y (:y wrapper-rect)})
:hright (let [right (+ (:x rect) (:width rect))]
{:x (- right (:width wrapper-rect))
:y (:y wrapper-rect)})
:vtop (let [top (:y rect)]
{:x (:x wrapper-rect)
:y top})
:vcenter (let [center (+ (:y rect) (/ (:height rect) 2))]
{:x (:x wrapper-rect)
:y (- center (/ (:height wrapper-rect) 2))})
:vbottom (let [bottom (+ (:y rect) (:height rect))]
{:x (:x wrapper-rect)
:y (- bottom (:height wrapper-rect))})))
;; --- Distribute
(s/def ::dist-axis #{:horizontal :vertical})
(defn distribute-space
"Distribute equally the space between shapes in the given axis. If
there is no space enough, it does nothing. It takes into account
the form of the shape and the rotation, what is distributed is
the wrapping recangles of the shapes. If any shape is a group,
move also all of its recursive children."
[shapes axis objects]
(let [coord (if (= axis :horizontal) :x :y)
other-coord (if (= axis :horizontal) :y :x)
size (if (= axis :horizontal) :width :height)
; The rectangle that wraps the whole selection
wrapper-rect (selection-rect shapes)
; Sort shapes by the center point in the given axis
sorted-shapes (sort-by #(coord (center %)) shapes)
; Each shape wrapped in its own rectangle
wrapped-shapes (map #(selection-rect [%]) sorted-shapes)
; The total space between shapes
space (reduce - (size wrapper-rect) (map size wrapped-shapes))]
(if (<= space 0)
shapes
(let [unit-space (/ space (- (count wrapped-shapes) 1))
; Calculate the distance we need to move each shape.
; The new position of each one is the position of the
; previous one plus its size plus the unit space.
deltas (loop [shapes' wrapped-shapes
start-pos (coord wrapper-rect)
deltas []]
(let [first-shape (first shapes')
delta (- start-pos (coord first-shape))
new-pos (+ start-pos (size first-shape) unit-space)]
(if (= (count shapes') 1)
(conj deltas delta)
(recur (rest shapes')
new-pos
(conj deltas delta)))))]
(mapcat #(recursive-move %1 {coord %2 other-coord 0} objects)
sorted-shapes deltas)))))
;; --- Helpers
(defn contained-in?
"Check if a shape is contained in the
provided selection rect."
[shape selrect]
(let [{sx1 :x1 sx2 :x2 sy1 :y1 sy2 :y2} (shape->rect-shape selrect)
{rx1 :x1 rx2 :x2 ry1 :y1 ry2 :y2} (shape->rect-shape shape)]
(let [{sx1 :x1 sx2 :x2 sy1 :y1 sy2 :y2} selrect
{rx1 :x1 rx2 :x2 ry1 :y1 ry2 :y2} (:selrect shape)]
(and (neg? (- sy1 ry1))
(neg? (- sx1 rx1))
(pos? (- sy2 ry2))
(pos? (- sx2 rx2)))))
;; TODO: This not will work for rotated shapes
(defn overlaps?
"Check if a shape overlaps with provided selection rect."
[shape selrect]
(let [{sx1 :x1 sx2 :x2 sy1 :y1 sy2 :y2} (shape->rect-shape selrect)
{rx1 :x1 rx2 :x2 ry1 :y1 ry2 :y2} (shape->rect-shape shape)]
[shape rect]
(let [{sx1 :x1 sx2 :x2 sy1 :y1 sy2 :y2} (gpr/rect->selrect rect)
{rx1 :x1 rx2 :x2 ry1 :y1 ry2 :y2} (gpr/points->selrect (:points shape))]
(and (< rx1 sx2)
(> rx2 sx1)
(< ry1 sy2)
@ -564,43 +183,6 @@
:type :rect}]
(overlaps? shape selrect)))
(defn calculate-rec-path-skew-angle
[path-shape]
(let [p1 (get-in path-shape [:segments 2])
p2 (get-in path-shape [:segments 3])
p3 (get-in path-shape [:segments 4])
v1 (gpt/to-vec p1 p2)
v2 (gpt/to-vec p2 p3)]
(- 90 (gpt/angle-with-other v1 v2))))
(defn calculate-rec-path-height
"Calculates the height of a paralelogram given by the path"
[path-shape]
(let [p1 (get-in path-shape [:segments 2])
p2 (get-in path-shape [:segments 3])
p3 (get-in path-shape [:segments 4])
v1 (gpt/to-vec p1 p2)
v2 (gpt/to-vec p2 p3)
angle (gpt/angle-with-other v1 v2)]
(* (gpt/length v2) (mth/sin (mth/radians angle)))))
(defn calculate-rec-path-rotation
[path-shape1 path-shape2 resize-vector]
(let [idx-1 0
idx-2 (cond (and (neg? (:x resize-vector)) (pos? (:y resize-vector))) 1
(and (neg? (:x resize-vector)) (neg? (:y resize-vector))) 2
(and (pos? (:x resize-vector)) (neg? (:y resize-vector))) 3
:else 0)
p1 (get-in path-shape1 [:segments idx-1])
p2 (get-in path-shape2 [:segments idx-2])
v1 (gpt/to-vec (center path-shape1) p1)
v2 (gpt/to-vec (center path-shape2) p2)
rot-angle (gpt/angle-with-other v1 v2)
rot-sign (if (> (* (:y v1) (:x v2)) (* (:x v1) (:y v2))) -1 1)]
(* rot-sign rot-angle)))
(defn pad-selrec
([selrect] (pad-selrec selrect 1))
([selrect size]
@ -619,16 +201,22 @@
(defn selrect->areas [bounds selrect]
(let [make-selrect
(fn [x1 y1 x2 y2]
{:x1 x1 :y1 y1 :x2 x2 :y2 y2 :x x1 :y y1
:width (- x2 x1) :height (- y2 y1) :type :rect})
{frame-x1 :x1 frame-x2 :x2 frame-y1 :y1 frame-y2 :y2
frame-width :width frame-height :height} bounds
{sr-x1 :x1 sr-x2 :x2 sr-y1 :y1 sr-y2 :y2
sr-width :width sr-height :height} selrect]
{:left (make-selrect frame-x1 sr-y1 sr-x1 sr-y2)
:top (make-selrect sr-x1 frame-y1 sr-x2 sr-y1)
:right (make-selrect sr-x2 sr-y1 frame-x2 sr-y2)
:bottom (make-selrect sr-x1 sr-y2 sr-x2 frame-y2)}))
(let [x1 (min x1 x2)
x2 (max x1 x2)
y1 (min y1 y2)
y2 (max y1 y2)]
{:x1 x1 :y1 y1
:x2 x2 :y2 y2
:x x1 :y y1
:width (- x2 x1)
:height (- y2 y1)
:type :rect}))
{frame-x1 :x1 frame-x2 :x2 frame-y1 :y1 frame-y2 :y2} bounds
{sr-x1 :x1 sr-x2 :x2 sr-y1 :y1 sr-y2 :y2} selrect]
{:left (make-selrect frame-x1 sr-y1 (- sr-x1 2) sr-y2)
:top (make-selrect sr-x1 frame-y1 sr-x2 (- sr-y1 2))
:right (make-selrect (+ sr-x2 2) sr-y1 frame-x2 sr-y2)
:bottom (make-selrect sr-x1 (+ sr-y2 2) sr-x2 frame-y2)}))
(defn distance-selrect [selrect other]
(let [{:keys [x1 y1]} other
@ -658,310 +246,37 @@
(and (>= s1c1 s2c1) (<= s1c1 s2c2))
(and (>= s1c2 s2c1) (<= s1c2 s2c2)))))
(defn transform-shape-point
"Transform a point around the shape center"
[point shape transform]
(let [shape-center (center shape)]
(gpt/transform
point
(-> (gmt/multiply
(gmt/translate-matrix shape-center)
transform
(gmt/translate-matrix (gpt/negate shape-center)))))))
(defn transform-apply-modifiers
[shape]
(let [modifiers (:modifiers shape)
ds-modifier (:displacement modifiers (gmt/matrix))
{res-x :x res-y :y} (:resize-vector modifiers (gpt/point 1 1))
(defn setup-selrect [shape]
(let [selrect (gpr/rect->selrect shape)
points (gpr/rect->points shape)]
(-> shape
(assoc :selrect selrect
:points points))))
;; Normalize x/y vector coordinates because scale by 0 is infinite
res-x (cond
(and (< res-x 0) (> res-x -0.01)) -0.01
(and (>= res-x 0) (< res-x 0.01)) 0.01
:else res-x)
res-y (cond
(and (< res-y 0) (> res-y -0.01)) -0.01
(and (>= res-y 0) (< res-y 0.01)) 0.01
:else res-y)
resize (gpt/point res-x res-y)
origin (:resize-origin modifiers (gpt/point 0 0))
resize-transform (:resize-transform modifiers (gmt/matrix))
resize-transform-inverse (:resize-transform-inverse modifiers (gmt/matrix))
rt-modif (or (:rotation modifiers) 0)
shape (-> shape
(transform ds-modifier))
shape-center (center shape)]
(-> (shape->path shape)
(transform (-> (gmt/matrix)
;; Applies the current resize transformation
(gmt/translate origin)
(gmt/multiply resize-transform)
(gmt/scale resize)
(gmt/multiply resize-transform-inverse)
(gmt/translate (gpt/negate origin))
;; Applies the stacked transformations
(gmt/translate shape-center)
(gmt/multiply (gmt/rotate-matrix rt-modif))
(gmt/multiply (:transform shape (gmt/matrix)))
(gmt/translate (gpt/negate shape-center)))))))
(defn rect-path-dimensions [rect-path]
(let [seg (:segments rect-path)
[width height] (mapv (fn [[c1 c2]] (gpt/distance c1 c2)) (take 2 (d/zip seg (rest seg))))]
{:width width
:height height}))
(defn calculate-stretch [shape-path transform-inverse]
(let [shape-center (center shape-path)
shape-path-temp (transform
shape-path
(-> (gmt/matrix)
(gmt/translate shape-center)
(gmt/multiply transform-inverse)
(gmt/translate (gpt/negate shape-center))))
shape-path-temp-rec (shape->rect-shape shape-path-temp)
shape-path-temp-dim (rect-path-dimensions shape-path-temp)]
(gpt/divide (gpt/point (:width shape-path-temp-rec) (:height shape-path-temp-rec))
(gpt/point (:width shape-path-temp-dim) (:height shape-path-temp-dim)))))
(defn fix-invalid-rect-values
[rect-shape]
(letfn [(check [num]
(if (or (nil? num) (mth/nan? num) (= ##Inf num) (= ##-Inf num)) 0 num))
(to-positive [num] (if (< num 1) 1 num))]
(-> rect-shape
(update :x check)
(update :y check)
(update :width (comp to-positive check))
(update :height (comp to-positive check)))))
(defn transform-rect-shape
[shape]
(let [;; Apply modifiers to the rect as a path so we have the end shape expected
shape-path (transform-apply-modifiers shape)
shape-center (center shape-path)
resize-vector (-> (get-in shape [:modifiers :resize-vector] (gpt/point 1 1))
(update :x #(if (zero? %) 1 %))
(update :y #(if (zero? %) 1 %)))
;; Reverse the current transformation stack to get the base rectangle
shape-path-temp (center-transform shape-path (:transform-inverse shape (gmt/matrix)))
shape-path-temp-dim (rect-path-dimensions shape-path-temp)
shape-path-temp-rec (shape->rect-shape shape-path-temp)
;; This rectangle is the new data for the current rectangle. We want to change our rectangle
;; to have this width, height, x, y
rec (center->rect shape-center (:width shape-path-temp-dim) (:height shape-path-temp-dim))
rec (fix-invalid-rect-values rec)
rec-path (rect->path rec)
;; The next matrix is a series of transformations we have to do to the previous rec so that
;; after applying them the end result is the `shape-path-temp`
;; This is compose of three transformations: skew, resize and rotation
stretch-matrix (gmt/matrix)
skew-angle (calculate-rec-path-skew-angle shape-path-temp)
;; When one of the axis is flipped we have to reverse the skew
skew-angle (if (neg? (* (:x resize-vector) (:y resize-vector))) (- skew-angle) skew-angle )
skew-angle (if (mth/nan? skew-angle) 0 skew-angle)
(defn rotation-modifiers
[center shape angle]
(let [displacement (let [shape-center (gco/center-shape shape)]
(-> (gmt/matrix)
(gmt/rotate angle center)
(gmt/rotate (- angle) shape-center)))]
{:rotation angle
:displacement displacement}))
stretch-matrix (gmt/multiply stretch-matrix (gmt/skew-matrix skew-angle 0))
h1 (calculate-rec-path-height shape-path-temp)
h2 (calculate-rec-path-height (center-transform rec-path stretch-matrix))
h3 (/ h1 h2)
h3 (if (mth/nan? h3) 1 h3)
stretch-matrix (gmt/multiply stretch-matrix (gmt/scale-matrix (gpt/point 1 h3)))
rotation-angle (calculate-rec-path-rotation (center-transform rec-path stretch-matrix)
shape-path-temp resize-vector)
stretch-matrix (gmt/multiply (gmt/rotate-matrix rotation-angle) stretch-matrix)
;; This is the inverse to be able to remove the transformation
stretch-matrix-inverse (-> (gmt/matrix)
(gmt/scale (gpt/point 1 h3))
(gmt/skew (- skew-angle) 0)
(gmt/rotate (- rotation-angle)))
new-shape (as-> shape $
(merge $ rec)
(update $ :x #(mth/precision % 0))
(update $ :y #(mth/precision % 0))
(update $ :width #(mth/precision % 0))
(update $ :height #(mth/precision % 0))
(update $ :transform #(gmt/multiply (or % (gmt/matrix)) stretch-matrix))
(update $ :transform-inverse #(gmt/multiply stretch-matrix-inverse (or % (gmt/matrix))))
(assoc $ :points (shape->points $))
(assoc $ :selrect (points->selrect (:points $)))
(update $ :selrect fix-invalid-rect-values)
(update $ :rotation #(mod (+ (or % 0)
(or (get-in $ [:modifiers :rotation]) 0)) 360)))]
new-shape))
(declare update-path-selrect)
(defn transform-path-shape
[shape]
(-> shape
transform-apply-modifiers
update-path-selrect)
;; TODO: Addapt for paths is not working
#_(let [shape-path (transform-apply-modifiers shape)
shape-path-center (center shape-path)
shape-transform-inverse' (-> (gmt/matrix)
(gmt/translate shape-path-center)
(gmt/multiply (:transform-inverse shape (gmt/matrix)))
(gmt/multiply (gmt/rotate-matrix (- (:rotation-modifier shape 0))))
(gmt/translate (gpt/negate shape-path-center)))]
(-> shape-path
(transform shape-transform-inverse')
(add-rotate-transform (:rotation-modifier shape 0)))))
(defn transform-shape
"Transform the shape properties given the modifiers"
([shape] (transform-shape nil shape))
([frame shape]
(let [new-shape
(if (:modifiers shape)
(-> (case (:type shape)
(:curve :path) (transform-path-shape shape)
(transform-rect-shape shape))
(dissoc :modifiers))
shape)]
(cond-> new-shape
frame (translate-to-frame frame)))))
(defn transform-matrix
"Returns a transformation matrix without changing the shape properties.
The result should be used in a `transform` attribute in svg"
([{:keys [x y] :as shape}]
(let [shape-center (center shape)]
(-> (gmt/matrix)
(gmt/translate shape-center)
(gmt/multiply (:transform shape (gmt/matrix)))
(gmt/translate (gpt/negate shape-center))))))
(defn update-path-selrect [shape]
(as-> shape $
(assoc $ :points (shape->points $))
(assoc $ :selrect (points->selrect (:points $)))
(assoc $ :x (get-in $ [:selrect :x]))
(assoc $ :y (get-in $ [:selrect :y]))
(assoc $ :width (get-in $ [:selrect :width]))
(assoc $ :height (get-in $ [:selrect :height]))))
(defn adjust-to-viewport
([viewport srect] (adjust-to-viewport viewport srect nil))
([viewport srect {:keys [padding] :or {padding 0}}]
(let [gprop (/ (:width viewport) (:height viewport))
srect (-> srect
(update :x #(- % padding))
(update :y #(- % padding))
(update :width #(+ % padding padding))
(update :height #(+ % padding padding)))
width (:width srect)
height (:height srect)
lprop (/ width height)]
(cond
(> gprop lprop)
(let [width' (* (/ width lprop) gprop)
padding (/ (- width' width) 2)]
(-> srect
(update :x #(- % padding))
(assoc :width width')))
(< gprop lprop)
(let [height' (/ (* height lprop) gprop)
padding (/ (- height' height) 2)]
(-> srect
(update :y #(- % padding))
(assoc :height height')))
:else srect))))
(defn get-attrs-multi
[shapes attrs]
;; Extract some attributes of a list of shapes.
;; For each attribute, if the value is the same in all shapes,
;; wll take this value. If there is any shape that is different,
;; the value of the attribute will be the keyword :multiple.
;;
;; If some shape has the value nil in any attribute, it's
;; considered a different value. If the shape does not contain
;; the attribute, it's ignored in the final result.
;;
;; Example:
;; (def shapes [{:stroke-color "#ff0000"
;; :stroke-width 3
;; :fill-color "#0000ff"
;; :x 1000 :y 2000 :rx nil}
;; {:stroke-width "#ff0000"
;; :stroke-width 5
;; :x 1500 :y 2000}])
;;
;; (get-attrs-multi shapes [:stroke-color
;; :stroke-width
;; :fill-color
;; :rx
;; :ry])
;; >>> {:stroke-color "#ff0000"
;; :stroke-width :multiple
;; :fill-color "#0000ff"
;; :rx nil
;; :ry nil}
;;
(let [defined-shapes (filter some? shapes)
combine-value (fn [v1 v2] (cond
(= v1 v2) v1
(= v1 :undefined) v2
(= v2 :undefined) v1
:else :multiple))
combine-values (fn [attrs shape values]
(map #(combine-value (get shape % :undefined)
(get values % :undefined)) attrs))
select-attrs (fn [shape attrs]
(zipmap attrs (map #(get shape % :undefined) attrs)))
reducer (fn [result shape]
(zipmap attrs (combine-values attrs shape result)))
combined (reduce reducer
(select-attrs (first defined-shapes) attrs)
(rest defined-shapes))
cleanup-value (fn [value]
(if (= value :undefined) nil value))
cleanup (fn [result]
(zipmap attrs (map #(cleanup-value (get result %)) attrs)))]
(cleanup combined)))
(defn setup-selrect [{:keys [x y width height] :as shape}]
(-> shape
(assoc :selrect {:x x :y y
:width width :height height
:x1 x :y1 y
:x2 (+ x width) :y2 (+ y height)})))
;; EXPORTS
(d/export gco/center-shape)
(d/export gco/center-selrect)
(d/export gco/center-rect)
(d/export gpr/rect->selrect)
(d/export gpr/rect->points)
(d/export gpr/points->selrect)
(d/export gtr/transform-shape)
(d/export gtr/transform-matrix)
(d/export gtr/transform-point-center)
(d/export gtr/transform-rect)
(d/export gtr/update-group-selrect)
;; PATHS
(d/export gsp/content->points)
(d/export gsp/content->selrect)

53
common/app/common/geom/shapes/common.cljc Normal file
View file

@ -0,0 +1,53 @@
;; 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.common.geom.shapes.common
(:require
[app.common.geom.point :as gpt]
[app.common.math :as mth]))
(defn center-rect
[{:keys [x y width height]}]
(when (and (mth/finite? x)
(mth/finite? y)
(mth/finite? width)
(mth/finite? height))
(gpt/point (+ x (/ width 2))
(+ y (/ height 2)))))
(defn center-selrect
"Calculate the center of the shape."
[selrect]
(center-rect selrect))
(def map-x-xf (comp (map :x) (remove nil?)))
(def map-y-xf (comp (map :y) (remove nil?)))
(defn center-points [points]
(let [ptx (into [] map-x-xf points)
pty (into [] map-y-xf points)
minx (reduce min ##Inf ptx)
miny (reduce min ##Inf pty)
maxx (reduce max ##-Inf ptx)
maxy (reduce max ##-Inf pty)]
(gpt/point (/ (+ minx maxx) 2)
(/ (+ miny maxy) 2))))
(defn center-shape
"Calculate the center of the shape."
[shape]
(center-rect (:selrect shape)))
(defn make-centered-rect
"Creates a rect given a center and a width and height"
[center width height]
{:x (- (:x center) (/ width 2))
:y (- (:y center) (/ height 2))
:width width
:height height})

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