3pp-mirror/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-06-25 16:17:05 +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.spec :as us]
[app.common.transit :as t] [app.common.transit :as t]
[app.common.uuid :as uuid] [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.config :as cfg]
[app.main :as main] [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.helpers]
[app.srepl.main :as srepl] [app.srepl.main :as srepl]
[app.util.blob :as blob] [app.util.blob :as blob]
@ -31,7 +42,7 @@
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[clojure.stacktrace :as trace] [clojure.stacktrace :as trace]
[clojure.test :as test] [clojure.test :as test]
[clojure.test.check.generators :as gen] [clojure.test.check.generators :as tgen]
[clojure.tools.namespace.repl :as repl] [clojure.tools.namespace.repl :as repl]
[clojure.walk :refer [macroexpand-all]] [clojure.walk :refer [macroexpand-all]]
[criterium.core :as crit] [criterium.core :as crit]
@ -130,3 +141,39 @@
(add-tap #(locking debug-tap (add-tap #(locking debug-tap
(prn "tap debug:" %))) (prn "tap debug:" %)))
1)) 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

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

@ -20,13 +20,21 @@
<span>WEBHOOK</span> <span>WEBHOOK</span>
</span> </span>
{% endif %} {% 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> </div>
<div class="rpc-row-detail hidden"> <div class="rpc-row-detail hidden">
<h3>DOCSTRING:</h3> <h4>DOCSTRING:</h4>
<section class="padded-section"> <section class="padded-section">
{% if item.added %} {% if item.added %}
<p class="small"><strong>Added:</strong> on v{{item.added}}</p> <p class="small"><strong>Added:</strong> on v{{item.added}}</p>
{% endif %} {% endif %}
@ -35,13 +43,18 @@
<p class="small"><strong>Deprecated:</strong> since v{{item.deprecated}}</p> <p class="small"><strong>Deprecated:</strong> since v{{item.deprecated}}</p>
{% endif %} {% endif %}
{% if item.entrypoint %}
<p class="small"><strong>URI:</strong> <a href="{{item.entrypoint}}">{{item.entrypoint}}</a></p>
{% endif %}
{% if item.docs %} {% if item.docs %}
<p class="docstring"> {{item.docs}}</p> <p class="docstring"> {{item.docs}}</p>
{% endif %} {% endif %}
</section> </section>
{% if item.changes %} {% if item.changes %}
<h3>CHANGES:</h3> <h4>CHANGES:</h4>
<section class="padded-section"> <section class="padded-section">
<ul class="changes"> <ul class="changes">
@ -52,9 +65,55 @@
</section> </section>
{% endif %} {% endif %}
<h3>SPEC EXPLAIN:</h3> {% if item.spec %}
<h4>PARAMS (SPEC):</h4>
<section class="padded-section"> <section class="padded-section">
<pre class="spec-explain">{{item.spec}}</pre> <pre class="spec-explain">{{item.spec}}</pre>
</section> </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> </div>
</li> </li>

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

@ -27,12 +27,78 @@ main {
header { header {
border-bottom: 1px solid #c0c0c0; border-bottom: 1px solid #c0c0c0;
display: flex; display: flex;
flex-direction: column;
align-items: center;
justify-content: center; justify-content: center;
width: 100%; 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; 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%; width: 100%;
display: flex; display: flex;
flex-direction: column; flex-direction: column;
@ -65,7 +131,7 @@ header {
.rpc-row-info { .rpc-row-info {
cursor: pointer; cursor: pointer;
display: flex; display: flex;
background-color: #eeeeee; background-color: #e5e5e5;
padding: 5px 10px; padding: 5px 10px;
} }
@ -108,6 +174,8 @@ header {
.rpc-row-detail { .rpc-row-detail {
padding: 5px 10px; padding: 5px 10px;
padding-bottom: 20px; padding-bottom: 20px;
border-left: 2px solid #e5e5e5;
border-right: 2px solid #e5e5e5;
} }
.rpc-row-detail p { .rpc-row-detail p {
@ -143,3 +211,7 @@ header {
p.small strong { p.small strong {
font-size: 10px; font-size: 10px;
} }
p.small a {
font-size: 10px;
}

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

@ -20,10 +20,68 @@
<main> <main>
<header> <header>
<h1>Penpot API Documentation (v{{version}})</h1> <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> </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"> <ul class="rpc-items">
{% for item in methods %} {% for item in methods %}
{% include "app/templates/api-doc-entry.tmpl" with item=item %} {% 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 (def default-flags
[:enable-backend-api-doc [:enable-backend-api-doc
:enable-backend-openapi-doc
:enable-backend-worker :enable-backend-worker
:enable-secure-session-cookies :enable-secure-session-cookies
:enable-email-verification]) :enable-email-verification])

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

@ -154,8 +154,8 @@
[_ cfg] [_ cfg]
(rr/router (rr/router
[["" {:middleware [[mw/server-timing] [["" {:middleware [[mw/server-timing]
[mw/format-response]
[mw/params] [mw/params]
[mw/format-response]
[mw/parse-request] [mw/parse-request]
[session/soft-auth cfg] [session/soft-auth cfg]
[actoken/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") (-> (io/resource "app/templates/error-report.v2.tmpl")
(tmpl/render report))) (tmpl/render report)))
(render-template-v3 [{report :content}]
(-> (io/resource "app/templates/error-report.v3.tmpl")
(tmpl/render report)))
] ]
(when-not (authorized? pool request) (when-not (authorized? pool request)
@ -245,9 +248,10 @@
:code :only-admins-allowed)) :code :only-admins-allowed))
(if-let [report (get-report request)] (if-let [report (get-report request)]
(let [result (if (= 1 (:version report)) (let [result (case (:version report)
(render-template-v1 report) 1 (render-template-v1 report)
(render-template-v2 report))] 2 (render-template-v2 report)
3 (render-template-v3 report))]
{::yrs/status 200 {::yrs/status 200
::yrs/body result ::yrs/body result
::yrs/headers {"content-type" "text/html; charset=utf-8" ::yrs/headers {"content-type" "text/html; charset=utf-8"

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

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

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

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

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

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

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

@ -10,6 +10,9 @@
[app.common.data :as d] [app.common.data :as d]
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.common.media :as cm] [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.common.spec :as us]
[app.config :as cf] [app.config :as cf]
[app.db :as-alias db] [app.db :as-alias db]
@ -47,6 +50,27 @@
(s/keys :req-un [::path] (s/keys :req-un [::path]
:opt-un [::mtype])) :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! (defn validate-media-type!
([upload] (validate-media-type! upload cm/valid-image-types)) ([upload] (validate-media-type! upload cm/valid-image-types))
([upload allowed] ([upload allowed]

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

@ -10,6 +10,7 @@
[app.common.data :as d] [app.common.data :as d]
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.common.logging :as l] [app.common.logging :as l]
[app.common.schema :as sm]
[app.common.spec :as us] [app.common.spec :as us]
[app.config :as cf] [app.config :as cf]
[app.db :as db] [app.db :as db]
@ -74,14 +75,15 @@
etag (yrq/get-header request "if-none-match") etag (yrq/get-header request "if-none-match")
profile-id (or (::session/profile-id request) profile-id (or (::session/profile-id request)
(::actoken/profile-id request)) (::actoken/profile-id request))
data (-> params data (-> params
(assoc ::request-at (dt/now)) (assoc ::request-at (dt/now))
(assoc ::session/id (::session/id request)) (assoc ::session/id (::session/id request))
(assoc ::http/request request)
(assoc ::cond/key etag) (assoc ::cond/key etag)
(cond-> (uuid? profile-id) (cond-> (uuid? profile-id)
(assoc ::profile-id profile-id))) (assoc ::profile-id profile-id)))
data (vary-meta data assoc ::http/request request)
method (get methods type default-handler)] method (get methods type default-handler)]
(binding [cond/*enabled* true] (binding [cond/*enabled* true]
@ -127,9 +129,49 @@
(defn- wrap-spec-conform (defn- wrap-spec-conform
[_ f mdata] [_ f mdata]
(let [spec (or (::sv/spec mdata) (s/spec any?))] ;; 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] (fn [cfg params]
(f cfg (us/conform spec 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 (defn- wrap-all
[cfg f mdata] [cfg f mdata]
@ -141,6 +183,8 @@
(rlimit/wrap cfg $ mdata) (rlimit/wrap cfg $ mdata)
(wrap-audit cfg $ mdata) (wrap-audit cfg $ mdata)
(wrap-spec-conform cfg $ mdata) (wrap-spec-conform cfg $ mdata)
(wrap-output-validation cfg $ mdata)
(wrap-params-validation cfg $ mdata)
(wrap-authentication cfg $ mdata))) (wrap-authentication cfg $ mdata)))
(defn- wrap (defn- wrap

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

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

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

@ -11,6 +11,9 @@
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.common.pages.helpers :as cph] [app.common.pages.helpers :as cph]
[app.common.pages.migrations :as pmg] [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.spec :as us]
[app.common.types.components-list :as ctkl] [app.common.types.components-list :as ctkl]
[app.common.types.file :as ctf] [app.common.types.file :as ctf]
@ -19,7 +22,6 @@
[app.loggers.audit :as-alias audit] [app.loggers.audit :as-alias audit]
[app.loggers.webhooks :as-alias webhooks] [app.loggers.webhooks :as-alias webhooks]
[app.rpc :as-alias rpc] [app.rpc :as-alias rpc]
[app.rpc.commands.files.thumbnails :as-alias thumbs]
[app.rpc.commands.projects :as projects] [app.rpc.commands.projects :as projects]
[app.rpc.commands.teams :as teams] [app.rpc.commands.teams :as teams]
[app.rpc.cond :as-alias cond] [app.rpc.cond :as-alias cond]
@ -188,7 +190,7 @@
(ex/raise :type :restriction (ex/raise :type :restriction
:code :features-not-supported :code :features-not-supported
:feature (first 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)) features))
(defn load-pointer (defn load-pointer
@ -264,6 +266,41 @@
;; --- COMMAND QUERY: get-file (by id) ;; --- 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 (defn get-file
[conn id client-features] [conn id client-features]
;; here we check if client requested features are supported ;; here we check if client requested features are supported
@ -282,17 +319,14 @@
[{:keys [modified-at revn]}] [{:keys [modified-at revn]}]
(str (dt/format-instant modified-at :iso) "-" 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 (sv/defmethod ::get-file
"Retrieve a file by its ID. Only authenticated users." "Retrieve a file by its ID. Only authenticated users."
{::doc/added "1.17" {::doc/added "1.17"
::cond/get-object #(get-minimal-file %1 (:id %2)) ::cond/get-object #(get-minimal-file %1 (:id %2))
::cond/key-fn get-file-etag} ::cond/key-fn get-file-etag
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id features]}] ::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)] (dm/with-open [conn (db/open pool)]
(let [perms (get-permissions conn profile-id id)] (let [perms (get-permissions conn profile-id id)]
(check-read-permissions! perms) (check-read-permissions! perms)
@ -303,23 +337,29 @@
;; --- COMMAND QUERY: get-file-fragment (by id) ;; --- 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 (defn- get-file-fragment
[conn file-id fragment-id] [conn file-id fragment-id]
(some-> (db/get conn :file-data-fragment {:file-id file-id :id fragment-id}) (some-> (db/get conn :file-data-fragment {:file-id file-id :id fragment-id})
(update :content blob/decode))) (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 (sv/defmethod ::get-file-fragment
"Retrieve a file by its ID. Only authenticated users." "Retrieve a file by its ID. Only authenticated users."
{::doc/added "1.17" {::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] }] [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id fragment-id share-id] }]
(dm/with-open [conn (db/open pool)] (dm/with-open [conn (db/open pool)]
(let [perms (get-permissions conn profile-id file-id share-id)] (let [perms (get-permissions conn profile-id file-id share-id)]
@ -342,16 +382,16 @@
and f.deleted_at is null and f.deleted_at is null
order by f.modified_at desc") 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 (defn get-project-files
[conn project-id] [conn project-id]
(db/exec! conn [sql:project-files project-id])) (db/exec! conn [sql:project-files project-id]))
(sv/defmethod ::get-project-files (sv/defmethod ::get-project-files
"Get all files for the specified project." "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]}] [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id project-id]}]
(dm/with-open [conn (db/open pool)] (dm/with-open [conn (db/open pool)]
(projects/check-read-permissions! conn profile-id project-id) (projects/check-read-permissions! conn profile-id project-id)
@ -362,15 +402,12 @@
(declare get-has-file-libraries) (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 (sv/defmethod ::has-file-libraries
"Checks if the file has libraries. Returns a boolean" "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]}] [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id]}]
(dm/with-open [conn (db/open pool)] (dm/with-open [conn (db/open pool)]
(check-read-permissions! pool profile-id file-id) (check-read-permissions! pool profile-id file-id)
@ -408,6 +445,12 @@
(defn get-page (defn get-page
[conn {:keys [file-id page-id object-id features]}] [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) (let [file (get-file conn file-id features)
page-id (or page-id (-> file :data :pages first)) page-id (or page-id (-> file :data :pages first))
page (dm/get-in file [:data :pages-index page-id])] page (dm/get-in file [:data :pages-index page-id])]
@ -415,17 +458,11 @@
(uuid? object-id) (uuid? object-id)
(prune-objects object-id)))) (prune-objects object-id))))
(s/def ::page-id ::us/uuid) (sm/def! ::get-page
(s/def ::object-id ::us/uuid) [:map {:title "GetPage"}
(s/def ::get-page [:page-id {:optional true} ::sm/uuid]
(s/and [:object-id {:optional true} ::sm/uuid]
(s/keys :req [::rpc/profile-id] [:features {:optional true} ::features]])
:req-un [::file-id]
:opt-un [::page-id ::object-id ::features])
(fn [obj]
(if (contains? obj :object-id)
(contains? obj :page-id)
true))))
(sv/defmethod ::get-page (sv/defmethod ::get-page
"Retrieves the page data from file and returns it. If no page-id is "Retrieves the page data from file and returns it. If no page-id is
@ -437,7 +474,8 @@
mandatory. mandatory.
Mainly used for rendering purposes." 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}] [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id] :as params}]
(dm/with-open [conn (db/open pool)] (dm/with-open [conn (db/open pool)]
(check-read-permissions! conn profile-id file-id) (check-read-permissions! conn profile-id file-id)
@ -635,13 +673,30 @@
:modified-at (dt/now)} :modified-at (dt/now)}
{:id id})) {:id id}))
(s/def ::rename-file
(s/keys :req [::rpc/profile-id]
:req-un [::name ::id]))
(sv/defmethod ::rename-file (sv/defmethod ::rename-file
{::doc/added "1.17" {::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}] [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id] :as params}]
(db/with-atomic [conn pool] (db/with-atomic [conn pool]
(check-edition-permissions! conn profile-id id) (check-edition-permissions! conn profile-id id)
@ -673,6 +728,7 @@
(let [ldata (-> library decode-row pmg/migrate-file :data)] (let [ldata (-> library decode-row pmg/migrate-file :data)]
(binding [pmap/*load-fn* (partial load-pointer conn id)] (binding [pmap/*load-fn* (partial load-pointer conn id)]
(load-all-pointers! ldata)) (load-all-pointers! ldata))
(->> (db/query conn :file-library-rel {:library-file-id id}) (->> (db/query conn :file-library-rel {:library-file-id id})
(map :file-id) (map :file-id)
(keep #(db/get-by-id conn :file % ::db/check-deleted? false)) (keep #(db/get-by-id conn :file % ::db/check-deleted? false))

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

@ -40,21 +40,19 @@
:or {is-shared false revn 0 create-page true} :or {is-shared false revn 0 create-page true}
:as params}] :as params}]
(db/exec-one! conn ["SET CONSTRAINTS ALL DEFERRED;"])
(let [id (or id (uuid/next)) (let [id (or id (uuid/next))
features (->> features features (->> features
(into (files/get-default-features)) (into (files/get-default-features))
(files/check-features-compatibility!)) (files/check-features-compatibility!))
data (binding [pmap/*tracked* (atom {}) pointers (atom {})
data (binding [pmap/*tracked* pointers
ffeat/*current* features ffeat/*current* features
ffeat/*wrap-with-objects-map-fn* (if (features "storate/objects-map") omap/wrap identity) 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)] ffeat/*wrap-with-pointer-map-fn* (if (features "storage/pointer-map") pmap/wrap identity)]
(let [data (if create-page (if create-page
(ctf/make-file-data id) (ctf/make-file-data id)
(ctf/make-file-data id nil))] (ctf/make-file-data id nil)))
(files/persist-pointers! conn id)
data))
features (db/create-array conn "text" features) features (db/create-array conn "text" features)
file (db/insert! conn :file file (db/insert! conn :file
@ -70,6 +68,9 @@
:modified-at modified-at :modified-at modified-at
:deleted-at deleted-at}))] :deleted-at deleted-at}))]
(binding [pmap/*tracked* pointers]
(files/persist-pointers! conn id))
(->> (assoc params :file-id id :role :owner) (->> (assoc params :file-id id :role :owner)
(create-file-role! conn)) (create-file-role! conn))
@ -89,6 +90,7 @@
(sv/defmethod ::create-file (sv/defmethod ::create-file
{::doc/added "1.17" {::doc/added "1.17"
::doc/module :files
::webhooks/event? true} ::webhooks/event? true}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id project-id] :as params}] [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id project-id] :as params}]
(db/with-atomic [conn pool] (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 Share links are resources that allows external users access to specific
pages of a file with specific permissions (who-comment and who-inspect)." 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}] [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id] :as params}]
(db/with-atomic [conn pool] (db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id file-id) (files/check-edition-permissions! conn profile-id file-id)
@ -62,7 +63,8 @@
:req-un [::us/id])) :req-un [::us/id]))
(sv/defmethod ::delete-share-link (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}] [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id] :as params}]
(db/with-atomic [conn pool] (db/with-atomic [conn pool]
(let [slink (db/get-by-id conn :share-link id)] (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])) ::create-page]))
(sv/defmethod ::create-temp-file (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}] [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id project-id] :as params}]
(db/with-atomic [conn pool] (db/with-atomic [conn pool]
(projects/check-edition-permissions! conn profile-id project-id) (projects/check-edition-permissions! conn profile-id project-id)
@ -64,7 +65,8 @@
::files/id])) ::files/id]))
(sv/defmethod ::update-temp-file (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}] [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id] :as params}]
(db/with-atomic [conn pool] (db/with-atomic [conn pool]
(update-temp-file conn (assoc params :profile-id profile-id)) (update-temp-file conn (assoc params :profile-id profile-id))
@ -101,7 +103,8 @@
:req-un [::files/id])) :req-un [::files/id]))
(sv/defmethod ::persist-temp-file (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}] [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id] :as params}]
(db/with-atomic [conn pool] (db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id id) (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.exceptions :as ex]
[app.common.geom.shapes :as gsh] [app.common.geom.shapes :as gsh]
[app.common.pages.helpers :as cph] [app.common.pages.helpers :as cph]
[app.common.schema :as sm]
[app.common.spec :as us] [app.common.spec :as us]
[app.common.types.shape-tree :as ctt] [app.common.types.shape-tree :as ctt]
[app.config :as cf] [app.config :as cf]
@ -65,13 +66,12 @@
(or (some-> row :media-id get-public-uri) (or (some-> row :media-id get-public-uri)
(:data row)))))))) (: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 (sv/defmethod ::get-file-object-thumbnails
"Retrieve a file object thumbnails." "Retrieve a file object thumbnails."
{::doc/added "1.17" {::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/get-object #(files/get-minimal-file %1 (:file-id %2))
::cond/reuse-key? true ::cond/reuse-key? true
::cond/key-fn files/get-file-etag} ::cond/key-fn files/get-file-etag}
@ -102,6 +102,7 @@
:file-id (:file-id row)})) :file-id (:file-id row)}))
(s/def ::revn ::us/integer) (s/def ::revn ::us/integer)
(s/def ::file-id ::us/uuid)
(s/def ::get-file-thumbnail (s/def ::get-file-thumbnail
(s/keys :req [::rpc/profile-id] (s/keys :req [::rpc/profile-id]
@ -217,15 +218,18 @@
:always :always
(update :objects assoc-thumbnails page-id thumbs)))))) (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 (sv/defmethod ::get-file-data-for-thumbnail
"Retrieves the data for generate the thumbnail of the file. Used "Retrieves the data for generate the thumbnail of the file. Used
mainly for render thumbnails on dashboard." 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}] [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id features] :as props}]
(dm/with-open [conn (db/open pool)] (dm/with-open [conn (db/open pool)]
(files/check-read-permissions! conn profile-id file-id) (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.files.features :as ffeat]
[app.common.logging :as l] [app.common.logging :as l]
[app.common.pages :as cp] [app.common.pages :as cp]
[app.common.pages.changes :as cpc]
[app.common.pages.migrations :as pmg] [app.common.pages.migrations :as pmg]
[app.common.schema :as sm]
[app.common.schema.generators :as smg]
[app.common.spec :as us] [app.common.spec :as us]
[app.common.types.file :as ctf] [app.common.types.file :as ctf]
[app.common.uuid :as uuid] [app.common.uuid :as uuid]
@ -60,6 +63,40 @@
(or (contains? o :changes) (or (contains? o :changes)
(contains? o :changes-with-metadata))))) (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 ;; --- HELPERS
;; File changes that affect to the library, and must be notified ;; File changes that affect to the library, and must be notified
@ -130,6 +167,11 @@
::webhooks/event? true ::webhooks/event? true
::webhooks/batch-timeout (dt/duration "2m") ::webhooks/batch-timeout (dt/duration "2m")
::webhooks/batch-key (webhooks/key-fn ::rpc/profile-id :id) ::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"} ::doc/added "1.17"}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id] :as params}] [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id] :as params}]
(db/with-atomic [conn pool] (db/with-atomic [conn pool]

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

@ -8,8 +8,9 @@
(:require (:require
[app.auth :as auth] [app.auth :as auth]
[app.common.data :as d] [app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.common.spec :as us] [app.common.schema :as sm]
[app.common.uuid :as uuid] [app.common.uuid :as uuid]
[app.config :as cf] [app.config :as cf]
[app.db :as db] [app.db :as db]
@ -37,19 +38,35 @@
(declare strip-private-attrs) (declare strip-private-attrs)
(declare verify-password) (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 (def profile?
(s/keys :opt [::rpc/profile-id])) (sm/pred-fn schema:profile))
;; --- QUERY: Get profile (own)
(sv/defmethod ::get-profile (sv/defmethod ::get-profile
{::rpc/auth false {::rpc/auth false
::doc/added "1.18"} ::doc/added "1.18"
::sm/result schema:profile}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id]}] [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id]}]
;; We need to return the anonymous profile object in two cases, when ;; 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 ;; no profile-id is in session, and when db call raises not found. In all other
;; cases we need to reraise the exception. ;; cases we need to reraise the exception.
(try (try
(-> (get-profile pool profile-id) (-> (get-profile pool profile-id)
(strip-private-attrs) (strip-private-attrs)
@ -63,22 +80,21 @@
(-> (db/get-by-id conn :profile id attrs) (-> (db/get-by-id conn :profile id attrs)
(decode-row))) (decode-row)))
;; --- MUTATION: Update Profile (own) ;; --- 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 (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}] [{: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] (db/with-atomic [conn pool]
;; NOTE: we need to retrieve the profile independently if we use ;; NOTE: we need to retrieve the profile independently if we use
;; it or not for explicit locking and avoid concurrent updates of ;; it or not for explicit locking and avoid concurrent updates of
@ -112,14 +128,13 @@
(declare update-profile-password!) (declare update-profile-password!)
(declare invalidate-profile-session!) (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 (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}] [{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id password] :as params}]
(db/with-atomic [conn pool] (db/with-atomic [conn pool]
(let [cfg (assoc cfg ::db/conn conn) (let [cfg (assoc cfg ::db/conn conn)
@ -163,12 +178,11 @@
(declare upload-photo) (declare upload-photo)
(declare update-profile-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 (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}] [cfg {:keys [::rpc/profile-id file] :as params}]
;; Validate incoming mime type ;; Validate incoming mime type
(media/validate-media-type! file #{"image/jpeg" "image/png" "image/webp"}) (media/validate-media-type! file #{"image/jpeg" "image/png" "image/webp"})

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

@ -8,57 +8,197 @@
"API autogenerated documentation." "API autogenerated documentation."
(:require (:require
[app.common.data :as d] [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.config :as cf]
[app.loggers.webhooks :as-alias webhooks] [app.loggers.webhooks :as-alias webhooks]
[app.rpc :as-alias rpc] [app.rpc :as-alias rpc]
[app.util.json :as json]
[app.util.services :as sv] [app.util.services :as sv]
[app.util.template :as tmpl] [app.util.template :as tmpl]
[clojure.java.io :as io] [clojure.java.io :as io]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[cuerdas.core :as str] [cuerdas.core :as str]
[integrant.core :as ig] [integrant.core :as ig]
[malli.transform :as mt]
[pretty-spec.core :as ps] [pretty-spec.core :as ps]
[yetti.response :as yrs])) [yetti.response :as yrs]))
(defn- get-spec-str ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[k] ;; DOC (human readable)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- prepare-doc-context
[methods]
(letfn [(fmt-spec [mdata]
(when-let [spec (ex/ignoring (s/spec (::sv/spec mdata)))]
(with-out-str (with-out-str
(ps/pprint (s/form k) (ps/pprint (s/form spec)
{:ns-aliases {"clojure.spec.alpha" "s" {:ns-aliases {"clojure.spec.alpha" "s"
"clojure.core.specs.alpha" "score" "clojure.core.specs.alpha" "score"
"clojure.core" nil}}))) "clojure.core" nil}}))))
(defn- prepare-context (fmt-schema [type mdata key]
[methods] (when-let [schema (get mdata key)]
(letfn [(gen-doc [[{:keys [::sv/name] :as mdata} _f]] (if (= type :js)
{:name (d/name name) (smdj/describe (sm/schema schema) {::smdj/max-level 4})
:module (-> (:ns mdata) (str/split ".") last) (-> (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) :auth (:auth mdata true)
:webhook (::webhooks/event? mdata false) :webhook (::webhooks/event? mdata false)
:docs (::sv/docstring mdata) :docs (::sv/docstring mdata)
:deprecated (::deprecated mdata) :deprecated (::deprecated mdata)
:added (::added mdata) :added (::added mdata)
:changes (some->> (::changes mdata) (partition-all 2) (map vec)) :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) {:version (:main cf/version)
:methods :methods
(->> methods (->> methods
(map val) (map val)
(map gen-doc) (map first)
(map get-context)
(sort-by (juxt :module :name)))})) (sort-by (juxt :module :name)))}))
(defn- handler (defn- doc-handler
[methods] [context]
(if (contains? cf/flags :backend-api-doc) (if (contains? cf/flags :backend-api-doc)
(let [context (prepare-context methods)] (fn [request]
(fn [_] (let [params (:query-params request)
pstyle (:type params "js")
context (assoc context :param-style pstyle)]
{::yrs/status 200 {::yrs/status 200
::yrs/body (-> (io/resource "app/templates/api-doc.tmpl") ::yrs/body (-> (io/resource "app/templates/api-doc.tmpl")
(tmpl/render context))})) (tmpl/render context))}))
(fn [_] (fn [_]
{::yrs/status 404}))) {::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?) (s/def ::routes vector?)
(defmethod ig/pre-init-spec ::routes [_] (defmethod ig/pre-init-spec ::routes [_]
@ -66,6 +206,18 @@
(defmethod ig/init-key ::routes (defmethod ig/init-key ::routes
[_ {:keys [methods] :as cfg}] [_ {:keys [methods] :as cfg}]
["/_doc" {:handler (handler methods) [(let [context (prepare-doc-context methods)]
:allowed-methods #{:get}}]) [["/_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." "A permission checking helper factories."
(:require (:require
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.common.schema :as sm]
[app.common.spec :as us] [app.common.spec :as us]
[clojure.spec.alpha :as s])) [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}) (s/def ::role #{:admin :owner :editor :viewer})
(defn assign-role-flags (defn assign-role-flags

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

@ -212,10 +212,11 @@
(into [] (map #(assoc % ::service sname)) limits))) (into [] (map #(assoc % ::service sname)) limits)))
(defn- get-uid (defn- get-uid
[{:keys [::http/request] :as params}] [{:keys [::rpc/profile-id] :as params}]
(or (::rpc/profile-id params) (let [request (-> params meta ::http/request)]
(or profile-id
(some-> request parse-client-ip) (some-> request parse-client-ip)
uuid/zero)) uuid/zero)))
(defn process-request! (defn process-request!
[{:keys [::rpc/rlimit ::rds/redis ::skey ::sname] :as cfg} params] [{: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 (defn write-char
[n w o] [n w o]
(write-tag! w n 1) (write-tag! w n 1)
(write-int! w o)) (write-int! w (int o)))
(defn read-char (defn read-char
[rdr] [rdr]
@ -259,8 +259,8 @@
:rfn (comp vec read-object!)} :rfn (comp vec read-object!)}
{:name "clj/list" {:name "clj/list"
:class clojure.lang.IPersistentList ;; :class clojure.lang.IPersistentList
:wfn write-list-like ;; :wfn write-list-like
:rfn #(apply list (read-object! %))} :rfn #(apply list (read-object! %))}
{:name "clj/seq" {:name "clj/seq"

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

@ -8,8 +8,11 @@
(:require (:require
[app.common.data.macros :as dm] [app.common.data.macros :as dm]
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.common.schema :as sm]
[app.common.schema.openapi :as-alias oapi]
[app.common.time :as common-time] [app.common.time :as common-time]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[clojure.test.check.generators :as tgen]
[cuerdas.core :as str] [cuerdas.core :as str]
[fipp.ednize :as fez]) [fipp.ednize :as fez])
(:import (:import
@ -358,3 +361,27 @@
[] []
(let [p1 (System/nanoTime)] (let [p1 (System/nanoTime)]
#(duration {:nanos (- (System/nanoTime) p1)}))) #(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) proj-id (:default-project-id prof)
params {::th/type :push-audit-events params {::th/type :push-audit-events
:app.http/request http-request
::rpc/profile-id (:id prof) ::rpc/profile-id (:id prof)
:events [{:name "navigate" :events [{:name "navigate"
:props {:project-id proj-id :props {:project-id proj-id
@ -47,6 +46,9 @@
:profile-id (:id prof) :profile-id (:id prof)
:timestamp (dt/now) :timestamp (dt/now)
:type "action"}]} :type "action"}]}
params (with-meta params
{:app.http/request http-request})
out (th/command! params)] out (th/command! params)]
;; (th/print-result! out) ;; (th/print-result! out)
(t/is (nil? (:error out))) (t/is (nil? (:error out)))
@ -67,7 +69,6 @@
proj-id (:default-project-id prof) proj-id (:default-project-id prof)
params {::th/type :push-audit-events params {::th/type :push-audit-events
:app.http/request http-request
::rpc/profile-id (:id prof) ::rpc/profile-id (:id prof)
:events [{:name "navigate" :events [{:name "navigate"
:props {:project-id proj-id :props {:project-id proj-id
@ -77,6 +78,8 @@
:profile-id uuid/zero :profile-id uuid/zero
:timestamp (dt/now) :timestamp (dt/now)
:type "action"}]} :type "action"}]}
params (with-meta params
{:app.http/request http-request})
out (th/command! params)] out (th/command! params)]
;; (th/print-result! out) ;; (th/print-result! out)
(t/is (nil? (:error out))) (t/is (nil? (:error out)))

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

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

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

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

2
common/deps.edn
View file

@ -18,6 +18,8 @@
selmer/selmer {:mvn/version "1.12.55"} selmer/selmer {:mvn/version "1.12.55"}
criterium/criterium {:mvn/version "0.4.6"} criterium/criterium {:mvn/version "0.4.6"}
metosin/malli {:mvn/version "0.11.0"}
expound/expound {:mvn/version "0.9.0"} expound/expound {:mvn/version "0.9.0"}
com.cognitect/transit-clj {:mvn/version "1.0.329"} com.cognitect/transit-clj {:mvn/version "1.0.329"}
com.cognitect/transit-cljs {:mvn/version "0.8.280"} 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]) :clj [clojure.edn :as r])
#?(:cljs [cljs.core :as c] #?(:cljs [cljs.core :as c]
:clj [clojure.core :as c]) :clj [clojure.core :as c])
[app.common.exceptions :as ex]
[app.common.math :as mth] [app.common.math :as mth]
[clojure.set :as set] [clojure.set :as set]
[cuerdas.core :as str] [cuerdas.core :as str]
@ -539,7 +538,10 @@
(defn parse-uuid (defn parse-uuid
[v] [v]
(ex/ignoring (c/parse-uuid v))) (try
(c/parse-uuid v)
(catch #?(:clj Throwable :cljs :default) _
nil)))
(defn num-string? [v] (defn num-string? [v]
;; https://stackoverflow.com/questions/175739/built-in-way-in-javascript-to-check-if-a-string-is-a-valid-number ;; 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))])) [key (delay (generator-fn key))]))
keys)) 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 ;; Util protocols
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

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

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

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

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

@ -7,12 +7,12 @@
(ns app.common.geom.align (ns app.common.geom.align
(:require (:require
[app.common.geom.shapes :as gsh] [app.common.geom.shapes :as gsh]
[app.common.pages.helpers :refer [get-children]] [app.common.pages.helpers :refer [get-children]]))
[clojure.spec.alpha :as s]))
;; --- Alignment ;; --- 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) (declare calc-align-pos)
@ -65,7 +65,8 @@
;; --- Distribute ;; --- Distribute
(s/def ::dist-axis #{:horizontal :vertical}) (def valid-dist-axis
#{:horizontal :vertical})
(defn distribute-space (defn distribute-space
"Distribute equally the space between shapes in the given axis. If "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.data.macros :as dm]
[app.common.geom.point :as gpt] [app.common.geom.point :as gpt]
[app.common.math :as mth] [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] [app.common.spec :as us]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]))
[clojure.test.check.generators :as tgen]))
(def precision 6) (def precision 6)
@ -47,6 +49,58 @@
([a b c d e f] ([a b c d e f]
(Matrix. 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 ::a ::us/safe-float)
(s/def ::b ::us/safe-float) (s/def ::b ::us/safe-float)
(s/def ::c ::us/safe-float) (s/def ::c ::us/safe-float)
@ -58,18 +112,8 @@
(s/keys :req-un [::a ::b ::c ::d ::e ::f])) (s/keys :req-un [::a ::b ::c ::d ::e ::f]))
(s/def ::matrix (s/def ::matrix
(s/with-gen (s/and ::matrix-attrs matrix?))
(s/and ::matrix-attrs matrix?)
#(tgen/fmap map->Matrix (s/gen ::matrix-attrs))))
(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? (defn close?
[^Matrix m1 ^Matrix m2] [^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.data.macros :as dm]
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.common.math :as mth] [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] [app.common.spec :as us]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[clojure.test.check.generators :as tgen])) [cuerdas.core :as str]))
;; --- Point Impl ;; --- Point Impl
@ -32,6 +35,13 @@
[v] [v]
(instance? Point 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 ::x ::us/safe-number)
(s/def ::y ::us/safe-number) (s/def ::y ::us/safe-number)
@ -39,8 +49,33 @@
(s/keys :req-un [::x ::y])) (s/keys :req-un [::x ::y]))
(s/def ::point (s/def ::point
(s/with-gen (s/and ::point-attrs point?) (s/and ::point-attrs point?))
#(tgen/fmap map->Point (s/gen ::point-attrs))))
(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? (defn point-like?
[{:keys [x y] :as v}] [{: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.points :as gpo]
[app.common.geom.shapes.transforms :as gtr] [app.common.geom.shapes.transforms :as gtr]
[app.common.pages.helpers :as cph] [app.common.pages.helpers :as cph]
[app.common.spec :as us]
[app.common.types.modifiers :as ctm] [app.common.types.modifiers :as ctm]
[app.common.types.shape.layout :as ctl] [app.common.types.shape.layout :as ctl]
[app.common.uuid :as uuid])) [app.common.uuid :as uuid]))
@ -43,10 +42,7 @@
(defn resolve-tree-sequence (defn resolve-tree-sequence
"Given the ids that have changed search for layout roots to recalculate" "Given the ids that have changed search for layout roots to recalculate"
[ids objects] [ids objects]
(dm/assert! (or (nil? ids) (set? ids)))
(us/assert!
:expr (or (nil? ids) (set? ids))
:hint (dm/str "tree sequence from not set: " ids))
(let [get-tree-root (let [get-tree-root
(fn ;; Finds the tree root for the current id (fn ;; Finds the tree root for the current id

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

@ -14,18 +14,223 @@
[app.common.math :as mth] [app.common.math :as mth]
[app.common.pages.common :refer [component-sync-attrs]] [app.common.pages.common :refer [component-sync-attrs]]
[app.common.pages.helpers :as cph] [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.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.component :as ctk]
[app.common.types.components-list :as ctkl] [app.common.types.components-list :as ctkl]
[app.common.types.container :as ctn] [app.common.types.container :as ctn]
[app.common.types.colors-list :as ctcl]
[app.common.types.file :as ctf] [app.common.types.file :as ctf]
[app.common.types.page :as ctp] [app.common.types.page :as ctp]
[app.common.types.pages-list :as ctpl] [app.common.types.pages-list :as ctpl]
[app.common.types.shape :as cts] [app.common.types.shape :as cts]
[app.common.types.shape-tree :as ctst] [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 ;; Page Transformation Changes
@ -37,8 +242,9 @@
[data objects items] [data objects items]
(letfn [(validate-shape! [[page-id {:keys [id] :as shape}]] (letfn [(validate-shape! [[page-id {:keys [id] :as shape}]]
(when-not (= shape (dm/get-in data [:pages-index page-id :objects id])) (when-not (= shape (dm/get-in data [:pages-index page-id :objects id]))
;; If object has change verify is correct ;; If object has changed verify is correct
(us/verify ::cts/shape shape)))] (dm/verify! (cts/shape? shape))))]
(let [lookup (d/getf objects)] (let [lookup (d/getf objects)]
(->> (into #{} (map :page-id) items) (->> (into #{} (map :page-id) items)
(mapcat (fn [page-id] (mapcat (fn [page-id]
@ -64,7 +270,7 @@
;; When verify? false we spec the schema validation. Currently used to make just ;; When verify? false we spec the schema validation. Currently used to make just
;; 1 validation even if the changes are applied twice ;; 1 validation even if the changes are applied twice
(when verify? (when verify?
(us/assert ::pcs/changes items)) (dm/verify! (changes? items)))
(let [result (reduce #(or (process-change %1 %2) %1) data items)] (let [result (reduce #(or (process-change %1 %2) %1) data items)]
;; Validate result shapes (only on the backend) ;; Validate result shapes (only on the backend)
@ -127,6 +333,7 @@
(d/update-in-when data [:pages-index page-id] ctst/delete-shape id ignore-touched) (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))) (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 ;; reg-objects operation "regenerates" the geometry and selrect of the parent groups
(defmethod process-change :reg-objects (defmethod process-change :reg-objects
[data {:keys [page-id component-id shapes]}] [data {:keys [page-id component-id shapes]}]
@ -412,8 +619,7 @@
(and in-copy? group (not ignore) (not equal?) (and in-copy? group (not ignore) (not equal?)
(not root-name?) (not root-name?)
(not (and ignore-geometry is-geometry?))) (not (and ignore-geometry is-geometry?)))
(-> (-> (update :touched cph/set-touched-group group)
(update :touched cph/set-touched-group group)
(dissoc :remote-synced?)) (dissoc :remote-synced?))
(nil? val) (nil? val)
@ -444,7 +650,6 @@
:code :operation-not-implemented :code :operation-not-implemented
:context {:type (:type op)})) :context {:type (:type op)}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Component changes detection ;; 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-id main-instance-id
:main-instance-page main-instance-page} :main-instance-page main-instance-page}
(some? new-shapes) ;; this will be null in components-v2 (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)))) (into (map mk-change) updated-shapes))))
(update :undo-changes (update :undo-changes
(fn [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 (:require
[app.common.colors :as clr] [app.common.colors :as clr]
[app.common.data :as d] [app.common.data :as d]
[app.common.spec :as us] [app.common.data.macros :as dm]
[app.common.uuid :as uuid] [app.common.schema :as sm]
[clojure.spec.alpha :as s])) [app.common.uuid :as uuid]))
(def file-version 20) (def file-version 20)
(def default-color clr/gray-20) (def default-color clr/gray-20)
@ -601,14 +601,16 @@
[p1 (+ 1 (d/parse-integer p2))] [p1 (+ 1 (d/parse-integer p2))]
[basename 1])) [basename 1]))
(s/def ::set-of-strings
(s/every ::us/string :kind set?))
(defn generate-unique-name (defn generate-unique-name
"A unique name generator" "A unique name generator"
[used basename] [used basename]
(us/assert! ::set-of-strings used) (dm/assert!
(us/assert! ::us/string basename) "expected a set of strings"
(sm/set-of-strings? used))
(dm/assert!
"expected a string for `basename`."
(string? basename))
(if-not (contains? used basename) (if-not (contains? used basename)
basename basename
(let [[prefix initial] (extract-numeric-suffix basename)] (let [[prefix initial] (extract-numeric-suffix basename)]

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

@ -8,7 +8,6 @@
(:require (:require
[app.common.data :as d] [app.common.data :as d]
[app.common.data.macros :as dm] [app.common.data.macros :as dm]
[app.common.spec :as us]
[app.common.types.components-list :as ctkl] [app.common.types.components-list :as ctkl]
[app.common.types.pages-list :as ctpl] [app.common.types.pages-list :as ctpl]
[app.common.types.shape.layout :as ctl] [app.common.types.shape.layout :as ctl]
@ -286,9 +285,9 @@
(defn get-container (defn get-container
[file type id] [file type id]
(us/assert map? file) (dm/assert! (map? file))
(us/assert keyword? type) (dm/assert! (keyword? type))
(us/assert uuid? id) (dm/assert! (uuid? id))
(-> (if (= type :page) (-> (if (= type :page)
(ctpl/get-page file id) (ctpl/get-page file id)

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

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

@ -7,93 +7,99 @@
(ns app.common.types.color (ns app.common.types.color
(:require (:require
[app.common.data :as d] [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.text :as txt]
[app.common.types.color.generic :as-alias color-generic] [app.common.types.color.generic :as-alias color-generic]
[app.common.types.color.gradient :as-alias color-gradient] [app.common.types.color.gradient :as-alias color-gradient]
[app.common.types.color.gradient.stop :as-alias color-gradient-stop] [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}) (sm/def! ::rgb-color
(s/def ::color-gradient/start-x ::us/safe-number) {:type ::rgb-color
(s/def ::color-gradient/start-y ::us/safe-number) :pred #(and (string? %) (some? (re-matches rgb-color-re %)))
(s/def ::color-gradient/end-x ::us/safe-number) :type-properties
(s/def ::color-gradient/end-y ::us/safe-number) {:title "rgb-color"
(s/def ::color-gradient/width ::us/safe-number) :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) ::oapi/type "integer"
(s/def ::color-gradient-stop/opacity ::us/safe-number) ::oapi/format "int64"}})
(s/def ::color-gradient-stop/offset ::us/safe-number)
(s/def ::color-gradient/stop (sm/def! ::gradient
(s/keys :req-un [::color-gradient-stop/color [:map {:title "Gradient"}
::color-gradient-stop/opacity [:type [::sm/one-of #{:linear :radial}]]
::color-gradient-stop/offset])) [: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 (sm/def! ::color
(s/coll-of ::color-gradient/stop :kind vector?)) [: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?) (def color?
(s/def ::color-generic/path (s/nilable string?)) (sm/pred-fn ::color))
(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)
(s/def ::shape-color (def recent-color?
(s/keys :req-un [:us/color (sm/pred-fn ::recent-color))
::color-generic/opacity]
:opt-un [::color-generic/gradient
::color-generic/ref-id
::color-generic/ref-file]))
(s/def ::color ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/keys :opt-un [::id ;; HELPERS
::color-generic/name ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
::color-generic/path
::color-generic/value
::color-generic/color
::color-generic/opacity
::color-generic/gradient
::color-generic/modified-at]))
(s/def ::recent-color ;; --- fill
(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
(defn fill->shape-color (defn fill->shape-color
[fill] [fill]
(d/without-nils {:color (:fill-color fill) (d/without-nils
{:color (:fill-color fill)
:opacity (:fill-opacity fill) :opacity (:fill-opacity fill)
:gradient (:fill-color-gradient fill) :gradient (:fill-color-gradient fill)
:ref-id (:fill-color-ref-id fill) :ref-id (:fill-color-ref-id fill)

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

@ -6,26 +6,42 @@
(ns app.common.types.container (ns app.common.types.container
(:require (:require
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt] [app.common.geom.point :as gpt]
[app.common.geom.shapes :as gsh] [app.common.geom.shapes :as gsh]
[app.common.pages.common :as common] [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.component :as ctk]
[app.common.types.components-list :as ctkl] [app.common.types.components-list :as ctkl]
[app.common.types.pages-list :as ctpl] [app.common.types.pages-list :as ctpl]
[app.common.types.shape :as cts]
[app.common.types.shape-tree :as ctst] [app.common.types.shape-tree :as ctst]
[app.common.uuid :as uuid] [app.common.uuid :as uuid]))
[clojure.spec.alpha :as s]))
(s/def ::type #{:page :component}) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::id uuid?) ;; SCHEMA
(s/def ::name ::us/string) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::path (s/nilable ::us/string))
(s/def ::modified-at ::us/inst)
(s/def ::container (def valid-container-types
(s/keys :req-un [::id ::name] #{:page :component})
:opt-un [::type ::path ::modified-at ::ctst/objects]))
(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 (defn make-container
[page-or-component type] [page-or-component type]
@ -41,9 +57,9 @@
(defn get-container (defn get-container
[file type id] [file type id]
(us/assert map? file) (dm/assert! (map? file))
(us/assert ::type type) (dm/assert! (contains? valid-container-types type))
(us/assert uuid? id) (dm/assert! (uuid? id))
(-> (if (= type :page) (-> (if (= type :page)
(ctpl/get-page file id) (ctpl/get-page file id)
@ -52,8 +68,14 @@
(defn get-shape (defn get-shape
[container shape-id] [container shape-id]
(us/assert ::container container) (dm/assert!
(us/assert ::us/uuid shape-id) "expected valid container"
(container? container))
(dm/assert!
"expected valid uuid for `shape-id`"
(uuid? shape-id))
(-> container (-> container
(get :objects) (get :objects)
(get shape-id))) (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.geom.shapes :as gsh]
[app.common.pages.common :refer [file-version]] [app.common.pages.common :refer [file-version]]
[app.common.pages.helpers :as cph] [app.common.pages.helpers :as cph]
[app.common.schema :as sm]
[app.common.types.color :as ctc] [app.common.types.color :as ctc]
[app.common.types.colors-list :as ctcl] [app.common.types.colors-list :as ctcl]
[app.common.types.component :as ctk] [app.common.types.component :as ctk]
[app.common.types.components-list :as ctkl] [app.common.types.components-list :as ctkl]
[app.common.types.container :as ctn] [app.common.types.container :as ctn]
[app.common.types.file.media-object :as ctfm]
[app.common.types.page :as ctp] [app.common.types.page :as ctp]
[app.common.types.pages-list :as ctpl] [app.common.types.pages-list :as ctpl]
[app.common.types.shape-tree :as ctst] [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 cty] [app.common.types.typography :as cty]
[app.common.uuid :as uuid] [app.common.uuid :as uuid]
[clojure.spec.alpha :as s]
[cuerdas.core :as str])) [cuerdas.core :as str]))
;; Specs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SCHEMA
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::colors (sm/def! ::media-object
(s/map-of uuid? ::ctc/color)) [: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 (sm/def! ::data
(s/coll-of ::ctc/recent-color :kind vector?)) [: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 (def file-data?
(s/map-of uuid? ::cty/typography)) (sm/pred-fn ::data))
(s/def ::pages (def media-object?
(s/coll-of uuid? :kind vector?)) (sm/pred-fn ::media-object))
(s/def ::media ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/map-of uuid? ::ctfm/media-object)) ;; INITIALIZATION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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
(def empty-file-data (def empty-file-data
{:version file-version {:version file-version
@ -429,6 +434,7 @@
(some? (:component-file %)) (some? (:component-file %))
(assoc :component-file (:id file-data))) (assoc :component-file (:id file-data)))
main-instance-shapes) main-instance-shapes)
; Add all shapes of the main instance to the library page ; Add all shapes of the main instance to the library page
add-main-instance-shapes add-main-instance-shapes
(fn [page] (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]])

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

@ -17,7 +17,6 @@
[app.common.geom.shapes.strokes :as gss] [app.common.geom.shapes.strokes :as gss]
[app.common.math :as mth] [app.common.math :as mth]
[app.common.pages.helpers :as cph] [app.common.pages.helpers :as cph]
[app.common.spec :as us]
[app.common.text :as txt] [app.common.text :as txt]
[app.common.types.shape.layout :as ctl] [app.common.types.shape.layout :as ctl]
#?(:cljs [cljs.core :as c] #?(:cljs [cljs.core :as c]
@ -462,9 +461,9 @@
(change-dimensions-modifiers shape attr value nil)) (change-dimensions-modifiers shape attr value nil))
([{:keys [transform transform-inverse] :as shape} attr value {:keys [ignore-lock?] :or {ignore-lock? false}}] ([{:keys [transform transform-inverse] :as shape} attr value {:keys [ignore-lock?] :or {ignore-lock? false}}]
(us/assert map? shape) (dm/assert! (map? shape))
(us/assert #{:width :height} attr) (dm/assert! (#{:width :height} attr))
(us/assert number? value) (dm/assert! (number? value))
(let [{:keys [proportion proportion-lock]} shape (let [{:keys [proportion proportion-lock]} shape
size (select-keys (:selrect shape) [:width :height]) size (select-keys (:selrect shape) [:width :height])
@ -491,8 +490,11 @@
(defn change-orientation-modifiers (defn change-orientation-modifiers
[shape orientation] [shape orientation]
(us/assert map? shape) (dm/assert! (map? shape))
(us/verify #{:horiz :vert} orientation) (dm/assert!
"expected a valid orientation"
(#{:horiz :vert} orientation))
(let [width (:width shape) (let [width (:width shape)
height (:height shape) height (:height shape)
new-width (if (= orientation :horiz) (max width height) (min width height)) new-width (if (= orientation :horiz) (max width height) (min width height))

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

@ -8,34 +8,56 @@
(:require (:require
[app.common.data :as d] [app.common.data :as d]
[app.common.files.features :as ffeat] [app.common.files.features :as ffeat]
[app.common.spec :as us] [app.common.schema :as sm]
[app.common.types.page.flow :as ctpf] [app.common.types.color :as-alias ctc]
[app.common.types.page.grid :as ctpg] [app.common.types.grid :as ctg]
[app.common.types.page.guide :as ctpu]
[app.common.types.shape :as cts] [app.common.types.shape :as cts]
[app.common.uuid :as uuid] [app.common.uuid :as uuid]))
[clojure.spec.alpha :as s]))
;; --- 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 (sm/def! ::guide
(s/keys :opt-un [::background [:map {:title "PageGuide"}
::ctpg/saved-grids [:id ::sm/uuid]
::ctpf/flows [:axis [::sm/one-of #{:x :y}]]
::ctpu/guides])) [:position ::sm/safe-number]
[:frame-id {:optional true} [:maybe ::sm/uuid]]])
;; --- Page (def guide?
(sm/pred-fn ::guide))
(s/def ::id uuid?) (sm/def! ::page
(s/def ::name string?) [:map {:title "FilePage"}
(s/def ::objects (s/map-of uuid? ::cts/shape)) [: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 (def page?
(s/keys :req-un [::id ::name ::objects ::options])) (sm/pred-fn ::page))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INIT & HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- Initialization ;; --- Initialization
@ -80,6 +102,3 @@
(defn get-frame-flow (defn get-frame-flow
[flows frame-id] [flows frame-id]
(d/seek #(= (:starting-frame %) frame-id) flows)) (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.point :as gpt]
[app.common.geom.shapes :as gsh] [app.common.geom.shapes :as gsh]
[app.common.pages.common :refer [default-color]] [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.color :as ctc]
[app.common.types.grid :as ctg]
[app.common.types.shape.blur :as ctsb] [app.common.types.shape.blur :as ctsb]
[app.common.types.shape.export :as ctse] [app.common.types.shape.export :as ctse]
[app.common.types.shape.interactions :as ctsi] [app.common.types.shape.interactions :as ctsi]
[app.common.types.shape.layout :as ctsl] ;; FIXME: missing spec -> schema
[app.common.types.shape.path :as ctsp] #_[app.common.types.shape.layout :as ctsl]
[app.common.types.shape.radius :as ctsr]
[app.common.types.shape.shadow :as ctss] [app.common.types.shape.shadow :as ctss]
[app.common.types.shape.text :as ctsx] [app.common.types.shape.text :as ctsx]
[app.common.uuid :as uuid] [app.common.uuid :as uuid]
[clojure.set :as set] [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})
(def stroke-caps-line #{:round :square}) (def stroke-caps-line #{:round :square})
(def stroke-caps-marker #{:line-arrow :triangle-arrow :square-marker :circle-marker :diamond-marker}) (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)) (def stroke-caps (set/union stroke-caps-line stroke-caps-marker))
(s/def ::stroke-cap-start stroke-caps) (def blend-mode
(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
#{:normal #{:normal
:darken :darken
:multiply :multiply
@ -166,102 +48,235 @@
:color :color
:luminosity}) :luminosity})
(s/def ::shape-base-attrs (def horizontal-constraint-types
(s/keys :opt-un [::id #{:left :right :leftright :center :scale})
::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]))
(s/def ::shape-attrs (def vertical-constraint-types
(s/with-gen #{:top :bottom :topbottom :center :scale})
(s/merge
::shape-base-attrs
::ctsl/layout-container-props
::ctsl/layout-child-props
;; For BACKWARD COMPATIBILITY we need to spec fill and stroke (def text-align-types
;; attrs as shape toplevel attrs #{"left" "right" "center" "justify"})
::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))))
(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 [_] (sm/def! ::points
(s/spec ::shape-attrs)) [:vector {:gen/max 5} ::gpt/point])
(defmethod shape-spec :text [_] (sm/def! ::fill
(s/merge ::shape-attrs [:map {:title "Fill" :min 1}
(s/keys :opt-un [::ctsx/content [:fill-color {:optional true} ::ctc/rgb-color]
::ctsx/position-data]))) [: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 [_] (sm/def! ::stroke
(s/merge ::shape-attrs [:map {:title "Stroke"}
(s/keys :opt-un [::ctsp/content]))) [: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 [_] (sm/def! ::shape-attrs
(s/merge ::shape-attrs [:map {:title "ShapeAttrs"}
(s/keys :opt-un [::file-thumbnail [:name {:optional true} :string]
::hide-fill-on-export [:component-id {:optional true} ::sm/uuid]
::show-content [:component-file {:optional true} ::sm/uuid]
::hide-in-viewer]))) [: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 (def shape-attrs?
(s/with-gen (sm/pred-fn ::shape-attrs))
(s/merge
(s/keys :req-un [::type ::name]) (sm/def! ::group-attrs
(s/multi-spec shape-spec :type)) [:map {:title "GroupAttrs"}
(fn [] [:type [:= :group]]
(tgen/let [type (s/gen ::type) [:id ::sm/uuid]
name (s/gen ::name) [:shapes [:vector {:min 1 :gen/max 10 :gen/min 1} ::sm/uuid]]])
attrs (s/gen ::shape-attrs)]
(assoc attrs :type type :name name))))) (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 ;; --- Initialization
@ -311,11 +326,6 @@
:fills [{:fill-color clr/white :fills [{:fill-color clr/white
:fill-opacity 1}] :fill-opacity 1}]
:strokes [] :strokes []
:stroke-style :none
:stroke-alignment :center
:stroke-width 0
:stroke-color clr/black
:stroke-opacity 0
:rx 0 :rx 0
:ry 0} :ry 0}

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

@ -6,9 +6,14 @@
(ns app.common.types.shape.blur (ns app.common.types.shape.blur
(:require (:require
[app.common.schema :as sm]
[app.common.spec :as us] [app.common.spec :as us]
[clojure.spec.alpha :as s])) [clojure.spec.alpha :as s]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SPEC
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::id uuid?) (s/def ::id uuid?)
(s/def ::type #{:layer-blur}) (s/def ::type #{:layer-blur})
(s/def ::value ::us/safe-number) (s/def ::value ::us/safe-number)
@ -17,3 +22,13 @@
(s/def ::blur (s/def ::blur
(s/keys :req-un [::id ::type ::value ::hidden])) (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 (ns app.common.types.shape.export
(:require (:require
[app.common.spec :as us] [app.common.schema :as sm]))
[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]))
(sm/def! ::export
[:map {:title "ShapeExport"}
[:type :keyword]
[:scale ::sm/safe-number]
[:suffix :string]])

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

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

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

@ -8,9 +8,10 @@
(:require (:require
[app.common.data :as d] [app.common.data :as d]
[app.common.data.macros :as dm] [app.common.data.macros :as dm]
[app.common.spec :as us] [app.common.schema :as sm]
[app.common.uuid :as uuid] [app.common.uuid :as uuid]))
[clojure.spec.alpha :as s]))
;; FIXME: need proper schemas
;; :layout ;; :flex, :grid in the future ;; :layout ;; :flex, :grid in the future
;; :layout-flex-dir ;; :row, :row-reverse, :column, :column-reverse ;; :layout-flex-dir ;; :row, :row-reverse, :column, :column-reverse
@ -40,114 +41,144 @@
;; :layout-item-absolute ;; :layout-item-absolute
;; :layout-item-z-index ;; :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 (def flex-direction-types
(s/def ::layout-grid-dir #{:row :column}) #{:row :reverse-row :row-reverse :column :reverse-column :column-reverse}) ;;TODO remove reverse-column and reverse-row after script
(s/def ::layout-gap-type #{:simple :multiple})
(s/def ::layout-gap ::us/safe-number)
(s/def ::layout-align-items #{:start :end :center :stretch}) (def gap-types
(s/def ::layout-justify-items #{:start :end :center :stretch}) #{:simple :multiple})
(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})
(s/def :grid/type #{:percent :flex :auto :fixed}) (def wrap-types
(s/def :grid/value (s/nilable ::us/safe-number)) #{:wrap :nowrap :no-wrap}) ;;TODO remove no-wrap after script
(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?))
(s/def :grid-cell/id uuid?) (def padding-type
(s/def :grid-cell/area-name ::us/string) #{:simple :multiple})
(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 ::grid-cell (s/keys :opt-un [:grid-cell/id (def justify-content-types
:grid-cell/area-name #{:start :center :end :space-between :space-around :space-evenly})
: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 ::p1 ::us/safe-number) (def align-content-types
(s/def ::p2 ::us/safe-number) #{:start :end :center :space-between :space-around :space-evenly :stretch})
(s/def ::p3 ::us/safe-number)
(s/def ::p4 ::us/safe-number)
(s/def ::layout-padding (def align-items-types
(s/keys :opt-un [::p1 ::p2 ::p3 ::p4])) #{:start :end :center :stretch})
(s/def ::row-gap ::us/safe-number) (def justify-items-types
(s/def ::column-gap ::us/safe-number) #{:start :end :center :stretch})
(s/def ::layout-gap (sm/def! ::layout-attrs
(s/keys :opt-un [::row-gap ::column-gap])) [: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/def :grid/type #{:percent :flex :auto :fixed})
(s/keys :opt-un [::layout ;; (s/def :grid/value (s/nilable ::us/safe-number))
::layout-flex-dir ;; (s/def ::grid-definition (s/keys :req-un [:grid/type]
::layout-gap ;; :opt-un [:grid/value]))
::layout-gap-type ;; (s/def ::layout-grid-rows (s/coll-of ::grid-definition :kind vector?))
::layout-wrap-type ;; (s/def ::layout-grid-columns (s/coll-of ::grid-definition :kind vector?))
::layout-padding-type
::layout-padding
::layout-justify-content
::layout-align-items
::layout-align-content
;; grid ;; (s/def :grid-cell/id uuid?)
::layout-grid-dir ;; (s/def :grid-cell/area-name ::us/string)
::layout-justify-items ;; (s/def :grid-cell/row-start ::us/safe-integer)
::layout-grid-rows ;; (s/def :grid-cell/row-span ::us/safe-integer)
::layout-grid-columns ;; (s/def :grid-cell/column-start ::us/safe-integer)
::layout-grid-cells ;; (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 ::grid-cell (s/keys :opt-un [:grid-cell/id
(s/def ::m2 ::us/safe-number) ;; :grid-cell/area-name
(s/def ::m3 ::us/safe-number) ;; :grid-cell/row-start
(s/def ::m4 ::us/safe-number) ;; :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 (def item-margin-types
(s/keys :opt-un [::layout-item-margin #{:simple :multiple})
::layout-item-margin-type
::layout-item-h-sizing (def item-h-sizing-types
::layout-item-v-sizing #{:fill :fix :auto})
::layout-item-max-h
::layout-item-min-h (def item-v-sizing-types
::layout-item-max-w #{:fill :fix :auto})
::layout-item-min-w
::layout-item-align-self (def item-align-self-types
::layout-item-absolute #{:start :end :center :stretch})
::layout-item-z-index]))
(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? (defn flex-layout?
([objects id] ([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 ;; 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 (defn add-grid-column
[parent value] [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) (let [rows (:layout-grid-rows parent)
new-col-num (count (:layout-grid-columns parent)) new-col-num (count (:layout-grid-columns parent))
@ -557,7 +591,10 @@
(defn add-grid-row (defn add-grid-row
[parent value] [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) (let [cols (:layout-grid-columns parent)
new-row-num (inc (count (:layout-grid-rows 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?))

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

@ -6,16 +6,7 @@
(ns app.common.types.shape.radius (ns app.common.types.shape.radius
(:require (:require
[app.common.pages.common :refer [editable-attrs]] [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)
;; There are some shapes that admit border radius, as rectangles ;; 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: ;; frames and images. Those shapes may define the radius of the corners in two modes:

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

@ -6,44 +6,26 @@
(ns app.common.types.shape.shadow (ns app.common.types.shape.shadow
(:require (:require
[app.common.spec :as us] [app.common.schema :as sm]
[app.common.types.color :as ctc] [app.common.types.color :as ctc]
[app.common.types.shape.shadow.color :as-alias shadow-color] [app.common.types.shape.shadow.color :as-alias shadow-color]))
[clojure.spec.alpha :as s]))
;;; SHADOW EFFECT (def styles #{:drop-shadow :inner-shadow})
(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?))
(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 (ns app.common.types.shape.text
(:require (:require
[app.common.spec :as us] [app.common.schema :as sm]
[app.common.types.color :as ctc] [app.common.types.shape :as-alias shape]
[app.common.types.shape.text.position-data :as-alias position-data] [app.common.types.shape.text.position-data :as-alias position-data]))
[clojure.spec.alpha :as s]))
(s/def ::type #{"root" "paragraph-set" "paragraph"}) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::text string?) ;; SCHEMA
(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))
(s/def ::content (def node-types #{"root" "paragraph-set" "paragraph"})
(s/nilable
(s/or :text-container
(s/keys :req-un [::type]
:opt-un [::key
::children])
:text-content
(s/keys :req-un [::text]))))
(s/def ::children (sm/def! ::content
(s/coll-of ::content [:map
:kind vector? [:type [:= "root"]]
:min-count 1)) [: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) (sm/def! ::position-data
(s/def ::position-data/y ::us/safe-number) [:vector {:min 1 :gen/max 2}
(s/def ::position-data/width ::us/safe-number) [:map
(s/def ::position-data/height ::us/safe-number) [:x ::sm/safe-number]
[:y ::sm/safe-number]
(s/def ::position-data/fill-color ::fill-color) [:width ::sm/safe-number]
(s/def ::position-data/fill-opacity ::fill-opacity) [:height ::sm/safe-number]
(s/def ::position-data/fill-color-gradient ::fill-color-gradient) [:fills [:vector {:gen/max 2} ::shape/fill]]
[:font-family {:optional true} :string]
(s/def ::position-data/font-family string?) [:font-size {:optional true} :string]
(s/def ::position-data/font-size string?) [:font-style {:optional true} :string]
(s/def ::position-data/font-style string?) [:font-weight {:optional true} :string]
(s/def ::position-data/font-weight string?) [:rtl {:optional true} :boolean]
(s/def ::position-data/rtl boolean?) [:text {:optional true} :string]
(s/def ::position-data/text string?) [:text-decoration {:optional true} :string]
(s/def ::position-data/text-decoration string?) [:text-transform {:optional true} :string]]])
(s/def ::position-data/text-transform string?)

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

@ -12,14 +12,9 @@
[app.common.geom.shapes :as gsh] [app.common.geom.shapes :as gsh]
[app.common.math :as mth] [app.common.math :as mth]
[app.common.pages.helpers :as cph] [app.common.pages.helpers :as cph]
[app.common.spec :as us]
[app.common.types.component :as ctk] [app.common.types.component :as ctk]
[app.common.types.shape :as cts]
[app.common.types.shape.layout :as ctl] [app.common.types.shape.layout :as ctl]
[app.common.uuid :as uuid] [app.common.uuid :as uuid]))
[clojure.spec.alpha :as s]))
(s/def ::objects (s/map-of uuid? ::cts/shape))
(defn add-shape (defn add-shape
"Insert a shape in the tree, at the given index below the given parent or frame. "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) (let [child-id (first child-ids)
child (get objects child-id) child (get objects child-id)
_ (us/assert! ::us/some child) _ (dm/assert! (some? child))
[new-child new-child-objects updated-child-objects] [new-child new-child-objects updated-child-objects]
(clone-object child new-id objects update-new-object update-original-object)] (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 (ns app.common.types.typography
(:require (:require
[app.common.spec :as us] [app.common.schema :as sm]
[app.common.text :as txt] [app.common.text :as txt]))
[clojure.spec.alpha :as s]))
(s/def ::id uuid?) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::name string?) ;; SCHEMA
(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)
(s/def ::typography (sm/def! ::typography
(s/keys :req-un [::id [:map {:title "Typography"}
::name [:id ::sm/uuid]
::font-id [:name :string]
::font-family [:font-id :string]
::font-variant-id [:font-family :string]
::font-size [:font-variant-id :string]
::font-weight [:font-size :string]
::font-style [:font-weight :string]
::line-height [:font-style :string]
::letter-spacing [:line-height :string]
::text-transform] [:letter-spacing :string]
:opt-un [::path [:text-transform :string]
::modified-at])) [:modified-at {:optional true} ::sm/inst]
[:path {:optional true} [:maybe :string]]])
(def typography?
(sm/pred-fn ::typography))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn uses-library-typographies? (defn uses-library-typographies?
"Check if the shape uses any typography in the given library." "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)) typographies (ctyl/typographies-seq (ctf/file-data absorbed-file))
page (ctpl/get-page (ctf/file-data absorbed-file) file-page-id) page (ctpl/get-page (ctf/file-data absorbed-file) file-page-id)
shape1 (ctn/get-shape page (thf/id :shape1)) shape1 (ctn/get-shape page (thf/id :shape1))
text-node (d/seek #(some? (:text %)) (txt/node-seq (:content shape1)))] text-node (d/seek #(some? (:text %)) (txt/node-seq (:content shape1)))]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -7,9 +7,9 @@
(ns app.main.data.messages (ns app.main.data.messages
(:require (:require
[app.common.data :as d] [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] [beicon.core :as rx]
[cljs.spec.alpha :as s]
[potok.core :as ptk])) [potok.core :as ptk]))
(declare hide) (declare hide)
@ -18,32 +18,34 @@
(def default-animation-timeout 600) (def default-animation-timeout 600)
(def default-timeout 5000) (def default-timeout 5000)
(s/def ::type #{:success :error :info :warning}) (def schema:message
(s/def ::position #{:fixed :floating :inline}) [:map {:title "Message"}
(s/def ::status #{:visible :hide}) [:type [::sm/one-of #{:success :error :info :warning}]]
(s/def ::controls #{:none :close :inline-actions :bottom-actions}) [: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)) (def message?
(s/def ::label ::us/string) (sm/pred-fn schema:message))
(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]))
(defn show (defn show
[data] [data]
(us/verify ::message data) (dm/assert!
"expected valid message map"
(message? data))
(ptk/reify ::show (ptk/reify ::show
ptk/UpdateEvent ptk/UpdateEvent
(update [_ state] (update [_ state]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -6,18 +6,19 @@
(ns app.main.data.workspace.media (ns app.main.data.workspace.media
(:require (:require
[app.common.data.macros :as dm]
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.common.logging :as log] [app.common.logging :as log]
[app.common.math :as mth] [app.common.math :as mth]
[app.common.pages.changes-builder :as pcb] [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.container :as ctn]
[app.common.types.shape :as cts] [app.common.types.shape :as cts]
[app.common.types.shape-tree :as ctst] [app.common.types.shape-tree :as ctst]
[app.common.uuid :as uuid] [app.common.uuid :as uuid]
[app.config :as cfg] [app.config :as cfg]
[app.main.data.media :as dmm] [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.changes :as dch]
[app.main.data.workspace.libraries :as dwl] [app.main.data.workspace.libraries :as dwl]
[app.main.data.workspace.shapes :as dwsh] [app.main.data.workspace.shapes :as dwsh]
@ -28,7 +29,6 @@
[app.util.http :as http] [app.util.http :as http]
[app.util.i18n :refer [tr]] [app.util.i18n :refer [tr]]
[beicon.core :as rx] [beicon.core :as rx]
[cljs.spec.alpha :as s]
[cuerdas.core :as str] [cuerdas.core :as str]
[potok.core :as ptk] [potok.core :as ptk]
[promesa.core :as p] [promesa.core :as p]
@ -136,47 +136,46 @@
(rx/merge-map svg->clj) (rx/merge-map svg->clj)
(rx/do on-svg))))) (rx/do on-svg)))))
(s/def ::local? ::us/boolean) (def schema:process-media-objects
(s/def ::blobs ::dmm/blobs) [:map
(s/def ::name ::us/string) [:file-id ::sm/uuid]
(s/def ::uris (s/coll-of ::us/string)) [:local? :boolean]
(s/def ::mtype ::us/string) [:name {:optional true} :string]
[:data {:optional true} :any] ; FIXME
(s/def ::process-media-objects [:uris {:optional true} [:vector :string]]
(s/and [:mtype {:optional true} :string]])
(s/keys :req-un [::file-id ::local?]
:opt-un [::name ::data ::uris ::mtype])
(fn [props]
(or (contains? props :blobs)
(contains? props :uris)))))
(defn- process-media-objects (defn- process-media-objects
[{:keys [uris on-error] :as params}] [{: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] (letfn [(handle-error [error]
(if (ex/ex-info? error) (if (ex/ex-info? error)
(handle-error (ex-data error)) (handle-error (ex-data error))
(cond (cond
(= (:code error) :invalid-svg-file) (= (: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) (= (: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) (= (: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) (= (: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) (= (: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) (= (: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) (= (:code error) :unable-to-optimize)
(rx/of (dm/error (:hint error))) (rx/of (msg/error (:hint error)))
(fn? on-error) (fn? on-error)
(on-error error) (on-error error)
@ -188,7 +187,7 @@
ptk/WatchEvent ptk/WatchEvent
(watch [_ _ _] (watch [_ _ _]
(rx/concat (rx/concat
(rx/of (dm/show {:content (tr "media.loading") (rx/of (msg/show {:content (tr "media.loading")
:type :info :type :info
:timeout nil :timeout nil
:tag :media-loading})) :tag :media-loading}))
@ -201,7 +200,7 @@
;; Every stream has its own sideeffect. We need to ignore the result ;; Every stream has its own sideeffect. We need to ignore the result
(rx/ignore) (rx/ignore)
(rx/catch handle-error) (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 ;; Deprecated in components-v2
(defn upload-media-asset (defn upload-media-asset
@ -339,14 +338,14 @@
:on-svg #(st/emit! (process-svg-component %)))] :on-svg #(st/emit! (process-svg-component %)))]
(process-media-objects params))) (process-media-objects params)))
(s/def ::object-id ::us/uuid) (def schema:clone-media-object
[:map
(s/def ::clone-media-objects-params [:file-id ::sm/uuid]
(s/keys :req-un [::file-id ::object-id])) [:object-id ::sm/uuid]])
(defn clone-media-object (defn clone-media-object
[{:keys [file-id object-id] :as params}] [{: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/reify ::clone-media-objects
ptk/WatchEvent ptk/WatchEvent
(watch [_ _ _] (watch [_ _ _]
@ -358,12 +357,12 @@
:id object-id}] :id object-id}]
(rx/concat (rx/concat
(rx/of (dm/show {:content (tr "media.loading") (rx/of (msg/show {:content (tr "media.loading")
:type :info :type :info
:timeout nil :timeout nil
:tag :media-loading})) :tag :media-loading}))
(->> (rp/cmd! :clone-file-media-object params) (->> (rp/cmd! :clone-file-media-object params)
(rx/do on-success) (rx/do on-success)
(rx/catch on-error) (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.math :as mth]
[app.common.pages.common :as cpc] [app.common.pages.common :as cpc]
[app.common.pages.helpers :as cph] [app.common.pages.helpers :as cph]
[app.common.spec :as us]
[app.common.types.container :as ctn] [app.common.types.container :as ctn]
[app.common.types.modifiers :as ctm] [app.common.types.modifiers :as ctm]
[app.common.types.shape.layout :as ctl] [app.common.types.shape.layout :as ctl]
@ -25,7 +24,6 @@
[app.main.data.workspace.state-helpers :as wsh] [app.main.data.workspace.state-helpers :as wsh]
[app.main.data.workspace.undo :as dwu] [app.main.data.workspace.undo :as dwu]
[beicon.core :as rx] [beicon.core :as rx]
[cljs.spec.alpha :as s]
[potok.core :as ptk])) [potok.core :as ptk]))
;; -- temporary modifiers ------------------------------------------- ;; -- temporary modifiers -------------------------------------------
@ -96,7 +94,6 @@
ignore-geometry? (and (and (< (:x distance) 1) (< (:y distance) 1)) ignore-geometry? (and (and (< (:x distance) 1) (< (:y distance) 1))
(mth/close? (:width selrect) (:width transformed-selrect)) (mth/close? (:width selrect) (:width transformed-selrect))
(mth/close? (:height selrect) (:height transformed-selrect)))] (mth/close? (:height selrect) (:height transformed-selrect)))]
[root transformed-root ignore-geometry?])) [root transformed-root ignore-geometry?]))
(defn- get-ignore-tree (defn- get-ignore-tree
@ -157,12 +154,16 @@
(defn create-modif-tree (defn create-modif-tree
[ids modifiers] [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)) (into {} (map #(vector % {:modifiers modifiers})) ids))
(defn build-modif-tree (defn build-modif-tree
[ids objects get-modifier] [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)) (into {} (map #(vector % {:modifiers (get-modifier (get objects %))})) ids))
(defn modifier-remove-from-parent (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 (ns app.main.data.workspace.notifications
(:require (:require
[app.common.data :as d] [app.common.data :as d]
[app.common.pages.changes-spec :as pcs] [app.common.data.macros :as dm]
[app.common.spec :as us] [app.common.pages.changes :as cpc]
[app.common.schema :as sm]
[app.main.data.websocket :as dws] [app.main.data.websocket :as dws]
[app.main.data.workspace.changes :as dch] [app.main.data.workspace.changes :as dch]
[app.main.data.workspace.libraries :as dwl] [app.main.data.workspace.libraries :as dwl]
@ -18,7 +19,6 @@
[app.util.object :as obj] [app.util.object :as obj]
[app.util.time :as dt] [app.util.time :as dt]
[beicon.core :as rx] [beicon.core :as rx]
[cljs.spec.alpha :as s]
[clojure.set :as set] [clojure.set :as set]
[potok.core :as ptk])) [potok.core :as ptk]))
@ -183,19 +183,18 @@
:updated-at (dt/now) :updated-at (dt/now)
:page-id page-id)))))) :page-id page-id))))))
(s/def ::type keyword?) (def schema:handle-file-change
(s/def ::profile-id uuid?) [:map
(s/def ::file-id uuid?) [:type :keyword]
(s/def ::session-id uuid?) [:profile-id ::sm/uuid]
(s/def ::revn integer?) [:file-id ::sm/uuid]
(s/def ::changes ::pcs/changes) [:session-id ::sm/uuid]
[:revn :int]
(s/def ::file-change-event [:changes ::cpc/changes]])
(s/keys :req-un [::type ::profile-id ::file-id ::session-id ::revn ::changes]))
(defn handle-file-change (defn handle-file-change
[{:keys [file-id changes] :as msg}] [{: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 (ptk/reify ::handle-file-change
IDeref IDeref
(-deref [_] {:changes changes}) (-deref [_] {:changes changes})
@ -241,18 +240,19 @@
(when-not (empty? changes-by-pages) (when-not (empty? changes-by-pages)
(rx/from (map process-page-changes changes-by-pages)))))))) (rx/from (map process-page-changes changes-by-pages))))))))
(s/def ::library-change-event (def schema:handle-library-change
(s/keys :req-un [::type [:map
::profile-id [:type :keyword]
::file-id [:profile-id ::sm/uuid]
::session-id [:file-id ::sm/uuid]
::revn [:session-id ::sm/uuid]
::modified-at [:revn :int]
::changes])) [:modified-at ::sm/inst]
[:changes ::cpc/changes]])
(defn handle-library-change (defn handle-library-change
[{:keys [file-id modified-at changes revn] :as msg}] [{: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/reify ::handle-library-change
ptk/WatchEvent ptk/WatchEvent
(watch [_ state _] (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 (ns app.main.data.workspace.path.changes
(:require (:require
[app.common.data.macros :as dm]
[app.common.pages.changes-builder :as pcb] [app.common.pages.changes-builder :as pcb]
[app.common.spec :as us]
[app.main.data.workspace.changes :as dch] [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.helpers :as helpers]
[app.main.data.workspace.path.spec :as spec]
[app.main.data.workspace.path.state :as st] [app.main.data.workspace.path.state :as st]
[app.main.data.workspace.state-helpers :as wsh] [app.main.data.workspace.state-helpers :as wsh]
[beicon.core :as rx] [beicon.core :as rx]
@ -19,8 +19,8 @@
(defn generate-path-changes (defn generate-path-changes
"Generates changes to update the new content of the shape" "Generates changes to update the new content of the shape"
[it objects page-id shape old-content new-content] [it objects page-id shape old-content new-content]
(us/verify ::spec/content old-content) (dm/assert! (content? old-content))
(us/verify ::spec/content new-content) (dm/assert! (content? new-content))
(let [shape-id (:id shape) (let [shape-id (:id shape)
[old-points old-selrect] [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 (ns app.main.data.workspace.path.common
(:require (:require
[app.common.schema :as sm]
[app.main.data.workspace.path.state :as st] [app.main.data.workspace.path.state :as st]
[potok.core :as ptk])) [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 [] (defn init-path []
(ptk/reify ::init-path)) (ptk/reify ::init-path))

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