3pp-mirror/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-05-12 06:56:38 +02:00
Code Issues Projects Releases Packages Wiki Activity

🎉 Add malli based validation and coersion subsystem

Browse source
This commit is contained in:
Andrey Antukh 2023-03-18 10:32:26 +01:00
parent dbc08ba80f
commit 5ca3d01ea1
125 changed files with 4984 additions and 2762 deletions
Download patch file Download diff file Expand all files Collapse all files

49
backend/dev/user.clj
View file

@ -15,8 +15,19 @@
[app.common.spec :as us]
[app.common.transit :as t]
[app.common.uuid :as uuid]
[app.common.schema :as sm]
[app.common.schema.generators :as sg]
[app.common.schema.desc-native :as smdn]
[app.common.schema.desc-js-like :as smdj]
[app.config :as cfg]
[app.main :as main]
[malli.core :as m]
[malli.error :as me]
[malli.dev.pretty :as mdp]
[malli.transform :as mt]
[malli.util :as mu]
[malli.registry :as mr]
[malli.generator :as mg]
[app.srepl.helpers]
[app.srepl.main :as srepl]
[app.util.blob :as blob]
@ -31,7 +42,7 @@
[clojure.spec.alpha :as s]
[clojure.stacktrace :as trace]
[clojure.test :as test]
[clojure.test.check.generators :as gen]
[clojure.test.check.generators :as tgen]
[clojure.tools.namespace.repl :as repl]
[clojure.walk :refer [macroexpand-all]]
[criterium.core :as crit]
@ -130,3 +141,39 @@
(add-tap #(locking debug-tap
(prn "tap debug:" %)))
1))
(sm/def! ::test
[:map {:title "Foo"}
[:x :int]
[:y {:min 0} :double]
[:bar
[:map {:title "Bar"}
[:z :string]
[:v ::sm/uuid]]]
[:items
[:vector ::dt/instant]]])
(sm/def! ::test2
[:multi {:title "Foo" :dispatch :type}
[:x
[:map {:title "FooX"}
[:type [:= :x]]
[:x :int]]]
[:y
[:map
[:type [:= :x]]
[:y [::sm/one-of #{:a :b :c}]]]]
[:z
[:map {:title "FooZ"}
[:z
[:multi {:title "Bar" :dispatch :type}
[:a
[:map
[:type [:= :a]]
[:a :int]]]
[:b
[:map
[:type [:= :b]]
[:b :int]]]]]]]])

3
backend/resources/app/assets/swagger-ui-4.18.3.css Normal file
View file

File diff suppressed because one or more lines are too long

3
backend/resources/app/assets/swagger-ui-4.18.3.js Normal file
View file

File diff suppressed because one or more lines are too long

75
backend/resources/app/templates/api-doc-entry.tmpl
View file

@ -14,19 +14,27 @@
<span>AUTH</span>
</span>
{% endif %}
{% if item.webhook %}
<span class="tag">
<span>WEBHOOK</span>
</span>
{% endif %}
{% if item.params-schema-js %}
<span class="tag">
<span>SC</span>
</span>
{% else %}
<span class="tag">
<span>SP</span>
</span>
{% endif %}
</div>
</div>
<div class="rpc-row-detail hidden">
<h3>DOCSTRING:</h3>
<h4>DOCSTRING:</h4>
<section class="padded-section">
{% if item.added %}
<p class="small"><strong>Added:</strong> on v{{item.added}}</p>
{% endif %}
@ -35,13 +43,18 @@
<p class="small"><strong>Deprecated:</strong> since v{{item.deprecated}}</p>
{% endif %}
{% if item.entrypoint %}
<p class="small"><strong>URI:</strong> <a href="{{item.entrypoint}}">{{item.entrypoint}}</a></p>
{% endif %}
{% if item.docs %}
<p class="docstring"> {{item.docs}}</p>
{% endif %}
</section>
{% if item.changes %}
<h3>CHANGES:</h3>
<h4>CHANGES:</h4>
<section class="padded-section">
<ul class="changes">
@ -52,9 +65,55 @@
</section>
{% endif %}
<h3>SPEC EXPLAIN:</h3>
<section class="padded-section">
<pre class="spec-explain">{{item.spec}}</pre>
</section>
{% if item.spec %}
<h4>PARAMS (SPEC):</h4>
<section class="padded-section">
<pre class="spec-explain">{{item.spec}}</pre>
</section>
{% endif %}
{% if param-style = "js" %}
{% if item.params-schema-js %}
<h4>PARAMS:</h4>
<section class="padded-section">
<pre class="params-schema">{{item.params-schema-js}}</pre>
</section>
{% endif %}
{% if item.result-schema-js %}
<h4>RESPONSE:</h4>
<section class="padded-section">
<pre class="result">{{item.result-schema-js}}</pre>
</section>
{% endif %}
{% if item.webhook-schema-js %}
<h4>WEBHOOK PAYLOAD:</h4>
<section class="padded-section">
<pre class="webhook">{{item.webhook-schema-js}}</pre>
</section>
{% endif %}
{% else %}
{% if item.params-schema-clj %}
<h4>PARAMS:</h4>
<section class="padded-section">
<pre class="params-schema">{{item.params-schema-clj}}</pre>
</section>
{% endif %}
{% if item.result-schema-clj %}
<h4>RESPONSE:</h4>
<section class="padded-section">
<pre class="result">{{item.result-schema-clj}}</pre>
</section>
{% endif %}
{% if item.webhook-schema-clj %}
<h4>WEBHOOK PAYLOAD:</h4>
<section class="padded-section">
<pre class="webhook">{{item.webhook-schema-clj}}</pre>
</section>
{% endif %}
{% endif %}
</div>
</li>

76
backend/resources/app/templates/api-doc.css
View file

@ -27,12 +27,78 @@ main {
header {
border-bottom: 1px solid #c0c0c0;
display: flex;
flex-direction: column;
align-items: center;
justify-content: center;
width: 100%;
}
.rpc-doc-content {
header .menu {
display: flex;
align-items: center;
margin-top: 5px;
margin-bottom: 10px;
}
header .menu nav {
list-style: none;
padding: 0px;
margin: 0px;
display: flex;
width: 45px;
justify-content: space-between;
}
header .menu nav > a {
list-style: none;
padding: 0px;
margin: 0px;
cursor: pointer;
}
header .menu nav > a.selected {
font-weight: 600;
}
b {
font-weight: 500;
}
h2 {
margin-top: 30px;
}
h3 {
font-weight: 400;
font-size: 11px;
margin-top: 20px;
text-decoration: underline;
}
h4 {
font-weight: 300;
font-size: 11px;
}
.doc-content {
margin-top: 20px;
width: 100%;
display: flex;
flex-direction: column;
/* border: 1px solid red; */
padding: 5px;
}
.doc-content p {
line-height: 22px;
margin-bottom: 0px;
}
.doc-content h3 {
margin-bottom: 0px;
}
.rpc-doc-content {
width: 100%;
display: flex;
flex-direction: column;
@ -65,7 +131,7 @@ header {
.rpc-row-info {
cursor: pointer;
display: flex;
background-color: #eeeeee;
background-color: #e5e5e5;
padding: 5px 10px;
}
@ -108,6 +174,8 @@ header {
.rpc-row-detail {
padding: 5px 10px;
padding-bottom: 20px;
border-left: 2px solid #e5e5e5;
border-right: 2px solid #e5e5e5;
}
.rpc-row-detail p {
@ -143,3 +211,7 @@ header {
p.small strong {
font-size: 10px;
}
p.small a {
font-size: 10px;
}

62
backend/resources/app/templates/api-doc.tmpl
View file

@ -20,10 +20,68 @@
<main>
<header>
<h1>Penpot API Documentation (v{{version}})</h1>
<small class="menu">
[
<nav>
<a href="?type=js" {% if param-style = "js" %}class="selected"{% endif %}>JS</a>
<a href="?type=clj" {% if param-style = "cljs" %}class="selected"{% endif %}>CLJ</a>
</nav>
]
</small>
</header>
<section class="rpc-doc-content">
<section class="doc-content">
<h2>INTRODUCTION</h2>
<p>This documentation is intended to be a general overview of the penpot RPC API.
If you prefer, you can use <a href="/api/openapi.json">OpenAPI</a>
and/or <a href="/api/openapi">SwaggerUI</a> as alternative.</p>
<h2>RPC METHODS:</h2>
<h2>GENERAL NOTES</h2>
<h3>Authentication</h3>
<p>The penpot backend right now offerts two way for authenticate the request:
<b>cookies</b> (the same mechanism that we use ourselves on accessing the API from the
web application) and <b>access tokens</b>.</p>
<p>The cookie can be obtained using the <b>`login-with-password`</b> rpc method,
on successful login it sets the <b>`auth-token`</b> cookie with the session
token.</p>
<p>The access token can be obtained on the appropriate section on profile settings
and it should be provided using <b>`Authorization`</b> header with <b>`Token
&lt;token-string&gt;`</b> value.</p>
<h3>Content Negotiation</h3>
<p>The penpot API by default operates indistinctly with: <b>`application/json`</b>
and <b>`application/transit+json`</b> content types. You should specify the
desired content-type on the <b>`Accept`</b> header, the transit encoding is used
by default.</p>
<h3>Limits</h3>
<p>The rate limit work per user basis (this means that different api keys share
the same rate limit). For now the limits are not documented because we are
studying and analyzing the data. As a general rule, it should not be abused, if an
abusive use is detected, we will proceed to block the user's access to the
API.</p>
<h3>Webhooks</h3>
<p>All methods that emit webhook events are marked with flag <b>WEBHOOK</b>, the
data structure defined on each method represents the <i>payload</i> of the
event.</p>
<p>The webhook event structure has this aspect:</p>
<br/>
<pre>
{
"id": "db601c95-045f-808b-8002-362f08fcb621",
"name": "rename-file",
"props": &lt;payload&gt;,
"profileId": "db601c95-045f-808b-8002-361312e63531"
}
</pre>
</section>
<section class="rpc-doc-content">
<h2>RPC METHODS REFERENCE:</h2>
<ul class="rpc-items">
{% for item in methods %}
{% include "app/templates/api-doc-entry.tmpl" with item=item %}

100
backend/resources/app/templates/error-report.v3.tmpl Normal file
View file

@ -0,0 +1,100 @@
{% extends "app/templates/base.tmpl" %}
{% block title %}
penpot - error report v2 {{id}}
{% endblock %}
{% block content %}
<nav>
<div>[<a href="/dbg/error">⮜</a>]</div>
<div>[<a href="#message">message</a>]</div>
<div>[<a href="#props">props</a>]</div>
<div>[<a href="#context">context</a>]</div>
{% if params %}
<div>[<a href="#params">params</a>]</div>
{% endif %}
{% if data %}
<div>[<a href="#edata">data</a>]</div>
{% endif %}
{% if explain %}
<div>[<a href="#explain">explain</a>]</div>
{% endif %}
{% if value %}
<div>[<a href="#value">value</a>]</div>
{% endif %}
{% if trace %}
<div>[<a href="#trace">trace</a>]</div>
{% endif %}
</nav>
<main>
<div class="table">
<div class="table-row multiline">
<div id="message" class="table-key">MESSAGE: </div>
<div class="table-val">
<h1>{{hint}}</h1>
</div>
</div>
<div class="table-row multiline">
<div id="props" class="table-key">LOG PROPS: </div>
<div class="table-val">
<pre>{{props}}</pre>
</div>
</div>
<div class="table-row multiline">
<div id="context" class="table-key">CONTEXT: </div>
<div class="table-val">
<pre>{{context}}</pre>
</div>
</div>
{% if params %}
<div class="table-row multiline">
<div id="params" class="table-key">PARAMS: </div>
<div class="table-val">
<pre>{{params}}</pre>
</div>
</div>
{% endif %}
{% if data %}
<div class="table-row multiline">
<div id="edata" class="table-key">DATA: </div>
<div class="table-val">
<pre>{{data}}</pre>
</div>
</div>
{% endif %}
{% if value %}
<div class="table-row multiline">
<div id="value" class="table-key">VALIDATION VALUE: </div>
<div class="table-val">
<pre>{{value}}</pre>
</div>
</div>
{% endif %}
{% if explain %}
<div class="table-row multiline">
<div id="explain" class="table-key">EXPLAIN: </div>
<div class="table-val">
<pre>{{explain}}</pre>
</div>
</div>
{% endif %}
{% if trace %}
<div class="table-row multiline">
<div id="trace" class="table-key">TRACE:</div>
<div class="table-val">
<pre>{{trace}}</pre>
</div>
</div>
{% endif %}
</div>
</main>
{% endblock %}

28
backend/resources/app/templates/openapi.tmpl Normal file
View file

@ -0,0 +1,28 @@
<!DOCTYPE html>
<html lang="en">
<head>
<meta charset="utf-8" />
<meta name="viewport" content="width=device-width, initial-scale=1" />
<meta
name="description"
content="SwaggerUI"
/>
<title>PENPOT Swagger UI</title>
<style>{{swagger-css|safe}}</style>
</head>
<body>
<div id="swagger-ui"></div>
<script>{{swagger-js|safe}}</script>
<script>
window.onload = () => {
window.ui = SwaggerUIBundle({
url: '{{public-uri}}/api/openapi.json',
dom_id: '#swagger-ui',
presets: [
SwaggerUIBundle.presets.apis,
],
});
};
</script>
</body>
</html>

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

@ -323,6 +323,7 @@
(def default-flags
[:enable-backend-api-doc
:enable-backend-openapi-doc
:enable-backend-worker
:enable-secure-session-cookies
:enable-email-verification])

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

@ -154,8 +154,8 @@
[_ cfg]
(rr/router
[["" {:middleware [[mw/server-timing]
[mw/format-response]
[mw/params]
[mw/format-response]
[mw/parse-request]
[session/soft-auth cfg]
[actoken/soft-auth cfg]

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

@ -238,6 +238,9 @@
(-> (io/resource "app/templates/error-report.v2.tmpl")
(tmpl/render report)))
(render-template-v3 [{report :content}]
(-> (io/resource "app/templates/error-report.v3.tmpl")
(tmpl/render report)))
]
(when-not (authorized? pool request)
@ -245,9 +248,10 @@
:code :only-admins-allowed))
(if-let [report (get-report request)]
(let [result (if (= 1 (:version report))
(render-template-v1 report)
(render-template-v2 report))]
(let [result (case (:version report)
1 (render-template-v1 report)
2 (render-template-v2 report)
3 (render-template-v3 report))]
{::yrs/status 200
::yrs/body result
::yrs/headers {"content-type" "text/html; charset=utf-8"

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

@ -9,6 +9,7 @@
(:require
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.http :as-alias http]
[app.http.access-token :as-alias actoken]
[app.http.session :as-alias session]
@ -82,6 +83,14 @@
(dissoc ::s/problems ::s/value)
(cond-> explain (assoc :explain explain)))})
(= code :params-validation)
(let [explain (::sm/explain data)
payload (sm/humanize-data explain)]
{::yrs/status 400
::yrs/body (-> data
(dissoc ::sm/explain)
(assoc :data payload))})
(= code :request-body-too-large)
{::yrs/status 413 ::yrs/body data}
@ -90,16 +99,38 @@
(defmethod handle-exception :assertion
[error request]
(let [edata (ex-data error)
explain (ex/explain edata)]
(binding [l/*context* (request->context request)]
(l/error :hint "Assertion error" :message (ex-message error) :cause error)
{::yrs/status 500
::yrs/body {:type :server-error
:code :assertion
:data (-> edata
(dissoc ::s/problems ::s/value ::s/spec)
(cond-> explain (assoc :explain explain)))}})))
(binding [l/*context* (request->context request)]
(let [{:keys [code] :as data} (ex-data error)]
(cond
(= code :data-validation)
(let [explain (::sm/explain data)
payload (sm/humanize-data explain)]
(l/error :hint "Data assertion error" :message (ex-message error) :cause error)
{::yrs/status 500
::yrs/body {:type :server-error
:code :assertion
:data (-> data
(dissoc ::sm/explain)
(assoc :data payload))}})
(= code :spec-validation)
(let [explain (ex/explain data)]
(l/error :hint "Spec assertion error" :message (ex-message error) :cause error)
{::yrs/status 500
::yrs/body {:type :server-error
:code :assertion
:data (-> data
(dissoc ::s/problems ::s/value ::s/spec)
(cond-> explain (assoc :explain explain)))}})
:else
(do
(l/error :hint "Assertion error" :message (ex-message error) :cause error)
{::yrs/status 500
::yrs/body {:type :server-error
:code :assertion
:data data}})))))
(defmethod handle-exception :not-found
[err _]

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

@ -141,7 +141,7 @@
(defn prepare-event
[cfg mdata params result]
(let [resultm (meta result)
request (::http/request params)
request (-> params meta ::http/request)
profile-id (or (::profile-id resultm)
(:profile-id result)
(::rpc/profile-id params)
@ -171,7 +171,7 @@
;; NOTE: for batch-key lookup we need the params as-is
;; because the rpc api does not need to know the
;; audit/webhook specific object layout.
::rpc/params (dissoc params ::http/request)
::rpc/params params
::webhooks/batch-key
(or (::webhooks/batch-key mdata)

51
backend/src/app/loggers/database.clj
View file

@ -11,6 +11,7 @@
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.pprint :as pp]
[app.common.schema :as sm]
[app.common.spec :as us]
[app.config :as cf]
[app.db :as db]
@ -32,35 +33,41 @@
(when-not (db/read-only? pool)
(db/insert! pool :server-error-report
{:id id
:version 2
:version 3
:content (db/tjson report)})))
(defn record->report
[{:keys [::l/context ::l/message ::l/props ::l/logger ::l/level ::l/cause] :as record}]
(us/assert! ::l/record record)
(merge
{:context (-> context
(assoc :tenant (cf/get :tenant))
(assoc :host (cf/get :host))
(assoc :public-uri (cf/get :public-uri))
(assoc :version (:full cf/version))
(assoc :logger-name logger)
(assoc :logger-level level)
(dissoc :params)
(pp/pprint-str :width 200))
:params (some-> (:params context)
(pp/pprint-str :width 200))
:props (pp/pprint-str props :width 200)
:hint (or (ex-message cause) @message)
:trace (ex/format-throwable cause :data? false :explain? false :header? false :summary? false)}
(let [data (ex-data cause)]
(merge
{:context (-> context
(assoc :tenant (cf/get :tenant))
(assoc :host (cf/get :host))
(assoc :public-uri (cf/get :public-uri))
(assoc :version (:full cf/version))
(assoc :logger-name logger)
(assoc :logger-level level)
(dissoc :params)
(pp/pprint-str :width 200))
:props (pp/pprint-str props :width 200)
:hint (or (ex-message cause) @message)
:trace (ex/format-throwable cause :data? false :explain? false :header? false :summary? false)}
(when-let [params (:params context)]
{:params (pp/pprint-str params :width 200)})
(when-let [data (some-> data (dissoc ::s/problems ::s/value ::s/spec ::sm/explain :hint))]
{:data (pp/pprint-str data :width 200)})
(when-let [value (-> data ::sm/explain :value)]
{:value (pp/pprint-str value :width 200)})
(when-let [explain (ex/explain data)]
{:explain explain}))))
(when-let [data (ex-data cause)]
{:spec-value (some-> (::s/value data) (pp/pprint-str :width 200))
:spec-explain (ex/explain data)
:data (-> data
(dissoc ::s/problems ::s/value ::s/spec :hint)
(pp/pprint-str :width 200))})))
(defn error-record?
[{:keys [::l/level ::l/cause]}]

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

@ -10,6 +10,9 @@
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.media :as cm]
[app.common.schema :as sm]
[app.common.schema.generators :as sg]
[app.common.schema.openapi :as-alias oapi]
[app.common.spec :as us]
[app.config :as cf]
[app.db :as-alias db]
@ -47,6 +50,27 @@
(s/keys :req-un [::path]
:opt-un [::mtype]))
(sm/def! ::fs/path
{:type ::fs/path
:pred fs/path?
:type-properties
{:title "path"
:description "filesystem path"
:error/message "expected a valid fs path instance"
:gen/gen (sg/generator :string)
::oapi/type "string"
::oapi/format "unix-path"
::oapi/decode fs/path}})
(sm/def! ::upload
[:map {:title "Upload"}
[:filename :string]
[:size :int]
[:path ::fs/path]
[:mtype {:optional true} :string]
[:headers {:optional true}
[:map-of :string :string]]])
(defn validate-media-type!
([upload] (validate-media-type! upload cm/valid-image-types))
([upload allowed]

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

@ -10,6 +10,7 @@
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.spec :as us]
[app.config :as cf]
[app.db :as db]
@ -74,15 +75,16 @@
etag (yrq/get-header request "if-none-match")
profile-id (or (::session/profile-id request)
(::actoken/profile-id request))
data (-> params
(assoc ::request-at (dt/now))
(assoc ::session/id (::session/id request))
(assoc ::http/request request)
(assoc ::cond/key etag)
(cond-> (uuid? profile-id)
(assoc ::profile-id profile-id)))
method (get methods type default-handler)]
data (vary-meta data assoc ::http/request request)
method (get methods type default-handler)]
(binding [cond/*enabled* true]
(let [response (method data)]
@ -127,9 +129,49 @@
(defn- wrap-spec-conform
[_ f mdata]
(let [spec (or (::sv/spec mdata) (s/spec any?))]
(fn [cfg params]
(f cfg (us/conform spec params)))))
;; NOTE: skip spec conform operation on rpc methods that already
;; uses malli validation mechanism.
(if (contains? mdata ::sm/params)
f
(if-let [spec (ex/ignoring (s/spec (::sv/spec mdata)))]
(fn [cfg params]
(f cfg (us/conform spec params)))
f)))
(defn- wrap-params-validation
[_ f mdata]
(if-let [schema (::sm/params mdata)]
(let [schema (sm/schema schema)
valid? (sm/validator schema)
explain (sm/explainer schema)
decode (sm/decoder schema sm/default-transformer)]
(fn [cfg params]
(let [params (decode params)]
(if (valid? params)
(f cfg params)
(ex/raise :type :validation
:code :params-validation
::sm/explain (explain params))))))
f))
(defn- wrap-output-validation
[_ f mdata]
(if (contains? cf/flags :rpc-output-validation)
(or (when-let [schema (::sm/result mdata)]
(let [schema (sm/schema schema)
valid? (sm/validator schema)
explain (sm/explainer schema)]
(fn [cfg params]
(let [response (f cfg params)]
(when (map? response)
(when-not (valid? response)
(ex/raise :type :validation
:code :data-validation
::sm/explain (explain response))))
response))))
f)
f))
(defn- wrap-all
[cfg f mdata]
@ -141,6 +183,8 @@
(rlimit/wrap cfg $ mdata)
(wrap-audit cfg $ mdata)
(wrap-spec-conform cfg $ mdata)
(wrap-output-validation cfg $ mdata)
(wrap-params-validation cfg $ mdata)
(wrap-authentication cfg $ mdata)))
(defn- wrap

5
backend/src/app/rpc/commands/audit.clj
View file

@ -39,8 +39,9 @@
:profile-id :ip-addr :props :context])
(defn- handle-events
[{:keys [::db/pool]} {:keys [::rpc/profile-id events ::http/request]}]
(let [ip-addr (audit/parse-client-ip request)
[{:keys [::db/pool]} {:keys [::rpc/profile-id events] :as params}]
(let [request (-> params meta ::http/request)
ip-addr (audit/parse-client-ip request)
xform (comp
(map #(assoc % :profile-id profile-id))
(map #(assoc % :ip-addr ip-addr))

150
backend/src/app/rpc/commands/files.clj
View file

@ -11,6 +11,9 @@
[app.common.exceptions :as ex]
[app.common.pages.helpers :as cph]
[app.common.pages.migrations :as pmg]
[app.common.schema :as sm]
[app.common.schema.desc-js-like :as-alias smdj]
[app.common.schema.generators :as sg]
[app.common.spec :as us]
[app.common.types.components-list :as ctkl]
[app.common.types.file :as ctf]
@ -19,7 +22,6 @@
[app.loggers.audit :as-alias audit]
[app.loggers.webhooks :as-alias webhooks]
[app.rpc :as-alias rpc]
[app.rpc.commands.files.thumbnails :as-alias thumbs]
[app.rpc.commands.projects :as projects]
[app.rpc.commands.teams :as teams]
[app.rpc.cond :as-alias cond]
@ -188,7 +190,7 @@
(ex/raise :type :restriction
:code :features-not-supported
:feature (first not-supported)
:hint (format "features %s not supported" (str/join "," not-supported))))
:hint (format "features %s not supported" (str/join "," (map name not-supported)))))
features))
(defn load-pointer
@ -264,6 +266,41 @@
;; --- COMMAND QUERY: get-file (by id)
(sm/def! ::features
[:schema
{:title "FileFeatures"
::smdj/inline true
:gen/gen (sg/subseq supported-features)}
::sm/set-of-strings])
(sm/def! ::file
[:map {:title "File"}
[:id ::sm/uuid]
[:features ::features]
[:has-media-trimmed :boolean]
[:comment-thread-seqn {:min 0} :int]
[:name :string]
[:revn {:min 0} :int]
[:modified-at ::dt/instant]
[:is-shared :boolean]
[:project-id ::sm/uuid]
[:created-at ::dt/instant]
[:data {:optional true} :any]])
(sm/def! ::permissions-mixin
[:map {:title "PermissionsMixin"}
[:permissions ::perms/permissions]])
(sm/def! ::file-with-permissions
[:merge {:title "FileWithPermissions"}
::file
::permissions-mixin])
(sm/def! ::get-file
[:map {:title "get-file"}
[:features {:optional true} ::features]
[:id ::sm/uuid]])
(defn get-file
[conn id client-features]
;; here we check if client requested features are supported
@ -282,17 +319,14 @@
[{:keys [modified-at revn]}]
(str (dt/format-instant modified-at :iso) "-" revn))
(s/def ::get-file
(s/keys :req [::rpc/profile-id]
:req-un [::id]
:opt-un [::features]))
(sv/defmethod ::get-file
"Retrieve a file by its ID. Only authenticated users."
{::doc/added "1.17"
::cond/get-object #(get-minimal-file %1 (:id %2))
::cond/key-fn get-file-etag}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id features]}]
::cond/key-fn get-file-etag
::sm/params ::get-file
::sm/result ::file-with-permissions}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id features] :as params}]
(dm/with-open [conn (db/open pool)]
(let [perms (get-permissions conn profile-id id)]
(check-read-permissions! perms)
@ -303,23 +337,29 @@
;; --- COMMAND QUERY: get-file-fragment (by id)
(sm/def! ::file-fragment
[:map {:title "FileFragment"}
[:id ::sm/uuid]
[:file-id ::sm/uuid]
[:created-at ::dt/instant]
[:content any?]])
(sm/def! ::get-file-fragment
[:map {:title "get-file-fragment"}
[:file-id ::sm/uuid]
[:fragment-id ::sm/uuid]
[:share-id {:optional true} ::sm/uuid]])
(defn- get-file-fragment
[conn file-id fragment-id]
(some-> (db/get conn :file-data-fragment {:file-id file-id :id fragment-id})
(update :content blob/decode)))
(s/def ::share-id ::us/uuid)
(s/def ::fragment-id ::us/uuid)
(s/def ::get-file-fragment
(s/keys :req-un [::file-id ::fragment-id]
:opt [::rpc/profile-id]
:opt-un [::share-id]))
(sv/defmethod ::get-file-fragment
"Retrieve a file by its ID. Only authenticated users."
{::doc/added "1.17"
::rpc/:auth false}
::sm/params ::get-file-fragment
::sm/result ::file-fragment}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id fragment-id share-id] }]
(dm/with-open [conn (db/open pool)]
(let [perms (get-permissions conn profile-id file-id share-id)]
@ -342,16 +382,16 @@
and f.deleted_at is null
order by f.modified_at desc")
(s/def ::get-project-files
(s/keys :req [::rpc/profile-id] :req-un [::project-id]))
(defn get-project-files
[conn project-id]
(db/exec! conn [sql:project-files project-id]))
(sv/defmethod ::get-project-files
"Get all files for the specified project."
{::doc/added "1.17"}
{::doc/added "1.17"
::sm/params [:map {:title "get-project-files"}
[:project-id ::sm/uuid]]
::sm/result [:vector ::file]}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id project-id]}]
(dm/with-open [conn (db/open pool)]
(projects/check-read-permissions! conn profile-id project-id)
@ -362,15 +402,12 @@
(declare get-has-file-libraries)
(s/def ::file-id ::us/uuid)
(s/def ::has-file-libraries
(s/keys :req [::rpc/profile-id]
:req-un [::file-id]))
(sv/defmethod ::has-file-libraries
"Checks if the file has libraries. Returns a boolean"
{::doc/added "1.15.1"}
{::doc/added "1.15.1"
::sm/params [:map {:title "has-file-libraries"}
[:file-id ::sm/uuid]]
::sm/result :boolean}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id]}]
(dm/with-open [conn (db/open pool)]
(check-read-permissions! pool profile-id file-id)
@ -398,7 +435,7 @@
structure."
[{:keys [objects] :as page} object-id]
(let [objects (cph/get-children-with-self objects object-id)]
(assoc page :objects (d/index-by :id objects))))
(assoc page :objects (d/index-by :id objects))))
(defn- prune-thumbnails
"Given the page data, removes the `:thumbnail` prop from all
@ -408,6 +445,12 @@
(defn get-page
[conn {:keys [file-id page-id object-id features]}]
(when (and (uuid? object-id)
(not (uuid? page-id)))
(ex/raise :type :validation
:code :params-validation
:hint "page-id is required when object-id is provided"))
(let [file (get-file conn file-id features)
page-id (or page-id (-> file :data :pages first))
page (dm/get-in file [:data :pages-index page-id])]
@ -415,17 +458,11 @@
(uuid? object-id)
(prune-objects object-id))))
(s/def ::page-id ::us/uuid)
(s/def ::object-id ::us/uuid)
(s/def ::get-page
(s/and
(s/keys :req [::rpc/profile-id]
:req-un [::file-id]
:opt-un [::page-id ::object-id ::features])
(fn [obj]
(if (contains? obj :object-id)
(contains? obj :page-id)
true))))
(sm/def! ::get-page
[:map {:title "GetPage"}
[:page-id {:optional true} ::sm/uuid]
[:object-id {:optional true} ::sm/uuid]
[:features {:optional true} ::features]])
(sv/defmethod ::get-page
"Retrieves the page data from file and returns it. If no page-id is
@ -437,7 +474,8 @@
mandatory.
Mainly used for rendering purposes."
{::doc/added "1.17"}
{::doc/added "1.17"
::sm/params ::get-page}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id] :as params}]
(dm/with-open [conn (db/open pool)]
(check-read-permissions! conn profile-id file-id)
@ -635,13 +673,30 @@
:modified-at (dt/now)}
{:id id}))
(s/def ::rename-file
(s/keys :req [::rpc/profile-id]
:req-un [::name ::id]))
(sv/defmethod ::rename-file
{::doc/added "1.17"
::webhooks/event? true}
::webhooks/event? true
::sm/webhook
[:map {:title "RenameFileEvent"}
[:id ::sm/uuid]
[:project-id ::sm/uuid]
[:name :string]
[:created-at ::dt/instant]
[:modified-at ::dt/instant]]
::sm/params
[:map {:title "RenameFileParams"}
[:name {:min 1} :string]
[:id ::sm/uuid]]
::sm/result
[:map {:title "SimplifiedFile"}
[:id ::sm/uuid]
[:name :string]
[:created-at ::dt/instant]
[:modified-at ::dt/instant]]}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id] :as params}]
(db/with-atomic [conn pool]
(check-edition-permissions! conn profile-id id)
@ -673,6 +728,7 @@
(let [ldata (-> library decode-row pmg/migrate-file :data)]
(binding [pmap/*load-fn* (partial load-pointer conn id)]
(load-all-pointers! ldata))
(->> (db/query conn :file-library-rel {:library-file-id id})
(map :file-id)
(keep #(db/get-by-id conn :file % ::db/check-deleted? false))

16
backend/src/app/rpc/commands/files_create.clj
View file

@ -40,21 +40,19 @@
:or {is-shared false revn 0 create-page true}
:as params}]
(db/exec-one! conn ["SET CONSTRAINTS ALL DEFERRED;"])
(let [id (or id (uuid/next))
features (->> features
(into (files/get-default-features))
(files/check-features-compatibility!))
data (binding [pmap/*tracked* (atom {})
pointers (atom {})
data (binding [pmap/*tracked* pointers
ffeat/*current* features
ffeat/*wrap-with-objects-map-fn* (if (features "storate/objects-map") omap/wrap identity)
ffeat/*wrap-with-pointer-map-fn* (if (features "storage/pointer-map") pmap/wrap identity)]
(let [data (if create-page
(ctf/make-file-data id)
(ctf/make-file-data id nil))]
(files/persist-pointers! conn id)
data))
(if create-page
(ctf/make-file-data id)
(ctf/make-file-data id nil)))
features (db/create-array conn "text" features)
file (db/insert! conn :file
@ -70,6 +68,9 @@
:modified-at modified-at
:deleted-at deleted-at}))]
(binding [pmap/*tracked* pointers]
(files/persist-pointers! conn id))
(->> (assoc params :file-id id :role :owner)
(create-file-role! conn))
@ -89,6 +90,7 @@
(sv/defmethod ::create-file
{::doc/added "1.17"
::doc/module :files
::webhooks/event? true}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id project-id] :as params}]
(db/with-atomic [conn pool]

6
backend/src/app/rpc/commands/files_share.clj
View file

@ -36,7 +36,8 @@
Share links are resources that allows external users access to specific
pages of a file with specific permissions (who-comment and who-inspect)."
{::doc/added "1.18"}
{::doc/added "1.18"
::doc/module :files}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id] :as params}]
(db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id file-id)
@ -62,7 +63,8 @@
:req-un [::us/id]))
(sv/defmethod ::delete-share-link
{::doc/added "1.18"}
{::doc/added "1.18"
::doc/module ::files}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id] :as params}]
(db/with-atomic [conn pool]
(let [slink (db/get-by-id conn :share-link id)]

9
backend/src/app/rpc/commands/files_temp.clj
View file

@ -36,7 +36,8 @@
::create-page]))
(sv/defmethod ::create-temp-file
{::doc/added "1.17"}
{::doc/added "1.17"
::doc/module :files}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id project-id] :as params}]
(db/with-atomic [conn pool]
(projects/check-edition-permissions! conn profile-id project-id)
@ -64,7 +65,8 @@
::files/id]))
(sv/defmethod ::update-temp-file
{::doc/added "1.17"}
{::doc/added "1.17"
::doc/module :files}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id] :as params}]
(db/with-atomic [conn pool]
(update-temp-file conn (assoc params :profile-id profile-id))
@ -101,7 +103,8 @@
:req-un [::files/id]))
(sv/defmethod ::persist-temp-file
{::doc/added "1.17"}
{::doc/added "1.17"
::doc/module :files}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id] :as params}]
(db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id id)

24
backend/src/app/rpc/commands/files_thumbnails.clj
View file

@ -11,6 +11,7 @@
[app.common.exceptions :as ex]
[app.common.geom.shapes :as gsh]
[app.common.pages.helpers :as cph]
[app.common.schema :as sm]
[app.common.spec :as us]
[app.common.types.shape-tree :as ctt]
[app.config :as cf]
@ -65,13 +66,12 @@
(or (some-> row :media-id get-public-uri)
(:data row))))))))
(s/def ::file-id ::us/uuid)
(s/def ::get-file-object-thumbnails
(s/keys :req [::rpc/profile-id] :req-un [::file-id]))
(sv/defmethod ::get-file-object-thumbnails
"Retrieve a file object thumbnails."
{::doc/added "1.17"
::sm/params [:map {:title "get-file-object-thumbnails"}
[:file-id ::sm/uuid]]
::sm/result [:map-of :string :string]
::cond/get-object #(files/get-minimal-file %1 (:file-id %2))
::cond/reuse-key? true
::cond/key-fn files/get-file-etag}
@ -102,6 +102,7 @@
:file-id (:file-id row)}))
(s/def ::revn ::us/integer)
(s/def ::file-id ::us/uuid)
(s/def ::get-file-thumbnail
(s/keys :req [::rpc/profile-id]
@ -217,15 +218,18 @@
:always
(update :objects assoc-thumbnails page-id thumbs))))))
(s/def ::get-file-data-for-thumbnail
(s/keys :req [::rpc/profile-id]
:req-un [::file-id]
:opt-un [::features]))
(sv/defmethod ::get-file-data-for-thumbnail
"Retrieves the data for generate the thumbnail of the file. Used
mainly for render thumbnails on dashboard."
{::doc/added "1.17"}
{::doc/added "1.17"
::sm/params [:map {:title "get-file-data-for-thumbnail"}
[:file-id ::sm/uuid]
[:features {:optional true} ::files/features]]
::sm/result [:map {:title "PartialFile"}
[:id ::sm/uuid]
[:revn {:min 0} :int]
[:page :any]]}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id features] :as props}]
(dm/with-open [conn (db/open pool)]
(files/check-read-permissions! conn profile-id file-id)

42
backend/src/app/rpc/commands/files_update.clj
View file

@ -10,7 +10,10 @@
[app.common.files.features :as ffeat]
[app.common.logging :as l]
[app.common.pages :as cp]
[app.common.pages.changes :as cpc]
[app.common.pages.migrations :as pmg]
[app.common.schema :as sm]
[app.common.schema.generators :as smg]
[app.common.spec :as us]
[app.common.types.file :as ctf]
[app.common.uuid :as uuid]
@ -60,6 +63,40 @@
(or (contains? o :changes)
(contains? o :changes-with-metadata)))))
;; --- SCHEMA
(sm/def! ::changes
[:vector ::cpc/change])
(sm/def! ::change-with-metadata
[:map {:title "ChangeWithMetadata"}
[:changes ::changes]
[:hint-origin {:optional true} :keyword]
[:hint-events {:optional true} [:vector :string]]])
(sm/def! ::update-file-params
[:map {:title "UpdateFileParams"}
[:id ::sm/uuid]
[:session-id ::sm/uuid]
[:revn {:min 0} :int]
[:features {:optional true
:gen/max 3
:gen/gen (smg/subseq files/supported-features)}
::sm/set-of-strings]
[:changes {:optional true} ::changes]
[:changes-with-metadata {:optional true}
[:vector ::change-with-metadata]]])
(sm/def! ::update-file-result
[:vector {:title "UpdateFileResults"}
[:map {:title "UpdateFileResult"}
[:changes ::changes]
[:file-id ::sm/uuid]
[:id ::sm/uuid]
[:revn {:min 0} :int]
[:session-id ::sm/uuid]]])
;; --- HELPERS
;; File changes that affect to the library, and must be notified
@ -130,6 +167,11 @@
::webhooks/event? true
::webhooks/batch-timeout (dt/duration "2m")
::webhooks/batch-key (webhooks/key-fn ::rpc/profile-id :id)
::sm/params ::update-file-params
::sm/result ::update-file-result
::doc/module :files
::doc/added "1.17"}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id] :as params}]
(db/with-atomic [conn pool]

74
backend/src/app/rpc/commands/profile.clj
View file

@ -8,8 +8,9 @@
(:require
[app.auth :as auth]
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
@ -37,19 +38,35 @@
(declare strip-private-attrs)
(declare verify-password)
;; --- QUERY: Get profile (own)
(def schema:profile
[:map {:title "Profile"}
[:id ::sm/uuid]
[:fullname :string]
[:email ::sm/email]
[:is-active {:optional true} :boolean]
[:is-blocked {:optional true} :boolean]
[:is-demo {:optional true} :boolean]
[:is-muted {:optional true} :boolean]
[:created-at {:optional true} ::sm/inst]
[:modified-at {:optional true} ::sm/inst]
[:default-project-id {:optional true} ::sm/uuid]
[:default-team-id {:optional true} ::sm/uuid]
[:props {:optional true}
[:map-of {:title "ProfileProps"} :keyword :any]]])
(s/def ::get-profile
(s/keys :opt [::rpc/profile-id]))
(def profile?
(sm/pred-fn schema:profile))
;; --- QUERY: Get profile (own)
(sv/defmethod ::get-profile
{::rpc/auth false
::doc/added "1.18"}
::doc/added "1.18"
::sm/result schema:profile}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id]}]
;; We need to return the anonymous profile object in two cases, when
;; no profile-id is in session, and when db call raises not found. In all other
;; cases we need to reraise the exception.
(try
(-> (get-profile pool profile-id)
(strip-private-attrs)
@ -63,22 +80,21 @@
(-> (db/get-by-id conn :profile id attrs)
(decode-row)))
;; --- MUTATION: Update Profile (own)
(s/def ::email ::us/email)
(s/def ::fullname ::us/not-empty-string)
(s/def ::lang ::us/string)
(s/def ::theme ::us/string)
(s/def ::update-profile
(s/keys :req [::rpc/profile-id]
:req-un [::fullname]
:opt-un [::lang ::theme]))
(sv/defmethod ::update-profile
{::doc/added "1.0"}
{::doc/added "1.0"
::sm/params [:map {:title "UpdateProfileParams"}
[:fullname {:min 1} :string]
[:lang {:optional true} :string]
[:theme {:optional true} :string]]
::sm/result schema:profile}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id fullname lang theme] :as params}]
(dm/assert!
"expected valid profile data"
(profile? params))
(db/with-atomic [conn pool]
;; NOTE: we need to retrieve the profile independently if we use
;; it or not for explicit locking and avoid concurrent updates of
@ -112,14 +128,13 @@
(declare update-profile-password!)
(declare invalidate-profile-session!)
(s/def ::password ::us/not-empty-string)
(s/def ::old-password (s/nilable ::us/string))
(s/def ::update-profile-password
(s/keys :req [::rpc/profile-id]
:req-un [::password ::old-password]))
(sv/defmethod ::update-profile-password
{:doc/added "1.0"
::sm/params [:map {:title "UpdateProfilePasswordParams"}
[:password :string]
[:old-password :string]]
::sm/result :nil}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id password] :as params}]
(db/with-atomic [conn pool]
(let [cfg (assoc cfg ::db/conn conn)
@ -163,12 +178,11 @@
(declare upload-photo)
(declare update-profile-photo)
(s/def ::file ::media/upload)
(s/def ::update-profile-photo
(s/keys :req [::rpc/profile-id]
:req-un [::file]))
(sv/defmethod ::update-profile-photo
{:doc/added "1.1"
::sm/params [:map {:title "UpdateProfilePhotoParams"}
[:file ::media/upload]]
::sm/result :nil}
[cfg {:keys [::rpc/profile-id file] :as params}]
;; Validate incoming mime type
(media/validate-media-type! file #{"image/jpeg" "image/png" "image/webp"})

190
backend/src/app/rpc/doc.clj
View file

@ -8,57 +8,197 @@
"API autogenerated documentation."
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.pprint :as pp]
[app.common.schema :as sm]
[app.common.schema.desc-js-like :as smdj]
[app.common.schema.desc-native :as smdn]
[app.common.schema.openapi :as oapi]
[app.common.schema.registry :as sr]
[app.config :as cf]
[app.loggers.webhooks :as-alias webhooks]
[app.rpc :as-alias rpc]
[app.util.json :as json]
[app.util.services :as sv]
[app.util.template :as tmpl]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[integrant.core :as ig]
[malli.transform :as mt]
[pretty-spec.core :as ps]
[yetti.response :as yrs]))
(defn- get-spec-str
[k]
(with-out-str
(ps/pprint (s/form k)
{:ns-aliases {"clojure.spec.alpha" "s"
"clojure.core.specs.alpha" "score"
"clojure.core" nil}})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DOC (human readable)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- prepare-context
(defn- prepare-doc-context
[methods]
(letfn [(gen-doc [[{:keys [::sv/name] :as mdata} _f]]
{:name (d/name name)
:module (-> (:ns mdata) (str/split ".") last)
(letfn [(fmt-spec [mdata]
(when-let [spec (ex/ignoring (s/spec (::sv/spec mdata)))]
(with-out-str
(ps/pprint (s/form spec)
{:ns-aliases {"clojure.spec.alpha" "s"
"clojure.core.specs.alpha" "score"
"clojure.core" nil}}))))
(fmt-schema [type mdata key]
(when-let [schema (get mdata key)]
(if (= type :js)
(smdj/describe (sm/schema schema) {::smdj/max-level 4})
(-> (smdn/describe (sm/schema schema))
(pp/pprint-str {:level 5 :width 70})))))
(get-context [mdata]
{:name (::sv/name mdata)
:module (or (some-> (::module mdata) d/name)
(-> (:ns mdata) (str/split ".") last))
:auth (:auth mdata true)
:webhook (::webhooks/event? mdata false)
:docs (::sv/docstring mdata)
:deprecated (::deprecated mdata)
:added (::added mdata)
:changes (some->> (::changes mdata) (partition-all 2) (map vec))
:spec (get-spec-str (::sv/spec mdata))})]
:spec (fmt-spec mdata)
:entrypoint (str (cf/get :public-uri) "/api/rpc/commands/" (::sv/name mdata))
:params-schema-js (fmt-schema :js mdata ::sm/params)
:result-schema-js (fmt-schema :js mdata ::sm/result)
:webhook-schema-js (fmt-schema :js mdata ::sm/webhook)
:params-schema-clj (fmt-schema :clj mdata ::sm/params)
:result-schema-clj (fmt-schema :clj mdata ::sm/result)
:webhook-schema-clj (fmt-schema :clj mdata ::sm/webhook)})]
{:version (:main cf/version)
:methods
(->> methods
(map val)
(map gen-doc)
(map first)
(map get-context)
(sort-by (juxt :module :name)))}))
(defn- handler
[methods]
(defn- doc-handler
[context]
(if (contains? cf/flags :backend-api-doc)
(let [context (prepare-context methods)]
(fn [_]
(fn [request]
(let [params (:query-params request)
pstyle (:type params "js")
context (assoc context :param-style pstyle)]
{::yrs/status 200
::yrs/body (-> (io/resource "app/templates/api-doc.tmpl")
(tmpl/render context))}))
(fn [_]
{::yrs/status 404})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OPENAPI / SWAGGER (v3.1)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def output-transformer
(mt/transformer
sm/default-transformer
(mt/key-transformer {:encode str/camel
:decode (comp keyword str/kebab)})))
(defn prepare-openapi-context
[methods]
(letfn [(gen-response-doc [tsx schema]
(let [schema (sm/schema schema)
example (sm/generate schema)
example (sm/encode schema example output-transformer)]
{:default
{:description "A default response"
:content
{"application/json"
{:schema tsx
:example example}}}}))
(gen-params-doc [tsx schema]
(let [example (sm/generate schema)
example (sm/encode schema example output-transformer)]
{:required true
:content
{"application/json"
{:schema tsx
:example example}}}))
(gen-method-doc [options mdata]
(let [pschema (::sm/params mdata)
rschema (::sm/result mdata)
sparams (-> pschema (oapi/transform options) (gen-params-doc pschema))
sresp (some-> rschema (oapi/transform options) (gen-response-doc rschema))
rpost {:description (::sv/docstring mdata)
:deprecated (::deprecated mdata false)
:requestBody sparams}
rpost (cond-> rpost
(some? sresp)
(assoc :responses sresp))]
{:name (-> mdata ::sv/name d/name)
:module (-> (:ns mdata) (str/split ".") last)
:repr {:post rpost}}))
]
(let [definitions (atom {})
options {:registry sr/default-registry
::oapi/definitions-path "#/components/schemas/"
::oapi/definitions definitions}
paths (binding [oapi/*definitions* definitions]
(->> methods
(map (comp first val))
(filter ::sm/params)
(map (partial gen-method-doc options))
(sort-by (juxt :module :name))
(map (fn [doc]
[(str/ffmt "/commands/%" (:name doc)) (:repr doc)]))
(into {})))]
{:openapi "3.0.0"
:info {:version (:main cf/version)}
:servers [{:url (str/ffmt "%/api/rpc" (cf/get :public-uri))
;; :description "penpot backend"
}]
:security
{:api_key []}
:paths paths
:components {:schemas @definitions}})))
(defn openapi-json-handler
[context]
(if (contains? cf/flags :backend-openapi-doc)
(fn [_]
{::yrs/status 200
::yrs/headers {"content-type" "application/json; charset=utf-8"}
::yrs/body (json/encode context)})
(fn [_]
{::yrs/status 404})))
(defn openapi-handler
[]
(if (contains? cf/flags :backend-openapi-doc)
(fn [_]
(let [swagger-js (slurp (io/resource "app/assets/swagger-ui-4.18.3.js"))
swagger-cs (slurp (io/resource "app/assets/swagger-ui-4.18.3.css"))
context {:public-uri (cf/get :public-uri)
:swagger-js swagger-js
:swagger-css swagger-cs}]
{::yrs/status 200
::yrs/headers {"content-type" "text/html"}
::yrs/body (-> (io/resource "app/templates/openapi.tmpl")
(tmpl/render context))}))
(fn [_]
{::yrs/status 404})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MODULE INIT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::routes vector?)
(defmethod ig/pre-init-spec ::routes [_]
@ -66,6 +206,18 @@
(defmethod ig/init-key ::routes
[_ {:keys [methods] :as cfg}]
["/_doc" {:handler (handler methods)
:allowed-methods #{:get}}])
[(let [context (prepare-doc-context methods)]
[["/_doc"
{:handler (doc-handler context)
:allowed-methods #{:get}}]
["/doc"
{:handler (doc-handler context)
:allowed-methods #{:get}}]])
(let [context (prepare-openapi-context methods)]
[["/openapi"
{:handler (openapi-handler)
:allowed-methods #{:get}}]
["/openapi.json"
{:handler (openapi-json-handler context)
:allowed-methods #{:get}}]])])

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

@ -8,9 +8,20 @@
"A permission checking helper factories."
(:require
[app.common.exceptions :as ex]
[app.common.schema :as sm]
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
(sm/def! ::permissions
[:map {:title "Permissions"}
[:type {:gen/elements [:membership :share-link]} :keyword]
[:is-owner :boolean]
[:is-admin :boolean]
[:can-edit :boolean]
[:can-read :boolean]
[:is-logged :boolean]])
(s/def ::role #{:admin :owner :editor :viewer})
(defn assign-role-flags

9
backend/src/app/rpc/rlimit.clj
View file

@ -212,10 +212,11 @@
(into [] (map #(assoc % ::service sname)) limits)))
(defn- get-uid
[{:keys [::http/request] :as params}]
(or (::rpc/profile-id params)
(some-> request parse-client-ip)
uuid/zero))
[{:keys [::rpc/profile-id] :as params}]
(let [request (-> params meta ::http/request)]
(or profile-id
(some-> request parse-client-ip)
uuid/zero)))
(defn process-request!
[{:keys [::rpc/rlimit ::rds/redis ::skey ::sname] :as cfg} params]

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

@ -155,7 +155,7 @@
(defn write-char
[n w o]
(write-tag! w n 1)
(write-int! w o))
(write-int! w (int o)))
(defn read-char
[rdr]
@ -259,8 +259,8 @@
:rfn (comp vec read-object!)}
{:name "clj/list"
:class clojure.lang.IPersistentList
:wfn write-list-like
;; :class clojure.lang.IPersistentList
;; :wfn write-list-like
:rfn #(apply list (read-object! %))}
{:name "clj/seq"

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

@ -8,8 +8,11 @@
(:require
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.schema :as sm]
[app.common.schema.openapi :as-alias oapi]
[app.common.time :as common-time]
[clojure.spec.alpha :as s]
[clojure.test.check.generators :as tgen]
[cuerdas.core :as str]
[fipp.ednize :as fez])
(:import
@ -358,3 +361,27 @@
[]
(let [p1 (System/nanoTime)]
#(duration {:nanos (- (System/nanoTime) p1)})))
(sm/def! ::instant
{:type ::instant
:pred instant?
:type-properties
{:error/message "should be an instant"
:title "instant"
::sm/decode instant
:gen/gen (tgen/fmap (fn [i] (in-past i)) tgen/pos-int)
::oapi/type "string"
::oapi/format "iso"
}})
(sm/def! ::duration
{:type :durations
:pred duration?
:type-properties
{:error/message "should be a duration"
:gen/gen (tgen/fmap duration tgen/pos-int)
:title "duration"
::sm/decode duration
::oapi/type "string"
::oapi/format "duration"
}})

7
backend/test/backend_tests/rpc_audit_test.clj
View file

@ -37,7 +37,6 @@
proj-id (:default-project-id prof)
params {::th/type :push-audit-events
:app.http/request http-request
::rpc/profile-id (:id prof)
:events [{:name "navigate"
:props {:project-id proj-id
@ -47,6 +46,9 @@
:profile-id (:id prof)
:timestamp (dt/now)
:type "action"}]}
params (with-meta params
{:app.http/request http-request})
out (th/command! params)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
@ -67,7 +69,6 @@
proj-id (:default-project-id prof)
params {::th/type :push-audit-events
:app.http/request http-request
::rpc/profile-id (:id prof)
:events [{:name "navigate"
:props {:project-id proj-id
@ -77,6 +78,8 @@
:profile-id uuid/zero
:timestamp (dt/now)
:type "action"}]}
params (with-meta params
{:app.http/request http-request})
out (th/command! params)]
;; (th/print-result! out)
(t/is (nil? (:error out)))

5
backend/test/backend_tests/rpc_file_test.clj
View file

@ -132,6 +132,7 @@
:components-v2 true
:changes changes}
out (th/command! params)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(:result out)))]
@ -165,7 +166,6 @@
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(t/is (= 2 (count rows))))
;; Check the number of fragments
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(t/is (= 2 (count rows))))
@ -646,10 +646,11 @@
:components-v2 true}
out (th/command! data)]
;; (th/print-result! out)
(t/is (not (th/success? out)))
(let [{:keys [type code]} (-> out :error ex-data)]
(t/is (= :validation type))
(t/is (= :spec-validation code))))
(t/is (= :params-validation code))))
)

91
backend/test/backend_tests/util_objects_map_test.clj
View file

@ -6,19 +6,16 @@
(ns backend-tests.util-objects-map-test
(:require
[backend-tests.helpers :as th]
[app.common.spec :as us]
[app.common.schema.generators :as sg]
[app.common.transit :as transit]
[app.common.types.shape :as cts]
[app.common.uuid :as uuid]
[app.util.fressian :as fres]
[app.util.objects-map :as omap]
[backend-tests.helpers :as th]
[clojure.pprint :refer [pprint]]
[clojure.spec.alpha :as s]
[clojure.test :as t]
[clojure.test.check.clojure-test :refer [defspec]]
[clojure.test.check.generators :as gen]
[clojure.test.check.properties :as props]))
[clojure.test.check.generators :as cg]))
(t/deftest basic-operations
(t/testing "assoc"
@ -89,55 +86,55 @@
(t/is (= (hash obj1) (hash obj2)))))
)
(defspec internal-encode-decode 25
(props/for-all
[data (->> (gen/map gen/uuid (s/gen ::cts/shape))
(gen/not-empty))]
(let [obj1 (omap/wrap data)
obj2 (omap/create (deref obj1))
obj3 (assoc obj2 uuid/zero 1)
obj4 (omap/create (deref obj3))]
;; (app.common.pprint/pprint data)
(t/deftest internal-encode-decode
(sg/check!
(sg/for [data (->> (cg/map cg/uuid (sg/generator ::cts/shape))
(cg/not-empty))]
(let [obj1 (omap/wrap data)
obj2 (omap/create (deref obj1))
obj3 (assoc obj2 uuid/zero 1)
obj4 (omap/create (deref obj3))]
;; (app.common.pprint/pprint data)
(t/is (= (hash obj1) (hash obj2)))
(t/is (not= (hash obj2) (hash obj3)))
(t/is (bytes? (deref obj3)))
(t/is (pos? (alength (deref obj3))))
(t/is (= (hash obj3) (hash obj4))))))
(t/is (= (hash obj3) (hash obj4)))))))
(defspec fressian-encode-decode 25
(props/for-all
[data (->> (gen/map gen/uuid (s/gen ::cts/shape))
(gen/not-empty)
(gen/fmap omap/wrap)
(gen/fmap (fn [o] {:objects o})))]
(let [res (-> data fres/encode fres/decode)]
(t/is (contains? res :objects))
(t/is (omap/objects-map? (:objects res)))
(t/is (= (count (:objects data))
(count (:objects res))))
(t/is (= (hash (:objects data))
(hash (:objects res)))))))
(t/deftest fressian-encode-decode
(sg/check!
(sg/for [data (->> (cg/map cg/uuid (sg/generator ::cts/shape))
(cg/not-empty)
(cg/fmap omap/wrap)
(cg/fmap (fn [o] {:objects o})))]
(defspec transit-encode-decode 25
(props/for-all
[data (->> (gen/map gen/uuid (s/gen ::cts/shape))
(gen/not-empty)
(gen/fmap omap/wrap)
(gen/fmap (fn [o] {:objects o})))]
(let [res (-> data transit/encode transit/decode)]
;; (app.common.pprint/pprint data)
;; (app.common.pprint/pprint res)
(doseq [[k v] (:objects res)]
(t/is (= v (get-in data [:objects k]))))
(let [res (-> data fres/encode fres/decode)]
(t/is (contains? res :objects))
(t/is (omap/objects-map? (:objects res)))
(t/is (= (count (:objects data))
(count (:objects res))))
(t/is (= (hash (:objects data))
(hash (:objects res))))))))
(t/is (contains? res :objects))
(t/is (contains? data :objects))
(t/deftest transit-encode-decode
(sg/check!
(sg/for [data (->> (cg/map cg/uuid (sg/generator ::cts/shape))
(cg/not-empty)
(cg/fmap omap/wrap)
(cg/fmap (fn [o] {:objects o})))]
(let [res (-> data transit/encode transit/decode)]
;; (app.common.pprint/pprint data)
;; (app.common.pprint/pprint res)
(doseq [[k v] (:objects res)]
(t/is (= v (get-in data [:objects k]))))
(t/is (omap/objects-map? (:objects data)))
(t/is (not (omap/objects-map? (:objects res))))
(t/is (= (count (:objects data))
(count (:objects res)))))))
(t/is (contains? res :objects))
(t/is (contains? data :objects))
(t/is (omap/objects-map? (:objects data)))
(t/is (not (omap/objects-map? (:objects res))))
(t/is (= (count (:objects data))
(count (:objects res))))))))

2
common/deps.edn
View file

@ -18,6 +18,8 @@
selmer/selmer {:mvn/version "1.12.55"}
criterium/criterium {:mvn/version "0.4.6"}
metosin/malli {:mvn/version "0.11.0"}
expound/expound {:mvn/version "0.9.0"}
com.cognitect/transit-clj {:mvn/version "1.0.329"}
com.cognitect/transit-cljs {:mvn/version "0.8.280"}

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

@ -18,7 +18,6 @@
:clj [clojure.edn :as r])
#?(:cljs [cljs.core :as c]
:clj [clojure.core :as c])
[app.common.exceptions :as ex]
[app.common.math :as mth]
[clojure.set :as set]
[cuerdas.core :as str]
@ -539,7 +538,10 @@
(defn parse-uuid
[v]
(ex/ignoring (c/parse-uuid v)))
(try
(c/parse-uuid v)
(catch #?(:clj Throwable :cljs :default) _
nil)))
(defn num-string? [v]
;; https://stackoverflow.com/questions/175739/built-in-way-in-javascript-to-check-if-a-string-is-a-valid-number
@ -748,6 +750,51 @@
[key (delay (generator-fn key))]))
keys))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; String Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def stylize-re1 (re-pattern "(?u)(\\p{Lu}+[\\p{Ll}\\u0027\\p{Ps}\\p{Pe}]*)"))
(def stylize-re2 (re-pattern "(?u)[^\\p{L}\\p{N}\\u0027\\p{Ps}\\p{Pe}\\?!]+"))
(defn- stylize-split
[s]
(some-> s
(name)
(str/replace stylize-re1 "-$1")
(str/split stylize-re2)
(seq)))
(defn- stylize-join
([coll every-fn join-with]
(when (seq coll)
(str/join join-with (map every-fn coll))))
([[fst & rst] first-fn rest-fn join-with]
(when (string? fst)
(str/join join-with (cons (first-fn fst) (map rest-fn rst))))))
(defn stylize
([s every-fn join-with]
(stylize s every-fn every-fn join-with))
([s first-fn rest-fn join-with]
(let [remove-empty #(seq (remove empty? %))]
(some-> (stylize-split s)
(remove-empty)
(stylize-join first-fn rest-fn join-with)))))
(defn camel
"Output will be: lowerUpperUpperNoSpaces
accepts strings and keywords"
[s]
(stylize s str/lower str/capital ""))
(defn kebab
"Output will be: lower-cased-and-separated-with-dashes
accepts strings and keywords"
[s]
(stylize s str/lower "-"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Util protocols
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

29
common/src/app/common/data/macros.cljc
View file

@ -127,3 +127,32 @@
(if (:ns &env)
(list (symbol ".") (with-meta obj {:tag 'js}) (symbol (str "-" (c/name prop))))
`(c/get ~obj ~prop)))
(def ^:dynamic *assert-context* nil)
(defmacro assert!
([expr]
`(assert! nil ~expr))
([hint expr]
(let [hint (cond
(vector? hint)
`(str/ffmt ~@hint)
(some? hint)
hint
:else
(str "expr assert: " (pr-str expr)))]
(when *assert*
`(binding [*assert-context* true]
(when-not ~expr
(let [hint# ~hint
params# {:type :assertion
:code :expr-validation
:hint hint#}]
(throw (ex-info hint# params#)))))))))
(defmacro verify!
[& params]
(binding [*assert* true]
`(assert! ~@params)))

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

@ -10,6 +10,7 @@
(:require
#?(:clj [clojure.stacktrace :as strace])
[app.common.pprint :as pp]
[app.common.schema :as sm]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[expound.alpha :as expound])
@ -31,6 +32,7 @@
[& params]
`(throw (error ~@params)))
;; FIXME deprecate
(defn try*
[f on-error]
(try (f) (catch #?(:clj Throwable :cljs :default) e (on-error e))))
@ -40,11 +42,15 @@
(defmacro ignoring
[& exprs]
`(try* (^:once fn* [] ~@exprs) (constantly nil)))
(if (:ns &env)
`(try ~@exprs (catch :default e# nil))
`(try ~@exprs (catch Throwable e# nil))))
(defmacro try!
[& exprs]
`(try* (^:once fn* [] ~@exprs) identity))
(if (:ns &env)
`(try ~@exprs (catch :default e# e#))
`(try ~@exprs (catch Throwable e# e#))))
(defn ex-info?
[v]
@ -65,7 +71,7 @@
(defn explain
([data] (explain data nil))
([data {:keys [max-problems] :or {max-problems 10} :as opts}]
([data {:keys [level length] :or {level 8 length 10} :as opts}]
(cond
;; ;; NOTE: a special case for spec validation errors on integrant
(and (= (:reason data) :integrant.core/build-failed-spec)
@ -77,7 +83,11 @@
(contains? data ::s/spec))
(binding [s/*explain-out* expound/printer]
(with-out-str
(s/explain-out (update data ::s/problems #(take max-problems %))))))))
(s/explain-out (update data ::s/problems #(take length %)))))
(contains? data ::sm/explain)
(-> (sm/humanize-data (::sm/explain data))
(pp/pprint-str {:level level :length length})))))
#?(:clj
(defn format-throwable
@ -89,7 +99,7 @@
explain? true
chain? true
data-length 10
data-level 3}}]
data-level 8}}]
(letfn [(print-trace-element [^StackTraceElement e]
(let [class (.getClassName e)
@ -157,9 +167,9 @@
(print-trace cause)
(when-let [data (ex-data cause)]
(when data?
(print-data (dissoc data ::s/problems ::s/spec ::s/value)))
(print-data (dissoc data ::s/problems ::s/spec ::s/value ::sm/explain)))
(when explain?
(if-let [explain (explain data)]
(if-let [explain (explain data {:length data-length :level data-level})]
(print-explain explain)))))
(print-all [^Throwable cause]

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

@ -14,8 +14,8 @@
[app.common.geom.point :as gpt]
[app.common.geom.shapes :as gsh]
[app.common.pages.changes :as ch]
[app.common.pages.changes-spec :as pcs]
[app.common.spec :as us]
[app.common.pprint :as pp]
[app.common.schema :as sm]
[app.common.types.components-list :as ctkl]
[app.common.types.container :as ctn]
[app.common.types.file :as ctf]
@ -23,7 +23,6 @@
[app.common.types.pages-list :as ctpl]
[app.common.types.shape :as cts]
[app.common.uuid :as uuid]
[clojure.spec.alpha :as spec]
[cuerdas.core :as str]))
(def root-frame uuid/zero)
@ -53,20 +52,13 @@
:frame-id (:current-frame-id file)))]
(when fail-on-spec?
(us/verify ::pcs/change change))
(dm/verify! (ch/change? change)))
(let [valid? (ch/change? change)]
(when-not valid?
(pp/pprint change {:level 100})
(sm/pretty-explain ::ch/change change))
(let [valid? (us/valid? ::pcs/change change)
explain (spec/explain-str ::pcs/change change)]
#?(:cljs
(when-not valid?
(do
(.warn js/console "Invalid shape" (clj->js change))
(.warn js/console explain)))
:clj
(when-not valid?
(do
(prn "Invalid shape" change)
(prn explain))))
(cond-> file
valid?
@ -79,8 +71,8 @@
(defn- lookup-objects
([file]
(if (some? (:current-component-id file))
(get-in file [:data :components (:current-component-id file) :objects])
(get-in file [:data :pages-index (:current-page-id file) :objects]))))
(dm/get-in file [:data :components (:current-component-id file) :objects])
(dm/get-in file [:data :pages-index (:current-page-id file) :objects]))))
(defn lookup-shape [file shape-id]
(-> (lookup-objects file)
@ -146,7 +138,7 @@
(defn- generate-name
[type data]
(if (= type :svg-raw)
(let [tag (get-in data [:content :tag])]
(let [tag (dm/get-in data [:content :tag])]
(str "svg-" (cond (string? tag) tag
(keyword? tag) (d/name tag)
(nil? tag) "node"
@ -164,7 +156,7 @@
[name file]
(let [container-id (or (:current-component-id file)
(:current-page-id file))
unames (get-in file [:unames container-id])]
unames (dm/get-in file [:unames container-id])]
(d/unique-name name (or unames #{}))))
(defn clear-names [file]
@ -198,8 +190,7 @@
(defn add-page
[file data]
(assert (nil? (:current-component-id file)))
(dm/assert! (nil? (:current-component-id file)))
(let [page-id (or (:id data) (uuid/next))
page (-> (ctp/make-empty-page page-id "Page 1")
(d/deep-merge data))]
@ -221,7 +212,7 @@
(assoc :last-id nil))))
(defn close-page [file]
(assert (nil? (:current-component-id file)))
(dm/assert! (nil? (:current-component-id file)))
(-> file
(dissoc :current-page-id)
(dissoc :parent-stack)
@ -411,7 +402,7 @@
;; First :content is the the shape attribute, the other content is the
;; XML children
(reduce create-child file (get-in data [:content :content]))))
(reduce create-child file (dm/get-in data [:content :content]))))
(defn close-svg-raw [file]
(-> file
@ -763,7 +754,7 @@
(defn get-current-page
[file]
(let [page-id (:current-page-id file)]
(-> file (get-in [:data :pages-index page-id]))))
(dm/get-in file [:data :pages-index page-id])))
(defn add-guide
[file guide]
@ -772,7 +763,7 @@
(nil? (:id guide))
(assoc :id (uuid/next)))
page-id (:current-page-id file)
old-guides (or (get-in file [:data :pages-index page-id :options :guides]) {})
old-guides (or (dm/get-in file [:data :pages-index page-id :options :guides]) {})
new-guides (assoc old-guides (:id guide) guide)]
(-> file
(commit-change
@ -786,7 +777,7 @@
[file id]
(let [page-id (:current-page-id file)
old-guides (or (get-in file [:data :pages-index page-id :options :guides]) {})
old-guides (or (dm/get-in file [:data :pages-index page-id :options :guides]) {})
new-guides (dissoc old-guides id)]
(-> file
(commit-change
@ -799,7 +790,7 @@
[file guide]
(let [page-id (:current-page-id file)
old-guides (or (get-in file [:data :pages-index page-id :options :guides]) {})
old-guides (or (dm/get-in file [:data :pages-index page-id :options :guides]) {})
new-guides (assoc old-guides (:id guide) guide)]
(-> file
(commit-change

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

@ -7,12 +7,12 @@
(ns app.common.geom.align
(:require
[app.common.geom.shapes :as gsh]
[app.common.pages.helpers :refer [get-children]]
[clojure.spec.alpha :as s]))
[app.common.pages.helpers :refer [get-children]]))
;; --- Alignment
(s/def ::align-axis #{:hleft :hcenter :hright :vtop :vcenter :vbottom})
(def valid-align-axis
#{:hleft :hcenter :hright :vtop :vcenter :vbottom})
(declare calc-align-pos)
@ -65,7 +65,8 @@
;; --- Distribute
(s/def ::dist-axis #{:horizontal :vertical})
(def valid-dist-axis
#{:horizontal :vertical})
(defn distribute-space
"Distribute equally the space between shapes in the given axis. If

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

@ -12,9 +12,11 @@
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.math :as mth]
[app.common.schema :as sm]
[app.common.schema.generators :as sg]
[app.common.schema.openapi :as-alias oapi]
[app.common.spec :as us]
[clojure.spec.alpha :as s]
[clojure.test.check.generators :as tgen]))
[clojure.spec.alpha :as s]))
(def precision 6)
@ -47,6 +49,58 @@
([a b c d e f]
(Matrix. a b c d e f)))
(def number-regex #"[+-]?\d*(\.\d+)?(e[+-]?\d+)?")
(defn str->matrix
[matrix-str]
(let [params (->> (re-seq number-regex matrix-str)
(filter #(-> % first seq))
(map (comp d/parse-double first)))]
(apply matrix params)))
(sm/def! ::matrix-map
[:map {:title "MatrixMap"}
[:a ::sm/safe-double]
[:b ::sm/safe-double]
[:c ::sm/safe-double]
[:d ::sm/safe-double]
[:e ::sm/safe-double]
[:f ::sm/safe-double]])
(sm/def! ::matrix
(letfn [(decode [o]
(if (map? o)
(map->Matrix o)
(if (string? o)
(str->matrix o)
o)))
(encode [o]
(dm/str (dm/get-prop o :a) ","
(dm/get-prop o :b) ","
(dm/get-prop o :c) ","
(dm/get-prop o :d) ","
(dm/get-prop o :e) ","
(dm/get-prop o :f) ","))]
{:type ::matrix
:pred matrix?
:type-properties
{:title "matrix"
:description "Matrix instance"
:error/message "expected a valid point"
:gen/gen (->> (sg/tuple (sg/small-double)
(sg/small-double)
(sg/small-double)
(sg/small-double)
(sg/small-double)
(sg/small-double) )
(sg/fmap #(apply ->Matrix %)))
::oapi/type "string"
::oapi/format "matrix"
::oapi/decode decode
::oapi/encode encode}}))
;; FIXME: deprecated
(s/def ::a ::us/safe-float)
(s/def ::b ::us/safe-float)
(s/def ::c ::us/safe-float)
@ -58,18 +112,8 @@
(s/keys :req-un [::a ::b ::c ::d ::e ::f]))
(s/def ::matrix
(s/with-gen
(s/and ::matrix-attrs matrix?)
#(tgen/fmap map->Matrix (s/gen ::matrix-attrs))))
(s/and ::matrix-attrs matrix?))
(def number-regex #"[+-]?\d*(\.\d+)?(e[+-]?\d+)?")
(defn str->matrix
[matrix-str]
(let [params (->> (re-seq number-regex matrix-str)
(filter #(-> % first seq))
(map (comp d/parse-double first)))]
(apply matrix params)))
(defn close?
[^Matrix m1 ^Matrix m2]

41
common/src/app/common/geom/point.cljc
View file

@ -15,9 +15,12 @@
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.math :as mth]
[app.common.schema :as sm]
[app.common.schema.generators :as sg]
[app.common.schema.openapi :as-alias oapi]
[app.common.spec :as us]
[clojure.spec.alpha :as s]
[clojure.test.check.generators :as tgen]))
[cuerdas.core :as str]))
;; --- Point Impl
@ -32,6 +35,13 @@
[v]
(instance? Point v))
(sm/def! ::point-map
[:map {:title "PointMap"}
[:x ::sm/safe-number]
[:y ::sm/safe-number]])
;; FIXME: deprecated
(s/def ::x ::us/safe-number)
(s/def ::y ::us/safe-number)
@ -39,8 +49,33 @@
(s/keys :req-un [::x ::y]))
(s/def ::point
(s/with-gen (s/and ::point-attrs point?)
#(tgen/fmap map->Point (s/gen ::point-attrs))))
(s/and ::point-attrs point?))
(sm/def! ::point
(letfn [(decode [p]
(if (map? p)
(map->Point p)
(if (string? p)
(let [[x y] (->> (str/split p #",") (mapv parse-double))]
(Point. x y))
p)))
(encode [p]
(dm/str (dm/get-prop p :x) ","
(dm/get-prop p :y)))]
{:type ::point
:pred point?
:type-properties
{:title "point"
:description "Point"
:error/message "expected a valid point"
:gen/gen (->> (sg/tuple (sg/small-int) (sg/small-int))
(sg/fmap #(apply ->Point %)))
::oapi/type "string"
::oapi/format "point"
::oapi/decode decode
::oapi/encode encode}}))
(defn point-like?
[{:keys [x y] :as v}]

6
common/src/app/common/geom/shapes/modifiers.cljc
View file

@ -17,7 +17,6 @@
[app.common.geom.shapes.points :as gpo]
[app.common.geom.shapes.transforms :as gtr]
[app.common.pages.helpers :as cph]
[app.common.spec :as us]
[app.common.types.modifiers :as ctm]
[app.common.types.shape.layout :as ctl]
[app.common.uuid :as uuid]))
@ -43,10 +42,7 @@
(defn resolve-tree-sequence
"Given the ids that have changed search for layout roots to recalculate"
[ids objects]
(us/assert!
:expr (or (nil? ids) (set? ids))
:hint (dm/str "tree sequence from not set: " ids))
(dm/assert! (or (nil? ids) (set? ids)))
(let [get-tree-root
(fn ;; Finds the tree root for the current id

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

@ -14,18 +14,223 @@
[app.common.math :as mth]
[app.common.pages.common :refer [component-sync-attrs]]
[app.common.pages.helpers :as cph]
[app.common.schema :as sm]
[app.common.schema.desc-native :as smd]
[app.common.spec :as us]
[app.common.pages.changes-spec :as pcs]
[app.common.types.colors-list :as ctcl]
[app.common.types.component :as ctk]
[app.common.types.components-list :as ctkl]
[app.common.types.container :as ctn]
[app.common.types.colors-list :as ctcl]
[app.common.types.file :as ctf]
[app.common.types.page :as ctp]
[app.common.types.pages-list :as ctpl]
[app.common.types.shape :as cts]
[app.common.types.shape-tree :as ctst]
[app.common.types.typographies-list :as ctyl]))
[app.common.types.typographies-list :as ctyl]
[app.common.types.typography :as ctt]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SCHEMAS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(sm/def! ::operation
[:multi {:dispatch :type :title "Operation" ::smd/simplified true}
[:set
[:map {:title "SetOperation"}
[:type [:= :set]]
[:attr :keyword]
[:val :any]
[:ignore-touched {:optional true} :boolean]
[:ignore-geometry {:optional true} :boolean]]]
[:set-touched
[:map {:title "SetTouchedOperation"}
[:type [:= :set-touched]]
[:touched [:maybe [:set :keyword]]]]]
[:set-remote-synced
[:map {:title "SetRemoteSyncedOperation"}
[:type [:= :set-remote-synced]]
[:remote-synced? [:maybe :boolean]]]]])
(sm/def! ::change
[:schema
[:multi {:dispatch :type :title "Change" ::smd/simplified true}
[:set-option
[:map {:title "SetOptionChange"}
[:type [:= :set-option]]
[:page-id ::sm/uuid]
[:option [:union
[:keyword]
[:vector {:gen/max 10} :keyword]]]
[:value :any]]]
[:add-obj
[:map {:title "AddObjChange"}
[:type [:= :add-obj]]
[:id ::sm/uuid]
[:obj [:map-of {:gen/max 10} :keyword :any]]
[:page-id {:optional true} ::sm/uuid]
[:component-id {:optional true} ::sm/uuid]
[:frame-id {:optional true} ::sm/uuid]
[:parent-id {:optional true} ::sm/uuid]
[:index {:optional true} [:maybe :int]]
[:ignore-touched {:optional true} :boolean]
]]
[:mod-obj
[:map {:title "ModObjChange"}
[:type [:= :mod-obj]]
[:id ::sm/uuid]
[:page-id {:optional true} ::sm/uuid]
[:component-id {:optional true} ::sm/uuid]
[:operations [:vector {:gen/max 5} ::operation]]]]
[:del-obj
[:map {:title "DelObjChange"}
[:type [:= :del-obj]]
[:id ::sm/uuid]
[:page-id {:optional true} ::sm/uuid]
[:component-id {:optional true} ::sm/uuid]
[:ignore-touched {:optional true} :boolean]]]
[:mov-objects
[:map {:title "MovObjectsChange"}
[:type [:= :mov-objects]]
[:page-id {:optional true} ::sm/uuid]
[:component-id {:optional true} ::sm/uuid]
[:ignore-touched {:optional true} :boolean]
[:parent-id ::sm/uuid]
[:shapes :any]
[:index {:optional true} :int]
[:after-shape {:optional true} :any]]]
[:add-page
[:map {:title "AddPageChange"}
[:type [:= :add-page]]
[:id {:optional true} ::sm/uuid]
[:name {:optional true} :string]
[:page {:optional true} :any]]]
[:mod-page
[:map {:title "ModPageChange"}
[:type [:= :mod-page]]
[:id ::sm/uuid]
[:name :string]]]
[:del-page
[:map {:title "DelPageChange"}
[:type [:= :del-page]]
[:id ::sm/uuid]]]
[:mov-page
[:map {:title "MovPageChange"}
[:type [:= :mov-page]]
[:id ::sm/uuid]
[:index :int]]]
[:reg-objects
[:map {:title "RegObjectsChange"}
[:type [:= :reg-objects]]
[:page-id {:optional true} ::sm/uuid]
[:component-id {:optional true} ::sm/uuid]
[:shapes [:vector {:gen/max 5} ::sm/uuid]]]]
[:add-color
[:map {:title "AddColorChange"}
[:type [:= :add-color]]
[:color :any]]]
[:mod-color
[:map {:title "ModColorChange"}
[:type [:= :mod-color]]
[:color :any]]]
[:del-color
[:map {:title "DelColorChange"}
[:type [:= :del-color]]
[:id ::sm/uuid]]]
[:add-recent-color
[:map {:title "AddRecentColorChange"}
[:type [:= :add-recent-color]]
[:color :any]]]
[:add-media
[:map {:title "AddMediaChange"}
[:type [:= :add-media]]
[:object ::ctf/media-object]]]
[:mod-media
[:map {:title "ModMediaChange"}
[:type [:= :mod-media]]
[:object ::ctf/media-object]]]
[:del-media
[:map {:title "DelMediaChange"}
[:type [:= :del-media]]
[:id ::sm/uuid]]]
[:add-component
[:map {:title "AddComponentChange"}
[:type [:= :add-component]]
[:id ::sm/uuid]
[:name :string]
[:shapes {:optional true} [:vector {:gen/max 3} :any]]
[:path {:optional true} :string]]]
[:mod-component
[:map {:title "ModCompoenentChange"}
[:type [:= :mod-component]]
[:id ::sm/uuid]
[:shapes {:optional true} [:vector {:gen/max 3} :any]]
[:name {:optional true} :string]]]
[:del-component
[:map {:title "DelComponentChange"}
[:type [:= :del-component]]
[:id ::sm/uuid]
[:skip-undelete? {:optional true} :boolean]]]
[:restore-component
[:map {:title "RestoreComponentChange"}
[:type [:= :restore-component]]
[:id ::sm/uuid]]]
[:purge-component
[:map {:title "PurgeComponentChange"}
[:type [:= :purge-component]]
[:id ::sm/uuid]]]
[:add-typography
[:map {:title "AddTypogrphyChange"}
[:type [:= :add-typography]]
[:typography ::ctt/typography]]]
[:mod-typography
[:map {:title "ModTypogrphyChange"}
[:type [:= :mod-typography]]
[:typography ::ctt/typography]]]
[:del-typography
[:map {:title "DelTypogrphyChange"}
[:type [:= :del-typography]]
[:id ::sm/uuid]]]
]])
(def change?
(sm/pred-fn ::change))
(def changes?
(sm/pred-fn [:sequential ::change]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Specific helpers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- without-obj
"Clear collection from specified obj and without nil values."
[coll o]
(into [] (filter #(not= % o)) coll))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Page Transformation Changes
@ -37,8 +242,9 @@
[data objects items]
(letfn [(validate-shape! [[page-id {:keys [id] :as shape}]]
(when-not (= shape (dm/get-in data [:pages-index page-id :objects id]))
;; If object has change verify is correct
(us/verify ::cts/shape shape)))]
;; If object has changed verify is correct
(dm/verify! (cts/shape? shape))))]
(let [lookup (d/getf objects)]
(->> (into #{} (map :page-id) items)
(mapcat (fn [page-id]
@ -64,7 +270,7 @@
;; When verify? false we spec the schema validation. Currently used to make just
;; 1 validation even if the changes are applied twice
(when verify?
(us/assert ::pcs/changes items))
(dm/verify! (changes? items)))
(let [result (reduce #(or (process-change %1 %2) %1) data items)]
;; Validate result shapes (only on the backend)
@ -110,7 +316,7 @@
(let [result (reduce (partial process-operation on-touched) obj operations)]
(assoc objects id result))
objects))
modify-components (fn [data]
(reduce ctkl/set-component-modified
data @modified-component-ids))]
@ -127,6 +333,7 @@
(d/update-in-when data [:pages-index page-id] ctst/delete-shape id ignore-touched)
(d/update-in-when data [:components component-id] ctst/delete-shape id ignore-touched)))
;; FIXME: remove, seems like this method is already unused
;; reg-objects operation "regenerates" the geometry and selrect of the parent groups
(defmethod process-change :reg-objects
[data {:keys [page-id component-id shapes]}]
@ -412,9 +619,8 @@
(and in-copy? group (not ignore) (not equal?)
(not root-name?)
(not (and ignore-geometry is-geometry?)))
(->
(update :touched cph/set-touched-group group)
(dissoc :remote-synced?))
(-> (update :touched cph/set-touched-group group)
(dissoc :remote-synced?))
(nil? val)
(dissoc attr)
@ -444,7 +650,6 @@
:code :operation-not-implemented
:context {:type (:type op)}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Component changes detection
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

2
common/src/app/common/pages/changes_builder.cljc
View file

@ -613,7 +613,7 @@
:main-instance-id main-instance-id
:main-instance-page main-instance-page}
(some? new-shapes) ;; this will be null in components-v2
(assoc :shapes new-shapes)))
(assoc :shapes (vec new-shapes))))
(into (map mk-change) updated-shapes))))
(update :undo-changes
(fn [undo-changes]

187
common/src/app/common/pages/changes_spec.cljc
View file

@ -1,187 +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) KALEIDOS INC
(ns app.common.pages.changes-spec
(:require
[app.common.spec :as us]
[app.common.types.color :as ctc]
[app.common.types.file.media-object :as ctfm]
[app.common.types.page :as ctp]
[app.common.types.shape :as cts]
[app.common.types.typography :as ctt]
[app.common.uuid :as uuid]
[clojure.spec.alpha :as s]))
(s/def ::index integer?)
(s/def ::id uuid?)
(s/def ::parent-id uuid?)
(s/def ::frame-id uuid?)
(s/def ::page-id uuid?)
(s/def ::component-id uuid?)
(s/def ::name string?)
(s/def ::path (s/nilable string?))
(s/def ::annotation (s/nilable string?))
(defmulti operation-spec :type)
(s/def :internal.operations.set/attr keyword?)
(s/def :internal.operations.set/val any?)
(s/def :internal.operations.set/touched
(s/nilable (s/every keyword? :kind set?)))
(s/def :internal.operations.set/remote-synced?
(s/nilable boolean?))
(defmethod operation-spec :set [_]
(s/keys :req-un [:internal.operations.set/attr
:internal.operations.set/val]))
(defmethod operation-spec :set-touched [_]
(s/keys :req-un [:internal.operations.set/touched]))
(defmethod operation-spec :set-remote-synced [_]
(s/keys :req-un [:internal.operations.set/remote-synced?]))
(defmulti change-spec :type)
(s/def :internal.changes.set-option/option any?)
(s/def :internal.changes.set-option/value any?)
(defmethod change-spec :set-option [_]
(s/keys :req-un [:internal.changes.set-option/option
:internal.changes.set-option/value]))
(s/def :internal.changes.add-obj/obj ::cts/shape)
(defn- valid-container-id-frame?
[o]
(or (and (contains? o :page-id)
(not (contains? o :component-id))
(some? (:frame-id o)))
(and (contains? o :component-id)
(not (contains? o :page-id))
(not= (:frame-id o) uuid/zero))))
(defn- valid-container-id?
[o]
(or (and (contains? o :page-id)
(not (contains? o :component-id)))
(and (contains? o :component-id)
(not (contains? o :page-id)))))
(defmethod change-spec :add-obj [_]
(s/and (s/keys :req-un [::id :internal.changes.add-obj/obj]
:opt-un [::page-id ::component-id ::parent-id ::frame-id])
valid-container-id-frame?))
(s/def ::operation (s/multi-spec operation-spec :type))
(s/def ::operations (s/coll-of ::operation))
(defmethod change-spec :mod-obj [_]
(s/and (s/keys :req-un [::id ::operations]
:opt-un [::page-id ::component-id])
valid-container-id?))
(defmethod change-spec :del-obj [_]
(s/and (s/keys :req-un [::id]
:opt-un [::page-id ::component-id])
valid-container-id?))
(defmethod change-spec :reg-objects [_]
(s/and (s/keys :req-un [::cts/shapes]
:opt-un [::page-id ::component-id])
valid-container-id?))
(defmethod change-spec :mov-objects [_]
(s/and (s/keys :req-un [::parent-id ::cts/shapes]
:opt-un [::page-id ::component-id ::index])
valid-container-id?))
(defmethod change-spec :add-page [_]
(s/or :empty (s/keys :req-un [::id ::name])
:complete (s/keys :req-un [::ctp/page])))
(defmethod change-spec :mod-page [_]
(s/keys :req-un [::id ::name]))
(defmethod change-spec :del-page [_]
(s/keys :req-un [::id]))
(defmethod change-spec :mov-page [_]
(s/keys :req-un [::id ::index]))
(defmethod change-spec :add-color [_]
(s/keys :req-un [::ctc/color]))
(defmethod change-spec :mod-color [_]
(s/keys :req-un [::ctc/color]))
(defmethod change-spec :del-color [_]
(s/keys :req-un [::id]))
(s/def :internal.changes.add-recent-color/color ::ctc/recent-color)
(defmethod change-spec :add-recent-color [_]
(s/keys :req-un [:internal.changes.add-recent-color/color]))
(s/def :internal.changes.add-media/object ::ctfm/media-object)
(defmethod change-spec :add-media [_]
(s/keys :req-un [:internal.changes.add-media/object]))
(s/def :internal.changes.mod-media/width ::us/safe-integer)
(s/def :internal.changes.mod-media/height ::us/safe-integer)
(s/def :internal.changes.mod-media/path (s/nilable string?))
(s/def :internal.changes.mod-media/mtype string?)
(s/def :internal.changes.mod-media/object
(s/keys :req-un [::id]
:opt-un [:internal.changes.mod-media/width
:internal.changes.mod-media/height
:internal.changes.mod-media/path
:internal.changes.mod-media/mtype]))
(defmethod change-spec :mod-media [_]
(s/keys :req-un [:internal.changes.mod-media/object]))
(defmethod change-spec :del-media [_]
(s/keys :req-un [::id]))
(s/def :internal.changes.add-component/shapes
(s/coll-of ::cts/shape))
(defmethod change-spec :add-component [_]
(s/keys :req-un [::id ::name]
:opt-un [::path :internal.changes.add-component/shapes]))
(defmethod change-spec :mod-component [_]
(s/keys :req-un [::id]
:opt-un [::name ::path ::annotation :internal.changes.add-component/shapes]))
(s/def :internal.changes.del-component/skip-undelete? boolean?)
(defmethod change-spec :del-component [_]
(s/keys :req-un [::id]
:opt-un [:internal.changes.del-component/skip-undelete?]))
(defmethod change-spec :restore-component [_]
(s/keys :req-un [::id]))
(defmethod change-spec :purge-component [_]
(s/keys :req-un [::id]))
(defmethod change-spec :add-typography [_]
(s/keys :req-un [::ctt/typography]))
(defmethod change-spec :mod-typography [_]
(s/keys :req-un [::ctt/typography]))
(defmethod change-spec :del-typography [_]
(s/keys :req-un [::ctt/id]))
(s/def ::change (s/multi-spec change-spec :type))
(s/def ::changes (s/coll-of ::change))

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

@ -8,9 +8,9 @@
(:require
[app.common.colors :as clr]
[app.common.data :as d]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[clojure.spec.alpha :as s]))
[app.common.data.macros :as dm]
[app.common.schema :as sm]
[app.common.uuid :as uuid]))
(def file-version 20)
(def default-color clr/gray-20)
@ -601,14 +601,16 @@
[p1 (+ 1 (d/parse-integer p2))]
[basename 1]))
(s/def ::set-of-strings
(s/every ::us/string :kind set?))
(defn generate-unique-name
"A unique name generator"
[used basename]
(us/assert! ::set-of-strings used)
(us/assert! ::us/string basename)
(dm/assert!
"expected a set of strings"
(sm/set-of-strings? used))
(dm/assert!
"expected a string for `basename`."
(string? basename))
(if-not (contains? used basename)
basename
(let [[prefix initial] (extract-numeric-suffix basename)]

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

@ -8,7 +8,6 @@
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.spec :as us]
[app.common.types.components-list :as ctkl]
[app.common.types.pages-list :as ctpl]
[app.common.types.shape.layout :as ctl]
@ -286,9 +285,9 @@
(defn get-container
[file type id]
(us/assert map? file)
(us/assert keyword? type)
(us/assert uuid? id)
(dm/assert! (map? file))
(dm/assert! (keyword? type))
(dm/assert! (uuid? id))
(-> (if (= type :page)
(ctpl/get-page file id)
@ -375,7 +374,7 @@
(map second)))
(defn get-index-replacement
"Given a collection of shapes, calculate their positions
"Given a collection of shapes, calculate their positions
in the parent, find first index and return next one"
[shapes objects]
(->> shapes

505
common/src/app/common/schema.cljc Normal file
View file

@ -0,0 +1,505 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.common.schema
(:refer-clojure :exclude [deref merge parse-uuid])
#?(:cljs (:require-macros [app.common.schema :refer [ignoring]]))
(:require
[app.common.data.macros :as dm]
[app.common.schema.generators :as sg]
[app.common.schema.openapi :as-alias oapi]
[app.common.schema.registry :as sr]
[app.common.uri :as u]
[app.common.uuid :as uuid]
[clojure.test.check.generators :as tgen]
[cuerdas.core :as str]
[malli.core :as m]
[malli.dev.pretty :as mdp]
[malli.error :as me]
[malli.generator :as mg]
[malli.registry :as mr]
[malli.transform :as mt]
[malli.util :as mu]))
(defn validate
[s value]
(m/validate s value {:registry sr/default-registry}))
(defn explain
[s value]
(m/explain s value {:registry sr/default-registry}))
(defn explain-data
[s value]
(mu/explain-data s value {:registry sr/default-registry}))
(defn schema?
[o]
(m/schema? o))
(defn schema
[s]
(m/schema s {:registry sr/default-registry}))
(defn humanize
[exp]
(me/humanize exp))
(defn generate
([s]
(mg/generate (schema s)))
([s o]
(mg/generate (schema s) o)))
(defn form
[s]
(m/form s {:registry sr/default-registry}))
(defn merge
[& items]
(apply mu/merge (map schema items)))
(defn ref?
[s]
(m/-ref-schema? s))
(defn deref
[s]
(m/deref s))
(defn error-values
[exp]
(malli.error/error-value exp {:malli.error/mask-valid-values '...}))
(def default-transformer
(let [default-decoder
{:compile (fn [s _registry]
(let [props (m/type-properties s)]
(or (::oapi/decode props)
(::decode props))))}
default-encoder
{:compile (fn [s _]
(let [props (m/type-properties s)]
(or (::oapi/encode props)
(::encode props))))}
coders {:vector mt/-sequential-or-set->vector
:sequential mt/-sequential-or-set->seq
:set mt/-sequential->set
:tuple mt/-sequential->vector}]
(mt/transformer
{:name :penpot
:default-decoder default-decoder
:default-encoder default-encoder}
{:name :string
:decoders (mt/-string-decoders)
:encoders (mt/-string-encoders)}
{:name :collections
:decoders coders
:encoders coders}
)))
(defn validator
[s]
(-> s schema m/validator))
(defn explainer
[s]
(-> s schema m/explainer))
(defn lazy-validator
[s]
(let [vfn (delay (validator s))]
(fn [v] (@vfn v))))
(defn lazy-explainer
[s]
(let [vfn (delay (explainer s))]
(fn [v] (@vfn v))))
(defn encode
([s val transformer]
(m/encode s val {:registry sr/default-registry} transformer))
([s val options transformer]
(m/encode s val options transformer)))
(defn decode
([s val transformer]
(m/decode s val {:registry sr/default-registry} transformer))
([s val options transformer]
(m/decode s val options transformer)))
(defn decoder
([s transformer]
(m/decoder s {:registry sr/default-registry} transformer))
([s options transformer]
(m/decoder s options transformer)))
(defn humanize-data
[explain-data]
(-> explain-data
(update :schema form)
(update :errors (fn [errors] (map #(update % :schema form) errors)))))
(defn pretty-explain
[s d]
(mdp/explain (schema s) d))
(defmacro ignoring
[expr]
(if (:ns &env)
`(try ~expr (catch :default e# nil))
`(try ~expr (catch Throwable e# nil))))
(defn simple-schema
[& {:keys [pred] :as options}]
(cond-> options
(contains? options :type-properties)
(update :type-properties (fn [props]
(cond-> props
(contains? props :decode/string)
(update :decode/string (fn [decode-fn]
(fn [s]
(if (pred s)
s
(or (ignoring (decode-fn s)) s)))))
(contains? props ::decode)
(update ::decode (fn [decode-fn]
(fn [s]
(if (pred s)
s
(or (ignoring (decode-fn s)) s))))))))
:always
(m/-simple-schema)))
(defn lookup
"Lookups schema from registry."
([s] (lookup sr/default-registry s))
([registry s] (schema (mr/schema registry s))))
(defn pred-fn
[s]
(let [s (schema s)
v-fn (lazy-validator s)
e-fn (lazy-explainer s)]
(fn [v]
(let [result (v-fn v)]
(when (and (not result) (true? dm/*assert-context*))
(let [hint (str "schema assert: " (pr-str (form s)))
exp (e-fn v)]
(throw (ex-info hint {:type :assertion
:code :data-validation
:hint hint
::explain exp}))))
result))))
(defn valid?
[s v]
(let [result (validate s v)]
(when (and (not result) (true? dm/*assert-context*))
(let [hint (str "schema assert: " (pr-str (form s)))
exp (explain s v)]
(throw (ex-info hint {:type :assertion
:code :data-validation
:hint hint
::explain exp}))))
result))
(defn assert-fn
[s]
(let [f (pred-fn s)]
(fn [v]
(dm/assert! (f v)))))
(defmacro verify-fn
[s]
(let [f (pred-fn s)]
(fn [v]
(dm/verify! (f v)))))
(defn register! [type s]
(let [s (if (map? s) (simple-schema s) s)]
(swap! sr/registry assoc type s)))
(defn def! [type s]
(register! type s)
nil)
;; --- GENERATORS
;; FIXME: replace with sg/subseq
(defn gen-set-from-choices
[choices]
(->> tgen/nat
(tgen/fmap (fn [i]
(into #{}
(map (fn [_] (rand-nth choices)))
(range i))))))
;; --- BUILTIN SCHEMAS
(def! :merge (mu/-merge))
(def! :union (mu/-union))
(def uuid-rx
#"^[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}$")
(defn parse-uuid
[s]
(if (string? s)
(some->> (re-matches uuid-rx s) uuid/uuid)
s))
(def! ::uuid
{:type ::uuid
:pred uuid?
:type-properties
{:title "uuid"
:description "UUID formatted string"
:error/message "should be an uuid"
:gen/gen (sg/uuid)
::oapi/type "string"
::oapi/format "uuid"
::oapi/decode parse-uuid}})
(def email-re #"[a-zA-Z0-9_.+-\\\\]+@[a-zA-Z0-9-]+\.[a-zA-Z0-9-.]+")
(defn parse-email
[s]
(if (string? s)
(re-matches email-re s)
s))
;; FIXME: add proper email generator
(def! ::email
{:type ::email
:pred (fn [s]
(and (string? s) (re-seq email-re s)))
:type-properties
{:title "email"
:description "string with valid email address"
:error/message "expected valid email"
:gen/gen (-> :string sg/generator)
::oapi/type "string"
::oapi/format "email"
::oapi/decode parse-email}})
(def non-empty-strings-xf
(comp
(filter string?)
(remove str/empty?)
(remove str/blank?)))
(def! ::set-of-strings
{:type ::set-of-strings
:pred #(and (set? %) (every? string? %))
:type-properties
{:title "set[string]"
:description "Set of Strings"
:error/message "should be a set of strings"
:gen/gen (-> :string sg/generator sg/set)
::oapi/type "array"
::oapi/format "set"
::oapi/items {:type "string"}
::oapi/unique-items true
::oapi/decode (fn [v]
(let [v (if (string? v) (str/split v #"[\s,]+") v)]
(into #{} non-empty-strings-xf v)))}})
(def! ::set-of-emails
{:type ::set-of-emails
:pred #(and (set? %) (every? string? %))
:type-properties
{:title "set[email]"
:description "Set of Emails"
:error/message "should be a set of emails"
:gen/gen (-> ::email sg/generator sg/set)
::oapi/type "array"
::oapi/format "set"
::oapi/items {:type "string" :format "email"}
::oapi/unique-items true
::decode (fn [v]
(let [v (if (string? v) (str/split v #"[\s,]+") v)]
(into #{} (keep parse-email) v)))}})
(def! ::set-of-uuid
{:type ::set-of-uuid
:pred #(and (set? %) (every? uuid? %))
:type-properties
{:title "set[uuid]"
:description "Set of UUID"
:error/message "should be a set of UUID instances"
:gen/gen (-> ::uuid sg/generator sg/set)
::oapi/type "array"
::oapi/format "set"
::oapi/items {:type "string" :format "uuid"}
::oapi/unique-items true
::oapi/decode (fn [v]
(let [v (if (string? v) (str/split v #"[\s,]+") v)]
(into #{} (keep parse-uuid) v)))}})
(def! ::coll-of-uuid
{:type ::set-of-uuid
:pred (partial every? uuid?)
:type-properties
{:title "[uuid]"
:description "Coll of UUID"
:error/message "should be a coll of UUID instances"
:gen/gen (-> ::uuid sg/generator sg/set)
::oapi/type "array"
::oapi/format "array"
::oapi/items {:type "string" :format "uuid"}
::oapi/unique-items false
::oapi/decode (fn [v]
(let [v (if (string? v) (str/split v #"[\s,]+") v)]
(into [] (keep parse-uuid) v)))}})
(def! ::one-of
{:type ::one-of
:min 1
:max 1
:compile (fn [props children _]
(let [options (into #{} (last children))
format (:format props "keyword")]
{:pred #(contains? options %)
:type-properties
{:title "one-of"
:description "One of the Set"
:gen/gen (sg/elements options)
::oapi/type "string"
::oapi/format (:format props "keyword")
::oapi/decode (if (= format "keyword")
keyword
identity)}}))})
(def max-safe-int (int 1e6))
(def min-safe-int (int -1e6))
(def! ::safe-int
{:type ::safe-int
:pred #(and (int? %) (>= max-safe-int %) (>= % min-safe-int))
:type-properties
{:title "int"
:description "Safe Integer"
:error/message "expected to be int in safe range"
:gen/gen (sg/small-int)
::oapi/type "integer"
::oapi/format "int64"
::oapi/decode (fn [s]
(if (string? s)
(parse-long s)
s))}})
(def! ::safe-number
{:type ::safe-number
:pred #(and (number? %) (>= max-safe-int %) (>= % min-safe-int))
:type-properties
{:title "number"
:description "Safe Number"
:error/message "expected to be number in safe range"
:gen/gen (sg/one-of (sg/small-int)
(sg/small-double))
::oapi/type "number"
::oapi/format "double"
::oapi/decode (fn [s]
(if (string? s)
(parse-double s)
s))}})
(def! ::safe-double
{:type ::safe-double
:pred #(and (double? %) (>= max-safe-int %) (>= % min-safe-int))
:type-properties
{:title "number"
:description "Safe Number"
:error/message "expected to be number in safe range"
:gen/gen (sg/small-double)
::oapi/type "number"
::oapi/format "double"
::oapi/decode (fn [s]
(if (string? s)
(parse-double s)
s))}})
(def! ::contains-any
{:type ::contains-any
:min 1
:max 1
:compile (fn [props children _]
(let [choices (last children)
pred (if (:strict props)
#(some (fn [prop]
(some? (get % prop)))
choices)
#(some (fn [prop]
(contains? % prop))
choices))]
{:pred pred
:type-properties
{:title "contains"
:description "contains predicate"}}))})
(def! ::inst
{:type ::inst
:pred inst?
:type-properties
{:title "inst"
:description "Satisfies Inst protocol"
:error/message "expected to be number in safe range"
:gen/gen (sg/small-int)
::oapi/type "number"
::oapi/format "int64"}})
(def! ::fn
[:schema fn?])
(def! ::word-string
{:type ::word-string
:pred #(and (string? %) (not (str/blank? %)))
:type-properties
{:title "string"
:description "string"
:error/message "expected a non empty string"
:gen/gen (sg/word-string)
::oapi/type "string"
::oapi/format "string"}})
(def! ::uri
{:type ::uri
:pred u/uri?
:type-properties
{:title "uri"
:description "URI formatted string"
:error/message "expected URI instance"
:gen/gen (sg/uri)
::oapi/type "string"
::oapi/format "uri"
::oapi/decode (comp u/uri str/trim)}})
;; ---- PREDICATES
(def safe-int?
(pred-fn ::safe-int))
(def set-of-strings?
(pred-fn ::set-of-strings))
(def set-of-emails?
(pred-fn ::set-of-emails))
(def set-of-uuid?
(pred-fn ::set-of-uuid))
(def coll-of-uuid?
(pred-fn ::coll-of-uuid))
(def email?
(pred-fn ::email))

285
common/src/app/common/schema/desc_js_like.cljc Normal file
View file

@ -0,0 +1,285 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.common.schema.desc-js-like
(:require
[app.common.data :as d]
[cuerdas.core :as str]
[malli.core :as m]
[malli.util :as mu]))
(def ^:dynamic *definitions* nil)
(declare describe)
(declare describe*)
(defn -diamond [s] (str "<" s ">"))
(defn -titled [schema] (if-let [t (-> schema m/properties :title)] (str " :: " t "") ""))
(defn minmax-suffix [schema]
(let [{:keys [min max]} (-> schema m/properties)]
(cond
(and min max) (str "[min=" min ",max=" max "]")
min (str "[min=" min "]")
max (str "[max=" max "]"))))
(defn -min-max-suffix [schema]
(let [{:keys [min max]} (-> schema m/properties)]
(cond
(and min max) (str " between " min " and " max " inclusive")
min (str " greater than " min)
max (str " less than " max)
:else "")))
(defn -length-suffix [schema]
(let [{:keys [min max]} (-> schema m/properties)]
(cond
(and min max) (str " with length between " min " and " max " inclusive")
min (str " with length <= " min)
max (str " with length >= " max)
:else "")))
(defn -pluralize-times [n]
(when n
(if (= 1 n) "time" "times")))
(defn -repeat-suffix [schema]
(let [{:keys [min max]} (-> schema m/properties)
min-timez (-pluralize-times min)
max-timez (-pluralize-times max)]
(cond
(and min max) (str " at least " min " " min-timez ", up to " max " " max-timez)
min (str " at least " min " " min-timez)
max (str " at most " max " " max-timez)
:else "")))
(defn -min-max-suffix-number [schema]
(let [{:keys [min max]} (merge (-> schema m/properties) (-> schema m/type-properties))]
(cond
(and min max) (str " between " min " and " max " inclusive")
min (str " greater than or equal to " min)
max (str " less than or equal to " max)
:else "")))
(defmulti visit (fn [name _schema _children _options] name) :default ::default)
(defmethod visit :ref [_ _schema children _] (pr-str (first children)))
(defmethod visit :> [_ _ [value] _] (str "> " value))
(defmethod visit :>= [_ _ [value] _] (str ">= " value))
(defmethod visit :< [_ _ [value] _] (str "< " value))
(defmethod visit :<= [_ _ [value] _] (str "<= " value))
(defmethod visit := [_ _ [value] _] (str "== '" (name value) "'"))
(defmethod visit :not= [_ _ [value] _] (str "not equal " value))
(defmethod visit :not [_ _ children _] {:not (last children)})
(defn -of-clause [children] (when children (str " of " (first children))))
(defmethod visit :sequential [_ schema children _] (str "sequence" (-titled schema) (-length-suffix schema) (-of-clause children)))
(defmethod visit :string [_ schema _ _] (str "string" (-titled schema) (-length-suffix schema)))
(defmethod visit :number [_ schema _ _] (str "number" (-titled schema) (-min-max-suffix schema)))
(defmethod visit :pos-int [_ schema _ _] (str "integer greater than 0" (-titled schema) (-min-max-suffix schema)))
(defmethod visit :neg-int [_ schema _ _] (str "integer less than 0" (-titled schema) (-min-max-suffix schema)))
(defmethod visit :nat-int [_ schema _ _] (str "natural integer" (-titled schema) (-min-max-suffix schema)))
(defmethod visit :float [_ schema _ _] (str "float" (-titled schema) (-min-max-suffix schema)))
(defmethod visit :pos [_ schema _ _] (str "number greater than 0" (-titled schema) (-min-max-suffix schema)))
(defmethod visit :neg [_ schema _ _] (str "number less than 0" (-titled schema) (-min-max-suffix schema)))
(defmethod visit :int [_ schema _ _] (str "integer" (-titled schema) (-min-max-suffix-number schema)))
(defmethod visit :double [_ schema _ _] (str "double" (-titled schema) (-min-max-suffix-number schema)))
(defmethod visit :select-keys [_ schema _ options] (describe* (m/deref schema) options))
(defmethod visit :and [_ s children _] (str (str/join ", and " children) (-titled s)))
(defmethod visit :enum [_ s children _options] (str "enum" (-titled s) " of " (str/join ", " children)))
(defmethod visit :maybe [_ _ children _] (str (first children) "?"))
(defmethod visit :tuple [_ s children _] (str "vector " (-titled s) "with exactly " (count children) " items of type: " (str/join ", " children)))
(defmethod visit :re [_ s _ options] (str "regex pattern " (-titled s) "matching " (pr-str (first (m/children s options)))))
(defmethod visit :any [_ s _ _] (str "anything" (-titled s)))
(defmethod visit :some [_ _ _ _] "anything but null")
(defmethod visit :nil [_ _ _ _] "null")
(defmethod visit :qualified-ident [_ _ _ _] "qualified-ident")
(defmethod visit :simple-keyword [_ _ _ _] "simple-keyword")
(defmethod visit :simple-symbol [_ _ _ _] "simple-symbol")
(defmethod visit :qualified-keyword [_ _ _ _] "qualified keyword")
(defmethod visit :symbol [_ _ _ _] "symbol")
(defmethod visit :qualified-symbol [_ _ _ _] "qualified symbol")
(defmethod visit :uuid [_ _ _ _] "uuid")
(defmethod visit :boolean [_ _ _ _] "boolean")
(defmethod visit :keyword [_ _ _ _] "keyword")
(defmethod visit :vector [_ _ children _]
(str "[" (last children) "]"))
(defn -tagged [children] (map (fn [[tag _ c]] (str c " (tag: " tag ")")) children))
(defmethod visit :or [_ _ children _] (str/join ", or " children))
(defmethod visit :orn [_ _ children _] (str/join ", or " (-tagged children)))
(defmethod visit :cat [_ _ children _] (str/join ", " children))
(defmethod visit :catn [_ _ children _] (str/join ", and " (-tagged children)))
(defmethod visit :alt [_ _ children _] (str/join ", or " children))
(defmethod visit :altn [_ _ children _] (str/join ", or " (-tagged children)))
(defmethod visit :repeat [_ schema children _]
(str "repeat " (-diamond (first children)) (-repeat-suffix schema)))
(defmethod visit :set [_ schema children _]
(str "set[" (first children) "]" (minmax-suffix schema)))
(defmethod visit ::m/val [_ schema children _]
(let [suffix (minmax-suffix schema)]
(cond-> (first children)
(some? suffix)
(str suffix))))
(defmethod visit :map-of [_ _ children _]
(str "map[" (first children) "," (second children) "]"))
(defmethod visit :union [_ _ children _]
(str/join " | " children))
(defn pad
[data n]
(let [prefix (apply str (take n (repeat " ")))]
(->> (str/lines data)
(map (fn [s] (str prefix s)))
(str/join "\n"))))
(defmethod visit ::default [_ schema _ _]
(let [props (m/type-properties schema)]
(or (:title props)
"*")))
(defmethod visit :map
[_ schema children {:keys [::level ::max-level] :as options}]
(let [props (m/properties schema)
closed? (:closed props)
title (some->> (:title props) str/camel str/capital)]
(if (>= level max-level)
(or (some-> title str)
"<untitled>")
(let [optional (into #{} (comp (filter (m/-comp :optional second))
(map first))
children)
entries (->> children
(map (fn [[k _ s]]
(str (pad " " level) (str/camel k)
(when (contains? optional k) "?")
": " s )))
(str/join ",\n"))
header (cond-> (if (zero? level)
(str "type " title)
(str title))
closed? (str "!")
(some? title) (str " ")
)]
(str header "{\n" entries "\n" (pad "}" level))))))
(defmethod visit :multi
[_ s children {:keys [::level ::max-level] :as options}]
(let [props (m/properties s)
title (some-> (:title props) str/camel str/capital)]
(if (>= level max-level)
title
(let [dispatcher (or (-> s m/properties :dispatch-description)
(-> s m/properties :dispatch))
prefix (apply str (take (inc level) (repeat " ")))
entries (->> children
(map (fn [[_ _ shape]]
(str prefix shape)))
(str/join ",\n"))
header (cond-> "multi"
(some? title) (str " " title)
:always (str " [dispatch=" (d/name dispatcher) "]"))]
(str header " {\n" entries "\n" (pad "}" level))))))
(defmethod visit :merge
[_ schema children _]
(let [entries (str/join " , " children)
props (m/properties schema)
title (or (some-> (:title props) str/camel str/capital)
"<untitled>")]
(str "merge object " title " { " entries " }")))
(defmethod visit :app.common.schema/one-of
[_ _ children _]
(let [elems (last children)]
(str "OneOf[" (->> elems
(map d/name)
(str/join ",")) "]")))
(defmethod visit :schema [_ schema children options]
(visit ::m/schema schema children options))
(defmethod visit ::m/schema
[_ schema _ {:keys [::level ::limit ::max-level] :as options}]
(let [schema' (m/deref schema)
props (merge
(m/properties schema)
(m/properties schema'))
ref (m/-ref schema)
title (:title props)]
(cond
(::inline props)
(do
(if (>= limit max-level)
title
(describe* schema' options)))
(and ref title)
(do
(when (<= limit max-level)
(swap! *definitions* conj (describe* schema' (assoc options ::base-limit limit))))
title)
(>= limit max-level)
(or title
(some-> ref d/name str/camel str/capital)
"<untitled>")
:else
(describe* schema' (assoc options ::base-level level ::base-limit limit)))))
(defn describe* [s options]
(letfn [(walk-fn [schema path children {:keys [::base-level ::base-limit] :or {base-level 0 base-limit 0} :as options}]
(let [options (assoc options
::limit (+ base-limit (count path))
::level (+ base-level (count path)))]
(visit (m/type schema) schema children options)))]
(m/walk s walk-fn options)))
(defn describe
"Given a schema, returns a string explaiaing the required shape in English"
([s]
(describe s nil))
([s options]
(let [type (m/type s)
defs (atom (d/ordered-set))
s (cond-> s
(= type ::m/schema)
(m/deref)
:always
(mu/update-properties assoc ::root true))
options (into {::m/walk-entry-vals true
::level 0
::max-level 300}
options)]
(binding [*definitions* defs]
(str (str/trim (describe* s options))
(when-let [defs @*definitions*]
(str "\n\n" (str/join "\n\n" defs))))))))

73
common/src/app/common/schema/desc_native.cljc Normal file
View file

@ -0,0 +1,73 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.common.schema.desc-native
(:require
[app.common.data :as d]
[app.common.schema :as sm]
[malli.core :as m]))
(declare describe*)
(defmulti visit (fn [name _schema _children _options] name) :default ::default)
(defmethod visit ::default [_ schema _ options]
(m/form schema options))
(defmethod visit :vector [_ _ children _]
(apply vector :vector children))
(defmethod visit :map [_ _ children _]
(let [childs (map (fn [[k p c]]
(if (nil? p)
[k c]
[k (d/without-qualified p) c]))
children)
props nil #_(m/properties schema)
params (cond->> childs
(some? props)
(cons props))]
(apply vector :map params)))
(defmethod visit :multi [_ schema children options]
(let [props (m/properties schema)]
(if (::simplified props)
[:multi (-> props
(dissoc ::simplified)
(assoc :options (into #{} (map first children))))]
(m/form schema options))))
(defmethod visit :merge [_ _ children _]
(apply vector :merge children))
(defmethod visit :schema [_ schema children options]
(visit ::m/schema schema children options))
(defmethod visit ::m/val [_ _ children _]
(last children))
(defmethod visit ::m/schema [_ schema _ options]
(let [schema' (m/deref schema)]
(describe* schema' (update options ::level inc))))
(defn describe* [s options]
(letfn [(walk-fn [schema _ children options]
(visit (m/type schema) schema children options))]
(m/walk s walk-fn options)))
(defn describe
"Given a schema, returns a string explaiaing the required shape in English"
([s]
(describe s nil))
([s options]
(let [s (sm/schema s)
s (cond-> s
(= (m/type s) ::m/schema)
(m/deref))
options (assoc options ::m/walk-entry-vals true ::level 0)]
(describe* s options))))

125
common/src/app/common/schema/generators.cljc Normal file
View file

@ -0,0 +1,125 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.common.schema.generators
(:refer-clojure :exclude [set subseq uuid for])
#?(:cljs (:require-macros [app.common.schema.generators]))
(:require
[app.common.schema.registry :as sr]
[app.common.uri :as u]
[app.common.uuid :as uuid]
[clojure.test.check :as tc]
[clojure.test.check.generators :as tg]
[clojure.test.check.properties :as tp]
[cuerdas.core :as str]
[malli.generator :as mg]))
(defn default-reporter-fn
[{:keys [type result] :as args}]
(case type
:complete
(prn (select-keys args [:result :num-tests :seed "time-elapsed-ms"]))
:failure
(do
(prn (select-keys args [:num-tests :seed :failed-after-ms]))
(when #?(:clj (instance? Throwable result)
:cljs (instance? js/Error result))
(throw result)))
nil))
(defmacro for
[& params]
`(tp/for-all ~@params))
(defn check!
[p & {:keys [num] :or {num 20} :as options}]
(tc/quick-check num p (assoc options :reporter-fn default-reporter-fn)))
(defn sample
([g]
(mg/sample g {:registry sr/default-registry}))
([g opts]
(mg/sample g (assoc opts :registry sr/default-registry))))
(defn generate
([g]
(mg/generate g {:registry sr/default-registry}))
([g opts]
(mg/generate g (assoc opts :registry sr/default-registry))))
(defn generator
([s]
(mg/generator s {:registry sr/default-registry}))
([s opts]
(mg/generator s (assoc opts :registry sr/default-registry))))
(defn small-double
[& {:keys [min max] :or {min -100 max 100}}]
(tg/double* {:min min, :max max, :infinite? false, :NaN? false}))
(defn small-int
[& {:keys [min max] :or {min -100 max 100}}]
(tg/large-integer* {:min min, :max max}))
(defn word-string
[]
(->> (tg/such-that #(re-matches #"\w+" %)
tg/string-alphanumeric
50)
(tg/such-that (complement str/blank?))))
(defn uri
[]
(tg/let [scheme (tg/elements ["http" "https"])
domain (as-> (word-string) $
(tg/such-that (fn [x] (> (count x) 5)) $ 100)
(tg/fmap str/lower $))
ext (tg/elements ["net" "com" "org" "app" "io"])]
(u/uri (str scheme "://" domain "." ext))))
;; FIXME: revisit
(defn uuid
[]
(->> tg/small-integer
(tg/fmap (fn [_] (uuid/next)))))
(defn subseq
"Given a collection, generates \"subsequences\" which are sequences
of (not necessarily contiguous) elements from the original
collection, in the same order. For collections of distinct elements
this is effectively a subset generator, with an ordering guarantee."
([elements]
(subseq [] elements))
([dest elements]
(->> (apply tg/tuple (repeat (count elements) tg/boolean))
(tg/fmap (fn [bools]
(into dest
(comp
(filter first)
(map second))
(map list bools elements)))))))
(defn set
[g]
(tg/set g))
(defn elements
[s]
(tg/elements s))
(defn one-of
[& gens]
(tg/one-of (into [] gens)))
(defn fmap
[f g]
(tg/fmap f g))
(defn tuple
[& opts]
(apply tg/tuple opts))

154
common/src/app/common/schema/openapi.cljc Normal file
View file

@ -0,0 +1,154 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.common.schema.openapi
(:require
[clojure.set :as set]
[cuerdas.core :as str]
[malli.core :as m]))
(def ^:dynamic *definitions* nil)
(declare transform*)
(defmulti visit (fn [name _schema _children _options] name) :default ::default)
(defmethod visit ::default [_ _ _ _] {})
(defmethod visit :> [_ _ [value] _] {:type "number" :exclusiveMinimum value})
(defmethod visit :>= [_ _ [value] _] {:type "number" :minimum value})
(defmethod visit :< [_ _ [value] _] {:type "number" :exclusiveMaximum value})
(defmethod visit :<= [_ _ [value] _] {:type "number" :maximum value})
(defmethod visit := [_ _ [value] _] {:const value})
(defmethod visit :not= [_ _ _ _] {})
(defmethod visit :not [_ _ children _] {:not (last children)})
(defmethod visit :and [_ _ children _] {:allOf children})
(defmethod visit :or [_ _ children _] {:anyOf children})
(defmethod visit :orn [_ _ children _] {:anyOf (map last children)})
(defmethod visit ::m/val [_ _ children _] (first children))
(def ^:private required-xf
(comp
(filter (m/-comp not :optional second))
(map first)
(map str/camel)))
(defmethod visit :map [_ schema children _]
(let [required (into [] required-xf children)
props (->> children
(remove :hidden)
(mapcat (fn [[k _ s]] [(str/camel k) s]))
(apply array-map))
closed? (:closed (m/properties schema))
object {:type "object" :properties props}]
(cond-> object
(seq required)
(assoc :required required)
closed?
(assoc :additionalProperties false))))
(defmethod visit :multi [_ _ children _] {:oneOf (mapv last children)})
(defn- minmax-properties
[m schema kmin kmax]
(merge
m
(-> schema
m/properties
(select-keys [:min :max])
(set/rename-keys {:min kmin, :max kmax}))))
(defmethod visit :map-of [_ schema children _]
(minmax-properties
{:type "object",
:additionalProperties (second children)}
schema
:minProperties
:maxProperties))
(defmethod visit :vector [_ schema children _]
(let [child (-> schema m/children first)
props (m/properties (m/deref child))]
(minmax-properties
{:type "array", :items (first children) :title (:title props)}
schema
:minItems
:maxItems)))
(defmethod visit :sequential [_ schema children _]
(minmax-properties
{:type "array", :items (first children)}
schema
:minItems
:maxItems))
(defmethod visit :set [_ schema children _]
(minmax-properties
{:type "array", :items (first children), :uniqueItems true}
schema
:minItems
:maxItems))
(defmethod visit :enum [_ _ children options] (merge (some-> (m/-infer children) (transform* options)) {:enum children}))
(defmethod visit :maybe [_ _ children _] {:oneOf (conj children {:type "null"})})
(defmethod visit :tuple [_ _ children _] {:type "array", :items children, :additionalItems false})
(defmethod visit :re [_ schema _ options] {:type "string", :pattern (first (m/children schema options))})
(defmethod visit :nil [_ _ _ _] {:type "null"})
(defmethod visit :string [_ schema _ _]
(merge {:type "string"} (-> schema m/properties (select-keys [:min :max]) (set/rename-keys {:min :minLength, :max :maxLength}))))
(defmethod visit :int [_ schema _ _]
(merge {:type "integer"} (-> schema m/properties (select-keys [:min :max]) (set/rename-keys {:min :minimum, :max :maximum}))))
(defmethod visit :double [_ schema _ _]
(merge {:type "number"}
(-> schema m/properties (select-keys [:min :max]) (set/rename-keys {:min :minimum, :max :maximum}))))
(defmethod visit :boolean [_ _ _ _] {:type "boolean"})
(defmethod visit :keyword [_ _ _ _] {:type "string"})
(defmethod visit :qualified-keyword [_ _ _ _] {:type "string"})
(defmethod visit :symbol [_ _ _ _] {:type "string"})
(defmethod visit :qualified-symbol [_ _ _ _] {:type "string"})
(defmethod visit :uuid [_ _ _ _] {:type "string" :format "uuid"})
(defmethod visit :schema [_ schema children options]
(visit ::m/schema schema children options))
(defmethod visit ::m/schema [_ schema _ options]
(let [result (transform* (m/deref schema) options)
defpath (::definitions-path options "#/definitions/")]
(if-let [ref (m/-ref schema)]
(let [rkey (str/concat (str/camel (namespace ref)) "$" (name ref))]
(some-> *definitions* (swap! assoc rkey result))
{"$ref" (str/concat defpath rkey)})
result)))
(defmethod visit :merge [_ schema _ options] (transform* (m/deref schema) options))
(defmethod visit :union [_ schema _ options] (transform* (m/deref schema) options))
(defmethod visit :select-keys [_ schema _ options] (transform* (m/deref schema) options))
(defn- unlift-keys
[m prefix]
(reduce-kv #(if (= (name prefix) (namespace %2)) (assoc %1 (keyword (str/camel (name %2))) %3) %1) {} m))
(defn transform*
[s options]
(letfn [(walk-fn [schema _ children options]
(let [p (merge (m/type-properties schema)
(m/properties schema))]
(merge (select-keys p [:title :description :default])
(visit (m/type schema) schema children options)
(unlift-keys p :app.common.openapi))))]
(m/walk s walk-fn options)))
(defn transform
([s] (transform s nil))
([s options]
(let [options (assoc options ::m/walk-entry-vals true)]
(transform* s options))))

20
common/src/app/common/schema/registry.cljc Normal file
View file

@ -0,0 +1,20 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.common.schema.registry
(:require
[malli.core :as m]
[malli.registry :as mr]
[malli.util :as mu]))
(defonce registry (atom {}))
(def default-registry
(mr/composite-registry
m/default-registry
(mu/schemas)
(mr/mutable-registry registry)))

148
common/src/app/common/types/color.cljc
View file

@ -7,97 +7,103 @@
(ns app.common.types.color
(:require
[app.common.data :as d]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.schema.openapi :as-alias oapi]
[app.common.text :as txt]
[app.common.types.color.generic :as-alias color-generic]
[app.common.types.color.gradient :as-alias color-gradient]
[app.common.types.color.gradient.stop :as-alias color-gradient-stop]
[clojure.spec.alpha :as s]))
[clojure.test.check.generators :as tgen]))
;; TODO: maybe define ::color-hex-string with proper hex color spec?
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SCHEMAS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- GRADIENTS
(def rgb-color-re
#"^#(?:[0-9a-fA-F]{3}){1,2}$")
(s/def ::id uuid?)
(defn- random-rgb-color
[]
#?(:clj (format "#%06x" (rand-int 16rFFFFFF))
:cljs
(let [r (rand-int 255)
g (rand-int 255)
b (rand-int 255)]
(str "#"
(.. r (toString 16) (padStart 2 "0"))
(.. g (toString 16) (padStart 2 "0"))
(.. b (toString 16) (padStart 2 "0"))))))
(s/def ::color-gradient/type #{:linear :radial})
(s/def ::color-gradient/start-x ::us/safe-number)
(s/def ::color-gradient/start-y ::us/safe-number)
(s/def ::color-gradient/end-x ::us/safe-number)
(s/def ::color-gradient/end-y ::us/safe-number)
(s/def ::color-gradient/width ::us/safe-number)
(sm/def! ::rgb-color
{:type ::rgb-color
:pred #(and (string? %) (some? (re-matches rgb-color-re %)))
:type-properties
{:title "rgb-color"
:description "RGB Color String"
:error/message "expected a valid RGB color"
:gen/gen (->> tgen/any (tgen/fmap (fn [_] (random-rgb-color))))
(s/def ::color-gradient-stop/color ::us/rgb-color-str)
(s/def ::color-gradient-stop/opacity ::us/safe-number)
(s/def ::color-gradient-stop/offset ::us/safe-number)
::oapi/type "integer"
::oapi/format "int64"}})
(s/def ::color-gradient/stop
(s/keys :req-un [::color-gradient-stop/color
::color-gradient-stop/opacity
::color-gradient-stop/offset]))
(sm/def! ::gradient
[:map {:title "Gradient"}
[:type [::sm/one-of #{:linear :radial}]]
[:start-x ::sm/safe-number]
[:start-y ::sm/safe-number]
[:end-x ::sm/safe-number]
[:end-y ::sm/safe-number]
[:width ::sm/safe-number]
[:stops
[:vector {:min 1 :gen/max 2}
[:map {:title "GradientStop"}
[:color ::rgb-color]
[:opacity ::sm/safe-number]
[:offset ::sm/safe-number]]]]])
(s/def ::color-gradient/stops
(s/coll-of ::color-gradient/stop :kind vector?))
(sm/def! ::color
[:map
[:id {:optional true} ::sm/uuid]
[:name {:optional true} :string]
[:path {:optional true} [:maybe :string]]
[:value {:optional true} [:maybe :string]]
[:color {:optional true} [:maybe ::rgb-color]]
[:opacity {:optional true} [:maybe ::sm/safe-number]]
[:modified-at {:optional true} ::sm/inst]
[:ref-id {:optional true} ::sm/uuid]
[:ref-file {:optional true} ::sm/uuid]
[:gradient {:optional true} [:maybe ::gradient]]])
(s/def ::gradient
(s/keys :req-un [::color-gradient/type
::color-gradient/start-x
::color-gradient/start-y
::color-gradient/end-x
::color-gradient/end-y
::color-gradient/width
::color-gradient/stops]))
;; --- COLORS
;; FIXME: incomplete schema
(sm/def! ::recent-color
[:and
[:map {:title "RecentColot"}
[:opacity {:optional true} [:maybe ::sm/safe-number]]
[:color {:optional true} [:maybe ::rgb-color]]
[:gradient {:optional true} [:maybe ::gradient]]]
[::sm/contains-any {:strict true} [:color :gradient]]])
(s/def ::color-generic/name string?)
(s/def ::color-generic/path (s/nilable string?))
(s/def ::color-generic/value (s/nilable string?))
(s/def ::color-generic/color (s/nilable ::us/rgb-color-str))
(s/def ::color-generic/opacity (s/nilable ::us/safe-number))
(s/def ::color-generic/gradient (s/nilable ::gradient))
(s/def ::color-generic/ref-id uuid?)
(s/def ::color-generic/ref-file uuid?)
(s/def ::color-generic/modified-at ::us/inst)
(def color?
(sm/pred-fn ::color))
(s/def ::shape-color
(s/keys :req-un [:us/color
::color-generic/opacity]
:opt-un [::color-generic/gradient
::color-generic/ref-id
::color-generic/ref-file]))
(def recent-color?
(sm/pred-fn ::recent-color))
(s/def ::color
(s/keys :opt-un [::id
::color-generic/name
::color-generic/path
::color-generic/value
::color-generic/color
::color-generic/opacity
::color-generic/gradient
::color-generic/modified-at]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::recent-color
(s/and
(s/keys :opt-un [::color-generic/value
::color-generic/color
::color-generic/opacity
::color-generic/gradient])
(fn [o]
(or (contains? o :gradient)
(contains? o :color)))))
;; --- Helpers for color in different parts of a shape
;; fill
;; --- fill
(defn fill->shape-color
[fill]
(d/without-nils {:color (:fill-color fill)
:opacity (:fill-opacity fill)
:gradient (:fill-color-gradient fill)
:ref-id (:fill-color-ref-id fill)
:ref-file (:fill-color-ref-file fill)}))
(d/without-nils
{:color (:fill-color fill)
:opacity (:fill-opacity fill)
:gradient (:fill-color-gradient fill)
:ref-id (:fill-color-ref-id fill)
:ref-file (:fill-color-ref-file fill)}))
(defn set-fill-color
[shape position color opacity gradient]

54
common/src/app/common/types/container.cljc
View file

@ -6,26 +6,42 @@
(ns app.common.types.container
(:require
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.geom.shapes :as gsh]
[app.common.pages.common :as common]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.types.component :as ctk]
[app.common.types.components-list :as ctkl]
[app.common.types.pages-list :as ctpl]
[app.common.types.shape :as cts]
[app.common.types.shape-tree :as ctst]
[app.common.uuid :as uuid]
[clojure.spec.alpha :as s]))
[app.common.uuid :as uuid]))
(s/def ::type #{:page :component})
(s/def ::id uuid?)
(s/def ::name ::us/string)
(s/def ::path (s/nilable ::us/string))
(s/def ::modified-at ::us/inst)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SCHEMA
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::container
(s/keys :req-un [::id ::name]
:opt-un [::type ::path ::modified-at ::ctst/objects]))
(def valid-container-types
#{:page :component})
(sm/def! ::container
[:map
[:id ::sm/uuid]
[:type {:optional true}
[::sm/one-of valid-container-types]]
[:name :string]
[:path {:optional true} [:maybe :string]]
[:modified-at {:optional true} ::sm/inst]
[:objects {:optional true}
[:map-of {:gen/max 10} ::sm/uuid ::cts/shape]]])
(def container?
(sm/pred-fn ::container))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn make-container
[page-or-component type]
@ -41,9 +57,9 @@
(defn get-container
[file type id]
(us/assert map? file)
(us/assert ::type type)
(us/assert uuid? id)
(dm/assert! (map? file))
(dm/assert! (contains? valid-container-types type))
(dm/assert! (uuid? id))
(-> (if (= type :page)
(ctpl/get-page file id)
@ -52,8 +68,14 @@
(defn get-shape
[container shape-id]
(us/assert ::container container)
(us/assert ::us/uuid shape-id)
(dm/assert!
"expected valid container"
(container? container))
(dm/assert!
"expected valid uuid for `shape-id`"
(uuid? shape-id))
(-> container
(get :objects)
(get shape-id)))

66
common/src/app/common/types/file.cljc
View file

@ -13,54 +13,59 @@
[app.common.geom.shapes :as gsh]
[app.common.pages.common :refer [file-version]]
[app.common.pages.helpers :as cph]
[app.common.schema :as sm]
[app.common.types.color :as ctc]
[app.common.types.colors-list :as ctcl]
[app.common.types.component :as ctk]
[app.common.types.components-list :as ctkl]
[app.common.types.container :as ctn]
[app.common.types.file.media-object :as ctfm]
[app.common.types.page :as ctp]
[app.common.types.pages-list :as ctpl]
[app.common.types.shape-tree :as ctst]
[app.common.types.typographies-list :as ctyl]
[app.common.types.typography :as cty]
[app.common.uuid :as uuid]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]))
;; Specs
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SCHEMA
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::colors
(s/map-of uuid? ::ctc/color))
(sm/def! ::media-object
[:map {:title "FileMediaObject"}
[:id ::sm/uuid]
[:name :string]
[:width ::sm/safe-int]
[:height ::sm/safe-int]
[:mtype :string]
[:path {:optional true} [:maybe :string]]])
(s/def ::recent-colors
(s/coll-of ::ctc/recent-color :kind vector?))
(sm/def! ::data
[:map {:title "FileData"}
[:pages [:vector ::sm/uuid]]
[:pages-index
[:map-of {:gen/max 5} ::sm/uuid ::ctp/page]]
[:colors {:optional true}
[:map-of {:gen/max 5} ::sm/uuid ::ctc/color]]
[:components {:optional true}
[:map-of {:gen/max 5} ::sm/uuid ::ctn/container]]
[:recent-colors {:optional true}
[:vector {:gen/max 3} ::ctc/recent-color]]
[:typographies {:optional true}
[:map-of {:gen/max 2} ::sm/uuid ::cty/typography]]
[:media {:optional true}
[:map-of {:gen/max 5} ::sm/uuid ::media-object]]
])
(s/def ::typographies
(s/map-of uuid? ::cty/typography))
(def file-data?
(sm/pred-fn ::data))
(s/def ::pages
(s/coll-of uuid? :kind vector?))
(def media-object?
(sm/pred-fn ::media-object))
(s/def ::media
(s/map-of uuid? ::ctfm/media-object))
(s/def ::pages-index
(s/map-of uuid? ::ctp/page))
(s/def ::components
(s/map-of uuid? ::ctn/container))
(s/def ::data
(s/keys :req-un [::pages-index
::pages]
:opt-un [::colors
::components
::recent-colors
::typographies
::media]))
;; Initialization
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INITIALIZATION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def empty-file-data
{:version file-version
@ -429,6 +434,7 @@
(some? (:component-file %))
(assoc :component-file (:id file-data)))
main-instance-shapes)
; Add all shapes of the main instance to the library page
add-main-instance-shapes
(fn [page]

30
common/src/app/common/types/file/media_object.cljc
View file

@ -1,30 +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) KALEIDOS INC
(ns app.common.types.file.media-object
(:require
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
(s/def ::id uuid?)
(s/def ::name string?)
(s/def ::width ::us/safe-integer)
(s/def ::height ::us/safe-integer)
(s/def ::mtype string?)
;; NOTE: This is marked as nilable for backward compatibility, but
;; right now is just exists or not exists. We can thin in a gradual
;; migration and then mark it as not nilable.
(s/def ::path (s/nilable string?))
(s/def ::media-object
(s/keys :req-un [::id
::name
::width
::height
::mtype]
:opt-un [::path]))

59
common/src/app/common/types/grid.cljc Normal file
View file

@ -0,0 +1,59 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.common.types.grid
(:require
[app.common.schema :as sm]
[app.common.types.color :as ctc]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SCHEMA
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(sm/def! ::grid-color
[:map {:title "PageGridColor"}
[:color ::ctc/rgb-color]
[:opacity ::sm/safe-number]])
(sm/def! ::column-params
[:map
[:color ::grid-color]
[:type [::sm/one-of #{:stretch :left :center :right}]]
[:size {:optional true} ::sm/safe-number]
[:margin {:optional true} [:maybe ::sm/safe-number]]
[:item-length {:optional true} [:maybe ::sm/safe-number]]
[:gutter {:optional true} [:maybe ::sm/safe-number]]])
(sm/def! ::square-params
[:map
[:size ::sm/safe-number]
[:color ::grid-color]])
(sm/def! ::grid
[:multi {:dispatch :type}
[:column
[:map
[:type [:= :column]]
[:display :boolean]
[:params ::column-params]]]
[:row
[:map
[:type [:= :row]]
[:display :boolean]
[:params ::column-params]]]
[:square
[:map
[:type [:= :square]]
[:display :boolean]
[:params ::square-params]]]])
(sm/def! ::saved-grids
[:map {:title "PageGrid"}
[:square {:optional true} ::square-params]
[:row {:optional true} ::column-params]
[:column {:optional true} ::column-params]])

26
common/src/app/common/types/modifiers.cljc
View file

@ -17,7 +17,6 @@
[app.common.geom.shapes.strokes :as gss]
[app.common.math :as mth]
[app.common.pages.helpers :as cph]
[app.common.spec :as us]
[app.common.text :as txt]
[app.common.types.shape.layout :as ctl]
#?(:cljs [cljs.core :as c]
@ -264,7 +263,7 @@
(resize-vec? vector)
(update :geometry-child maybe-add-resize (resize-op order vector origin)))))
([modifiers vector origin transform transform-inverse]
([modifiers vector origin transform transform-inverse]
(resize modifiers vector origin transform transform-inverse nil))
;; `precise?` works so we don't remove almost empty resizes. This will be used in the pixel-precision
@ -462,9 +461,9 @@
(change-dimensions-modifiers shape attr value nil))
([{:keys [transform transform-inverse] :as shape} attr value {:keys [ignore-lock?] :or {ignore-lock? false}}]
(us/assert map? shape)
(us/assert #{:width :height} attr)
(us/assert number? value)
(dm/assert! (map? shape))
(dm/assert! (#{:width :height} attr))
(dm/assert! (number? value))
(let [{:keys [proportion proportion-lock]} shape
size (select-keys (:selrect shape) [:width :height])
@ -491,8 +490,11 @@
(defn change-orientation-modifiers
[shape orientation]
(us/assert map? shape)
(us/verify #{:horiz :vert} orientation)
(dm/assert! (map? shape))
(dm/assert!
"expected a valid orientation"
(#{:horiz :vert} orientation))
(let [width (:width shape)
height (:height shape)
new-width (if (= orientation :horiz) (max width height) (min width height))
@ -672,17 +674,17 @@
[shape value]
(cond-> shape
(cph/text-shape? shape)
(update-text-content scale-text-content value)
(update-text-content scale-text-content value)
:always
(gsc/update-corners-scale value)
(d/not-empty? (:strokes shape))
(gss/update-strokes-width value)
(d/not-empty? (:shadow shape))
(gse/update-shadows-scale value)
(some? (:blur shape))
(gse/update-blur-scale value)

65
common/src/app/common/types/page.cljc
View file

@ -8,34 +8,56 @@
(:require
[app.common.data :as d]
[app.common.files.features :as ffeat]
[app.common.spec :as us]
[app.common.types.page.flow :as ctpf]
[app.common.types.page.grid :as ctpg]
[app.common.types.page.guide :as ctpu]
[app.common.schema :as sm]
[app.common.types.color :as-alias ctc]
[app.common.types.grid :as ctg]
[app.common.types.shape :as cts]
[app.common.uuid :as uuid]
[clojure.spec.alpha :as s]))
[app.common.uuid :as uuid]))
;; --- Background color
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SCHEMAS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::background ::us/rgb-color-str)
(sm/def! ::flow
[:map {:title "PageFlow"}
[:id ::sm/uuid]
[:name :string]
[:starting-frame ::sm/uuid]])
;; --- Page options
(def flow?
(sm/pred-fn ::flow))
(s/def ::options
(s/keys :opt-un [::background
::ctpg/saved-grids
::ctpf/flows
::ctpu/guides]))
(sm/def! ::guide
[:map {:title "PageGuide"}
[:id ::sm/uuid]
[:axis [::sm/one-of #{:x :y}]]
[:position ::sm/safe-number]
[:frame-id {:optional true} [:maybe ::sm/uuid]]])
;; --- Page
(def guide?
(sm/pred-fn ::guide))
(s/def ::id uuid?)
(s/def ::name string?)
(s/def ::objects (s/map-of uuid? ::cts/shape))
(sm/def! ::page
[:map {:title "FilePage"}
[:id ::sm/uuid]
[:name :string]
[:objects
[:map-of {:gen/max 5} ::sm/uuid ::cts/shape]]
[:options
[:map {:title "PageOptions"}
[:background {:optional true} ::ctc/rgb-color]
[:saved-grids {:optional true} ::ctg/saved-grids]
[:flows {:optional true}
[:vector {:gen/max 2} ::flow]]
[:guides {:optional true}
[:map-of {:gen/max 2} ::sm/uuid ::guide]]]]])
(s/def ::page
(s/keys :req-un [::id ::name ::objects ::options]))
(def page?
(sm/pred-fn ::page))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INIT & HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- Initialization
@ -80,6 +102,3 @@
(defn get-frame-flow
[flows frame-id]
(d/seek #(= (:starting-frame %) frame-id) flows))

24
common/src/app/common/types/page/flow.cljc
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) KALEIDOS INC
(ns app.common.types.page.flow
(:require
[clojure.spec.alpha :as s]))
;; --- Interaction Flows
(s/def ::id uuid?)
(s/def ::name string?)
(s/def ::starting-frame uuid?)
(s/def ::flow
(s/keys :req-un [::id
::name
::starting-frame]))
(s/def ::flows
(s/coll-of ::flow :kind vector?))

46
common/src/app/common/types/page/grid.cljc
View file

@ -1,46 +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) KALEIDOS INC
(ns app.common.types.page.grid
(:require
[app.common.spec :as us]
[app.common.types.page.grid.color :as-alias grid-color]
[clojure.spec.alpha :as s]))
;; --- Board grids
(s/def ::grid-color/color string?)
(s/def ::grid-color/opacity ::us/safe-number)
(s/def ::size (s/nilable ::us/safe-integer))
(s/def ::item-length (s/nilable ::us/safe-number))
(s/def ::color (s/keys :req-un [::grid-color/color
::grid-color/opacity]))
(s/def ::type #{:stretch :left :center :right})
(s/def ::gutter (s/nilable ::us/safe-integer))
(s/def ::margin (s/nilable ::us/safe-integer))
(s/def ::square
(s/keys :req-un [::size
::color]))
(s/def ::column
(s/keys :req-un [::color]
:opt-un [::size
::type
::item-length
::margin
::gutter]))
(s/def ::row ::column)
(s/def ::saved-grids
(s/keys :opt-un [::square
::row
::column]))

27
common/src/app/common/types/page/guide.cljc
View file

@ -1,27 +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) KALEIDOS INC
(ns app.common.types.page.guide
(:require
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
;; --- Page guides
(s/def ::id uuid?)
(s/def ::axis #{:x :y})
(s/def ::position ::us/safe-number)
(s/def ::frame-id (s/nilable uuid?))
(s/def ::guide
(s/keys :req-un [::id
::axis
::position]
:opt-un [::frame-id]))
(s/def ::guides
(s/map-of uuid? ::guide))

444
common/src/app/common/types/shape.cljc
View file

@ -13,142 +13,24 @@
[app.common.geom.point :as gpt]
[app.common.geom.shapes :as gsh]
[app.common.pages.common :refer [default-color]]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.types.color :as ctc]
[app.common.types.grid :as ctg]
[app.common.types.shape.blur :as ctsb]
[app.common.types.shape.export :as ctse]
[app.common.types.shape.interactions :as ctsi]
[app.common.types.shape.layout :as ctsl]
[app.common.types.shape.path :as ctsp]
[app.common.types.shape.radius :as ctsr]
;; FIXME: missing spec -> schema
#_[app.common.types.shape.layout :as ctsl]
[app.common.types.shape.shadow :as ctss]
[app.common.types.shape.text :as ctsx]
[app.common.uuid :as uuid]
[clojure.set :as set]
[clojure.spec.alpha :as s]
[clojure.test.check.generators :as tgen]))
;; --- Specs
(s/def ::frame-id uuid?)
(s/def ::id uuid?)
(s/def ::name ::us/string)
(s/def ::path (s/nilable ::us/string))
(s/def ::page-id uuid?)
(s/def ::parent-id uuid?)
(s/def ::string ::us/string)
(s/def ::type #{:frame :text :rect :path :image :circle :group :bool :svg-raw})
(s/def ::uuid uuid?)
(s/def ::component-id uuid?)
(s/def ::component-file uuid?)
(s/def ::component-root? boolean?)
(s/def ::shape-ref uuid?)
;; Size constraints
(s/def ::constraints-h #{:left :right :leftright :center :scale})
(s/def ::constraints-v #{:top :bottom :topbottom :center :scale})
(s/def ::fixed-scroll boolean?)
;; Page Data related
(s/def ::blocked boolean?)
(s/def ::collapsed boolean?)
(s/def ::fill-color ::us/rgb-color-str)
(s/def ::fill-opacity ::us/safe-number)
(s/def ::fill-color-gradient (s/nilable ::ctc/gradient))
(s/def ::fill-color-ref-file (s/nilable uuid?))
(s/def ::fill-color-ref-id (s/nilable uuid?))
(s/def ::hide-fill-on-export boolean?)
(s/def ::show-content boolean?)
(s/def ::hide-in-viewer boolean?)
(s/def ::file-thumbnail boolean?)
(s/def ::masked-group? boolean?)
(s/def ::font-family ::us/string)
(s/def ::font-size ::us/safe-integer)
(s/def ::font-style ::us/string)
(s/def ::font-weight ::us/string)
(s/def ::hidden boolean?)
(s/def ::letter-spacing ::us/safe-number)
(s/def ::line-height ::us/safe-number)
(s/def ::locked boolean?)
(s/def ::page-id uuid?)
(s/def ::proportion ::us/safe-number)
(s/def ::proportion-lock boolean?)
(s/def ::stroke-color ::us/string)
(s/def ::stroke-color-gradient (s/nilable ::ctc/gradient))
(s/def ::stroke-color-ref-file (s/nilable uuid?))
(s/def ::stroke-color-ref-id (s/nilable uuid?))
(s/def ::stroke-opacity ::us/safe-number)
(s/def ::stroke-style #{:solid :dotted :dashed :mixed :none :svg})
[clojure.set :as set]))
(def stroke-caps-line #{:round :square})
(def stroke-caps-marker #{:line-arrow :triangle-arrow :square-marker :circle-marker :diamond-marker})
(def stroke-caps (set/union stroke-caps-line stroke-caps-marker))
(s/def ::stroke-cap-start stroke-caps)
(s/def ::stroke-cap-end stroke-caps)
(s/def ::stroke-width ::us/safe-number)
(s/def ::stroke-alignment #{:center :inner :outer})
(s/def ::text-align #{"left" "right" "center" "justify"})
(s/def ::x ::us/safe-number)
(s/def ::y ::us/safe-number)
(s/def ::cx ::us/safe-number)
(s/def ::cy ::us/safe-number)
(s/def ::width ::us/safe-number)
(s/def ::height ::us/safe-number)
(s/def ::index integer?)
(s/def ::x1 ::us/safe-number)
(s/def ::y1 ::us/safe-number)
(s/def ::x2 ::us/safe-number)
(s/def ::y2 ::us/safe-number)
(s/def ::selrect
(s/keys :req-un [::x ::y ::x1 ::y1 ::x2 ::y2 ::width ::height]))
(s/def ::exports
(s/coll-of ::ctse/export :kind vector?))
(s/def ::points
(s/every ::gpt/point :kind vector?))
(s/def ::shapes
(s/every uuid? :kind vector?))
(s/def ::fill
(s/and (s/keys :opt-un [::fill-color
::fill-opacity
::fill-color-gradient
::fill-color-ref-file
::fill-color-ref-id])
(comp boolean seq)))
(s/def ::fills
(s/coll-of ::fill :kind vector?))
(s/def ::stroke
(s/keys :opt-un [::stroke-color
::stroke-color-ref-file
::stroke-color-ref-id
::stroke-opacity
::stroke-style
::stroke-width
::stroke-alignment
::stroke-cap-start
::stroke-cap-end]))
(s/def ::strokes
(s/coll-of ::stroke :kind vector?))
(s/def ::transform ::gmt/matrix)
(s/def ::transform-inverse ::gmt/matrix)
(s/def ::opacity ::us/safe-number)
(s/def ::blend-mode
(def blend-mode
#{:normal
:darken
:multiply
@ -166,102 +48,235 @@
:color
:luminosity})
(s/def ::shape-base-attrs
(s/keys :opt-un [::id
::name
::component-id
::component-file
::component-root?
::shape-ref
::selrect
::points
::blocked
::collapsed
::fills
::hide-fill-on-export
::font-family
::font-size
::font-style
::font-weight
::hidden
::letter-spacing
::line-height
::locked
::proportion
::proportion-lock
::constraints-h
::constraints-v
::fixed-scroll
::ctsr/rx
::ctsr/ry
::ctsr/r1
::ctsr/r2
::ctsr/r3
::ctsr/r4
::x
::y
::exports
::shapes
::strokes
::text-align
::transform
::transform-inverse
::width
::height
::masked-group?
::ctsi/interactions
::ctss/shadow
::ctsb/blur
::opacity
::blend-mode]))
(def horizontal-constraint-types
#{:left :right :leftright :center :scale})
(s/def ::shape-attrs
(s/with-gen
(s/merge
::shape-base-attrs
::ctsl/layout-container-props
::ctsl/layout-child-props
(def vertical-constraint-types
#{:top :bottom :topbottom :center :scale})
;; For BACKWARD COMPATIBILITY we need to spec fill and stroke
;; attrs as shape toplevel attrs
::fill
::stroke)
#(tgen/let [attrs1 (s/gen ::shape-base-attrs)
attrs2 (s/gen ::ctsl/layout-container-props)
attrs3 (s/gen ::ctsl/layout-child-props)]
(merge attrs1 attrs2 attrs3))))
(def text-align-types
#{"left" "right" "center" "justify"})
(defmulti shape-spec :type)
(sm/def! ::selrect
[:map {:title "Selrect"}
[:x ::sm/safe-number]
[:y ::sm/safe-number]
[:x1 ::sm/safe-number]
[:x2 ::sm/safe-number]
[:y1 ::sm/safe-number]
[:y2 ::sm/safe-number]
[:width ::sm/safe-number]
[:height ::sm/safe-number]])
(defmethod shape-spec :default [_]
(s/spec ::shape-attrs))
(sm/def! ::points
[:vector {:gen/max 5} ::gpt/point])
(defmethod shape-spec :text [_]
(s/merge ::shape-attrs
(s/keys :opt-un [::ctsx/content
::ctsx/position-data])))
(sm/def! ::fill
[:map {:title "Fill" :min 1}
[:fill-color {:optional true} ::ctc/rgb-color]
[:fill-opacity {:optional true} ::sm/safe-number]
[:fill-color-gradient {:optional true} ::ctc/gradient]
[:fill-color-ref-file {:optional true} [:maybe ::sm/uuid]]
[:fill-color-ref-id {:optional true} [:maybe ::sm/uuid]]])
(defmethod shape-spec :path [_]
(s/merge ::shape-attrs
(s/keys :opt-un [::ctsp/content])))
(sm/def! ::stroke
[:map {:title "Stroke"}
[:stroke-color {:optional true} :string]
[:stroke-color-ref-file {:optional true} ::sm/uuid]
[:stroke-color-ref-id {:optional true} ::sm/uuid]
[:stroke-opacity {:optional true} ::sm/safe-number]
[:stroke-style {:optional true}
[::sm/one-of #{:solid :dotted :dashed :mixed :none :svg}]]
[:stroke-width {:optional true} ::sm/safe-number]
[:stroke-alignment {:optional true}
[::sm/one-of #{:center :inner :outer}]]
[:stroke-cap-start {:optional true}
[::sm/one-of stroke-caps]]
[:stroke-cap-end {:optional true}
[::sm/one-of stroke-caps]]
[:stroke-color-gradient {:optional true} ::ctc/gradient]])
(defmethod shape-spec :frame [_]
(s/merge ::shape-attrs
(s/keys :opt-un [::file-thumbnail
::hide-fill-on-export
::show-content
::hide-in-viewer])))
(sm/def! ::shape-attrs
[:map {:title "ShapeAttrs"}
[:name {:optional true} :string]
[:component-id {:optional true} ::sm/uuid]
[:component-file {:optional true} ::sm/uuid]
[:component-root {:optional true} :boolean]
[:shape-ref {:optional true} ::sm/uuid]
[:selrect {:optional true} ::selrect]
[:points {:optional true} ::points]
[:blocked {:optional true} :boolean]
[:collapsed {:optional true} :boolean]
[:locked {:optional true} :boolean]
[:hidden {:optional true} :boolean]
[:masked-group? {:optional true} :boolean]
[:fills {:optional true}
[:vector {:gen/max 2} ::fill]]
[:hide-fill-on-export {:optional true} :boolean]
[:proportion {:optional true} ::sm/safe-number]
[:proportion-lock {:optional true} :boolean]
[:constraints-h {:optional true}
[::sm/one-of horizontal-constraint-types]]
[:constraints-v {:optional true}
[::sm/one-of vertical-constraint-types]]
[:fixed-scroll {:optional true} :boolean]
[:rx {:optional true} ::sm/safe-number]
[:ry {:optional true} ::sm/safe-number]
[:r1 {:optional true} ::sm/safe-number]
[:r2 {:optional true} ::sm/safe-number]
[:r3 {:optional true} ::sm/safe-number]
[:r4 {:optional true} ::sm/safe-number]
[:x {:optional true} ::sm/safe-number]
[:y {:optional true} ::sm/safe-number]
[:width {:optional true} ::sm/safe-number]
[:height {:optional true} ::sm/safe-number]
[:opacity {:optional true} ::sm/safe-number]
[:grids {:optional true}
[:vector {:gen/max 2} ::ctg/grid]]
[:exports {:optional true}
[:vector {:gen/max 2} ::ctse/export]]
[:strokes {:optional true}
[:vector {:gen/max 2} ::stroke]]
[:transform {:optional true} ::gmt/matrix]
[:transform-inverse {:optional true} ::gmt/matrix]
[:blend-mode {:optional true} [::sm/one-of blend-mode]]
[:interactions {:optional true}
[:vector {:gen/max 2} ::ctsi/interaction]]
[:shadow {:optional true}
[:vector {:gen/max 1} ::ctss/shadow]]
[:blur {:optional true} ::ctsb/blur]
[:grow-type {:optional true}
[::sm/one-of #{:auto-width :auto-height :fixed}]]
])
(s/def ::shape
(s/with-gen
(s/merge
(s/keys :req-un [::type ::name])
(s/multi-spec shape-spec :type))
(fn []
(tgen/let [type (s/gen ::type)
name (s/gen ::name)
attrs (s/gen ::shape-attrs)]
(assoc attrs :type type :name name)))))
(def shape-attrs?
(sm/pred-fn ::shape-attrs))
(sm/def! ::group-attrs
[:map {:title "GroupAttrs"}
[:type [:= :group]]
[:id ::sm/uuid]
[:shapes [:vector {:min 1 :gen/max 10 :gen/min 1} ::sm/uuid]]])
(sm/def! ::frame-attrs
[:map {:title "FrameAttrs"}
[:type [:= :frame]]
[:id ::sm/uuid]
[:shapes {:optional true} [:vector {:gen/max 10 :gen/min 1} ::sm/uuid]]
[:file-thumbnail {:optional true} :boolean]
[:hide-fill-on-export {:optional true} :boolean]
[:show-content {:optional true} :boolean]
[:hide-in-viewer {:optional true} :boolean]])
(sm/def! ::bool-attrs
[:map {:title "BoolAttrs"}
[:type [:= :bool]]
[:id ::sm/uuid]
[:shapes [:vector {:min 1 :gen/max 10 :gen/min 1} ::sm/uuid]]
;; FIXME: improve this schema
[:bool-type :keyword]
;; FIXME: improve this schema
[:bool-content
[:vector {:gen/max 2}
[:map
[:command :keyword]
[:relative :boolean]
[:params [:map-of {:gen/max 5} :keyword ::sm/safe-number]]]]]])
(sm/def! ::rect-attrs
[:map {:title "RectAttrs"}
[:type [:= :rect]]
[:id ::sm/uuid]])
(sm/def! ::circle-attrs
[:map {:title "CircleAttrs"}
[:type [:= :circle]]
[:id ::sm/uuid]])
(sm/def! ::svg-raw-attrs
[:map {:title "SvgRawAttrs"}
[:type [:= :svg-raw]]
[:id ::sm/uuid]])
(sm/def! ::image-attrs
[:map {:title "ImageAttrs"}
[:type [:= :image]]
[:id ::sm/uuid]
[:metadata
[:map
[:width :int]
[:height :int]
[:mtype :string]
[:id ::sm/uuid]]]])
(sm/def! ::path-attrs
[:map {:title "PathAttrs"}
[:type [:= :path]]
[:id ::sm/uuid]
[:content
[:vector
[:map
[:command :keyword]
[:params {:optional true} [:maybe :map]]]]]])
(sm/def! ::text-attrs
[:map {:title "TextAttrs"}
[:id ::sm/uuid]
[:type [:= :text]]
[:content ::ctsx/content]])
(sm/def! ::shape
[:multi {:dispatch :type :title "Shape"}
[:group
[:merge {:title "GroupShape"}
::shape-attrs
::group-attrs]]
[:frame
[:merge {:title "FrameShape"}
::shape-attrs
::frame-attrs]]
[:bool
[:merge {:title "BoolShape"}
::shape-attrs
::bool-attrs]]
[:rect
[:merge {:title "RectShape"}
::shape-attrs
::rect-attrs]]
[:circle
[:merge {:title "CircleShape"}
::shape-attrs
::circle-attrs]]
[:image
[:merge {:title "ImageShape"}
::shape-attrs
::image-attrs]]
[:svg-raw
[:merge {:title "SvgRawShape"}
::shape-attrs
::svg-raw-attrs]]
[:path
[:merge {:title "PathShape"}
::shape-attrs
::path-attrs]]
[:text
[:merge {:title "TextShape"}
::shape-attrs
::text-attrs]]
])
(def shape?
(sm/pred-fn ::shape))
;; --- Initialization
@ -311,11 +326,6 @@
:fills [{:fill-color clr/white
:fill-opacity 1}]
:strokes []
:stroke-style :none
:stroke-alignment :center
:stroke-width 0
:stroke-color clr/black
:stroke-opacity 0
:rx 0
:ry 0}

15
common/src/app/common/types/shape/blur.cljc
View file

@ -6,9 +6,14 @@
(ns app.common.types.shape.blur
(:require
[app.common.schema :as sm]
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SPEC
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::id uuid?)
(s/def ::type #{:layer-blur})
(s/def ::value ::us/safe-number)
@ -17,3 +22,13 @@
(s/def ::blur
(s/keys :req-un [::id ::type ::value ::hidden]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SCHEMA
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(sm/def! ::blur
[:map {:title "Blur"}
[:id ::sm/uuid]
[:type [:= :layer-blur]]
[:value ::sm/safe-number]
[:hidden :boolean]])

17
common/src/app/common/types/shape/export.cljc
View file

@ -6,15 +6,10 @@
(ns app.common.types.shape.export
(:require
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
(s/def ::suffix ::us/string)
(s/def ::scale ::us/safe-number)
(s/def ::type ::us/keyword)
(s/def ::export
(s/keys :req-un [::type
::suffix
::scale]))
[app.common.schema :as sm]))
(sm/def! ::export
[:map {:title "ShapeExport"}
[:type :keyword]
[:scale ::sm/safe-number]
[:suffix :string]])

537
common/src/app/common/types/shape/interactions.cljc
View file

@ -7,11 +7,11 @@
(ns app.common.types.shape.interactions
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.bounds :as gsb]
[app.common.pages.helpers :as cph]
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
[app.common.schema :as sm]))
;; WARNING: options are not deleted when changing event or action type, so it can be
;; restored if the user changes it back later.
@ -22,9 +22,11 @@
;; So make sure to use has-delay/has-destination... functions, or similar,
;; before reading them.
;; -- Options depending on event type
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SCHEMA
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::event-type
(def event-types
#{:click
:mouse-press
:mouse-over
@ -32,65 +34,15 @@
:mouse-leave
:after-delay})
(s/def ::delay ::us/safe-integer)
(defmulti event-opts-spec :event-type)
(defmethod event-opts-spec :after-delay [_]
(s/keys :req-un [::delay]))
(defmethod event-opts-spec :default [_]
(s/keys :req-un []))
(s/def ::event-opts
(s/multi-spec event-opts-spec :event-type))
;; -- Animation options
(s/def ::animation-type #{:dissolve :slide :push})
(s/def ::duration ::us/safe-integer)
(s/def ::way #{:in :out})
(s/def ::direction #{:right :left :up :down})
(s/def ::offset-effect ::us/boolean)
(s/def ::easing
#{:linear
:ease
:ease-in
:ease-out
:ease-in-out})
(defmulti animation-spec :animation-type)
(defmethod animation-spec :dissolve [_]
(s/keys :req-un [::duration
::easing]))
(defmethod animation-spec :slide [_]
(s/keys :req-un [::duration
::easing
::way
::direction
::offset-effect]))
(defmethod animation-spec :push [_]
(s/keys :req-un [::duration
::easing
::direction]))
(s/def ::animation
(s/multi-spec animation-spec :animation-type))
;; -- Options depending on action type
(s/def ::action-type
(def action-types
#{:navigate
:open-overlay
:toggle-overlay
:close-overlay
:prev-screen
:open-url})
(s/def ::position-relative-to (s/nilable ::us/uuid))
(s/def ::overlay-pos-type
(def overlay-positioning-types
#{:manual
:center
:top-left
@ -100,65 +52,101 @@
:bottom-right
:bottom-center})
(s/def ::destination (s/nilable ::us/uuid))
(s/def ::overlay-position ::gpt/point)
(s/def ::url ::us/string)
(s/def ::close-click-outside ::us/boolean)
(s/def ::background-overlay ::us/boolean)
(s/def ::preserve-scroll ::us/boolean)
(def easing-types
#{:linear
:ease
:ease-in
:ease-out
:ease-in-out})
(defmulti action-opts-spec :action-type)
(def direction-types
#{:right
:left
:up
:down})
(defmethod action-opts-spec :navigate [_]
(s/keys :opt-un [::destination
::preserve-scroll
::animation]))
(def way-types
#{:in :out})
(defmethod action-opts-spec :open-overlay [_]
(s/keys :req-un [::overlay-position
::overlay-pos-type]
:opt-un [::destination
::close-click-outside
::background-overlay
::animation
::position-relative-to]))
(def animation-types
#{:dissolve :slide :push})
(defmethod action-opts-spec :toggle-overlay [_]
(s/keys :req-un [::overlay-position
::overlay-pos-type]
:opt-un [::destination
::close-click-outside
::background-overlay
::animation
::position-relative-to]))
(sm/def! ::animation
[:multi {:dispatch :animation-type :title "Animation"}
[:dissolve
[:map {:title "AnimationDisolve"}
[:animation-type [:= :dissolve]]
[:duration ::sm/safe-int]
[:easing [::sm/one-of easing-types]]]]
[:slide
[:map {:title "AnimationSlide"}
[:animation-type [:= :slide]]
[:duration ::sm/safe-int]
[:easing [::sm/one-of easing-types]]
[:way [::sm/one-of way-types]]
[:direction [::sm/one-of direction-types]]
[:offset-effect :boolean]]]
[:push
[:map {:title "AnimationPush"}
[:animation-type [:= :push]]
[:duration ::sm/safe-int]
[:easing [::sm/one-of easing-types]]
[:direction [::sm/one-of direction-types]]]]])
(defmethod action-opts-spec :close-overlay [_]
(s/keys :opt-un [::destination
::animation
::position-relative-to]))
(def animation?
(sm/pred-fn ::animation))
(defmethod action-opts-spec :prev-screen [_]
(s/keys :req-un []))
(sm/def! ::interaction
[:multi {:dispatch :action-type}
[:navigate
[:map
[:action-type [:= :navigate]]
[:event-type [::sm/one-of event-types]]
[:destination {:optional true} [:maybe ::sm/uuid]]
[:preserve-scroll {:optional true} :boolean]
[:animation {:optional true} ::animation]]]
[:open-overlay
[:map
[:action-type [:= :open-overlay]]
[:event-type [::sm/one-of event-types]]
[:overlay-position ::gpt/point]
[:overlay-pos-type [::sm/one-of overlay-positioning-types]]
[:destination {:optional true} [:maybe ::sm/uuid]]
[:close-click-outside {:optional true} :boolean]
[:background-overlay {:optional true} :boolean]
[:animation {:optional true} ::animation]
[:position-relative-to {:optional true} [:maybe ::sm/uuid]]]]
[:toggle-overlay
[:map
[:action-type [:= :toggle-overlay]]
[:event-type [::sm/one-of event-types]]
[:overlay-position ::gpt/point]
[:overlay-pos-type [::sm/one-of overlay-positioning-types]]
[:destination {:optional true} [:maybe ::sm/uuid]]
[:close-click-outside {:optional true} :boolean]
[:background-overlay {:optional true} :boolean]
[:animation {:optional true} ::animation]
[:position-relative-to {:optional true} [:maybe ::sm/uuid]]]]
[:close-overlay
[:map
[:action-type [:= :close-overlay]]
[:event-type [::sm/one-of event-types]]
[:destination {:optional true} [:maybe ::sm/uuid]]
[:animation {:optional true} ::animation]
[:position-relative-to {:optional true} [:maybe ::sm/uuid]]]]
[:prev-screen
[:map
[:action-type [:= :prev-screen]]
[:event-type [::sm/one-of event-types]]]]
[:open-url
[:map
[:action-type [:= :open-url]]
[:event-type [::sm/one-of event-types]]
[:url :string]]]])
(defmethod action-opts-spec :open-url [_]
(s/keys :req-un [::url]))
(s/def ::action-opts
(s/multi-spec action-opts-spec :action-type))
;; -- Interaction
(s/def ::classifier
(s/keys :req-un [::event-type
::action-type]))
(s/def ::interaction
(s/merge ::classifier
::event-opts
::action-opts))
(s/def ::interactions
(s/coll-of ::interaction :kind vector?))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def default-interaction
{:event-type :click
@ -169,17 +157,33 @@
(def default-delay 600)
;; -- Helpers for interaction
(def interaction?
(sm/pred-fn ::interaction))
;; (def destination?
;; (sm/pred-fn [:maybe ::sm/uuid]))
(declare calc-overlay-pos-initial)
(declare allowed-animation?)
(defn set-event-type
[interaction event-type shape]
(us/verify ::interaction interaction)
(us/verify ::event-type event-type)
(assert (or (not= event-type :after-delay)
(= (:type shape) :frame)))
(dm/assert!
"Should be an interraction map"
^boolean (interaction? interaction))
(dm/assert!
"Should be a valid event type"
(contains? event-types event-type))
(dm/assert!
"The `:after-delay` event type incompatible with frame shapes"
(or (not= event-type :after-delay)
(= (:type shape) :frame)))
(if (= (:event-type interaction) event-type)
interaction
(case event-type
@ -194,8 +198,15 @@
(defn set-action-type
[interaction action-type]
(us/verify ::interaction interaction)
(us/verify ::action-type action-type)
(dm/assert!
"Should be an interraction map"
(interaction? interaction))
(dm/assert!
"Should be a valid event type"
(contains? action-types action-type))
(let [new-interaction
(if (= (:action-type interaction) action-type)
interaction
@ -233,17 +244,33 @@
(-> new-interaction :animation :animation-type)))
(dissoc :animation-type :animation))))
;; FIXME: should be renamed to has-delay?
(defn has-delay
[interaction]
(= (:event-type interaction) :after-delay))
(defn set-delay
[interaction delay]
(us/verify ::interaction interaction)
(us/verify ::delay delay)
(assert (has-delay interaction))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected valid delay"
(sm/safe-int? delay))
(dm/assert!
"expected compatible interaction event type"
(has-delay interaction))
(assoc interaction :delay delay))
;; FIXME: rename to proper name, very confusing one because it does
;; not checks if interaction has distination, it checks if it can have
;; one.
(defn has-destination
[interaction]
(#{:navigate :open-overlay :toggle-overlay :close-overlay}
@ -256,9 +283,15 @@
(defn set-destination
[interaction destination]
(us/verify ::interaction interaction)
(us/verify ::destination destination)
(assert (has-destination interaction))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected compatible interaction event type"
(has-destination interaction))
(cond-> interaction
:always
(assoc :destination destination)
@ -274,9 +307,19 @@
(defn set-preserve-scroll
[interaction preserve-scroll]
(us/verify ::interaction interaction)
(us/verify ::us/boolean preserve-scroll)
(assert (has-preserve-scroll interaction))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected boolean for `preserve-scroll`"
(boolean? preserve-scroll))
(dm/assert!
"expected compatible interaction map with preserve-scroll"
(has-preserve-scroll interaction))
(assoc interaction :preserve-scroll preserve-scroll))
(defn has-url
@ -285,9 +328,19 @@
(defn set-url
[interaction url]
(us/verify ::interaction interaction)
(us/verify ::url url)
(assert (has-url interaction))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected a string for `url`"
(string? url))
(dm/assert!
"expected compatible interaction map with url param"
(has-url interaction))
(assoc interaction :url url))
(defn has-overlay-opts
@ -296,9 +349,19 @@
(defn set-overlay-pos-type
[interaction overlay-pos-type shape objects]
(us/verify ::interaction interaction)
(us/verify ::overlay-pos-type overlay-pos-type)
(assert (has-overlay-opts interaction))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected valid overlay positioning type"
(contains? overlay-positioning-types overlay-pos-type))
(dm/assert!
"expected compatible interaction map"
(has-overlay-opts interaction))
(assoc interaction
:overlay-pos-type overlay-pos-type
:overlay-position (calc-overlay-pos-initial (:destination interaction)
@ -307,9 +370,19 @@
overlay-pos-type)))
(defn toggle-overlay-pos-type
[interaction overlay-pos-type shape objects]
(us/verify ::interaction interaction)
(us/verify ::overlay-pos-type overlay-pos-type)
(assert (has-overlay-opts interaction))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected valid overlay positioning type"
(contains? overlay-positioning-types overlay-pos-type))
(dm/assert!
"expected compatible interaction map"
(has-overlay-opts interaction))
(let [new-pos-type (if (= (:overlay-pos-type interaction) overlay-pos-type)
:manual
overlay-pos-type)]
@ -321,32 +394,73 @@
new-pos-type))))
(defn set-overlay-position
[interaction overlay-position]
(us/verify ::interaction interaction)
(us/verify ::overlay-position overlay-position)
(assert (has-overlay-opts interaction))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected valid overlay position"
(gpt/point? overlay-position))
(dm/assert!
"expected compatible interaction map"
(has-overlay-opts interaction))
(assoc interaction
:overlay-pos-type :manual
:overlay-position overlay-position))
(defn set-close-click-outside
[interaction close-click-outside]
(us/verify ::interaction interaction)
(us/verify ::us/boolean close-click-outside)
(assert (has-overlay-opts interaction))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected boolean value for `close-click-outside`"
(boolean? close-click-outside))
(dm/assert!
"expected compatible interaction map"
(has-overlay-opts interaction))
(assoc interaction :close-click-outside close-click-outside))
(defn set-background-overlay
[interaction background-overlay]
(us/verify ::interaction interaction)
(us/verify ::us/boolean background-overlay)
(assert (has-overlay-opts interaction))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected boolean value for `background-overlay`"
(boolean? background-overlay))
(dm/assert!
"expected compatible interaction map"
(has-overlay-opts interaction))
(assoc interaction :background-overlay background-overlay))
(defn set-position-relative-to
[interaction position-relative-to]
(us/verify ::interaction interaction)
(us/verify ::position-relative-to position-relative-to)
(assert (has-overlay-opts interaction))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected valid uuid for `position-relative-to`"
(or (nil? position-relative-to)
(uuid? position-relative-to)))
(dm/assert!
"expected compatible interaction map"
(has-overlay-opts interaction))
(assoc interaction :position-relative-to position-relative-to))
(defn- calc-overlay-pos-initial
@ -363,16 +477,24 @@
(gpt/point 0 0)))
(defn calc-overlay-position
[interaction ;; interaction data
shape ;; Shape with the interaction
objects ;; the objects tree
relative-to-shape ;; the interaction position is realtive to this sape
base-frame ;; the base frame of the current interaction
dest-frame ;; the frame to display with this interaction
frame-offset] ;; if this interaction starts in a frame opened on another interaction, this is the position of that frame
[interaction ;; interaction data
shape ;; Shape with the interaction
objects ;; the objects tree
relative-to-shape ;; the interaction position is realtive to this
;; sape
base-frame ;; the base frame of the current interaction
dest-frame ;; the frame to display with this interaction
frame-offset] ;; if this interaction starts in a frame opened
;; on another interaction, this is the position
;; of that frame
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected compatible interaction map"
(has-overlay-opts interaction))
(us/verify ::interaction interaction)
(assert (has-overlay-opts interaction))
(let [
;; When the interactive item is inside a nested frame we need to add to the offset the position
;; of the parent-frame otherwise the position won't match
@ -455,10 +577,22 @@
(defn set-animation-type
[interaction animation-type]
(us/verify ::interaction interaction)
(us/verify (s/nilable ::animation-type) animation-type)
(assert (has-animation? interaction))
(assert (allowed-animation? (:action-type interaction) animation-type))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected valid value for `animation-type`"
(or (nil? animation-type)
(contains? animation-types animation-type)))
(dm/assert!
"expected interaction map compatible with animation"
(has-animation? interaction))
(dm/assert!
"expected allowed animation type"
(allowed-animation? (:action-type interaction) animation-type))
(if (= (-> interaction :animation :animation-type) animation-type)
interaction
@ -493,9 +627,19 @@
(defn set-duration
[interaction duration]
(us/verify ::interaction interaction)
(us/verify ::duration duration)
(assert (has-duration? interaction))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected valid duration"
(sm/safe-int? duration))
(dm/assert!
"expected compatible interaction map"
(has-duration? interaction))
(update interaction :animation assoc :duration duration))
(defn has-easing?
@ -504,9 +648,19 @@
(defn set-easing
[interaction easing]
(us/verify ::interaction interaction)
(us/verify ::easing easing)
(assert (has-easing? interaction))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected valid easing"
(contains? easing-types easing))
(dm/assert!
"expected compatible interaction map"
(has-easing? interaction))
(update interaction :animation assoc :easing easing))
(defn has-way?
@ -517,9 +671,19 @@
(defn set-way
[interaction way]
(us/verify ::interaction interaction)
(us/verify ::way way)
(assert (has-way? interaction))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected valid way"
(contains? way-types way))
(dm/assert!
"expected compatible interaction map"
(has-way? interaction))
(update interaction :animation assoc :way way))
(defn has-direction?
@ -528,14 +692,28 @@
(defn set-direction
[interaction direction]
(us/verify ::interaction interaction)
(us/verify ::direction direction)
(assert (has-direction? interaction))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected valid direction"
(contains? direction-types direction))
(dm/assert!
"expected compatible interaction map"
(has-direction? interaction))
(update interaction :animation assoc :direction direction))
(defn invert-direction
[animation]
(us/verify (s/nilable ::animation) animation)
(dm/assert!
"expected valid animation map"
(or (nil? animation)
(animation? animation)))
(case (:direction animation)
:right
(assoc animation :direction :left)
@ -545,6 +723,7 @@
(assoc animation :direction :down)
:down
(assoc animation :direction :up)
animation))
(defn has-offset-effect?
@ -555,9 +734,19 @@
(defn set-offset-effect
[interaction offset-effect]
(us/verify ::interaction interaction)
(us/verify ::offset-effect offset-effect)
(assert (has-offset-effect? interaction))
(dm/assert!
"expected valid interaction map"
(interaction? interaction))
(dm/assert!
"expected valid boolean for `offset-effect`"
(boolean? offset-effect))
(dm/assert!
"expected compatible interaction map"
(has-offset-effect? interaction))
(update interaction :animation assoc :offset-effect offset-effect))
(defn dest-to?

233
common/src/app/common/types/shape/layout.cljc
View file

@ -8,9 +8,10 @@
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[clojure.spec.alpha :as s]))
[app.common.schema :as sm]
[app.common.uuid :as uuid]))
;; FIXME: need proper schemas
;; :layout ;; :flex, :grid in the future
;; :layout-flex-dir ;; :row, :row-reverse, :column, :column-reverse
@ -40,114 +41,144 @@
;; :layout-item-absolute
;; :layout-item-z-index
(s/def ::layout #{:flex :grid})
(def layout-types
#{:flex :grid})
(s/def ::layout-flex-dir #{:row :reverse-row :row-reverse :column :reverse-column :column-reverse}) ;;TODO remove reverse-column and reverse-row after script
(s/def ::layout-grid-dir #{:row :column})
(s/def ::layout-gap-type #{:simple :multiple})
(s/def ::layout-gap ::us/safe-number)
(def flex-direction-types
#{:row :reverse-row :row-reverse :column :reverse-column :column-reverse}) ;;TODO remove reverse-column and reverse-row after script
(s/def ::layout-align-items #{:start :end :center :stretch})
(s/def ::layout-justify-items #{:start :end :center :stretch})
(s/def ::layout-align-content #{:start :end :center :space-between :space-around :space-evenly :stretch})
(s/def ::layout-justify-content #{:start :center :end :space-between :space-around :space-evenly})
(s/def ::layout-wrap-type #{:wrap :nowrap :no-wrap}) ;;TODO remove no-wrap after script
(s/def ::layout-padding-type #{:simple :multiple})
(def gap-types
#{:simple :multiple})
(s/def :grid/type #{:percent :flex :auto :fixed})
(s/def :grid/value (s/nilable ::us/safe-number))
(s/def ::grid-definition (s/keys :req-un [:grid/type]
:opt-un [:grid/value]))
(s/def ::layout-grid-rows (s/coll-of ::grid-definition :kind vector?))
(s/def ::layout-grid-columns (s/coll-of ::grid-definition :kind vector?))
(def wrap-types
#{:wrap :nowrap :no-wrap}) ;;TODO remove no-wrap after script
(s/def :grid-cell/id uuid?)
(s/def :grid-cell/area-name ::us/string)
(s/def :grid-cell/row-start ::us/safe-integer)
(s/def :grid-cell/row-span ::us/safe-integer)
(s/def :grid-cell/column-start ::us/safe-integer)
(s/def :grid-cell/column-span ::us/safe-integer)
(s/def :grid-cell/position #{:auto :manual :area})
(s/def :grid-cell/align-self #{:auto :start :end :center :stretch})
(s/def :grid-cell/justify-self #{:auto :start :end :center :stretch})
(s/def :grid-cell/shapes (s/coll-of uuid?))
(def padding-type
#{:simple :multiple})
(s/def ::grid-cell (s/keys :opt-un [:grid-cell/id
:grid-cell/area-name
:grid-cell/row-start
:grid-cell/row-span
:grid-cell/column-start
:grid-cell/column-span
:grid-cell/position ;; auto, manual, area
:grid-cell/align-self
:grid-cell/justify-self
:grid-cell/shapes]))
(s/def ::layout-grid-cells (s/map-of uuid? ::grid-cell))
(def justify-content-types
#{:start :center :end :space-between :space-around :space-evenly})
(s/def ::p1 ::us/safe-number)
(s/def ::p2 ::us/safe-number)
(s/def ::p3 ::us/safe-number)
(s/def ::p4 ::us/safe-number)
(def align-content-types
#{:start :end :center :space-between :space-around :space-evenly :stretch})
(s/def ::layout-padding
(s/keys :opt-un [::p1 ::p2 ::p3 ::p4]))
(def align-items-types
#{:start :end :center :stretch})
(s/def ::row-gap ::us/safe-number)
(s/def ::column-gap ::us/safe-number)
(def justify-items-types
#{:start :end :center :stretch})
(s/def ::layout-gap
(s/keys :opt-un [::row-gap ::column-gap]))
(sm/def! ::layout-attrs
[:map {:title "LayoutAttrs"}
[:layout {:optional true} [::sm/one-of layout-types]]
[:layout-flex-dir {:optional true} [::sm/one-of flex-direction-types]]
[:layout-gap {:optional true}
[:map
[:row-gap {:optional true} ::sm/safe-number]
[:column-gap {:optional true} ::sm/safe-number]]]
[:layout-gap-type {:optional true} [::sm/one-of gap-types]]
[:layout-wrap-type {:optional true} [::sm/one-of wrap-types]]
[:layout-padding-type {:optional true} [::sm/one-of padding-type]]
[:layout-padding {:optional true}
[:map
[:p1 ::sm/safe-number]
[:p2 ::sm/safe-number]
[:p3 ::sm/safe-number]
[:p4 ::sm/safe-number]]]
[:layout-justify-content {:optional true} [::sm/one-of justify-content-types]]
[:layout-justify-items {:optional true} [::sm/one-of justify-items-types]]
[:layout-align-content {:optional true} [::sm/one-of align-content-types]]
[:layout-align-items {:optional true} [::sm/one-of align-items-types]]])
(s/def ::layout-container-props
(s/keys :opt-un [::layout
::layout-flex-dir
::layout-gap
::layout-gap-type
::layout-wrap-type
::layout-padding-type
::layout-padding
::layout-justify-content
::layout-align-items
::layout-align-content
;; (s/def :grid/type #{:percent :flex :auto :fixed})
;; (s/def :grid/value (s/nilable ::us/safe-number))
;; (s/def ::grid-definition (s/keys :req-un [:grid/type]
;; :opt-un [:grid/value]))
;; (s/def ::layout-grid-rows (s/coll-of ::grid-definition :kind vector?))
;; (s/def ::layout-grid-columns (s/coll-of ::grid-definition :kind vector?))
;; grid
::layout-grid-dir
::layout-justify-items
::layout-grid-rows
::layout-grid-columns
::layout-grid-cells
]))
;; (s/def :grid-cell/id uuid?)
;; (s/def :grid-cell/area-name ::us/string)
;; (s/def :grid-cell/row-start ::us/safe-integer)
;; (s/def :grid-cell/row-span ::us/safe-integer)
;; (s/def :grid-cell/column-start ::us/safe-integer)
;; (s/def :grid-cell/column-span ::us/safe-integer)
;; (s/def :grid-cell/position #{:auto :manual :area})
;; (s/def :grid-cell/align-self #{:auto :start :end :center :stretch})
;; (s/def :grid-cell/justify-self #{:auto :start :end :center :stretch})
;; (s/def :grid-cell/shapes (s/coll-of uuid?))
(s/def ::m1 ::us/safe-number)
(s/def ::m2 ::us/safe-number)
(s/def ::m3 ::us/safe-number)
(s/def ::m4 ::us/safe-number)
;; (s/def ::grid-cell (s/keys :opt-un [:grid-cell/id
;; :grid-cell/area-name
;; :grid-cell/row-start
;; :grid-cell/row-span
;; :grid-cell/column-start
;; :grid-cell/column-span
;; :grid-cell/position ;; auto, manual, area
;; :grid-cell/align-self
;; :grid-cell/justify-self
;; :grid-cell/shapes]))
;; (s/def ::layout-grid-cells (s/map-of uuid? ::grid-cell))
(s/def ::layout-item-margin (s/keys :opt-un [::m1 ::m2 ::m3 ::m4]))
;; (s/def ::layout-container-props
;; (s/keys :opt-un [
;; ;; grid
;; ::layout-grid-dir
;; ::layout-justify-items
;; ::layout-grid-rows
;; ::layout-grid-columns
;; ::layout-grid-cells
;; ]))
(s/def ::layout-item-margin-type #{:simple :multiple})
(s/def ::layout-item-h-sizing #{:fill :fix :auto})
(s/def ::layout-item-v-sizing #{:fill :fix :auto})
(s/def ::layout-item-align-self #{:start :end :center :stretch})
(s/def ::layout-item-max-h ::us/safe-number)
(s/def ::layout-item-min-h ::us/safe-number)
(s/def ::layout-item-max-w ::us/safe-number)
(s/def ::layout-item-min-w ::us/safe-number)
(s/def ::layout-item-absolute boolean?)
(s/def ::layout-item-z-index ::us/safe-integer)
(s/def ::layout-child-props
(s/keys :opt-un [::layout-item-margin
::layout-item-margin-type
::layout-item-h-sizing
::layout-item-v-sizing
::layout-item-max-h
::layout-item-min-h
::layout-item-max-w
::layout-item-min-w
::layout-item-align-self
::layout-item-absolute
::layout-item-z-index]))
(def item-margin-types
#{:simple :multiple})
(def item-h-sizing-types
#{:fill :fix :auto})
(def item-v-sizing-types
#{:fill :fix :auto})
(def item-align-self-types
#{:start :end :center :stretch})
(sm/def! ::layout-child-attrs
[:map {:title "LayoutChildAttrs"}
[:layout-item-margin-type {:optional true} [::sm/one-of item-margin-types]]
[:layout-item-margin {:optional true}
[:map
[:m1 {:optional true} ::sm/safe-number]
[:m2 {:optional true} ::sm/safe-number]
[:m3 {:optional true} ::sm/safe-number]
[:m4 {:optional true} ::sm/safe-number]]]
[:layout-item-max-h {:optional true} ::sm/safe-number]
[:layout-item-min-h {:optional true} ::sm/safe-number]
[:layout-item-max-w {:optional true} ::sm/safe-number]
[:layout-item-min-w {:optional true} ::sm/safe-number]
[:layout-item-h-sizing {:optional true} [::sm/one-of item-h-sizing-types]]
[:layout-item-v-sizing {:optional true} [::sm/one-of item-v-sizing-types]]
[:layout-item-align-self {:optional true} [::sm/one-of item-align-self-types]]
[:layout-item-absolute {:optional true} :boolean]
[:layout-item-z-index {:optional true} ::sm/safe-number]])
(def schema:grid-definition
[:map {:title "LayoutGridDefinition"}
[:type [::sm/one-of #{:percent :flex :auto :fixed}]]
[:value {:optional true} [:maybe ::sm/safe-int]]])
(def grid-definition?
(sm/pred-fn schema:grid-definition))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SCHEMAS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def valid-layouts
#{:flex :grid})
(sm/def! ::layout
[::sm/one-of valid-layouts])
(defn flex-layout?
([objects id]
@ -536,7 +567,10 @@
;; Adding a track creates the cells. We should check the shapes that are not tracked (with default values) and assign to the correct tracked values
(defn add-grid-column
[parent value]
(us/assert ::grid-definition value)
(dm/assert!
"expected a valid grid definition for `value`"
(grid-definition? value))
(let [rows (:layout-grid-rows parent)
new-col-num (count (:layout-grid-columns parent))
@ -557,7 +591,10 @@
(defn add-grid-row
[parent value]
(us/assert ::grid-definition value)
(dm/assert!
"expected a valid grid definition for `value`"
(grid-definition? value))
(let [cols (:layout-grid-columns parent)
new-row-num (inc (count (:layout-grid-rows parent)))

20
common/src/app/common/types/shape/path.cljc
View file

@ -1,20 +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) KALEIDOS INC
(ns app.common.types.shape.path
(:require
[clojure.spec.alpha :as s]))
(s/def ::command keyword?)
(s/def ::params (s/nilable (s/map-of keyword? any?)))
(s/def ::command-item
(s/keys :req-un [::command]
:opt-un [::params]))
(s/def ::content
(s/coll-of ::command-item :kind vector?))

15
common/src/app/common/types/shape/radius.cljc
View file

@ -6,16 +6,7 @@
(ns app.common.types.shape.radius
(:require
[app.common.pages.common :refer [editable-attrs]]
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
(s/def ::rx ::us/safe-number)
(s/def ::ry ::us/safe-number)
(s/def ::r1 ::us/safe-number)
(s/def ::r2 ::us/safe-number)
(s/def ::r3 ::us/safe-number)
(s/def ::r4 ::us/safe-number)
[app.common.pages.common :refer [editable-attrs]]))
;; There are some shapes that admit border radius, as rectangles
;; frames and images. Those shapes may define the radius of the corners in two modes:
@ -27,8 +18,8 @@
;; A shape never will have both :rx and :r1 simultaneously
;; All operations take into account that the shape may not be a one of those
;; shapes that has border radius, and so it hasn't :rx nor :r1.
;; All operations take into account that the shape may not be a one of those
;; shapes that has border radius, and so it hasn't :rx nor :r1.
;; In this case operations must leave shape untouched.
(defn has-radius?

58
common/src/app/common/types/shape/shadow.cljc
View file

@ -6,44 +6,26 @@
(ns app.common.types.shape.shadow
(:require
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.types.color :as ctc]
[app.common.types.shape.shadow.color :as-alias shadow-color]
[clojure.spec.alpha :as s]))
[app.common.types.shape.shadow.color :as-alias shadow-color]))
;;; SHADOW EFFECT
(s/def ::id (s/nilable uuid?))
(s/def ::style #{:drop-shadow :inner-shadow})
(s/def ::offset-x ::us/safe-number)
(s/def ::offset-y ::us/safe-number)
(s/def ::blur ::us/safe-number)
(s/def ::spread ::us/safe-number)
(s/def ::hidden boolean?)
(s/def ::color string?)
(s/def ::opacity ::us/safe-number)
(s/def ::gradient (s/nilable ::ctc/gradient))
(s/def ::file-id (s/nilable uuid?))
(s/def ::ref-id (s/nilable uuid?))
(s/def ::shadow-color/color
(s/keys :opt-un [::color
::opacity
::gradient
::file-id
::id]))
(s/def ::shadow-props
(s/keys :req-un [::id
::style
::shadow-color/color
::offset-x
::offset-y
::blur
::spread
::hidden]))
(s/def ::shadow
(s/coll-of ::shadow-props :kind vector?))
(def styles #{:drop-shadow :inner-shadow})
(sm/def! ::shadow
[:map {:title "Shadow"}
[:id [:maybe ::sm/uuid]]
[:style [::sm/one-of styles]]
[:offset-x ::sm/safe-number]
[:offset-y ::sm/safe-number]
[:blur ::sm/safe-number]
[:spread ::sm/safe-number]
[:hidden :boolean]
;;FIXME: reuse color?
[:color
[:map
[:color {:optional true} :string]
[:opacity {:optional true} ::sm/safe-number]
[:gradient {:optional true} [:maybe ::ctc/gradient]]
[:file-id {:optional true} [:maybe ::sm/uuid]]
[:id {:optional true} [:maybe ::sm/uuid]]]]])

121
common/src/app/common/types/shape/text.cljc
View file

@ -6,68 +6,73 @@
(ns app.common.types.shape.text
(:require
[app.common.spec :as us]
[app.common.types.color :as ctc]
[app.common.types.shape.text.position-data :as-alias position-data]
[clojure.spec.alpha :as s]))
[app.common.schema :as sm]
[app.common.types.shape :as-alias shape]
[app.common.types.shape.text.position-data :as-alias position-data]))
(s/def ::type #{"root" "paragraph-set" "paragraph"})
(s/def ::text string?)
(s/def ::key string?)
(s/def ::fill-color string?)
(s/def ::fill-opacity ::us/safe-number)
(s/def ::fill-color-gradient (s/nilable ::ctc/gradient))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SCHEMA
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::content
(s/nilable
(s/or :text-container
(s/keys :req-un [::type]
:opt-un [::key
::children])
:text-content
(s/keys :req-un [::text]))))
(def node-types #{"root" "paragraph-set" "paragraph"})
(s/def ::children
(s/coll-of ::content
:kind vector?
:min-count 1))
(sm/def! ::content
[:map
[:type [:= "root"]]
[:key {:optional true} :string]
[:children
[:vector {:min 1 :gen/max 2 :gen/min 1}
[:map
[:type [:= "paragraph-set"]]
[:key {:optional true} :string]
[:children
[:vector {:min 1 :gen/max 2 :gen/min 1}
[:map
[:type [:= "paragraph"]]
[:key {:optional true} :string]
[:fills {:optional true}
[:vector {:gen/max 2} ::shape/fill]]
[:font-family {:optional true} :string]
[:font-size {:optional true} :string]
[:font-style {:optional true} :string]
[:font-weight {:optional true} :string]
[:direction {:optional true} :string]
[:text-decoration {:optional true} :string]
[:text-transform {:optional true} :string]
[:typography-ref-id {:optional true} [:maybe ::sm/uuid]]
[:typography-ref-file {:optional true} [:maybe ::sm/uuid]]
[:children
[:vector {:min 1 :gen/max 2 :gen/min 1}
[:map
[:text :string]
[:key {:optional true} :string]
[:fills [:vector {:gen/max 2} ::shape/fill]]
[:font-family {:optional true} :string]
[:font-size {:optional true} :string]
[:font-style {:optional true} :string]
[:font-weight {:optional true} :string]
[:direction {:optional true} :string]
[:text-decoration {:optional true} :string]
[:text-transform {:optional true} :string]
[:typography-ref-id {:optional true} [:maybe ::sm/uuid]]
[:typography-ref-file {:optional true} [:maybe ::sm/uuid]]]]]]]]]]]])
(s/def ::position-data
(s/coll-of ::position-data-element
:kind vector?
:min-count 1))
(s/def ::position-data-element
(s/keys :req-un [::position-data/x
::position-data/y
::position-data/width
::position-data/height]
:opt-un [::position-data/fill-color
::position-data/fill-opacity
::position-data/font-family
::position-data/font-size
::position-data/font-style
::position-data/font-weight
::position-data/rtl
::position-data/text
::position-data/text-decoration
::position-data/text-transform]))
(s/def ::position-data/x ::us/safe-number)
(s/def ::position-data/y ::us/safe-number)
(s/def ::position-data/width ::us/safe-number)
(s/def ::position-data/height ::us/safe-number)
(s/def ::position-data/fill-color ::fill-color)
(s/def ::position-data/fill-opacity ::fill-opacity)
(s/def ::position-data/fill-color-gradient ::fill-color-gradient)
(s/def ::position-data/font-family string?)
(s/def ::position-data/font-size string?)
(s/def ::position-data/font-style string?)
(s/def ::position-data/font-weight string?)
(s/def ::position-data/rtl boolean?)
(s/def ::position-data/text string?)
(s/def ::position-data/text-decoration string?)
(s/def ::position-data/text-transform string?)
(sm/def! ::position-data
[:vector {:min 1 :gen/max 2}
[:map
[:x ::sm/safe-number]
[:y ::sm/safe-number]
[:width ::sm/safe-number]
[:height ::sm/safe-number]
[:fills [:vector {:gen/max 2} ::shape/fill]]
[:font-family {:optional true} :string]
[:font-size {:optional true} :string]
[:font-style {:optional true} :string]
[:font-weight {:optional true} :string]
[:rtl {:optional true} :boolean]
[:text {:optional true} :string]
[:text-decoration {:optional true} :string]
[:text-transform {:optional true} :string]]])

9
common/src/app/common/types/shape_tree.cljc
View file

@ -12,14 +12,9 @@
[app.common.geom.shapes :as gsh]
[app.common.math :as mth]
[app.common.pages.helpers :as cph]
[app.common.spec :as us]
[app.common.types.component :as ctk]
[app.common.types.shape :as cts]
[app.common.types.shape.layout :as ctl]
[app.common.uuid :as uuid]
[clojure.spec.alpha :as s]))
(s/def ::objects (s/map-of uuid? ::cts/shape))
[app.common.uuid :as uuid]))
(defn add-shape
"Insert a shape in the tree, at the given index below the given parent or frame.
@ -367,7 +362,7 @@
(let [child-id (first child-ids)
child (get objects child-id)
_ (us/assert! ::us/some child)
_ (dm/assert! (some? child))
[new-child new-child-objects updated-child-objects]
(clone-object child new-id objects update-new-object update-original-object)]

57
common/src/app/common/types/typography.cljc
View file

@ -6,38 +6,35 @@
(ns app.common.types.typography
(:require
[app.common.spec :as us]
[app.common.text :as txt]
[clojure.spec.alpha :as s]))
[app.common.schema :as sm]
[app.common.text :as txt]))
(s/def ::id uuid?)
(s/def ::name string?)
(s/def ::path (s/nilable string?))
(s/def ::font-id string?)
(s/def ::font-family string?)
(s/def ::font-variant-id string?)
(s/def ::font-size string?)
(s/def ::font-weight string?)
(s/def ::font-style string?)
(s/def ::line-height string?)
(s/def ::letter-spacing string?)
(s/def ::text-transform string?)
(s/def ::modified-at ::us/inst)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SCHEMA
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::typography
(s/keys :req-un [::id
::name
::font-id
::font-family
::font-variant-id
::font-size
::font-weight
::font-style
::line-height
::letter-spacing
::text-transform]
:opt-un [::path
::modified-at]))
(sm/def! ::typography
[:map {:title "Typography"}
[:id ::sm/uuid]
[:name :string]
[:font-id :string]
[:font-family :string]
[:font-variant-id :string]
[:font-size :string]
[:font-weight :string]
[:font-style :string]
[:line-height :string]
[:letter-spacing :string]
[:text-transform :string]
[:modified-at {:optional true} ::sm/inst]
[:path {:optional true} [:maybe :string]]])
(def typography?
(sm/pred-fn ::typography))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn uses-library-typographies?
"Check if the shape uses any typography in the given library."

1
common/test/common_tests/types_file_test.cljc
View file

@ -195,6 +195,7 @@
typographies (ctyl/typographies-seq (ctf/file-data absorbed-file))
page (ctpl/get-page (ctf/file-data absorbed-file) file-page-id)
shape1 (ctn/get-shape page (thf/id :shape1))
text-node (d/seek #(some? (:text %)) (txt/node-seq (:content shape1)))]

59
common/test/common_tests/types_test.cljc
View file

@ -6,54 +6,27 @@
(ns common-tests.types-test
(:require
[clojure.spec.alpha :as s]
[clojure.test :as t]
[clojure.test.check.clojure-test :refer [defspec]]
[clojure.test.check.generators :as gen]
[clojure.test.check.properties :as props]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.schema.generators :as sg]
[app.common.transit :as transit]
[app.common.types.shape :as cts]
[app.common.types.page :as ctp]
[app.common.types.file :as ctf]))
(defspec transit-encode-decode-with-shape 10
(props/for-all
[fdata (s/gen ::cts/shape)]
(let [res (-> fdata transit/encode-str transit/decode-str)]
(t/is (= res fdata)))))
(t/deftest transit-encode-decode-with-shape
(sg/check!
(sg/for [fdata (sg/generator ::cts/shape)]
(let [res (-> fdata transit/encode-str transit/decode-str)]
(t/is (= res fdata))))
{:num 18 :seed 1683548002439}))
(defspec types-shape-spec 5
(props/for-all
[fdata (s/gen ::cts/shape)]
(t/is (us/valid? ::cts/shape fdata))))
(t/deftest types-shape-spec
(sg/check!
(sg/for [fdata (sg/generator ::cts/shape)]
(t/is (sm/validate ::cts/shape fdata)))))
(defspec types-page-spec 5
(props/for-all
[fdata (s/gen ::ctp/page)]
(t/is (us/valid? ::ctp/page fdata))))
(defspec types-file-colors-spec 10
(props/for-all
[fdata (s/gen ::ctf/colors)]
(t/is (us/valid? ::ctf/colors fdata))))
(defspec types-file-recent-colors-spec 10
(props/for-all
[fdata (s/gen ::ctf/recent-colors)]
(t/is (us/valid? ::ctf/recent-colors fdata))))
(defspec types-file-typographies-spec 10
(props/for-all
[fdata (s/gen ::ctf/typographies)]
(t/is (us/valid? ::ctf/typographies fdata))))
(defspec types-file-media-spec 10
(props/for-all
[fdata (s/gen ::ctf/media)]
(t/is (us/valid? ::ctf/media fdata))))
(defspec types-file-components-spec 1
(props/for-all
[fdata (s/gen ::ctf/components)]
(t/is (us/valid? ::ctf/components fdata))))
(t/deftest types-page-spec
(-> (sg/for [fdata (sg/generator ::ctp/page)]
(t/is (sm/validate ::ctp/page fdata)))
(sg/check! {:num 30})))

21
common/test/common_tests/uuid_test.cljc
View file

@ -6,16 +6,13 @@
(ns common-tests.uuid-test
(:require
[app.common.spec :as us]
[app.common.uuid :as uuid]
[clojure.spec.alpha :as s]
[clojure.test :as t]
[clojure.test.check.clojure-test :refer [defspec]]
[clojure.test.check.generators :as gen]
[clojure.test.check.properties :as props]))
[app.common.schema :as sm]
[app.common.schema.generators :as sg]
[clojure.test :as t]))
(defspec non-repeating-uuid-next-1 100
(props/for-all
[uuid1 (s/gen ::us/uuid)
uuid2 (s/gen ::us/uuid)]
(t/is (not= uuid1 uuid2))))
(t/deftest non-repeating-uuid-next-1-schema
(sg/check!
(sg/for [uuid1 (sg/generator ::sm/uuid)
uuid2 (sg/generator ::sm/uuid)]
(t/is (not= uuid1 uuid2)))
{:num 100}))

2
exporter/scripts/wait-and-start.sh
View file

@ -1,5 +1,7 @@
#!/usr/bin/env bash
export PENPOT_TENANT=dev
bb -i '(babashka.wait/wait-for-port "localhost" 9630)';
bb -i '(babashka.wait/wait-for-path "target/app.js")';
sleep 2;

14
frontend/src/app/config.cljs
View file

@ -6,23 +6,25 @@
(ns app.config
(:require
[app.common.data.macros :as dm]
[app.common.flags :as flags]
[app.common.spec :as us]
[app.common.uri :as u]
[app.common.version :as v]
[app.util.avatars :as avatars]
[app.util.dom :as dom]
[app.util.globals :refer [global location]]
[app.util.object :as obj]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]))
(set! *assert* js/goog.DEBUG)
;; --- Auxiliar Functions
(s/def ::platform #{:windows :linux :macos :other})
(s/def ::browser #{:chrome :firefox :safari :edge :other})
(def valid-browsers
#{:chrome :firefox :safari :edge :other})
(def valid-platforms
#{:windows :linux :macos :other})
(defn- parse-browser
[]
@ -114,11 +116,11 @@
;; --- Helper Functions
(defn ^boolean check-browser? [candidate]
(us/verify! ::browser candidate)
(dm/assert! (contains? valid-browsers candidate))
(= candidate @browser))
(defn ^boolean check-platform? [candidate]
(us/verify! ::platform candidate)
(dm/assert! (contains? valid-platforms candidate))
(= candidate @platform))
(defn resolve-profile-photo-url

141
frontend/src/app/main/data/comments.cljs
View file

@ -7,70 +7,55 @@
(ns app.main.data.comments
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.types.shape-tree :as ctst]
[app.common.uuid :as uuid]
[app.main.data.workspace.state-helpers :as wsh]
[app.main.repo :as rp]
[beicon.core :as rx]
[cljs.spec.alpha :as s]
[potok.core :as ptk]))
(s/def ::content ::us/string)
(s/def ::count-comments ::us/integer)
(s/def ::count-unread-comments ::us/integer)
(s/def ::created-at ::us/inst)
(s/def ::file-id ::us/uuid)
(s/def ::file-name ::us/string)
(s/def ::modified-at ::us/inst)
(s/def ::owner-id ::us/uuid)
(s/def ::page-id ::us/uuid)
(s/def ::page-name ::us/string)
(s/def ::participants (s/every ::us/uuid :kind set?))
(s/def ::position ::gpt/point)
(s/def ::project-id ::us/uuid)
(s/def ::seqn ::us/integer)
(s/def ::thread-id ::us/uuid)
(def schema:comment-thread
[:map {:title "CommentThread"}
[:id ::sm/uuid]
[:page-id ::sm/uuid]
[:file-id ::sm/uuid]
[:project-id ::sm/uuid]
[:owner-id ::sm/uuid]
[:page-name :string]
[:file-name :string]
[:seqn :int]
[:content :string]
[:participants ::sm/set-of-uuid]
[:created-at ::sm/inst]
[:modified-at ::sm/inst]
[:position ::gpt/point]
[:count-unread-comments {:optional true} :int]
[:count-comments {:optional true} :int]])
(s/def ::comment-thread
(s/keys :req-un [::us/id
::page-id
::file-id
::project-id
::page-name
::file-name
::seqn
::content
::participants
::created-at
::modified-at
::owner-id
::position]
:opt-un [::count-unread-comments
::count-comments]))
(def schema:comment
[:map {:title "CommentThread"}
[:id ::sm/uuid]
[:thread-id ::sm/uuid]
[:owner-id ::sm/uuid]
[:created-at ::sm/inst]
[:modified-at ::sm/inst]
[:content :string]])
(s/def ::comment
(s/keys :req-un [::us/id
::thread-id
::owner-id
::created-at
::modified-at
::content]))
(def comment-thread?
(sm/pred-fn schema:comment-thread))
(def comment?
(sm/pred-fn schema:comment))
(declare create-draft-thread)
(declare retrieve-comment-threads)
(declare refresh-comment-thread)
(s/def ::create-thread-on-workspace-params
(s/keys :req-un [::page-id ::file-id ::position ::content]))
(s/def ::create-thread-on-viewer-params
(s/keys :req-un [::page-id ::file-id ::position ::content ::frame-id]))
(defn created-thread-on-workspace
[{:keys [id comment page-id] :as thread}]
(ptk/reify ::created-thread-on-workspace
ptk/UpdateEvent
(update [_ state]
@ -82,10 +67,17 @@
(update :workspace-drawing dissoc :comment)
(update-in [:comments id] assoc (:id comment) comment)))))
(def schema:create-thread-on-workspace
[:map
[:page-id ::sm/uuid]
[:file-id ::sm/uuid]
[:position ::gpt/point]
[:content :string]])
(defn create-thread-on-workspace
[params]
(us/assert ::create-thread-on-workspace-params params)
(dm/assert! (sm/valid? schema:create-thread-on-workspace params))
(ptk/reify ::create-thread-on-workspace
ptk/WatchEvent
(watch [_ state _]
@ -115,9 +107,17 @@
(update :workspace-drawing dissoc :comment)
(update-in [:comments id] assoc (:id comment) comment)))))
(def schema:create-thread-on-viewer
[:map
[:page-id ::sm/uuid]
[:file-id ::sm/uuid]
[:frame-id ::sm/uuid]
[:position ::gpt/point]
[:content :string]])
(defn create-thread-on-viewer
[params]
(us/assert! ::create-thread-on-viewer-params params)
(dm/assert! (sm/valid? schema:create-thread-on-viewer params))
(ptk/reify ::create-thread-on-viewer
ptk/WatchEvent
(watch [_ state _]
@ -135,7 +135,7 @@
(defn update-comment-thread-status
[{:keys [id] :as thread}]
(us/assert ::comment-thread thread)
(dm/assert! (comment-thread? thread))
(ptk/reify ::update-comment-thread-status
ptk/WatchEvent
(watch [_ state _]
@ -147,7 +147,7 @@
(defn update-comment-thread
[{:keys [id is-resolved] :as thread}]
(us/assert ::comment-thread thread)
(dm/assert! (comment-thread? thread))
(ptk/reify ::update-comment-thread
IDeref
(-deref [_] {:is-resolved is-resolved})
@ -169,8 +169,9 @@
(defn add-comment
[thread content]
(us/assert ::comment-thread thread)
(us/assert ::us/string content)
(dm/assert! (comment-thread? thread))
(dm/assert! (string? content))
(letfn [(created [comment state]
(update-in state [:comments (:id thread)] assoc (:id comment) comment))]
(ptk/reify ::create-comment
@ -189,7 +190,7 @@
(defn update-comment
[{:keys [id content thread-id] :as comment}]
(us/assert ::comment comment)
(dm/assert! (comment? comment))
(ptk/reify ::update-comment
ptk/UpdateEvent
(update [_ state]
@ -204,7 +205,7 @@
(defn delete-comment-thread-on-workspace
[{:keys [id] :as thread}]
(us/assert ::comment-thread thread)
(dm/assert! (comment-thread? thread))
(ptk/reify ::delete-comment-thread-on-workspace
ptk/UpdateEvent
(update [_ state]
@ -222,7 +223,7 @@
(defn delete-comment-thread-on-viewer
[{:keys [id] :as thread}]
(us/assert ::comment-thread thread)
(dm/assert! (comment-thread? thread))
(ptk/reify ::delete-comment-thread-on-viewer
ptk/UpdateEvent
(update [_ state]
@ -241,7 +242,7 @@
(defn delete-comment
[{:keys [id thread-id] :as comment}]
(us/assert ::comment comment)
(dm/assert! (comment? comment))
(ptk/reify ::delete-comment
ptk/UpdateEvent
(update [_ state]
@ -256,7 +257,7 @@
(defn refresh-comment-thread
[{:keys [id file-id] :as thread}]
(us/assert ::comment-thread thread)
(dm/assert! (comment-thread? thread))
(letfn [(fetched [thread state]
(assoc-in state [:comment-threads id] thread))]
(ptk/reify ::refresh-comment-thread
@ -269,7 +270,7 @@
(defn retrieve-comment-threads
[file-id]
(us/assert ::us/uuid file-id)
(dm/assert! (uuid? file-id))
(letfn [(set-comment-threds [state comment-thread]
(let [path [:workspace-data :pages-index (:page-id comment-thread) :options :comment-threads-position (:id comment-thread)]
thread-position (get-in state path)]
@ -296,7 +297,7 @@
(defn retrieve-comments
[thread-id]
(us/assert ::us/uuid thread-id)
(dm/assert! (uuid? thread-id))
(letfn [(fetched [comments state]
(update state :comments assoc thread-id (d/index-by :id comments)))]
(ptk/reify ::retrieve-comments
@ -310,7 +311,7 @@
(defn retrieve-unread-comment-threads
"A event used mainly in dashboard for retrieve all unread threads of a team."
[team-id]
(us/assert ::us/uuid team-id)
(dm/assert! (uuid? team-id))
(ptk/reify ::retrieve-unread-comment-threads
ptk/WatchEvent
(watch [_ _ _]
@ -326,7 +327,7 @@
(defn open-thread
[{:keys [id] :as thread}]
(us/assert ::comment-thread thread)
(dm/assert! (comment-thread? thread))
(ptk/reify ::open-comment-thread
ptk/UpdateEvent
(update [_ state]
@ -367,12 +368,15 @@
(update [_ state]
(update state :comments-local merge params))))
(s/def ::create-draft-params
(s/keys :req-un [::page-id ::file-id ::position]))
(def schema:create-draft
[:map
[:page-id ::sm/uuid]
[:file-id ::sm/uuid]
[:position ::gpt/point]])
(defn create-draft
[params]
(us/assert ::create-draft-params params)
(dm/assert! (sm/valid? schema:create-draft params))
(ptk/reify ::create-draft
ptk/UpdateEvent
(update [_ state]
@ -441,7 +445,7 @@
(update-comment-thread-frame thread uuid/zero))
([thread frame-id]
(us/assert ::comment-thread thread)
(dm/assert! (comment-thread? thread))
(ptk/reify ::update-comment-thread-frame
ptk/UpdateEvent
(update [_ state]
@ -458,8 +462,7 @@
(defn detach-comment-thread
"Detach comment threads that are inside a frame when that frame is deleted"
[ids]
(us/assert! ::us/coll-of-uuid ids)
(dm/assert! (sm/coll-of-uuid? ids))
(ptk/reify ::detach-comment-thread
ptk/WatchEvent
(watch [_ state _]

139
frontend/src/app/main/data/dashboard.cljs
View file

@ -7,8 +7,10 @@
(ns app.main.data.dashboard
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.pages :as cp]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.uri :as u]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.main.data.events :as ev]
@ -23,41 +25,8 @@
[app.util.timers :as tm]
[app.util.webapi :as wapi]
[beicon.core :as rx]
[cljs.spec.alpha :as s]
[potok.core :as ptk]))
;; --- Specs
(s/def ::id ::us/uuid)
(s/def ::name string?)
(s/def ::team-id ::us/uuid)
(s/def ::profile-id ::us/uuid)
(s/def ::project-id ::us/uuid)
(s/def ::created-at ::us/inst)
(s/def ::modified-at ::us/inst)
(s/def ::is-pinned ::us/boolean)
(s/def ::team
(s/keys :req-un [::id
::name
::created-at
::modified-at]))
(s/def ::project
(s/keys :req-un [::id
::name
::team-id
::created-at
::modified-at
::is-pinned]))
(s/def ::file
(s/keys :req-un [::id
::name
::project-id]
:opt-un [::created-at
::modified-at]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Initialization
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -68,7 +37,7 @@
(defn initialize
[{:keys [id] :as params}]
(us/assert! ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::initialize
ptk/UpdateEvent
(update [_ state]
@ -199,13 +168,13 @@
(update [_ state]
(assoc state :dashboard-search-result result))))
(s/def ::search-term (s/nilable ::us/string))
(s/def ::search
(s/keys :req-un [::search-term ]))
(def schema:search-params
[:map {:closed true}
[:search-term [:maybe :string]]])
(defn search
[params]
(us/assert! ::search params)
(dm/assert! schema:search-params params)
(ptk/reify ::search
ptk/UpdateEvent
(update [_ state]
@ -240,7 +209,7 @@
(defn fetch-files
[{:keys [project-id] :as params}]
(us/assert! ::us/uuid project-id)
(dm/assert! (uuid? project-id))
(ptk/reify ::fetch-files
ptk/WatchEvent
(watch [_ _ _]
@ -351,7 +320,6 @@
(defn toggle-file-select
[{:keys [id project-id] :as file}]
(us/assert! ::file file)
(ptk/reify ::toggle-file-select
ptk/UpdateEvent
(update [_ state]
@ -381,7 +349,7 @@
(defn create-team
[{:keys [name] :as params}]
(us/assert! ::us/string name)
(dm/assert! (string? name))
(ptk/reify ::create-team
ptk/WatchEvent
(watch [_ _ _]
@ -397,7 +365,6 @@
(defn create-team-with-invitations
[{:keys [name emails role] :as params}]
(us/assert! ::us/string name)
(ptk/reify ::create-team-with-invitations
ptk/WatchEvent
(watch [_ _ _]
@ -416,7 +383,6 @@
(defn update-team
[{:keys [id name] :as params}]
(us/assert! ::team params)
(ptk/reify ::update-team
ptk/UpdateEvent
(update [_ state]
@ -429,7 +395,9 @@
(defn update-team-photo
[file]
(us/assert! ::di/blob file)
(dm/assert!
"expected a valid blob for `file` param"
(di/blob? file))
(ptk/reify ::update-team-photo
ptk/WatchEvent
(watch [_ state _]
@ -450,8 +418,8 @@
(defn update-team-member-role
[{:keys [role member-id] :as params}]
(us/assert! ::us/uuid member-id)
(us/assert! ::us/keyword role)
(dm/assert! (uuid? member-id))
(dm/assert! (keyword? role)) ; FIXME: validate proper role?
(ptk/reify ::update-team-member-role
ptk/WatchEvent
(watch [_ state _]
@ -464,7 +432,7 @@
(defn delete-team-member
[{:keys [member-id] :as params}]
(us/assert! ::us/uuid member-id)
(dm/assert! (uuid? member-id))
(ptk/reify ::delete-team-member
ptk/WatchEvent
(watch [_ state _]
@ -477,9 +445,9 @@
(defn leave-team
[{:keys [reassign-to] :as params}]
(us/assert!
:spec (s/nilable ::us/uuid)
:val reassign-to)
(dm/assert! (or (nil? reassign-to)
(uuid? reassign-to)))
(ptk/reify ::leave-team
ptk/WatchEvent
(watch [_ state _]
@ -496,9 +464,10 @@
(defn invite-team-members
[{:keys [emails role team-id resend?] :as params}]
(us/assert! ::us/set-of-valid-emails emails)
(us/assert! ::us/keyword role)
(us/assert! ::us/uuid team-id)
(dm/assert! (keyword? role))
(dm/assert! (uuid? team-id))
(dm/assert! (sm/set-of-emails? emails))
(ptk/reify ::invite-team-members
IDeref
(-deref [_] {:role role :team-id team-id :resend? resend?})
@ -516,14 +485,13 @@
(defn copy-invitation-link
[{:keys [email team-id] :as params}]
(us/assert! ::us/email email)
(us/assert! ::us/uuid team-id)
(dm/assert! (sm/email? email))
(dm/assert! (uuid? team-id))
(ptk/reify ::copy-invitation-link
IDeref
(-deref [_] {:email email :team-id team-id})
ptk/WatchEvent
(watch [_ state _]
(let [{:keys [on-success on-error]
@ -545,9 +513,10 @@
(defn update-team-invitation-role
[{:keys [email team-id role] :as params}]
(us/assert! ::us/email email)
(us/assert! ::us/uuid team-id)
(us/assert! ::us/keyword role)
(dm/assert! (sm/email? email))
(dm/assert! (uuid? team-id))
(dm/assert! (keyword? role)) ;; FIXME validate role
(ptk/reify ::update-team-invitation-role
IDeref
(-deref [_] {:role role})
@ -563,8 +532,8 @@
(defn delete-team-invitation
[{:keys [email team-id] :as params}]
(us/assert! ::us/email email)
(us/assert! ::us/uuid team-id)
(dm/assert! (sm/email? email))
(dm/assert! (uuid? team-id))
(ptk/reify ::delete-team-invitation
ptk/WatchEvent
(watch [_ _ _]
@ -577,7 +546,7 @@
(defn delete-team-webhook
[{:keys [id] :as params}]
(us/assert! ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::delete-team-webhook
ptk/WatchEvent
(watch [_ state _]
@ -590,17 +559,17 @@
(rx/tap on-success)
(rx/catch on-error))))))
(s/def ::mtype
(def valid-mtypes
#{"application/json"
"application/x-www-form-urlencoded"
"application/transit+json"})
(defn update-team-webhook
[{:keys [id uri mtype is-active] :as params}]
(us/assert! ::us/uuid id)
(us/assert! ::us/uri uri)
(us/assert! ::mtype mtype)
(us/assert! ::us/boolean is-active)
(dm/assert! (uuid? id))
(dm/assert! (contains? valid-mtypes mtype))
(dm/assert! (boolean? is-active))
(dm/assert! (u/uri? uri))
(ptk/reify ::update-team-webhook
ptk/WatchEvent
(watch [_ state _]
@ -615,9 +584,10 @@
(defn create-team-webhook
[{:keys [uri mtype is-active] :as params}]
(us/assert! ::us/uri uri)
(us/assert! ::mtype mtype)
(us/assert! ::us/boolean is-active)
(dm/assert! (contains? valid-mtypes mtype))
(dm/assert! (boolean? is-active))
(dm/assert! (u/uri? uri))
(ptk/reify ::create-team-webhook
ptk/WatchEvent
(watch [_ state _]
@ -636,7 +606,6 @@
(defn delete-team
[{:keys [id] :as params}]
(us/assert! ::team params)
(ptk/reify ::delete-team
ptk/WatchEvent
(watch [_ _ _]
@ -691,7 +660,7 @@
(defn duplicate-project
[{:keys [id name] :as params}]
(us/assert! ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::duplicate-project
ptk/WatchEvent
(watch [_ _ _]
@ -708,8 +677,8 @@
(defn move-project
[{:keys [id team-id] :as params}]
(us/assert! ::us/uuid id)
(us/assert! ::us/uuid team-id)
(dm/assert! (uuid? id))
(dm/assert! (uuid? team-id))
(ptk/reify ::move-project
IDeref
(-deref [_]
@ -727,7 +696,6 @@
(defn toggle-project-pin
[{:keys [id is-pinned] :as project}]
(us/assert! ::project project)
(ptk/reify ::toggle-project-pin
ptk/UpdateEvent
(update [_ state]
@ -744,7 +712,6 @@
(defn rename-project
[{:keys [id name] :as params}]
(us/assert! ::project params)
(ptk/reify ::rename-project
ptk/UpdateEvent
(update [_ state]
@ -762,7 +729,6 @@
(defn delete-project
[{:keys [id] :as params}]
(us/assert! ::project params)
(ptk/reify ::delete-project
ptk/UpdateEvent
(update [_ state]
@ -784,7 +750,6 @@
(defn delete-file
[{:keys [id project-id] :as params}]
(us/assert! ::file params)
(ptk/reify ::delete-file
ptk/UpdateEvent
(update [_ state]
@ -803,7 +768,6 @@
(defn rename-file
[{:keys [id name] :as params}]
(us/assert! ::file params)
(ptk/reify ::rename-file
IDeref
(-deref [_]
@ -826,7 +790,6 @@
(defn set-file-shared
[{:keys [id is-shared] :as params}]
(us/assert! ::file params)
(ptk/reify ::set-file-shared
IDeref
(-deref [_]
@ -853,7 +816,6 @@
(defn file-created
[{:keys [id project-id] :as file}]
(us/verify ::file file)
(ptk/reify ::file-created
IDeref
(-deref [_] {:file-id id
@ -868,7 +830,7 @@
(defn create-file
[{:keys [project-id] :as params}]
(us/assert! ::us/uuid project-id)
(dm/assert! (uuid? project-id))
(ptk/reify ::create-file
IDeref
@ -899,8 +861,8 @@
(defn duplicate-file
[{:keys [id name] :as params}]
(us/assert! ::us/uuid id)
(us/assert! ::name name)
(dm/assert! (uuid? id))
(dm/assert! (string? name))
(ptk/reify ::duplicate-file
ptk/WatchEvent
(watch [_ _ _]
@ -919,8 +881,8 @@
(defn move-files
[{:keys [ids project-id] :as params}]
(us/assert! ::us/set-of-uuid ids)
(us/assert! ::us/uuid project-id)
(dm/assert! ::sm/set-of-uuid ids)
(dm/assert! (uuid? project-id))
(ptk/reify ::move-files
IDeref
(-deref [_]
@ -947,7 +909,7 @@
;; --- EVENT: clone-template
(defn clone-template
[{:keys [template-id project-id] :as params}]
(us/assert! ::us/uuid project-id)
(dm/assert! (uuid? project-id))
(ptk/reify ::clone-template
IDeref
(-deref [_]
@ -969,7 +931,6 @@
(defn go-to-workspace
[{:keys [id project-id] :as file}]
(us/assert! ::file file)
(ptk/reify ::go-to-workspace
ptk/WatchEvent
(watch [_ _ _]

29
frontend/src/app/main/data/fonts.cljs
View file

@ -8,11 +8,11 @@
(:require
["opentype.js" :as ot]
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.logging :as log]
[app.common.media :as cm]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.main.data.messages :as dm]
[app.main.data.messages :as msg]
[app.main.fonts :as fonts]
[app.main.repo :as rp]
[app.main.store :as st]
@ -96,18 +96,17 @@
;; If the useTypoMetrics is not set, Firefox will also use metrics from the hhea table.
;; On Windows, all browsers use the usWin metrics, but respect the useTypoMetrics setting and if set will use the OS/2 values.
hhea-ascender (abs (-> font .-tables .-hhea .-ascender))
hhea-descender (abs (-> font .-tables .-hhea .-descender))
hhea-ascender (abs (-> ^js font .-tables .-hhea .-ascender))
hhea-descender (abs (-> ^js font .-tables .-hhea .-descender))
win-ascent (abs (-> font .-tables .-os2 .-usWinAscent))
win-descent (abs (-> font .-tables .-os2 .-usWinDescent))
win-ascent (abs (-> ^js font .-tables .-os2 .-usWinAscent))
win-descent (abs (-> ^js font .-tables .-os2 .-usWinDescent))
os2-ascent (abs (-> font .-tables .-os2 .-sTypoAscender))
os2-descent (abs (-> font .-tables .-os2 .-sTypoDescender))
os2-ascent (abs (-> ^js font .-tables .-os2 .-sTypoAscender))
os2-descent (abs (-> ^js font .-tables .-os2 .-sTypoDescender))
;; useTypoMetrics can be read from the 7th bit
f-selection (-> (-> font .-tables .-os2 .-fsSelection)
(bit-test 7))
f-selection (-> ^js font .-tables .-os2 .-fsSelection (bit-test 7))
height-warning? (or (not= hhea-ascender win-ascent)
(not= hhea-descender win-descent)
@ -183,7 +182,7 @@
#(when
(not-empty %)
(st/emit!
(dm/error
(msg/error
(if (> (count %) 1)
(tr "errors.bad-font-plural" (str/join ", " %))
(tr "errors.bad-font" (first %)))))))
@ -246,8 +245,8 @@
(defn update-font
[{:keys [id name] :as params}]
(us/assert ::us/uuid id)
(us/assert ::us/not-empty-string name)
(dm/assert! (uuid? id))
(dm/assert! (string? name))
(ptk/reify ::update-font
ptk/UpdateEvent
(update [_ state]
@ -270,7 +269,7 @@
(defn delete-font
"Delete all variants related to the provided `font-id`."
[font-id]
(us/assert ::us/uuid font-id)
(dm/assert! (uuid? font-id))
(ptk/reify ::delete-font
ptk/UpdateEvent
(update [_ state]
@ -286,7 +285,7 @@
(defn delete-font-variant
[id]
(us/assert ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::delete-font-variants
ptk/UpdateEvent
(update [_ state]

50
frontend/src/app/main/data/messages.cljs
View file

@ -7,9 +7,9 @@
(ns app.main.data.messages
(:require
[app.common.data :as d]
[app.common.spec :as us]
[app.common.data.macros :as dm]
[app.common.schema :as sm]
[beicon.core :as rx]
[cljs.spec.alpha :as s]
[potok.core :as ptk]))
(declare hide)
@ -18,32 +18,34 @@
(def default-animation-timeout 600)
(def default-timeout 5000)
(s/def ::type #{:success :error :info :warning})
(s/def ::position #{:fixed :floating :inline})
(s/def ::status #{:visible :hide})
(s/def ::controls #{:none :close :inline-actions :bottom-actions})
(def schema:message
[:map {:title "Message"}
[:type [::sm/one-of #{:success :error :info :warning}]]
[:status {:optional true}
[::sm/one-of #{:visible :hide}]]
[:position {:optional true}
[::sm/one-of #{:fixed :floating :inline}]]
[:controls {:optional true}
[::sm/one-of #{:none :close :inline-actions :bottom-actions}]]
[:tag {:optional true}
[:or :string :keyword]]
[:timeout {:optional true}
[:maybe :int]]
[:actions {:optional true}
[:vector
[:map
[:label :string]
[:callback ::sm/fn]]]]])
(s/def ::tag (s/or :str ::us/string :kw ::us/keyword))
(s/def ::label ::us/string)
(s/def ::callback fn?)
(s/def ::action (s/keys :req-un [::label ::callback]))
(s/def ::actions (s/every ::action :kind vector?))
(s/def ::timeout (s/nilable ::us/integer))
(s/def ::content ::us/string)
(s/def ::message
(s/keys :req-un [::type]
:opt-un [::status
::position
::controls
::tag
::timeout
::actions
::status]))
(def message?
(sm/pred-fn schema:message))
(defn show
[data]
(us/verify ::message data)
(dm/assert!
"expected valid message map"
(message? data))
(ptk/reify ::show
ptk/UpdateEvent
(update [_ state]

32
frontend/src/app/main/data/shortcuts.cljs
View file

@ -8,10 +8,10 @@
(:refer-clojure :exclude [meta reset!])
(:require
["./shortcuts_impl.js$default" :as mousetrap]
[app.common.data.macros :as dm]
[app.common.logging :as log]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.config :as cf]
[cljs.spec.alpha :as s]
[cuerdas.core :as str]
[potok.core :as ptk]))
@ -127,21 +127,16 @@
;; --- EVENT: push
(s/def ::tooltip ::us/string)
(s/def ::fn fn?)
(def schema:shortcuts
[:map-of
:keyword
[:map
[:command [:or :string [:vector :any]]]
[:fn {:optional true} fn?]
[:tooltip {:optional true} :string]]])
(s/def ::command
(s/or :str ::us/string
:vec vector?))
(s/def ::shortcut
(s/keys :req-un [::command]
:opt-un [::fn
::tooltip]))
(s/def ::shortcuts
(s/map-of ::us/keyword
::shortcut))
(def shortcuts?
(sm/pred-fn schema:shortcuts))
(defn- wrap-cb
[key cb]
@ -174,8 +169,9 @@
(defn push-shortcuts
[key shortcuts]
(us/assert ::us/keyword key)
(us/assert ::shortcuts shortcuts)
(dm/assert! (keyword? key))
(dm/assert! (shortcuts? shortcuts))
(ptk/reify ::push-shortcuts
ptk/UpdateEvent
(update [_ state]

97
frontend/src/app/main/data/users.cljs
View file

@ -7,7 +7,9 @@
(ns app.main.data.users
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.schema :as sm]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cf]
@ -19,36 +21,28 @@
[app.util.router :as rt]
[app.util.storage :refer [storage]]
[beicon.core :as rx]
[cljs.spec.alpha :as s]
[potok.core :as ptk]))
;; --- COMMON SPECS
;; --- SCHEMAS
(def schema:profile
[:map {:title "Profile"}
[:id ::sm/uuid]
[:created-at {:optional true} :any]
[:fullname {:optional true} :string]
[:email {:optional true} :string]
[:lang {:optional true} :string]
[:theme {:optional true} :string]])
(def profile?
(sm/pred-fn schema:profile))
;; --- HELPERS
(defn is-authenticated?
[{:keys [id]}]
(and (uuid? id) (not= id uuid/zero)))
(s/def ::id ::us/uuid)
(s/def ::fullname ::us/string)
(s/def ::email ::us/email)
(s/def ::password ::us/string)
(s/def ::lang (s/nilable ::us/string))
(s/def ::theme (s/nilable ::us/string))
(s/def ::created-at ::us/inst)
(s/def ::password-1 ::us/string)
(s/def ::password-2 ::us/string)
(s/def ::password-old (s/nilable ::us/string))
(s/def ::profile
(s/keys :req-un [::id]
:opt-un [::created-at
::fullname
::email
::lang
::theme]))
;; --- HELPERS
(defn get-current-team-id
[profile]
(let [team-id (::current-team-id @storage)]
@ -98,7 +92,6 @@
(defn profile-fetched
[{:keys [id] :as profile}]
(us/verify ::profile profile)
(ptk/reify ::profile-fetched
IDeref
(-deref [_] profile)
@ -174,16 +167,10 @@
(get-redirect-event))
(rx/observe-on :async)))))))
(s/def ::invitation-token ::us/not-empty-string)
(s/def ::login-params
(s/keys :req-un [::email ::password]
:opt-un [::invitation-token]))
(declare login-from-register)
(defn login
[{:keys [email password invitation-token] :as data}]
(us/verify ::login-params data)
(ptk/reify ::login
ptk/WatchEvent
(watch [_ _ stream]
@ -299,7 +286,7 @@
(defn update-profile
[data]
(us/assert ::profile data)
(dm/assert! (profile? data))
(ptk/reify ::update-profile
ptk/WatchEvent
(watch [_ _ stream]
@ -307,7 +294,6 @@
on-success (:on-success mdata identity)
on-error (:on-error mdata rx/throw)]
(->> (rp/cmd! :update-profile (dissoc data :props))
(rx/catch on-error)
(rx/mapcat
(fn [_]
(rx/merge
@ -316,14 +302,16 @@
(rx/take 1)
(rx/tap on-success)
(rx/ignore))
(rx/of (profile-fetched data))))))))))
(rx/of (profile-fetched data)))))
(rx/catch on-error))))))
;; --- Request Email Change
(defn request-email-change
[{:keys [email] :as data}]
(us/assert ::us/email email)
(dm/assert! ::us/email email)
(ptk/reify ::request-email-change
ptk/WatchEvent
(watch [_ _ _]
@ -345,14 +333,15 @@
;; --- Update Password (Form)
(s/def ::update-password
(s/keys :req-un [::password-1
::password-2
::password-old]))
(def schema:update-password
[:map {:closed true}
[:password-1 :string]
[:password-2 :string]
[:password-old :string]])
(defn update-password
[data]
(us/verify ::update-password data)
(dm/assert! (sm/valid? schema:update-password data))
(ptk/reify ::update-password
ptk/WatchEvent
(watch [_ _ _]
@ -412,7 +401,10 @@
(defn update-photo
[file]
(us/verify ::di/blob file)
(dm/assert!
"expected a valid blob for `file` param"
(di/blob? file))
(ptk/reify ::update-photo
ptk/WatchEvent
(watch [_ _ _]
@ -434,8 +426,8 @@
(rx/catch on-error))))))
(defn fetch-users
[{:keys [team-id] :as params}]
(us/assert ::us/uuid team-id)
[{:keys [team-id]}]
(dm/assert! (uuid? team-id))
(letfn [(fetched [users state]
(->> users
(d/index-by :id)
@ -447,8 +439,8 @@
(rx/map #(partial fetched %)))))))
(defn fetch-file-comments-users
[{:keys [team-id] :as params}]
(us/assert ::us/uuid team-id)
[{:keys [team-id]}]
(dm/assert! (uuid? team-id))
(letfn [(fetched [users state]
(->> users
(d/index-by :id)
@ -479,12 +471,14 @@
;; --- EVENT: request-profile-recovery
(s/def ::request-profile-recovery
(s/keys :req-un [::email]))
(def schema:request-profile-recovery
[:map {:closed true}
[:email ::sm/email]])
;; FIXME: check if we can use schema for proper filter
(defn request-profile-recovery
[data]
(us/verify ::request-profile-recovery data)
(dm/assert! (sm/valid? schema:request-profile-recovery data))
(ptk/reify ::request-profile-recovery
ptk/WatchEvent
(watch [_ _ _]
@ -498,13 +492,14 @@
;; --- EVENT: recover-profile (Password)
(s/def ::token string?)
(s/def ::recover-profile
(s/keys :req-un [::password ::token]))
(def schema:recover-profile
[:map {:closed true}
[:password :string]
[:token :string]])
(defn recover-profile
[data]
(us/verify ::recover-profile data)
(dm/assert! (sm/valid? ::recover-profile data))
(ptk/reify ::recover-profile
ptk/WatchEvent
(watch [_ _ _]

81
frontend/src/app/main/data/viewer.cljs
View file

@ -11,7 +11,7 @@
[app.common.files.features :as ffeat]
[app.common.geom.point :as gpt]
[app.common.pages.helpers :as cph]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.transit :as t]
[app.common.types.shape-tree :as ctt]
[app.common.types.shape.interactions :as ctsi]
@ -22,12 +22,8 @@
[app.util.globals :as ug]
[app.util.router :as rt]
[beicon.core :as rx]
[cljs.spec.alpha :as s]
[potok.core :as ptk]))
(s/def ::nilable-boolean (s/nilable ::us/boolean))
(s/def ::nilable-animation (s/nilable ::ctsi/animation))
;; --- Local State Initialization
(def ^:private
@ -50,19 +46,15 @@
(declare zoom-to-fill)
(declare zoom-to-fit)
(s/def ::file-id ::us/uuid)
(s/def ::index ::us/integer)
(s/def ::page-id (s/nilable ::us/uuid))
(s/def ::share-id (s/nilable ::us/uuid))
(s/def ::section ::us/string)
(s/def ::initialize-params
(s/keys :req-un [::file-id]
:opt-un [::share-id ::page-id]))
(def schema:initialize
[:map
[:file-id ::sm/uuid]
[:share-id {:optional true} [:maybe ::sm/uuid]]
[:page-id {:optional true} ::sm/uuid]])
(defn initialize
[{:keys [file-id share-id] :as params}]
(us/assert ::initialize-params params)
(dm/assert! (sm/valid? schema:initialize params))
(ptk/reify ::initialize
ptk/UpdateEvent
(update [_ state]
@ -77,7 +69,7 @@
ptk/WatchEvent
(watch [_ _ _]
(rx/of (fetch-bundle params)
(rx/of (fetch-bundle (d/without-nils params))
(fetch-comment-threads params)))
ptk/EffectEvent
@ -99,14 +91,15 @@
;; --- Data Fetching
(s/def ::fetch-bundle
(s/keys :req-un [::page-id ::file-id]
:opt-un [::share-id]))
(def schema:fetch-bundle
[:map
[:page-id ::sm/uuid]
[:file-id ::sm/uuid]
[:share-id {:optional true} ::sm/uuid]])
(defn- fetch-bundle
[{:keys [file-id share-id] :as params}]
(us/assert! ::fetch-bundle params)
(dm/assert! (sm/valid? schema:fetch-bundle params))
(ptk/reify ::fetch-bundle
ptk/WatchEvent
(watch [_ state _]
@ -227,7 +220,7 @@
(defn fetch-comments
[{:keys [thread-id]}]
(us/assert ::us/uuid thread-id)
(dm/assert! (uuid thread-id))
(letfn [(fetched [comments state]
(update state :comments assoc thread-id (d/index-by :id comments)))]
(ptk/reify ::retrieve-comments
@ -391,11 +384,14 @@
(dcm/close-thread)
(rt/nav :viewer pparams (assoc qparams :index 0)))))))
(s/def ::interactions-mode #{:hide :show :show-on-click})
(def valid-interaction-modes
#{:hide :show :show-on-click})
(defn set-interactions-mode
[mode]
(us/verify ::interactions-mode mode)
(dm/assert!
"expected valid interaction mode"
(contains? valid-interaction-modes mode))
(ptk/reify ::set-interactions-mode
ptk/UpdateEvent
(update [_ state]
@ -471,8 +467,9 @@
(go-to-frame frame-id nil))
([frame-id animation]
(us/assert! ::us/uuid frame-id)
(us/assert! ::nilable-animation animation)
(dm/assert! (uuid? frame-id))
(dm/assert! (or (nil? animation)
(ctsi/animation? animation)))
(ptk/reify ::go-to-frame
ptk/UpdateEvent
@ -563,12 +560,14 @@
(defn open-overlay
[frame-id position close-click-outside background-overlay animation]
(us/assert! ::us/uuid frame-id)
(us/assert! ::gpt/point position)
(us/assert! ::nilable-boolean close-click-outside)
(us/assert! ::nilable-boolean background-overlay)
(us/assert! ::nilable-animation animation)
(dm/assert! (uuid? frame-id))
(dm/assert! (gpt/point? position))
(dm/assert! (or (nil? close-click-outside)
(boolean? close-click-outside)))
(dm/assert! (or (nil? background-overlay)
(boolean? background-overlay)))
(dm/assert! (or (nil? animation)
(ctsi/animation? animation)))
(ptk/reify ::open-overlay
ptk/UpdateEvent
(update [_ state]
@ -590,11 +589,14 @@
(defn toggle-overlay
[frame-id position close-click-outside background-overlay animation]
(us/assert! ::us/uuid frame-id)
(us/assert! ::gpt/point position)
(us/assert! ::nilable-boolean close-click-outside)
(us/assert! ::nilable-boolean background-overlay)
(us/assert! ::nilable-animation animation)
(dm/assert! (uuid? frame-id))
(dm/assert! (gpt/point? position))
(dm/assert! (or (nil? close-click-outside)
(boolean? close-click-outside)))
(dm/assert! (or (nil? background-overlay)
(boolean? background-overlay)))
(dm/assert! (or (nil? animation)
(ctsi/animation? animation)))
(ptk/reify ::toggle-overlay
ptk/UpdateEvent
@ -619,8 +621,9 @@
(defn close-overlay
([frame-id] (close-overlay frame-id nil))
([frame-id animation]
(us/assert! ::us/uuid frame-id)
(us/assert! ::nilable-animation animation)
(dm/assert! (uuid? frame-id))
(dm/assert! (or (nil? animation)
(ctsi/animation? animation)))
(ptk/reify ::close-overlay
ptk/UpdateEvent

76
frontend/src/app/main/data/workspace.cljs
View file

@ -18,7 +18,6 @@
[app.common.pages :as cp]
[app.common.pages.changes-builder :as pcb]
[app.common.pages.helpers :as cph]
[app.common.spec :as us]
[app.common.text :as txt]
[app.common.transit :as t]
[app.common.types.components-list :as ctkl]
@ -84,10 +83,6 @@
(def default-workspace-local {:zoom 1})
(s/def ::layout-name (s/nilable ::us/keyword))
(s/def ::coll-of-uuids (s/coll-of ::us/uuid))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Workspace Initialization
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -101,7 +96,11 @@
(defn initialize-layout
[lname]
(us/assert! ::layout-name lname)
;; (dm/assert!
;; "expected valid layout"
;; (and (keyword? lname)
;; (contains? layout/presets lname)))
(ptk/reify ::initialize-layout
ptk/UpdateEvent
(update [_ state]
@ -298,8 +297,8 @@
(defn initialize-file
[project-id file-id]
(us/assert! ::us/uuid project-id)
(us/assert! ::us/uuid file-id)
(dm/assert! (uuid? project-id))
(dm/assert! (uuid? file-id))
(ptk/reify ::initialize-file
ptk/UpdateEvent
@ -350,7 +349,7 @@
(defn initialize-page
[page-id]
(us/assert! ::us/uuid page-id)
(dm/assert! (uuid? page-id))
(ptk/reify ::initialize-page
ptk/UpdateEvent
(update [_ state]
@ -384,7 +383,7 @@
(defn finalize-page
[page-id]
(us/assert! ::us/uuid page-id)
(dm/assert! (uuid? page-id))
(ptk/reify ::finalize-page
ptk/UpdateEvent
(update [_ state]
@ -465,8 +464,8 @@
(defn rename-page
[id name]
(us/verify ::us/uuid id)
(us/verify string? name)
(dm/assert! (uuid? id))
(dm/assert! (string? name))
(ptk/reify ::rename-page
ptk/WatchEvent
(watch [it state _]
@ -567,8 +566,8 @@
(defn update-shape
[id attrs]
(us/verify ::us/uuid id)
(us/verify ::cts/shape-attrs attrs)
(dm/assert! (uuid? id))
(dm/assert! (cts/shape-attrs? attrs))
(ptk/reify ::update-shape
ptk/WatchEvent
(watch [_ _ _]
@ -577,7 +576,7 @@
(defn start-rename-shape
[id]
(us/verify ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::start-rename-shape
ptk/UpdateEvent
(update [_ state]
@ -594,7 +593,7 @@
(defn update-selected-shapes
[attrs]
(us/verify ::cts/shape-attrs attrs)
(dm/assert! (cts/shape-attrs? attrs))
(ptk/reify ::update-selected-shapes
ptk/WatchEvent
(watch [_ state _]
@ -621,11 +620,14 @@
;; --- Shape Vertical Ordering
(s/def ::loc #{:up :down :bottom :top})
(def valid-vertical-locations
#{:up :down :bottom :top})
(defn vertical-order-selected
[loc]
(us/verify ::loc loc)
(dm/assert!
"expected valid location"
(contains? valid-vertical-locations loc))
(ptk/reify ::vertical-order-selected
ptk/WatchEvent
(watch [it state _]
@ -746,9 +748,9 @@
(defn relocate-shapes
[ids parent-id to-index & [ignore-parents?]]
(us/verify (s/coll-of ::us/uuid) ids)
(us/verify ::us/uuid parent-id)
(us/verify number? to-index)
(dm/assert! (every? uuid? ids))
(dm/assert! (uuid? parent-id))
(dm/assert! (number? to-index))
(ptk/reify ::relocate-shapes
ptk/WatchEvent
@ -935,7 +937,10 @@
(defn align-objects
[axis]
(us/verify ::gal/align-axis axis)
(dm/assert!
"expected valid align axis value"
(contains? gal/valid-align-axis axis))
(ptk/reify ::align-objects
ptk/WatchEvent
(watch [_ state _]
@ -976,7 +981,10 @@
(defn distribute-objects
[axis]
(us/verify ::gal/dist-axis axis)
(dm/assert!
"expected valid distribute axis value"
(contains? gal/valid-dist-axis axis))
(ptk/reify ::distribute-objects
ptk/WatchEvent
(watch [_ state _]
@ -1055,7 +1063,7 @@
qparams {:page-id page-id}]
(rx/of (rt/nav' :workspace pparams qparams))))))
([page-id]
(us/assert! ::us/uuid page-id)
(dm/assert! (uuid? page-id))
(ptk/reify ::go-to-page-2
ptk/WatchEvent
(watch [_ state _]
@ -1067,7 +1075,6 @@
(defn go-to-layout
[layout]
(us/verify ::layout/flag layout)
(ptk/reify ::go-to-layout
IDeref
(-deref [_] {:layout layout})
@ -1120,8 +1127,8 @@
:typographies #{}}))))
(defn go-to-main-instance
[page-id shape-id]
(us/verify ::us/uuid page-id)
(us/verify ::us/uuid shape-id)
(dm/assert! (uuid? page-id))
(dm/assert! (uuid? shape-id))
(ptk/reify ::go-to-main-instance
ptk/WatchEvent
(watch [_ state stream]
@ -1243,12 +1250,9 @@
;; Context Menu
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::point gpt/point?)
(defn show-context-menu
[{:keys [position] :as params}]
(us/verify ::point position)
(dm/assert! (gpt/point? position))
(ptk/reify ::show-context-menu
ptk/UpdateEvent
(update [_ state]
@ -1282,7 +1286,7 @@
(defn show-page-item-context-menu
[{:keys [position page] :as params}]
(us/verify ::point position)
(dm/assert! (gpt/point? position))
(ptk/reify ::show-page-item-context-menu
ptk/WatchEvent
(watch [_ _ _]
@ -1729,7 +1733,7 @@
(defn paste-text
[text]
(us/assert! (string? text) "expected string as first argument")
(dm/assert! (string? text))
(ptk/reify ::paste-text
ptk/WatchEvent
(watch [_ state _]
@ -1756,7 +1760,7 @@
;; TODO: why not implement it in terms of upload-media-workspace?
(defn- paste-svg
[text]
(us/assert! (string? text) "expected string as first argument")
(dm/assert! (string? text))
(ptk/reify ::paste-svg
ptk/WatchEvent
(watch [_ state _]
@ -2067,8 +2071,8 @@
(defn update-component-annotation
"Update the component with the given annotation"
[id annotation]
(us/assert ::us/uuid id)
(us/assert ::us/string annotation)
(dm/assert! (uuid? id))
(dm/assert! (string? annotation))
(ptk/reify ::update-component-annotation
ptk/WatchEvent
(watch [it state _]

21
frontend/src/app/main/data/workspace/changes.cljs
View file

@ -7,12 +7,13 @@
(ns app.main.data.workspace.changes
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.logging :as log]
[app.common.pages :as cp]
[app.common.pages.changes :as cpc]
[app.common.pages.changes-builder :as pcb]
[app.common.pages.changes-spec :as pcs]
[app.common.pages.helpers :as cph]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.types.shape-tree :as ctst]
[app.common.uuid :as uuid]
[app.main.data.workspace.state-helpers :as wsh]
@ -20,15 +21,11 @@
[app.main.store :as st]
[app.main.worker :as uw]
[beicon.core :as rx]
[cljs.spec.alpha :as s]
[potok.core :as ptk]))
;; Change this to :info :debug or :trace to debug this module
(log/set-level! :warn)
(s/def ::coll-of-uuid
(s/every ::us/uuid))
(defonce page-change? #{:add-page :mod-page :del-page :mov-page})
(defonce update-layout-attr? #{:hidden})
@ -56,8 +53,8 @@
([ids update-fn] (update-shapes ids update-fn nil))
([ids update-fn {:keys [reg-objects? save-undo? stack-undo? attrs ignore-tree page-id ignore-remote?]
:or {reg-objects? false save-undo? true stack-undo? false ignore-remote? false}}]
(us/assert ::coll-of-uuid ids)
(us/assert fn? update-fn)
(dm/assert! (sm/coll-of-uuid? ids))
(dm/assert! (fn? update-fn))
(ptk/reify ::update-shapes
ptk/WatchEvent
@ -75,7 +72,7 @@
changes (reduce
(fn [changes id]
(let [opts {:attrs attrs :ignore-geometry? (get ignore-tree id)}]
(pcb/update-shapes changes [id] update-fn opts)))
(pcb/update-shapes changes [id] update-fn (d/without-nils opts))))
(-> (pcb/empty-changes it page-id)
(pcb/set-save-undo? save-undo?)
(pcb/set-stack-undo? stack-undo?)
@ -204,8 +201,10 @@
[:workspace-data]
[:workspace-libraries file-id :data])]
(try
(us/assert ::pcs/changes redo-changes)
(us/assert ::pcs/changes undo-changes)
(dm/assert!
"expect valid vector of changes"
(and (cpc/changes? redo-changes)
(cpc/changes? undo-changes)))
(update-in state path (fn [file]
(-> file

13
frontend/src/app/main/data/workspace/comments.cljs
View file

@ -6,10 +6,11 @@
(ns app.main.data.workspace.comments
(:require
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.geom.shapes :as gsh]
[app.common.pages.changes-builder :as pcb]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.types.shape-tree :as ctst]
[app.main.data.comments :as dcm]
[app.main.data.workspace.changes :as dwc]
@ -28,7 +29,7 @@
(defn initialize-comments
[file-id]
(us/assert ::us/uuid file-id)
(dm/assert! (uuid? file-id))
(ptk/reify ::initialize-comments
ptk/WatchEvent
(watch [_ _ stream]
@ -80,7 +81,7 @@
(defn center-to-comment-thread
[{:keys [position] :as thread}]
(us/assert ::dcm/comment-thread thread)
(dm/assert! (dcm/comment-thread? thread))
(ptk/reify ::center-to-comment-thread
ptk/UpdateEvent
(update [_ state]
@ -96,7 +97,7 @@
(defn navigate
[thread]
(us/assert ::dcm/comment-thread thread)
(dm/assert! (dcm/comment-thread? thread))
(ptk/reify ::open-comment-thread
ptk/WatchEvent
(watch [_ _ stream]
@ -117,7 +118,7 @@
(update-comment-thread-position thread [new-x new-y] nil))
([thread [new-x new-y] frame-id]
(us/assert ::dcm/comment-thread thread)
(dm/assert! (dcm/comment-thread? thread))
(ptk/reify ::update-comment-thread-position
ptk/WatchEvent
(watch [it state _]
@ -146,7 +147,7 @@
;; Move comment threads that are inside a frame when that frame is moved"
(defmethod ptk/resolve ::move-frame-comment-threads
[_ ids]
(us/assert! ::us/coll-of-uuid ids)
(dm/assert! (sm/coll-of-uuid? ids))
(ptk/reify ::move-frame-comment-threads
ptk/WatchEvent
(watch [_ state _]

4
frontend/src/app/main/data/workspace/edition.cljs
View file

@ -6,7 +6,7 @@
(ns app.main.data.workspace.edition
(:require
[app.common.spec :as us]
[app.common.data.macros :as dm]
[app.main.data.workspace.state-helpers :as wsh]
[beicon.core :as rx]
[potok.core :as ptk]))
@ -17,7 +17,7 @@
(defn start-edition-mode
[id]
(us/assert ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::start-edition-mode
ptk/UpdateEvent
(update [_ state]

4
frontend/src/app/main/data/workspace/grid.cljs
View file

@ -8,8 +8,8 @@
(:require
[app.common.colors :as clr]
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.pages.changes-builder :as pcb]
[app.common.spec :as us]
[app.main.data.workspace.changes :as dch]
[app.main.data.workspace.state-helpers :as wsh]
[beicon.core :as rx]
@ -40,7 +40,7 @@
(defn add-frame-grid
[frame-id]
(us/assert ::us/uuid frame-id)
(dm/assert! (uuid? frame-id))
(ptk/reify ::add-frame-grid
ptk/WatchEvent
(watch [_ state _]

19
frontend/src/app/main/data/workspace/guides.cljs
View file

@ -6,11 +6,11 @@
(ns app.main.data.workspace.guides
(:require
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.geom.shapes :as gsh]
[app.common.pages.changes-builder :as pcb]
[app.common.spec :as us]
[app.common.types.page.guide :as ctpg]
[app.common.types.page :as ctp]
[app.main.data.workspace.changes :as dwc]
[app.main.data.workspace.state-helpers :as wsh]
[beicon.core :as rx]
@ -23,7 +23,10 @@
(merge guide))))
(defn update-guides [guide]
(us/verify ::ctpg/guide guide)
(dm/assert!
"expected valid guide"
(ctp/guide? guide))
(ptk/reify ::update-guides
ptk/WatchEvent
(watch [it state _]
@ -35,7 +38,10 @@
(rx/of (dwc/commit-changes changes))))))
(defn remove-guide [guide]
(us/verify ::ctpg/guide guide)
(dm/assert!
"expected valid guide"
(ctp/guide? guide))
(ptk/reify ::remove-guide
ptk/UpdateEvent
(update [_ state]
@ -62,10 +68,11 @@
guides (-> (select-keys guides ids) (vals))]
(rx/from (->> guides (mapv #(remove-guide %))))))))
(defmethod ptk/resolve ::move-frame-guides
[_ ids]
(us/assert! ::us/coll-of-uuid ids)
(dm/assert!
"expected a coll of uuids"
(every? uuid? ids))
(ptk/reify ::move-frame-guides
ptk/WatchEvent
(watch [_ state _]

6
frontend/src/app/main/data/workspace/highlight.cljs
View file

@ -6,7 +6,7 @@
(ns app.main.data.workspace.highlight
(:require
[app.common.spec :as us]
[app.common.data.macros :as dm]
[clojure.set :as set]
[potok.core :as ptk]))
@ -14,7 +14,7 @@
(defn highlight-shape
[id]
(us/verify ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::highlight-shape
ptk/UpdateEvent
(update [_ state]
@ -22,7 +22,7 @@
(defn dehighlight-shape
[id]
(us/verify ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::dehighlight-shape
ptk/UpdateEvent
(update [_ state]

10
frontend/src/app/main/data/workspace/interactions.cljs
View file

@ -7,11 +7,11 @@
(ns app.main.data.workspace.interactions
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.pages :as cp]
[app.common.pages.changes-builder :as pcb]
[app.common.pages.helpers :as cph]
[app.common.spec :as us]
[app.common.types.page :as ctp]
[app.common.types.shape-tree :as ctst]
[app.common.types.shape.interactions :as ctsi]
@ -55,7 +55,7 @@
(defn remove-flow
[flow-id]
(us/verify ::us/uuid flow-id)
(dm/assert! (uuid? flow-id))
(ptk/reify ::remove-flow
ptk/WatchEvent
(watch [it state _]
@ -67,8 +67,8 @@
(defn rename-flow
[flow-id name]
(us/verify ::us/uuid flow-id)
(us/verify ::us/string name)
(dm/assert! (uuid? flow-id))
(dm/assert! (string? name))
(ptk/reify ::rename-flow
ptk/WatchEvent
(watch [it state _]
@ -81,7 +81,7 @@
(defn start-rename-flow
[id]
(us/verify ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::start-rename-flow
ptk/UpdateEvent
(update [_ state]

10
frontend/src/app/main/data/workspace/layout.cljs
View file

@ -7,13 +7,12 @@
(ns app.main.data.workspace.layout
"Workspace layout management events and helpers."
(:require
[app.common.spec :as us]
[app.common.data.macros :as dm]
[app.util.storage :refer [storage]]
[cljs.spec.alpha :as s]
[clojure.set :as set]
[potok.core :as ptk]))
(s/def ::flag
(def valid-flags
#{:sitemap
:layers
:comments
@ -44,7 +43,8 @@
{:del #{:document-history :assets}
:add #{:sitemap :layers}}})
(s/def ::options-mode #{:design :prototype :inspect})
(def valid-options-mode
#{:design :prototype :inspect})
(def default-layout
#{:sitemap
@ -114,7 +114,7 @@
(defn set-options-mode
[mode]
(us/assert ::options-mode mode)
(dm/assert! (contains? valid-options-mode mode))
(ptk/reify ::set-options-mode
ptk/UpdateEvent
(update [_ state]

115
frontend/src/app/main/data/workspace/libraries.cljs
View file

@ -7,26 +7,23 @@
(ns app.main.data.workspace.libraries
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.files.features :as ffeat]
[app.common.geom.point :as gpt]
[app.common.logging :as log]
[app.common.pages :as cp]
[app.common.pages.changes :as ch]
[app.common.pages.changes-builder :as pcb]
[app.common.pages.changes-spec :as pcs]
[app.common.pages.helpers :as cph]
[app.common.spec :as us]
[app.common.types.color :as ctc]
[app.common.types.component :as ctk]
[app.common.types.components-list :as ctkl]
[app.common.types.container :as ctn]
[app.common.types.file :as ctf]
[app.common.types.file.media-object :as ctfm]
[app.common.types.typography :as ctt]
[app.common.uuid :as uuid]
[app.main.data.dashboard :as dd]
[app.main.data.events :as ev]
[app.main.data.messages :as dm]
[app.main.data.messages :as msg]
[app.main.data.workspace.changes :as dch]
[app.main.data.workspace.groups :as dwg]
[app.main.data.workspace.libraries-helpers :as dwlh]
@ -42,14 +39,11 @@
[app.util.router :as rt]
[app.util.time :as dt]
[beicon.core :as rx]
[cljs.spec.alpha :as s]
[potok.core :as ptk]))
;; Change this to :info :debug or :trace to debug this module, or :warn to reset to default
(log/set-level! :warn)
(s/def ::file ::dd/file)
(defn- log-changes
[changes file]
(let [extract-change
@ -116,7 +110,7 @@
color (-> color
(assoc :id id)
(assoc :name (default-color-name color)))]
(us/assert ::ctc/color color)
(dm/assert! (ctc/color? color))
(ptk/reify ::add-color
IDeref
(-deref [_] color)
@ -130,7 +124,7 @@
(defn add-recent-color
[color]
(us/assert! ::ctc/recent-color color)
(dm/assert! (ctc/recent-color? color))
(ptk/reify ::add-recent-color
ptk/WatchEvent
(watch [it _ _]
@ -160,8 +154,9 @@
(defn update-color
[color file-id]
(us/assert ::ctc/color color)
(us/assert ::us/uuid file-id)
(dm/assert! (ctc/color? color))
(dm/assert! (uuid? file-id))
(ptk/reify ::update-color
ptk/WatchEvent
(watch [it state _]
@ -169,9 +164,10 @@
(defn rename-color
[file-id id new-name]
(us/assert ::us/uuid file-id)
(us/assert ::us/uuid id)
(us/assert ::us/string new-name)
(dm/assert! (uuid? file-id))
(dm/assert! (uuid? id))
(dm/assert! (string? new-name))
(ptk/reify ::rename-color
ptk/WatchEvent
(watch [it state _]
@ -183,7 +179,7 @@
(defn delete-color
[{:keys [id] :as params}]
(us/assert ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::delete-color
ptk/WatchEvent
(watch [it state _]
@ -195,7 +191,7 @@
(defn add-media
[media]
(us/assert ::ctfm/media-object media)
(dm/assert! (ctf/media-object? media))
(ptk/reify ::add-media
ptk/WatchEvent
(watch [it _ _]
@ -206,8 +202,8 @@
(defn rename-media
[id new-name]
(us/assert ::us/uuid id)
(us/assert ::us/string new-name)
(dm/assert! (uuid? id))
(dm/assert! (string? new-name))
(ptk/reify ::rename-media
ptk/WatchEvent
(watch [it state _]
@ -224,7 +220,7 @@
(defn delete-media
[{:keys [id] :as params}]
(us/assert ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::delete-media
ptk/WatchEvent
(watch [it state _]
@ -238,7 +234,7 @@
([typography] (add-typography typography true))
([typography edit?]
(let [typography (update typography :id #(or % (uuid/next)))]
(us/assert ::ctt/typography typography)
(dm/assert! (ctt/typography? typography))
(ptk/reify ::add-typography
IDeref
(-deref [_] typography)
@ -267,8 +263,9 @@
(defn update-typography
[typography file-id]
(us/assert ::ctt/typography typography)
(us/assert ::us/uuid file-id)
(dm/assert! (ctt/typography? typography))
(dm/assert! (uuid? file-id))
(ptk/reify ::update-typography
ptk/WatchEvent
(watch [it state _]
@ -276,9 +273,9 @@
(defn rename-typography
[file-id id new-name]
(us/assert ::us/uuid file-id)
(us/assert ::us/uuid id)
(us/assert ::us/string new-name)
(dm/assert! (uuid? file-id))
(dm/assert! (uuid? id))
(dm/assert! (string? new-name))
(ptk/reify ::rename-typography
ptk/WatchEvent
(watch [it state _]
@ -291,7 +288,7 @@
(defn delete-typography
[id]
(us/assert ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::delete-typography
ptk/WatchEvent
(watch [it state _]
@ -341,8 +338,8 @@
(defn rename-component
"Rename the component with the given id, in the current file library."
[id new-name]
(us/assert ::us/uuid id)
(us/assert ::us/string new-name)
(dm/assert! (uuid? id))
(dm/assert! (string? new-name))
(ptk/reify ::rename-component
ptk/WatchEvent
(watch [it state _]
@ -414,7 +411,7 @@
(defn delete-component
"Delete the component with the given id, from the current file library."
[{:keys [id] :as params}]
(us/assert ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::delete-component
ptk/WatchEvent
(watch [it state _]
@ -432,8 +429,8 @@
(defn restore-component
"Restore a deleted component, with the given id, in the given file library."
[library-id component-id]
(us/assert ::us/uuid library-id)
(us/assert ::us/uuid component-id)
(dm/assert! (uuid? library-id))
(dm/assert! (uuid? component-id))
(ptk/reify ::restore-component
ptk/WatchEvent
(watch [it state _]
@ -460,9 +457,10 @@
"Create a new shape in the current page, from the component with the given id
in the given file library. Then selects the newly created instance."
[file-id component-id position]
(us/assert ::us/uuid file-id)
(us/assert ::us/uuid component-id)
(us/assert ::gpt/point position)
(dm/assert! (uuid? file-id))
(dm/assert! (uuid? component-id))
(dm/assert! (gpt/point? position))
(ptk/reify ::instantiate-component
ptk/WatchEvent
(watch [it state _]
@ -489,7 +487,7 @@
"Remove all references to components in the shape with the given id,
and all its children, at the current page."
[id]
(us/assert ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::detach-component
ptk/WatchEvent
(watch [it state _]
@ -528,7 +526,7 @@
(defn nav-to-component-file
[file-id]
(us/assert ::us/uuid file-id)
(dm/assert! (uuid? file-id))
(ptk/reify ::nav-to-component-file
ptk/WatchEvent
(watch [_ state _]
@ -543,8 +541,8 @@
(defn ext-library-changed
[file-id modified-at revn changes]
(us/assert ::us/uuid file-id)
(us/assert ::pcs/changes changes)
(dm/assert! (uuid? file-id))
(dm/assert! (ch/changes? changes))
(ptk/reify ::ext-library-changed
ptk/UpdateEvent
(update [_ state]
@ -559,7 +557,7 @@
the current page. Set all attributes equal to the ones in the linked component,
and untouched."
[id]
(us/assert ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::reset-component
ptk/WatchEvent
(watch [it state _]
@ -595,7 +593,7 @@
different of that the one we are currently editing."
([id] (update-component id nil))
([id undo-group]
(us/assert ::us/uuid id)
(dm/assert! (uuid? id))
(ptk/reify ::update-component
ptk/WatchEvent
(watch [it state _]
@ -680,6 +678,9 @@
(declare sync-file-2nd-stage)
(def valid-asset-types
#{:colors :components :typographies})
(defn sync-file
"Synchronize the given file from the given library. Walk through all
shapes in all pages in the file that use some color, typography or
@ -694,10 +695,12 @@
([file-id library-id asset-type asset-id]
(sync-file file-id library-id asset-type asset-id nil))
([file-id library-id asset-type asset-id undo-group]
(us/assert ::us/uuid file-id)
(us/assert ::us/uuid library-id)
(us/assert (s/nilable #{:colors :components :typographies}) asset-type)
(us/assert (s/nilable ::us/uuid) asset-id)
(dm/assert! (uuid? file-id))
(dm/assert! (uuid? library-id))
(dm/assert! (or (nil? asset-type)
(contains? valid-asset-types asset-type)))
(dm/assert! (or (nil? asset-id)
(uuid? asset-id)))
(ptk/reify ::sync-file
ptk/UpdateEvent
(update [_ state]
@ -748,7 +751,7 @@
(:redo-changes changes)
file))
(rx/concat
(rx/of (dm/hide-tag :sync-dialog))
(rx/of (msg/hide-tag :sync-dialog))
(when (seq (:redo-changes changes))
(rx/of (dch/commit-changes (assoc changes ;; TODO a ver qué pasa con esto
:file-id file-id))))
@ -777,9 +780,10 @@
;; implement updated-at at component level, to detect what components have
;; not changed, and then not to apply sync and terminate the loop.
[file-id library-id asset-id undo-group]
(us/assert ::us/uuid file-id)
(us/assert ::us/uuid library-id)
(us/assert (s/nilable ::us/uuid) asset-id)
(dm/assert! (uuid? file-id))
(dm/assert! (uuid? library-id))
(dm/assert! (or (nil? asset-id)
(uuid? asset-id)))
(ptk/reify ::sync-file-2nd-stage
ptk/WatchEvent
(watch [it state _]
@ -818,7 +822,7 @@
"Get a lazy sequence of all the assets of each type in the library that have
been modified after the last sync of the library. The sync date may be
overriden by providing a ignore-until parameter.
The sequence items are tuples of (page-id shape-id asset-id asset-type)."
([library file-data] (assets-need-sync library file-data nil))
([library file-data ignore-until]
@ -828,7 +832,7 @@
(defn notify-sync-file
[file-id]
(us/assert ::us/uuid file-id)
(dm/assert! (uuid? file-id))
(ptk/reify ::notify-sync-file
ptk/WatchEvent
(watch [_ state _]
@ -839,12 +843,12 @@
(sync-file (:current-file-id state)
(:id library)))
libraries-need-sync))
(st/emit! dm/hide))
(st/emit! msg/hide))
do-dismiss #(do (st/emit! ignore-sync)
(st/emit! dm/hide))]
(st/emit! msg/hide))]
(when (seq libraries-need-sync)
(rx/of (dm/info-dialog
(rx/of (msg/info-dialog
(tr "workspace.updates.there-are-updates")
:inline-actions
[{:label (tr "workspace.updates.update")
@ -921,7 +925,6 @@
(defn- shared-files-fetched
[files]
(us/verify (s/every ::file) files)
(ptk/reify ::shared-files-fetched
ptk/UpdateEvent
(update [_ state]
@ -930,7 +933,7 @@
(defn fetch-shared-files
[{:keys [team-id] :as params}]
(us/assert ::us/uuid team-id)
(dm/assert! (uuid? team-id))
(ptk/reify ::fetch-shared-files
ptk/WatchEvent
(watch [_ _ _]

83
frontend/src/app/main/data/workspace/media.cljs
View file

@ -6,18 +6,19 @@
(ns app.main.data.workspace.media
(:require
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.logging :as log]
[app.common.math :as mth]
[app.common.pages.changes-builder :as pcb]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.types.container :as ctn]
[app.common.types.shape :as cts]
[app.common.types.shape-tree :as ctst]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.main.data.media :as dmm]
[app.main.data.messages :as dm]
[app.main.data.messages :as msg]
[app.main.data.workspace.changes :as dch]
[app.main.data.workspace.libraries :as dwl]
[app.main.data.workspace.shapes :as dwsh]
@ -28,7 +29,6 @@
[app.util.http :as http]
[app.util.i18n :refer [tr]]
[beicon.core :as rx]
[cljs.spec.alpha :as s]
[cuerdas.core :as str]
[potok.core :as ptk]
[promesa.core :as p]
@ -136,47 +136,46 @@
(rx/merge-map svg->clj)
(rx/do on-svg)))))
(s/def ::local? ::us/boolean)
(s/def ::blobs ::dmm/blobs)
(s/def ::name ::us/string)
(s/def ::uris (s/coll-of ::us/string))
(s/def ::mtype ::us/string)
(s/def ::process-media-objects
(s/and
(s/keys :req-un [::file-id ::local?]
:opt-un [::name ::data ::uris ::mtype])
(fn [props]
(or (contains? props :blobs)
(contains? props :uris)))))
(def schema:process-media-objects
[:map
[:file-id ::sm/uuid]
[:local? :boolean]
[:name {:optional true} :string]
[:data {:optional true} :any] ; FIXME
[:uris {:optional true} [:vector :string]]
[:mtype {:optional true} :string]])
(defn- process-media-objects
[{:keys [uris on-error] :as params}]
(us/assert ::process-media-objects params)
(dm/assert!
(and (sm/valid? schema:process-media-objects params)
(or (contains? params :blobs)
(contains? params :uris))))
(letfn [(handle-error [error]
(if (ex/ex-info? error)
(handle-error (ex-data error))
(cond
(= (:code error) :invalid-svg-file)
(rx/of (dm/error (tr "errors.media-type-not-allowed")))
(rx/of (msg/error (tr "errors.media-type-not-allowed")))
(= (:code error) :media-type-not-allowed)
(rx/of (dm/error (tr "errors.media-type-not-allowed")))
(rx/of (msg/error (tr "errors.media-type-not-allowed")))
(= (:code error) :unable-to-access-to-url)
(rx/of (dm/error (tr "errors.media-type-not-allowed")))
(rx/of (msg/error (tr "errors.media-type-not-allowed")))
(= (:code error) :invalid-image)
(rx/of (dm/error (tr "errors.media-type-not-allowed")))
(rx/of (msg/error (tr "errors.media-type-not-allowed")))
(= (:code error) :media-max-file-size-reached)
(rx/of (dm/error (tr "errors.media-too-large")))
(rx/of (msg/error (tr "errors.media-too-large")))
(= (:code error) :media-type-mismatch)
(rx/of (dm/error (tr "errors.media-type-mismatch")))
(rx/of (msg/error (tr "errors.media-type-mismatch")))
(= (:code error) :unable-to-optimize)
(rx/of (dm/error (:hint error)))
(rx/of (msg/error (:hint error)))
(fn? on-error)
(on-error error)
@ -188,10 +187,10 @@
ptk/WatchEvent
(watch [_ _ _]
(rx/concat
(rx/of (dm/show {:content (tr "media.loading")
:type :info
:timeout nil
:tag :media-loading}))
(rx/of (msg/show {:content (tr "media.loading")
:type :info
:timeout nil
:tag :media-loading}))
(->> (if (seq uris)
;; Media objects is a list of URL's pointing to the path
(process-uris params)
@ -201,7 +200,7 @@
;; Every stream has its own sideeffect. We need to ignore the result
(rx/ignore)
(rx/catch handle-error)
(rx/finalize #(st/emit! (dm/hide-tag :media-loading)))))))))
(rx/finalize #(st/emit! (msg/hide-tag :media-loading)))))))))
;; Deprecated in components-v2
(defn upload-media-asset
@ -235,9 +234,9 @@
(rx/map #(vector (:name media-obj) %))
(rx/merge-map svg->clj)
(rx/catch ; When error downloading media-obj, skip it and continue with next one
#(log/error :msg (str "Error downloading " (:name media-obj) " from " path)
:hint (ex-message %)
:error %)))))
#(log/error :msg (str "Error downloading " (:name media-obj) " from " path)
:hint (ex-message %)
:error %)))))
(defn create-shapes-svg
"Convert svg elements into penpot shapes."
@ -339,14 +338,14 @@
:on-svg #(st/emit! (process-svg-component %)))]
(process-media-objects params)))
(s/def ::object-id ::us/uuid)
(s/def ::clone-media-objects-params
(s/keys :req-un [::file-id ::object-id]))
(def schema:clone-media-object
[:map
[:file-id ::sm/uuid]
[:object-id ::sm/uuid]])
(defn clone-media-object
[{:keys [file-id object-id] :as params}]
(us/assert ::clone-media-objects-params params)
(dm/assert! (sm/valid? schema:clone-media-object params))
(ptk/reify ::clone-media-objects
ptk/WatchEvent
(watch [_ _ _]
@ -358,12 +357,12 @@
:id object-id}]
(rx/concat
(rx/of (dm/show {:content (tr "media.loading")
:type :info
:timeout nil
:tag :media-loading}))
(rx/of (msg/show {:content (tr "media.loading")
:type :info
:timeout nil
:tag :media-loading}))
(->> (rp/cmd! :clone-file-media-object params)
(rx/do on-success)
(rx/catch on-error)
(rx/finalize #(st/emit! (dm/hide-tag :media-loading)))))))))
(rx/finalize #(st/emit! (msg/hide-tag :media-loading)))))))))

11
frontend/src/app/main/data/workspace/modifiers.cljs
View file

@ -14,7 +14,6 @@
[app.common.math :as mth]
[app.common.pages.common :as cpc]
[app.common.pages.helpers :as cph]
[app.common.spec :as us]
[app.common.types.container :as ctn]
[app.common.types.modifiers :as ctm]
[app.common.types.shape.layout :as ctl]
@ -25,7 +24,6 @@
[app.main.data.workspace.state-helpers :as wsh]
[app.main.data.workspace.undo :as dwu]
[beicon.core :as rx]
[cljs.spec.alpha :as s]
[potok.core :as ptk]))
;; -- temporary modifiers -------------------------------------------
@ -96,7 +94,6 @@
ignore-geometry? (and (and (< (:x distance) 1) (< (:y distance) 1))
(mth/close? (:width selrect) (:width transformed-selrect))
(mth/close? (:height selrect) (:height transformed-selrect)))]
[root transformed-root ignore-geometry?]))
(defn- get-ignore-tree
@ -157,12 +154,16 @@
(defn create-modif-tree
[ids modifiers]
(us/verify (s/coll-of uuid?) ids)
(dm/assert!
"expected valid coll of uuids"
(every? uuid? ids))
(into {} (map #(vector % {:modifiers modifiers})) ids))
(defn build-modif-tree
[ids objects get-modifier]
(us/verify (s/coll-of uuid?) ids)
(dm/assert!
"expected valid coll of uuids"
(every? uuid? ids))
(into {} (map #(vector % {:modifiers (get-modifier (get objects %))})) ids))
(defn modifier-remove-from-parent

44
frontend/src/app/main/data/workspace/notifications.cljs
View file

@ -7,8 +7,9 @@
(ns app.main.data.workspace.notifications
(:require
[app.common.data :as d]
[app.common.pages.changes-spec :as pcs]
[app.common.spec :as us]
[app.common.data.macros :as dm]
[app.common.pages.changes :as cpc]
[app.common.schema :as sm]
[app.main.data.websocket :as dws]
[app.main.data.workspace.changes :as dch]
[app.main.data.workspace.libraries :as dwl]
@ -18,7 +19,6 @@
[app.util.object :as obj]
[app.util.time :as dt]
[beicon.core :as rx]
[cljs.spec.alpha :as s]
[clojure.set :as set]
[potok.core :as ptk]))
@ -183,19 +183,18 @@
:updated-at (dt/now)
:page-id page-id))))))
(s/def ::type keyword?)
(s/def ::profile-id uuid?)
(s/def ::file-id uuid?)
(s/def ::session-id uuid?)
(s/def ::revn integer?)
(s/def ::changes ::pcs/changes)
(s/def ::file-change-event
(s/keys :req-un [::type ::profile-id ::file-id ::session-id ::revn ::changes]))
(def schema:handle-file-change
[:map
[:type :keyword]
[:profile-id ::sm/uuid]
[:file-id ::sm/uuid]
[:session-id ::sm/uuid]
[:revn :int]
[:changes ::cpc/changes]])
(defn handle-file-change
[{:keys [file-id changes] :as msg}]
(us/assert ::file-change-event msg)
(dm/assert! (sm/valid? schema:handle-file-change msg))
(ptk/reify ::handle-file-change
IDeref
(-deref [_] {:changes changes})
@ -241,18 +240,19 @@
(when-not (empty? changes-by-pages)
(rx/from (map process-page-changes changes-by-pages))))))))
(s/def ::library-change-event
(s/keys :req-un [::type
::profile-id
::file-id
::session-id
::revn
::modified-at
::changes]))
(def schema:handle-library-change
[:map
[:type :keyword]
[:profile-id ::sm/uuid]
[:file-id ::sm/uuid]
[:session-id ::sm/uuid]
[:revn :int]
[:modified-at ::sm/inst]
[:changes ::cpc/changes]])
(defn handle-library-change
[{:keys [file-id modified-at changes revn] :as msg}]
(us/assert ::library-change-event msg)
(dm/assert! (sm/valid? schema:handle-library-change msg))
(ptk/reify ::handle-library-change
ptk/WatchEvent
(watch [_ state _]

8
frontend/src/app/main/data/workspace/path/changes.cljs
View file

@ -6,11 +6,11 @@
(ns app.main.data.workspace.path.changes
(:require
[app.common.data.macros :as dm]
[app.common.pages.changes-builder :as pcb]
[app.common.spec :as us]
[app.main.data.workspace.changes :as dch]
[app.main.data.workspace.path.common :refer [content?]]
[app.main.data.workspace.path.helpers :as helpers]
[app.main.data.workspace.path.spec :as spec]
[app.main.data.workspace.path.state :as st]
[app.main.data.workspace.state-helpers :as wsh]
[beicon.core :as rx]
@ -19,8 +19,8 @@
(defn generate-path-changes
"Generates changes to update the new content of the shape"
[it objects page-id shape old-content new-content]
(us/verify ::spec/content old-content)
(us/verify ::spec/content new-content)
(dm/assert! (content? old-content))
(dm/assert! (content? new-content))
(let [shape-id (:id shape)
[old-points old-selrect]

31
frontend/src/app/main/data/workspace/path/common.cljs
View file

@ -6,9 +6,40 @@
(ns app.main.data.workspace.path.common
(:require
[app.common.schema :as sm]
[app.main.data.workspace.path.state :as st]
[potok.core :as ptk]))
(def valid-commands
#{:move-to
:line-to
:line-to-horizontal
:line-to-vertical
:curve-to
:smooth-curve-to
:quadratic-bezier-curve-to
:smooth-quadratic-bezier-curve-to
:elliptical-arc
:close-path})
(def schema:content
[:vector {:title "PathContent"}
[:map {:title "PathContentEntry"}
[:command [::sm/one-of valid-commands]]
;; FIXME: remove the `?` from prop name
[:relative? {:optional true} :boolean]
[:params {:optional true}
[:map {:title "PathContentEntryParams"}
[:x :double]
[:y :double]
[:c1x {:optional true} :double]
[:c1y {:optional true} :double]
[:c2x {:optional true} :double]
[:c2y {:optional true} :double]]]]])
(def content?
(sm/pred-fn schema:content))
(defn init-path []
(ptk/reify ::init-path))

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