Penpot/penpot
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-04-14 16:01:24 -05:00
Code Issues Activity

🚧 Major refactor of backend code.

Browse source 
Relevant changes:

- ring -> vertx
- suricatta -> vertx-pgsql
- emails improvements
- logging
- hybrid sync/async -> full async execution model
- database layout refactor
This commit is contained in:
Andrey Antukh 2019-11-18 11:52:57 +01:00
parent 73753ce071
commit e9b00339a5
134 changed files with 5394 additions and 6598 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

43
backend/deps.edn
View file

@ -1,35 +1,38 @@
{:deps {org.clojure/clojure {:mvn/version "1.10.1"}
org.clojure/tools.logging {:mvn/version "0.3.1"}
funcool/promesa {:mvn/version "4.0.2"}
funcool/cuerdas {:mvn/version "2.2.0"}
funcool/promesa {:mvn/version "5.0.0-SNAPSHOT"}
funcool/cuerdas {:mvn/version "2.2.1"}
funcool/suricatta {:mvn/version "2.0.0-SNAPSHOT"}
;; Logging
org.clojure/tools.logging {:mvn/version "0.5.0"}
org.apache.logging.log4j/log4j-api {:mvn/version "2.12.1"}
org.apache.logging.log4j/log4j-core {:mvn/version "2.12.1"}
org.apache.logging.log4j/log4j-jul {:mvn/version "2.12.1"}
funcool/datoteka {:mvn/version "1.1.0"}
funcool/struct {:mvn/version "2.0.0-SNAPSHOT"}
expound/expound {:mvn/version "0.7.2"}
instaparse/instaparse {:mvn/version "1.4.10"}
ring/ring {:mvn/version "1.7.1"}
metosin/reitit-core {:mvn/version "0.3.9"}
metosin/reitit-ring {:mvn/version "0.3.9"}
metosin/reitit-middleware {:mvn/version "0.3.9"}
metosin/reitit-spec {:mvn/version "0.3.9"}
;; vertx deps
metosin/reitit-core {:mvn/version "0.3.10"}
metosin/sieppari {:mvn/version "0.0.0-alpha8"}
com.cognitect/transit-clj {:mvn/version "0.8.319"}
io.vertx/vertx-core {:mvn/version "3.8.1"}
io.vertx/vertx-web {:mvn/version "3.8.1"}
io.vertx/vertx-pg-client {:mvn/version "3.8.1"}
;; end verx deps
lambdaisland/uri {:mvn/version "1.1.0"}
danlentz/clj-uuid {:mvn/version "0.1.9"}
org.jsoup/jsoup {:mvn/version "1.12.1"}
hiccup/hiccup {:mvn/version "1.0.5"}
org.im4java/im4java {:mvn/version "1.4.0"}
org.slf4j/slf4j-simple {:mvn/version "1.7.26"}
com.layerware/hugsql-core {:mvn/version "0.4.9"
:exclusions [org.clojure/tools.reader]}
niwinz/migrante {:mvn/version "0.1.0"}
buddy/buddy-sign {:mvn/version "3.1.0"}
buddy/buddy-hashers {:mvn/version "1.4.0"}
org.xerial.snappy/snappy-java {:mvn/version "1.1.7.3"}
com.github.spullara.mustache.java/compiler {:mvn/version "0.9.6"}
org.postgresql/postgresql {:mvn/version "42.2.6"}
org.quartz-scheduler/quartz {:mvn/version "2.3.1"}
org.quartz-scheduler/quartz-jobs {:mvn/version "2.3.1"}
commons-io/commons-io {:mvn/version "2.6"}
com.draines/postal {:mvn/version "2.0.3"
:exclusions [commons-codec/commons-codec]}
@ -37,7 +40,6 @@
;; exception printing
io.aviso/pretty {:mvn/version "0.1.37"}
hikari-cp/hikari-cp {:mvn/version "2.7.1"}
mount/mount {:mvn/version "0.1.16"}
environ/environ {:mvn/version "1.1.0"}
}
@ -46,9 +48,8 @@
{:dev
{:extra-deps {com.bhauman/rebel-readline {:mvn/version "0.1.4"}
org.clojure/tools.namespace {:mvn/version "0.3.1"}
fipp/fipp {:mvn/version "0.6.19"}
clj-http/clj-http {:mvn/version "2.1.0"}
ring/ring-mock {:mvn/version "0.4.0"}
fipp/fipp {:mvn/version "0.6.21"}
criterium/criterium {:mvn/version "0.4.5"}
}
:extra-paths ["test"]}
:repl {:main-opts ["-m" "rebel-readline.main"]}

14
backend/resources/emails/debug-email-list.html Normal file
View file

@ -0,0 +1,14 @@
<html>
<body>
<section style="font-family: Monoid, monospace; font-size: 14px;">
<h1>Available Emails:</h1>
<ul>
{{#emails}}
<li>
<a href="/debug/emails/{{ id }}">{{id}}</a>
</li>
{{/emails}}
</ul>
</section>
</body>
</html>

30
backend/resources/emails/en/register.mustache
View file

@ -11,7 +11,31 @@ UXBOX team.
-- end
-- begin :body-html
<p>Hello {{user}}!</p>
<p>Welcome to UXBOX.</p>
<p>UXBOX team.</p>
<html>
<head>
<meta content="text/html; charset=UTF-8" http-equiv="Content-Type" />
<meta content="width=device-width" name="viewport" />
<title>title</title>
{{> ../partials/inline_style }}
</head>
<body bgcolor="#f6f6f6" cz-shortcut-listen="true">
<table class="body-wrap">
<tbody>
<tr>
<td></td>
<td bgcolor="#FFFFFF" class="container">
<div class="logo">
<img alt="UXBOX" src="{{#static}}images/email/logo.png{{/static}}" />
</div>
<p>Hello {{user}}!</p>
<p>Welcome to UXBOX.</p>
<p>UXBOX team.</p>
</td>
<td></td>
</tr>
</tbody>
</table>
{{> ../partials/en/footer }}
</body>
</html>
-- end

46
backend/resources/emails/partials/en/footer.mustache Normal file
View file

@ -0,0 +1,46 @@
<table class="footer-wrap">
<tbody>
<tr>
<td></td>
<td class="container">
<div class="content">
<table>
<tbody>
<tr>
<td>
<div style="text-align: center;">
<a href="#" target="_blank">
<img src="{{#static}}images/email/twitter.png{{/static}}"
style="display: inline-block; width: 25px; margin-right: 5px;" />
</a>
<a href="#" target="_blank">
<img src="{{#static}}images/email/github.png{{/static}}"
style="display: inline-block; width: 25px; margin-right: 5px;" />
</a>
<a href="#" target="_blank">
<img src="{{#static}}images/email/linkedin.png{{/static}}"
style="display: inline-block; width: 25px; margin-right: 5px;" />
</a>
</div>
</td>
</tr>
{{#comment}}
<tr>
<td align="center">
<p>
<span>Sent from UXBOX | </span>
<a href="#" target="_blank">
<unsubscribe>Email preferences</unsubscribe>
</a>
</p>
</td>
</tr>
{{/comment}}
</tbody>
</table>
</div>
</td>
<td></td>
</tr>
</tbody>
</table>

6
backend/resources/emails/partials/head.mustache Normal file
View file

@ -0,0 +1,6 @@
<head>
<meta content="text/html; charset=UTF-8" http-equiv="Content-Type" />
<meta content="width=device-width" name="viewport" />
<title>title</title>
{{> inline_style }}
</head>

162
backend/resources/emails/partials/inline_style.mustache Normal file
View file

@ -0,0 +1,162 @@
<style>
/* GLOBAL */
* {
margin:0;
padding:0;
font-family: Arial, sans-serif;
font-size: 100%;
line-height: 1.6;
}
img {
max-width: 100%;
width: 100%;
}
.img-header {
border-top-left-radius: 5px;
border-top-right-radius: 5px;
}
body {
-webkit-font-smoothing:antialiased;
-webkit-text-size-adjust:none;
width: 100%!important;
height: 100%;
}
/* ELEMENTS */
a {
color: #78dbbe;
text-decoration:none;
font-weight: bold;
}
.btn-primary {
text-decoration:none;
color: #fff;
background-color: #78dbbe;
padding: 10px 30px;
font-weight: bold;
margin: 20px 0;
text-align: center;
cursor: pointer;
display: inline-block;
border-radius: 4px;
}
.btn-primary:hover {
color: #FFF;
background-color: #8eefcf;
}
.last {
margin-bottom: 0;
}
.first{
margin-top: 0;
}
.logo {
background-color: #f6f6f6;
padding: 10px;
text-align: center;
padding-bottom: 25px;
}
.logo h2 {
color: #777;
font-size: 20px;
font-weight: bold;
margin-top: 15px;
}
.logo img {
max-width: 150px;
}
/* BODY */
table.body-wrap {
width: 100%;
padding: 20px;
}
table.body-wrap .container{
border-radius: 5px;
color: #ababab;
}
/* FOOTER */
table.footer-wrap {
width: 100%;
clear:both!important;
}
.footer-wrap .container p {
font-size: 12px;
color:#666;
}
table.footer-wrap a{
color: #999;
}
/* TYPOGRAPHY */
h1,h2,h3{
font-family: Arial, sans-serif;
line-height: 1.1;
margin-bottom:15px;
color:#000;
margin: 40px 0 10px;
line-height: 1.2;
font-weight:200;
}
h1 {
color: #777;
font-size: 28px;
font-weight: bold;
}
h2 {
font-size: 24px;
}
h3 {
font-size: 18px;
}
p, ul {
margin-bottom: 10px;
font-weight: normal;
}
ul li {
margin-left:5px;
list-style-position: inside;
}
/* RESPONSIVE */
/* Set a max-width, and make it display as block so it will automatically stretch to that width, but will also shrink down on a phone or something */
.container {
display: block !important;
max-width: 620px !important;
margin: 0 auto !important; /* makes it centered */
clear: both !important;
}
/* This should also be a block element, so that it will fill 100% of the .container */
.content {
padding: 20px;
max-width: 620px;
margin: 0 auto;
display: block;
}
/* Let's make sure tables in the content area are 100% wide */
.content table {
width: 100%;
}
</style>

12
backend/resources/log4j2.xml Normal file
View file

@ -0,0 +1,12 @@
<Configuration status="info" monitorInterval="60">
<Appenders>
<Console name="console" target="SYSTEM_OUT">
<PatternLayout pattern="%d{HH:mm:ss.SSS} [%t] %-5level %logger{36} - %msg%n"/>
</Console>
</Appenders>
<Loggers>
<Root level="info">
<AppenderRef ref="console"/>
</Root>
</Loggers>
</Configuration>

28
backend/resources/migrations/0000.main.up.sql
View file

@ -1,28 +0,0 @@
CREATE EXTENSION IF NOT EXISTS "uuid-ossp";
CREATE EXTENSION IF NOT EXISTS "pgcrypto";
-- OCC
CREATE OR REPLACE FUNCTION handle_occ()
RETURNS TRIGGER AS $occ$
BEGIN
IF (NEW.version != OLD.version) THEN
RAISE EXCEPTION 'Version missmatch: expected % given %',
OLD.version, NEW.version
USING ERRCODE='P0002';
ELSE
NEW.version := NEW.version + 1;
END IF;
RETURN NEW;
END;
$occ$ LANGUAGE plpgsql;
-- Modified At
CREATE OR REPLACE FUNCTION update_modified_at()
RETURNS TRIGGER AS $updt$
BEGIN
NEW.modified_at := clock_timestamp();
RETURN NEW;
END;
$updt$ LANGUAGE plpgsql;

12
backend/resources/migrations/0001.main.up.sql Normal file
View file

@ -0,0 +1,12 @@
CREATE EXTENSION IF NOT EXISTS "uuid-ossp";
CREATE EXTENSION IF NOT EXISTS "pgcrypto";
-- Modified At
CREATE OR REPLACE FUNCTION update_modified_at()
RETURNS TRIGGER AS $updt$
BEGIN
NEW.modified_at := clock_timestamp();
RETURN NEW;
END;
$updt$ LANGUAGE plpgsql;

17
backend/resources/migrations/0001.txlog.up.sql
View file

@ -1,17 +0,0 @@
-- A table that will store the whole transaction log of the database.
CREATE TABLE IF NOT EXISTS txlog (
id uuid PRIMARY KEY DEFAULT uuid_generate_v4(),
created_at timestamptz NOT NULL DEFAULT clock_timestamp(),
payload bytea NOT NULL
);
CREATE OR REPLACE FUNCTION handle_txlog_notify()
RETURNS TRIGGER AS $notify$
BEGIN
PERFORM pg_notify('uxbox.transaction', (NEW.id)::text);
RETURN NEW;
END;
$notify$ LANGUAGE plpgsql;
CREATE TRIGGER txlog_notify_tgr AFTER INSERT ON txlog
FOR EACH ROW EXECUTE PROCEDURE handle_txlog_notify();

26
backend/resources/migrations/0002.auth.up.sql
View file

@ -13,6 +13,16 @@ CREATE TABLE users (
metadata bytea NOT NULL
);
CREATE TABLE sessions (
id uuid PRIMARY KEY DEFAULT uuid_generate_v4(),
created_at timestamptz NOT NULL DEFAULT clock_timestamp(),
modified_at timestamptz NOT NULL DEFAULT clock_timestamp(),
user_id uuid REFERENCES users(id) ON DELETE CASCADE,
user_agent TEXT NULL
);
-- Insert a placeholder system user.
INSERT INTO users (id, fullname, username, email, photo, password, metadata)
VALUES ('00000000-0000-0000-0000-000000000000'::uuid,
@ -21,22 +31,22 @@ VALUES ('00000000-0000-0000-0000-000000000000'::uuid,
'system@uxbox.io',
'',
'!',
''::bytea);
'{}');
CREATE UNIQUE INDEX users_username_idx
ON users USING btree (username)
WHERE deleted_at is null;
ON users USING btree (username)
WHERE deleted_at is null;
CREATE UNIQUE INDEX users_email_idx
ON users USING btree (email)
WHERE deleted_at is null;
ON users USING btree (email)
WHERE deleted_at is null;
CREATE TRIGGER users_modified_at_tgr BEFORE UPDATE ON users
FOR EACH ROW EXECUTE PROCEDURE update_modified_at();
FOR EACH ROW EXECUTE PROCEDURE update_modified_at();
CREATE TABLE user_pswd_recovery (
id uuid PRIMARY KEY DEFAULT uuid_generate_v4(),
"user" uuid REFERENCES users(id) ON DELETE CASCADE,
user_id uuid REFERENCES users(id) ON DELETE CASCADE,
token text NOT NULL,
created_at timestamptz NOT NULL DEFAULT clock_timestamp(),
@ -44,7 +54,7 @@ CREATE TABLE user_pswd_recovery (
);
CREATE INDEX user_pswd_recovery_user_idx
ON user_pswd_recovery USING btree ("user");
ON user_pswd_recovery USING btree (user_id);
CREATE UNIQUE INDEX user_pswd_recovery_token_idx
ON user_pswd_recovery USING btree (token);

9
backend/resources/migrations/0003.projects.up.sql
View file

@ -2,13 +2,12 @@
CREATE TABLE IF NOT EXISTS projects (
id uuid PRIMARY KEY DEFAULT uuid_generate_v4(),
"user" uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
user_id uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
created_at timestamptz NOT NULL DEFAULT clock_timestamp(),
modified_at timestamptz NOT NULL DEFAULT clock_timestamp(),
deleted_at timestamptz DEFAULT NULL,
version bigint NOT NULL DEFAULT 0,
name text NOT NULL
);
@ -23,7 +22,7 @@ CREATE TABLE IF NOT EXISTS project_shares (
-- Indexes
CREATE INDEX projects_user_idx
ON projects("user");
ON projects(user_id);
CREATE UNIQUE INDEX projects_shares_token_idx
ON project_shares(token);
@ -49,10 +48,6 @@ CREATE TRIGGER project_on_create_tgr
AFTER INSERT ON projects
FOR EACH ROW EXECUTE PROCEDURE handle_project_create();
CREATE TRIGGER project_occ_tgr
BEFORE UPDATE ON projects
FOR EACH ROW EXECUTE PROCEDURE handle_occ();
CREATE TRIGGER projects_modified_at_tgr
BEFORE UPDATE ON projects
FOR EACH ROW EXECUTE PROCEDURE update_modified_at();

31
backend/resources/migrations/0004.pages.up.sql
View file

@ -3,13 +3,12 @@
CREATE TABLE IF NOT EXISTS pages (
id uuid PRIMARY KEY DEFAULT uuid_generate_v4(),
"user" uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
project uuid NOT NULL REFERENCES projects(id) ON DELETE CASCADE,
user_id uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
project_id uuid NOT NULL REFERENCES projects(id) ON DELETE CASCADE,
created_at timestamptz NOT NULL DEFAULT clock_timestamp(),
modified_at timestamptz NOT NULL DEFAULT clock_timestamp(),
deleted_at timestamptz DEFAULT NULL,
version bigint DEFAULT 0,
name text NOT NULL,
data bytea NOT NULL,
@ -19,8 +18,8 @@ CREATE TABLE IF NOT EXISTS pages (
CREATE TABLE IF NOT EXISTS pages_history (
id uuid PRIMARY KEY DEFAULT uuid_generate_v4(),
"user" uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
page uuid NOT NULL REFERENCES pages(id) ON DELETE CASCADE,
user_id uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
page_id uuid NOT NULL REFERENCES pages(id) ON DELETE CASCADE,
created_at timestamptz NOT NULL,
modified_at timestamptz NOT NULL,
@ -33,10 +32,10 @@ CREATE TABLE IF NOT EXISTS pages_history (
-- Indexes
CREATE INDEX pages_project_idx ON pages(project);
CREATE INDEX pages_user_idx ON pages("user");
CREATE INDEX pages_history_page_idx ON pages_history(page);
CREATE INDEX pages_history_user_idx ON pages_history("user");
CREATE INDEX pages_project_idx ON pages(project_id);
CREATE INDEX pages_user_idx ON pages(user_id);
CREATE INDEX pages_history_page_idx ON pages_history(page_id);
CREATE INDEX pages_history_user_idx ON pages_history(user_id);
-- Triggers
@ -46,16 +45,7 @@ CREATE OR REPLACE FUNCTION handle_page_update()
--- Update projects modified_at attribute when a
--- page of that project is modified.
UPDATE projects SET modified_at = clock_timestamp()
WHERE id = OLD.project;
--- Register a new history entry if the data
--- property is changed.
IF (OLD.data != NEW.data) THEN
INSERT INTO pages_history (page, "user", created_at,
modified_at, data, version)
VALUES (OLD.id, OLD."user", OLD.modified_at,
OLD.modified_at, OLD.data, OLD.version);
END IF;
WHERE id = OLD.project_id;
RETURN NEW;
END;
@ -64,9 +54,6 @@ $pagechange$ LANGUAGE plpgsql;
CREATE TRIGGER page_on_update_tgr BEFORE UPDATE ON pages
FOR EACH ROW EXECUTE PROCEDURE handle_page_update();
CREATE TRIGGER page_occ_tgr BEFORE UPDATE ON pages
FOR EACH ROW EXECUTE PROCEDURE handle_occ();
CREATE TRIGGER pages_modified_at_tgr BEFORE UPDATE ON pages
FOR EACH ROW EXECUTE PROCEDURE update_modified_at();

11
backend/resources/migrations/0005.kvstore.up.sql
View file

@ -1,19 +1,14 @@
CREATE TABLE IF NOT EXISTS kvstore (
"user" uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
user_id uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
created_at timestamptz NOT NULL DEFAULT clock_timestamp(),
modified_at timestamptz NOT NULL DEFAULT clock_timestamp(),
version bigint NOT NULL DEFAULT 0,
key text NOT NULL,
value bytea NOT NULL,
PRIMARY KEY (key, "user")
PRIMARY KEY (key, user_id)
);
CREATE TRIGGER kvstore_occ_tgr BEFORE UPDATE ON kvstore
FOR EACH ROW EXECUTE PROCEDURE handle_occ();
CREATE TRIGGER kvstore_modified_at_tgr BEFORE UPDATE ON kvstore
FOR EACH ROW EXECUTE PROCEDURE update_modified_at();
FOR EACH ROW EXECUTE PROCEDURE update_modified_at();

7
backend/resources/migrations/0006.emails.up.sql
View file

@ -7,7 +7,7 @@ CREATE TABLE IF NOT EXISTS email_queue (
modified_at timestamptz NOT NULL DEFAULT clock_timestamp(),
deleted_at timestamptz DEFAULT NULL,
data bytea NOT NULL,
data jsonb NOT NULL,
priority smallint NOT NULL DEFAULT 10
CHECK (priority BETWEEN 0 and 10),
@ -19,9 +19,8 @@ CREATE TABLE IF NOT EXISTS email_queue (
-- Triggers
CREATE TRIGGER email_queue_modified_at_tgr BEFORE UPDATE ON email_queue
FOR EACH ROW EXECUTE PROCEDURE update_modified_at();
FOR EACH ROW EXECUTE PROCEDURE update_modified_at();
-- Indexes
CREATE INDEX email_status_idx
ON email_queue (status);
CREATE INDEX email_status_idx ON email_queue (status);

25
backend/resources/migrations/0007.images.up.sql
View file

@ -2,32 +2,29 @@
CREATE TABLE IF NOT EXISTS images_collections (
id uuid PRIMARY KEY DEFAULT uuid_generate_v4(),
"user" uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
user_id uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
created_at timestamptz NOT NULL DEFAULT clock_timestamp(),
modified_at timestamptz NOT NULL DEFAULT clock_timestamp(),
deleted_at timestamptz DEFAULT NULL,
version bigint NOT NULL DEFAULT 0,
name text NOT NULL
);
CREATE TABLE IF NOT EXISTS images (
id uuid PRIMARY KEY DEFAULT uuid_generate_v4(),
"user" uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
user_id uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
created_at timestamptz NOT NULL DEFAULT clock_timestamp(),
modified_at timestamptz NOT NULL DEFAULT clock_timestamp(),
deleted_at timestamptz DEFAULT NULL,
version bigint NOT NULL DEFAULT 0,
width int NOT NULL,
height int NOT NULL,
mimetype text NOT NULL,
collection uuid REFERENCES images_collections(id)
ON DELETE SET NULL
DEFAULT NULL,
collection_id uuid REFERENCES images_collections(id)
ON DELETE SET NULL
DEFAULT NULL,
name text NOT NULL,
path text NOT NULL
);
@ -35,25 +32,19 @@ CREATE TABLE IF NOT EXISTS images (
-- Indexes
CREATE INDEX images_collections_user_idx
ON images_collections ("user");
ON images_collections (user_id);
CREATE INDEX images_collection_idx
ON images (collection);
ON images (collection_id);
CREATE INDEX images_user_idx
ON images ("user");
ON images (user_id);
-- Triggers
CREATE TRIGGER images_collections_occ_tgr BEFORE UPDATE ON images_collections
FOR EACH ROW EXECUTE PROCEDURE handle_occ();
CREATE TRIGGER images_collections_modified_at_tgr BEFORE UPDATE ON images_collections
FOR EACH ROW EXECUTE PROCEDURE update_modified_at();
CREATE TRIGGER images_occ_tgr BEFORE UPDATE ON images
FOR EACH ROW EXECUTE PROCEDURE handle_occ();
CREATE TRIGGER images_modified_at_tgr BEFORE UPDATE ON images
FOR EACH ROW EXECUTE PROCEDURE update_modified_at();

25
backend/resources/migrations/0008.icons.up.sql
View file

@ -2,55 +2,48 @@
CREATE TABLE IF NOT EXISTS icons_collections (
id uuid PRIMARY KEY DEFAULT uuid_generate_v4(),
"user" uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
user_id uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
created_at timestamptz NOT NULL DEFAULT clock_timestamp(),
modified_at timestamptz NOT NULL DEFAULT clock_timestamp(),
deleted_at timestamptz DEFAULT NULL,
version bigint NOT NULL DEFAULT 0,
name text NOT NULL
);
CREATE TABLE IF NOT EXISTS icons (
id uuid PRIMARY KEY DEFAULT uuid_generate_v4(),
"user" uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
user_id uuid NOT NULL REFERENCES users(id) ON DELETE CASCADE,
created_at timestamptz NOT NULL DEFAULT clock_timestamp(),
modified_at timestamptz NOT NULL DEFAULT clock_timestamp(),
deleted_at timestamptz DEFAULT NULL,
version bigint NOT NULL DEFAULT 0,
name text NOT NULL,
content text NOT NULL,
metadata bytea NOT NULL,
collection uuid REFERENCES icons_collections(id)
ON DELETE SET NULL
DEFAULT NULL
collection_id uuid REFERENCES icons_collections(id)
ON DELETE SET NULL
DEFAULT NULL
);
-- Indexes
CREATE INDEX icon_colections_user_idx
ON icons_collections ("user");
ON icons_collections (user_id);
CREATE INDEX icons_user_idx
ON icons ("user");
ON icons (user_id);
CREATE INDEX icons_collection_idx
ON icons (collection);
ON icons (collection_id);
-- Triggers
CREATE TRIGGER icons_collections_occ_tgr BEFORE UPDATE ON icons_collections
FOR EACH ROW EXECUTE PROCEDURE handle_occ();
CREATE TRIGGER icons_collections_modified_at_tgr BEFORE UPDATE ON icons_collections
FOR EACH ROW EXECUTE PROCEDURE update_modified_at();
CREATE TRIGGER icons_occ_tgr BEFORE UPDATE ON icons
FOR EACH ROW EXECUTE PROCEDURE handle_occ();
CREATE TRIGGER icons_modified_at_tgr BEFORE UPDATE ON icons
FOR EACH ROW EXECUTE PROCEDURE update_modified_at();

42
backend/resources/migrations/0009.history.improvements.up.sql
View file

@ -1,42 +0,0 @@
DROP TRIGGER page_on_update_tgr ON pages;
CREATE OR REPLACE FUNCTION handle_page_update()
RETURNS TRIGGER AS $pagechange$
BEGIN
--- Update projects modified_at attribute when a
--- page of that project is modified.
UPDATE projects SET modified_at = clock_timestamp()
WHERE id = OLD.project;
RETURN NEW;
END;
$pagechange$ LANGUAGE plpgsql;
CREATE OR REPLACE FUNCTION handle_page_history()
RETURNS TRIGGER AS $pagehistory$
BEGIN
INSERT INTO pages_history (page, "user", created_at,
modified_at, data, version)
VALUES (NEW.id, NEW."user", NEW.modified_at,
NEW.modified_at, NEW.data, NEW.version);
RETURN NEW;
END;
$pagehistory$ LANGUAGE plpgsql;
CREATE TRIGGER page_on_insert_tgr
AFTER INSERT ON pages
FOR EACH ROW
EXECUTE PROCEDURE handle_page_history();
CREATE TRIGGER page_on_update_tgr
AFTER UPDATE ON pages
FOR EACH ROW
EXECUTE PROCEDURE handle_page_update();
CREATE TRIGGER page_on_update_history_tgr
AFTER UPDATE ON pages
FOR EACH ROW
WHEN (OLD.data IS DISTINCT FROM NEW.data)
EXECUTE PROCEDURE handle_page_history();

12
backend/resources/migrations/XXXX.workers.up.sql
View file

@ -1,11 +1 @@
CREATE TYPE task_status
AS ENUM ('pending', 'canceled', 'completed', 'failed');
CREATE TABLE task (
id uuid PRIMARY KEY DEFAULT uuid_generate_v4(),
created_at timestamptz NOT NULL DEFAULT clock_timestamp(),
completed_at timestamptz DEFAULT NULL,
queue text NOT NULL DEFAULT '',
status task_status NOT NULL DEFAULT 'pending',
error text NOT NULL DEFAULT ''
) WITH (OIDS=FALSE);
select version();

53
backend/resources/sql/cli.sql
View file

@ -1,53 +0,0 @@
-- :name get-image-collection :? :1
select *
from images_collections as cc
where cc.id = :id
and cc."user" = '00000000-0000-0000-0000-000000000000'::uuid;
-- :name create-image :<! :1
insert into images ("user", id, name, collection, path, width, height, mimetype)
values ('00000000-0000-0000-0000-000000000000'::uuid,
:id, :name, :collection, :path, :width, :height, :mimetype)
returning *;
-- :name delete-image :! :n
delete from images
where id = :id
and "user" = '00000000-0000-0000-0000-000000000000'::uuid;
-- :name create-images-collection
insert into images_collections (id, "user", name)
values (:id, '00000000-0000-0000-0000-000000000000'::uuid, :name)
on conflict (id)
do update set name = :name
returning *;
-- :name get-image
select * from images as i
where i.id = :id
and i."user" = '00000000-0000-0000-0000-000000000000'::uuid;
-- :name create-icons-collection
insert into icons_collections (id, "user", name)
values (:id, '00000000-0000-0000-0000-000000000000'::uuid, :name)
on conflict (id)
do update set name = :name
returning *;
-- :name get-icon
select * from icons as i
where i.id = :id
and i."user" = '00000000-0000-0000-0000-000000000000'::uuid;
-- :name create-icon :<! :1
insert into icons ("user", id, name, collection, metadata, content)
values ('00000000-0000-0000-0000-000000000000'::uuid,
:id, :name, :collection, :metadata, :content)
on conflict (id)
do update set name = :name,
content = :content,
metadata = :metadata,
collection = :collection,
"user" = '00000000-0000-0000-0000-000000000000'::uuid
returning *;

45
backend/resources/sql/emails.sql
View file

@ -1,45 +0,0 @@
-- :name insert-email :! :n
insert into email_queue (data, priority)
values (:data, :priority);
-- :name get-pending-emails :? :*
select eq.* from email_queue as eq
where eq.status = 'pending'
and eq.deleted_at is null
order by eq.priority desc,
eq.created_at desc;
-- :name get-immediate-emails :? :*
select eq.* from email_queue as eq
where eq.status = 'pending'
and eq.priority = 10
and eq.deleted_at is null
order by eq.priority desc,
eq.created_at desc;
-- :name get-failed-emails :? :*
select eq.* from email_queue as eq
where eq.status = 'failed'
and eq.deleted_at is null
and eq.retries < :max-retries
order by eq.priority desc,
eq.created_at desc;
-- :name mark-email-as-sent :! :n
update email_queue
set status = 'ok'
where id = :id
and deleted_at is null;
-- :name mark-email-as-failed :! :n
update email_queue
set status = 'failed',
retries = retries + 1
where id = :id
and deleted_at is null;
-- :name delete-email :! :n
update email_queue
set deleted_at = clock_timestamp()
where id = :id
and deleted_at is null;

69
backend/resources/sql/icons.sql
View file

@ -1,69 +0,0 @@
-- :name create-icon-collection :<! :1
insert into icons_collections (id, "user", name)
values (:id, :user, :name)
returning *;
-- :name update-icon-collection :<! :1
update icons_collections
set name = :name,
version = :version
where id = :id
and "user" = :user
returning *;
-- :name get-icon-collections :? :*
select *,
(select count(*) from icons where collection = ic.id) as num_icons
from icons_collections as ic
where (ic."user" = :user or
ic."user" = '00000000-0000-0000-0000-000000000000'::uuid)
and ic.deleted_at is null
order by ic.created_at desc;
-- :name delete-icon-collection :! :n
update icons_collections
set deleted_at = clock_timestamp()
where id = :id and "user" = :user;
-- :name get-icons-by-collection :? :*
select *
from icons as i
where (i."user" = :user or
i."user" = '00000000-0000-0000-0000-000000000000'::uuid)
and i.deleted_at is null
and i."collection" = :collection
order by i.created_at desc;
-- :name get-icons :? :*
select * from icons
where "user" = :user
and deleted_at is null
and collection is null
order by created_at desc;
-- :name get-icon :? :1
select * from icons
where id = :id
and deleted_at is null
and ("user" = :user or
"user" = '00000000-0000-0000-0000-000000000000'::uuid);
-- :name create-icon :<! :1
insert into icons ("user", name, collection, metadata, content)
values (:user, :name, :collection, :metadata, :content)
returning *;
-- :name update-icon :<! :1
update icons
set name = :name,
collection = :collection,
version = :version
where id = :id
and "user" = :user
returning *;
-- :name delete-icon :! :n
update icons
set deleted_at = clock_timestamp()
where id = :id
and "user" = :user;

67
backend/resources/sql/images.sql
View file

@ -1,67 +0,0 @@
-- :name create-image-collection :<! :1
insert into images_collections (id, "user", name)
values (:id, :user, :name)
returning *;
-- :name update-image-collection :<! :1
update images_collections
set name = :name,
version = :version
where id = :id
and "user" = :user
returning *;
-- :name get-image-collections :? :*
select *,
(select count(*) from images where collection = ic.id) as num_images
from images_collections as ic
where (ic."user" = :user or
ic."user" = '00000000-0000-0000-0000-000000000000'::uuid)
and ic.deleted_at is null
order by ic.created_at desc;
-- :name delete-image-collection :! :n
update images_collections
set deleted_at = clock_timestamp()
where id = :id
and "user" = :user;
-- :name get-images-by-collection :? :*
select * from images
where ("user" = :user or
"user" = '00000000-0000-0000-0000-000000000000'::uuid)
and deleted_at is null
and collection = :collection
order by created_at desc;
-- :name get-images :? :*
select * from images
where "user" = :user
and deleted_at is null
and collection is null
order by created_at desc;
-- :name get-image :? :1
select * from images
where id = :id
and deleted_at is null;
-- :name create-image :<! :1
insert into images ("user", name, collection, path, width, height, mimetype)
values (:user, :name, :collection, :path, :width, :height, :mimetype)
returning *;
-- :name update-image :<! :1
update images
set name = :name,
collection = :collection,
version = :version
where id = :id
and "user" = :user
returning *;
-- :name delete-image :! :n
update images
set deleted_at = clock_timestamp()
where id = :id and "user" = :user
returning *;

17
backend/resources/sql/kvstore.sql
View file

@ -1,17 +0,0 @@
-- :name update-kvstore :<! :1
insert into kvstore (key, value, "user")
values (:key, :value, :user)
on conflict ("user", key)
do update set value = :value, version = :version
returning *;
-- :name retrieve-kvstore :? :1
select kv.*
from kvstore as kv
where kv."user" = :user
and kv.key = :key;
-- :name delete-kvstore :! :n
delete from kvstore
where "user" = :user
and key = :key;

88
backend/resources/sql/pages.sql
View file

@ -1,88 +0,0 @@
-- :name create-page :<! :1
insert into pages (id, "user", project, name, data, metadata)
values (:id, :user, :project, :name, :data, :metadata)
returning *;
-- :name update-page :<! :1
update pages
set name = :name,
data = :data,
version = :version,
metadata = :metadata
where id = :id
and "user" = :user
and deleted_at is null
returning *;
-- :name update-page-metadata :<! :1
update pages
set name = :name,
version = :version,
metadata = :metadata
where id = :id
and "user" = :user
and deleted_at is null
returning *;
-- :name delete-page :! :n
update pages
set deleted_at = clock_timestamp()
where id = :id
and "user" = :user
and deleted_at is null;
-- :name get-pages :? :*
select pg.*
from pages as pg
where pg.user = :user
and pg.deleted_at is null
order by created_at asc;
-- :name get-page-by-id :? :1
select pg.* from pages as pg
where pg.id = :id
and pg.deleted_at is null;
-- :name get-pages-for-user-and-project :? :*
select pg.*
from pages as pg
where pg.user = :user
and pg.project = :project
and pg.deleted_at is null
order by pg.created_at asc;
-- :name get-pages-for-project :? :*
select pg.*
from pages as pg
where pg.project = :project
and pg.deleted_at is null
order by created_at asc;
-- :name create-page-history :! :n
insert into page_history (id, "user", page, pinned, label, data, version);
values (:id, :user, :page, :pinned :label, :data, :version);
-- :name get-page-history :? :*
select ph.*
from pages_history as ph
where ph.user = :user
and ph.page = :page
and ph.version < :since
--~ (when (:pinned params) "and ph.pinned = true")
order by ph.version desc
limit :max;
-- :name get-page-history-for-project :? :*
select ph.*
from pages_history as ph
inner join pages as p
on (p.id = ph.page)
where p.project = :project;
-- :name update-page-history :? :*
update pages_history
set label = :label,
pinned = :pinned
where id = :id
and "user" = :user
returning *;

49
backend/resources/sql/projects.sql
View file

@ -1,49 +0,0 @@
-- :name create-project :<! :1
insert into projects (id, "user", name)
values (:id, :user, :name)
returning *;
-- :name update-project :<! :1
update projects
set name = :name,
version = :version
where id = :id
and "user" = :user
and deleted_at is null
returning *;
-- :name delete-project :! :n
update projects
set deleted_at = clock_timestamp()
where id = :id
and "user" = :user
and deleted_at is null;
-- :name get-project-by-id :? :1
select p.*
from projects as p
where p.id = :id
and p.deleted_at is null;
-- :name get-projects :? :*
select pr.*,
ps.token as share_token
from projects as pr
inner join project_shares as ps
on (ps.project = pr.id)
where pr.deleted_at is null
and pr."user" = :user
order by pr.created_at asc;
-- :name get-project-by-share-token :? :*
select p.*
from projects as p
inner join project_shares as ps
on (p.id = ps.project)
where ps.token = :token;
-- :name get-share-tokens-for-project
select s.*
from project_shares as s
where s.project = :project
order by s.created_at desc;

69
backend/resources/sql/users.sql
View file

@ -1,69 +0,0 @@
-- :name create-profile :<! :1
insert into users (id, fullname, username, email, password, metadata, photo)
values (:id, :fullname, :username, :email, :password, :metadata, '')
returning *;
-- :name get-profile :? :1
select * from users
where id = :id
and deleted_at is null;
-- :name get-profile-by-username :? :1
select * from users
where (username = :username or email = :username)
and deleted_at is null;
-- :name user-with-username-exists?
select exists
(select * from users
where username = :username
--~ (when (:id params) "and id != :id")
) as val;
-- :name user-with-email-exists?
select exists
(select * from users
where email = :email
--~ (when (:id params) "and id != :id")
) as val;
-- :name update-profile :<! :1
update users
set username = :username,
email = :email,
fullname = :fullname,
metadata = :metadata
where id = :id
and deleted_at is null
returning *;
-- :name update-profile-password :! :n
update users
set password = :password
where id = :id
and deleted_at is null
-- :name update-profile-photo :! :n
update users
set photo = :photo
where id = :id
and deleted_at is null
-- :name create-recovery-token :! :n
insert into user_pswd_recovery ("user", token)
values (:user, :token);
-- :name get-recovery-token
select * from user_pswd_recovery
where used_at is null
and token = :token;
-- :name recovery-token-exists? :? :1
select exists (select * from user_pswd_recovery
where used_at is null
and token = :token) as token_exists;
-- :name mark-recovery-token-used :! :n
update user_pswd_recovery
set used_at = clock_timestamp()
where token = :token;

53
backend/resources/sql/workers.sql
View file

@ -1,53 +0,0 @@
-- :name acquire-task :? :1
with recursive locked_tasks as (
select (j).*, pg_try_advisory_lock((j).id) as locked
from (
select j
from tasks as j
where queue = :queue
and status = 'pending'
and created_at <= now()
order by created_at, id
limit 1
) as t1
union all (
select (j).*, pg_try_advisory_lock((j).id) as locked
from (
select (
select j
from tasks as j
where queue = :queue
and status = 'pending'
and created_at <= now()
and (created_at, id) > (locked_tasks.created_at, locked_tasks.id)
order by created_at, id
limit 1
) as j
from locked_tasks
where locked_tasks.id is not null
limit 1
) as t1
)
)
select id, status, error, created_at
from locked_tasks
where locked
limit 1;
-- :name create-task :? :1
insert into tasks (queue)
values (:queue)
returning *;
-- :name mark-task-done
update tasks
set status = 'completed',
completed_at = clock_timestamp()
where id = :id;
-- :name mark-task-failed
update tasks
set status = 'failed',
error = :error,
completed_at = clock_timestamp()
where id = :id;

69
backend/src/user.clj
View file

@ -5,18 +5,48 @@
;; Copyright (c) 2016-2019 Andrey Antukh <niwi@niwi.nz>
(ns user
(:require [clojure.tools.namespace.repl :as repl]
[clojure.walk :refer [macroexpand-all]]
[clojure.pprint :refer [pprint]]
[clojure.test :as test]
[clojure.java.io :as io]
[buddy.core.codecs :as codecs]
[buddy.core.codecs.base64 :as b64]
[buddy.core.nonce :as nonce]
[mount.core :as mount]
[uxbox.main])
(:require
[clojure.tools.namespace.repl :as repl]
[clojure.walk :refer [macroexpand-all]]
[clojure.pprint :refer [pprint]]
[clojure.test :as test]
[clojure.java.io :as io]
[criterium.core :refer [quick-bench bench with-progress-reporting]]
[expound.alpha :as expound]
[promesa.core :as p]
[sieppari.core :as sp]
[sieppari.context :as spx]
[buddy.core.codecs :as codecs]
[buddy.core.codecs.base64 :as b64]
[buddy.core.nonce :as nonce]
[mount.core :as mount]
[uxbox.main]
[uxbox.util.blob :as blob])
(:gen-class))
(defmacro run-quick-bench
[& exprs]
`(with-progress-reporting (quick-bench (do ~@exprs) :verbose)))
(defmacro run-quick-bench'
[& exprs]
`(quick-bench (do ~@exprs)))
(defmacro run-bench
[& exprs]
`(with-progress-reporting (bench (do ~@exprs) :verbose)))
(defmacro run-bench'
[& exprs]
`(bench (do ~@exprs)))
(def stress-data
{:shapes [{:id #uuid "352cbd3c-1336-5793-80f7-31027d0acfe7", :name "Canvas-1", :type :canvas, :page #uuid "1b7d4218-e3be-5254-9582-18f767d30501", :x1 200, :y1 200, :x2 1224, :y2 968} {:stroke-color "#000000", :name "Rect-1-copy-4-copy-1", :y1 334, :width 2, :type :rect, :page #uuid "2ef8e638-4018-5581-aa18-0887f126966c", :canvas #uuid "352cbd3c-1336-5793-80f7-31027d0acfe7", :proportion-lock false, :id #uuid "c1966bac-b568-4f8f-9917-227cc37e5672", :x1 674, :proportion 1.353448275862069, :y2 450, :x2 831, :height 2} {:stroke-color "#000000", :name "Rect-1-copy-7-copy-1", :y1 400, :width 2, :type :rect, :page #uuid "2ef8e638-4018-5581-aa18-0887f126966c", :canvas #uuid "352cbd3c-1336-5793-80f7-31027d0acfe7", :proportion-lock false, :id #uuid "20f11fd1-e9a2-41b1-a539-1298194c6d07", :x1 836, :proportion 1.353448275862069, :y2 516, :x2 993, :height 2} {:stroke-color "#000000", :name "Rect-1-copy-11", :y1 355, :width 2, :type :rect, :page #uuid "2ef8e638-4018-5581-aa18-0887f126966c", :canvas #uuid "352cbd3c-1336-5793-80f7-31027d0acfe7", :proportion-lock false, :id #uuid "e1efb49a-03dd-4b87-b568-f35e3a85cf19", :x1 223, :proportion 1.353448275862069, :y2 471, :x2 380, :height 2} {:stroke-color "#000000", :name "Rect-1-copy-10", :y1 404, :width 2, :type :rect, :page #uuid "2ef8e638-4018-5581-aa18-0887f126966c", :canvas #uuid "352cbd3c-1336-5793-80f7-31027d0acfe7", :proportion-lock false, :id #uuid "4bf2440d-38d4-461b-af41-001cfb00be49", :x1 928, :proportion 1.353448275862069, :y2 520, :x2 1085, :height 2} {:stroke-color "#000000", :name "Rect-1-copy-9", :y1 525, :width 2, :type :rect, :page #uuid "2ef8e638-4018-5581-aa18-0887f126966c", :canvas #uuid "352cbd3c-1336-5793-80f7-31027d0acfe7", :proportion-lock false, :id #uuid "bd1cb612-3960-4428-b030-ea0e59c70b06", :x1 497, :proportion 1.353448275862069, :y2 641, :x2 654, :height 2} {:stroke-color "#000000", :name "Rect-1-copy-8", :y1 393, :width 2, :type :rect, :page #uuid "2ef8e638-4018-5581-aa18-0887f126966c", :canvas #uuid "352cbd3c-1336-5793-80f7-31027d0acfe7", :proportion-lock false, :id #uuid "78104154-3d6b-43dc-8444-873ca3285bca", :x1 395, :proportion 1.353448275862069, :y2 509, :x2 552, :height 2} {:stroke-color "#000000", :name "Rect-1-copy-7", :y1 711, :width 2, :type :rect, :page #uuid "2ef8e638-4018-5581-aa18-0887f126966c", :canvas #uuid "352cbd3c-1336-5793-80f7-31027d0acfe7", :proportion-lock false, :id #uuid "35540bc3-e1a9-4052-8cb7-a4b07da229dd", :x1 838, :proportion 1.353448275862069, :y2 827, :x2 995, :height 2} {:stroke-color "#000000", :name "Rect-1-copy-6", :y1 502, :width 2, :type :rect, :page #uuid "2ef8e638-4018-5581-aa18-0887f126966c", :canvas #uuid "352cbd3c-1336-5793-80f7-31027d0acfe7", :proportion-lock false, :id #uuid "a4d2ef30-1da9-4aba-98ed-15088aba36e0", :x1 893, :proportion 1.353448275862069, :y2 618, :x2 1050, :height 2} {:stroke-color "#000000", :name "Rect-1-copy-5", :y1 479, :width 2, :type :rect, :page #uuid "2ef8e638-4018-5581-aa18-0887f126966c", :canvas #uuid "352cbd3c-1336-5793-80f7-31027d0acfe7", :proportion-lock false, :id #uuid "4de4a87a-74f3-47ce-85e6-a0d5da9adb62", :x1 595, :proportion 1.353448275862069, :y2 595, :x2 752, :height 2} {:stroke-color "#000000", :name "Rect-1-copy-4", :y1 645, :width 2, :type :rect, :page #uuid "2ef8e638-4018-5581-aa18-0887f126966c", :canvas #uuid "352cbd3c-1336-5793-80f7-31027d0acfe7", :proportion-lock false, :id #uuid "c6c062d2-20fe-4e48-8035-63358db2df4c", :x1 676, :proportion 1.353448275862069, :y2 761, :x2 833, :height 2} {:stroke-color "#000000", :name "Rect-1-copy-3", :y1 609, :width 2, :type :rect, :page #uuid "2ef8e638-4018-5581-aa18-0887f126966c", :canvas #uuid "352cbd3c-1336-5793-80f7-31027d0acfe7", :proportion-lock false, :id #uuid "b3089c39-24f9-4574-8df1-d1e4596a6200", :x1 831, :proportion 1.353448275862069, :y2 725, :x2 988, :height 2} {:stroke-color "#000000", :name "Rect-1-copy-2", :y1 404, :width 2, :type :rect, :page #uuid "2ef8e638-4018-5581-aa18-0887f126966c", :canvas #uuid "352cbd3c-1336-5793-80f7-31027d0acfe7", :proportion-lock false, :id #uuid "da7c624b-807a-41b1-84a6-7e14ed4f150c", :x1 733, :proportion 1.353448275862069, :y2 520, :x2 890, :height 2} {:stroke-color "#000000", :name "Rect-1-copy-1", :y1 609, :width 2, :type :rect, :page #uuid "2ef8e638-4018-5581-aa18-0887f126966c", :canvas #uuid "352cbd3c-1336-5793-80f7-31027d0acfe7", :proportion-lock false, :id #uuid "ec65a0a8-9de1-48d7-b245-71f98961dc7c", :x1 518, :proportion 1.353448275862069, :y2 725, :x2 675, :height 2} {:stroke-color "#000000", :name "Rect-1", :y1 566, :width 2, :type :rect, :page #uuid "2ef8e638-4018-5581-aa18-0887f126966c", :canvas #uuid "352cbd3c-1336-5793-80f7-31027d0acfe7", :proportion-lock false, :id #uuid "c7eafc25-214a-4d16-abbe-19aa0f2eb25b", :x1 306, :proportion 1.353448275862069, :y2 682, :x2 463, :height 2}]})
;; (def a1 (blob/encode stress-data))
;; (def b1 (blob/encode-with-json stress-data))
;; (def b2 (blob/encode-json-snappy stress-data))
;; --- Development Stuff
(defn- make-secret
@ -27,24 +57,29 @@
(defn- start
[]
(-> (mount/except #{#'uxbox.scheduled-jobs/scheduler})
(-> #_(mount/except #{#'uxbox.scheduled-jobs/scheduler})
(mount/start)))
(defn- stop
[]
(mount/stop))
(defn- start-minimal
(defn restart
[]
(-> (mount/only #{#'uxbox.config/config
#'uxbox.db/datasource
#'uxbox.migrations/migrations})
(mount/start)))
(stop)
(repl/refresh :after 'user/start))
;; (defn- start-minimal
;; []
;; (-> (mount/only #{#'uxbox.config/config
;; #'uxbox.db/datasource
;; #'uxbox.migrations/migrations})
;; (mount/start)))
(defn- run-test
([] (run-test #"^uxbox.tests.*"))
([o]
(repl/refresh)
;; (repl/refresh)
(cond
(instance? java.util.regex.Pattern o)
(test/run-all-tests o)

72
backend/src/uxbox/api/auth.clj
View file

@ -1,72 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.api.auth
(:require [clojure.spec.alpha :as s]
[promesa.core :as p]
[struct.core :as st]
[uxbox.services :as sv]
[uxbox.http.response :as rsp]
[uxbox.util.spec :as us]
[uxbox.util.uuid :as uuid]))
(defn login
{:description "User login endpoint"
:parameters {:body {:username [st/required st/string]
:password [st/required st/string]
:scope [st/required st/string]}}}
[ctx]
(let [data (get-in ctx [:parameters :body])]
(->> (sv/novelty (assoc data :type :login))
(p/map (fn [{:keys [id] :as user}]
(-> (rsp/no-content)
(assoc :session {:user-id id})))))))
(defn logout
{:description "User logout endpoint"}
[req]
(-> (rsp/no-content)
(assoc :session nil)
(p/resolved)))
(defn register
{:parameters {:body {:username [st/required st/string]
:email [st/required st/email]
:password [st/required st/string]
:fullname [st/required st/string]}}}
[{:keys [parameters]}]
(let [data (get parameters :body)
message (assoc data :type :register-profile)]
(->> (sv/novelty message)
(p/map rsp/ok))))
(defn request-recovery
{:parameters {:body {:username [st/required st/string]}}}
[{:keys [parameters]}]
(let [data (get parameters :body)
message (assoc data :type :request-profile-password-recovery)]
(->> (sv/novelty message)
(p/map (constantly (rsp/no-content))))))
(defn recover-password
{:parameters {:body {:token [st/required st/string]
:password [st/required st/string]}}}
[{:keys [parameters]}]
(let [data (get parameters :body)
message (assoc data :type :recover-profile-password)]
(->> (sv/novelty message)
(p/map (constantly (rsp/no-content))))))
(defn validate-recovery-token
{:parameters {:path {:token [st/required st/string]}}}
[{:keys [parameters]}]
(let [message {:type :validate-profile-password-recovery-token
:token (get-in parameters [:path :token])}]
(->> (sv/query message)
(p/map (fn [v]
(if v
(rsp/no-content)
(rsp/not-found "")))))))

67
backend/src/uxbox/api/debug_emails.clj
View file

@ -1,67 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.api.debug-emails
"A helper namespace for just render emails."
(:require [clojure.edn :as edn]
[hiccup.page :refer (html5)]
[uxbox.emails :as emails]
[uxbox.emails.core :as emails-core]))
;; (def +available-emails+
;; {:users/register
;; {:name "Cirilla"}
;; :users/password-recovery
;; {:name "Cirilla"
;; :token "agNFhA6SolcFb4Us2NOTNWh0cfFDquVLAav400xQPjw"}})
;; (defn- render-emails-list
;; []
;; (html5
;; [:section {:style "font-family: Monoid, monospace; font-size: 14px;"}
;; [:h1 "Available emails"]
;; [:table {:style "width: 500px;"}
;; [:tbody
;; [:tr
;; (for [[type email] @emails-core/emails]
;; [:tr
;; [:td (pr-str type)]
;; [:td
;; [:a {:href (str "/debug/emails/email?id="
;; (pr-str type)
;; "&type=:text/html")}
;; "(html)"]]
;; [:td
;; [:a {:href (str "/debug/emails/email?id="
;; (pr-str type)
;; "&type=:text/plain")}
;; "(text)"]]])]]]]))
;; (defn list-emails
;; [context]
;; (http/ok (render-emails-list)
;; {:content-type "text/html; charset=utf-8"}))
;; (defn- render-email
;; [type content]
;; (if (= type :text/html)
;; content
;; (html5
;; [:pre content])))
;; (defn show-email
;; [{params :query-params}]
;; (let [id (edn/read-string (:id params))
;; type (or (edn/read-string (:type params)) :text/html)
;; params (-> (get +available-emails+ id)
;; (assoc :email/name id))
;; email (emails/render params)
;; content (->> (:body email)
;; (filter #(= (:uxbox.emails.core/type %) type))
;; (first)
;; (:content))]
;; (-> (render-email type content)
;; (http/ok {:content-type "text/html; charset=utf-8"}))))

131
backend/src/uxbox/api/icons.clj
View file

@ -1,131 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.api.icons
(:require [struct.core :as st]
[promesa.core :as p]
[uxbox.services :as sv]
[uxbox.http.response :as rsp]
[uxbox.util.spec :as us]
[uxbox.util.uuid :as uuid]))
(defn create-collection
{:parameters {:body {:name [st/required st/string]
:id [st/uuid]}}}
[{:keys [user parameters]}]
(let [data (get parameters :body)
message (assoc data
:type :create-icon-collection
:user user)]
(->> (sv/novelty message)
(p/map (fn [result]
(let [loc (str "/api/library/icons/" (:id result))]
(rsp/created loc result)))))))
(defn update-collection
{:parameters {:path {:id [st/required st/uuid-str]}
:body {:name [st/required st/string]
:version [st/required st/integer]
:id [st/uuid]}}}
[{:keys [user parameters]}]
(let [data (get parameters :body)
message (assoc data
:id (get-in parameters [:path :id])
:type :update-icon-collection
:user user)]
(-> (sv/novelty message)
(p/then #(rsp/ok %)))))
(defn delete-collection
{:parameters {:path {:id [st/required st/uuid-str]}}}
[{:keys [user parameters]}]
(let [message {:id (get-in parameters [:path :id])
:type :delete-icon-collection
:user user}]
(-> (sv/novelty message)
(p/then (fn [v] (rsp/no-content))))))
(defn list-collections
[{:keys [user]}]
(let [params {:user user :type :list-icon-collections}]
(-> (sv/query params)
(p/then #(rsp/ok %)))))
;; (def metadata-spec
;; {:width [st/number st/positive]
;; :height [st/number st/positive]
;; :view-box [st/coll [st/every number?]]
;; :mimetype [st/string]})
;; (def metadata-validator
;; {:message "must be a metadata"
;; :optional true
;; :validate #(st/valid? %1 metadata-spec)})
(defn create-icon
{:parameters {:body {:id [st/uuid]
:collection [st/uuid]
:metadata [st/required] ;; TODO
:name [st/required st/string]
:content [st/required st/string]}}}
[{:keys [user parameters]}]
(let [id (or (get-in parameters [:body :id]) (uuid/random))
data (get parameters :body)
message (assoc data
:user user
:id id
:type :create-icon)]
(->> (sv/novelty message)
(p/map (fn [entry]
(let [loc (str "/api/library/icons/" (:id entry))]
(rsp/created loc entry)))))))
(defn update-icon
{:parameters {:path {:id [st/required st/uuid-str]}
:body {:name [st/required st/string]
:version [st/required st/number]
:collection [st/uuid]}}}
[{:keys [user parameters]}]
(let [data (get parameters :body)
message (assoc data
:id (get-in parameters [:path :id])
:type :update-icon
:user user)]
(->> (sv/novelty message)
(p/map rsp/ok))))
(defn copy-icon
{:parameters {:path {:id [st/required st/uuid-str]}
:body {:collection [st/uuid]}}}
[{:keys [user parameters]}]
(let [data (get parameters :body)
message {:collection (get-in parameters [:body :collection])
:id (get-in parameters [:path :id])
:user user
:type :copy-icon}]
(->> (sv/novelty message)
(p/map rsp/ok))))
(defn delete-icon
{:parameters {:path {:id [st/required st/uuid-str]}}}
[{:keys [user parameters]}]
(let [message {:id (get-in parameters [:path :id])
:type :delete-icon
:user user}]
(->> (sv/novelty message)
(p/map (fn [v] (rsp/no-content))))))
(defn list-icons
{:parameters {:query {:collection [st/uuid-str]}}}
[{:keys [user parameters]}]
(let [collection (get-in parameters [:query :collection])
message {:collection collection
:type :list-icons
:user user}]
(->> (sv/query message)
(p/map rsp/ok))))

169
backend/src/uxbox/api/images.clj
View file

@ -1,169 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.api.images
(:require [struct.core :as st]
[promesa.core :as p]
[datoteka.storages :as ds]
[datoteka.core :as fs]
[uxbox.media :as media]
[uxbox.images :as images]
[uxbox.services :as sv]
[uxbox.http.response :as rsp]
[uxbox.util.spec :as us]
[uxbox.util.uuid :as uuid]))
(def +thumbnail-options+ {:src :path
:dst :thumbnail
:width 300
:height 100
:quality 92
:format "webp"})
(def populate-thumbnails
#(images/populate-thumbnails % +thumbnail-options+))
(def populate-urls
#(images/populate-urls % media/images-storage :path :url))
(defn create-collection
{:parameters {:body {:name [st/required st/string]
:id [st/uuid]}}}
[{:keys [user parameters]}]
(let [data (get parameters :body)
message (assoc data
:type :create-image-collection
:user user)]
(->> (sv/novelty message)
(p/map (fn [result]
(let [loc (str "/api/library/images/" (:id result))]
(rsp/created loc result)))))))
(defn update-collection
{:parameters {:path {:id [st/required st/uuid-str]}
:body {:name [st/required st/string]
:version [st/required st/number]
:id [st/uuid]}}}
[{:keys [user parameters]}]
(let [data (get parameters :body)
message (assoc data
:id (get-in parameters [:path :id])
:type :update-image-collection
:user user)]
(-> (sv/novelty message)
(p/then rsp/ok))))
(defn delete-collection
{:parameters {:path {:id [st/required st/uuid-str]}}}
[{:keys [user parameters]}]
(let [message {:id (get-in parameters [:path :id])
:type :delete-image-collection
:user user}]
(-> (sv/novelty message)
(p/then (constantly (rsp/no-content))))))
(defn list-collections
[{:keys [user]}]
(let [params {:user user :type :list-image-collections}]
(-> (sv/query params)
(p/then rsp/ok))))
(defn retrieve-image
{:parameters {:path {:id [st/required st/uuid-str]}}}
[{:keys [user parameters]}]
(let [message {:user user
:type :retrieve-image
:id (get-in parameters [:path :id])}]
(->> (sv/query message)
(p/map (fn [result]
(if result
(-> (populate-thumbnails result)
(populate-urls)
(rsp/ok))
(rsp/not-found "")))))))
(defn create-image
{:parameters {:multipart {:file [st/required]
:id [st/uuid-str]
:width [st/required st/integer-str]
:height [st/required st/integer-str]
:mimetype [st/required st/string]
:collection [st/uuid-str]}}}
[{:keys [user parameters] :as ctx}]
(let [params (get parameters :multipart)
upload (get params :file)
filename (fs/name (:filename upload))
tempfile (:tempfile upload)
storage media/images-storage]
(letfn [(persist-image-entry [path]
(let [message (select-keys params [:id :width :height :collection :mimetype])]
(sv/novelty (assoc message
:id (or (:id params) (uuid/random))
:type :create-image
:name filename
:path (str path)
:user user))))
(create-response [entry]
(let [loc (str "/api/library/images/" (:id entry))]
(rsp/created loc entry)))]
(->> (ds/save storage filename tempfile)
(p/mapcat persist-image-entry)
(p/map populate-thumbnails)
(p/map populate-urls)
(p/map create-response)))))
(defn update-image
{:parameters {:path {:id [st/required st/uuid-str]}
:body {:name [st/required st/string]
:version [st/required st/number]
:collection [st/uuid]}}}
[{:keys [user parameters]}]
(let [data (get parameters :body)
message (assoc data
:id (get-in parameters [:path :id])
:type :update-image
:user user)]
(->> (sv/novelty message)
(p/map populate-thumbnails)
(p/map populate-urls)
(p/map rsp/ok))))
(defn copy-image
{:parameters {:path {:id [st/required st/uuid-str]}
:body {:collection [st/uuid]}}}
[{:keys [user parameters]}]
(let [message {:id (get-in parameters [:path :id])
:type :copy-image
:collection (get-in parameters [:body :collection])}]
(->> (sv/novelty message)
(p/map populate-thumbnails)
(p/map populate-urls)
(p/map rsp/ok))))
(defn delete-image
{:parameters {:path {:id [st/required st/uuid-str]}}}
[{:keys [user parameters]}]
(let [message {:id (get-in parameters [:path :id])
:type :delete-image
:user user}]
(->> (sv/novelty message)
(p/map (constantly (rsp/no-content))))))
;; --- List collections
(defn list-images
{:parameters {:query {:collection [st/uuid-str]}}}
[{:keys [user parameters]}]
(let [collection (get-in parameters [:query :collection])
message {:collection collection
:type :list-images
:user user}]
(->> (sv/query message)
(p/map (partial map populate-thumbnails))
(p/map (partial map populate-urls))
(p/map rsp/ok))))

53
backend/src/uxbox/api/kvstore.clj
View file

@ -1,53 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.api.kvstore
(:refer-clojure :exclude [update])
(:require [struct.core :as st]
[promesa.core :as p]
[uxbox.services :as sv]
[uxbox.media :as media]
[uxbox.http.response :as rsp]
[uxbox.util.spec :as us]
[uxbox.util.uuid :as uuid]))
(defn retrieve
{:parameters {:path {:key [st/required st/string]}}}
[{:keys [user parameters] }]
(let [key (get-in parameters [:path :key])
message {:key key
:type :retrieve-kvstore
:user user}]
(->> (sv/query message)
(p/map rsp/ok))))
(defn upsert
{:parameters {:path {:key [st/required st/string]}
:body {:value [st/required]
:version [st/number]}}}
[{:keys [user parameters]}]
(let [value (get-in parameters [:body :value])
key (get-in parameters [:path :key])
version (get-in parameters [:body :version])
message {:key key
:version version
:value value
:type :update-kvstore
:user user}]
(->> (sv/novelty message)
(p/map rsp/ok))))
(defn delete
{:parameters {:path {:key [st/required st/string]}}}
[{:keys [user parameters]}]
(let [key (get-in parameters [:path :key])
message {:key key
:type :delete-kvstore
:user user}]
(->> (sv/novelty message)
(p/map (constantly (rsp/no-content))))))

167
backend/src/uxbox/api/pages.clj
View file

@ -1,167 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.api.pages
(:require [clojure.spec.alpha :as s]
[struct.core :as st]
[promesa.core :as p]
[uxbox.services :as sv]
[uxbox.http.response :as rsp]
[uxbox.util.spec :as us]
[uxbox.util.uuid :as uuid]))
;; --- Common Specs
(s/def ::id ::us/uuid)
(s/def ::name string?)
(s/def ::project ::us/uuid)
(s/def ::version int?)
(s/def ::data any?)
(s/def ::metadata any?)
;; --- List Pages
(s/def ::list-pages|query
(s/keys :req-un [::project]))
(defn list-pages
{:parameters {:query ::list-pages|query}
:validation :spec}
[{:keys [user parameters]}]
(let [project (get-in parameters [:query :project])
message {:user user :project project :type :list-pages-by-project}]
(-> (sv/query message)
(p/then rsp/ok))))
;; --- Create Page
(s/def ::create-page|body
(s/keys :req-un [::data
::metadata
::project
::name]
:opt-un [::id]))
(defn create-page
{:parameters {:body ::create-page|body}
:validation :spec}
[{:keys [user parameters]}]
(let [data (get parameters :body)
message (assoc data :user user :type :create-page)]
(->> (sv/novelty message)
(p/map (fn [result]
(let [loc (str "/api/pages/" (:id result))]
(rsp/created loc result)))))))
;; --- Update Page
(s/def ::update-page|path
(s/keys :req-un [::id]))
(s/def ::update-page|body
(s/keys :req-un [::data
::metadata
::project
::name
::version]
:opt-un [::id]))
(defn update-page
{:parameters {:path ::update-page|path
:body ::update-page|body}
:validation :spec}
[{:keys [user parameters]}]
(let [id (get-in parameters [:path :id])
data (get parameters :body)
message (assoc data :id id :type :update-page :user user)]
(->> (sv/novelty message)
(p/map #(rsp/ok %)))))
;; --- Update Page Metadata
(s/def ::update-page-metadata|path
(s/keys :req-un [::id]))
(s/def ::update-page-metadata|body
(s/keys :req-un [::id
::metadata
::project
::name]))
(defn update-page-metadata
{:parameters {:path ::update-page-metadata|path
:body ::update-page-metadata|body}
:validation :spec}
[{:keys [user parameters]}]
(let [id (get-in parameters [:path :id])
data (get parameters :body)
message (assoc data :id id :type :update-page-metadata :user user)]
(->> (sv/novelty message)
(p/map rsp/ok))))
;; --- Delete Page
(s/def ::delete-page|path
(s/keys :req-un [::id]))
(defn delete-page
{:parameters {:path ::delete-page|path}
:validation :spec}
[{:keys [user parameters]}]
(let [id (get-in parameters [:path :id])
message {:id id :type :delete-page :user user}]
(-> (sv/novelty message)
(p/then (constantly (rsp/no-content))))))
;; --- Retrieve Page History
(s/def ::max ::us/integer)
(s/def ::since ::us/integer)
(s/def ::pinned ::us/boolean)
(s/def ::retrieve-page-history|path
(s/keys :req-un [::id]))
(s/def ::retrieve-page-history|query
(s/keys :opt-un [::max
::since
::pinned]))
(defn retrieve-page-history
"Retrieve the page history"
{:parameters {:path ::retrieve-page-history|path
:query ::retrieve-page-history|query}
:validation :spec}
[{:keys [user parameters]}]
(let [id (get-in parameters [:path :id])
data (get parameters :query)
message (assoc data :id id :type :list-page-history :user user)]
(->> (sv/query message)
(p/map rsp/ok))))
;; --- Update page history
(s/def ::hid ::us/uuid)
(s/def ::label string?)
(s/def ::update-page-history|path
(s/keys :req-un [::id ::hid]))
(s/def ::update-page-history|body
(s/keys :req-un [::label ::pinned]))
(defn update-page-history
{:parameters {:path ::update-page-history|path
:body ::update-page-history|body}
:validation :spec}
[{:keys [user parameters]}]
(let [{:keys [id hid]} (get parameters :path)
message (assoc (get parameters :body)
:type :update-page-history
:id hid
:user user)]
(->> (sv/novelty message)
(p/map rsp/ok))))

102
backend/src/uxbox/api/projects.clj
View file

@ -1,102 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.api.projects
(:require [clojure.spec.alpha :as s]
[clojure.pprint :refer [pprint]]
[struct.core :as st]
[promesa.core :as p]
[uxbox.services :as sv]
[uxbox.http.response :as rsp]
[uxbox.util.spec :as us]
[uxbox.util.uuid :as uuid]
[uxbox.util.exceptions :as ex]))
;; --- Common Specs
(s/def ::id ::us/uuid)
(s/def ::name string?)
(s/def ::version int?)
;; --- List Projects
(defn list-projects
{:description "List projects"}
[{:keys [user] :as req}]
(let [message {:user user :type :list-projects}]
(->> (sv/query message)
(p/map rsp/ok))))
;; --- Create Projects
(s/def ::create-project|body
(s/keys :req-un [::name]
:opt-un [::id]))
(defn create-project
"Create project"
{:parameters {:body ::create-project|body}
:validation :spec}
[{:keys [user parameters] :as req}]
(let [data (get parameters :body)
message (assoc data :type :create-project :user user)]
(->> (sv/novelty message)
(p/map (fn [result]
(let [loc (str "/api/projects/" (:id result))]
(rsp/created loc result)))))))
;; --- Update Project
(s/def ::update-project|path
(s/keys :req-un [::id]))
(s/def ::update-project|body
(s/keys :req-un [::name ::version]))
(defn update-project
"Update project"
{:parameters {:path ::update-project|path
:body ::update-project|body}
:validation :spec}
[{:keys [user parameters] :as req}]
(let [id (get-in parameters [:path :id])
data (get parameters :body)
message (assoc data :id id :type :update-project :user user)]
(-> (sv/novelty message)
(p/then rsp/ok))))
;; --- Delete Project
(s/def ::delete-project|path
(s/keys :req-un [::id]))
(defn delete-project
"Delete project"
{:parameters {:path ::delete-project|path}
:validation :spec}
[{:keys [user parameters] :as req}]
(let [id (get-in parameters [:path :id])
message {:id id :type :delete-project :user user}]
(-> (sv/novelty message)
(p/then (constantly (rsp/no-content))))))
;; --- Get Project by Share Token
(s/def ::token string?)
(s/def ::get-project-by-share-token|path
(s/keys :req-un [::token]))
(defn get-project-by-share-token
"Get a project by shared token"
{:parameters {:path ::get-project-by-share-token|path}
:validation :spec}
[{:keys [user parameters] :as req}]
(let [message {:token (get-in parameters [:path :token])
:type :retrieve-project-by-share-token}]
(->> (sv/query message)
(p/map rsp/ok))))

19
backend/src/uxbox/api/svg.clj
View file

@ -1,19 +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) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.api.svg
(:require [promesa.core :as p]
[uxbox.util.spec :as us]
[uxbox.services :as sv]
[uxbox.util.http :as http]
[uxbox.util.uuid :as uuid]))
(defn parse
[{:keys [body] :as req}]
(let [message {:data (slurp body)
:type :parse-svg}]
(->> (sv/query message)
(p/map http/ok))))

84
backend/src/uxbox/api/users.clj
View file

@ -1,84 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.api.users
(:require [clojure.spec.alpha :as s]
[struct.core :as st]
[promesa.core :as p]
[datoteka.storages :as ds]
[datoteka.core :as fs]
[uxbox.services :as sv]
[uxbox.media :as media]
[uxbox.images :as images]
[uxbox.util.http :as http]
[uxbox.util.spec :as us]
[uxbox.util.uuid :as uuid]))
;; --- Helpers
(defn- resolve-thumbnail
[user]
(let [opts {:src :photo
:dst :photo
:size [100 100]
:quality 90
:format "jpg"}]
(images/populate-thumbnails user opts)))
(defn retrieve-profile
[{:keys [user]}]
(let [message {:user user :type :retrieve-profile}]
(->> (sv/query message)
(p/map resolve-thumbnail)
(p/map #(http/ok %)))))
(defn update-profile
{:parameters {:body {:username [st/required st/string]
:email [st/required st/email]
:fullname [st/required st/string]
:metadata [st/required]}}}
[{:keys [user parameters]}]
(let [data (get parameters :body)
message (assoc data
:type :update-profile
:user user)]
(->> (sv/novelty message)
(p/map resolve-thumbnail)
(p/map #(http/ok %)))))
(defn update-password
{:parameters {:body {:password [st/required st/string]
:old-password [st/required st/string]}}}
[{:keys [user parameters]}]
(let [data (get parameters :body)
message (assoc data
:type :update-profile-password
:user user)]
(-> (sv/novelty message)
(p/then (fn [_] (http/no-content))))))
;; TODO: validate {:multipart {:file {:filename "sample.jpg", :content-type "application/octet-stream", :tempfile #file "/tmp/ring-multipart-7913603702731714635.tmp", :size 312043}}}
(defn update-photo
{:parameters {:multipart {:file [st/required]}}}
[{:keys [user parameters] :as ctx}]
(letfn [(store-photo [{:keys [filename tempfile] :as upload}]
(let [filename (fs/name filename)
storage media/images-storage]
(ds/save storage filename tempfile)))
(assign-photo [path]
(sv/novelty {:user user
:path (str path)
:type :update-profile-photo}))]
(->> (get-in parameters [:multipart :file])
(store-photo)
(p/mapcat assign-photo)
(p/map (constantly (http/no-content))))))

224
backend/src/uxbox/cli/collimp.clj
View file

@ -1,224 +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) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.cli.collimp
"Collection importer command line helper."
(:require [clojure.spec.alpha :as s]
[clojure.pprint :refer [pprint]]
[clojure.java.io :as io]
[mount.core :as mount]
[cuerdas.core :as str]
[suricatta.core :as sc]
[datoteka.storages :as st]
[datoteka.core :as fs]
[uxbox.config]
[uxbox.db :as db]
[uxbox.migrations]
[uxbox.media :as media]
[uxbox.cli.sql :as sql]
[uxbox.services.svgparse :as svg]
[uxbox.util.transit :as t]
[uxbox.util.spec :as us]
[uxbox.util.cli :as cli]
[uxbox.util.blob :as blob]
[uxbox.util.uuid :as uuid]
[uxbox.util.data :as data])
(:import [java.io Reader PushbackReader]
[org.im4java.core Info]))
;; --- Constants & Helpers
(def ^:const +images-uuid-ns+ #uuid "3642a582-565f-4070-beba-af797ab27a6e")
(def ^:const +icons-uuid-ns+ #uuid "3642a582-565f-4070-beba-af797ab27a6f")
(s/def ::name string?)
(s/def ::path string?)
(s/def ::regex us/regex?)
(s/def ::import-entry
(s/keys :req-un [::name ::path ::regex]))
(defn- pushback-reader
[reader]
(PushbackReader. ^Reader reader))
;; --- Icons Collections Importer
(defn- create-icons-collection
"Create or replace image collection by its name."
[conn {:keys [name] :as entry}]
(println "Creating or updating icons collection:" name)
(let [id (uuid/namespaced +icons-uuid-ns+ name)
sqlv (sql/create-icons-collection {:id id :name name})]
(sc/execute conn sqlv)
id))
(defn- retrieve-icon
[conn id]
{:pre [(uuid? id)]}
(let [sqlv (sql/get-icon {:id id})]
(some->> (sc/fetch-one conn sqlv)
(data/normalize-attrs))))
(defn- create-icon
[conn collid iconid localpath]
{:pre [(fs/path? localpath)
(uuid? collid)
(uuid? iconid)]}
(let [filename (fs/name localpath)
extension (second (fs/split-ext filename))
data (svg/parse localpath)
params {:name (:name data filename)
:content (:content data)
:metadata (-> {:width (:width data)
:height (:height data)
:view-box (:view-box data)}
t/encode blob/encode)
:collection collid
:id iconid}
sqlv (sql/create-icon params)]
(sc/execute conn sqlv)))
(defn- import-icon
[conn id fpath]
{:pre [(uuid? id) (fs/path? fpath)]}
(let [filename (fs/name fpath)
iconid (uuid/namespaced +icons-uuid-ns+ (str id filename))]
(when-not (retrieve-icon conn iconid)
(println "Importing icon:" (str fpath))
(create-icon conn id iconid fpath))))
(defn- process-icons-entry
[conn basedir {:keys [path regex] :as entry}]
{:pre [(us/valid? ::import-entry entry)]}
(let [id (create-icons-collection conn entry)
path (fs/join basedir path)]
(doseq [fpath (->> (fs/list-dir path)
(filter fs/regular-file?))]
(when (re-matches regex (str fpath))
(import-icon conn id fpath)))))
;; --- Images Collections Importer
(defn- create-images-collection
"Create or replace image collection by its name."
[conn {:keys [name] :as entry}]
(println "Creating or updating image collection:" name)
(let [id (uuid/namespaced +images-uuid-ns+ name)
sqlv (sql/create-images-collection {:id id :name name})]
(sc/execute conn sqlv)
id))
(defn- retrieve-image-size
[path]
(let [info (Info. (str path) true)]
[(.getImageWidth info) (.getImageHeight info)]))
(defn- retrieve-image
[conn id]
{:pre [(uuid? id)]}
(let [sqlv (sql/get-image {:id id})]
(some->> (sc/fetch-one conn sqlv)
(data/normalize-attrs))))
(defn- delete-image
[conn {:keys [id path] :as image}]
{:pre [(uuid? id)
(fs/path? path)]}
(let [sqlv (sql/delete-image {:id id})
storage media/images-storage]
@(st/delete storage path)
(sc/execute conn sqlv)))
(defn- create-image
[conn collid imageid localpath]
{:pre [(fs/path? localpath)
(uuid? collid)
(uuid? imageid)]}
(let [filename (fs/name localpath)
storage media/images-storage
[width height] (retrieve-image-size localpath)
extension (second (fs/split-ext filename))
path @(st/save storage filename localpath)
params {:name filename
:path (str path)
:mimetype (case extension
".jpg" "image/jpeg"
".png" "image/png")
:width width
:height height
:collection collid
:id imageid}
sqlv (sql/create-image params)]
(sc/execute conn sqlv)))
(defn- import-image
[conn id fpath]
{:pre [(uuid? id) (fs/path? fpath)]}
(let [filename (fs/name fpath)
imageid (uuid/namespaced +images-uuid-ns+ (str id filename))]
(when-not (retrieve-image conn imageid)
(println "Importing image:" (str fpath))
(create-image conn id imageid fpath))))
(defn- process-images-entry
[conn basedir {:keys [path regex] :as entry}]
{:pre [(us/valid? ::import-entry entry)]}
(let [id (create-images-collection conn entry)
path (fs/join basedir path)]
(doseq [fpath (->> (fs/list-dir path)
(filter fs/regular-file?))]
(when (re-matches regex (str fpath))
(import-image conn id fpath)))))
;; --- Entry Point
(defn- check-path!
[path]
(when-not path
(cli/print-err! "No path is provided.")
(cli/exit! -1))
(when-not (fs/exists? path)
(cli/print-err! "Path does not exists.")
(cli/exit! -1))
(when (fs/directory? path)
(cli/print-err! "The provided path is a directory.")
(cli/exit! -1))
(fs/path path))
(defn- read-import-file
[path]
(let [path (check-path! path)
parent (fs/parent path)
reader (pushback-reader (io/reader path))]
[parent (read reader)]))
(defn- start-system
[]
(-> (mount/except #{#'uxbox.http/server})
(mount/start)))
(defn- stop-system
[]
(mount/stop))
(defn- run-importer
[conn basedir data]
(let [images (:images data)
icons (:icons data)]
(run! #(process-images-entry conn basedir %) images)
(run! #(process-icons-entry conn basedir %) icons)
#_(throw (ex-info "" {}))))
(defn -main
[& [path]]
(let [[basedir data] (read-import-file path)]
(start-system)
(try
(with-open [conn (db/connection)]
(sc/apply-atomic conn run-importer basedir data))
(finally
(stop-system)))))

4
backend/src/uxbox/cli/sql.clj
View file

@ -1,4 +0,0 @@
(ns uxbox.cli.sql
(:require [hugsql.core :as hugsql]))
(hugsql/def-sqlvec-fns "sql/cli.sql" {:quoting :ansi :fn-suffix ""})

6
backend/src/uxbox/config.clj
View file

@ -38,7 +38,7 @@
:http-server-cors (lookup-env env :uxbox-http-server-cors "http://localhost:3449")
:database-username (lookup-env env :uxbox-database-username nil)
:database-password (lookup-env env :uxbox-database-password nil)
:database-uri (lookup-env env :uxbox-database-uri "jdbc:postgresql://127.0.0.1/uxbox")
:database-uri (lookup-env env :uxbox-database-uri "postgresql://127.0.0.1/uxbox")
:media-directory (lookup-env env :uxbox-media-directory "resources/public/media")
:media-uri (lookup-env env :uxbox-media-uri "http://localhost:6060/media/")
:assets-directory (lookup-env env :uxbox-assets-directory "resources/public/static")
@ -54,15 +54,13 @@
:smtp-tls (lookup-env env :uxbox-smtp-tls false)
:smtp-ssl (lookup-env env :uxbox-smtp-ssl false)
:smtp-enabled (lookup-env env :uxbox-smtp-enabled false)
:registration-enabled (lookup-env env :uxbox-registration-enabled true)
:secret (lookup-env env :uxbox-secret "5qjiAndGY3")})
(defn read-test-config
[]
(assoc (read-config)
:database-name "test"
:database-uri "postgresql://postgres/test"
:media-directory "/tmp/uxbox/media"
:assets-directory "/tmp/uxbox/static"
:migrations-verbose false))

16
backend/src/uxbox/core.clj Normal file
View file

@ -0,0 +1,16 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.core
(:require
[vertx.core :as vx]
[mount.core :as mount :refer [defstate]]))
(defstate system
:start (vx/system)
:stop (.close system))

113
backend/src/uxbox/db.clj
View file

@ -2,91 +2,48 @@
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.db
"Database access layer for UXBOX."
(:require
[executors.core :as exec]
[hikari-cp.core :as hikari]
[mount.core :as mount :refer (defstate)]
[clojure.tools.logging :as log]
[lambdaisland.uri :refer [uri]]
[mount.core :as mount :refer [defstate]]
[promesa.core :as p]
[suricatta.core :as sc]
[suricatta.impl :as si]
[suricatta.proto :as sp]
[uxbox.config :as cfg])
(:import
org.jooq.Configuration
org.jooq.TransactionContext
org.jooq.TransactionProvider
))
[uxbox.config :as cfg]
[uxbox.core :refer [system]]
[uxbox.util.data :as data]
[uxbox.util.pgsql :as pg]
[vertx.core :as vx])
(:import io.vertx.core.buffer.Buffer))
;; --- State
(defn- create-pool
[config system]
(let [dburi (:database-uri config)
username (:database-username config)
password (:database-password config)
dburi (-> (uri dburi)
(assoc :user username)
(assoc :password password)
(str))]
(log/info "creating connection pool with" dburi)
(pg/tl-pool dburi {:system system})))
(def connection-defaults
{:connection-timeout 30000
:idle-timeout 600000
:max-lifetime 1800000
:minimum-idle 10
:maximum-pool-size 10})
(defstate pool
:start (create-pool cfg/config system))
(defn get-db-config
[config]
(assoc connection-defaults
:username (:database-username config)
:password (:database-password config)
:jdbc-url (:database-uri config)))
(defn create-datasource
[config]
(let [dbconf (get-db-config config)]
(hikari/make-datasource dbconf)))
(defstate datasource
:start (create-datasource cfg/config)
:stop (hikari/close-datasource datasource))
;; --- Suricatta Async Adapter
(defn transaction
"Asynchronous transaction handling."
{:internal true}
[ctx func]
(let [^Configuration conf (.derive (sp/-config ctx))
^TransactionContext txctx (si/transaction-context conf)
^TransactionProvider provider (.transactionProvider conf)]
(doto conf
(.data "suricatta.rollback" false)
(.data "suricatta.transaction" true))
(try
(.begin provider txctx)
(->> (func (si/make-context conf))
(p/map (fn [result]
(if (.data conf "suricatta.rollback")
(.rollback provider txctx)
(.commit provider txctx))
result))
(p/error (fn [error]
(.rollback provider (.cause txctx error))
(p/rejected error))))
(catch Exception cause
(.rollback provider (.cause txctx cause))
(p/rejected cause)))))
;; --- Public Api
(defmacro atomic
[ctx & body]
`(transaction ~ctx (fn [~ctx] ~@body)))
(defn connection
[]
(sc/context datasource))
(defn fetch
(defmacro with-atomic
[& args]
(exec/submit #(apply sc/fetch args)))
`(pg/with-atomic ~@args))
(defn execute
(def row-xfm
(comp (map pg/row->map)
(map data/normalize-attrs)))
(defmacro query
[& args]
(exec/submit #(apply sc/execute args)))
`(pg/query ~@args {:xfm row-xfm}))
(defmacro query-one
[& args]
`(pg/query-one ~@args {:xfm row-xfm}))

45
backend/src/uxbox/emails.clj
View file

@ -2,13 +2,48 @@
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2016-2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.emails
"Main api for send emails."
(:require [uxbox.emails.core :as core]))
(:require
[clojure.spec.alpha :as s]
[promesa.core :as p]
[uxbox.config :as cfg]
[uxbox.db :as db]
[uxbox.media :as media]
[uxbox.util.exceptions :as ex]
[uxbox.util.emails :as emails]
[uxbox.util.blob :as blob]
[uxbox.util.spec :as us]))
(def send! core/send!)
(def render core/render)
(def default-context
{:static media/resolve-asset
:comment (constantly nil)})
(load "emails/users")
(def register
"A new profile registration welcome email."
(emails/build :register default-context))
;; (defn render
;; [email context]
;; (let [defaults {:from (:email-from cfg/config)
;; :reply-to (:email-reply-to cfg/config)}]
;; (->> (email context)
;; (merge defaults))))
(defn send!
"Schedule the email for sending."
[email context]
(s/assert fn? email)
(s/assert map? context)
(let [defaults {:from (:email-from cfg/config)
:reply-to (:email-reply-to cfg/config)}
data (->> (email context)
(merge defaults)
(blob/encode))
priority (case (::priority context) :low 1 :high 10)
sql "insert into email_queue (data, priority)
values ($1, $2) returning *"]
(-> (db/query-one db/pool [sql data priority])
(p/then' (constantly nil)))))

88
backend/src/uxbox/emails/core.clj
View file

@ -1,88 +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) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.emails.core
(:require [hiccup.core :refer [html]]
[hiccup.page :refer [html4]]
[suricatta.core :as sc]
[uxbox.db :as db]
[uxbox.config :as cfg]
[uxbox.sql :as sql]
[uxbox.emails.layouts :as layouts]
[uxbox.util.blob :as blob]
[uxbox.util.transit :as t]))
(def emails
"A global state for registring emails."
(atom {}))
(defmacro defemail
[type & args]
(let [email (apply hash-map args)]
`(do
(swap! emails assoc ~type ~email)
nil)))
(defn- render-subject
[{:keys [subject]} context]
(cond
(delay? subject) (deref subject)
(ifn? subject) (subject context)
(string? subject) subject
:else (throw (ex-info "Invalid subject." {}))))
(defn- render-body
[[type bodyfn] layout context]
(let [layoutfn (get layout type)]
{:content (cond-> (bodyfn context)
layoutfn (layoutfn context)
(= type :text/html) (html4))
::type type
:type (subs (str type) 1)}))
(defn- render-body-alternatives
[{:keys [layout body] :as email} context]
(reduce #(conj %1 (render-body %2 layout context)) [:alternatives] body))
(defn render-email
[email context]
(let [from (or (:email/from context)
(:email-from cfg/config))
reply-to (or (:email/reply-to context)
(:email-reply-to cfg/config)
from)]
{:subject (render-subject email context)
:body (render-body-alternatives email context)
:to (:email/to context)
:from from
:reply-to reply-to}))
(def valid-priority? #{:high :low})
(def valid-email-identifier? #(contains? @emails %))
(defn render
"Render a email as data structure."
[{name :email/name :as context}]
{:pre [(valid-email-identifier? name)]}
(let [email (get @emails name)]
(render-email email context)))
(defn send!
"Schedule the email for sending."
[{name :email/name
priority :email/priority
:or {priority :high}
:as context}]
{:pre [(valid-priority? priority)
(valid-email-identifier? name)]}
(let [email (get @emails name)
email (render-email email context)
data (-> email t/encode blob/encode)
priority (case priority :low 1 :high 10)
sqlv (sql/insert-email {:data data :priority priority})]
(with-open [conn (db/connection)]
(sc/atomic conn
(sc/execute conn sqlv)))))

228
backend/src/uxbox/emails/layouts.clj
View file

@ -1,228 +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) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.emails.layouts
(:require [uxbox.media :as md]))
(def default-embedded-styles
"/* GLOBAL */
* {
margin:0;
padding:0;
font-family: Arial, sans-serif;
font-size: 100%;
line-height: 1.6;
}
img {
max-width: 100%;
width: 100%;
}
.img-header {
border-top-left-radius: 5px;
border-top-right-radius: 5px;
}
body {
-webkit-font-smoothing:antialiased;
-webkit-text-size-adjust:none;
width: 100%!important;
height: 100%;
}
/* ELEMENTS */
a {
color: #78dbbe;
text-decoration:none;
font-weight: bold;
}
.btn-primary {
text-decoration:none;
color: #fff;
background-color: #78dbbe;
padding: 10px 30px;
font-weight: bold;
margin: 20px 0;
text-align: center;
cursor: pointer;
display: inline-block;
border-radius: 4px;
}
.btn-primary:hover {
color: #FFF;
background-color: #8eefcf;
}
.last {
margin-bottom: 0;
}
.first{
margin-top: 0;
}
.logo {
background-color: #f6f6f6;
padding: 10px;
text-align: center;
padding-bottom: 25px;
}
.logo h2 {
color: #777;
font-size: 20px;
font-weight: bold;
margin-top: 15px;
}
.logo img {
max-width: 150px;
}
/* BODY */
table.body-wrap {
width: 100%;
padding: 20px;
}
table.body-wrap .container{
border-radius: 5px;
color: #ababab;
}
/* FOOTER */
table.footer-wrap {
width: 100%;
clear:both!important;
}
.footer-wrap .container p {
font-size: 12px;
color:#666;
}
table.footer-wrap a{
color: #999;
}
/* TYPOGRAPHY */
h1,h2,h3{
font-family: Arial, sans-serif;
line-height: 1.1;
margin-bottom:15px;
color:#000;
margin: 40px 0 10px;
line-height: 1.2;
font-weight:200;
}
h1 {
color: #777;
font-size: 28px;
font-weight: bold;
}
h2 {
font-size: 24px;
}
h3 {
font-size: 18px;
}
p, ul {
margin-bottom: 10px;
font-weight: normal;
}
ul li {
margin-left:5px;
list-style-position: inside;
}
/* RESPONSIVE */
/* Set a max-width, and make it display as block so it will automatically stretch to that width, but will also shrink down on a phone or something */
.container {
display: block !important;
max-width: 620px !important;
margin: 0 auto !important; /* makes it centered */
clear: both !important;
}
/* This should also be a block element, so that it will fill 100% of the .container */
.content {
padding: 20px;
max-width: 620px;
margin: 0 auto;
display: block;
}
/* Let's make sure tables in the content area are 100% wide */
.content table {
width: 100%;
}")
(defn- default-html
[body context]
[:html
[:head
[:meta {:http-equiv "Content-Type"
:content "text/html; charset=UTF-8"}]
[:meta {:name "viewport"
:content "width=device-width"}]
[:title "title"]
[:style default-embedded-styles]]
[:body {:bgcolor "#f6f6f6"
:cz-shortcut-listen "true"}
[:table.body-wrap
[:tbody
[:tr
[:td]
[:td.container {:bgcolor "#FFFFFF"}
[:div.logo
[:img {:src (md/resolve-asset "images/email/logo.png")
:alt "UXBOX"}]]
body]
[:td]]]]
[:table.footer-wrap
[:tbody
[:tr
[:td]
[:td.container
[:div.content
[:table
[:tbody
[:tr
[:td
[:div {:style "text-align: center;"}
[:a {:href "#" :target "_blank"}
[:img {:style "display: inline-block; width: 25px; margin-right: 5px;"
:src (md/resolve-asset "images/email/twitter.png")}]]
[:a {:href "#" :target "_blank"}
[:img {:style "display: inline-block; width: 25px; margin-right: 5px;"
:src (md/resolve-asset "images/email/github.png")}]]
[:a {:href "#" :target "_blank"}
[:img {:style "display: inline-block; width: 25px; margin-right: 5px;"
:src (md/resolve-asset "images/email/linkedin.png")}]]]]]
[:tr
[:td {:align "center"}
[:p
[:span "Sent from UXBOX | "]
[:a {:href "#" :target "_blank"}
[:unsubscribe "Email preferences"]]]]]]]]]
[:td]]]]]])
(defn default-text
[body context]
body)
(def default
"Default layout instance."
{:text/html default-html
:text/plain default-text})

77
backend/src/uxbox/emails/users.clj
View file

@ -1,77 +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) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.emails.users
(:require [uxbox.media :as md]
[uxbox.emails.core :refer (defemail)]
[uxbox.emails.layouts :as layouts]))
;; --- User Register
(defn- register-body-html
[{:keys [name] :as ctx}]
[:div
[:img.img-header {:src (md/resolve-asset "images/email/img-header.jpg")
:alt "UXBOX"}]
[:div.content
[:table
[:tbody
[:tr
[:td
[:h1 "Hi " name]
[:p "Welcome to uxbox."]
[:p
[:a.btn-primary {:href "#"} "Sign in"]]
[:p "Sincerely," [:br] [:strong "The UXBOX Team"]]
#_[:p "P.S. Having trouble signing up? please contact "
[:a {:href "#"} "Support email"]]]]]]]])
(defn- register-body-text
[{:keys [name] :as ctx}]
(str "Hi " name "\n\n"
"Welcome to uxbox!\n\n"
"Sincerely, the UXBOX team.\n"))
(defemail :users/register
:layout layouts/default
:subject "UXBOX: Welcome!"
:body {:text/html register-body-html
:text/plain register-body-text})
;; --- Password Recovery
(defn- password-recovery-body-html
[{:keys [name token] :as ctx}]
[:div
[:img.img-header {:src (md/resolve-asset "images/img-header.jpg")
:alt "UXBOX"}]
[:div.content
[:table
[:tbody
[:tr
[:td
[:h1 "Hi " name]
[:p "A password recovery is requested."]
[:p
"Please, follow the following url in order to"
"change your password."
[:a {:href "#"} "http://uxbox.io/..."]]
[:p "Sincerely," [:br] [:strong "The UXBOX Team"]]]]]]]])
(defn- password-recovery-body-text
[{:keys [name token] :as ctx}]
(str "Hi " name "\n\n"
"A password recovery is requested.\n\n"
"Please follow the following url in order to change the password:\n\n"
" http://uxbox.io/recovery/" token "\n\n\n"
"Sincerely, the UXBOX team.\n"))
(defemail :users/password-recovery
:layout layouts/default
:subject "Password recovery requested."
:body {:text/html password-recovery-body-html
:text/plain password-recovery-body-text})

157
backend/src/uxbox/fixtures.clj
View file

@ -2,101 +2,112 @@
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.fixtures
"A initial fixtures."
(:require
[buddy.core.codecs :as codecs]
[buddy.hashers :as hashers]
[clj-uuid :as uuid]
[mount.core :as mount]
[suricatta.core :as sc]
[promesa.core :as p]
[uxbox.config :as cfg]
[uxbox.core]
[uxbox.db :as db]
[uxbox.media :as media]
[uxbox.migrations]
[uxbox.services.pages :as spag]
[uxbox.services.projects :as sproj]
[uxbox.services.users :as susers]
[uxbox.util.transit :as t]))
[uxbox.util.blob :as blob]
[uxbox.util.uuid :as uuid]))
(defn- mk-uuid
[prefix & args]
(uuid/v5 uuid/+namespace-oid+ (apply str prefix args)))
(uuid/namespaced uuid/oid (apply str prefix args)))
(defn- data-encode
[data]
(-> (t/encode data)
(codecs/bytes->str)))
;; --- Users creation
(defn- create-user
(def create-user-sql
"insert into users (id, fullname, username, email, password, metadata, photo)
values ($1, $2, $3, $4, $5, $6, $7)
returning *;")
(defn create-user
[conn i]
(println "create user" i)
(susers/create-user conn
{:username (str "user" i)
:id (mk-uuid "user" i)
:fullname (str "User " i)
:metadata {}
:password "123123"
:email (str "user" i ".test@uxbox.io")}))
(db/query-one conn [create-user-sql
(mk-uuid "user" i)
(str "User " i)
(str "user" i)
(str "user" i ".test@uxbox.io")
(hashers/encrypt "123123")
(blob/encode {})
""]))
(defn- create-project
[conn i ui]
;; (Thread/sleep 20)
(println "create project" i "for user" ui)
(sproj/create-project conn
{:id (mk-uuid "project" i)
:user (mk-uuid "user" ui)
:name (str "project " i)}))
;; --- Projects creation
(defn- create-page
[conn i pi ui]
;; (Thread/sleep 1)
(println "create page" i "for user" ui "for project" pi)
(spag/create-page conn
{:id (mk-uuid "page" i)
:user (mk-uuid "user" ui)
:project (mk-uuid "project" pi)
:data {:shapes [{:id (mk-uuid "canvas" i 1)
:name "Canvas-1"
:type :canvas
:page (mk-uuid "page" i)
:x1 200
:y1 200
:x2 1224
:y2 968}]}
:metadata {:width 1024
:height 768
:layout "tablet"}
:name (str "page " i)}))
(def create-project-sql
"insert into projects (id, user_id, name)
values ($1, $2, $3)
returning *;")
(def num-users 50)
(defn create-project
[conn [pjid uid]]
(println "create project" pjid "(for user=" uid ")")
(db/query-one conn [create-project-sql
(mk-uuid "project" pjid uid)
(mk-uuid "user" uid)
(str "sample project " pjid)]))
;; --- Pages creation
(def create-page-sql
"insert into pages (id, user_id, project_id, name, data, metadata)
values ($1, $2, $3, $4, $5, $6)
returning *;")
(defn create-page
[conn [pjid paid uid]]
(println "create page" paid "(for project=" pjid ", user=" uid ")")
(let [data {:shapes [{:id (mk-uuid "canvas" 1)
:name "Canvas-1"
:type :canvas
:page (mk-uuid "page" pjid paid uid)
:x1 200
:y1 200
:x2 1224
:y2 968}]}]
(db/query-one conn [create-page-sql
(mk-uuid "page" pjid paid uid)
(mk-uuid "user" uid)
(mk-uuid "project" pjid uid)
(str "page " paid)
(blob/encode data)
(blob/encode {})])))
(def num-users 5)
(def num-projects 5)
(def num-pages 5)
(defn -main
[& args]
(-> (mount/only #{#'uxbox.config/config
#'uxbox.config/secret
#'uxbox.db/datasource
#'uxbox.migrations/migrations
#'uxbox.media/assets-storage
#'uxbox.media/media-storage
#'uxbox.media/images-storage
#'uxbox.media/thumbnails-storage})
(mount/start))
(with-open [conn (db/connection)]
(sc/atomic conn
(doseq [i (range num-users)]
(create-user conn i))
(doseq [ui (range num-users)]
(doseq [i (range num-projects)]
(create-project conn (str ui i) ui)))
(doseq [pi (range num-projects)]
(doseq [ui (range num-users)]
(doseq [i (range num-pages)]
(create-page conn (str pi ui i) (str ui pi) ui))))))
(mount/stop))
(try
(-> (mount/only #{#'uxbox.config/config
#'uxbox.config/secret
#'uxbox.core/system
#'uxbox.db/pool
#'uxbox.migrations/migrations})
(mount/start))
@(db/with-atomic [conn db/pool]
(p/do!
(p/run! #(create-user conn %) (range num-users))
(p/run! #(create-project conn %)
(for [uid (range num-users)
pjid (range num-projects)]
[pjid uid]))
(p/run! #(create-page conn %)
(for [pjid(range num-projects)
paid (range num-pages)
uid (range num-users)]
[pjid paid uid]))
(p/promise 1)))
(finally
(mount/stop))))

162
backend/src/uxbox/http.clj
View file

@ -5,115 +5,67 @@
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.http
(:require [mount.core :refer [defstate]]
[ring.adapter.jetty :as jetty]
[reitit.ring :as rr]
[uxbox.config :as cfg]
[uxbox.http.middleware :refer [handler
middleware
options-handler
authorization-middleware]]
[uxbox.api.auth :as api-auth]
[uxbox.api.pages :as api-pages]
[uxbox.api.users :as api-users]
[uxbox.api.icons :as api-icons]
[uxbox.api.images :as api-images]
[uxbox.api.kvstore :as api-kvstore]
[uxbox.api.projects :as api-projects]
[uxbox.api.svg :as api-svg]
[uxbox.util.transit :as t]))
(:require
[clojure.tools.logging :as log]
[mount.core :as mount :refer [defstate]]
[promesa.core :as p]
[uxbox.config :as cfg]
[uxbox.core :refer [system]]
[uxbox.http.errors :as errors]
[uxbox.http.interceptors :as interceptors]
[uxbox.http.session :as session]
[uxbox.http.handlers :as handlers]
[uxbox.http.debug :as debug]
[uxbox.services.core :as sv]
[vertx.core :as vc]
[vertx.http :as vh]
[vertx.web :as vw]
[vertx.web.interceptors :as vxi]))
(def ^:private router-options
{::rr/default-options-handler options-handler
:data {:middleware middleware}})
(declare login-handler)
(declare logout-handler)
(declare register-handler)
(declare mutation-handler)
(declare query-handler)
(declare echo-handler)
(def routes
[["/media/*" (rr/create-resource-handler {:root "public/media"})]
["/static/*" (rr/create-resource-handler {:root "public/static"})]
(defn- on-start
[ctx]
(let [cors-opts {:origin (:http-server-cors cfg/config "http://localhost:3449")
:max-age 3600
:allow-credentials true
:allow-methods #{:post :get :patch :head :options :put}
:allow-headers #{:x-requested-with :content-type :cookie}}
["/api/auth"
["/login" {:post (handler #'api-auth/login)}]
["/logout" {:post (handler #'api-auth/logout)}]
["/register" {:post (handler #'api-auth/register)}]
["/recovery/:token" {:get (handler #'api-auth/register)}]
["/recovery" {:post (handler #'api-auth/request-recovery)
:get (handler #'api-auth/recover-password)}]]
interceptors [(vxi/cookies)
(vxi/headers)
(vxi/params)
(vxi/cors cors-opts)
interceptors/parse-request-body
interceptors/format-response-body]
["/api" {:middleware [authorization-middleware]}
;; KVStore
["/kvstore/:key" {:put (handler #'api-kvstore/upsert)
:get (handler #'api-kvstore/retrieve)
:delete (handler #'api-kvstore/delete)}]
routes [["/api" {:interceptors interceptors}
["/echo" {:interceptors [(session/auth)]
:all handlers/echo-handler}]
["/login" {:post handlers/login-handler}]
["/logout" {:post handlers/logout-handler}]
["/register" {:post handlers/register-handler}]
["/debug"
["/emails" {:get debug/emails-list}]
["/emails/:id" {:get debug/email}]]
["/w" {:interceptors [(session/auth)]}
["/mutation/:type" {:interceptors [(vxi/uploads)]
:post handlers/mutation-handler}]
["/query/:type" {:get handlers/query-handler}]]]]
["/svg/parse" {:post (handler #'api-svg/parse)}]
handler (vw/handler ctx
(vw/assets "/media/*" {:root "resources/public/media/"})
(vw/assets "/static/*" {:root "resources/public/static"})
(vw/router routes))]
;; Projects
["/projects" {:get (handler #'api-projects/list-projects)
:post (handler #'api-projects/create-project)}]
["/projects/by-token/:token" {:get (handler #'api-projects/get-project-by-share-token)}]
["/projects/:id" {:put (handler #'api-projects/update-project)
:delete (handler #'api-projects/delete-project)}]
(vh/server ctx {:handler handler
:port (:http-server-port cfg/config)})))
;; Pages
["/pages" {:get (handler #'api-pages/list-pages)
:post (handler #'api-pages/create-page)}]
["/pages/:id" {:put (handler #'api-pages/update-page)
:delete (handler #'api-pages/delete-page)}]
["/pages/:id/metadata" {:put (handler #'api-pages/update-page-metadata)}]
["/pages/:id/history" {:get (handler #'api-pages/retrieve-page-history)}]
["/pages/:id/history/:hid" {:put (handler #'api-pages/update-page-history)}]
;; Profile
["/profile"
["/me" {:get (handler #'api-users/retrieve-profile)
:put (handler #'api-users/update-profile)}]
["/me/password" {:put (handler #'api-users/update-password)}]
["/me/photo" {:post (handler #'api-users/update-photo)}]]
;; Library
["/library"
;; Icons
["/icon-collections/:id" {:put (handler #'api-icons/update-collection)
:delete (handler #'api-icons/delete-collection)}]
["/icon-collections" {:get (handler #'api-icons/list-collections)
:post (handler #'api-icons/create-collection)}]
["/icons/:id/copy" {:put (handler #'api-icons/copy-icon)}]
["/icons/:id" {:put (handler #'api-icons/update-icon)
:delete (handler #'api-icons/delete-icon)}]
["/icons" {:post (handler #'api-icons/create-icon)
:get (handler #'api-icons/list-icons)}]
;; Images
["/image-collections/:id" {:put (handler #'api-images/update-collection)
:delete (handler #'api-images/delete-collection)}]
["/image-collections" {:post (handler #'api-images/create-collection)
:get (handler #'api-images/list-collections)}]
["/images/:id/copy" {:put (handler #'api-images/copy-image)}]
["/images/:id" {:get (handler #'api-images/retrieve-image)
:delete (handler #'api-images/delete-image)
:put (handler #'api-images/update-image)}]
["/images" {:post (handler #'api-images/create-image)
:get (handler #'api-images/list-images)}]
]
]])
;; --- State Initialization
(def app
(delay
(let [router (rr/router routes router-options)]
(rr/ring-handler router (rr/create-default-handler)))))
(defn- start-server
[config]
(jetty/run-jetty @app {:join? false
:async? true
:daemon? false
:port (:http-server-port config)}))
(defstate server
:start (start-server cfg/config)
:stop (.stop server))
(defstate http-verticle
:start (let [factory (vc/verticle {:on-start on-start})]
@(vc/deploy! system factory {:instances 4})))

77
backend/src/uxbox/http/cors.clj
View file

@ -1,77 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.http.cors
"CORS Implementation for Async Ring"
(:require [cuerdas.core :as str]))
(defn- allow-origin?
[value {:keys [origin]}]
(cond
(nil? value) value
(= origin "*") origin
(set? origin) (origin value)
(= origin value) origin))
(defn- normalize-headers
[headers]
(->> (map (comp str/lower name) headers)
(str/join ",")))
(defn- normalize-methods
[methods]
(->> (map (comp str/upper name) methods)
(str/join ",")))
(defn- get-preflight-headers
[origin {:keys [allow-methods allow-headers max-age allow-credentials]
:or {allow-methods #{:get :post :put :delete}}
:as opts}]
(when-let [origin (allow-origin? origin opts)]
(cond-> {"access-control-allow-origin" origin
"access-control-allow-methods" (normalize-methods allow-methods)}
allow-credentials
(assoc "access-control-allow-credentials" "true")
max-age
(assoc "access-control-max-age" (str max-age))
allow-headers
(assoc "access-control-allow-headers" (normalize-headers allow-headers)))))
(defn get-response-headers
[origin {:keys [allow-headers expose-headers allow-credentials] :as opts}]
(when-let [origin (allow-origin? origin opts)]
(cond-> {"access-control-allow-origin" origin}
allow-credentials
(assoc "access-control-allow-credentials" "true")
allow-headers
(assoc "access-control-allow-headers" (normalize-headers allow-headers))
expose-headers
(assoc "access-control-expose-headers" (normalize-headers expose-headers)))))
(defn- cors-preflight?
[{:keys [request-method headers] :as req}]
(and (= request-method :options)
(contains? headers "origin")
(contains? headers "access-control-request-method")))
(defn wrap-cors
"A chain handler that handles cors related headers."
[handler opts]
(fn [{:keys [headers] :as req} respond raise]
(let [origin (get headers "origin")]
(if (cors-preflight? req)
(let [headers (get-preflight-headers origin opts)]
(respond {:status 200 :headers headers :body ""}))
(let [headers (get-response-headers origin opts)
wrapped-respond (fn [response] (respond (update response :headers merge headers)))]
(handler req wrapped-respond raise))))))

25
backend/src/uxbox/http/debug.clj Normal file
View file

@ -0,0 +1,25 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.http.debug
"Debug related handlers."
(:require
[clojure.tools.logging :as log]
[promesa.core :as p]
[uxbox.http.errors :as errors]
[uxbox.http.session :as session]
[uxbox.services.core :as sv]
[uxbox.util.uuid :as uuid]))
(defn emails-list
[req]
{:status 200
:body "Hello world\n"})
(defn email
[req]
{:status 200
:body "Hello world\n"})

18
backend/src/uxbox/http/errors.clj
View file

@ -16,6 +16,12 @@
{:status 400
:body response}))
(defmethod handle-exception :not-found
[err]
(let [response (ex-data err)]
{:status 404
:body response}))
(defmethod handle-exception :parse
[err]
{:status 400
@ -24,7 +30,9 @@
(defmethod handle-exception :default
[err]
(println "--- START REQ EXCEPTION ---")
(e/write-exception err)
(println "--- END REQ EXCEPTION ---")
{:status 500
:body {:type :exception
:message (ex-message err)}})
@ -40,14 +48,14 @@
:type :occ}}
(handle-exception err))))
(defn errors-handler
[error context]
(defn handle
[error]
(cond
(or (instance? java.util.concurrent.CompletionException error)
(instance? java.util.concurrent.ExecutionException error))
(errors-handler context (.getCause error))
(handle (.getCause error))
(instance? org.jooq.exception.DataAccessException error)
(handle-data-access-exception error)
;; (instance? org.jooq.exception.DataAccessException error)
;; (handle-data-access-exception error)
:else (handle-exception error)))

53
backend/src/uxbox/http/etag.clj
View file

@ -1,53 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.http.etag
"ETag calculation helpers."
(:require [clojure.java.io :as io]
[buddy.core.hash :as hash]
[buddy.core.codecs :as codecs]
[buddy.core.codecs.base64 :as b64]))
(defn digest
[^bytes data]
(-> (hash/blake2b-256 data)
(b64/encode true)
(codecs/bytes->str)))
(defn- etag-match?
[request new-tag]
(when-let [etag (get-in request [:headers "if-none-match"])]
(= etag new-tag)))
(defn stream-bytes
[is]
(let [baos (java.io.ByteArrayOutputStream.)]
(io/copy is baos)
(.toByteArray baos)))
(defn handle-response
[request {:keys [body] :as response}]
(when (instance? java.io.ByteArrayInputStream body)
(let [data (stream-bytes body)
etag (digest data)]
(.reset body)
(if-not (etag-match? request etag)
(update response :headers assoc "etag" etag)
(-> response
(assoc :body "" :status 304)
(update :headers assoc "etag" etag))))))
(defn wrap-etag
[handler]
(fn [request respond raise]
(handler request
(fn [response]
(if (= (:request-method request) :get)
(respond (or (handle-response request response) response))
(respond response)))
raise)))

86
backend/src/uxbox/http/handlers.clj Normal file
View file

@ -0,0 +1,86 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.http.handlers
(:require
[clojure.tools.logging :as log]
[promesa.core :as p]
[uxbox.http.errors :as errors]
[uxbox.http.session :as session]
[uxbox.services.core :as sv]
[uxbox.util.uuid :as uuid]))
(defn query-handler
[req]
(let [type (get-in req [:path-params :type])
data (merge (:params req)
{::sv/type (keyword type)
:user (:user req)})]
(-> (sv/query (with-meta data {:req req}))
(p/handle (fn [result error]
(if error
(errors/handle error)
{:status 200
:body result}))))))
(defn mutation-handler
[req]
(let [type (get-in req [:path-params :type])
data (merge (:params req)
(:body-params req)
(:uploads req)
{::sv/type (keyword type)
:user (:user req)})]
(-> (sv/mutation (with-meta data {:req req}))
(p/handle (fn [result error]
(if error
(errors/handle error)
{:status 200 :body result}))))))
(defn login-handler
[req]
(let [data (:body-params req)
user-agent (get-in req [:headers "user-agent"])]
(-> (sv/mutation (assoc data ::sv/type :login))
(p/then #(session/create % user-agent))
(p/then (fn [token]
{:status 204
:cookies {"auth-token" {:value token}}
:body ""}))
(p/catch errors/handle))))
(defn logout-handler
[req]
(let [token (get-in req [:cookies "auth-token"])
token (uuid/from-string token)]
(-> (session/delete token)
(p/then (fn [token]
{:status 204
:cookies {"auth-token" {:value nil}}
:body ""}))
(p/catch errors/handle))))
(defn register-handler
[req]
(let [data (merge (:body-params req)
{::sv/type :register-profile})
user-agent (get-in req [:headers "user-agent"])]
(-> (sv/mutation (with-meta data {:req req}))
(p/then (fn [{:keys [id] :as user}]
(session/create id user-agent)))
(p/then' (fn [token]
{:status 204
:cookies {"auth-token" {:value token}}
:body ""}))
(p/catch' errors/handle))))
(defn echo-handler
[req]
{:status 200
:body {:params (:params req)
:cookies (:cookies req)
:headers (:headers req)}})

65
backend/src/uxbox/http/interceptors.clj Normal file
View file

@ -0,0 +1,65 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.http.interceptors
(:require
[vertx.web :as vw]
[uxbox.util.blob :as blob]
[uxbox.util.exceptions :as ex])
(:import
io.vertx.ext.web.RoutingContext
io.vertx.ext.web.FileUpload
io.vertx.core.buffer.Buffer))
(def parse-request-body
{:enter (fn [{:keys [request] :as data}]
(let [body (:body request)
mtype (get-in request [:headers "content-type"])]
(if (= "application/transit+json" mtype)
(try
(let [params (blob/decode-from-json body)]
(update data :request assoc :body-params params))
(catch Exception e
(ex/raise :type :parse
:message "Unable to parse transit from request body."
:cause e)))
data)))})
(def format-response-body
{:leave (fn [{:keys [response] :as data}]
(let [body (:body response)]
(cond
(coll? body)
(-> data
(assoc-in [:response :body]
(blob/encode-with-json body true))
(update-in [:response :headers]
assoc "content-type" "application/transit+json"))
(nil? body)
(-> data
(assoc-in [:response :status] 204)
(assoc-in [:response :body] ""))
:else
data)))})
(def handle-uploads
{:enter (fn [data]
(let [rcontext (get-in data [:request ::vw/routing-context])
uploads (.fileUploads ^RoutingContext rcontext)
uploads (reduce (fn [acc ^FileUpload upload]
(assoc acc
(keyword (.name upload))
{:type :uploaded-file
:mtype (.contentType upload)
:path (.uploadedFileName upload)
:name (.fileName upload)
:size (.size upload)}))
{}
uploads)]
(assoc-in data [:request :upload-params] uploads)))})

307
backend/src/uxbox/http/middleware.clj
View file

@ -1,307 +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) 2016-2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.http.middleware
(:require
[clojure.spec.alpha :as s]
[clojure.java.io :as io]
[cuerdas.core :as str]
[promesa.core :as p]
[reitit.ring :as rr]
[reitit.ring.middleware.exception :as exception]
[reitit.ring.middleware.multipart :as multipart]
[reitit.ring.middleware.parameters :as parameters]
[ring.middleware.multipart-params :refer [wrap-multipart-params]]
[ring.middleware.session :refer [wrap-session]]
[ring.middleware.session.cookie :refer [cookie-store]]
[struct.core :as st]
[uxbox.config :as cfg]
[uxbox.http.cors :refer [wrap-cors]]
[uxbox.http.errors :as errors]
[uxbox.http.etag :refer [wrap-etag]]
[uxbox.http.response :as rsp]
[uxbox.util.data :refer [normalize-attrs]]
[uxbox.util.exceptions :as ex]
[uxbox.util.spec :as us]
[uxbox.util.transit :as t]))
(extend-protocol ring.core.protocols/StreamableResponseBody
(Class/forName "[B")
(write-body-to-stream [body _ ^java.io.OutputStream output-stream]
(with-open [out output-stream]
(.write out ^bytes body))))
(defn- transform-handler
[handler]
(fn [request respond raise]
(try
(let [response (handler request)]
(if (p/promise? response)
(-> response
(p/then respond)
(p/catch raise))
(respond response)))
(catch Exception e
(raise e)))))
;; The middleware that transform string keys to keywords and perform
;; usability transformations.
(def ^:private normalize-params-middleware
{:name ::normalize-params-middleware
:wrap (fn [handler]
(letfn [(transform-request [request key]
(if-let [data (get request key)]
(assoc request key (normalize-attrs data))
request))
(transform [request]
(-> request
(transform-request :query-params)
(transform-request :multipart-params)))]
(fn
([request] (handler (transform request)))
([request respond raise]
(try
(try
(handler (transform request) respond raise)
(catch Exception e
(raise e))))))))})
(def ^:private multipart-params-middleware
{:name ::multipart-params-middleware
:wrap wrap-multipart-params})
(def ^:private parameters-validation-middleware
(letfn [(prepare [parameters]
(reduce-kv
(fn [acc key spec]
(let [newkey (case key
:path :path-params
:query :query-params
:body :body-params
:multipart :multipart-params
(throw (ex-info "Not supported key on :parameters" {})))]
(assoc acc newkey {:key key
:fn #(st/validate spec %)})))
{} parameters))
(validate [request parameters debug]
(reduce-kv
(fn [req key spec]
(let [[errors, result] ((:fn spec) (get req key))]
(if errors
(ex/raise :type :validation
:code (:key spec)
:context errors
:prop key
:value (get req key)
:message "Invalid data")
(assoc-in req [:parameters (:key spec)] result))))
request parameters))
(compile-struct [route opts parameters]
(let [parameters (prepare parameters)]
(fn [handler]
(fn
([request]
(handler (validate request parameters)))
([request respond raise]
(try
(handler (validate request parameters false) respond raise)
(catch Exception e
(raise e))))))))
(prepare-spec [parameters]
(reduce-kv (fn [acc key s]
(let [rk (case key
:path :path-params
:query :query-params
:body :body-params
:multipart :multipart-params
(throw (ex-info "Not supported key on :parameters" {})))]
(assoc acc rk {:key key
:fn #(us/conform s %)})))
{}
parameters))
(validate-spec [request parameters]
(reduce-kv
(fn [req key spec]
(let [[result errors] ((:fn spec) (get req key))]
(if errors
(ex/raise :type :validation
:code :parameters
:context {:problems (vec (::s/problems errors))
:spec (::s/spec errors)
:value (::s/value errors)})
(assoc-in req [:parameters (:key spec)] result))))
request parameters))
(compile-spec [route opts parameters]
(let [parameters (prepare-spec parameters)]
(fn [handler]
(fn
([request]
(handler (validate-spec request parameters)))
([request respond raise]
(try
(handler (validate-spec request parameters) respond raise)
(catch Exception e
(raise e))))))))
(compile [route opts]
(when-let [parameters (:parameters route)]
(if (= :spec (:validation route))
(compile-spec route opts parameters)
(compile-struct route opts parameters))))]
{:name ::parameters-validation-middleware
:compile compile}))
(def ^:private session-middleware
(let [options {:store (cookie-store {:key "a 16-byte secret"})
:cookie-name "session"
:cookie-attrs {:same-site :lax
:http-only false}}]
{:name ::session-middleware
:wrap #(wrap-session % options)}))
(def cors-conf
{:origin #{"http://localhost:3449"}
:max-age 3600
:allow-credentials true
:allow-methods #{:post :put :get :delete}
:allow-headers #{:x-requested-with :content-type :cookie}})
(def ^:private cors-middleware
{:name ::cors-middleware
:wrap (fn [handler]
(let [cors (:http-server-cors cfg/config)]
(if (string? cors)
(->> (assoc cors-conf :origin #{cors})
(wrap-cors handler))
handler)))})
(def ^:private etag-middleware
{:name ::etag-middleware
:wrap wrap-etag})
(def ^:private exception-middleware
(exception/create-exception-middleware
(assoc exception/default-handlers
:muuntaja/decode errors/errors-handler
::exception/default errors/errors-handler)))
(def authorization-middleware
{:name ::authorization-middleware
:wrap (fn [handler]
(fn
([request]
(if-let [identity (get-in request [:session :user-id])]
(handler (assoc request :identity identity :user identity))
(rsp/forbidden nil)))
([request respond raise]
(if-let [identity (get-in request [:session :user-id])]
(handler (assoc request :identity identity :user identity) respond raise)
(respond (rsp/forbidden nil))))))})
(def format-response-middleware
(letfn [(process-response [{:keys [body] :as rsp}]
(if (coll? body)
(let [body (t/encode body {:type :json-verbose})]
(-> rsp
(assoc :body body)
(update :headers assoc "content-type" "application/transit+json")))
rsp))]
{:name ::format-response-middleware
:wrap (fn [handler]
(fn
([request]
(process-response (handler request)))
([request respond raise]
(handler request (fn [res] (respond (process-response res))) raise))))}))
(def parse-request-middleware
(letfn [(get-content-type [request]
(or (:content-type request)
(get (:headers request) "content-type")))
(slurp-bytes [body]
(with-open [input (io/input-stream body)
output (java.io.ByteArrayOutputStream. (.available input))]
(io/copy input output)
(.toByteArray output)))
(parse-body [body]
(let [^bytes body (slurp-bytes body)]
(when (pos? (alength body))
(t/decode body))))
(process-request [request]
(let [ctype (get-content-type request)]
(if (= "application/transit+json" ctype)
(try
(let [body (parse-body (:body request))]
(assoc request :body-params body))
(catch Exception e
(ex/raise :type :parse
:message "Unable to parse transit from request body."
:cause e)))
request)))]
{:name ::parse-request-middleware
:wrap (fn [handler]
(fn
([request]
(handler (process-request request)))
([request respond raise]
(let [^HttpInput body (:body request)]
(try
(handler (process-request request) respond raise)
(catch Exception e
(raise e)))))))}))
(def middleware
[cors-middleware
session-middleware
;; etag
etag-middleware
parameters/parameters-middleware
;; Format the body into transit
format-response-middleware
;; main exception handling
exception-middleware
;; parse transit format from request body
parse-request-middleware
;; multipart parsing
multipart-params-middleware
;; parameters normalization
normalize-params-middleware
;; parameters validation
parameters-validation-middleware])
(defn handler
[invar]
(let [metadata (meta invar)
hlrdata (-> metadata
(dissoc :arglist :line :column :file :ns)
(assoc :handler (transform-handler (var-get invar))
:fullname (symbol (str (:ns metadata)) (str (:name metadata)))))]
(cond-> hlrdata
(:doc metadata) (assoc :description (:doc metadata)))))
(defn options-handler
[request respond raise]
(let [methods (->> request rr/get-match :result (keep (fn [[k v]] (if v k))))
allow (->> methods (map (comp str/upper name)) (str/join ","))]
(respond {:status 200, :body "", :headers {"Allow" allow}})))

216
backend/src/uxbox/http/response.clj
View file

@ -1,216 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.http.response)
(defn response
"Create a response instance."
([body] (response body 200 {}))
([body status] (response body status {}))
([body status headers] {:body body :status status :headers headers}))
(defn response?
[resp]
(and (map? resp)
(integer? (:status resp))
(map? (:headers resp))))
(defn continue
([body] (response body 100))
([body headers] (response body 100 headers)))
(defn ok
"HTTP 200 OK
Should be used to indicate nonspecific success. Must not be used to
communicate errors in the response body.
In most cases, 200 is the code the client hopes to see. It indicates that
the REST API successfully carried out whatever action the client requested,
and that no more specific code in the 2xx series is appropriate. Unlike
the 204 status code, a 200 response should include a response body."
([body] (response body 200))
([body headers] (response body 200 headers)))
(defn created
"HTTP 201 Created
Must be used to indicate successful resource creation.
A REST API responds with the 201 status code whenever a collection creates,
or a store adds, a new resource at the client's request. There may also be
times when a new resource is created as a result of some controller action,
in which case 201 would also be an appropriate response."
([location] (response "" 201 {"location" location}))
([location body] (response body 201 {"location" location}))
([location body headers] (response body 201 (merge headers {"location" location}))))
(defn accepted
"HTTP 202 Accepted
Must be used to indicate successful start of an asynchronous action.
A 202 response indicates that the client's request will be handled
asynchronously. This response status code tells the client that the request
appears valid, but it still may have problems once it's finally processed.
A 202 response is typically used for actions that take a long while to
process."
([body] (response body 202))
([body headers] (response body 202 headers)))
(defn no-content
"HTTP 204 No Content
Should be used when the response body is intentionally empty.
The 204 status code is usually sent out in response to a PUT, POST, or
DELETE request, when the REST API declines to send back any status message
or representation in the response message's body. An API may also send 204
in conjunction with a GET request to indicate that the requested resource
exists, but has no state representation to include in the body."
([] (response "" 204))
([headers] (response "" 204 headers)))
(defn moved-permanently
"301 Moved Permanently
Should be used to relocate resources.
The 301 status code indicates that the REST API's resource model has been
significantly redesigned and a new permanent URI has been assigned to the
client's requested resource. The REST API should specify the new URI in
the response's Location header."
([location] (response "" 301 {"location" location}))
([location body] (response body 301 {"location" location}))
([location body headers] (response body 301 (merge headers {"location" location}))))
(defn found
"HTTP 302 Found
Should not be used.
The intended semantics of the 302 response code have been misunderstood
by programmers and incorrectly implemented in programs since version 1.0
of the HTTP protocol.
The confusion centers on whether it is appropriate for a client to always
automatically issue a follow-up GET request to the URI in response's
Location header, regardless of the original request's method. For the
record, the intent of 302 is that this automatic redirect behavior only
applies if the client's original request used either the GET or HEAD
method.
To clear things up, HTTP 1.1 introduced status codes 303 (\"See Other\")
and 307 (\"Temporary Redirect\"), either of which should be used
instead of 302."
([location] (response "" 302 {"location" location}))
([location body] (response body 302 {"location" location}))
([location body headers] (response body 302 (merge headers {"location" location}))))
(defn see-other
"HTTP 303 See Other
Should be used to refer the client to a different URI.
A 303 response indicates that a controller resource has finished its work,
but instead of sending a potentially unwanted response body, it sends the
client the URI of a response resource. This can be the URI of a temporary
status message, or the URI to some already existing, more permanent,
resource.
Generally speaking, the 303 status code allows a REST API to send a
reference to a resource without forcing the client to download its state.
Instead, the client may send a GET request to the value of the Location
header."
([location] (response "" 303 {"location" location}))
([location body] (response body 303 {"location" location}))
([location body headers] (response body 303 (merge headers {"location" location}))))
(defn temporary-redirect
"HTTP 307 Temporary Redirect
Should be used to tell clients to resubmit the request to another URI.
HTTP/1.1 introduced the 307 status code to reiterate the originally
intended semantics of the 302 (\"Found\") status code. A 307 response
indicates that the REST API is not going to process the client's request.
Instead, the client should resubmit the request to the URI specified by
the response message's Location header.
A REST API can use this status code to assign a temporary URI to the
client's requested resource. For example, a 307 response can be used to
shift a client request over to another host."
([location] (response "" 307 {"location" location}))
([location body] (response body 307 {"location" location}))
([location body headers] (response body 307 (merge headers {"location" location}))))
(defn bad-request
"HTTP 400 Bad Request
May be used to indicate nonspecific failure.
400 is the generic client-side error status, used when no other 4xx error
code is appropriate."
([body] (response body 400))
([body headers] (response body 400 headers)))
(defn unauthorized
"HTTP 401 Unauthorized
Must be used when there is a problem with the client credentials.
A 401 error response indicates that the client tried to operate on a
protected resource without providing the proper authorization. It may have
provided the wrong credentials or none at all."
([body] (response body 401))
([body headers] (response body 401 headers)))
(defn forbidden
"HTTP 403 Forbidden
Should be used to forbid access regardless of authorization state.
A 403 error response indicates that the client's request is formed
correctly, but the REST API refuses to honor it. A 403 response is not a
case of insufficient client credentials; that would be 401 (\"Unauthorized\").
REST APIs use 403 to enforce application-level permissions. For example, a
client may be authorized to interact with some, but not all of a REST API's
resources. If the client attempts a resource interaction that is outside of
its permitted scope, the REST API should respond with 403."
([body] (response body 403))
([body headers] (response body 403 headers)))
(defn not-found
"HTTP 404 Not Found
Must be used when a client's URI cannot be mapped to a resource.
The 404 error status code indicates that the REST API can't map the
client's URI to a resource."
([body] (response body 404))
([body headers] (response body 404 headers)))
(defn method-not-allowed
([body] (response body 405))
([body headers] (response body 405 headers)))
(defn not-acceptable
([body] (response body 406))
([body headers] (response body 406 headers)))
(defn conflict
([body] (response body 409))
([body headers] (response body 409 headers)))
(defn gone
([body] (response body 410))
([body headers] (response body 410 headers)))
(defn precondition-failed
([body] (response body 412))
([body headers] (response body 412 headers)))
(defn unsupported-mediatype
([body] (response body 415))
([body headers] (response body 415 headers)))
(defn too-many-requests
([body] (response body 429))
([body headers] (response body 429 headers)))
(defn internal-server-error
([body] (response body 500))
([body headers] (response body 500 headers)))
(defn not-implemented
([body] (response body 501))
([body headers] (response body 501 headers)))

63
backend/src/uxbox/http/session.clj Normal file
View file

@ -0,0 +1,63 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.http.session
(:require
[promesa.core :as p]
[sieppari.context :as spx]
[vertx.core :as vc]
[uxbox.db :as db]
[uxbox.util.exceptions :as ex]
[uxbox.util.uuid :as uuid]))
;; --- Main API
(defn retrieve
"Retrieves a user id associated with the provided auth token."
[token]
(let [sql "select user_id from sessions where id = $1"]
(-> (db/query-one db/pool [sql token])
(p/then' (fn [row] (when row (:user-id row)))))))
(defn create
[user-id user-agent]
(let [id (uuid/random)
sql "insert into sessions (id, user_id, user_agent) values ($1, $2, $3)"]
(-> (db/query-one db/pool [sql id user-id user-agent])
(p/then (constantly (str id))))))
(defn delete
[token]
(let [sql "delete from sessions where id = $1"]
(-> (db/query-one db/pool [sql token])
(p/then' (constantly nil)))))
;; --- Interceptor
(defn parse-token
[request]
(try
(when-let [token (get-in request [:cookies "auth-token"])]
(uuid/from-string token))
(catch java.lang.IllegalArgumentException e
nil)))
(defn auth
[]
{:enter (fn [data]
(let [token (parse-token (:request data))]
(-> (retrieve token)
(p/then' (fn [user-id]
(if user-id
(update data :request assoc :user user-id)
(spx/terminate (assoc data ::unauthorized true)))))
(vc/handle-on-context))))
:leave (fn [data]
(if (::unauthorized data)
(update data :response
assoc :status 403 :body {:type :authentication
:code :unauthorized})
data))})

2
backend/src/uxbox/images.clj
View file

@ -21,6 +21,8 @@
org.im4java.core.ConvertCmd
org.im4java.core.IMOperation))
;; TODO: make this module non-blocking
;; --- Thumbnails Generation
(s/def ::width integer?)

12
backend/src/uxbox/locks.clj
View file

@ -7,15 +7,15 @@
(ns uxbox.locks
"Advirsory locks for specific handling concurrent modifications
on particular objects in the database."
(:require [suricatta.core :as sc])
#_(:require [suricatta.core :as sc])
(:import clojure.lang.Murmur3))
(defn- uuid->long
[v]
(Murmur3/hashUnencodedChars (str v)))
(defn acquire!
[conn v]
(let [id (uuid->long v)]
(sc/execute conn ["select pg_advisory_xact_lock(?);" id])
nil))
;; (defn acquire!
;; [conn v]
;; (let [id (uuid->long v)]
;; (sc/execute conn ["select pg_advisory_xact_lock(?);" id])
;; nil))

5
backend/src/uxbox/main.clj
View file

@ -10,12 +10,11 @@
[uxbox.migrations]
[uxbox.db]
[uxbox.http]
[uxbox.scheduled-jobs])
#_[uxbox.scheduled-jobs])
(:gen-class))
;; --- Entry point (only for uberjar)
(defn -main
[& args]
(mount/start)
(.join uxbox.http/server))
(mount/start))

103
backend/src/uxbox/migrations.clj
View file

@ -5,79 +5,52 @@
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.migrations
(:require [mount.core :as mount :refer (defstate)]
[migrante.core :as mg :refer (defmigration)]
[uxbox.db :as db]
[uxbox.config :as cfg]
[uxbox.util.template :as tmpl]))
(:require
[mount.core :as mount :refer [defstate]]
[uxbox.db :as db]
[uxbox.config :as cfg]
[uxbox.util.migrations :as mg]
[uxbox.util.template :as tmpl]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Migrations
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- Migrations
(defmigration utils-0000
"Create a initial version of txlog table."
:up (mg/resource "migrations/0000.main.up.sql"))
(defmigration txlog-0001
"Create a initial version of txlog table."
:up (mg/resource "migrations/0001.txlog.up.sql"))
(defmigration auth-0002
"Create initial auth related tables."
:up (mg/resource "migrations/0002.auth.up.sql"))
(defmigration projects-0003
"Create initial tables for projects."
:up (mg/resource "migrations/0003.projects.up.sql"))
(defmigration pages-0004
"Create initial tables for pages."
:up (mg/resource "migrations/0004.pages.up.sql"))
(defmigration kvstore-0005
"Create initial tables for kvstore."
:up (mg/resource "migrations/0005.kvstore.up.sql"))
(defmigration emails-queue-0006
"Create initial tables for emails queue."
:up (mg/resource "migrations/0006.emails.up.sql"))
(defmigration images-0007
"Create initial tables for image collections."
:up (mg/resource "migrations/0007.images.up.sql"))
(defmigration icons-0008
"Create initial tables for image collections."
:up (mg/resource "migrations/0008.icons.up.sql"))
(defmigration history-0009
"Add improvements on how history is managed for pages."
:up (mg/resource "migrations/0009.history.improvements.up.sql"))
(def migrations
{:name "uxbox-main"
:steps
[{:desc "Initial triggers and utils."
:name "0001-main"
:fn (mg/resource "migrations/0001.main.up.sql")}
{:desc "Initial auth related tables"
:name "0002-auth"
:fn (mg/resource "migrations/0002.auth.up.sql")}
{:desc "Initial projects tables"
:name "0003-projects"
:fn (mg/resource "migrations/0003.projects.up.sql")}
{:desc "Initial pages tables"
:name "0004-pages"
:fn (mg/resource "migrations/0004.pages.up.sql")}
{:desc "Initial kvstore tables"
:name "0005-kvstore"
:fn (mg/resource "migrations/0005.kvstore.up.sql")}
{:desc "Initial emails related tables"
:name "0006-emails"
:fn (mg/resource "migrations/0006.emails.up.sql")}
{:desc "Initial images tables"
:name "0007-images"
:fn (mg/resource "migrations/0007.images.up.sql")}
{:desc "Initial icons tables"
:name "0008-icons"
:fn (mg/resource "migrations/0008.icons.up.sql")}
]})
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Entry point
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def +migrations+
{:name :uxbox-main
:steps [[:0000 utils-0000]
[:0001 txlog-0001]
[:0002 auth-0002]
[:0003 projects-0003]
[:0004 pages-0004]
[:0005 kvstore-0005]
[:0006 emails-queue-0006]
[:0007 images-0007]
[:0008 icons-0008]
[:0009 history-0009]]})
(defn- migrate
(defn migrate
[]
(let [options {:verbose (:migrations-verbose cfg/config true)}]
(with-open [mctx (mg/context db/datasource options)]
(mg/migrate mctx +migrations+)
nil)))
(with-open [ctx (mg/context db/pool)]
@(mg/migrate ctx migrations)))
(defstate migrations
:start (migrate))

168
backend/src/uxbox/portation.clj
View file

@ -7,107 +7,105 @@
(ns uxbox.portation
"Support for export/import operations of projects."
(:refer-clojure :exclude [with-open])
(:require [clojure.java.io :as io]
#_(:require [clojure.java.io :as io]
[suricatta.core :as sc]
[datoteka.core :as fs]
[uxbox.db :as db]
[uxbox.sql :as sql]
[uxbox.util.uuid :as uuid]
[uxbox.util.closeable :refer (with-open)]
[uxbox.util.transit :as t]
[uxbox.util.snappy :as snappy]))
[uxbox.util.transit :as t]))
;; --- Export
;; ;; --- Export
(defn- write-project
[conn writer id]
(let [sql (sql/get-project-by-id {:id id})
result (sc/fetch-one conn sql)]
(when-not result
(ex-info "No project found with specified id" {:id id}))
(t/write! writer {::type ::project ::payload result})))
;; (defn- write-project
;; [conn writer id]
;; (let [sql (sql/get-project-by-id {:id id})
;; result (sc/fetch-one conn sql)]
;; (when-not result
;; (ex-info "No project found with specified id" {:id id}))
;; (t/write! writer {::type ::project ::payload result})))
(defn- write-pages
[conn writer id]
(let [sql (sql/get-pages-for-project {:project id})
results (sc/fetch conn sql)]
(run! #(t/write! writer {::type ::page ::payload %}) results)))
;; (defn- write-pages
;; [conn writer id]
;; (let [sql (sql/get-pages-for-project {:project id})
;; results (sc/fetch conn sql)]
;; (run! #(t/write! writer {::type ::page ::payload %}) results)))
(defn- write-pages-history
[conn writer id]
(let [sql (sql/get-page-history-for-project {:project id})
results (sc/fetch conn sql)]
(run! #(t/write! writer {::type ::page-history ::payload %}) results)))
;; (defn- write-pages-history
;; [conn writer id]
;; (let [sql (sql/get-page-history-for-project {:project id})
;; results (sc/fetch conn sql)]
;; (run! #(t/write! writer {::type ::page-history ::payload %}) results)))
(defn- write-data
[path id]
(with-open [ostream (io/output-stream path)
zstream (snappy/output-stream ostream)
conn (db/connection)]
(let [writer (t/writer zstream {:type :msgpack})]
(sc/atomic conn
(write-project conn writer id)
(write-pages conn writer id)
(write-pages-history conn writer id)))))
;; (defn- write-data
;; [path id]
;; (with-open [ostream (io/output-stream path)
;; zstream (snappy/output-stream ostream)
;; conn (db/connection)]
;; (let [writer (t/writer zstream {:type :msgpack})]
;; (sc/atomic conn
;; (write-project conn writer id)
;; (write-pages conn writer id)
;; (write-pages-history conn writer id)))))
(defn export
"Given an id, returns a path to a temporal file with the exported
bundle of the specified project."
[id]
(let [path (fs/create-tempfile)]
(write-data path id)
path))
;; (defn export
;; "Given an id, returns a path to a temporal file with the exported
;; bundle of the specified project."
;; [id]
;; (let [path (fs/create-tempfile)]
;; (write-data path id)
;; path))
;; --- Import
;; ;; --- Import
(defn- read-entry
[reader]
(try
(t/read! reader)
(catch RuntimeException e
(let [cause (.getCause e)]
(if (instance? java.io.EOFException cause)
::eof
(throw e))))))
;; (defn- read-entry
;; [reader]
;; (try
;; (t/read! reader)
;; (catch RuntimeException e
;; (let [cause (.getCause e)]
;; (if (instance? java.io.EOFException cause)
;; ::eof
;; (throw e))))))
(defn- persist-project
[conn project]
(let [sql (sql/create-project project)]
(sc/execute conn sql)))
;; (defn- persist-project
;; [conn project]
;; (let [sql (sql/create-project project)]
;; (sc/execute conn sql)))
(defn- persist-page
[conn page]
(let [sql (sql/create-page page)]
(sc/execute conn sql)))
;; (defn- persist-page
;; [conn page]
;; (let [sql (sql/create-page page)]
;; (sc/execute conn sql)))
(defn- persist-page-history
[conn history]
(let [sql (sql/create-page-history history)]
(sc/execute conn sql)))
;; (defn- persist-page-history
;; [conn history]
;; (let [sql (sql/create-page-history history)]
;; (sc/execute conn sql)))
(defn- persist-entry
[conn entry]
(let [payload (::payload entry)
type (::type entry)]
(case type
::project (persist-project conn payload)
::page (persist-page conn payload)
::page-history (persist-page-history conn payload))))
;; (defn- persist-entry
;; [conn entry]
;; (let [payload (::payload entry)
;; type (::type entry)]
;; (case type
;; ::project (persist-project conn payload)
;; ::page (persist-page conn payload)
;; ::page-history (persist-page-history conn payload))))
(defn- read-data
[conn reader]
(loop [entry (read-entry reader)]
(when (not= entry ::eof)
(persist-entry conn entry)
(recur (read-entry reader)))))
;; (defn- read-data
;; [conn reader]
;; (loop [entry (read-entry reader)]
;; (when (not= entry ::eof)
;; (persist-entry conn entry)
;; (recur (read-entry reader)))))
(defn import!
"Given a path to the previously exported bundle, try to import it."
[path]
(with-open [istream (io/input-stream (fs/path path))
zstream (snappy/input-stream istream)
conn (db/connection)]
(let [reader (t/reader zstream {:type :msgpack})]
(sc/atomic conn
(read-data conn reader)
nil))))
;; (defn import!
;; "Given a path to the previously exported bundle, try to import it."
;; [path]
;; (with-open [istream (io/input-stream (fs/path path))
;; zstream (snappy/input-stream istream)
;; conn (db/connection)]
;; (let [reader (t/reader zstream {:type :msgpack})]
;; (sc/atomic conn
;; (read-data conn reader)
;; nil))))

23
backend/src/uxbox/scheduled_jobs.clj
View file

@ -1,23 +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) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.scheduled-jobs
"Time-based scheduled jobs."
(:require [mount.core :as mount :refer (defstate)]
[uxbox.config :as cfg]
[uxbox.db]
[uxbox.util.quartz :as qtz]))
(defn- initialize
[]
(let [nss #{'uxbox.scheduled-jobs.garbage
'uxbox.scheduled-jobs.emails}]
(-> (qtz/scheduler)
(qtz/start! {:search-on nss}))))
(defstate scheduler
:start (initialize)
:stop (qtz/stop! scheduler))

133
backend/src/uxbox/scheduled_jobs/emails.clj
View file

@ -1,133 +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) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.scheduled-jobs.emails
"Email sending async tasks."
(:require [clojure.tools.logging :as log]
[suricatta.core :as sc]
[postal.core :as postal]
[uxbox.db :as db]
[uxbox.config :as cfg]
[uxbox.sql :as sql]
[uxbox.util.quartz :as qtz]
[uxbox.util.blob :as blob]
[uxbox.util.transit :as t]
[uxbox.util.data :as data]))
;; --- Impl details
(defn- decode-email-data
[{:keys [data] :as result}]
(merge result (when data
{:data (-> data blob/decode t/decode)})))
(defn- fetch-pending-emails
[conn]
(let [sqlv (sql/get-pending-emails)]
(->> (sc/fetch conn sqlv)
(map data/normalize-attrs)
(map decode-email-data))))
(defn- fetch-immediate-emails
[conn]
(let [sqlv (sql/get-immediate-emails)]
(->> (sc/fetch conn sqlv)
(map data/normalize-attrs)
(map decode-email-data))))
(defn- fetch-failed-emails
[conn]
(let [sqlv (sql/get-pending-emails)]
(->> (sc/fetch conn sqlv)
(map data/normalize-attrs)
(map decode-email-data))))
(defn- mark-email-as-sent
[conn id]
(let [sqlv (sql/mark-email-as-sent {:id id})]
(sc/execute conn sqlv)))
(defn- mark-email-as-failed
[conn id]
(let [sqlv (sql/mark-email-as-failed {:id id})]
(sc/execute conn sqlv)))
(defn- send-email-to-console
[{:keys [id data] :as entry}]
(println "******** start email:" id "**********")
(println (->> (:body data)
(filter #(= (:uxbox.emails.core/type %) :text/plain))
(first)
(:content)))
(println "********** end email:" id "**********")
{:error :SUCCESS})
(defn- get-smtp-config
[config]
{:host (:smtp-host config)
:port (:smtp-port config)
:user (:smtp-user config)
:pass (:smtp-password config)
:ssl (:smtp-ssl config)
:tls (:smtp-tls config)
:noop (not (:smtp-enabled config))})
(defn- send-email
[{:keys [id data] :as entry}]
(let [config (get-smtp-config cfg/config)
result (if (:noop config)
(send-email-to-console entry)
(postal/send-message config data))]
(if (= (:error result) :SUCCESS)
(log/debug "Message" id "sent successfully.")
(log/warn "Message" id "failed with:" (:message result)))
(if (= (:error result) :SUCCESS)
true
false)))
(defn- send-emails
[conn entries]
(loop [entries entries]
(if-let [entry (first entries)]
(do (if (send-email entry)
(mark-email-as-sent conn (:id entry))
(mark-email-as-failed conn (:id entry)))
(recur (rest entries))))))
;; --- Jobs
(defn send-immediate-emails
{::qtz/interval (* 60 1 1000) ;; every 1min
::qtz/repeat? true
::qtz/job true}
[]
(log/info "task-send-immediate-emails...")
(with-open [conn (db/connection)]
(sc/atomic conn
(->> (fetch-immediate-emails conn)
(send-emails conn)))))
(defn send-pending-emails
{::qtz/interval (* 60 5 1000) ;; every 5min
::qtz/repeat? true
::qtz/job true}
[]
(with-open [conn (db/connection)]
(sc/atomic conn
(->> (fetch-pending-emails conn)
(send-emails conn)))))
(defn send-failed-emails
"Job that resends failed to send messages."
{::qtz/interval (* 60 5 1000) ;; every 5min
::qtz/repeat? true
::qtz/job true}
[]
(log/info "task-send-failed-emails...")
(with-open [conn (db/connection)]
(sc/atomic conn
(->> (fetch-failed-emails conn)
(send-emails conn)))))

28
backend/src/uxbox/scheduled_jobs/garbage.clj
View file

@ -1,28 +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) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.scheduled-jobs.garbage
"Garbage Collector related tasks."
(:require [suricatta.core :as sc]
[uxbox.db :as db]
[uxbox.util.quartz :as qtz]))
;; --- Delete projects
;; TODO: move inline sql into resources/sql directory
(defn clean-deleted-projects
"Task that cleans the deleted projects."
{::qtz/repeat? true
::qtz/interval (* 1000 3600 24)
::qtz/job true}
[]
(with-open [conn (db/connection)]
(sc/atomic conn
(let [sql (str "DELETE FROM projects "
" WHERE deleted_at is not null AND "
" (now()-deleted_at)::interval > '10 day'::interval;")]
(sc/execute conn sql)))))

61
backend/src/uxbox/services.clj
View file

@ -1,61 +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) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.services
"Main namespace for access to all uxbox services."
(:require [suricatta.core :as sc]
[executors.core :as exec]
[promesa.core :as p]
[uxbox.db :as db]
[uxbox.services.core :as core]
[uxbox.util.transit :as t]
[uxbox.util.blob :as blob]))
;; Load relevant subnamespaces with the implementation
(load "services/auth")
(load "services/projects")
(load "services/pages")
(load "services/images")
(load "services/icons")
(load "services/kvstore")
;; --- Implementation
(def ^:private encode (comp blob/encode t/encode))
(defn- insert-txlog
[data]
(with-open [conn (db/connection)]
(let [sql (str "INSERT INTO txlog (payload) VALUES (?)")
sqlv [sql (encode data)]]
(sc/execute conn sqlv))))
(defn- handle-novelty
[data]
(let [rs (core/novelty data)
rs (if (p/promise? rs) rs (p/resolved rs))]
(p/map (fn [v]
(insert-txlog data)
v) rs)))
(defn- handle-query
[data]
(let [result (core/query data)]
(if (p/promise? result)
result
(p/resolved result))))
;; --- Public Api
(defn novelty
[data]
(->> (exec/submit (partial handle-novelty data))
(p/mapcat identity)))
(defn query
[data]
(->> (exec/submit (partial handle-query data))
(p/mapcat identity)))

63
backend/src/uxbox/services/auth.clj
View file

@ -2,30 +2,49 @@
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.services.auth
(:require [clojure.spec.alpha :as s]
[suricatta.core :as sc]
[buddy.hashers :as hashers]
[uxbox.config :as cfg]
[uxbox.db :as db]
[uxbox.services.core :as core]
[uxbox.services.users :as users]
[uxbox.util.exceptions :as ex]))
(:require
[clojure.spec.alpha :as s]
[buddy.hashers :as hashers]
[promesa.core :as p]
[uxbox.config :as cfg]
[uxbox.db :as db]
[uxbox.services.core :as sc]
[uxbox.services.users :as users]
[uxbox.util.spec :as us]
[uxbox.util.exceptions :as ex]))
(defn- check-user-password
[user password]
(hashers/check password (:password user)))
(s/def ::username ::us/string)
(s/def ::password ::us/string)
(s/def ::scope ::us/string)
(defmethod core/novelty :login
(s/def ::login-params
(s/keys :req-un [::username ::password]
:opt-un [::scope]))
(def ^:private user-by-username-sql
"select id, password
from users
where username=$1 or email=$1
and deleted_at is null")
(sc/defmutation :login
{:doc "User login"
:spec ::login-params}
[{:keys [username password scope] :as params}]
(with-open [conn (db/connection)]
(let [user (users/find-user-by-username-or-email conn username)]
(when-not user
(ex/raise :type :validation
:code ::wrong-credentials))
(when-not (check-user-password user password)
(ex/raise :type :validation
:code ::wrong-credentials))
user)))
(letfn [(check-password [user password]
(hashers/check password (:password user)))
(check-user [user]
(when-not user
(ex/raise :type :validation
:code ::wrong-credentials))
(when-not (check-password user password)
(ex/raise :type :validation
:code ::wrong-credentials))
(:id user))]
(-> (db/query-one db/pool [user-by-username-sql username])
(p/then' check-user))))

76
backend/src/uxbox/services/core.clj
View file

@ -2,26 +2,70 @@
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.services.core
(:require [clojure.walk :as walk]
[cuerdas.core :as str]
[uxbox.util.exceptions :as ex]))
(:require
[clojure.tools.logging :as log]
[promesa.core :as p]
[vertx.core :as vc]
[uxbox.core :refer [system]]
[uxbox.util.uuid :as uuid]
[uxbox.util.dispatcher :as uds]
[uxbox.util.exceptions :as ex])
(:import
java.util.Map
java.util.List
java.util.Map$Entry
java.util.HashMap))
(defmulti novelty :type)
(def context-interceptor
{:enter (fn [data]
(update data :request assoc ::ctx (vc/get-or-create-context system)))})
(defmulti query :type)
(def logging-interceptor
{:enter (fn [data]
(let [type (get-in data [:request ::type])]
(assoc data ::start-time (System/nanoTime))))
:leave (fn [data]
(let [elapsed (- (System/nanoTime) (::start-time data))
elapsed (str (quot elapsed 1000000) "ms")
type (get-in data [:request ::type])]
(log/info "service" type "processed in" elapsed)
data))})
(defmethod novelty :default
[{:keys [type] :as data}]
(ex/raise :code ::not-implemented
:message-category :novelty
:message-type type))
(defmethod query :default
[{:keys [type] :as data}]
(ex/raise :code ::not-implemented
:message-category :query
:message-type type))
(uds/defservice query
{:dispatch-by ::type
:interceptors [uds/spec-interceptor
logging-interceptor
#_context-interceptor]})
(uds/defservice mutation
{:dispatch-by ::type
:interceptors [uds/spec-interceptor
#_context-interceptor]})
;; --- Helpers
(defmacro defmutation
[key & rest]
`(uds/defmethod mutation ~key ~@rest))
(defmacro defquery
[key & rest]
`(uds/defmethod query ~key ~@rest))
(defn raise-not-found-if-nil
[v]
(if (nil? v)
(ex/raise :type :not-found
:hint "Object doest not exists.")
v))
(def constantly-nil (constantly nil))
(defn handle-on-context
[p]
(->> (vc/get-or-create-context system)
(vc/handle-on-context p)))

414
backend/src/uxbox/services/icons.clj
View file

@ -2,226 +2,236 @@
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.services.icons
"Icons library related services."
(:require [clojure.spec.alpha :as s]
[suricatta.core :as sc]
[uxbox.util.spec :as us]
[uxbox.sql :as sql]
[uxbox.db :as db]
[uxbox.services.core :as core]
[uxbox.util.exceptions :as ex]
[uxbox.util.transit :as t]
[uxbox.util.uuid :as uuid]
[uxbox.util.blob :as blob]
[uxbox.util.data :as data])
(:import org.apache.commons.io.FilenameUtils))
(:require
[clojure.spec.alpha :as s]
[promesa.core :as p]
[uxbox.db :as db]
[uxbox.services.core :as sv]
[uxbox.util.blob :as blob]
[uxbox.util.exceptions :as ex]
[uxbox.util.spec :as us]
[uxbox.util.uuid :as uuid]))
;; --- Helpers & Specs
(s/def ::user uuid?)
(s/def ::collection (s/nilable uuid?))
(s/def ::width (s/and number? pos?))
(s/def ::height (s/and number? pos?))
(s/def ::view-box (s/and (s/coll-of number?)
#(= 4 (count %))
vector?))
(s/def ::id ::us/uuid)
(s/def ::name ::us/string)
(s/def ::user ::us/uuid)
(s/def ::collection-id (s/nilable ::us/uuid))
(s/def ::width ::us/integer)
(s/def ::height ::us/integer)
(s/def ::view-box
(s/and (s/coll-of number?)
#(= 4 (count %))
vector?))
(s/def ::content ::us/string)
(s/def ::mimetype ::us/string)
(s/def ::content string?)
(s/def ::mimetype string?)
(s/def ::metadata
(s/keys :opt-un [::width ::height ::view-box ::mimetype]))
(defn decode-metadata
[{:keys [metadata] :as data}]
(if metadata
(assoc data :metadata (-> metadata blob/decode t/decode))
data))
(defn- decode-icon-row
[{:keys [metadata] :as row}]
(when row
(cond-> row
metadata (assoc :metadata (blob/decode metadata)))))
;; --- Create Collection
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Queries
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn create-collection
[conn {:keys [id user name]}]
(let [id (or id (uuid/random))
params {:id id :user user :name name}
sqlv (sql/create-icon-collection params)]
(-> (sc/fetch-one conn sqlv)
(data/normalize))))
;; --- Query: Collections
(s/def ::create-icon-collection
(s/keys :req-un [::user ::us/name]
:opt-un [::us/id]))
(def ^:private icons-collections-sql
"select *,
(select count(*) from icons where collection_id = ic.id) as num_icons
from icons_collections as ic
where (ic.user_id = $1 or
ic.user_id = '00000000-0000-0000-0000-000000000000'::uuid)
and ic.deleted_at is null
order by ic.created_at desc")
(defmethod core/novelty :create-icon-collection
[params]
(s/assert ::create-icon-collection params)
(with-open [conn (db/connection)]
(create-collection conn params)))
(s/def ::icons-collections
(s/keys :req-un [::user]))
;; --- Update Collection
(defn update-collection
[conn {:keys [id user name version]}]
(let [sqlv (sql/update-icon-collection {:id id
:user user
:name name
:version version})]
(some-> (sc/fetch-one conn sqlv)
(data/normalize))))
(s/def ::update-icon-collection
(s/keys :req-un [::user ::us/name ::us/version]
:opt-un [::us/id]))
(defmethod core/novelty :update-icon-collection
[params]
(s/assert ::update-icon-collection params)
(with-open [conn (db/connection)]
(sc/apply-atomic conn update-collection params)))
;; --- Copy Icon
(s/def ::copy-icon
(s/keys :req-un [:us/id ::collection ::user]))
(defn- retrieve-icon
[conn {:keys [user id]}]
(let [sqlv (sql/get-icon {:user user :id id})]
(some->> (sc/fetch-one conn sqlv)
(data/normalize-attrs))))
(declare create-icon)
(defn- copy-icon
[conn {:keys [user id collection]}]
(let [icon (retrieve-icon conn {:id id :user user})]
(when-not icon
(ex/raise :type :validation
:code ::icon-does-not-exists))
(let [params (dissoc icon :id)]
(create-icon conn params))))
(defmethod core/novelty :copy-icon
[params]
(s/assert ::copy-icon params)
(with-open [conn (db/connection)]
(sc/apply-atomic conn copy-icon params)))
;; --- List Collections
(defn get-collections-by-user
[conn user]
(let [sqlv (sql/get-icon-collections {:user user})]
(->> (sc/fetch conn sqlv)
(map data/normalize))))
(defmethod core/query :list-icon-collections
(sv/defquery :icons-collections
{:doc "Retrieve all icons collections for current user."
:spec ::icons-collections}
[{:keys [user] :as params}]
(s/assert ::user user)
(with-open [conn (db/connection)]
(get-collections-by-user conn user)))
;; --- Delete Collection
(defn delete-collection
[conn {:keys [id user]}]
(let [sqlv (sql/delete-icon-collection {:id id :user user})]
(pos? (sc/execute conn sqlv))))
(s/def ::delete-icon-collection
(s/keys :req-un [::user]
:opt-un [::us/id]))
(defmethod core/novelty :delete-icon-collection
[params]
(s/assert ::delete-icon-collection params)
(with-open [conn (db/connection)]
(delete-collection conn params)))
;; --- Create Icon (Upload)
(defn create-icon
[conn {:keys [id user name collection
metadata content] :as params}]
(let [id (or id (uuid/random))
params {:id id
:name name
:content content
:metadata (-> metadata t/encode blob/encode)
:collection collection
:user user}
sqlv (sql/create-icon params)]
(some-> (sc/fetch-one conn sqlv)
(data/normalize)
(decode-metadata))))
(s/def ::create-icon
(s/keys :req-un [::user ::us/name ::metadata ::content]
:opt-un [::us/id ::collection]))
(defmethod core/novelty :create-icon
[params]
(s/assert ::create-icon params)
(with-open [conn (db/connection)]
(create-icon conn params)))
;; --- Update Icon
(defn update-icon
[conn {:keys [id name version user collection]}]
(let [sqlv (sql/update-icon {:id id
:collection collection
:name name
:user user
:version version})]
(some-> (sc/fetch-one conn sqlv)
(data/normalize)
(decode-metadata))))
(s/def ::update-icon
(s/keys :req-un [::us/id ::user ::us/name ::us/version ::collection]))
(defmethod core/novelty :update-icon
[params]
(s/assert ::update-icon params)
(with-open [conn (db/connection)]
(update-icon conn params)))
;; --- Delete Icon
(defn delete-icon
[conn {:keys [user id]}]
(let [sqlv (sql/delete-icon {:id id :user user})]
(pos? (sc/execute conn sqlv))))
(s/def ::delete-icon
(s/keys :req-un [::user]
:opt-un [::us/id]))
(defmethod core/novelty :delete-icon
[params]
(s/assert ::delete-icon params)
(with-open [conn (db/connection)]
(delete-icon conn params)))
(let [sqlv [icons-collections-sql user]]
(db/query db/pool sqlv)))
;; --- List Icons
(defn get-icons-by-user
[conn user collection]
(let [sqlv (if collection
(sql/get-icons-by-collection {:user user :collection collection})
(sql/get-icons {:user user}))]
(->> (sc/fetch conn sqlv)
(map data/normalize)
(map decode-metadata))))
(def ^:private icons-by-collection-sql
"select *
from icons as i
where (i.user_id = $1 or
i.user_id = '00000000-0000-0000-0000-000000000000'::uuid)
and i.deleted_at is null
and case when $2::uuid is null then i.collection_id is null
else i.collection_id = $2::uuid
end
order by i.created_at desc")
(s/def ::list-icons
(s/keys :req-un [::user ::collection]))
(s/def ::icons-by-collection
(s/keys :req-un [::user]
:opt-un [::collection-id]))
(defmethod core/query :list-icons
[{:keys [user collection] :as params}]
(s/assert ::list-icons params)
(with-open [conn (db/connection)]
(get-icons-by-user conn user collection)))
(sv/defquery :icons-by-collection
{:doc "Retrieve icons for specified collection."
:spec ::icons-by-collection}
[{:keys [user collection-id] :as params}]
(let [sqlv [icons-by-collection-sql user collection-id]]
(-> (db/query db/pool sqlv)
(p/then' #(mapv decode-icon-row %)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Mutations
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- Mutation: Create Collection
(s/def ::create-icons-collection
(s/keys :req-un [::user ::name]
:opt-un [::id]))
(sv/defmutation :create-icons-collection
{:doc "Create a new collection of icons."
:spec ::create-icons-collection}
[{:keys [id user name] :as params}]
(let [id (or id (uuid/next))
sql "insert into icons_collections (id, user_id, name)
values ($1, $2, $3) returning *"]
(db/query-one db/pool [sql id user name])))
;; --- Mutation: Update Collection
(s/def ::update-icons-collection
(s/keys :req-un [::user ::name ::id]))
(sv/defmutation :update-icons-collection
{:doc "Update a collection of icons."
:spec ::update-icons-collection}
[{:keys [id user name] :as params}]
(let [sql "update icons_collections
set name = $3
where id = $1
and user_id = $2
returning *"]
(-> (db/query-one db/pool [sql id user name])
(p/then' sv/raise-not-found-if-nil))))
;; --- Copy Icon
(declare create-icon)
(defn- retrieve-icon
[conn {:keys [user id]}]
(let [sql "select * from icons
where id = $1
and deleted_at is null
and (user_id = $2 or
user_id = '00000000-0000-0000-0000-000000000000'::uuid)"]
(-> (db/query-one conn [sql id user])
(p/then' sv/raise-not-found-if-nil))))
(s/def ::copy-icon
(s/keys :req-un [:us/id ::collection-id ::user]))
(sv/defmutation :copy-icon
{:doc "Copy an icon from one collection to other."
:spec ::copy-icon}
[{:keys [user id collection-id] :as params}]
(db/with-atomic [conn db/pool]
(-> (retrieve-icon conn {:user user :id id})
(p/then (fn [icon]
(let [icon (-> (dissoc icon :id)
(assoc :collection-id collection-id))]
(create-icon conn icon)))))))
;; --- Delete Collection
(s/def ::delete-icons-collection
(s/keys :req-un [::user ::id]))
(sv/defmutation :delete-icons-collection
{:doc "Delete a collection of icons."
:spec ::delete-icons-collection}
[{:keys [user id] :as params}]
(let [sql "update icons_collections
set deleted_at = clock_timestamp()
where id = $1
and user_id = $2
returning id"]
(-> (db/query-one db/pool [sql id user])
(p/then' sv/raise-not-found-if-nil)
(p/then' sv/constantly-nil))))
;; --- Mutation: Create Icon (Upload)
(def ^:private create-icon-sql
"insert into icons (user_id, name, collection_id, content, metadata)
values ($1, $2, $3, $4, $5) returning *")
(defn create-icon
[conn {:keys [id user name collection-id metadata content]}]
(let [id (or id (uuid/next))
sqlv [create-icon-sql user name
collection-id
content
(blob/encode metadata)]]
(-> (db/query-one conn sqlv)
(p/then' decode-icon-row))))
(s/def ::create-icon
(s/keys :req-un [::user ::name ::metadata ::content]
:opt-un [::id ::collection-id]))
(sv/defmutation :create-icon
{:doc "Create (upload) a new icon."
:spec ::create-icon}
[params]
(create-icon db/pool params))
;; --- Mutation: Update Icon
(s/def ::update-icon
(s/keys :req-un [::id ::user ::name ::collection-id]))
(sv/defmutation :update-icon
{:doc "Update an icon entry."
:spec ::update-icon}
[{:keys [id name user collection-id] :as params}]
(let [sql "update icons
set name = $1,
collection_id = $2
where id = $3
and user_id = $4
returning *"]
(-> (db/query-one db/pool [sql name collection-id id user])
(p/then' sv/raise-not-found-if-nil))))
;; --- Mutation: Delete Icon
(s/def ::delete-icon
(s/keys :req-un [::user ::id]))
(sv/defmutation :delete-icon
{:doc "Delete an icon entry."
:spec ::delete-icon}
[{:keys [id user] :as params}]
(let [sql "update icons
set deleted_at = clock_timestamp()
where id = $1
and user_id = $2
returning id"]
(-> (db/query-one db/pool [sql id user])
(p/then' sv/raise-not-found-if-nil)
(p/then' sv/constantly-nil))))

401
backend/src/uxbox/services/images.clj
View file

@ -2,241 +2,274 @@
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.services.images
"Images library related services."
(:require [clojure.spec.alpha :as s]
[promesa.core :as p]
[suricatta.core :as sc]
[datoteka.storages :as st]
[datoteka.core :as fs]
[uxbox.config :as ucfg]
[uxbox.util.spec :as us]
[uxbox.sql :as sql]
[uxbox.db :as db]
[uxbox.media :as media]
[uxbox.services.core :as core]
[uxbox.util.exceptions :as ex]
[uxbox.util.transit :as t]
[uxbox.util.uuid :as uuid]
[uxbox.util.data :as data])
(:import org.apache.commons.io.FilenameUtils))
(:require
[clojure.spec.alpha :as s]
[datoteka.core :as fs]
[datoteka.storages :as ds]
[promesa.core :as p]
[promesa.exec :as px]
[uxbox.db :as db]
[uxbox.media :as media]
[uxbox.images :as images]
[uxbox.services.core :as sc]
[uxbox.util.blob :as blob]
[uxbox.util.data :as data]
[uxbox.util.exceptions :as ex]
[uxbox.util.spec :as us]
[uxbox.util.uuid :as uuid]
[vertx.core :as vc]))
(s/def ::width integer?)
(s/def ::height integer?)
(s/def ::mimetype string?)
(s/def ::user uuid?)
(s/def ::path string?)
(s/def ::collection (s/nilable uuid?))
(def +thumbnail-options+
{:src :path
:dst :thumbnail
:width 300
:height 100
:quality 92
:format "webp"})
(defn- populate-thumbnail
[row]
(let [opts +thumbnail-options+]
(-> (px/submit! #(images/populate-thumbnails row opts))
(sc/handle-on-context))))
(defn- populate-thumbnails
[rows]
(if (empty? rows)
rows
(p/all (map populate-thumbnail rows))))
(defn- populate-urls
[row]
(images/populate-urls row media/images-storage :path :url))
(s/def ::id ::us/uuid)
(s/def ::name ::us/string)
(s/def ::user ::us/uuid)
(s/def ::collection-id (s/nilable ::us/uuid))
;; --- Create Collection
(defn create-collection
[conn {:keys [id user name]}]
(let [id (or id (uuid/random))
params {:id id :user user :name name}
sqlv (sql/create-image-collection params)]
(-> (sc/fetch-one conn sqlv)
(data/normalize-attrs))))
(s/def ::create-image-collection
(s/keys :req-un [::user ::us/name]
:opt-un [::us/id]))
:opt-un [::id]))
(defmethod core/novelty :create-image-collection
[params]
(s/assert ::create-image-collection params)
(with-open [conn (db/connection)]
(create-collection conn params)))
(sc/defmutation :create-image-collection
{:doc "Create image collection"
:spec ::create-image-collection}
[{:keys [id user name] :as params}]
(let [sql "insert into images_collections (id, user_id, name)
values ($1, $2, $3) returning *;"]
(db/query-one db/pool [sql (or id (uuid/next)) user name])))
;; --- Update Collection
(defn update-collection
[conn {:keys [id user name version]}]
(let [sqlv (sql/update-image-collection {:id id
:user user
:name name
:version version})]
(some-> (sc/fetch-one conn sqlv)
(data/normalize-attrs))))
(s/def ::update-images-collection
(s/keys :req-un [::id ::user ::us/name]))
(s/def ::update-image-collection
(s/keys :req-un [::user ::us/name ::us/version]
:opt-un [::us/id]))
(defmethod core/novelty :update-image-collection
[params]
(s/assert ::update-image-collection params)
(with-open [conn (db/connection)]
(update-collection conn params)))
(sc/defmutation :update-images-collection
{:doc "Update image collection."
:spec ::update-images-collection}
[{:keys [id user name] :as params}]
(let [sql "update images_collections
set name = $3
where id = $1
and user_id = $2
returning *;"]
(db/query-one db/pool [sql id user name])))
;; --- List Collections
(defn get-collections-by-user
[conn user]
(let [sqlv (sql/get-image-collections {:user user})]
(->> (sc/fetch conn sqlv)
(map data/normalize-attrs))))
(def ^:private images-collections-sql
"select *,
(select count(*) from images where collection_id = ic.id) as num_images
from images_collections as ic
where (ic.user_id = $1 or
ic.user_id = '00000000-0000-0000-0000-000000000000'::uuid)
and ic.deleted_at is null
order by ic.created_at desc;")
(defmethod core/query :list-image-collections
(sc/defquery :images-collections
{:doc "Retrieve image collections for the current logged user"}
[{:keys [user] :as params}]
(s/assert ::user user)
(with-open [conn (db/connection)]
(get-collections-by-user conn user)))
(db/query db/pool [images-collections-sql user]))
;; --- Delete Collection
(defn delete-collection
[conn {:keys [id user]}]
(let [sqlv (sql/delete-image-collection {:id id :user user})]
(pos? (sc/execute conn sqlv))))
(s/def ::delete-images-collection
(s/keys :req-un [::user ::id]))
(s/def ::delete-image-collection
(s/keys :req-un [::user]
:opt-un [::us/id]))
(defmethod core/novelty :delete-image-collection
[params]
(s/assert ::delete-image-collection params)
(with-open [conn (db/connection)]
(delete-collection conn params)))
(sc/defmutation :delete-images-collection
{:doc "Delete an image collection"
:spec ::delete-images-collection}
[{:keys [id user] :as params}]
(let [sql "update images_collections
set deleted_at = clock_timestamp()
where id = $1
and user_id = $2
returning id"]
(-> (db/query-one db/pool [sql id user])
(p/then' sc/raise-not-found-if-nil))))
;; --- Retrieve Image
(defn retrieve-image
[conn {:keys [id]}]
(let [sqlv (sql/get-image {:id id})]
(some-> (sc/fetch-one conn sqlv)
(data/normalize-attrs))))
[conn id]
(let [sql "select * from images
where id = $1
and deleted_at is null;"]
(db/query-one conn [sql id])))
(s/def ::retrieve-image
(s/keys :req-un [::user ::us/id]))
;; (s/def ::retrieve-image
;; (s/keys :req-un [::user ::us/id]))
(defmethod core/query :retrieve-image
[params]
(s/assert ::retrieve-image params)
(with-open [conn (db/connection)]
(retrieve-image conn params)))
;; (defmethod core/query :retrieve-image
;; [params]
;; (s/assert ::retrieve-image params)
;; (with-open [conn (db/connection)]
;; (retrieve-image conn params)))
;; --- Create Image (Upload)
(defn create-image
[conn {:keys [id user name path collection
height width mimetype]}]
(let [id (or id (uuid/random))
sqlv (sql/create-image {:id id
:name name
:mimetype mimetype
:path path
:width width
:height height
:collection collection
:user user})]
(some-> (sc/fetch-one conn sqlv)
(data/normalize-attrs))))
(defn- store-image-in-fs
[{:keys [name path] :as upload}]
(prn "store-image-in-fs" upload)
(let [filename (fs/name name)
storage media/images-storage]
(-> (ds/save storage filename path)
(vc/handle-on-context))))
(def ^:private create-image-sql
"insert into images (user_id, name, collection_id, path, width, height, mimetype)
values ($1, $2, $3, $4, $5, $6, $7) returning *")
(defn- store-image-in-db
[conn {:keys [id user name path collection-id height width mimetype]}]
(let [sqlv [create-image-sql user name collection-id
path width height mimetype]]
(-> (db/query-one conn sqlv)
(p/then populate-thumbnail)
(p/then populate-urls))))
(def valid-image-types?
#{"image/jpeg", "image/png", "image/webp"})
(s/def ::file ::us/upload)
(s/def ::width ::us/integer)
(s/def ::height ::us/integer)
(s/def ::mimetype valid-image-types?)
(s/def ::create-image
(s/keys :req-un [::user ::us/name ::path ::width ::height ::mimetype]
:opt-un [::us/id]))
(s/keys :req-un [::user ::name ::file ::width ::height ::mimetype]
:opt-un [::id ::collection-id]))
(defmethod core/novelty :create-image
[params]
(s/assert ::create-image params)
(with-open [conn (db/connection)]
(create-image conn params)))
(sc/defmutation :create-image
{:doc "Create (upload) new image."
:spec ::create-image}
[{:keys [file] :as params}]
(when-not (valid-image-types? (:mtype file))
(ex/raise :type :validation
:code :image-type-not-allowed
:hint "Seems like you are uploading an invalid image."))
(-> (store-image-in-fs file)
(p/then (fn [path]
(store-image-in-db db/pool (assoc params :path (str path)))))))
;; --- Update Image
(defn update-image
[conn {:keys [id name version user collection]}]
(let [sqlv (sql/update-image {:id id
:collection collection
:name name
:user user
:version version})]
(some-> (sc/fetch-one conn sqlv)
(data/normalize-attrs))))
(s/def ::update-image
(s/keys :req-un [::user ::us/name ::us/version ::collection]
:opt-un [::us/id]))
(s/keys :req-un [::id ::user ::name ::collection-id]))
(defmethod core/novelty :update-image
[params]
(s/assert ::update-image params)
(with-open [conn (db/connection)]
(update-image conn params)))
(def ^:private update-image-sql
"update images
set name = $3,
collection_id = $2
where id = $1
and user_id = $4
returning *;")
(sc/defmutation :update-image
{:doc "Update a image entry."
:spec ::update-image}
[{:keys [id name user collection-id] :as params}]
(let [sql update-image-sql]
(db/query-one db/pool [sql id collection-id name user])))
;; --- Copy Image
(s/def ::copy-image
(s/keys :req-un [::us/id ::collection ::user]))
(declare retrieve-image)
(defn- copy-image
[conn {:keys [user id collection]}]
(let [image (retrieve-image conn {:id id :user user})
storage media/images-storage]
(when-not image
(ex/raise :type :validation
:code ::image-does-not-exists))
(let [path @(st/lookup storage (:path image))
filename (fs/name path)
path @(st/save storage filename path)
image (assoc image
:path (str path)
:collection collection)
image (dissoc image :id)]
(create-image conn image))))
(s/def ::copy-image
(s/keys :req-un [::id ::collection-id ::user]))
(defmethod core/novelty :copy-image
[params]
(s/assert ::copy-image params)
(with-open [conn (db/connection)]
(sc/apply-atomic conn copy-image params)))
(sc/defmutation :copy-image
{:doc "Copy image from one collection to an other."
:spec ::copy-image}
[{:keys [user id collection-id] :as params}]
(letfn [(copy-image [conn {:keys [path] :as image}]
(-> (ds/lookup media/images-storage (:path image))
(p/then (fn [path] (ds/save media/images-storage (fs/name path) path)))
(p/then (fn [path]
(-> image
(assoc :path (str path) :collection-id collection-id)
(dissoc :id))))
(p/then (partial store-image-in-db conn))))]
(db/with-atomic [conn db/pool]
(-> (retrieve-image conn {:id id :user user})
(p/then sc/raise-not-found-if-nil)
(p/then (partial copy-image conn))))))
;; --- Delete Image
(defn- delete-image-from-storage
[{:keys [path] :as image}]
(when @(st/exists? media/images-storage path)
@(st/delete media/images-storage path))
(when @(st/exists? media/thumbnails-storage path)
@(st/delete media/thumbnails-storage path)))
(defn delete-image
[conn {:keys [user id]}]
(let [sqlv (sql/delete-image {:id id :user user})]
(some-> (sc/fetch-one conn sqlv)
(delete-image-from-storage))))
;; TODO: this need to be performed in the GC process
;; (defn- delete-image-from-storage
;; [{:keys [path] :as image}]
;; (when @(ds/exists? media/images-storage path)
;; @(ds/delete media/images-storage path))
;; (when @(ds/exists? media/thumbnails-storage path)
;; @(ds/delete media/thumbnails-storage path)))
(s/def ::delete-image
(s/keys :req-un [::id ::user]))
(sc/defmutation :delete-image
{:doc "Delete image entry."
:spec ::delete-image}
[{:keys [user id] :as params}]
(let [sql "update images
set deleted_at = clock_timestamp()
where id = $1
and user_id = $2
returning *"]
(db/query-one db/pool [sql id user])))
;; --- Query Images by Collection (id)
(def images-by-collection-sql
"select * from images
where (user_id = $1 or
user_id = '00000000-0000-0000-0000-000000000000'::uuid)
and deleted_at is null
and case when $2::uuid is null then collection_id is null
else collection_id = $2::uuid
end
order by created_at desc;")
(s/def ::images-by-collection-query
(s/keys :req-un [::user]
:opt-un [::us/id]))
:opt-un [::collection-id]))
(defmethod core/novelty :delete-image
[params]
(s/assert ::delete-image params)
(with-open [conn (db/connection)]
(sc/apply-atomic conn delete-image params)))
(sc/defquery :images-by-collection
{:doc "Get all images of a collection"
:spec ::images-by-collection-query}
[{:keys [user collection-id] :as params}]
(let [sqlv [images-by-collection-sql user collection-id]]
(-> (db/query db/pool sqlv)
(p/then populate-thumbnails)
(p/then #(mapv populate-urls %)))))
;; --- List Images
(defn get-images-by-user
[conn user collection]
(let [sqlv (if collection
(sql/get-images-by-collection {:user user :collection collection})
(sql/get-images {:user user}))]
(->> (sc/fetch conn sqlv)
(map data/normalize-attrs))))
(s/def ::list-images
(s/keys :req-un [::user ::collection]))
(defmethod core/query :list-images
[{:keys [user collection] :as params}]
(s/assert ::list-images params)
(with-open [conn (db/connection)]
(get-images-by-user conn user collection)))

117
backend/src/uxbox/services/kvstore.clj
View file

@ -2,86 +2,75 @@
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.services.kvstore
(:require [clojure.spec.alpha :as s]
[suricatta.core :as sc]
[buddy.core.codecs :as codecs]
[uxbox.config :as ucfg]
[uxbox.sql :as sql]
[uxbox.db :as db]
[uxbox.util.spec :as us]
[uxbox.services.core :as core]
[uxbox.util.time :as dt]
[uxbox.util.data :as data]
[uxbox.util.transit :as t]
[uxbox.util.blob :as blob]
[uxbox.util.uuid :as uuid]))
(:require
[clojure.spec.alpha :as s]
[promesa.core :as p]
[uxbox.db :as db]
[uxbox.services.core :as sv]
[uxbox.util.blob :as blob]
[uxbox.util.data :as data]
[uxbox.util.spec :as us]
[uxbox.util.time :as dt]
[uxbox.util.uuid :as uuid]))
(s/def ::version integer?)
(s/def ::key string?)
(s/def ::value any?)
(s/def ::user uuid?)
(defn decode-value
[{:keys [value] :as data}]
(if value
(assoc data :value (-> value blob/decode t/decode))
data))
(defn- decode-row
[{:keys [value] :as row}]
(when row
(cond-> row
value (assoc :value (blob/decode value)))))
;; --- Update KVStore
(s/def ::update-kvstore
(s/keys :req-un [::key ::value ::user ::version]))
(s/def ::user ::us/uuid)
(s/def ::key ::us/string)
(s/def ::value any?)
(defn update-kvstore
[conn {:keys [user key value version] :as data}]
(let [opts {:user user
:key key
:version version
:value (-> value t/encode blob/encode)}
sqlv (sql/update-kvstore opts)]
(some->> (sc/fetch-one conn sqlv)
(data/normalize-attrs)
(decode-value))))
(s/def ::upsert-kvstore
(s/keys :req-un [::key ::value ::user]))
(defmethod core/novelty :update-kvstore
[params]
(s/assert ::update-kvstore params)
(with-open [conn (db/connection)]
(sc/apply-atomic conn update-kvstore params)))
(sv/defmutation :upsert-kvstore
{:doc "Update or insert kvstore entry."
:spec ::upsert-kvstore}
[{:keys [key value user] :as params}]
(let [sql "insert into kvstore (key, value, user_id)
values ($1, $2, $3)
on conflict (user_id, key)
do update set value = $2"
val (blob/encode value)]
(-> (db/query-one db/pool [sql key val user])
(p/then' sv/constantly-nil))))
;; --- Retrieve KVStore
(s/def ::retrieve-kvstore
(s/def ::kvstore-entry
(s/keys :req-un [::key ::user]))
(defn retrieve-kvstore
[conn {:keys [user key] :as params}]
(let [sqlv (sql/retrieve-kvstore params)]
(some->> (sc/fetch-one conn sqlv)
(data/normalize-attrs)
(decode-value))))
(defmethod core/query :retrieve-kvstore
[params]
(s/assert ::retrieve-kvstore params)
(with-open [conn (db/connection)]
(retrieve-kvstore conn params)))
(sv/defquery :kvstore-entry
{:doc "Retrieve kvstore entry."
:spec ::kvstore-entry}
[{:keys [key user]}]
(let [sql "select kv.*
from kvstore as kv
where kv.user_id = $2
and kv.key = $1"]
(-> (db/query-one db/pool [sql key user])
(p/then' sv/raise-not-found-if-nil)
(p/then' decode-row))))
;; --- Delete KVStore
(s/def ::delete-kvstore
(s/keys :req-un [::key ::user]))
(defn delete-kvstore
[conn {:keys [user key] :as params}]
(let [sqlv (sql/delete-kvstore params)]
(pos? (sc/execute conn sqlv))))
(defmethod core/novelty :delete-kvstore
[params]
(s/assert ::delete-kvstore params)
(with-open [conn (db/connection)]
(sc/apply-atomic conn delete-kvstore params)))
(sv/defmutation :delete-kvstore
{:doc "Delete kvstore entry."
:spec ::delete-kvstore}
[{:keys [user key] :as params}]
(let [sql "delete from kvstore
where user_id = $2
and key = $1"]
(-> (db/query-one db/pool [sql key user])
(p/then' sv/constantly-nil))))

370
backend/src/uxbox/services/pages.clj
View file

@ -2,225 +2,221 @@
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.services.pages
(:require [clojure.spec.alpha :as s]
[suricatta.core :as sc]
[buddy.core.codecs :as codecs]
[uxbox.config :as ucfg]
[uxbox.sql :as sql]
[uxbox.db :as db]
[uxbox.util.spec :as us]
[uxbox.services.core :as core]
[uxbox.services.auth :as usauth]
[uxbox.util.time :as dt]
[uxbox.util.data :as data]
[uxbox.util.transit :as t]
[uxbox.util.blob :as blob]
[uxbox.util.uuid :as uuid]))
(:require
[clojure.spec.alpha :as s]
[promesa.core :as p]
[uxbox.db :as db]
[uxbox.util.spec :as us]
[uxbox.services.core :as sv]
[uxbox.util.time :as dt]
[uxbox.util.blob :as blob]
[uxbox.util.uuid :as uuid]))
(declare decode-page-data)
(declare decode-page-metadata)
(declare encode-data)
;; --- Helpers & Specs
(declare decode-row)
;; TODO: validate `:data` and `:metadata`
(s/def ::id ::us/uuid)
(s/def ::name ::us/string)
(s/def ::data any?)
(s/def ::user uuid?)
(s/def ::project uuid?)
(s/def ::user ::us/uuid)
(s/def ::project-id ::us/uuid)
(s/def ::metadata any?)
(s/def ::max integer?)
(s/def ::pinned boolean?)
(s/def ::since integer?)
;; --- Create Page
(defn create-page
[conn {:keys [id user project name data metadata] :as params}]
(let [opts {:id (or id (uuid/random))
:user user
:project project
:name name
:data (-> data t/encode blob/encode)
:metadata (-> metadata t/encode blob/encode)}
sqlv (sql/create-page opts)]
(->> (sc/fetch-one conn sqlv)
(data/normalize-attrs)
(decode-page-data)
(decode-page-metadata))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Queries
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- Query: Pages by Project
(s/def ::pages-by-project
(s/keys :req-un [::user ::project-id]))
(sv/defquery :pages-by-project
{:doc "List pages by project id."
:spec ::pages-by-project}
[{:keys [user project-id] :as params}]
(let [sql "select pg.*,
pg.data,
pg.metadata
from pages as pg
where pg.user_id = $2
and pg.project_id = $1
and pg.deleted_at is null
order by pg.created_at asc;"]
(-> (db/query db/pool [sql project-id user])
(p/then #(mapv decode-row %)))))
;; --- Query: Page History
;; (def ^:private page-history-sql
;; "select ph.*
;; from pages_history as ph
;; where ph.user_id = $1
;; and ph.page_id = $2
;; and ph.version < $3
;; order by ph.version desc
;; limit $4")
;; (defn get-page-history
;; [{:keys [id page-id user since max pinned]
;; :or {since Long/MAX_VALUE max 10}}]
;; (let [sqlv [page-history-sql user page-id since
;; (let [sqlv (sql/get-page-history {:user user
;; :page id
;; :since since
;; :max max
;; :pinned pinned})]
;; (->> (db/fetch conn sqlv)
;; ;; TODO
;; (map decode-row))))
;; (s/def ::max ::us/integer)
;; (s/def ::pinned ::us/boolean)
;; (s/def ::since ::us/integer)
;; (s/def ::page-history
;; (s/keys :req-un [::us/id ::user]
;; :opt-un [::max ::pinned ::since]))
;; (sv/defquery :page-history
;; {:doc "Retrieve page history."
;; :spec ::page-history}
;; [params]
;; (with-open [conn (db/connection)]
;; (get-page-history conn params)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Mutations
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- Mutation: Create Page
(s/def ::create-page
(s/keys :req-un [::data ::user ::project ::us/name ::metadata]
:opt-un [::us/id]))
(s/keys :req-un [::data ::user ::project-id ::name ::metadata]
:opt-un [::id]))
(defmethod core/novelty :create-page
[params]
(s/assert ::create-page params)
(with-open [conn (db/connection)]
(create-page conn params)))
(sv/defmutation :create-page
{:doc "Create a new page."
:spec ::create-page}
[{:keys [id user project-id name data metadata]}]
(let [sql "insert into pages (id, user_id, project_id, name, data, metadata)
values ($1, $2, $3, $4, $5, $6) returning *"
id (or id (uuid/next))
data (blob/encode data)
mdata (blob/encode metadata)]
(-> (db/query-one db/pool [sql id user project-id name data mdata])
(p/then' decode-row))))
;; --- Update Page
(defn update-page
[conn {:keys [id user project name
data version metadata] :as params}]
(let [opts {:id (or id (uuid/random))
:user user
:project project
:name name
:version version
:data (-> data t/encode blob/encode)
:metadata (-> metadata t/encode blob/encode)}
sqlv (sql/update-page opts)]
(some-> (sc/fetch-one conn sqlv)
(data/normalize-attrs)
(decode-page-data)
(decode-page-metadata))))
;; --- Mutation: Update Page
(s/def ::update-page
(s/merge ::create-page (s/keys :req-un [::us/version])))
(s/keys :req-un [::data ::user ::project-id ::name ::data ::metadata ::id]))
(defmethod core/novelty :update-page
[params]
(s/assert ::update-page params)
(with-open [conn (db/connection)]
(update-page conn params)))
(sv/defmutation :update-page
{:doc "Update an existing page."
:spec ::update-page}
[{:keys [id user project-id name data metadata]}]
(let [sql "update pages
set name = $1,
data = $2,
metadata = $3
where id = $4
and user_id = $5
and deleted_at is null
returning *"
data (blob/encode data)
mdata (blob/encode metadata)]
(-> (db/query-one db/pool [sql name data mdata id user])
(p/then' decode-row))))
;; --- Update Page Metadata
(defn update-page-metadata
[conn {:keys [id user project name
version metadata] :as params}]
(let [opts {:id (or id (uuid/random))
:user user
:project project
:name name
:version version
:metadata (-> metadata t/encode blob/encode)}
sqlv (sql/update-page-metadata opts)]
(some-> (sc/fetch-one conn sqlv)
(data/normalize-attrs)
(decode-page-data)
(decode-page-metadata))))
;; --- Mutation: Update Page Metadata
(s/def ::update-page-metadata
(s/keys :req-un [::user ::project ::us/name ::us/version ::metadata]
:opt-un [::us/id ::data]))
(s/keys :req-un [::data ::user ::project-id ::name ::metadata ::id]))
(defmethod core/novelty :update-page-metadata
[params]
(s/assert ::update-page-metadata params)
(with-open [conn (db/connection)]
(update-page-metadata conn params)))
(sv/defmutation :update-page-metadata
{:doc "Update an existing page."
:spec ::update-page-metadata}
[{:keys [id user project-id name metadata]}]
(let [sql "update pages
set name = $3,
metadata = $4
where id = $1
and user_id = $2
and deleted_at is null
returning *"
mdata (blob/encode metadata)]
(-> (db/query-one db/pool [sql id user name mdata])
(p/then' decode-row))))
;; --- Delete Page
(defn delete-page
[conn {:keys [id user] :as params}]
(let [sqlv (sql/delete-page {:id id :user user})]
(pos? (sc/execute conn sqlv))))
;; --- Mutation: Delete Page
(s/def ::delete-page
(s/keys :req-un [::user ::us/id]))
(s/keys :req-un [::user ::id]))
(defmethod core/novelty :delete-page
[params]
(s/assert ::delete-page params)
(with-open [conn (db/connection)]
(delete-page conn params)))
(sv/defmutation :delete-page
{:doc "Delete existing page."
:spec ::delete-page}
[{:keys [id user]}]
(let [sql "update pages
set deleted_at = clock_timestamp()
where id = $1
and user_id = $2
and deleted_at is null
returning id"]
(-> (db/query-one db/pool [sql id user])
(p/then sv/raise-not-found-if-nil)
(p/then sv/constantly-nil))))
;; --- List Pages by Project
;; ;; --- Update Page History
(defn get-pages-for-project
[conn project]
(let [sqlv (sql/get-pages-for-project {:project project})]
(->> (sc/fetch conn sqlv)
(map data/normalize-attrs)
(map decode-page-data)
(map decode-page-metadata))))
;; (defn update-page-history
;; [conn {:keys [user id label pinned]}]
;; (let [sqlv (sql/update-page-history {:user user
;; :id id
;; :label label
;; :pinned pinned})]
;; (some-> (db/fetch-one conn sqlv)
;; (decode-row))))
(defn get-pages-for-user-and-project
[conn {:keys [user project]}]
(let [sqlv (sql/get-pages-for-user-and-project
{:user user :project project})]
(->> (sc/fetch conn sqlv)
(map data/normalize-attrs)
(map decode-page-data)
(map decode-page-metadata))))
;; (s/def ::label ::us/string)
;; (s/def ::update-page-history
;; (s/keys :req-un [::user ::id ::pinned ::label]))
(s/def ::list-pages-by-project
(s/keys :req-un [::user ::project]))
(defmethod core/query :list-pages-by-project
[params]
(s/assert ::list-pages-by-project params)
(with-open [conn (db/connection)]
(get-pages-for-user-and-project conn params)))
;; --- Page History (Query)
(defn get-page-history
[conn {:keys [id user since max pinned]
:or {since Long/MAX_VALUE max 10}}]
(let [sqlv (sql/get-page-history {:user user
:page id
:since since
:max max
:pinned pinned})]
(->> (sc/fetch conn sqlv)
(map data/normalize-attrs)
(map decode-page-data))))
(s/def ::list-page-history
(s/keys :req-un [::us/id ::user]
:opt-un [::max ::pinned ::since]))
(defmethod core/query :list-page-history
[params]
(s/assert ::list-page-history params)
(with-open [conn (db/connection)]
(get-page-history conn params)))
;; --- Update Page History
(defn update-page-history
[conn {:keys [user id label pinned]}]
(let [sqlv (sql/update-page-history {:user user
:id id
:label label
:pinned pinned})]
(some-> (sc/fetch-one conn sqlv)
(data/normalize-attrs)
(decode-page-data))))
(s/def ::label string?)
(s/def ::update-page-history
(s/keys :req-un [::user ::us/id ::pinned ::label]))
(defmethod core/novelty :update-page-history
[params]
(s/assert ::update-page-history params)
(with-open [conn (db/connection)]
(update-page-history conn params)))
;; (sv/defmutation :update-page-history
;; {:doc "Update page history"
;; :spec ::update-page-history}
;; [params]
;; (with-open [conn (db/connection)]
;; (update-page-history conn params)))
;; --- Helpers
(defn- decode-page-metadata
[{:keys [metadata] :as result}]
(s/assert ::us/bytes metadata)
(merge result (when metadata
{:metadata (-> metadata blob/decode t/decode)})))
(defn- decode-row
[{:keys [data metadata] :as row}]
(when row
(cond-> row
data (assoc :data (blob/decode data))
metadata (assoc :metadata (blob/decode metadata)))))
(defn- decode-page-data
[{:keys [data] :as result}]
(s/assert ::us/bytes data)
(merge result (when data
{:data (-> data blob/decode t/decode)})))
;; select pg.* from pages as pg
;; where pg.id = :id
;; and pg.deleted_at is null;
(defn get-page-by-id
[conn id]
(s/assert ::us/id id)
(let [sqlv (sql/get-page-by-id {:id id})]
(some-> (sc/fetch-one conn sqlv)
(data/normalize-attrs)
(decode-page-data)
(decode-page-metadata))))
;; (defn get-page-by-id
;; [conn id]
;; (s/assert ::us/id id)
;; (let [sqlv (sql/get-page-by-id {:id id})]
;; (some-> (db/fetch-one conn sqlv)
;; (decode-row))))

212
backend/src/uxbox/services/projects.clj
View file

@ -2,142 +2,126 @@
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.services.projects
(:require [clojure.spec.alpha :as s]
[suricatta.core :as sc]
[buddy.core.codecs :as codecs]
[uxbox.config :as ucfg]
[uxbox.sql :as sql]
[uxbox.db :as db]
[uxbox.util.spec :as us]
[uxbox.services.core :as core]
[uxbox.services.pages :as pages]
[uxbox.util.data :as data]
[uxbox.util.transit :as t]
[uxbox.util.blob :as blob]
[uxbox.util.uuid :as uuid]))
(:require
[clojure.spec.alpha :as s]
[promesa.core :as p]
[uxbox.db :as db]
[uxbox.util.spec :as us]
[uxbox.services.core :as sv]
[uxbox.util.blob :as blob]
[uxbox.util.uuid :as uuid]))
(s/def ::token string?)
(s/def ::data string?)
(s/def ::user uuid?)
(s/def ::project uuid?)
;; --- Helpers & Specs
;; --- Create Project
(s/def ::id ::us/uuid)
(s/def ::name ::us/string)
(s/def ::token ::us/string)
(s/def ::user ::us/uuid)
(defn create-project
[conn {:keys [id user name] :as data}]
(let [id (or id (uuid/random))
sqlv (sql/create-project {:id id :user user :name name})]
(some-> (sc/fetch-one conn sqlv)
(data/normalize))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Queries
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- Query: Projects
(s/def ::projects-query
(s/keys :req-un [::user]))
(sv/defquery :projects
{:doc "Query all projects"
:spec ::projects-query}
[{:keys [user] :as params}]
(let [sql "select pr.*,
ps.token as share_token
from projects as pr
inner join project_shares as ps
on (ps.project = pr.id)
where pr.deleted_at is null
and pr.user_id = $1
order by pr.created_at asc"]
(db/query db/pool [sql user])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Mutations
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- Mutation: Create Project
(s/def ::create-project
(s/keys :req-un [::user ::us/name]
:opt-un [::us/id]))
(s/keys :req-un [::user ::name]
:opt-un [::id]))
(defmethod core/novelty :create-project
[params]
(s/assert ::create-project params)
(with-open [conn (db/connection)]
(create-project conn params)))
(sv/defmutation :create-project
{:doc "Create a project."
:spec ::create-project}
[{:keys [id user name] :as params}]
(let [id (or id (uuid/next))
sql "insert into projects (id, user_id, name)
values ($1, $2, $3) returning *"]
(db/query-one db/pool [sql id user name])))
;; --- Update Project
(defn- update-project
[conn {:keys [name version id user] :as data}]
(let [sqlv (sql/update-project {:name name
:version version
:id id
:user user})]
(some-> (sc/fetch-one conn sqlv)
(data/normalize))))
;; --- Mutation: Update Project
(s/def ::update-project
(s/merge ::create-project (s/keys :req-un [::us/version])))
(s/keys :req-un [::user ::name ::id]))
(defmethod core/novelty :update-project
[params]
(s/assert ::update-project params)
(with-open [conn (db/connection)]
(update-project conn params)))
(sv/defmutation :update-project
{:doc "Update project."
:spec ::update-project}
[{:keys [id name user] :as params}]
(let [sql "update projects
set name = $3
where id = $1
and user_id = $2
and deleted_at is null
returning *"]
(db/query-one db/pool [sql id user name])))
;; --- Delete Project
(defn- delete-project
[conn {:keys [id user] :as data}]
(let [sqlv (sql/delete-project {:id id :user user})]
(pos? (sc/execute conn sqlv))))
;; --- Mutation: Delete Project
(s/def ::delete-project
(s/keys :req-un [::us/id ::user]))
(s/keys :req-un [::id ::user]))
(defmethod core/novelty :delete-project
[params]
(s/assert ::delete-project params)
(with-open [conn (db/connection)]
(delete-project conn params)))
(sv/defmutation :delete-project
{:doc "Delete project"
:spec ::delete-project}
[{:keys [id user] :as params}]
(let [sql "update projects
set deleted_at = clock_timestamp()
where id = $1
and user_id = $2
and deleted_at is null
returning id"]
(-> (db/query-one db/pool [sql id user])
(p/then' sv/raise-not-found-if-nil)
(p/then' sv/constantly-nil))))
;; --- List Projects
(declare decode-page-metadata)
(declare decode-page-data)
(defn get-projects
[conn user]
(let [sqlv (sql/get-projects {:user user})]
(->> (sc/fetch conn sqlv)
(map data/normalize)
;; This is because the project comes with
;; the first page preloaded and it need
;; to be decoded.
(map decode-page-metadata)
(map decode-page-data))))
(defmethod core/query :list-projects
[{:keys [user] :as params}]
(s/assert ::user user)
(with-open [conn (db/connection)]
(get-projects conn user)))
;; --- Retrieve Project by share token
(defn- get-project-by-share-token
[conn token]
(let [sqlv (sql/get-project-by-share-token {:token token})
project (some-> (sc/fetch-one conn sqlv)
(data/normalize))]
(when-let [id (:id project)]
(let [pages (vec (pages/get-pages-for-project conn id))]
(assoc project :pages pages)))))
;; (defn- get-project-by-share-token
;; [conn token]
;; (let [sqlv (sql/get-project-by-share-token {:token token})
;; project (some-> (db/fetch-one conn sqlv)
;; (data/normalize))]
;; (when-let [id (:id project)]
;; (let [pages (vec (pages/get-pages-for-project conn id))]
;; (assoc project :pages pages)))))
(defmethod core/query :retrieve-project-by-share-token
[{:keys [token]}]
(s/assert ::token token)
(with-open [conn (db/connection)]
(get-project-by-share-token conn token)))
;; (defmethod core/query :retrieve-project-by-share-token
;; [{:keys [token]}]
;; (s/assert ::token token)
;; (with-open [conn (db/connection)]
;; (get-project-by-share-token conn token)))
;; --- Retrieve share tokens
(defn get-share-tokens-for-project
[conn project]
(s/assert ::project project)
(let [sqlv (sql/get-share-tokens-for-project {:project project})]
(->> (sc/fetch conn sqlv)
(map data/normalize))))
;; Helpers
(defn- decode-page-metadata
[{:keys [page-metadata] :as result}]
(merge result (when page-metadata
{:page-metadata (-> page-metadata blob/decode t/decode)})))
(defn- decode-page-data
[{:keys [page-data] :as result}]
(merge result (when page-data
{:page-data (-> page-data blob/decode t/decode)})))
;; (defn get-share-tokens-for-project
;; [conn project]
;; (s/assert ::project project)
;; (let [sqlv (sql/get-share-tokens-for-project {:project project})]
;; (db/fetch conn sqlv)))

144
backend/src/uxbox/services/svgparse.clj
View file

@ -13,87 +13,87 @@
(:import org.jsoup.Jsoup
java.io.InputStream))
(s/def ::content string?)
(s/def ::width number?)
(s/def ::height number?)
(s/def ::name string?)
(s/def ::view-box (s/coll-of number? :min-count 4 :max-count 4))
(s/def ::svg-entity (s/keys :req-un [::content ::width ::height ::view-box]
:opt-un [::name]))
;; (s/def ::content string?)
;; (s/def ::width number?)
;; (s/def ::height number?)
;; (s/def ::name string?)
;; (s/def ::view-box (s/coll-of number? :min-count 4 :max-count 4))
;; (s/def ::svg-entity (s/keys :req-un [::content ::width ::height ::view-box]
;; :opt-un [::name]))
;; --- Implementation
;; ;; --- Implementation
(defn- parse-double
[data]
{:pre [(string? data)]}
(Double/parseDouble data))
;; (defn- parse-double
;; [data]
;; {:pre [(string? data)]}
;; (Double/parseDouble data))
(defn- parse-viewbox
[data]
{:pre [(string? data)]}
(mapv parse-double (str/split data #"\s+")))
;; (defn- parse-viewbox
;; [data]
;; {:pre [(string? data)]}
;; (mapv parse-double (str/split data #"\s+")))
(defn- assoc-attr
[acc attr]
(let [key (.getKey attr)
val (.getValue attr)]
(case key
"width" (assoc acc :width (parse-double val))
"height" (assoc acc :height (parse-double val))
"viewbox" (assoc acc :view-box (parse-viewbox val))
"sodipodi:docname" (assoc acc :name val)
acc)))
;; (defn- assoc-attr
;; [acc attr]
;; (let [key (.getKey attr)
;; val (.getValue attr)]
;; (case key
;; "width" (assoc acc :width (parse-double val))
;; "height" (assoc acc :height (parse-double val))
;; "viewbox" (assoc acc :view-box (parse-viewbox val))
;; "sodipodi:docname" (assoc acc :name val)
;; acc)))
(defn- parse-attrs
[element]
(let [attrs (.attributes element)]
(reduce assoc-attr {} attrs)))
;; (defn- parse-attrs
;; [element]
;; (let [attrs (.attributes element)]
;; (reduce assoc-attr {} attrs)))
(defn- parse-svg
[data]
(try
(let [document (Jsoup/parse data)
svgelement (some-> (.body document)
(.getElementsByTag "svg")
(first))
innerxml (.html svgelement)
attrs (parse-attrs svgelement)]
(merge {:content innerxml} attrs))
(catch java.lang.IllegalArgumentException e
(ex/raise :type :validation
:code ::invalid-input
:message "Input does not seems to be a valid svg."))
(catch java.lang.NullPointerException e
(ex/raise :type :validation
:code ::invalid-input
:message "Input does not seems to be a valid svg."))
;; (defn- parse-svg
;; [data]
;; (try
;; (let [document (Jsoup/parse data)
;; svgelement (some-> (.body document)
;; (.getElementsByTag "svg")
;; (first))
;; innerxml (.html svgelement)
;; attrs (parse-attrs svgelement)]
;; (merge {:content innerxml} attrs))
;; (catch java.lang.IllegalArgumentException e
;; (ex/raise :type :validation
;; :code ::invalid-input
;; :message "Input does not seems to be a valid svg."))
;; (catch java.lang.NullPointerException e
;; (ex/raise :type :validation
;; :code ::invalid-input
;; :message "Input does not seems to be a valid svg."))
(catch org.jsoup.UncheckedIOException e
(ex/raise :type :validation
:code ::invalid-input
:message "Input does not seems to be a valid svg."))
;; (catch org.jsoup.UncheckedIOException e
;; (ex/raise :type :validation
;; :code ::invalid-input
;; :message "Input does not seems to be a valid svg."))
(catch Exception e
(ex/raise :code ::unexpected))))
;; (catch Exception e
;; (ex/raise :code ::unexpected))))
;; --- Public Api
;; ;; --- Public Api
(defn parse-string
"Parse SVG from a string."
[data]
{:pre [(string? data)]}
(let [result (parse-svg data)]
(if (s/valid? ::svg-entity result)
result
(ex/raise :type :validation
:code ::invalid-result
:message "The result does not conform valid svg entity."))))
;; (defn parse-string
;; "Parse SVG from a string."
;; [data]
;; {:pre [(string? data)]}
;; (let [result (parse-svg data)]
;; (if (s/valid? ::svg-entity result)
;; result
;; (ex/raise :type :validation
;; :code ::invalid-result
;; :message "The result does not conform valid svg entity."))))
(defn parse
[data]
(parse-string (slurp data)))
;; (defn parse
;; [data]
;; (parse-string (slurp data)))
(defmethod core/query :parse-svg
[{:keys [data] :as params}]
{:pre [(string? data)]}
(parse-string data))
;; (defmethod core/query :parse-svg
;; [{:keys [data] :as params}]
;; {:pre [(string? data)]}
;; (parse-string data))

565
backend/src/uxbox/services/users.clj
View file

@ -5,318 +5,377 @@
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.services.users
(:require [clojure.spec.alpha :as s]
[mount.core :as mount :refer (defstate)]
[suricatta.core :as sc]
[buddy.hashers :as hashers]
[buddy.sign.jwe :as jwe]
[uxbox.sql :as sql]
[uxbox.db :as db]
[uxbox.config :as cfg]
[uxbox.util.spec :as us]
[uxbox.emails :as emails]
[uxbox.services.core :as core]
[uxbox.util.transit :as t]
[uxbox.util.exceptions :as ex]
[uxbox.util.data :as data]
[uxbox.util.blob :as blob]
[uxbox.util.uuid :as uuid]
[uxbox.util.token :as token]))
(:require
[buddy.hashers :as hashers]
[clojure.spec.alpha :as s]
[datoteka.core :as fs]
[datoteka.storages :as ds]
[promesa.core :as p]
[promesa.exec :as px]
[uxbox.config :as cfg]
[uxbox.db :as db]
[uxbox.emails :as emails]
[uxbox.images :as images]
[uxbox.media :as media]
[uxbox.services.core :as sv]
[uxbox.util.blob :as blob]
[uxbox.util.exceptions :as ex]
[uxbox.util.spec :as us]
[uxbox.util.token :as token]
[uxbox.util.uuid :as uuid]
[vertx.core :as vc]))
(declare decode-user-data)
(declare trim-user-attrs)
(declare find-user-by-id)
(declare find-full-user-by-id)
(declare find-user-by-username-or-email)
;; --- Helpers & Specs
(s/def ::user uuid?)
(s/def ::fullname string?)
(declare decode-profile-row)
(declare strip-private-attrs)
(s/def ::email ::us/email)
(s/def ::fullname ::us/string)
(s/def ::metadata any?)
(s/def ::old-password string?)
(s/def ::path string?)
(s/def ::old-password ::us/string)
(s/def ::password ::us/string)
(s/def ::path ::us/string)
(s/def ::user ::us/uuid)
(s/def ::username ::us/string)
;; --- Retrieve User Profile (own)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Queries
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod core/query :retrieve-profile
;; --- Query: Profile (own)
(defn- resolve-thumbnail
[user]
(let [opts {:src :photo
:dst :photo
:size [100 100]
:quality 90
:format "jpg"}]
(-> (px/submit! #(images/populate-thumbnails user opts))
(sv/handle-on-context))))
(defn- get-profile
[conn id]
(let [sql "select * from users where id=$1 and deleted_at is null"]
(-> (db/query-one db/pool [sql id])
(p/then' decode-profile-row))))
(s/def ::profile
(s/keys :req-un [::user]))
(sv/defquery :profile
{:doc "Retrieve the user profile."
:spec ::profile}
[{:keys [user] :as params}]
(s/assert ::user user)
(with-open [conn (db/connection)]
(some-> (find-user-by-id conn (:user params))
(decode-user-data))))
(-> (get-profile db/pool user)
(p/then' strip-private-attrs)))
;; --- Update User Profile (own)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Mutations
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- check-profile-existence!
[conn {:keys [id username email]}]
(let [sqlv1 (sql/user-with-email-exists? {:id id :email email})
sqlv2 (sql/user-with-username-exists? {:id id :username username})]
(when (:val (sc/fetch-one conn sqlv1))
(ex/raise :type :validation
:code ::email-already-exists))
(when (:val (sc/fetch-one conn sqlv2))
(ex/raise :type :validation
:code ::username-already-exists))))
;; --- Mutation: Update Profile (own)
(defn- check-username-and-email!
[conn {:keys [id username email] :as params}]
(let [sql1 "select exists
(select * from users
where username = $2
and id != $1
) as val"
sql2 "select exists
(select * from users
where email = $2
and id != $1
) as val"]
(p/let [res1 (db/query-one conn [sql1 id username])
res2 (db/query-one conn [sql2 id email])]
(when (:val res1)
(ex/raise :type :validation
:code ::username-already-exists))
(when (:val res2)
(ex/raise :type :validation
:code ::email-already-exists))
params)))
(defn- update-profile
[conn {:keys [id username email fullname metadata] :as params}]
(check-profile-existence! conn params)
(let [metadata (-> metadata t/encode blob/encode)
sqlv (sql/update-profile {:username username
:fullname fullname
:metadata metadata
:email email
:id id})]
(some-> (sc/fetch-one conn sqlv)
(data/normalize-attrs)
(trim-user-attrs)
(decode-user-data)
(dissoc :password))))
(let [sql "update users
set username = $2,
email = $3,
fullname = $4,
metadata = $5
where id = $1
and deleted_at is null
returning *"]
(-> (db/query-one conn [sql id username email fullname (blob/encode metadata)])
(p/then' sv/raise-not-found-if-nil)
(p/then' decode-profile-row)
(p/then' strip-private-attrs))))
(s/def ::update-profile
(s/keys :req-un [::us/id ::us/username ::us/email ::fullname ::metadata]))
(s/keys :req-un [::id ::username ::email ::fullname ::metadata]))
(defmethod core/novelty :update-profile
(sv/defmutation :update-profile
{:doc "Update self profile."
:spec ::update-profile}
[params]
(s/assert ::update-profile params)
(with-open [conn (db/connection)]
(sc/apply-atomic conn update-profile params)))
(db/with-atomic [conn db/pool]
(-> (p/resolved params)
(p/then (partial check-username-and-email! conn))
(p/then (partial update-profile conn)))))
;; --- Update Password
;; --- Mutation: Update Password
(defn- validate-password
[conn {:keys [user old-password] :as params}]
(p/let [profile (get-profile conn user)]
(when-not (hashers/check old-password (:password profile))
(ex/raise :type :validation
:code ::old-password-not-match))
params))
(defn update-password
[conn {:keys [user password]}]
(let [password (hashers/encrypt password)
sqlv (sql/update-profile-password {:id user :password password})]
(pos? (sc/execute conn sqlv))))
(defn- validate-old-password
[conn {:keys [user old-password] :as params}]
(let [user (find-full-user-by-id conn user)]
(when-not (hashers/check old-password (:password user))
(ex/raise :type :validation
:code ::old-password-not-match))
params))
(let [sql "update users
set password = $2
where id = $1
and deleted_at is null
returning id"]
(-> (db/query-one conn [sql user password])
(p/then' sv/raise-not-found-if-nil)
(p/then' sv/constantly-nil))))
(s/def ::update-password
(s/keys :req-un [::user ::us/password ::old-password]))
(defmethod core/novelty :update-profile-password
(sv/defmutation :update-password
{:doc "Update self password."
:spec ::update-password}
[params]
(s/assert ::update-password params)
(with-open [conn (db/connection)]
(->> params
(validate-old-password conn)
(update-password conn))))
(db/with-atomic [conn db/pool]
(-> (p/resolved params)
(p/then (partial validate-password conn))
(p/then (partial update-password conn)))))
;; --- Update Photo
;; --- Mutation: Update Photo
(defn update-photo
[conn {:keys [user path]}]
(let [sqlv (sql/update-profile-photo {:id user :photo path})]
(pos? (sc/execute conn sqlv))))
(s/def ::file ::us/upload)
(s/def ::update-profile-photo
(s/keys :req-un [::user ::file]))
(s/def ::update-photo
(s/keys :req-un [::user ::path]))
(def valid-image-types?
#{"image/jpeg", "image/png", "image/webp"})
(defmethod core/novelty :update-profile-photo
[params]
(s/assert ::update-photo params)
(with-open [conn (db/connection)]
(update-photo conn params)))
(sv/defmutation :update-profile-photo
{:doc "Update profile photo."
:spec ::update-profile-photo}
[{:keys [user file] :as params}]
(letfn [(store-photo [{:keys [name path] :as upload}]
(let [filename (fs/name name)
storage media/images-storage]
(-> (ds/save storage filename path)
#_(sv/handle-on-context))))
;; --- Create User
(update-user-photo [path]
(let [sql "update users
set photo = $1
where id = $2
and deleted_at is null
returning *"]
(-> (db/query-one db/pool [sql (str path) user])
(p/then' sv/raise-not-found-if-nil)
(p/then' strip-private-attrs)
(p/then resolve-thumbnail))))]
(s/def ::create-user
(s/keys :req-un [::metadata ::fullname ::us/email ::us/password]
:opt-un [::us/id]))
(defn create-user
[conn {:keys [id username password email fullname metadata] :as data}]
(s/assert ::create-user data)
(let [id (or id (uuid/random))
metadata (-> metadata t/encode blob/encode)
password (hashers/encrypt password)
sqlv (sql/create-profile {:id id
:fullname fullname
:username username
:email email
:password password
:metadata metadata})]
(->> (sc/fetch-one conn sqlv)
(data/normalize-attrs)
(trim-user-attrs)
(decode-user-data))))
;; --- Register User
(defn- check-user-registred!
"Check if the user identified by username or by email
is already registred in the platform."
[conn {:keys [username email]}]
(let [sqlv1 (sql/user-with-email-exists? {:email email})
sqlv2 (sql/user-with-username-exists? {:username username})]
(when (:val (sc/fetch-one conn sqlv1))
(when-not (valid-image-types? (:mtype file))
(ex/raise :type :validation
:code ::email-already-exists))
(when (:val (sc/fetch-one conn sqlv2))
(ex/raise :type :validation
:code ::username-already-exists))))
:code :image-type-not-allowed
:hint "Seems like you are uploading an invalid image."))
(-> (store-photo file)
(p/then update-user-photo))))
(defn- register-user
;; --- Mutation: Register Profile
(def ^:private create-user-sql
"insert into users (id, fullname, username, email, password, metadata, photo)
values ($1, $2, $3, $4, $5, $6, '') returning *")
(defn- check-profile-existence!
[conn {:keys [username email] :as params}]
(let [sql "select exists
(select * from users
where username = $1
or email = $2
) as val"]
(-> (db/query-one conn [sql username email])
(p/then (fn [result]
(when (:val result)
(ex/raise :type :validation
:code ::username-or-email-already-exists))
params)))))
(defn- register-profile
"Create the user entry on the database with limited input
filling all the other fields with defaults."
[conn {:keys [username fullname email password] :as params}]
(check-user-registred! conn params)
(let [metadata (-> nil t/encode blob/encode)
(let [metadata (blob/encode {})
password (hashers/encrypt password)
sqlv (sql/create-profile {:id (uuid/random)
:fullname fullname
:username username
:email email
:password password
:metadata metadata})]
(sc/execute conn sqlv)
(emails/send! {:email/name :users/register
:email/to (:email params)
:email/priority :high
:name (:fullname params)})
nil))
sqlv [create-user-sql
(uuid/next)
fullname
username
email
password
metadata]]
(-> (db/query-one conn sqlv)
(p/then' decode-profile-row)
(p/then' strip-private-attrs)
#_(p/then (fn [profile]
(-> (emails/send! {::emails/id :users/register
::emails/to (:email params)
::emails/priority :high
:name (:fullname params)})
(p/then' (constantly profile))))))))
(s/def ::register
(s/keys :req-un [::us/username ::us/email ::us/password ::fullname]))
(s/def ::register-profile
(s/keys :req-un [::username ::email ::password ::fullname]))
(defmethod core/novelty :register-profile
(sv/defmutation :register-profile
{:doc "Register new user."
:spec ::register-profile}
[params]
(s/assert ::register params)
(if (= (:registration-enabled cfg/config) true)
(with-open [conn (db/connection)]
(sc/apply-atomic conn register-user params))
(ex/raise :type :validation
:code ::registration-disabled)))
(when-not (:registration-enabled cfg/config)
(ex/raise :type :restriction
:code :registration-disabled))
(db/with-atomic [conn db/pool]
(-> (p/resolved params)
(p/then (partial check-profile-existence! conn))
(p/then (partial register-profile conn)))))
;; --- Password Recover
(defn- recovery-token-exists?
"Checks if the token exists in the system. Just
return `true` or `false`."
[conn token]
(let [sqlv (sql/recovery-token-exists? {:token token})
result (sc/fetch-one conn sqlv)]
(:token_exists result)))
;; (defn- recovery-token-exists?
;; "Checks if the token exists in the system. Just
;; return `true` or `false`."
;; [conn token]
;; (let [sqlv (sql/recovery-token-exists? {:token token})
;; result (db/fetch-one conn sqlv)]
;; (:token_exists result)))
(defn- retrieve-user-for-recovery-token
"Retrieve a user id (uuid) for the given token. If
no user is found, an exception is raised."
[conn token]
(let [sqlv (sql/get-recovery-token {:token token})
data (sc/fetch-one conn sqlv)]
(or (:user data)
(ex/raise :type :validation
:code ::invalid-token))))
;; (defn- retrieve-user-for-recovery-token
;; "Retrieve a user id (uuid) for the given token. If
;; no user is found, an exception is raised."
;; [conn token]
;; (let [sqlv (sql/get-recovery-token {:token token})
;; data (db/fetch-one conn sqlv)]
;; (or (:user data)
;; (ex/raise :type :validation
;; :code ::invalid-token))))
(defn- mark-token-as-used
[conn token]
(let [sqlv (sql/mark-recovery-token-used {:token token})]
(pos? (sc/execute conn sqlv))))
;; (defn- mark-token-as-used
;; [conn token]
;; (let [sqlv (sql/mark-recovery-token-used {:token token})]
;; (pos? (db/execute conn sqlv))))
(defn- recover-password
"Given a token and password, resets the password
to corresponding user or raise an exception."
[conn {:keys [token password]}]
(let [user (retrieve-user-for-recovery-token conn token)]
(update-password conn {:user user :password password})
(mark-token-as-used conn token)
nil))
;; (defn- recover-password
;; "Given a token and password, resets the password
;; to corresponding user or raise an exception."
;; [conn {:keys [token password]}]
;; (let [user (retrieve-user-for-recovery-token conn token)]
;; (update-password conn {:user user :password password})
;; (mark-token-as-used conn token)
;; nil))
(defn- create-recovery-token
"Creates a new recovery token for specified user and return it."
[conn userid]
(let [token (token/random)
sqlv (sql/create-recovery-token {:user userid
:token token})]
(sc/execute conn sqlv)
token))
;; (defn- create-recovery-token
;; "Creates a new recovery token for specified user and return it."
;; [conn userid]
;; (let [token (token/random)
;; sqlv (sql/create-recovery-token {:user userid
;; :token token})]
;; (db/execute conn sqlv)
;; token))
(defn- retrieve-user-for-password-recovery
[conn username]
(let [user (find-user-by-username-or-email conn username)]
(when-not user
(ex/raise :type :validation :code ::user-does-not-exists))
user))
;; (defn- retrieve-user-for-password-recovery
;; [conn username]
;; (let [user (find-user-by-username-or-email conn username)]
;; (when-not user
;; (ex/raise :type :validation :code ::user-does-not-exists))
;; user))
(defn- request-password-recovery
"Creates a new recovery password token and sends it via email
to the correspondig to the given username or email address."
[conn username]
(let [user (retrieve-user-for-password-recovery conn username)
token (create-recovery-token conn (:id user))]
(emails/send! {:email/name :users/password-recovery
:email/to (:email user)
:name (:fullname user)
:token token})
token))
;; (defn- request-password-recovery
;; "Creates a new recovery password token and sends it via email
;; to the correspondig to the given username or email address."
;; [conn username]
;; (let [user (retrieve-user-for-password-recovery conn username)
;; token (create-recovery-token conn (:id user))]
;; (emails/send! {:email/name :users/password-recovery
;; :email/to (:email user)
;; :name (:fullname user)
;; :token token})
;; token))
(defmethod core/query :validate-profile-password-recovery-token
[{:keys [token]}]
(s/assert ::us/token token)
(with-open [conn (db/connection)]
(recovery-token-exists? conn token)))
;; (defmethod core/query :validate-profile-password-recovery-token
;; [{:keys [token]}]
;; (s/assert ::us/token token)
;; (with-open [conn (db/connection)]
;; (recovery-token-exists? conn token)))
(defmethod core/novelty :request-profile-password-recovery
[{:keys [username]}]
(s/assert ::us/username username)
(with-open [conn (db/connection)]
(sc/atomic conn
(request-password-recovery conn username))))
;; (defmethod core/novelty :request-profile-password-recovery
;; [{:keys [username]}]
;; (s/assert ::us/username username)
;; (with-open [conn (db/connection)]
;; (db/atomic conn
;; (request-password-recovery conn username))))
(s/def ::recover-password
(s/keys :req-un [::us/token ::us/password]))
;; (s/def ::recover-password
;; (s/keys :req-un [::us/token ::us/password]))
(defmethod core/novelty :recover-profile-password
[params]
(s/assert ::recover-password params)
(with-open [conn (db/connection)]
(sc/apply-atomic conn recover-password params)))
;; (defmethod core/novelty :recover-profile-password
;; [params]
;; (s/assert ::recover-password params)
;; (with-open [conn (db/connection)]
;; (db/apply-atomic conn recover-password params)))
;; --- Query Helpers
(defn find-full-user-by-id
"Find user by its id. This function is for internal
use only because it returns a lot of sensitive information.
If no user is found, `nil` is returned."
[conn id]
(let [sqlv (sql/get-profile {:id id})]
(some-> (sc/fetch-one conn sqlv)
(data/normalize-attrs))))
;; (defn find-full-user-by-id
;; "Find user by its id. This function is for internal
;; use only because it returns a lot of sensitive information.
;; If no user is found, `nil` is returned."
;; [conn id]
;; (let [sqlv (sql/get-profile {:id id})]
;; (some-> (db/fetch-one conn sqlv)
;; (data/normalize-attrs))))
(defn find-user-by-id
"Find user by its id. If no user is found, `nil` is returned."
[conn id]
(let [sqlv (sql/get-profile {:id id})]
(some-> (sc/fetch-one conn sqlv)
(data/normalize-attrs)
(trim-user-attrs)
(dissoc :password))))
;; (defn find-user-by-id
;; "Find user by its id. If no user is found, `nil` is returned."
;; [conn id]
;; (let [sqlv (sql/get-profile {:id id})]
;; (some-> (db/fetch-one conn sqlv)
;; (data/normalize-attrs)
;; (trim-user-attrs)
;; (dissoc :password))))
(defn find-user-by-username-or-email
"Finds a user in the database by username and email. If no
user is found, `nil` is returned."
[conn username]
(let [sqlv (sql/get-profile-by-username {:username username})]
(some-> (sc/fetch-one conn sqlv)
(data/normalize-attrs)
(trim-user-attrs))))
;; (defn find-user-by-username-or-email
;; "Finds a user in the database by username and email. If no
;; user is found, `nil` is returned."
;; [conn username]
;; (let [sqlv (sql/get-profile-by-username {:username username})]
;; (some-> (db/fetch-one conn sqlv)
;; (trim-user-attrs))))
;; --- Attrs Helpers
(defn- decode-user-data
[{:keys [metadata] :as result}]
(merge result (when metadata
{:metadata (-> metadata blob/decode t/decode)})))
(defn- decode-profile-row
[{:keys [metadata] :as row}]
(when row
(cond-> row
metadata (assoc :metadata (blob/decode metadata)))))
(defn trim-user-attrs
(defn strip-private-attrs
"Only selects a publicy visible user attrs."
[user]
(select-keys user [:id :username :fullname
:password :metadata :email
:created-at :photo]))
[profile]
(select-keys profile [:id :username :fullname :metadata
:email :created-at :photo]))

18
backend/src/uxbox/sql.clj
View file

@ -1,18 +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) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.sql
(:require [hugsql.core :as hugsql]))
(hugsql/def-sqlvec-fns "sql/projects.sql" {:quoting :ansi :fn-suffix ""})
(hugsql/def-sqlvec-fns "sql/pages.sql" {:quoting :ansi :fn-suffix ""})
(hugsql/def-sqlvec-fns "sql/users.sql" {:quoting :ansi :fn-suffix ""})
(hugsql/def-sqlvec-fns "sql/emails.sql" {:quoting :ansi :fn-suffix ""})
(hugsql/def-sqlvec-fns "sql/images.sql" {:quoting :ansi :fn-suffix ""})
(hugsql/def-sqlvec-fns "sql/icons.sql" {:quoting :ansi :fn-suffix ""})
(hugsql/def-sqlvec-fns "sql/kvstore.sql" {:quoting :ansi :fn-suffix ""})
(hugsql/def-sqlvec-fns "sql/workers.sql" {:quoting :ansi :fn-suffix ""})

90
backend/src/uxbox/util/blob.clj
View file

@ -7,15 +7,93 @@
(ns uxbox.util.blob
"A generic blob storage encoding. Mainly used for
page data, page options and txlog payload storage."
(:require [uxbox.util.snappy :as snappy]))
(:require [uxbox.util.transit :as t])
(:import
io.vertx.core.buffer.Buffer
java.io.ByteArrayInputStream
java.io.ByteArrayOutputStream
java.io.DataInputStream
java.io.DataOutputStream
org.xerial.snappy.Snappy))
(defprotocol IDataToBytes
(->bytes [data] "convert data to bytes"))
(extend-protocol IDataToBytes
(Class/forName "[B")
(->bytes [data] data)
Buffer
(->bytes [data] (.getBytes ^Buffer data))
;; org.jooq.JSONB
;; (->bytes [data] (->bytes (.toString data)))
String
(->bytes [data] (.getBytes ^String data "UTF-8")))
(defn str->bytes
"Convert string to byte array."
([^String s]
(str->bytes s "UTF-8"))
([^String s, ^String encoding]
(.getBytes s encoding)))
(defn bytes->str
"Convert byte array to String."
([^bytes data]
(bytes->str data "UTF-8"))
([^bytes data, ^String encoding]
(String. data encoding)))
(defn buffer
[^bytes data]
(Buffer/buffer data))
(defn encode-with-json
"A function used for encode data for transfer it to frontend."
([data] (encode-with-json data false))
([data verbose?]
(let [type (if verbose? :json-verbose :json)]
(-> (t/encode data {:type type})
(Buffer/buffer)))))
(defn decode-from-json
"A function used for parse data coming from frontend."
[data]
(-> (->bytes data)
(t/decode {:type :json})))
(defn encode
"Encode data into compressed blob."
"A function used for encode data for persist in the database."
[data]
(snappy/compress data))
(let [data (t/encode data {:type :json})
data-len (alength ^bytes data)
cdata (Snappy/compress ^bytes data)]
(with-open [^ByteArrayOutputStream baos (ByteArrayOutputStream. (+ (alength cdata) 2 4))
^DataOutputStream dos (DataOutputStream. baos)]
(.writeShort dos (short 1)) ;; version number
(.writeInt dos (int data-len))
(.write dos ^bytes cdata (int 0) (alength cdata))
(-> (.toByteArray baos)
(buffer)))))
(declare decode-v1)
(defn decode
"Decode blob into string."
[^bytes data]
(snappy/uncompress data))
"A function used for decode persisted blobs in the database."
[data]
(let [data (->bytes data)]
(with-open [bais (ByteArrayInputStream. data)
dis (DataInputStream. bais)]
(let [version (.readShort dis)
udata-len (.readInt dis)]
(when (not= version 1)
(throw (ex-info "unsupported version" {:version version})))
(decode-v1 data udata-len)))))
(defn- decode-v1
[data udata-len]
(let [^bytes output-ba (byte-array udata-len)]
(Snappy/uncompress data 6 (- (alength data) 6) output-ba 0)
(t/decode output-ba {:type :json})))

88
backend/src/uxbox/util/dispatcher.clj Normal file
View file

@ -0,0 +1,88 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.util.dispatcher
"A generic service dispatcher implementation."
(:refer-clojure :exclude [defmethod])
(:require
[clojure.spec.alpha :as s]
[promesa.core :as p]
[expound.alpha :as expound]
[sieppari.core :as sp]
[sieppari.context :as spx]
[uxbox.util.spec :as us]
[uxbox.util.exceptions :as ex])
(:import
java.util.Map
java.util.List
java.util.Map$Entry
java.util.HashMap))
(definterface IDispatcher
(^void add [key f metadata]))
(deftype Dispatcher [reg attr interceptors]
IDispatcher
(add [this key f metadata]
(.put ^Map reg key (Map/entry f metadata))
nil)
clojure.lang.IFn
(invoke [_ params]
(let [key (get params attr)
entry (.get ^Map reg key)]
(if (nil? entry)
(p/rejected (ex/error :type :not-found
:code :method-not-found
:hint "No method found for the current request."))
(let [f (.getKey ^Map$Entry entry)
m (.getValue ^Map$Entry entry)
d (p/deferred)]
(sp/execute (conj interceptors f)
(with-meta params m)
#(p/resolve! d %)
#(p/reject! d %))
d)))))
(defn dispatcher?
[v]
(instance? Dispatcher v))
(defmacro defservice
[sname {:keys [dispatch-by interceptors]}]
`(defonce ~sname (Dispatcher. (HashMap.)
~dispatch-by
~interceptors)))
(defmacro defmethod
[sname key metadata args & rest]
(s/assert symbol? sname)
(s/assert keyword? key)
(s/assert map? metadata)
(s/assert vector? args)
(let [f `(fn ~args ~@rest)]
`(do
(s/assert dispatcher? ~sname)
(.add ~sname ~key ~f ~metadata)
~sname)))
(def spec-interceptor
"An interceptor that conforms the request with the user provided
spec."
{:enter (fn [{:keys [request] :as data}]
(let [{:keys [spec]} (meta request)]
(if spec
(let [result (s/conform spec request)]
(if (not= result ::s/invalid)
(assoc data :request result)
(let [data (s/explain-data spec request)]
(ex/raise :type :validation
:code :spec-validation
:explain (with-out-str
(expound/printer data))
:data data))))
data)))})

103
backend/src/uxbox/util/emails.clj Normal file
View file

@ -0,0 +1,103 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.util.emails
(:require
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[instaparse.core :as insta]
[uxbox.util.exceptions :as ex]
[uxbox.util.spec :as us]
[uxbox.util.template :as tmpl]))
;; --- Impl.
(def ^:private grammar
(str "message = part*"
"part = begin header body end; "
"header = tag* eol; "
"tag = space keyword; "
"body = line*; "
"begin = #'--\\s+begin\\s+'; "
"end = #'--\\s+end\\s*' eol*; "
"keyword = #':[\\w\\-]+'; "
"space = #'\\s*'; "
"line = #'.*\\n'; "
"eol = ('\\n' | '\\r\\n'); "))
(def ^:private parse-fn (insta/parser grammar))
(def ^:private email-path "emails/%(lang)s/%(id)s.mustache")
(defn- parse-template
[content]
(loop [state {}
parts (drop 1 (parse-fn content))]
(if-let [[_ _ header body] (first parts)]
(let [type (get-in header [1 2 1])
type (keyword (str/slice type 1))
content (apply str (map second (rest body)))]
(recur (assoc state type (str/trim content " \n"))
(rest parts)))
state)))
(s/def ::subject ::us/string)
(s/def ::body-text ::us/string)
(s/def ::body-html ::us/string)
(s/def ::parsed-email
(s/keys :req-un [::subject ::body-html ::body-html]))
(defn- build-base-email
[data context]
(when-not (s/valid? ::parsed-email data)
(ex/raise :type :internal
:code :template-parse-error
:hint "Seems like the email template has invalid data."
:contex data))
{:subject (:subject data)
:body [:alternatives
{:type "text/plain; charset=utf-8"
:contex (:body-text data)}
{:type "text/html; charset=utf-8"
:contex (:body-html data)}]})
(defn- impl-build-email
[id context]
(let [lang (:lang context :en)
path (str/format email-path {:id (name id) :lang (name lang)})]
(-> (tmpl/render path context)
(parse-template)
(build-base-email context))))
;; --- Public API
(s/def ::priority #{:high :low})
(s/def ::to ::us/email)
(s/def ::from ::us/email)
(s/def ::reply-to ::us/email)
(s/def ::lang ::us/string)
(s/def ::context
(s/keys :req-un [::to]
:opt-un [::reply-to ::from ::lang ::priority]))
(defn build
([id] (build id {}))
([id extra-context]
(s/assert keyword? id)
(fn [context]
(s/assert ::context context)
(let [context (merge extra-context context)
email (impl-build-email id context)]
(when-not email
(ex/raise :type :internal
:code :email-template-does-not-exists
:hint "seems like the template is wrong or does not exists."
::id id))
(cond-> (assoc email :id id)
(:from context) (assoc :from (:from context))
(:reply-to context) (assoc :reply-to (:reply-to context)))))))

104
backend/src/uxbox/util/migrations.clj Normal file
View file

@ -0,0 +1,104 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.util.migrations
(:require
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[promesa.core :as p]
[uxbox.util.pgsql :as pg]))
(s/def ::name string?)
(s/def ::step (s/keys :req-un [::name ::desc ::fn]))
(s/def ::steps (s/every ::step :kind vector?))
(s/def ::migrations
(s/keys :req-un [::name ::steps]))
;; --- Implementation
(defn- registered?
"Check if concrete migration is already registred."
[pool modname stepname]
(let [sql "select * from migrations where module=$1 and step=$2"]
(-> (pg/query pool [sql modname stepname])
(p/then' (fn [rows]
(pos? (count rows)))))))
(defn- register!
"Register a concrete migration into local migrations database."
[pool modname stepname]
(let [sql "insert into migrations (module, step) values ($1, $2)"]
(-> (pg/query pool [sql modname stepname])
(p/then' (constantly nil)))))
(defn- setup!
"Initialize the database if it is not initialized."
[pool]
(let [sql (str "create table if not exists migrations ("
" module text,"
" step text,"
" created_at timestamp DEFAULT current_timestamp,"
" unique(module, step)"
");")]
(-> (pg/query pool sql)
(p/then' (constantly nil)))))
(defn- impl-migrate-single
[pool modname {:keys [name] :as migration}]
(letfn [(execute []
(p/do! (register! pool modname name)
((:fn migration) pool)))]
(-> (registered? pool modname (:name migration))
(p/then (fn [registered?]
(when-not registered?
(println (str/format "applying migration - %s: %s" modname name))
(execute)))))))
(defn- impl-migrate
[pool migrations {:keys [fake] :or {fake false}}]
(s/assert ::migrations migrations)
(let [mname (:name migrations)
steps (:steps migrations)]
;; (println (str/format "Applying migrations for `%s`:" mname))
(pg/with-atomic [conn pool]
(p/run! #(impl-migrate-single conn mname %) steps))))
(defprotocol IMigrationContext
(-migrate [_ migration options]))
;; --- Public Api
(defn context
"Create new instance of migration context."
([pool] (context pool nil))
([pool opts]
@(setup! pool)
(reify
java.lang.AutoCloseable
(close [_] #_(.close pool))
IMigrationContext
(-migrate [_ migration options]
(impl-migrate pool migration options)))))
(defn migrate
"Main entry point for apply a migration."
([ctx migrations]
(migrate ctx migrations nil))
([ctx migrations options]
(-migrate ctx migrations options)))
(defn resource
"Helper for setup migration functions
just using a simple path to sql file
located in the class path."
[path]
(fn [pool]
(let [sql (slurp (io/resource path))]
(-> (pg/query pool sql)
(p/then' (constantly true))))))

150
backend/src/uxbox/util/pgsql.clj Normal file
View file

@ -0,0 +1,150 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.util.pgsql
"Asynchronous posgresql client."
(:require
[promesa.core :as p])
(:import
clojure.lang.IDeref
java.util.function.Supplier
java.lang.ThreadLocal
io.vertx.core.Vertx
io.vertx.core.Handler
io.vertx.core.AsyncResult
io.vertx.core.buffer.Buffer
io.vertx.pgclient.PgPool
io.vertx.sqlclient.impl.ArrayTuple
io.vertx.sqlclient.RowSet
io.vertx.sqlclient.PoolOptions))
(declare impl-execute)
(declare impl-query)
(declare impl-handler)
(declare impl-transact)
(declare seqable->tuple)
;; --- Public Api
(defn vertx?
[v]
(instance? Vertx v))
(defn pool?
[v]
(instance? PgPool v))
(defn bytes->buffer
[data]
(Buffer/buffer ^bytes data))
(defn pool
([uri] (pool uri {}))
([uri {:keys [system max-size] :or {max-size 5}}]
(let [^PoolOptions poptions (PoolOptions.)]
(when max-size (.setMaxSize poptions max-size))
(if (vertx? system)
(PgPool/pool ^Vertx system ^String uri poptions)
(PgPool/pool ^String uri poptions)))))
(defn tl-pool
"Thread local based connection pool."
([uri] (tl-pool uri {}))
([uri options]
(let [state (ThreadLocal/withInitial (reify Supplier
(get [_]
(pool uri options))))]
(reify IDeref
(deref [_]
(.get state))))))
(defn query
([conn sqlv] (query conn sqlv {}))
([conn sqlv opts]
(cond
(vector? sqlv)
(impl-query conn (first sqlv) (rest sqlv) opts)
(string? sqlv)
(impl-query conn sqlv nil opts)
:else
(throw (ex-info "Invalid arguments" {:sqlv sqlv})))))
(defn query-one
[& args]
(p/map first (apply query args)))
(defn row->map
[row]
(reduce (fn [acc index]
(let [cname (.getColumnName row index)]
(assoc acc cname (.getValue row index))))
{}
(range (.size row))))
(defmacro with-atomic
[[bsym psym] & body]
`(impl-transact ~psym (fn [c#] (let [~bsym c#] ~@body))))
;; --- Implementation
(defn- seqable->tuple
[v]
(let [res (ArrayTuple. (count v))]
(run! #(.addValue res %) v)
res))
(defn- impl-handler
[resolve reject]
(reify Handler
(handle [_ ar]
(if (.failed ar)
(reject (.cause ar))
(resolve (.result ar))))))
(defn- impl-execute
[conn sql params]
(if (seq params)
(p/create #(.preparedQuery conn sql (seqable->tuple params) (impl-handler %1 %2)))
(p/create #(.query conn sql (impl-handler %1 %2)))))
(defn- impl-query
[conn sql params {:keys [xfm] :as opts}]
(let [conn (if (instance? IDeref conn) @conn conn)]
(->> (impl-execute conn sql params)
(p/map (fn [rows]
(if xfm
(into [] xfm rows)
(into [] (map vec) rows)))))))
(defn impl-transact
[pool f]
(let [pool (if (instance? IDeref pool) @pool pool)]
(letfn [(commit [tx]
(p/create #(.commit tx (impl-handler %1 %2))))
(rollback [tx]
(p/create #(.rollback tx (impl-handler %1 %2))))
(on-connect [conn]
(let [tx (.begin conn)
df (p/deferred)]
(-> (f conn)
(p/finally (fn [v e]
(if e
(-> (rollback tx)
(p/finally (fn [& args]
(.close conn)
(p/reject! df e))))
(-> (commit tx)
(p/finally (fn [_ e']
(.close conn)
(if e'
(p/reject! df e')
(p/resolve! df v)))))))))
df))]
(-> (p/create #(.getConnection pool (impl-handler %1 %2)))
(p/bind on-connect)))))

139
backend/src/uxbox/util/quartz.clj
View file

@ -1,139 +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) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.util.quartz
"A lightweight abstraction layer for quartz job scheduling library."
(:import java.util.Properties
org.quartz.Scheduler
org.quartz.SchedulerException
org.quartz.impl.StdSchedulerFactory
org.quartz.Job
org.quartz.JobBuilder
org.quartz.JobDataMap
org.quartz.JobExecutionContext
org.quartz.TriggerBuilder
org.quartz.CronScheduleBuilder
org.quartz.SimpleScheduleBuilder
org.quartz.PersistJobDataAfterExecution
org.quartz.DisallowConcurrentExecution))
;; --- Implementation
(defn- map->props
[data]
(let [p (Properties.)]
(run! (fn [[k v]] (.setProperty p (name k) (str v))) (seq data))
p))
(deftype JobImpl []
Job
(execute [_ context]
(let [^JobDataMap data (.. context getJobDetail getJobDataMap)
args (.get data "arguments")
state (.get data "state")
callable (.get data "callable")]
(if state
(apply callable state args)
(apply callable args)))))
(defn- resolve-var
[sym]
(let [ns (symbol (namespace sym))
func (symbol (name sym))]
(require ns)
(resolve func)))
(defn- build-trigger
[opts]
(let [repeat? (::repeat? opts true)
interval (::interval opts 1000)
cron (::cron opts)
group (::group opts "uxbox")
schdl (if cron
(CronScheduleBuilder/cronSchedule cron)
(let [schdl (SimpleScheduleBuilder/simpleSchedule)
schdl (if (number? repeat?)
(.withRepeatCount schdl repeat?)
(.repeatForever schdl))]
(.withIntervalInMilliseconds schdl interval)))
name (str (:name opts) "-trigger")
bldr (doto (TriggerBuilder/newTrigger)
(.startNow)
(.withIdentity name group)
(.withSchedule schdl))]
(.build bldr)))
(defn- build-job-detail
[fvar args]
(let [opts (meta fvar)
state (::state opts)
group (::group opts "uxbox")
name (str (:name opts))
data {"callable" @fvar
"arguments" (into [] args)
"state" (if state (atom state) nil)}
bldr (doto (JobBuilder/newJob JobImpl)
(.storeDurably false)
(.usingJobData (JobDataMap. data))
(.withIdentity name group))]
(.build bldr)))
(defn- make-scheduler-props
[{:keys [name daemon? threads thread-priority]
:or {name "uxbox-scheduler"
daemon? true
threads 1
thread-priority Thread/MIN_PRIORITY}}]
(map->props
{"org.quartz.threadPool.threadCount" threads
"org.quartz.threadPool.threadPriority" thread-priority
"org.quartz.threadPool.makeThreadsDaemons" (if daemon? "true" "false")
"org.quartz.scheduler.instanceName" name
"org.quartz.scheduler.makeSchedulerThreadDaemon" (if daemon? "true" "false")}))
;; --- Public Api
(defn scheduler
"Create a new scheduler instance."
([] (scheduler nil))
([opts]
(let [props (make-scheduler-props opts)
factory (StdSchedulerFactory. props)]
(.getScheduler factory))))
(declare schedule!)
(defn start!
([schd]
(start! schd nil))
([schd {:keys [delay search-on]}]
;; Start the scheduler
(if (number? delay)
(.startDelayed schd (int delay))
(.start schd))
(when (coll? search-on)
(run! (fn [ns]
(require ns)
(doseq [v (vals (ns-publics ns))]
(when (::job (meta v))
(schedule! schd v))))
search-on))
schd))
(defn stop!
[scheduler]
(.shutdown ^Scheduler scheduler true))
;; TODO: add proper handling of `:delay` option that should allow
;; execute a task firstly delayed until some milliseconds or at certain time.
(defn schedule!
[schd f & args]
(let [vf (if (symbol? f) (resolve-var f) f)
job (build-job-detail vf args)
trigger (build-trigger (meta vf))]
(.scheduleJob ^Scheduler schd job trigger)))

28
backend/src/uxbox/util/snappy.clj
View file

@ -2,30 +2,28 @@
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.util.snappy
"A lightweight abstraction layer for snappy compression library."
(:require [buddy.core.codecs :as codecs])
(:import org.xerial.snappy.Snappy
org.xerial.snappy.SnappyFramedInputStream
org.xerial.snappy.SnappyFramedOutputStream
java.io.OutputStream
java.io.InputStream))
(:import
java.io.ByteArrayInputStream
java.io.ByteArrayOutputStream
java.io.InputStream
java.io.OutputStream
org.xerial.snappy.Snappy
org.xerial.snappy.SnappyFramedInputStream
org.xerial.snappy.SnappyFramedOutputStream))
(defn compress
"Compress data unsing snappy compression algorithm."
[data]
(-> (codecs/to-bytes data)
(Snappy/compress)))
[^bytes data]
(Snappy/compress data))
(defn uncompress
"Uncompress data using snappy compression algorithm."
[data]
(-> (codecs/to-bytes data)
(Snappy/uncompress)))
[^bytes data]
(Snappy/uncompress data))
(defn input-stream
"Create a Snappy framed input stream."

33
backend/src/uxbox/util/spec.clj
View file

@ -6,9 +6,11 @@
(ns uxbox.util.spec
(:refer-clojure :exclude [keyword uuid vector boolean map set])
(:require [clojure.spec.alpha :as s]
[cuerdas.core :as str]
[uxbox.util.exceptions :as ex])
(:require
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[datoteka.core :as fs]
[uxbox.util.exceptions :as ex])
(:import java.time.Instant))
;; --- Constants
@ -95,8 +97,16 @@
[v]
(if v "true" "false"))
(defn path-conformer
[v]
(cond
(string? v) (fs/path v)
(fs/path? v) v
:else ::s/invalid))
;; --- Default Specs
(s/def ::string string?)
(s/def ::integer (s/conformer integer-conformer str))
(s/def ::uuid (s/conformer uuid-conformer str))
(s/def ::boolean (s/conformer boolean-conformer boolean-unformer))
@ -104,14 +114,19 @@
(s/def ::negative neg?)
(s/def ::uploaded-file any?)
(s/def ::bytes bytes?)
(s/def ::path path?)
(s/def ::email email?)
(s/def ::file any?)
(s/def ::name ::string)
(s/def ::path (s/conformer path-conformer str))
(s/def ::size ::integer)
(s/def ::mtype ::string)
(s/def ::upload
(s/keys :req-un [::name ::path ::size ::mtype]))
;; TODO: deprecated
(s/def ::id ::uuid)
(s/def ::name string?)
(s/def ::username string?)
(s/def ::password string?)
(s/def ::version integer?)
(s/def ::token string?)
(s/def ::username ::string)
(s/def ::password ::string)
(s/def ::token ::string)

251
backend/src/uxbox/util/sql.clj Normal file
View file

@ -0,0 +1,251 @@
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;; * Redistributions of source code must retain the above copyright notice, this
;; list of conditions and the following disclaimer.
;;
;; * Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(ns uxbox.util.sql
"A composable sql helpers."
(:refer-clojure :exclude [test update set format])
(:require [clojure.core :as c]))
(defn- query?
[m]
(::query m))
(defn select
[]
{::query true
::type ::select})
(defn update
([table]
(update table nil))
([table alias]
{::query true
::type ::update
::table [table alias]}))
(defn delete
[]
{::query true
::type ::delete})
(defn insert
[table fields]
{::query true
::table table
::fields fields
::type ::insert})
(defn from
([m name]
(from m name nil))
([m name alias]
{:pre [(query? m)]}
(c/update m ::from (fnil conj []) [name alias])))
(defn field
([m name]
(field m name nil))
([m name alias]
(c/update m ::fields (fnil conj []) [name alias])))
(defn fields
[m & fields]
(reduce (fn [acc item]
(if (vector? item)
(apply field acc item)
(field acc item)))
m
fields))
(defn limit
[m n]
{:pre [(= (::type m) ::select)
(query? m)]}
(assoc m ::limit n))
(defn offset
[m n]
{:pre [(= (::type m) ::select)
(query? m)]}
(assoc m ::offset n))
(defn- join*
[m type table alias condition]
{:pre [(= (::type m) ::select)
(query? m)]}
(c/update m ::joins (fnil conj [])
{:type type
:name table
:alias alias
:condition condition}))
(defn join
([m table condition]
(join m table nil condition))
([m table alias condition]
{:pre [(= (::type m) ::select)
(query? m)]}
(join* m :inner table alias condition)))
(defn left-join
([m table condition]
(left-join m table nil condition))
([m table alias condition]
{:pre [(= (::type m) ::select)
(query? m)]}
(join* m :left table alias condition)))
(defn where
[m condition & params]
{:pre [(query? m)]}
(-> m
(c/update ::where (fnil conj []) condition)
(cond-> (seq params)
(c/update ::params (fnil into []) params))))
(defn set
[m field value]
{:pre [(query? m)]}
(-> m
(c/update ::assignations (fnil conj []) field)
(c/update ::params (fnil conj []) value)))
(defn values
[m values]
{:pre [(query? m)]}
(assoc ::values values))
(defn raw
[m sql & params]
(-> m
(c/update ::raw (fnil conj []) sql)
(c/update ::params (fnil into []) params)))
(defmulti format ::type)
(defn fmt
[m]
(into [(format m)] (::params m)))
;; --- Formating
(defn- format-fields
[fields]
(letfn [(transform [[name alias]]
(if (string? alias)
(str name " " alias)
name))]
(apply str (->> (map transform fields)
(interpose ", ")))))
(defn- format-join
[{:keys [type name alias condition]}]
(str (case type
:inner "INNER JOIN "
:left "LEFT JOIN ")
(if alias
(str name " " alias)
name)
" ON (" condition ")"))
(defn- format-joins
[clauses]
(apply str (->> (map format-join clauses)
(interpose " "))))
(defn- format-where
[conditions]
(when (seq conditions)
(str "WHERE (" (apply str (interpose ") AND (" conditions)) ")")))
(defn- format-assignations
[assignations]
(apply str (->> (map #(str % " = ?") assignations)
(interpose ", "))))
(defn- format-raw
[items]
(when (seq items)
(apply str (interpose " " items))))
(defmethod format ::select
[{:keys [::fields ::from ::joins ::where]}]
(str "SELECT "
(format-fields fields)
" FROM "
(format-fields from)
" "
(format-joins joins)
" "
(format-where where)))
(defmethod format ::update
[{:keys [::table ::assignations ::where]}]
(str "UPDATE "
(format-fields [table])
" SET "
(format-assignations assignations)
" "
(format-where where)))
(defmethod format ::delete
[{:keys [::from ::where]}]
(str "DELETE FROM "
(format-fields from)
" "
(format-where where)))
(defmethod format ::insert
[{:keys [::table ::fields ::values ::raw]}]
(let [fsize (count fields)
pholder (str "(" (apply str (->> (map (constantly "?") fields)
(interpose ", "))) ")")]
(str "INSERT INTO " table "(" (apply str (interpose ", " fields)) ")"
" VALUES " (apply str (->> (map (constantly pholder) values)
(interpose ", ")))
" "
(format-raw raw))))
;; (defn test-update
;; []
;; (-> (update "users" "u")
;; (set "u.username" "foobar")
;; (set "u.email" "niwi@niwi.nz")
;; (where "u.id = ? AND u.deleted_at IS null" 555)))
;; (defn test-delete
;; []
;; (-> (delete)
;; (from "users" "u")
;; (where "u.id = ? AND u.deleted_at IS null" 555)))
;; (defn test-insert
;; []
;; (-> (insert "users" ["id", "username"])
;; (values [[1 "niwinz"] [2 "niwibe"]])
;; (raw "RETURNING *")))

3
backend/src/uxbox/util/struct.clj
View file

@ -1,3 +0,0 @@
(ns uxbox.util.struct
(:refer-clojure :exclude [keyword uuid vector boolean long map set])
(:require [struct.core :as st]))

88
backend/src/uxbox/util/template.clj
View file

@ -2,55 +2,63 @@
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2016-2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.util.template
"A lightweight abstraction over mustache.java template engine.
The documentation can be found: http://mustache.github.io/mustache.5.html"
(:require [clojure.walk :as walk]
[clojure.java.io :as io])
(:import java.io.StringReader
java.io.StringWriter
java.util.HashMap
com.github.mustachejava.DefaultMustacheFactory
com.github.mustachejava.Mustache))
(:require
[clojure.walk :as walk]
[clojure.java.io :as io]
[uxbox.util.exceptions :as ex])
(:import
java.io.StringReader
java.util.HashMap
java.util.function.Function;
com.github.mustachejava.DefaultMustacheFactory
com.github.mustachejava.Mustache))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Impl
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^DefaultMustacheFactory +mustache-factory+ (DefaultMustacheFactory.))
(def ^:private
^DefaultMustacheFactory
+mustache-factory+ (DefaultMustacheFactory.))
(defn- adapt-context
[data]
(walk/postwalk (fn [x]
(cond
(instance? clojure.lang.Named x)
(name x)
(defprotocol ITemplate
"A basic template rendering abstraction."
(-render [template context]))
(instance? clojure.lang.MapEntry x)
x
(extend-type Mustache
ITemplate
(-render [template context]
(with-out-str
(let [scope (HashMap. (walk/stringify-keys context))]
(.execute template *out* scope)))))
(fn? x)
(reify Function
(apply [this content]
(x content)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Public Api
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(or (vector? x) (list? x))
(java.util.ArrayList. x)
(map? x)
(java.util.HashMap. x)
(set? x)
(java.util.HashSet. x)
:else
x))
data))
(defn render-string
"Render string as mustache template."
([^String template]
(render-string template {}))
([^String template context]
(let [reader (StringReader. template)
template (.compile +mustache-factory+ reader "example")]
(-render template context))))
(defn render
"Load a file from the class path and render
it using mustache template."
([^String path]
(render path {}))
([^String path context]
(render-string (slurp (io/resource path)) context)))
[path context]
(try
(let [context (adapt-context context)
template (.compile +mustache-factory+ path)]
(with-out-str
(let [scope (HashMap. (walk/stringify-keys context))]
(.execute ^Mustache template *out* scope))))
(catch Exception cause
(ex/raise :type :internal
:code :template-render-error
:cause cause))))

46
backend/src/uxbox/util/time.clj
View file

@ -5,10 +5,12 @@
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.util.time
(:require [suricatta.proto :as sp]
[suricatta.impl :as si]
[cognitect.transit :as t])
(:require
#_[suricatta.proto :as sp]
#_[suricatta.impl :as si]
[cognitect.transit :as t])
(:import java.time.Instant
java.time.OffsetDateTime
java.sql.Timestamp))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -17,11 +19,16 @@
(declare from-string)
(def ^:private write-handler
(def ^:private instant-write-handler
(t/write-handler
(constantly "m")
(fn [v] (str (.toEpochMilli v)))))
(def ^:private offset-datetime-write-handler
(t/write-handler
(constantly "m")
(fn [v] (str (.toEpochMilli (.toInstant v))))))
(def ^:private read-handler
(t/read-handler
(fn [v] (-> (Long/parseLong v)
@ -31,25 +38,26 @@
{"m" read-handler})
(def +write-handlers+
{Instant write-handler})
{Instant instant-write-handler
OffsetDateTime offset-datetime-write-handler})
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Persistence Layer Conversions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;; Persistence Layer Conversions
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(extend-protocol sp/IParam
Instant
(-param [self ctx]
(si/sql->param "{0}::timestamptz" (.toString self))))
;; (extend-protocol sp/IParam
;; Instant
;; (-param [self ctx]
;; (si/sql->param "{0}::timestamptz" (.toString self))))
(extend-protocol sp/ISQLType
Timestamp
(-convert [self]
(.toInstant self))
;; (extend-protocol sp/ISQLType
;; Timestamp
;; (-convert [self]
;; (.toInstant self))
java.time.OffsetDateTime
(-convert [self]
(.toInstant self)))
;; java.time.OffsetDateTime
;; (-convert [self]
;; (.toInstant self)))
(defmethod print-method Instant
[mv ^java.io.Writer writer]

35
backend/src/uxbox/util/transit.clj
View file

@ -2,15 +2,19 @@
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.util.transit
(:require [cognitect.transit :as t]
[clojure.java.io :as io]
[uxbox.util.time :as dt])
(:import java.io.ByteArrayInputStream
java.io.ByteArrayOutputStream
java.io.File))
(:require
[cognitect.transit :as t]
[clojure.java.io :as io]
[uxbox.util.time :as dt]
[uxbox.util.data :as data])
(:import
io.vertx.core.buffer.Buffer
java.io.ByteArrayInputStream
java.io.ByteArrayOutputStream
java.io.File))
;; --- Handlers
@ -49,28 +53,33 @@
;; --- High-Level Api
;; TODO: check performance of different options
(defn decode
([data]
(decode data nil))
([data opts]
(cond
(string? data)
(decode (.getBytes data "UTF-8") opts)
(instance? Buffer data)
(decode (.getBytes ^Buffer data) opts)
(bytes? data)
(with-open [input (ByteArrayInputStream. data)]
(read! (reader input opts)))
;; ;; TODO: temporal
;; (instance? org.jooq.JSONB data)
;; (decode (.toString data) opts)
(string? data)
(decode (.getBytes data "UTF-8") opts)
:else
(with-open [input (io/input-stream data)]
(read! (reader input opts))))))
(defn encode
(^bytes [data]
([data]
(encode data nil))
(^bytes [data opts]
([data opts]
(with-open [out (ByteArrayOutputStream.)]
(let [w (writer out opts)]
(write! w data)

19
backend/src/uxbox/util/uuid.clj
View file

@ -5,18 +5,29 @@
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.util.uuid
(:refer-clojure :exclude [next])
(:require [clj-uuid :as uuid])
(:import java.util.UUID))
(def ^:const zero uuid/+null+)
(def ^:const oid uuid/+namespace-oid+)
(def random
(defmacro next
[]
`(uuid/v1))
(defmacro random
"Alias for clj-uuid/v4."
uuid/v4)
[]
`(uuid/v4))
(defn namespaced
(defmacro namespaced
[ns data]
(uuid/v5 ns data))
`(uuid/v5 ~ns ~data))
(defmacro str->uuid
[s]
`(UUID/fromString ~s))
(defn from-string
"Parse string uuid representation into proper UUID instance."

114
backend/src/uxbox/util/workers.clj
View file

@ -7,68 +7,68 @@
(ns uxbox.util.workers
"A distributed asynchronous tasks queue implementation on top
of PostgreSQL reliable advirsory locking mechanism."
(:require [suricatta.core :as sc]
[uxbox.db :as db]
[uxbox.sql :as sql]))
#_(:require
[suricatta.core :as sc]
[uxbox.db :as db]))
(defn- poll-for-task
[conn queue]
(let [sql (sql/acquire-task {:queue queue})]
(sc/fetch-one conn sql)))
;; (defn- poll-for-task
;; [conn queue]
;; (let [sql (sql/acquire-task {:queue queue})]
;; (sc/fetch-one conn sql)))
(defn- mark-task-done
[conn {:keys [id]}]
(let [sql (sql/mark-task-done {:id id})]
(sc/execute conn sql)))
;; (defn- mark-task-done
;; [conn {:keys [id]}]
;; (let [sql (sql/mark-task-done {:id id})]
;; (sc/execute conn sql)))
(defn- mark-task-failed
[conn {:keys [id]} error]
(let [sql (sql/mark-task-done {:id id :error (.getMessage error)})]
(sc/execute conn sql)))
;; (defn- mark-task-failed
;; [conn {:keys [id]} error]
;; (let [sql (sql/mark-task-done {:id id :error (.getMessage error)})]
;; (sc/execute conn sql)))
(defn- watch-unit
[conn queue callback]
(let [task (poll-for-task conn queue)]
(if (nil? task)
(Thread/sleep 1000)
(try
(sc/atomic conn
(callback conn task)
(mark-task-done conn task))
(catch Exception e
(mark-task-failed conn task e))))))
;; (defn- watch-unit
;; [conn queue callback]
;; (let [task (poll-for-task conn queue)]
;; (if (nil? task)
;; (Thread/sleep 1000)
;; (try
;; (sc/atomic conn
;; (callback conn task)
;; (mark-task-done conn task))
;; (catch Exception e
;; (mark-task-failed conn task e))))))
(defn- watch-loop
"Watch tasks on the specified queue and executes a
callback for each task is received.
NOTE: This function blocks the current thread."
[queue callback]
(try
(loop []
(with-open [conn (db/connection)]
(sc/atomic conn (watch-unit conn queue callback)))
(recur))
(catch InterruptedException e
;; just ignoring
)))
;; (defn- watch-loop
;; "Watch tasks on the specified queue and executes a
;; callback for each task is received.
;; NOTE: This function blocks the current thread."
;; [queue callback]
;; (try
;; (loop []
;; (with-open [conn (db/connection)]
;; (sc/atomic conn (watch-unit conn queue callback)))
;; (recur))
;; (catch InterruptedException e
;; ;; just ignoring
;; )))
(defn watch!
[queue callback]
(let [runnable #(watch-loop queue callback)
thread (Thread. ^Runnable runnable)]
(.setDaemon thread true)
(.start thread)
(reify
java.lang.AutoCloseable
(close [_]
(.interrupt thread)
(.join thread 2000))
;; (defn watch!
;; [queue callback]
;; (let [runnable #(watch-loop queue callback)
;; thread (Thread. ^Runnable runnable)]
;; (.setDaemon thread true)
;; (.start thread)
;; (reify
;; java.lang.AutoCloseable
;; (close [_]
;; (.interrupt thread)
;; (.join thread 2000))
clojure.lang.IDeref
(deref [_]
(.join thread))
;; clojure.lang.IDeref
;; (deref [_]
;; (.join thread))
clojure.lang.IBlockingDeref
(deref [_ ms default]
(.join thread ms)
default))))
;; clojure.lang.IBlockingDeref
;; (deref [_ ms default]
;; (.join thread ms)
;; default))))

223
backend/src/vertx/core.clj Normal file
View file

@ -0,0 +1,223 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns vertx.core
(:require [clojure.spec.alpha :as s]
[promesa.core :as p]
[vertx.eventbus :as vxe]
[vertx.util :as vu])
(:import
io.vertx.core.Context
io.vertx.core.DeploymentOptions
io.vertx.core.Future
io.vertx.core.Handler
io.vertx.core.Verticle
io.vertx.core.Vertx
io.vertx.core.VertxOptions
java.util.function.Supplier))
(declare opts->deployment-options)
(declare opts->vertx-options)
(declare build-verticle)
(declare build-actor)
(declare build-disposable)
;; --- Protocols
(definterface IVerticleFactory)
;; --- Public Api
(s/def :vertx.core$system/threads pos?)
(s/def :vertx.core$system/on-error fn?)
(s/def ::system-options
(s/keys :opt-un [:vertx.core$system/threads
:vertx.core$system/on-error]))
(defn system
"Creates a new vertx actor system instance."
([] (system {}))
([options]
(s/assert ::system-options options)
(let [^VertxOptions opts (opts->vertx-options options)
^Vertx vsm (Vertx/vertx opts)]
(vxe/configure! vsm opts)
vsm)))
(defn get-or-create-context
[vsm]
(.getOrCreateContext ^Vertx (vu/resolve-system vsm)))
(defn current-context
[]
(Vertx/currentContext))
(defn handle-on-context
"Attaches the context (current if not explicitly provided) to the
promise execution chain."
([prm] (handle-on-context prm (current-context)))
([prm ctx]
(let [d (p/deferred)]
(p/finally prm (fn [v e]
(.runOnContext
^Context ctx
^Handler (reify Handler
(handle [_ v']
(if e
(p/reject! d e)
(p/resolve! d v)))))))
d)))
(s/def :vertx.core$verticle/on-start fn?)
(s/def :vertx.core$verticle/on-stop fn?)
(s/def :vertx.core$verticle/on-error fn?)
(s/def ::verticle-options
(s/keys :req-un [:vertx.core$verticle/on-start]
:opt-un [:vertx.core$verticle/on-stop
:vertx.core$verticle/on-error]))
(defn verticle
"Creates a verticle instance (factory)."
[options]
(s/assert ::verticle-options options)
(reify
IVerticleFactory
Supplier
(get [_] (build-verticle options))))
(defn verticle?
"Return `true` if `v` is instance of `IVerticleFactory`."
[v]
(instance? IVerticleFactory v))
(s/def :vertx.core$actor/on-message fn?)
(s/def ::actor-options
(s/keys :req-un [:vertx.core$actor/on-message]
:opt-un [:vertx.core$verticle/on-start
:vertx.core$verticle/on-error
:vertx.core$verticle/on-stop]))
(defn actor
"A shortcut for create a verticle instance (factory) that consumes a
specific topic."
[topic options]
(s/assert string? topic)
(s/assert ::actor-options options)
(reify
IVerticleFactory
Supplier
(get [_] (build-actor topic options))))
(s/def :vertx.core$deploy/instances pos?)
(s/def :vertx.core$deploy/worker boolean?)
(s/def ::deploy-options
(s/keys :opt-un [:vertx.core$deploy/worker
:vertx.core$deploy/instances]))
(defn deploy!
"Deploy a verticle."
([vsm supplier] (deploy! vsm supplier nil))
([vsm supplier options]
(s/assert verticle? supplier)
(s/assert ::deploy-options options)
(let [d (p/deferred)
o (opts->deployment-options options)]
(.deployVerticle ^Vertx vsm
^Supplier supplier
^DeploymentOptions o
^Handler (vu/deferred->handler d))
(p/then' d (fn [id] (build-disposable vsm id))))))
(defn undeploy!
"Undeploy the verticle, this function should be rarelly used because
the easiest way to undeplo is executin the callable returned by
`deploy!` function."
[vsm id]
(s/assert string? id)
(let [d (p/deferred)]
(.undeploy ^Vertx (vu/resolve-system vsm)
^String id
^Handler (vu/deferred->handler d))
d))
;; --- Impl
(defn- build-verticle
[{:keys [on-start on-stop on-error]
:or {on-error (constantly nil)
on-stop (constantly nil)}}]
(let [vsm (volatile! nil)
ctx (volatile! nil)
lst (volatile! nil)]
(reify Verticle
(init [_ instance context]
(vreset! vsm instance)
(vreset! ctx context))
(getVertx [_] @vsm)
(^void start [_ ^Future o]
(-> (p/do! (on-start @ctx))
(p/handle (fn [state error]
(if error
(do
(.fail o error)
(on-error @ctx error))
(do
(when (map? state)
(vswap! lst merge state))
(.complete o)))))))
(^void stop [_ ^Future o]
(p/handle (p/do! (on-stop @ctx @lst))
(fn [_ err]
(if err
(do (on-error err)
(.fail o err))
(.complete o))))))))
(defn- build-actor
[topic {:keys [on-message on-error on-stop on-start]
:or {on-error (constantly nil)
on-start (constantly {})
on-stop (constantly nil)}}]
(letfn [(-on-start [ctx]
(let [state (on-start ctx)
state (if (map? state) state {})
consumer (vxe/consumer ctx topic on-message)]
(assoc state ::consumer consumer)))]
(build-verticle {:on-error on-error
:on-stop on-stop
:on-start -on-start})))
(defn- build-disposable
[vsm id]
(reify
clojure.lang.IDeref
(deref [_] id)
clojure.lang.IFn
(invoke [_] (undeploy! vsm id))
java.io.Closeable
(close [_]
@(undeploy! vsm id))))
(defn- opts->deployment-options
[{:keys [instances worker]}]
(let [opts (DeploymentOptions.)]
(when instances (.setInstances opts (int instances)))
(when worker (.setWorker opts worker))
;; (.setInstances opts 4)
;; (.setWorkerPoolSize opts 4)
opts))
(defn- opts->vertx-options
[{:keys [threads on-error]}]
(let [opts (VertxOptions.)]
(when threads (.setEventLoopPoolSize opts (int threads)))
(when on-error (.exceptionHandler (vu/fn->handler on-error)))
opts))

122
backend/src/vertx/eventbus.clj Normal file
View file

@ -0,0 +1,122 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns vertx.eventbus
(:require [promesa.core :as p]
[vertx.util :as vu])
(:import io.vertx.core.Vertx
io.vertx.core.Handler
io.vertx.core.Context
io.vertx.core.eventbus.Message
io.vertx.core.eventbus.MessageConsumer
io.vertx.core.eventbus.DeliveryOptions
io.vertx.core.eventbus.EventBus
io.vertx.core.eventbus.MessageCodec
java.util.function.Supplier))
(declare opts->delivery-opts)
(declare resolve-eventbus)
(declare build-message-codec)
(declare build-message)
;; --- Public Api
(defn consumer
[vsm topic f]
(let [^EventBus bus (resolve-eventbus vsm)
^MessageConsumer consumer (.consumer bus ^String topic)]
(.handler consumer (reify Handler
(handle [_ msg]
(.pause consumer)
(-> (p/do! (f vsm (build-message msg)))
(p/handle (fn [res err]
(.resume consumer)
(.reply msg (or res err)
(opts->delivery-opts {}))))))))
consumer))
(defn publish!
([vsm topic msg] (publish! vsm topic msg {}))
([vsm topic msg opts]
(let [bus (resolve-eventbus vsm)
opts (opts->delivery-opts opts)]
(.publish ^EventBus bus
^String topic
^Object msg
^DeliveryOptions opts)
nil)))
(defn send!
([vsm topic msg] (send! vsm topic msg {}))
([vsm topic msg opts]
(let [bus (resolve-eventbus vsm)
opts (opts->delivery-opts opts)]
(.send ^EventBus bus
^String topic
^Object msg
^DeliveryOptions opts)
nil)))
(defn request!
([vsm topic msg] (request! vsm topic msg {}))
([vsm topic msg opts]
(let [bus (resolve-eventbus vsm)
opts (opts->delivery-opts opts)
d (p/deferred)]
(.request ^EventBus bus
^String topic
^Object msg
^DeliveryOptions opts
^Handler (vu/deferred->handler d))
(p/then' d build-message))))
(defn configure!
[vsm opts]
(let [^EventBus bus (resolve-eventbus vsm)]
(.registerCodec bus (build-message-codec))))
(defrecord Msg [body])
(defn message?
[v]
(instance? Msg v))
;; --- Impl
(defn- resolve-eventbus
[o]
(cond
(instance? Vertx o) (.eventBus ^Vertx o)
(instance? Context o) (resolve-eventbus (.owner ^Context o))
(instance? EventBus o) o
:else (throw (ex-info "unexpected argument" {}))))
(defn- build-message-codec
[]
;; TODO: implement the wire encode/decode using transit+msgpack
(reify MessageCodec
(encodeToWire [_ buffer data])
(decodeFromWire [_ pos buffer])
(transform [_ data] data)
(name [_] "clj:msgpack")
(^byte systemCodecID [_] (byte -1))))
(defn- build-message
[^Message msg]
(let [metadata {::reply-to (.replyAddress msg)
::send? (.isSend msg)
::address (.address msg)}
body (.body msg)]
(Msg. body metadata nil)))
(defn- opts->delivery-opts
[{:keys [codec local?]}]
(let [^DeliveryOptions opts (DeliveryOptions.)]
(.setCodecName opts (or codec "clj:msgpack"))
(when local? (.setLocalOnly opts true))
opts))

74
backend/src/vertx/http.clj Normal file
View file

@ -0,0 +1,74 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns vertx.http
"Enables `raw` access to the http facilites of vertx. If you want more
clojure idiomatic api, refer to the `vertx.web` namespace."
(:require [clojure.spec.alpha :as s]
[promesa.core :as p]
[vertx.util :as vu])
(:import
io.vertx.core.Vertx
io.vertx.core.Verticle
io.vertx.core.Handler
io.vertx.core.Future
io.vertx.core.Context
io.vertx.core.http.HttpServer
io.vertx.core.http.HttpServerRequest
io.vertx.core.http.HttpServerResponse
io.vertx.core.http.HttpServerOptions))
(declare opts->http-server-options)
(declare resolve-handler)
;; --- Public Api
(s/def :vertx.http/handler fn?)
(s/def :vertx.http/host string?)
(s/def :vertx.http/port pos?)
(s/def ::server-options
(s/keys :req-un [:vertx.http/handler]
:opt-un [:vertx.http/host
:vertx.http/port]))
(defn server
"Starts a vertx http server."
[vsm {:keys [handler] :as options}]
(s/assert ::server-options options)
(let [^Vertx vsm (vu/resolve-system vsm)
^HttpServerOptions opts (opts->http-server-options options)
^HttpServer srv (.createHttpServer vsm opts)
^Handler handler (resolve-handler handler)]
(doto srv
(.requestHandler handler)
(.listen))
srv))
;; --- Impl
(defn- opts->http-server-options
[{:keys [host port]}]
(let [opts (HttpServerOptions.)]
(.setReuseAddress opts true)
(.setReusePort opts true)
;; (.setTcpNoDelay opts true)
;; (.setTcpFastOpen opts true)
(when host (.setHost opts host))
(when port (.setPort opts port))
opts))
(defn- fn->handler
[f]
(reify Handler
(handle [_ request]
(f request))))
(defn- resolve-handler
[handler]
(cond
(fn? handler) (fn->handler handler)
(instance? Handler handler) handler
:else (throw (ex-info "invalid handler" {}))))

55
backend/src/vertx/timers.clj Normal file
View file

@ -0,0 +1,55 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns vertx.timers
"The timers and async scheduled tasks."
(:require
[clojure.spec.alpha :as s]
[promesa.core :as p]
[vertx.util :as vu])
(:import
io.vertx.core.Vertx
io.vertx.core.Handler))
(defn schedule-once!
[vsm ms f]
(let [^Vertx system (vu/resolve-system vsm)
^Handler handler (vu/fn->handler (fn [v] (f)))
timer-id (.setTimer system ms handler)]
(reify
java.lang.AutoCloseable
(close [_]
(.cancelTimer system timer-id)))))
(defn sechdule-periodic!
[vsm ms f]
(let [^Vertx system (vu/resolve-system vsm)
^Handler handler (vu/fn->handler (fn [v] (f)))
timer-id (.setPeriodic system ms handler)]
(reify
java.lang.AutoCloseable
(close [_]
(.cancelTimer system timer-id)))))
(defn schedule-task!
[vsm ms f]
(let [^Vertx system (vu/resolve-system vsm)
tid* (atom nil)
task (fn wrapped-task []
(-> (p/do! (f))
(p/then (fn [_]
(let [tid (schedule-task! vsm ms wrapped-task)]
(reset! tid* tid)
nil)))))
tid (schedule-task! vsm ms task)]
(reset! tid* tid)
(reify
java.lang.AutoCloseable
(close [this]
(locking this
(when-let [timer-id (deref tid*)]
(.cancelTimer system timer-id)
(reset! tid* nil)))))))

40
backend/src/vertx/util.clj Normal file
View file

@ -0,0 +1,40 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns vertx.util
(:require [promesa.core :as p])
(:import io.vertx.core.Vertx
io.vertx.core.Handler
io.vertx.core.Context
io.vertx.core.AsyncResult
java.util.function.Supplier))
(defn resolve-system
[o]
(cond
(instance? Vertx o) o
(instance? Context o) (.owner ^Context o)
:else (throw (ex-info "unexpected parameters" {}))))
(defn fn->supplier
[f]
(reify Supplier
(get [_] (f))))
(defn fn->handler
[f]
(reify Handler
(handle [_ v]
(f v))))
(defn deferred->handler
[d]
(reify Handler
(handle [_ ar]
(if (.failed ar)
(p/reject! d (.cause ar))
(p/resolve! d (.result ar))))))

87
backend/src/vertx/util/transit.clj Normal file
View file

@ -0,0 +1,87 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns vertx.util.transit
(:require [cognitect.transit :as t]
[clojure.java.io :as io])
(:import java.io.ByteArrayInputStream
java.io.ByteArrayOutputStream
java.time.Instant))
(def ^:private write-handler
(t/write-handler
(constantly "m")
(fn [v] (str (.toEpochMilli v)))))
(def ^:private read-handler
(t/read-handler
(fn [v] (-> (Long/parseLong v)
(Instant/ofEpochMilli)))))
(def +read-handlers+
{"m" read-handler})
(def +write-handlers+
{Instant write-handler})
(defmethod print-method Instant
[mv ^java.io.Writer writer]
(.write writer (str "#instant \"" (.toString mv) "\"")))
(defmethod print-dup Instant [o w]
(print-method o w))
;; --- Low-Level Api
(defn reader
([istream]
(reader istream nil))
([istream {:keys [type] :or {type :msgpack}}]
(t/reader istream type {:handlers +read-handlers+})))
(defn read!
"Read value from streamed transit reader."
[reader]
(t/read reader))
(defn writer
([ostream]
(writer ostream nil))
([ostream {:keys [type] :or {type :msgpack}}]
(t/writer ostream type {:handlers +write-handlers+})))
(defn write!
[writer data]
(t/write writer data))
;; --- High-Level Api
;; TODO: check performance of different options
(defn decode
([data]
(decode data nil))
([data opts]
(cond
(string? data)
(decode (.getBytes data "UTF-8") opts)
(bytes? data)
(with-open [input (ByteArrayInputStream. data)]
(read! (reader input opts)))
:else
(with-open [input (io/input-stream data)]
(read! (reader input opts))))))
(defn encode
(^bytes [data]
(encode data nil))
(^bytes [data opts]
(with-open [out (ByteArrayOutputStream.)]
(let [w (writer out opts)]
(write! w data)
(.toByteArray out)))))

169
backend/src/vertx/web.clj Normal file
View file

@ -0,0 +1,169 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns vertx.web
"High level api for http servers."
(:require [clojure.spec.alpha :as s]
[promesa.core :as p]
[sieppari.core :as sp]
[reitit.core :as rt]
[vertx.http :as vxh]
[vertx.util :as vu])
(:import
clojure.lang.Keyword
clojure.lang.IPersistentMap
io.vertx.core.Vertx
io.vertx.core.Handler
io.vertx.core.Future
io.vertx.core.buffer.Buffer
io.vertx.core.http.Cookie
io.vertx.core.http.HttpServer
io.vertx.core.http.HttpServerRequest
io.vertx.core.http.HttpServerResponse
io.vertx.core.http.HttpServerOptions
io.vertx.ext.web.Route
io.vertx.ext.web.Router
io.vertx.ext.web.RoutingContext
io.vertx.ext.web.handler.BodyHandler
io.vertx.ext.web.handler.StaticHandler
io.vertx.ext.web.handler.ResponseTimeHandler
io.vertx.ext.web.handler.LoggerHandler))
;; --- Constants & Declarations
(declare -handle-response)
(declare -handle-body)
;; --- Public Api
(s/def ::wrap-handler
(s/or :fn fn?
:vec (s/every fn? :kind vector?)))
(defn- make-ctx
[^RoutingContext routing-context]
(let [^HttpServerRequest request (.request ^RoutingContext routing-context)
^HttpServerResponse response (.response ^RoutingContext routing-context)
^Vertx system (.vertx routing-context)]
{:body (.getBody routing-context)
:path (.path request)
:method (-> request .rawMethod .toLowerCase keyword)
::request request
::response response
::execution-context (.getContext system)
::routing-context routing-context}))
(defn handler
"Wraps a user defined funcion based handler into a vertx-web aware
handler (with support for multipart uploads.
If the handler is a vector, the sieppari intercerptos engine will be used
to resolve the execution of the interceptors + handler."
[vsm & handlers]
(let [^Vertx vsm (vu/resolve-system vsm)
^Router router (Router/router vsm)]
(reduce #(%2 %1) router handlers)))
(defn assets
([path] (assets path {}))
([path {:keys [root] :or {root "public"} :as options}]
(fn [^Router router]
(let [^Route route (.route router path)
^Handler handler (doto (StaticHandler/create)
(.setWebRoot root)
(.setDirectoryListing true))]
(.handler route handler)
router))))
(defn- default-handler
[ctx]
(if (::match ctx)
{:status 405}
{:status 404}))
(defn- run-chain
[ctx chain handler]
(let [d (p/deferred)]
(sp/execute (conj chain handler) ctx #(p/resolve! d %) #(p/reject! d %))
d))
(defn- router-handler
[router {:keys [path method] :as ctx}]
(let [{:keys [data path-params] :as match} (rt/match-by-path router path)
handler-fn (or (get data method)
(get data :all)
default-handler)
interceptors (get data :interceptors)
ctx (assoc ctx ::match match :path-params path-params)]
(if (empty? interceptors)
(handler-fn ctx)
(run-chain ctx interceptors handler-fn))))
(defn router
([routes] (router routes {}))
([routes {:keys [delete-uploads?
upload-dir
log-requests?
time-response?]
:or {delete-uploads? true
upload-dir "/tmp/vertx.uploads"
log-requests? false
time-response? true}
:as options}]
(let [rtr (rt/router routes options)
hdr #(router-handler rtr %)]
(fn [^Router router]
(let [^Route route (.route router)]
(when time-response? (.handler route (ResponseTimeHandler/create)))
(when log-requests? (.handler route (LoggerHandler/create)))
(.handler route (doto (BodyHandler/create true)
(.setDeleteUploadedFilesOnEnd delete-uploads?)
(.setUploadsDirectory upload-dir)))
(.handler route (reify Handler
(handle [_ context]
(let [ctx (make-ctx context)]
(-> (p/do! (hdr ctx))
(p/then' #(-handle-response % ctx))
(p/catch #(do (prn %) (.fail (:context ctx) %)))))))))
router))))
;; --- Impl
(defprotocol IAsyncResponse
(-handle-response [_ _]))
(extend-protocol IAsyncResponse
clojure.lang.IPersistentMap
(-handle-response [data ctx]
(let [status (or (:status data) 200)
body (:body data)
res (::response ctx)]
(.setStatusCode ^HttpServerResponse res status)
(-handle-body body res))))
(defprotocol IAsyncBody
(-handle-body [_ _]))
(extend-protocol IAsyncBody
(Class/forName "[B")
(-handle-body [data res]
(.end ^HttpServerResponse res (Buffer/buffer data)))
Buffer
(-handle-body [data res]
(.end ^HttpServerResponse res ^Buffer data))
nil
(-handle-body [data res]
(.putHeader ^HttpServerResponse res "content-length" "0")
(.end ^HttpServerResponse res))
String
(-handle-body [data res]
(let [length (count data)]
(.putHeader ^HttpServerResponse res "content-length" (str length))
(.end ^HttpServerResponse res data))))

204
backend/src/vertx/web/interceptors.clj Normal file
View file

@ -0,0 +1,204 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
(ns vertx.web.interceptors
"High level api for http servers."
(:require
[clojure.spec.alpha :as s]
[clojure.string :as str]
[promesa.core :as p]
[reitit.core :as r]
[vertx.web :as vw]
[sieppari.context :as spx]
[sieppari.core :as sp])
(:import
clojure.lang.Keyword
clojure.lang.MapEntry
java.util.Map
java.util.Map$Entry
io.vertx.core.Vertx
io.vertx.core.Handler
io.vertx.core.Future
io.vertx.core.http.Cookie
io.vertx.core.http.HttpServerRequest
io.vertx.core.http.HttpServerResponse
io.vertx.ext.web.FileUpload
io.vertx.ext.web.RoutingContext))
;; --- Cookies
(defn- build-cookie
[name data]
(cond-> (Cookie/cookie ^String name ^String (:value data))
(:http-only data) (.setHttpOnly true)
(:domain data) (.setDomain (:domain data))
(:path data) (.setPath (:path data))
(:secure data) (.setSecure true)))
(defn cookies
[]
{:enter (fn [data]
(let [^HttpServerRequest req (get-in data [:request ::vw/request])
parse-cookie (fn [^Cookie item] [(.getName item) (.getValue item)])
cookies (into {} (map parse-cookie) (vals (.cookieMap req)))]
(update data :request assoc :cookies cookies)))
:leave (fn [data]
(let [cookies (get-in data [:response :cookies])
^HttpServerResponse res (get-in data [:request ::vw/response])]
(when (map? cookies)
(reduce-kv #(.addCookie res (build-cookie %1 %2)) nil cookies))
data))})
;; --- Headers
(def ^:private lowercase-keys-t
(map (fn [^Map$Entry entry]
(MapEntry. (.toLowerCase (.getKey entry)) (.getValue entry)))))
(defn- parse-headers
[req]
(let [^HttpServerRequest request (::vw/request req)]
(into {} lowercase-keys-t (.headers request))))
(defn headers
[]
{:enter (fn [data]
(update data :request assoc :headers (parse-headers (:request data))))
:leave (fn [data]
(let [^HttpServerResponse res (get-in data [:request ::vw/response])
headers (get-in data [:response :headers])]
(run! (fn [[key value]]
(.putHeader ^HttpServerResponse res
^String (name key)
^String (str value)))
headers)
data))})
;; --- Params
(defn- parse-param-entry
[acc ^Map$Entry item]
(let [key (keyword (.toLowerCase (.getKey item)))
prv (get acc key ::default)]
(cond
(= prv ::default)
(assoc! acc key (.getValue item))
(vector? prv)
(assoc! acc key (conj prv (.getValue item)))
:else
(assoc! acc key [prv (.getValue item)]))))
(defn- parse-params
[req]
(let [request (::vw/request req)]
(persistent!
(reduce parse-param-entry
(transient {})
(.params ^HttpServerResponse request)))))
(defn params
([] (params nil))
([{:keys [attr] :or {attr :params}}]
{:enter (fn [data]
(let [params (parse-params (:request data))]
(update data :request assoc attr params)))}))
;; --- Uploads
(defn uploads
([] (uploads nil))
([{:keys [attr] :or {attr :uploads}}]
{:enter (fn [data]
(let [context (get-in data [:request ::vw/routing-context])
uploads (reduce (fn [acc ^FileUpload upload]
(assoc acc
(keyword (.name upload))
{:type :uploaded-file
:mtype (.contentType upload)
:path (.uploadedFileName upload)
:name (.fileName upload)
:size (.size upload)}))
(transient {})
(.fileUploads ^RoutingContext context))]
(update data :request assoc attr (persistent! uploads))))}))
;; --- CORS
(s/def ::origin string?)
(s/def ::allow-credentials boolean?)
(s/def ::allow-methods (s/every keyword? :kind set?))
(s/def ::allow-headers (s/every keyword? :kind set?))
(s/def ::expose-headers (s/every keyword? :kind set?))
(s/def ::max-age number?)
(s/def ::cors-opts
(s/keys :req-un [::origin]
:opt-un [::allow-headers
::allow-methods
::expose-headers
::max-age]))
(defn cors
[opts]
(s/assert ::cors-opts opts)
(letfn [(preflight? [{:keys [method headers] :as ctx}]
(and (= method :options)
(contains? headers "origin")
(contains? headers "access-control-request-method")))
(normalize [data]
(str/join ", " (map name data)))
(allow-origin? [headers]
(let [origin (:origin opts)
value (get headers "origin")]
(cond
(nil? value) value
(= origin "*") origin
(set? origin) (origin value)
(= origin value) origin)))
(get-headers [{:keys [headers] :as ctx}]
(when-let [origin (allow-origin? headers)]
(cond-> {"access-control-allow-origin" origin
"access-control-allow-methods" "GET, OPTIONS, HEAD"}
(:allow-methods opts)
(assoc "access-control-allow-methods"
(-> (normalize (:allow-methods opts))
(str/upper-case)))
(:allow-credentials opts)
(assoc "access-control-allow-credentials" "true")
(:expose-headers opts)
(assoc "access-control-expose-headers"
(-> (normalize (:expose-headers opts))
(str/lower-case)))
(:max-age opts)
(assoc "access-control-max-age" (:max-age opts))
(:allow-headers opts)
(assoc "access-control-allow-headers"
(-> (normalize (:allow-headers opts))
(str/lower-case))))))
(enter [data]
(let [ctx (:request data)]
(if (preflight? ctx)
(spx/terminate (assoc data ::preflight true))
data)))
(leave [data]
(let [headers (get-headers (:request data))]
(if (::preflight data)
(assoc data :response {:status 204 :headers headers})
(update-in data [:response :headers] merge headers))))]
{:enter enter
:leave leave}))

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