github/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2026-04-25 11:18:36 +00:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Alejandro Alonso 2026-04-21 08:24:29 +02:00
commit 0d17debde7
141 changed files with 4781 additions and 1212 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
CHANGES.md
View File

@ -94,11 +94,12 @@
- Fix text editor v1 focus [Taiga #13961](https://tree.taiga.io/project/penpot/issue/13961)
## 2.14.3 (Unreleased)
## 2.14.3
### :sparkles: New features & Enhancements
- Add webp export format to plugin types [Github #8870](https://github.com/penpot/penpot/pull/8870)
- Use shared singleton containers for React portals to reduce DOM growth [Github #8957](https://github.com/penpot/penpot/pull/8957)
### :bug: Bugs fixed
@ -111,6 +112,16 @@
- Fix path drawing preview passing shape instead of content to next-node
- Fix swapped arguments in CLJS PathData `-nth` with default
- Normalize PathData coordinates to safe integer bounds on read
- Fix RangeError from re-entrant error handling causing stack overflow [Github #8962](https://github.com/penpot/penpot/pull/8962)
- Fix builder bool styles and media validation [Github #8963](https://github.com/penpot/penpot/pull/8963)
- Fix "Move to" menu allowing same project as target when multiple files are selected
- Fix crash when index query param is duplicated in URL
- Fix wrong extremity point in path `calculate-extremities` for line-to segments
- Fix reversed args in DTCG shadow composite token conversion
- Fix `inside-layout?` passing shape id instead of shape to `frame-shape?`
- Fix wrong `mapcat` call in `collect-main-shapes`
- Fix stale accumulator in `get-children-in-instance` recursion
- Fix typo `:podition` in swap-shapes grid cell
## 2.14.2

113
backend/AGENTS.md
View File

@ -83,7 +83,52 @@ are config maps with `::ig/ref` for dependencies. Components implement
`ig/init-key` / `ig/halt-key!`.
### Database Access
### Connecting to the Database
Two PostgreSQL databases are used in this environment:
| Database | Purpose | Connection string |
|---------------|--------------------|----------------------------------------------------|
| `penpot` | Development / app | `postgresql://penpot:penpot@postgres/penpot` |
| `penpot_test` | Test suite | `postgresql://penpot:penpot@postgres/penpot_test` |
**Interactive psql session:**
```bash
# development DB
psql "postgresql://penpot:penpot@postgres/penpot"
# test DB
psql "postgresql://penpot:penpot@postgres/penpot_test"
```
**One-shot query (non-interactive):**
```bash
psql "postgresql://penpot:penpot@postgres/penpot" -c "SELECT id, name FROM team LIMIT 5;"
```
**Useful psql meta-commands:**
```
\dt -- list all tables
\d <table> -- describe a table (columns, types, constraints)
\di -- list indexes
\q -- quit
```
> **Migrations table:** Applied migrations are tracked in the `migrations` table
> with columns `module`, `step`, and `created_at`. When renaming a migration
> logical name, update this table in both databases to match the new name;
> otherwise the runner will attempt to re-apply the migration on next startup.
```bash
# Example: fix a renamed migration entry in the test DB
psql "postgresql://penpot:penpot@postgres/penpot_test" \
-c "UPDATE migrations SET step = 'new-name' WHERE step = 'old-name';"
```
### Database Access (Clojure)
`app.db` wraps next.jdbc. Queries use a SQL builder that auto-converts kebab-case ↔ snake_case.
@ -146,3 +191,69 @@ optimized implementations:
`src/app/config.clj` reads `PENPOT_*` environment variables, validated with
Malli. Access anywhere via `(cf/get :smtp-host)`. Feature flags: `(cf/flags
:enable-smtp)`.
### Background Tasks
Background tasks live in `src/app/tasks/`. Each task is an Integrant component
that exposes a `::handler` key and follows this three-method pattern:
```clojure
(defmethod ig/assert-key ::handler ;; validate config at startup
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool"))
(defmethod ig/expand-key ::handler ;; inject defaults before init
[k v]
{k (assoc v ::my-option default-value)})
(defmethod ig/init-key ::handler ;; return the task fn
[_ cfg]
(fn [_task] ;; receives the task row from the worker
(db/tx-run! cfg (fn [{:keys [::db/conn]}]
;; … do work …
))))
```
**Wiring a new task** requires two changes in `src/app/main.clj`:
1. **Handler config** – add an entry in `system-config` with the dependencies:
```clojure
:app.tasks.my-task/handler
{::db/pool (ig/ref ::db/pool)}
```
2. **Registry + cron** – register the handler name and schedule it:
```clojure
;; in ::wrk/registry ::wrk/tasks map:
:my-task (ig/ref :app.tasks.my-task/handler)
;; in worker-config ::wrk/cron ::wrk/entries vector:
{:cron #penpot/cron "0 0 0 * * ?" ;; daily at midnight
:task :my-task}
```
**Useful cron patterns** (Quartz format — six fields: s m h dom mon dow):
| Expression | Meaning |
|------------------------------|--------------------|
| `"0 0 0 * * ?"` | Daily at midnight |
| `"0 0 */6 * * ?"` | Every 6 hours |
| `"0 */5 * * * ?"` | Every 5 minutes |
**Time helpers** (`app.common.time`):
```clojure
(ct/now) ;; current instant
(ct/duration {:hours 1}) ;; java.time.Duration
(ct/minus (ct/now) some-duration) ;; subtract duration from instant
```
`db/interval` converts a `Duration` (or millis / string) to a PostgreSQL
interval object suitable for use in SQL queries:
```clojure
(db/interval (ct/duration {:hours 1})) ;; → PGInterval "3600.0 seconds"
```

4
backend/scripts/_env
View File

@ -45,6 +45,10 @@ export PENPOT_FLAGS="\
enable-redis-cache \
enable-subscriptions";
# Uncomment for nexus integration testing
# export PENPOT_FLAGS="$PENPOT_FLAGS enable-audit-log-archive";
# export PENPOT_AUDIT_LOG_ARCHIVE_URI="http://localhost:6070/api/audit";
# Default deletion delay for devenv
export PENPOT_DELETION_DELAY="24h"

7
backend/src/app/config.clj
View File

@ -82,7 +82,10 @@
:initial-project-skey "initial-project"
;; time to avoid email sending after profile modification
:email-verify-threshold "15m"})
:email-verify-threshold "15m"
:quotes-upload-sessions-per-profile 5
:quotes-upload-chunks-per-session 20})
(def schema:config
(do #_sm/optional-keys
@ -154,6 +157,8 @@
[:quotes-snapshots-per-team {:optional true} ::sm/int]
[:quotes-team-access-requests-per-team {:optional true} ::sm/int]
[:quotes-team-access-requests-per-requester {:optional true} ::sm/int]
[:quotes-upload-sessions-per-profile {:optional true} ::sm/int]
[:quotes-upload-chunks-per-session {:optional true} ::sm/int]
[:auth-token-cookie-name {:optional true} :string]
[:auth-token-cookie-max-age {:optional true} ::ct/duration]

2
backend/src/app/loggers/audit/archive_task.clj
View File

@ -81,7 +81,7 @@
(def ^:private sql:get-audit-log-chunk
"SELECT *
FROM audit_log
WHERE archived_at is null
WHERE archived_at IS NULL
ORDER BY created_at ASC
LIMIT 128
FOR UPDATE

7
backend/src/app/main.clj
View File

@ -388,6 +388,7 @@
:offload-file-data (ig/ref :app.tasks.offload-file-data/handler)
:tasks-gc (ig/ref :app.tasks.tasks-gc/handler)
:telemetry (ig/ref :app.tasks.telemetry/handler)
:upload-session-gc (ig/ref :app.tasks.upload-session-gc/handler)
:storage-gc-deleted (ig/ref ::sto.gc-deleted/handler)
:storage-gc-touched (ig/ref ::sto.gc-touched/handler)
:session-gc (ig/ref ::session.tasks/gc)
@ -423,6 +424,9 @@
:app.tasks.tasks-gc/handler
{::db/pool (ig/ref ::db/pool)}
:app.tasks.upload-session-gc/handler
{::db/pool (ig/ref ::db/pool)}
:app.tasks.objects-gc/handler
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)}
@ -544,6 +548,9 @@
{:cron #penpot/cron "0 0 0 * * ?" ;; daily
:task :tasks-gc}
{:cron #penpot/cron "0 0 0 * * ?" ;; daily
:task :upload-session-gc}
{:cron #penpot/cron "0 0 2 * * ?" ;; daily
:task :file-gc-scheduler}

7
backend/src/app/migrations.clj
View File

@ -465,12 +465,17 @@
{:name "0145-fix-plugins-uri-on-profile"
:fn mg0145/migrate}
{:name "0145-mod-audit-log-table"
:fn (mg/resource "app/migrations/sql/0145-mod-audit-log-table.sql")}
{:name "0146-mod-access-token-table"
:fn (mg/resource "app/migrations/sql/0146-mod-access-token-table.sql")}
{:name "0147-mod-team-invitation-table"
:fn (mg/resource "app/migrations/sql/0147-mod-team-invitation-table.sql")}])
:fn (mg/resource "app/migrations/sql/0147-mod-team-invitation-table.sql")}
{:name "0147-add-upload-session-table"
:fn (mg/resource "app/migrations/sql/0147-add-upload-session-table.sql")}])
(defn apply-migrations!
[pool name migrations]

2
backend/src/app/migrations/sql/0145-mod-audit-log-table.sql Normal file
View File

@ -0,0 +1,2 @@
CREATE INDEX audit_log__created_at__idx ON audit_log(created_at) WHERE archived_at IS NULL;
CREATE INDEX audit_log__archived_at__idx ON audit_log(archived_at) WHERE archived_at IS NOT NULL;

14
backend/src/app/migrations/sql/0147-add-upload-session-table.sql Normal file
View File

@ -0,0 +1,14 @@
CREATE TABLE upload_session (
id uuid PRIMARY KEY,
created_at timestamptz NOT NULL DEFAULT now(),
profile_id uuid NOT NULL REFERENCES profile(id) ON DELETE CASCADE,
total_chunks integer NOT NULL
);
CREATE INDEX upload_session__profile_id__idx
ON upload_session(profile_id);
CREATE INDEX upload_session__created_at__idx
ON upload_session(created_at);

14
backend/src/app/rpc/commands/auth.clj
View File

@ -448,6 +448,7 @@
(when (:create-welcome-file params)
(let [cfg (dissoc cfg ::db/conn)]
(wrk/submit! executor (create-welcome-file cfg profile)))))]
(cond
;; When profile is blocked, we just ignore it and return plain data
(:is-blocked profile)
@ -455,7 +456,8 @@
(l/wrn :hint "register attempt for already blocked profile"
:profile-id (str (:id profile))
:profile-email (:email profile))
(rph/with-meta {:email (:email profile)}
(rph/with-meta {:id (:id profile)
:email (:email profile)}
{::audit/replace-props props
::audit/context {:action "ignore-because-blocked"}
::audit/profile-id (:id profile)
@ -471,7 +473,9 @@
(:member-email invitation)))
(let [invitation (assoc invitation :member-id (:id profile))
token (tokens/generate cfg invitation)]
(-> {:invitation-token token}
(-> {:id (:id profile)
:email (:email profile)
:invitation-token token}
(rph/with-transform (session/create-fn cfg profile claims))
(rph/with-meta {::audit/replace-props props
::audit/context {:action "accept-invitation"}
@ -494,7 +498,8 @@
(when-not (eml/has-reports? conn (:email profile))
(send-email-verification! cfg profile))
(-> {:email (:email profile)}
(-> {:id (:id profile)
:email (:email profile)}
(rph/with-defer create-welcome-file-when-needed)
(rph/with-meta
{::audit/replace-props props
@ -521,7 +526,8 @@
{:id (:id profile)})
(send-email-verification! cfg profile))
(rph/with-meta {:email (:email profile)}
(rph/with-meta {:email (:email profile)
:id (:id profile)}
{::audit/replace-props (audit/profile->props profile)
::audit/context {:action action}
::audit/profile-id (:id profile)

95
backend/src/app/rpc/commands/binfile.clj
View File

@ -22,6 +22,7 @@
[app.media :as media]
[app.rpc :as-alias rpc]
[app.rpc.commands.files :as files]
[app.rpc.commands.media :as media-cmd]
[app.rpc.commands.projects :as projects]
[app.rpc.commands.teams :as teams]
[app.rpc.doc :as-alias doc]
@ -80,20 +81,33 @@
;; --- Command: import-binfile
(defn- import-binfile
[{:keys [::db/pool] :as cfg} {:keys [profile-id project-id version name file]}]
(let [team (teams/get-team pool
:profile-id profile-id
:project-id project-id)
cfg (-> cfg
(assoc ::bfc/features (cfeat/get-team-enabled-features cf/flags team))
(assoc ::bfc/project-id project-id)
(assoc ::bfc/profile-id profile-id)
(assoc ::bfc/name name)
(assoc ::bfc/input (:path file)))
[{:keys [::db/pool] :as cfg} {:keys [profile-id project-id version name file upload-id]}]
(let [team
(teams/get-team pool
:profile-id profile-id
:project-id project-id)
result (case (int version)
1 (bf.v1/import-files! cfg)
3 (bf.v3/import-files! cfg))]
cfg
(-> cfg
(assoc ::bfc/features (cfeat/get-team-enabled-features cf/flags team))
(assoc ::bfc/project-id project-id)
(assoc ::bfc/profile-id profile-id)
(assoc ::bfc/name name))
input-path (:path file)
owned? (some? upload-id)
cfg
(assoc cfg ::bfc/input input-path)
result
(try
(case (int version)
1 (bf.v1/import-files! cfg)
3 (bf.v3/import-files! cfg))
(finally
(when owned?
(fs/delete input-path))))]
(db/update! pool :project
{:modified-at (ct/now)}
@ -103,13 +117,18 @@
result))
(def ^:private schema:import-binfile
[:map {:title "import-binfile"}
[:name [:or [:string {:max 250}]
[:map-of ::sm/uuid [:string {:max 250}]]]]
[:project-id ::sm/uuid]
[:file-id {:optional true} ::sm/uuid]
[:version {:optional true} ::sm/int]
[:file media/schema:upload]])
[:and
[:map {:title "import-binfile"}
[:name [:or [:string {:max 250}]
[:map-of ::sm/uuid [:string {:max 250}]]]]
[:project-id ::sm/uuid]
[:file-id {:optional true} ::sm/uuid]
[:version {:optional true} ::sm/int]
[:file {:optional true} media/schema:upload]
[:upload-id {:optional true} ::sm/uuid]]
[:fn {:error/message "one of :file or :upload-id is required"}
(fn [{:keys [file upload-id]}]
(or (some? file) (some? upload-id)))]])
(sv/defmethod ::import-binfile
"Import a penpot file in a binary format. If `file-id` is provided,
@ -117,28 +136,40 @@
The in-place imports are only supported for binfile-v3 and when a
.penpot file only contains one penpot file.
The file content may be provided either as a multipart `file` upload
or as an `upload-id` referencing a completed chunked-upload session,
which allows importing files larger than the multipart size limit.
"
{::doc/added "1.15"
::doc/changes ["1.20" "Add file-id param for in-place import"
"1.20" "Set default version to 3"]
"1.20" "Set default version to 3"
"2.15" "Add upload-id param for chunked upload support"]
::webhooks/event? true
::sse/stream? true
::sm/params schema:import-binfile}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id project-id version file-id file] :as params}]
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id project-id version file-id upload-id] :as params}]
(projects/check-edition-permissions! pool profile-id project-id)
(let [version (or version 3)
params (-> params
(assoc :profile-id profile-id)
(assoc :version version))
(let [version (or version 3)
params (-> params
(assoc :profile-id profile-id)
(assoc :version version))
cfg (cond-> cfg
(uuid? file-id)
(assoc ::bfc/file-id file-id))
cfg (cond-> cfg
(uuid? file-id)
(assoc ::bfc/file-id file-id))
manifest (case (int version)
1 nil
3 (bf.v3/get-manifest (:path file)))]
params
(if (some? upload-id)
(let [file (db/tx-run! cfg media-cmd/assemble-chunks upload-id)]
(assoc params :file file))
params)
manifest
(case (int version)
1 nil
3 (bf.v3/get-manifest (-> params :file :path)))]
(with-meta
(sse/response (partial import-binfile cfg params))

188
backend/src/app/rpc/commands/media.clj
View File

@ -7,9 +7,11 @@
(ns app.rpc.commands.media
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.schema :as sm]
[app.common.time :as ct]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.loggers.audit :as-alias audit]
[app.media :as media]
@ -17,8 +19,13 @@
[app.rpc.climit :as climit]
[app.rpc.commands.files :as files]
[app.rpc.doc :as-alias doc]
[app.rpc.quotes :as quotes]
[app.storage :as sto]
[app.util.services :as sv]))
[app.storage.tmp :as tmp]
[app.util.services :as sv]
[datoteka.io :as io])
(:import
java.io.OutputStream))
(def thumbnail-options
{:width 100
@ -236,3 +243,182 @@
:width (:width mobj)
:height (:height mobj)
:mtype (:mtype mobj)})))
;; --- Chunked Upload: Create an upload session
(def ^:private schema:create-upload-session
[:map {:title "create-upload-session"}
[:total-chunks ::sm/int]])
(def ^:private schema:create-upload-session-result
[:map {:title "create-upload-session-result"}
[:session-id ::sm/uuid]])
(sv/defmethod ::create-upload-session
{::doc/added "2.16"
::sm/params schema:create-upload-session
::sm/result schema:create-upload-session-result}
[{:keys [::db/pool] :as cfg}
{:keys [::rpc/profile-id total-chunks]}]
(let [max-chunks (cf/get :quotes-upload-chunks-per-session)]
(when (> total-chunks max-chunks)
(ex/raise :type :restriction
:code :max-quote-reached
:target "upload-chunks-per-session"
:quote max-chunks
:count total-chunks)))
(quotes/check! cfg {::quotes/id ::quotes/upload-sessions-per-profile
::quotes/profile-id profile-id})
(let [session-id (uuid/next)]
(db/insert! pool :upload-session
{:id session-id
:profile-id profile-id
:total-chunks total-chunks})
{:session-id session-id}))
;; --- Chunked Upload: Upload a single chunk
(def ^:private schema:upload-chunk
[:map {:title "upload-chunk"}
[:session-id ::sm/uuid]
[:index ::sm/int]
[:content media/schema:upload]])
(def ^:private schema:upload-chunk-result
[:map {:title "upload-chunk-result"}
[:session-id ::sm/uuid]
[:index ::sm/int]])
(sv/defmethod ::upload-chunk
{::doc/added "2.16"
::sm/params schema:upload-chunk
::sm/result schema:upload-chunk-result}
[{:keys [::db/pool] :as cfg}
{:keys [::rpc/profile-id session-id index content] :as _params}]
(let [session (db/get pool :upload-session {:id session-id :profile-id profile-id})]
(when (or (neg? index) (>= index (:total-chunks session)))
(ex/raise :type :validation
:code :invalid-chunk-index
:hint "chunk index is out of range for this session"
:session-id session-id
:total-chunks (:total-chunks session)
:index index)))
(let [storage (sto/resolve cfg)
data (sto/content (:path content))]
(sto/put-object! storage
{::sto/content data
::sto/deduplicate? false
::sto/touch true
:content-type (:mtype content)
:bucket "tempfile"
:upload-id (str session-id)
:chunk-index index}))
{:session-id session-id
:index index})
;; --- Chunked Upload: shared helpers
(def ^:private sql:get-upload-chunks
"SELECT id, size, (metadata->>'~:chunk-index')::integer AS chunk_index
FROM storage_object
WHERE (metadata->>'~:upload-id') = ?::text
AND deleted_at IS NULL
ORDER BY (metadata->>'~:chunk-index')::integer ASC")
(defn- get-upload-chunks
[conn session-id]
(db/exec! conn [sql:get-upload-chunks (str session-id)]))
(defn- concat-chunks
"Reads all chunk storage objects in order and writes them to a single
temporary file on the local filesystem. Returns a path to that file."
[storage chunks]
(let [tmp (tmp/tempfile :prefix "penpot.chunked-upload.")]
(with-open [^OutputStream out (io/output-stream tmp)]
(doseq [{:keys [id]} chunks]
(let [sobj (sto/get-object storage id)
bytes (sto/get-object-bytes storage sobj)]
(.write out ^bytes bytes))))
tmp))
(defn assemble-chunks
"Validates that all expected chunks are present for `session-id` and
concatenates them into a single temporary file. Returns a map
conforming to `media/schema:upload` with `:filename`, `:path` and
`:size`.
Raises a :validation/:missing-chunks error when the number of stored
chunks does not match `:total-chunks` recorded in the session row.
Deletes the session row from `upload_session` on success."
[{:keys [::db/conn] :as cfg} session-id]
(let [session (db/get conn :upload-session {:id session-id})
chunks (get-upload-chunks conn session-id)]
(when (not= (count chunks) (:total-chunks session))
(ex/raise :type :validation
:code :missing-chunks
:hint "number of stored chunks does not match expected total"
:session-id session-id
:expected (:total-chunks session)
:found (count chunks)))
(let [storage (sto/resolve cfg ::db/reuse-conn true)
path (concat-chunks storage chunks)
size (reduce #(+ %1 (:size %2)) 0 chunks)]
(db/delete! conn :upload-session {:id session-id})
{:filename "upload"
:path path
:size size})))
;; --- Chunked Upload: Assemble all chunks into a final media object
(def ^:private schema:assemble-file-media-object
[:map {:title "assemble-file-media-object"}
[:session-id ::sm/uuid]
[:file-id ::sm/uuid]
[:is-local ::sm/boolean]
[:name [:string {:max 250}]]
[:mtype :string]
[:id {:optional true} ::sm/uuid]])
(sv/defmethod ::assemble-file-media-object
{::doc/added "2.16"
::sm/params schema:assemble-file-media-object
::climit/id [[:process-image/by-profile ::rpc/profile-id]
[:process-image/global]]}
[{:keys [::db/pool] :as cfg}
{:keys [::rpc/profile-id session-id file-id is-local name mtype id] :as params}]
(files/check-edition-permissions! pool profile-id file-id)
(db/tx-run! cfg
(fn [{:keys [::db/conn] :as cfg}]
(let [{:keys [path size]} (assemble-chunks cfg session-id)
content {:filename "upload"
:size size
:path path
:mtype mtype}
_ (media/validate-media-type! content)
mobj (create-file-media-object cfg (assoc params
:id (or id (uuid/next))
:content content))]
(db/update! conn :file
{:modified-at (ct/now)
:has-media-trimmed false}
{:id file-id}
{::db/return-keys false})
(with-meta mobj
{::audit/replace-props
{:name name
:file-id file-id
:is-local is-local
:mtype mtype}})))))

24
backend/src/app/rpc/quotes.clj
View File

@ -522,6 +522,30 @@
(assoc ::count-sql [sql:get-team-access-requests-per-requester profile-id])
(generic-check!)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; QUOTE: UPLOAD-SESSIONS-PER-PROFILE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:private schema:upload-sessions-per-profile
[:map [::profile-id ::sm/uuid]])
(def ^:private valid-upload-sessions-per-profile-quote?
(sm/lazy-validator schema:upload-sessions-per-profile))
(def ^:private sql:get-upload-sessions-per-profile
"SELECT count(*) AS total
FROM upload_session
WHERE profile_id = ?")
(defmethod check-quote ::upload-sessions-per-profile
[{:keys [::profile-id ::target] :as quote}]
(assert (valid-upload-sessions-per-profile-quote? quote) "invalid quote parameters")
(-> quote
(assoc ::default (cf/get :quotes-upload-sessions-per-profile Integer/MAX_VALUE))
(assoc ::quote-sql [sql:get-quotes-1 target profile-id])
(assoc ::count-sql [sql:get-upload-sessions-per-profile profile-id])
(generic-check!)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; QUOTE: DEFAULT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

15
backend/src/app/storage/gc_touched.clj
View File

@ -149,7 +149,7 @@
:status "delete"
:bucket bucket)
(recur to-freeze (conj to-delete id) (rest objects))))
(let [deletion-delay (if (= bucket "tempfile")
(let [deletion-delay (if (= "tempfile" bucket)
(ct/duration {:hours 2})
(cf/get-deletion-delay))]
(some->> (seq to-freeze) (mark-freeze-in-bulk! conn))
@ -213,8 +213,13 @@
[_ params]
(assert (db/pool? (::db/pool params)) "expect valid storage"))
(defmethod ig/init-key ::handler
[_ cfg]
(fn [_]
(process-touched! (assoc cfg ::timestamp (ct/now)))))
(defmethod ig/expand-key ::handler
[k v]
{k (merge {::min-age (ct/duration {:hours 2})} v)})
(defmethod ig/init-key ::handler
[_ {:keys [::min-age] :as cfg}]
(fn [_]
(let [threshold (ct/minus (ct/now) min-age)]
(process-touched! (assoc cfg ::timestamp threshold)))))

41
backend/src/app/tasks/upload_session_gc.clj Normal file
View File

@ -0,0 +1,41 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.tasks.upload-session-gc
"A maintenance task that deletes stalled (incomplete) upload sessions.
An upload session is considered stalled when it was created more than
`max-age` ago without being completed (i.e. the session row still
exists because `assemble-chunks` was never called to clean it up).
The default max-age is 1 hour."
(:require
[app.common.logging :as l]
[app.common.time :as ct]
[app.db :as db]
[integrant.core :as ig]))
(def ^:private sql:delete-stalled-sessions
"DELETE FROM upload_session
WHERE created_at < ?::timestamptz")
(defmethod ig/assert-key ::handler
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool"))
(defmethod ig/expand-key ::handler
[k v]
{k (merge {::max-age (ct/duration {:hours 1})} v)})
(defmethod ig/init-key ::handler
[_ {:keys [::max-age] :as cfg}]
(fn [_]
(db/tx-run! cfg
(fn [{:keys [::db/conn]}]
(let [threshold (ct/minus (ct/now) max-age)
result (-> (db/exec-one! conn [sql:delete-stalled-sessions threshold])
(db/get-update-count))]
(l/debug :hint "task finished" :deleted result)
{:deleted result})))))

24
backend/test/backend_tests/rpc_file_test.clj
View File

@ -312,7 +312,8 @@
;; freeze because of the deduplication (we have uploaded 2 times
;; the same files).
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 2 (:freeze res)))
(t/is (= 0 (:delete res))))
@ -386,7 +387,8 @@
;; Now that file-gc have deleted the file-media-object usage,
;; lets execute the touched-gc task, we should see that two of
;; them are marked to be deleted
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 0 (:freeze res)))
(t/is (= 2 (:delete res))))
@ -571,7 +573,8 @@
;; Now that file-gc have deleted the file-media-object usage,
;; lets execute the touched-gc task, we should see that two of
;; them are marked to be deleted.
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 0 (:freeze res)))
(t/is (= 2 (:delete res))))
@ -664,7 +667,8 @@
;; because of the deduplication (we have uploaded 2 times the
;; same files).
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 1 (:freeze res)))
(t/is (= 0 (:delete res))))
@ -714,7 +718,8 @@
;; Now that objects-gc have deleted the object thumbnail lets
;; execute the touched-gc task
(let [res (th/run-task! "storage-gc-touched" {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! "storage-gc-touched" {}))]
(t/is (= 1 (:freeze res))))
;; check file media objects
@ -749,7 +754,8 @@
;; Now that file-gc have deleted the object thumbnail lets
;; execute the touched-gc task
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 1 (:delete res))))
;; check file media objects
@ -1319,7 +1325,8 @@
;; The FileGC task will schedule an inner taskq
(th/run-pending-tasks!)
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 2 (:freeze res)))
(t/is (= 0 (:delete res))))
@ -1413,7 +1420,8 @@
;; we ensure that once object-gc is passed and marked two storage
;; objects to delete
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 0 (:freeze res)))
(t/is (= 2 (:delete res))))

7
backend/test/backend_tests/rpc_file_thumbnails_test.clj
View File

@ -85,7 +85,7 @@
(t/is (map? (:result out))))
;; run the task again
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:minutes 31}))]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! "storage-gc-touched" {}))]
(t/is (= 2 (:freeze res))))
@ -136,7 +136,7 @@
(t/is (some? (sto/get-object storage (:media-id row2))))
;; run the task again
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:minutes 31}))]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 1 (:delete res)))
(t/is (= 0 (:freeze res))))
@ -235,7 +235,8 @@
(t/is (= (:object-id data1) (:object-id row)))
(t/is (uuid? (:media-id row1))))
(let [result (th/run-task! :storage-gc-touched {})]
(let [result (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 1 (:delete result))))
;; Check if storage objects still exists after file-gc

71
backend/test/backend_tests/rpc_font_test.clj
View File

@ -165,7 +165,8 @@
;; (th/print-result! out)
(t/is (nil? (:error out))))
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 6 (:freeze res))))
(let [params {::th/type :delete-font
@ -177,14 +178,16 @@
(t/is (nil? (:error out)))
(t/is (nil? (:result out))))
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 0 (:freeze res)))
(t/is (= 0 (:delete res))))
(binding [ct/*clock* (ct/fixed-clock (ct/in-future {:days 8}))]
(let [res (th/run-task! :objects-gc {})]
(t/is (= 2 (:processed res))))
(t/is (= 2 (:processed res)))))
(binding [ct/*clock* (ct/fixed-clock (ct/in-future {:days 8 :hours 3}))]
(let [res (th/run-task! :storage-gc-touched {})]
(t/is (= 0 (:freeze res)))
(t/is (= 6 (:delete res)))))))
@ -226,7 +229,8 @@
;; (th/print-result! out)
(t/is (nil? (:error out))))
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 6 (:freeze res))))
(let [params {::th/type :delete-font
@ -238,14 +242,16 @@
(t/is (nil? (:error out)))
(t/is (nil? (:result out))))
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 0 (:freeze res)))
(t/is (= 0 (:delete res))))
(binding [ct/*clock* (ct/fixed-clock (ct/in-future {:days 8}))]
(let [res (th/run-task! :objects-gc {})]
(t/is (= 1 (:processed res))))
(t/is (= 1 (:processed res)))))
(binding [ct/*clock* (ct/fixed-clock (ct/in-future {:days 8 :hours 3}))]
(let [res (th/run-task! :storage-gc-touched {})]
(t/is (= 0 (:freeze res)))
(t/is (= 3 (:delete res)))))))
@ -255,57 +261,42 @@
team-id (:default-team-id prof)
proj-id (:default-project-id prof)
font-id (uuid/custom 10 1)
data1 (-> (io/resource "backend_tests/test_files/font-1.woff")
(io/read*))
data2 (-> (io/resource "backend_tests/test_files/font-2.woff")
(io/read*))
params1 {::th/type :create-font-variant
::rpc/profile-id (:id prof)
:team-id team-id
:font-id font-id
:font-family "somefont"
:font-weight 400
:font-style "normal"
:data {"font/woff" data1}}
params2 {::th/type :create-font-variant
::rpc/profile-id (:id prof)
:team-id team-id
:font-id font-id
:font-family "somefont"
:font-weight 500
:font-style "normal"
:data {"font/woff" data2}}
data1 (-> (io/resource "backend_tests/test_files/font-1.woff") (io/read*))
data2 (-> (io/resource "backend_tests/test_files/font-2.woff") (io/read*))
params1 {::th/type :create-font-variant ::rpc/profile-id (:id prof)
:team-id team-id :font-id font-id :font-family "somefont"
:font-weight 400 :font-style "normal" :data {"font/woff" data1}}
params2 {::th/type :create-font-variant ::rpc/profile-id (:id prof)
:team-id team-id :font-id font-id :font-family "somefont"
:font-weight 500 :font-style "normal" :data {"font/woff" data2}}
out1 (th/command! params1)
out2 (th/command! params2)]
;; (th/print-result! out1)
(t/is (nil? (:error out1)))
(t/is (nil? (:error out2)))
(let [res (th/run-task! :storage-gc-touched {})]
;; freeze with hours 3 clock
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 6 (:freeze res))))
(let [params {::th/type :delete-font-variant
::rpc/profile-id (:id prof)
:team-id team-id
:id (-> out1 :result :id)}
(let [params {::th/type :delete-font-variant ::rpc/profile-id (:id prof)
:team-id team-id :id (-> out1 :result :id)}
out (th/command! params)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(t/is (nil? (:result out))))
(let [res (th/run-task! :storage-gc-touched {})]
;; no-op with hours 3 clock (nothing touched yet)
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 0 (:freeze res)))
(t/is (= 0 (:delete res))))
;; objects-gc at days 8, then storage-gc-touched at days 8 + 3h
(binding [ct/*clock* (ct/fixed-clock (ct/in-future {:days 8}))]
(let [res (th/run-task! :objects-gc {})]
(t/is (= 1 (:processed res))))
(t/is (= 1 (:processed res)))))
(binding [ct/*clock* (ct/fixed-clock (ct/in-future {:days 8 :hours 3}))]
(let [res (th/run-task! :storage-gc-touched {})]
(t/is (= 0 (:freeze res)))
(t/is (= 3 (:delete res)))))))

331
backend/test/backend_tests/rpc_media_test.clj
View File

@ -6,9 +6,7 @@
(ns backend-tests.rpc-media-test
(:require
[app.common.time :as ct]
[app.common.uuid :as uuid]
[app.db :as db]
[app.http.client :as http]
[app.media :as media]
[app.rpc :as-alias rpc]
@ -16,7 +14,10 @@
[backend-tests.helpers :as th]
[clojure.test :as t]
[datoteka.fs :as fs]
[mockery.core :refer [with-mocks]]))
[datoteka.io :as io]
[mockery.core :refer [with-mocks]])
(:import
java.io.RandomAccessFile))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
@ -260,7 +261,7 @@
:is-shared false})
_ (th/db-update! :file
{:deleted-at (ct/now)}
{:deleted-at (app.common.time/now)}
{:id (:id file)})
mfile {:filename "sample.jpg"
@ -378,3 +379,325 @@
(t/is (some? err))
(t/is (= :validation (:type (ex-data err))))
(t/is (= :unable-to-download-image (:code (ex-data err))))))))
;; --------------------------------------------------------------------
;; Helpers for chunked-upload tests
;; --------------------------------------------------------------------
(defn- split-file-into-chunks
"Splits the file at `path` into byte-array chunks of at most
`chunk-size` bytes. Returns a vector of byte arrays."
[path chunk-size]
(let [file (RandomAccessFile. (str path) "r")
length (.length file)]
(try
(loop [offset 0 chunks []]
(if (>= offset length)
chunks
(let [remaining (- length offset)
size (min chunk-size remaining)
buf (byte-array size)]
(.seek file offset)
(.readFully file buf)
(recur (+ offset size) (conj chunks buf)))))
(finally
(.close file)))))
(defn- make-chunk-mfile
"Writes `data` (byte array) to a tempfile and returns a map
compatible with `media/schema:upload`."
[data mtype]
(let [tmp (fs/create-tempfile :dir "/tmp/penpot" :prefix "test-chunk-")]
(io/write* tmp data)
{:filename "chunk"
:path tmp
:mtype mtype
:size (alength data)}))
;; --------------------------------------------------------------------
;; Chunked-upload tests
;; --------------------------------------------------------------------
(defn- create-session!
"Creates an upload session for `prof` with `total-chunks`. Returns the session-id UUID."
[prof total-chunks]
(let [out (th/command! {::th/type :create-upload-session
::rpc/profile-id (:id prof)
:total-chunks total-chunks})]
(t/is (nil? (:error out)))
(:session-id (:result out))))
(t/deftest chunked-upload-happy-path
(let [prof (th/create-profile* 1)
_ (th/create-project* 1 {:profile-id (:id prof)
:team-id (:default-team-id prof)})
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof)
:is-shared false})
source-path (th/tempfile "backend_tests/test_files/sample.jpg")
chunks (split-file-into-chunks source-path 110000) ; ~107 KB each
mtype "image/jpeg"
total-size (reduce + (map alength chunks))
session-id (create-session! prof (count chunks))]
(t/is (= 3 (count chunks)))
;; --- 1. Upload chunks ---
(doseq [[idx chunk-data] (map-indexed vector chunks)]
(let [mfile (make-chunk-mfile chunk-data mtype)
out (th/command! {::th/type :upload-chunk
::rpc/profile-id (:id prof)
:session-id session-id
:index idx
:content mfile})]
(t/is (nil? (:error out)))
(t/is (= session-id (:session-id (:result out))))
(t/is (= idx (:index (:result out))))))
;; --- 2. Assemble ---
(let [assemble-out (th/command! {::th/type :assemble-file-media-object
::rpc/profile-id (:id prof)
:session-id session-id
:file-id (:id file)
:is-local true
:name "assembled-image"
:mtype mtype})]
(t/is (nil? (:error assemble-out)))
(let [{:keys [media-id thumbnail-id] :as result} (:result assemble-out)]
(t/is (= (:id file) (:file-id result)))
(t/is (= 800 (:width result)))
(t/is (= 800 (:height result)))
(t/is (= mtype (:mtype result)))
(t/is (uuid? media-id))
(t/is (uuid? thumbnail-id))
(let [storage (:app.storage/storage th/*system*)
mobj1 (sto/get-object storage media-id)
mobj2 (sto/get-object storage thumbnail-id)]
(t/is (sto/object? mobj1))
(t/is (sto/object? mobj2))
(t/is (= total-size (:size mobj1))))))))
(t/deftest chunked-upload-idempotency
(let [prof (th/create-profile* 1)
_ (th/create-project* 1 {:profile-id (:id prof)
:team-id (:default-team-id prof)})
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof)
:is-shared false})
media-id (uuid/next)
source-path (th/tempfile "backend_tests/test_files/sample.jpg")
chunks (split-file-into-chunks source-path 312043) ; single chunk = whole file
mtype "image/jpeg"
mfile (make-chunk-mfile (first chunks) mtype)
session-id (create-session! prof 1)]
(th/command! {::th/type :upload-chunk
::rpc/profile-id (:id prof)
:session-id session-id
:index 0
:content mfile})
;; First assemble succeeds; session row is deleted afterwards
(let [out1 (th/command! {::th/type :assemble-file-media-object
::rpc/profile-id (:id prof)
:session-id session-id
:file-id (:id file)
:is-local true
:name "sample"
:mtype mtype
:id media-id})]
(t/is (nil? (:error out1)))
(t/is (= media-id (:id (:result out1)))))
;; Second assemble with the same session-id must fail because the
;; session row has been deleted after the first assembly
(let [out2 (th/command! {::th/type :assemble-file-media-object
::rpc/profile-id (:id prof)
:session-id session-id
:file-id (:id file)
:is-local true
:name "sample"
:mtype mtype
:id media-id})]
(t/is (some? (:error out2)))
(t/is (= :not-found (-> out2 :error ex-data :type)))
(t/is (= :object-not-found (-> out2 :error ex-data :code))))))
(t/deftest chunked-upload-no-permission
;; A second profile must not be able to upload chunks into a session
;; that belongs to another profile: the DB lookup includes profile-id,
;; so the session will not be found.
(let [prof1 (th/create-profile* 1)
prof2 (th/create-profile* 2)
session-id (create-session! prof1 1)
source-path (th/tempfile "backend_tests/test_files/sample.jpg")
mfile {:filename "sample.jpg"
:path source-path
:mtype "image/jpeg"
:size 312043}
;; prof2 tries to upload a chunk into prof1's session
out (th/command! {::th/type :upload-chunk
::rpc/profile-id (:id prof2)
:session-id session-id
:index 0
:content mfile})]
(t/is (some? (:error out)))
(t/is (= :not-found (-> out :error ex-data :type)))))
(t/deftest chunked-upload-invalid-media-type
(let [prof (th/create-profile* 1)
_ (th/create-project* 1 {:profile-id (:id prof)
:team-id (:default-team-id prof)})
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof)
:is-shared false})
session-id (create-session! prof 1)
source-path (th/tempfile "backend_tests/test_files/sample.jpg")
mfile {:filename "sample.jpg"
:path source-path
:mtype "image/jpeg"
:size 312043}]
(th/command! {::th/type :upload-chunk
::rpc/profile-id (:id prof)
:session-id session-id
:index 0
:content mfile})
;; Assemble with a wrong mtype should fail validation
(let [out (th/command! {::th/type :assemble-file-media-object
::rpc/profile-id (:id prof)
:session-id session-id
:file-id (:id file)
:is-local true
:name "bad-type"
:mtype "application/octet-stream"})]
(t/is (some? (:error out)))
(t/is (= :validation (-> out :error ex-data :type))))))
(t/deftest chunked-upload-missing-chunks
(let [prof (th/create-profile* 1)
_ (th/create-project* 1 {:profile-id (:id prof)
:team-id (:default-team-id prof)})
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof)
:is-shared false})
;; Session expects 3 chunks
session-id (create-session! prof 3)
source-path (th/tempfile "backend_tests/test_files/sample.jpg")
mfile {:filename "sample.jpg"
:path source-path
:mtype "image/jpeg"
:size 312043}]
;; Upload only 1 chunk
(th/command! {::th/type :upload-chunk
::rpc/profile-id (:id prof)
:session-id session-id
:index 0
:content mfile})
;; Assemble: session says 3 expected, only 1 stored → :missing-chunks
(let [out (th/command! {::th/type :assemble-file-media-object
::rpc/profile-id (:id prof)
:session-id session-id
:file-id (:id file)
:is-local true
:name "incomplete"
:mtype "image/jpeg"})]
(t/is (some? (:error out)))
(t/is (= :validation (-> out :error ex-data :type)))
(t/is (= :missing-chunks (-> out :error ex-data :code))))))
(t/deftest chunked-upload-session-not-found
(let [prof (th/create-profile* 1)
_ (th/create-project* 1 {:profile-id (:id prof)
:team-id (:default-team-id prof)})
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof)
:is-shared false})
bogus-id (uuid/next)]
;; Assemble with a session-id that was never created
(let [out (th/command! {::th/type :assemble-file-media-object
::rpc/profile-id (:id prof)
:session-id bogus-id
:file-id (:id file)
:is-local true
:name "ghost"
:mtype "image/jpeg"})]
(t/is (some? (:error out)))
(t/is (= :not-found (-> out :error ex-data :type)))
(t/is (= :object-not-found (-> out :error ex-data :code))))))
(t/deftest chunked-upload-over-chunk-limit
;; Verify that requesting more chunks than the configured maximum
;; (quotes-upload-chunks-per-session) raises a :restriction error.
(with-mocks [mock {:target 'app.config/get
:return (th/config-get-mock
{:quotes-upload-chunks-per-session 3})}]
(let [prof (th/create-profile* 1)
out (th/command! {::th/type :create-upload-session
::rpc/profile-id (:id prof)
:total-chunks 4})]
(t/is (some? (:error out)))
(t/is (= :restriction (-> out :error ex-data :type)))
(t/is (= :max-quote-reached (-> out :error ex-data :code)))
(t/is (= "upload-chunks-per-session" (-> out :error ex-data :target))))))
(t/deftest chunked-upload-invalid-chunk-index
;; Both a negative index and an index >= total-chunks must be
;; rejected with a :validation / :invalid-chunk-index error.
(let [prof (th/create-profile* 1)
session-id (create-session! prof 2)
source-path (th/tempfile "backend_tests/test_files/sample.jpg")
mfile {:filename "sample.jpg"
:path source-path
:mtype "image/jpeg"
:size 312043}]
;; index == total-chunks (out of range)
(let [out (th/command! {::th/type :upload-chunk
::rpc/profile-id (:id prof)
:session-id session-id
:index 2
:content mfile})]
(t/is (some? (:error out)))
(t/is (= :validation (-> out :error ex-data :type)))
(t/is (= :invalid-chunk-index (-> out :error ex-data :code))))
;; negative index
(let [out (th/command! {::th/type :upload-chunk
::rpc/profile-id (:id prof)
:session-id session-id
:index -1
:content mfile})]
(t/is (some? (:error out)))
(t/is (= :validation (-> out :error ex-data :type)))
(t/is (= :invalid-chunk-index (-> out :error ex-data :code))))))
(t/deftest chunked-upload-sessions-per-profile-quota
;; With the session limit set to 2, creating a third session for the
;; same profile must fail with :restriction / :max-quote-reached.
;; The :quotes flag is already enabled by the test fixture.
(with-mocks [mock {:target 'app.config/get
:return (th/config-get-mock
{:quotes-upload-sessions-per-profile 2})}]
(let [prof (th/create-profile* 1)]
;; First two sessions succeed
(create-session! prof 1)
(create-session! prof 1)
;; Third session must be rejected
(let [out (th/command! {::th/type :create-upload-session
::rpc/profile-id (:id prof)
:total-chunks 1})]
(t/is (some? (:error out)))
(t/is (= :restriction (-> out :error ex-data :type)))
(t/is (= :max-quote-reached (-> out :error ex-data :code)))))))

17
backend/test/backend_tests/storage_test.clj
View File

@ -169,7 +169,8 @@
(t/is (= 2 (:count res))))
;; run the touched gc task
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 2 (:freeze res)))
(t/is (= 0 (:delete res))))
@ -229,7 +230,8 @@
(t/is (nil? (:error out2)))
;; run the touched gc task
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 5 (:freeze res)))
(t/is (= 0 (:delete res)))
@ -249,7 +251,8 @@
(th/db-exec-one! ["update storage_object set touched_at=?" (ct/now)])
;; Run the task again
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 2 (:freeze res)))
(t/is (= 3 (:delete res))))
@ -295,7 +298,8 @@
(th/db-exec! ["update storage_object set touched_at=?" (ct/now)])
;; run the touched gc task
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 2 (:freeze res)))
(t/is (= 0 (:delete res))))
@ -310,7 +314,8 @@
(t/is (= 2 (:processed res))))
;; run the touched gc task
(let [res (th/run-task! :storage-gc-touched {})]
(let [res (binding [ct/*clock* (ct/fixed-clock (ct/in-future {:hours 3}))]
(th/run-task! :storage-gc-touched {}))]
(t/is (= 0 (:freeze res)))
(t/is (= 2 (:delete res))))
@ -336,7 +341,7 @@
(t/is (= 0 (:delete res)))))
(binding [ct/*clock* (ct/fixed-clock (ct/plus now {:minutes 1}))]
(binding [ct/*clock* (ct/fixed-clock (ct/plus now {:hours 3}))]
(let [res (th/run-task! :storage-gc-touched {})]
(t/is (= 0 (:freeze res)))
(t/is (= 1 (:delete res)))))

59
common/src/app/common/colors.cljc
View File

@ -487,62 +487,3 @@
b (+ (* bh 100) (* bv 10))]
(compare a b)))
(defn interpolate-color
[c1 c2 offset]
(cond
(<= offset (:offset c1)) (assoc c1 :offset offset)
(>= offset (:offset c2)) (assoc c2 :offset offset)
:else
(let [tr-offset (/ (- offset (:offset c1)) (- (:offset c2) (:offset c1)))
[r1 g1 b1] (hex->rgb (:color c1))
[r2 g2 b2] (hex->rgb (:color c2))
a1 (:opacity c1)
a2 (:opacity c2)
r (+ r1 (* (- r2 r1) tr-offset))
g (+ g1 (* (- g2 g1) tr-offset))
b (+ b1 (* (- b2 b1) tr-offset))
a (+ a1 (* (- a2 a1) tr-offset))]
{:color (rgb->hex [r g b])
:opacity a
:r r
:g g
:b b
:alpha a
:offset offset})))
(defn- offset-spread
[from to num]
(->> (range 0 num)
(map #(mth/precision (+ from (* (/ (- to from) (dec num)) %)) 2))))
(defn uniform-spread?
"Checks if the gradient stops are spread uniformly"
[stops]
(let [cs (count stops)
from (first stops)
to (last stops)
expect-vals (offset-spread (:offset from) (:offset to) cs)
calculate-expected
(fn [expected-offset stop]
(and (mth/close? (:offset stop) expected-offset)
(let [ec (interpolate-color from to expected-offset)]
(and (= (:color ec) (:color stop))
(= (:opacity ec) (:opacity stop))))))]
(->> (map calculate-expected expect-vals stops)
(every? true?))))
(defn uniform-spread
"Assign an uniform spread to the offset values for the gradient"
[from to num-stops]
(->> (offset-spread (:offset from) (:offset to) num-stops)
(mapv (fn [offset]
(interpolate-color from to offset)))))
(defn interpolate-gradient
[stops offset]
(let [idx (d/index-of-pred stops #(<= offset (:offset %)))
start (if (= idx 0) (first stops) (get stops (dec idx)))
end (if (nil? idx) (last stops) (get stops idx))]
(interpolate-color start end offset)))

74
common/src/app/common/data.cljc
View File

@ -5,7 +5,7 @@
;; Copyright (c) KALEIDOS INC
(ns app.common.data
"A collection if helpers for working with data structures and other
"A collection of helpers for working with data structures and other
data resources."
(:refer-clojure :exclude [read-string hash-map merge name update-vals
parse-double group-by iteration concat mapcat
@ -143,7 +143,7 @@
(oassoc-in o (cons k ks) v)))
(defn vec2
"Creates a optimized vector compatible type of length 2 backed
"Creates an optimized vector compatible type of length 2 backed
internally with MapEntry impl because it has faster access method
for its fields."
[o1 o2]
@ -252,13 +252,13 @@
([items] (enumerate items 0))
([items start]
(loop [idx start
items items
items (seq items)
res (transient [])]
(if (empty? items)
(persistent! res)
(if items
(recur (inc idx)
(rest items)
(conj! res [idx (first items)]))))))
(next items)
(conj! res [idx (first items)]))
(persistent! res)))))
(defn group-by
([kf coll] (group-by kf identity [] coll))
@ -291,15 +291,12 @@
(defn index-of-pred
[coll pred]
(loop [c (first coll)
coll (rest coll)
(loop [s (seq coll)
index 0]
(if (nil? c)
nil
(if (pred c)
(when s
(if (pred (first s))
index
(recur (first coll)
(rest coll)
(recur (next s)
(inc index))))))
(defn index-of
@ -377,7 +374,7 @@
(assoc object key nil)
(nil? value)
(dissoc object key value)
(dissoc object key)
:else
(assoc object key value)))
@ -396,7 +393,7 @@
(subvec v (inc index))))
(defn without-obj
"Clear collection from specified obj and without nil values."
"Return a vector with all elements equal to `o` removed."
[coll o]
(into [] (filter #(not= % o)) coll))
@ -404,7 +401,7 @@
(map vector col1 col2))
(defn zip-all
"Return a zip of both collections, extended to the lenght of the longest one,
"Return a zip of both collections, extended to the length of the longest one,
and padding the shorter one with nils as needed."
[col1 col2]
(let [diff (- (count col1) (count col2))]
@ -423,9 +420,9 @@
coll)))
(defn removev
"Returns a vector of the items in coll for which (fn item) returns logical false"
[fn coll]
(filterv (comp not fn) coll))
"Returns a vector of the items in coll for which (pred item) returns logical false"
[pred coll]
(filterv (comp not pred) coll))
(defn filterm
"Filter values of a map that satisfy a predicate"
@ -443,7 +440,7 @@
Optional parameters:
`pred?` A predicate that if not satisfied won't process the pair
`target?` A collection that will be used as seed to be stored
`target` A collection that will be used as seed to be stored
Example:
(map-perm vector [1 2 3 4]) => [[1 2] [1 3] [1 4] [2 3] [2 4] [3 4]]"
@ -602,12 +599,9 @@
(let [do-map
(fn [entry]
(let [[k v] (mfn entry)]
(cond
(or (vector? v) (map? v))
(if (or (vector? v) (map? v))
[k (deep-mapm mfn v)]
:else
(mfn [k v]))))]
[k v])))]
(cond
(map? m)
(into {} (map do-map) m)
@ -724,7 +718,7 @@
(defn nan?
[v]
#?(:cljs (js/isNaN v)
:clj (not= v v)))
:clj (and (number? v) (Double/isNaN v))))
(defn- impl-parse-integer
[v]
@ -788,7 +782,8 @@
(not (js/isNaN v))
(not (js/isNaN (parse-double v))))
:clj (not= (parse-double v :nan) :nan)))
:clj (and (string? v)
(not= (parse-double v :nan) :nan))))
(defn read-string
[v]
@ -958,7 +953,7 @@
(assoc diff key (map-diff v1 v2))
:else
(assoc diff key [(get m1 key) (get m2 key)]))))]
(assoc diff key [v1 v2]))))]
(->> keys
(reduce diff-attr {}))))
@ -1123,8 +1118,7 @@
([value {:keys [precision] :or {precision 2}}]
(let [value (if (string? value) (parse-double value) value)]
(when (num? value)
(let [value (format-precision value precision)]
(str value))))))
(format-precision value precision)))))
(defn- natural-sort-key
"Splits a string into a sequence of alternating string and number segments,
@ -1217,20 +1211,20 @@
"Wrapper around subvec so it doesn't throw an exception but returns nil instead"
([v start]
(when (and (some? v)
(> start 0) (< start (count v)))
(>= start 0) (< start (count v)))
(subvec v start)))
([v start end]
(let [size (count v)]
(when (and (some? v)
(>= start 0) (< start size)
(>= end 0) (<= start end) (<= end size))
(subvec v start end)))))
(when (some? v)
(let [size (count v)]
(when (and (>= start 0) (< start size)
(>= end 0) (<= start end) (<= end size))
(subvec v start end))))))
(defn append-class
[class current-class]
(str (if (some? class) (str class " ") "")
current-class))
(if (seq class)
(str class " " current-class)
current-class))
(defn nth-index-of*
"Finds the nth occurrence of `char` in `string`, searching either forward or backward.

6
common/src/app/common/files/builder.cljc
View File

@ -356,7 +356,7 @@
:code :empty-children
:hint "expected a group with at least one shape for creating a bool"))
(let [head (if (= type :difference)
(let [head (if (= (:bool-type bool-shape) :difference)
(first children)
(last children))
fills (if (and (contains? head :svg-attrs) (empty? (:fills head)))
@ -364,7 +364,7 @@
(get head :fills))]
(-> bool-shape
(assoc :fills fills)
(assoc :stroks (get head :strokes))))))
(assoc :strokes (get head :strokes))))))
(defn add-bool
[state params]
@ -576,7 +576,7 @@
{:keys [id width height name]}
(-> params
(update :id default-uuid)
(check-add-file-media params))]
(check-add-file-media))]
(-> state
(update ::blobs assoc media-id blob)

2
common/src/app/common/files/changes.cljc
View File

@ -439,7 +439,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- without-obj
"Clear collection from specified obj and without nil values."
"Return a vector with all elements equal to `o` removed."
[coll o]
(into [] (filter #(not= % o)) coll))

85
common/src/app/common/fressian.clj
View File

@ -118,6 +118,36 @@
(d/ordered-map)
(partition-all 2 (seq kvs)))))
(defn- adapt-write-handler
[{:keys [name class wfn]}]
[class {name (reify WriteHandler
(write [_ w o]
(wfn name w o)))}])
(defn- adapt-read-handler
[{:keys [name rfn]}]
[name (reify ReadHandler
(read [_ rdr _ _]
(rfn rdr)))])
(defn- merge-handlers
[m1 m2]
(-> (merge m1 m2)
(d/without-nils)))
(def ^:private
xf:adapt-write-handler
(comp
(filter :wfn)
(map adapt-write-handler)))
(def ^:private
xf:adapt-read-handler
(comp
(filter :rfn)
(map adapt-read-handler)))
(def ^:dynamic *write-handler-lookup* nil)
(def ^:dynamic *read-handler-lookup* nil)
@ -126,36 +156,39 @@
(defn add-handlers!
[& handlers]
(letfn [(adapt-write-handler [{:keys [name class wfn]}]
[class {name (reify WriteHandler
(write [_ w o]
(wfn name w o)))}])
(let [write-handlers'
(into {} xf:adapt-write-handler handlers)
(adapt-read-handler [{:keys [name rfn]}]
[name (reify ReadHandler
(read [_ rdr _ _]
(rfn rdr)))])
read-handlers'
(into {} xf:adapt-read-handler handlers)
(merge-and-clean [m1 m2]
(-> (merge m1 m2)
(d/without-nils)))]
write-handlers'
(swap! write-handlers merge-handlers write-handlers')
(let [whs (into {}
(comp
(filter :wfn)
(map adapt-write-handler))
handlers)
rhs (into {}
(comp
(filter :rfn)
(map adapt-read-handler))
handlers)
cwh (swap! write-handlers merge-and-clean whs)
crh (swap! read-handlers merge-and-clean rhs)]
read-handlers'
(swap! read-handlers merge-handlers read-handlers')]
(alter-var-root #'*write-handler-lookup* (constantly (-> cwh fres/associative-lookup fres/inheritance-lookup)))
(alter-var-root #'*read-handler-lookup* (constantly (-> crh fres/associative-lookup)))
nil)))
(alter-var-root #'*write-handler-lookup*
(constantly
(-> write-handlers' fres/associative-lookup fres/inheritance-lookup)))
(alter-var-root #'*read-handler-lookup*
(constantly (-> read-handlers' fres/associative-lookup)))
nil))
(defn overwrite-read-handlers
[& handlers]
(->> (into {} xf:adapt-read-handler handlers)
(merge-handlers @read-handlers)
(fres/associative-lookup)))
(defn overwrite-write-handlers
[& handlers]
(->> (into {} xf:adapt-write-handler handlers)
(merge-handlers @write-handlers)
(fres/associative-lookup)
(fres/inheritance-lookup)))
(defn write-char
[n w o]

4
common/src/app/common/geom/bounds_map.cljc
View File

@ -79,10 +79,10 @@
(loop [new-ids
(->> (cfh/get-parent-seq objects cid)
(take-while #(and (cfh/group-like-shape? %)
(not (.has ids %))))
(not (.has ids (:id %)))))
(seq))]
(when (some? new-ids)
(.add ids (first new-ids))
(.add ids (:id (first new-ids)))
(recur (next new-ids))))
(recur (next base-ids)))))
ids)))

4
common/src/app/common/geom/matrix.cljc
View File

@ -101,7 +101,7 @@
(dm/get-prop o :c) ","
(dm/get-prop o :d) ","
(dm/get-prop o :e) ","
(dm/get-prop o :f) ",")
(dm/get-prop o :f))
o))
(defn- matrix->json
@ -359,8 +359,6 @@
(th-eq m1e m2e)
(th-eq m1f m2f))))
(defmethod pp/simple-dispatch Matrix [obj] (pr obj))
(defn transform-in [pt mtx]
(if (and (some? pt) (some? mtx))
(-> (matrix)

8
common/src/app/common/geom/point.cljc
View File

@ -151,7 +151,7 @@
(dm/get-prop p2 :y))))
(defn multiply
"Returns the subtraction of the supplied value to both
"Returns the multiplication of the supplied value to both
coordinates of the point as a new point."
[p1 p2]
(assert (and (point? p1)
@ -509,12 +509,10 @@
(let [old-length (length vector)]
(scale vector (/ new-length old-length))))
;; FIXME: perfromance
(defn abs
[point]
(-> point
(update :x mth/abs)
(update :y mth/abs)))
(pos->Point (mth/abs (dm/get-prop point :x))
(mth/abs (dm/get-prop point :y))))
;; --- Debug

22
common/src/app/common/geom/rect.cljc
View File

@ -119,12 +119,14 @@
(defn update-rect
[rect type]
(case type
:size
(:size :position)
(let [x (dm/get-prop rect :x)
y (dm/get-prop rect :y)
w (dm/get-prop rect :width)
h (dm/get-prop rect :height)]
(assoc rect
:x1 x
:y1 y
:x2 (+ x w)
:y2 (+ y h)))
@ -137,19 +139,7 @@
:x (mth/min x1 x2)
:y (mth/min y1 y2)
:width (mth/abs (- x2 x1))
:height (mth/abs (- y2 y1))))
;; FIXME: looks unused
:position
(let [x (dm/get-prop rect :x)
y (dm/get-prop rect :y)
w (dm/get-prop rect :width)
h (dm/get-prop rect :height)]
(assoc rect
:x1 x
:y1 y
:x2 (+ x w)
:y2 (+ y h)))))
:height (mth/abs (- y2 y1))))))
(defn update-rect!
[rect type]
@ -382,8 +372,8 @@
([xp1 yp1 xp2 yp2]
(make-rect (mth/min xp1 xp2)
(mth/min yp1 yp2)
(abs (- xp1 xp2))
(abs (- yp1 yp2)))))
(mth/abs (- xp1 xp2))
(mth/abs (- yp1 yp2)))))
(defn clip-rect
[selrect bounds]

2
common/src/app/common/geom/shapes/constraints.cljc
View File

@ -234,7 +234,7 @@
after-side-vector (side-vector axis parent-points-after)]
(ctm/move-modifiers (displacement center-before center-after before-side-vector after-side-vector))))
(defmethod constraint-modifier :default [_ _ _ _ _]
(defmethod constraint-modifier :default [_ _ _ _ _ _]
[])
(def const->type+axis

2
common/src/app/common/geom/shapes/flex_layout/drop_area.cljc
View File

@ -81,7 +81,7 @@
h-center? (and row? (ctl/h-center? frame))
h-end? (and row? (ctl/h-end? frame))
v-center? (and col? (ctl/v-center? frame))
v-end? (and row? (ctl/v-end? frame))
v-end? (and col? (ctl/v-end? frame))
center (gco/shape->center frame)
start-p (gmt/transform-point-center start-p center transform-inverse)

3
common/src/app/common/geom/shapes/flex_layout/layout_data.cljc
View File

@ -369,9 +369,6 @@
(cond (and col? space-evenly?)
0
(and col? space-evenly? auto-height?)
0
(and col? space-around?)
(/ (max layout-gap-row (/ (- height line-height) num-children)) 2)

2
common/src/app/common/geom/shapes/flex_layout/positions.cljc
View File

@ -61,7 +61,7 @@
(gpt/add (hv free-width-gap))
around?
(gpt/add (hv (max lines-gap-col (/ free-width num-lines) 2)))
(gpt/add (hv (max lines-gap-col (/ free-width num-lines 2))))
evenly?
(gpt/add (hv (max lines-gap-col (/ free-width (inc num-lines)))))))))

30
common/src/app/common/geom/shapes/grid_layout/layout_data.cljc
View File

@ -331,7 +331,7 @@
;; Apply the allocations to the tracks
track-list
(into []
(map-indexed #(update %2 :size max (get allocated %1)))
(map-indexed #(update %2 :size max (get allocated %1 0)))
track-list)]
track-list))
@ -381,7 +381,7 @@
;; Apply the allocations to the tracks
track-list
(into []
(map-indexed #(update %2 :size max (get allocate-fr-tracks %1)))
(map-indexed #(update %2 :size max (get allocate-fr-tracks %1 0)))
track-list)]
track-list))
@ -474,8 +474,8 @@
min-column-fr (min-fr-value column-tracks)
min-row-fr (min-fr-value row-tracks)
column-fr (if auto-width? min-column-fr (mth/finite (/ fr-column-space column-frs) 0))
row-fr (if auto-height? min-row-fr (mth/finite (/ fr-row-space row-frs) 0))
column-fr (if auto-width? min-column-fr (if (zero? column-frs) 0 (mth/finite (/ fr-column-space column-frs) 0)))
row-fr (if auto-height? min-row-fr (if (zero? row-frs) 0 (mth/finite (/ fr-row-space row-frs) 0)))
column-tracks (set-fr-value column-tracks column-fr auto-width?)
row-tracks (set-fr-value row-tracks row-fr auto-height?)
@ -489,8 +489,8 @@
column-autos (tracks-total-autos column-tracks)
row-autos (tracks-total-autos row-tracks)
column-add-auto (/ auto-column-space column-autos)
row-add-auto (/ auto-row-space row-autos)
column-add-auto (if (zero? column-autos) 0 (/ auto-column-space column-autos))
row-add-auto (if (zero? row-autos) 0 (/ auto-row-space row-autos))
column-tracks (cond-> column-tracks
(= :stretch (:layout-justify-content parent))
@ -505,36 +505,38 @@
num-columns (count column-tracks)
column-gap
(case (:layout-justify-content parent)
(cond
auto-width?
column-gap
:space-evenly
(= :space-evenly (:layout-justify-content parent))
(max column-gap (/ (- bound-width column-total-size) (inc num-columns)))
:space-around
(= :space-around (:layout-justify-content parent))
(max column-gap (/ (- bound-width column-total-size) num-columns))
:space-between
(= :space-between (:layout-justify-content parent))
(max column-gap (if (= num-columns 1) column-gap (/ (- bound-width column-total-size) (dec num-columns))))
:else
column-gap)
num-rows (count row-tracks)
row-gap
(case (:layout-align-content parent)
(cond
auto-height?
row-gap
:space-evenly
(= :space-evenly (:layout-align-content parent))
(max row-gap (/ (- bound-height row-total-size) (inc num-rows)))
:space-around
(= :space-around (:layout-align-content parent))
(max row-gap (/ (- bound-height row-total-size) num-rows))
:space-between
(= :space-between (:layout-align-content parent))
(max row-gap (if (= num-rows 1) row-gap (/ (- bound-height row-total-size) (dec num-rows))))
:else
row-gap)
start-p

8
common/src/app/common/geom/shapes/intersect.cljc
View File

@ -55,16 +55,16 @@
(and (not= o1 o2) (not= o3 o4))
;; p1, q1 and p2 colinear and p2 lies on p1q1
(and (= o1 :coplanar) ^boolean (on-segment? p2 p1 q1))
(and (= o1 ::coplanar) ^boolean (on-segment? p2 p1 q1))
;; p1, q1 and q2 colinear and q2 lies on p1q1
(and (= o2 :coplanar) ^boolean (on-segment? q2 p1 q1))
(and (= o2 ::coplanar) ^boolean (on-segment? q2 p1 q1))
;; p2, q2 and p1 colinear and p1 lies on p2q2
(and (= o3 :coplanar) ^boolean (on-segment? p1 p2 q2))
(and (= o3 ::coplanar) ^boolean (on-segment? p1 p2 q2))
;; p2, q2 and p1 colinear and q1 lies on p2q2
(and (= o4 :coplanar) ^boolean (on-segment? q1 p2 q2)))))
(and (= o4 ::coplanar) ^boolean (on-segment? q1 p2 q2)))))
(defn points->lines
"Given a set of points for a polygon will return

8
common/src/app/common/geom/shapes/transforms.cljc
View File

@ -303,13 +303,13 @@
(neg? dot-x)
(update :flip-x not)
(neg? dot-x)
(update :rotation -)
(neg? dot-y)
(update :flip-y not)
(neg? dot-y)
;; Negate rotation only when an odd number of axes are flipped,
;; since flipping both axes is equivalent to a 180° rotation and
;; two negations would cancel each other out.
(not= (neg? dot-x) (neg? dot-y))
(update :rotation -))))
(defn- apply-transform-move

11
common/src/app/common/types/color.cljc
View File

@ -720,8 +720,10 @@
(defn- offset-spread
[from to num]
(->> (range 0 num)
(map #(mth/precision (+ from (* (/ (- to from) (dec num)) %)) 2))))
(if (<= num 1)
[from]
(->> (range 0 num)
(map #(mth/precision (+ from (* (/ (- to from) (dec num)) %)) 2)))))
(defn uniform-spread?
"Checks if the gradient stops are spread uniformly"
@ -750,6 +752,9 @@
(defn interpolate-gradient
[stops offset]
(let [idx (d/index-of-pred stops #(<= offset (:offset %)))
start (if (= idx 0) (first stops) (get stops (dec idx)))
start (cond
(nil? idx) (last stops)
(= idx 0) (first stops)
:else (get stops (dec idx)))
end (if (nil? idx) (last stops) (get stops idx))]
(interpolate-color start end offset)))

7
common/src/app/common/types/container.cljc
View File

@ -110,8 +110,9 @@
(let [shape (get objects id)]
(if (and (ctk/instance-head? shape) (seq children))
children
(into (conj children shape)
(mapcat #(get-children-rec children %) (:shapes shape))))))]
(let [children' (conj children shape)]
(into children'
(mapcat #(get-children-rec children' %) (:shapes shape)))))))]
(get-children-rec [] id)))
(defn get-component-shape
@ -444,7 +445,7 @@
(if (ctk/main-instance? shape)
[shape]
(if-let [children (cfh/get-children objects (:id shape))]
(mapcat collect-main-shapes children objects)
(mapcat #(collect-main-shapes % objects) children)
[])))
(defn get-component-from-shape

2
common/src/app/common/types/fills/impl.cljc
View File

@ -380,7 +380,7 @@
nil))
(-nth [_ i default]
(if (d/in-range? i size)
(if (d/in-range? size i)
(read-fill dbuffer mbuffer i)
default))

2
common/src/app/common/types/objects_map.cljc
View File

@ -278,7 +278,7 @@
(set! (.-cache this) (c/-assoc cache k v))
v)
(do
(set! (.-cache this) (assoc cache key nil))
(set! (.-cache this) (assoc cache k nil))
nil))))
(-lookup [this k not-found]

2
common/src/app/common/types/path/segment.cljc
View File

@ -812,7 +812,7 @@
:line-to
(recur (cond-> points
(and from-p to-p)
(-> (conj! move-p)
(-> (conj! from-p)
(conj! to-p)))
(not-empty (subvec content 1))
to-p

4
common/src/app/common/types/shape/layout.cljc
View File

@ -262,7 +262,7 @@
(or (nil? current) (= current-id parent-id))
false
(cfh/frame-shape? current-id)
(cfh/frame-shape? current)
(:layout current)
:else
@ -1475,7 +1475,7 @@
(update-in [:layout-grid-cells id-from]
assoc
:shapes (:shapes cell-to)
:podition (:position cell-to))
:position (:position cell-to))
(update-in [:layout-grid-cells id-to]
assoc
:shapes (:shapes cell-from)

1
common/src/app/common/types/token.cljc
View File

@ -357,7 +357,6 @@
(def typography-keys (set/union font-family-keys
font-size-keys
font-weight-keys
font-weight-keys
letter-spacing-keys
line-height-keys
text-case-keys

2
common/src/app/common/types/tokens_lib.cljc
View File

@ -1689,7 +1689,7 @@ Will return a value that matches this schema:
[value]
(let [process-shadow (fn [shadow]
(if (map? shadow)
(let [legacy-shadow-type (get "type" shadow)]
(let [legacy-shadow-type (get shadow "type")]
(-> shadow
(set/rename-keys {"x" :offset-x
"offsetX" :offset-x

135
common/test/common_tests/colors_test.cljc
View File

@ -9,91 +9,8 @@
#?(:cljs [goog.color :as gcolors])
[app.common.colors :as c]
[app.common.math :as mth]
[app.common.types.color :as colors]
[clojure.test :as t]))
(t/deftest valid-hex-color
(t/is (false? (colors/valid-hex-color? nil)))
(t/is (false? (colors/valid-hex-color? "")))
(t/is (false? (colors/valid-hex-color? "#")))
(t/is (false? (colors/valid-hex-color? "#qqqqqq")))
(t/is (true? (colors/valid-hex-color? "#aaa")))
(t/is (false? (colors/valid-hex-color? "#aaaa")))
(t/is (true? (colors/valid-hex-color? "#fabada"))))
(t/deftest valid-rgb-color
(t/is (false? (colors/valid-rgb-color? nil)))
(t/is (false? (colors/valid-rgb-color? "")))
(t/is (false? (colors/valid-rgb-color? "()")))
(t/is (true? (colors/valid-rgb-color? "(255, 30, 30)")))
(t/is (true? (colors/valid-rgb-color? "rgb(255, 30, 30)"))))
(t/deftest rgb-to-str
(t/is (= "rgb(1,2,3)" (colors/rgb->str [1 2 3])))
(t/is (= "rgba(1,2,3,4)" (colors/rgb->str [1 2 3 4]))))
(t/deftest rgb-to-hsv
;; (prn (colors/rgb->hsv [1 2 3]))
;; (prn (gcolors/rgbToHsv 1 2 3))
(t/is (= [210.0 0.6666666666666666 3.0] (colors/rgb->hsv [1.0 2.0 3.0])))
#?(:cljs (t/is (= (colors/rgb->hsv [1 2 3]) (vec (gcolors/rgbToHsv 1 2 3))))))
(t/deftest hsv-to-rgb
(t/is (= [1 2 3]
(colors/hsv->rgb [210 0.6666666666666666 3])))
#?(:cljs
(t/is (= (colors/hsv->rgb [210 0.6666666666666666 3])
(vec (gcolors/hsvToRgb 210 0.6666666666666666 3))))))
(t/deftest rgb-to-hex
(t/is (= "#010203" (colors/rgb->hex [1 2 3]))))
(t/deftest hex-to-rgb
(t/is (= [0 0 0] (colors/hex->rgb "#kkk")))
(t/is (= [1 2 3] (colors/hex->rgb "#010203"))))
(t/deftest format-hsla
(t/is (= "210, 50%, 0.78%, 1" (colors/format-hsla [210.0 0.5 0.00784313725490196 1])))
(t/is (= "220, 5%, 30%, 0.8" (colors/format-hsla [220.0 0.05 0.3 0.8]))))
(t/deftest format-rgba
(t/is (= "210, 199, 12, 0.08" (colors/format-rgba [210 199 12 0.08])))
(t/is (= "210, 199, 12, 1" (colors/format-rgba [210 199 12 1]))))
(t/deftest rgb-to-hsl
(t/is (= [210.0 0.5 0.00784313725490196] (colors/rgb->hsl [1 2 3])))
#?(:cljs (t/is (= (colors/rgb->hsl [1 2 3])
(vec (gcolors/rgbToHsl 1 2 3))))))
(t/deftest hsl-to-rgb
(t/is (= [1 2 3] (colors/hsl->rgb [210.0 0.5 0.00784313725490196])))
(t/is (= [210.0 0.5 0.00784313725490196] (colors/rgb->hsl [1 2 3])))
#?(:cljs (t/is (= (colors/hsl->rgb [210 0.5 0.00784313725490196])
(vec (gcolors/hslToRgb 210 0.5 0.00784313725490196))))))
(t/deftest expand-hex
(t/is (= "aaaaaa" (colors/expand-hex "a")))
(t/is (= "aaaaaa" (colors/expand-hex "aa")))
(t/is (= "aaaaaa" (colors/expand-hex "aaa")))
(t/is (= "aaaa" (colors/expand-hex "aaaa"))))
(t/deftest prepend-hash
(t/is "#aaa" (colors/prepend-hash "aaa"))
(t/is "#aaa" (colors/prepend-hash "#aaa")))
(t/deftest remove-hash
(t/is "aaa" (colors/remove-hash "aaa"))
(t/is "aaa" (colors/remove-hash "#aaa")))
(t/deftest color-string-pred
(t/is (true? (colors/color-string? "#aaa")))
(t/is (true? (colors/color-string? "(10,10,10)")))
(t/is (true? (colors/color-string? "rgb(10,10,10)")))
(t/is (true? (colors/color-string? "magenta")))
(t/is (false? (colors/color-string? nil)))
(t/is (false? (colors/color-string? "")))
(t/is (false? (colors/color-string? "kkkkkk"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; app.common.colors tests
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -387,55 +304,3 @@
(t/is (= 0.25 (c/reduce-range 0.3 4)))
(t/is (= 0.0 (c/reduce-range 0.0 10))))
;; --- Gradient helpers
(t/deftest ac-interpolate-color
(let [c1 {:color "#000000" :opacity 0.0 :offset 0.0}
c2 {:color "#ffffff" :opacity 1.0 :offset 1.0}]
;; At c1's offset → c1 with updated offset
(let [result (c/interpolate-color c1 c2 0.0)]
(t/is (= "#000000" (:color result)))
(t/is (= 0.0 (:opacity result))))
;; At c2's offset → c2 with updated offset
(let [result (c/interpolate-color c1 c2 1.0)]
(t/is (= "#ffffff" (:color result)))
(t/is (= 1.0 (:opacity result))))
;; At midpoint → gray
(let [result (c/interpolate-color c1 c2 0.5)]
(t/is (= "#7f7f7f" (:color result)))
(t/is (mth/close? (:opacity result) 0.5)))))
(t/deftest ac-uniform-spread
(let [c1 {:color "#000000" :opacity 0.0 :offset 0.0}
c2 {:color "#ffffff" :opacity 1.0 :offset 1.0}
stops (c/uniform-spread c1 c2 3)]
(t/is (= 3 (count stops)))
(t/is (= 0.0 (:offset (first stops))))
(t/is (mth/close? 0.5 (:offset (second stops))))
(t/is (= 1.0 (:offset (last stops))))))
(t/deftest ac-uniform-spread?
(let [c1 {:color "#000000" :opacity 0.0 :offset 0.0}
c2 {:color "#ffffff" :opacity 1.0 :offset 1.0}
stops (c/uniform-spread c1 c2 3)]
;; A uniformly spread result should pass the predicate
(t/is (true? (c/uniform-spread? stops))))
;; Manual non-uniform stops should not pass
(let [stops [{:color "#000000" :opacity 0.0 :offset 0.0}
{:color "#888888" :opacity 0.5 :offset 0.3}
{:color "#ffffff" :opacity 1.0 :offset 1.0}]]
(t/is (false? (c/uniform-spread? stops)))))
(t/deftest ac-interpolate-gradient
(let [stops [{:color "#000000" :opacity 0.0 :offset 0.0}
{:color "#ffffff" :opacity 1.0 :offset 1.0}]]
;; At start
(let [result (c/interpolate-gradient stops 0.0)]
(t/is (= "#000000" (:color result))))
;; At end
(let [result (c/interpolate-gradient stops 1.0)]
(t/is (= "#ffffff" (:color result))))
;; In the middle
(let [result (c/interpolate-gradient stops 0.5)]
(t/is (= "#7f7f7f" (:color result))))))

60
common/test/common_tests/data_test.cljc
View File

@ -399,6 +399,8 @@
(t/is (= [2 3] (d/safe-subvec [1 2 3 4] 1 3)))
;; single arg — from index to end
(t/is (= [2 3 4] (d/safe-subvec [1 2 3 4] 1)))
;; start=0 returns the full vector
(t/is (= [1 2 3 4] (d/safe-subvec [1 2 3 4] 0)))
;; out-of-range returns nil
(t/is (nil? (d/safe-subvec [1 2 3] 5)))
(t/is (nil? (d/safe-subvec [1 2 3] 0 5)))
@ -446,12 +448,19 @@
(t/is (= 0 (d/index-of-pred [1 2 3] odd?)))
(t/is (= 1 (d/index-of-pred [2 3 4] odd?)))
(t/is (nil? (d/index-of-pred [2 4 6] odd?)))
(t/is (nil? (d/index-of-pred [] odd?))))
(t/is (nil? (d/index-of-pred [] odd?)))
;; works correctly when collection contains nil elements
(t/is (= 2 (d/index-of-pred [nil nil 3] some?)))
(t/is (= 0 (d/index-of-pred [nil 1 2] nil?)))
;; works correctly when collection contains false elements
(t/is (= 1 (d/index-of-pred [false true false] true?))))
(t/deftest index-of-test
(t/is (= 0 (d/index-of [:a :b :c] :a)))
(t/is (= 2 (d/index-of [:a :b :c] :c)))
(t/is (nil? (d/index-of [:a :b :c] :z))))
(t/is (nil? (d/index-of [:a :b :c] :z)))
;; works when searching for nil in a collection
(t/is (= 1 (d/index-of [:a nil :c] nil))))
(t/deftest replace-by-id-test
(let [items [{:id 1 :v "a"} {:id 2 :v "b"} {:id 3 :v "c"}]
@ -519,6 +528,8 @@
(t/is (= {:a {:x 10 :y 2}} (d/patch-object {:a {:x 1 :y 2}} {:a {:x 10}})))
;; nested nil removes nested key
(t/is (= {:a {:y 2}} (d/patch-object {:a {:x 1 :y 2}} {:a {:x nil}})))
;; nil value removes only the specified key, not other keys
(t/is (= {nil 0 :b 2} (d/patch-object {nil 0 :a 1 :b 2} {:a nil})))
;; transducer arity (1-arg returns a fn)
(let [f (d/patch-object {:a 99})]
(t/is (= {:a 99 :b 2} (f {:a 1 :b 2})))))
@ -610,33 +621,33 @@
(into [] (d/distinct-xf :id) [{:id 1 :v "a"} {:id 2 :v "x"} {:id 2 :v "b"}]))))
(t/deftest deep-mapm-test
;; Note: mfn is called twice on leaf entries (once initially, once again
;; after checking if the value is a map/vector), so a doubling fn applied
;; to value 1 gives 1*2*2=4.
(t/is (= {:a 4 :b {:c 8}}
;; mfn is applied once per entry
(t/is (= {:a 2 :b {:c 4}}
(d/deep-mapm (fn [[k v]] [k (if (number? v) (* v 2) v)])
{:a 1 :b {:c 2}})))
;; Keyword renaming: keys are also transformed — and applied twice.
;; Use an idempotent key transformation (uppercase once = uppercase twice).
;; Keyword renaming: keys are transformed once per entry
(let [result (d/deep-mapm (fn [[k v]] [(keyword (str (name k) "!")) v])
{:a 1})]
(t/is (contains? result (keyword "a!!")))))
(t/is (contains? result (keyword "a!"))))
;; Vectors inside maps are recursed into
(t/is (= {:items [{:x 10}]}
(d/deep-mapm (fn [[k v]] [k (if (number? v) (* v 10) v)])
{:items [{:x 1}]})))
;; Plain scalar at top level map
(t/is (= {:a "hello"} (d/deep-mapm identity {:a "hello"}))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Numeric helpers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(t/deftest nan-test
;; Note: nan? behaves differently per platform:
;; - CLJS: uses js/isNaN, returns true for ##NaN
;; - CLJ: uses (not= v v); Clojure's = uses .equals on doubles,
;; so (= ##NaN ##NaN) is true and nan? returns false for ##NaN.
;; Either way, nan? returns false for regular numbers and nil.
(t/is (d/nan? ##NaN))
(t/is (not (d/nan? 0)))
(t/is (not (d/nan? 1)))
(t/is (not (d/nan? nil)))
;; Platform-specific: JS nan? correctly detects NaN
#?(:cljs (t/is (d/nan? ##NaN))))
;; CLJS js/isNaN coerces non-numbers; JVM Double/isNaN is number-only
#?(:cljs (t/is (d/nan? "hello")))
#?(:clj (t/is (not (d/nan? "hello")))))
(t/deftest safe-plus-test
(t/is (= 5 (d/safe+ 3 2)))
@ -680,18 +691,13 @@
(t/is (nil? (d/parse-uuid nil))))
(t/deftest coalesce-str-test
;; On JVM: nan? uses (not= v v), which is false for all normal values.
;; On CLJS: nan? uses js/isNaN, which is true for non-numeric strings.
;; coalesce-str returns default when value is nil or nan?.
(t/is (= "default" (d/coalesce-str nil "default")))
;; Numbers always stringify on both platforms
(t/is (= "42" (d/coalesce-str 42 "default")))
;; ##NaN: nan? is true in CLJS, returns default;
;; nan? is false in CLJ, so str(##NaN)="NaN" is returned.
#?(:cljs (t/is (= "default" (d/coalesce-str ##NaN "default"))))
#?(:clj (t/is (= "NaN" (d/coalesce-str ##NaN "default"))))
;; ##NaN returns default on both platforms now that nan? is fixed on JVM
(t/is (= "default" (d/coalesce-str ##NaN "default")))
;; Strings: in CLJS js/isNaN("hello")=true so "default" is returned;
;; in CLJ nan? is false so (str "hello")="hello" is returned.
;; in CLJ nan? is false for strings so (str "hello")="hello" is returned.
#?(:cljs (t/is (= "default" (d/coalesce-str "hello" "default"))))
#?(:clj (t/is (= "hello" (d/coalesce-str "hello" "default")))))
@ -853,7 +859,8 @@
(t/deftest append-class-test
(t/is (= "foo bar" (d/append-class "foo" "bar")))
(t/is (= "bar" (d/append-class nil "bar")))
(t/is (= " bar" (d/append-class "" "bar"))))
;; empty string is treated like nil — no leading space
(t/is (= "bar" (d/append-class "" "bar"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Additional helpers (5th batch)
@ -902,6 +909,9 @@
(t/is (d/num-string? "-7"))
(t/is (not (d/num-string? "hello")))
(t/is (not (d/num-string? nil)))
;; non-string types always return false
(t/is (not (d/num-string? 42)))
(t/is (not (d/num-string? :keyword)))
;; In CLJS, js/isNaN("") → false (empty string coerces to 0), so "" is numeric
#?(:clj (t/is (not (d/num-string? ""))))
#?(:cljs (t/is (d/num-string? ""))))

72
common/test/common_tests/files_builder_test.cljc Normal file
View File

@ -0,0 +1,72 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns common-tests.files-builder-test
(:require
[app.common.files.builder :as fb]
[app.common.uuid :as uuid]
[clojure.test :as t]))
(defn- stroke
[color]
[{:stroke-style :solid
:stroke-alignment :inner
:stroke-width 1
:stroke-color color
:stroke-opacity 1}])
(t/deftest add-bool-uses-difference-head-style
(let [file-id (uuid/next)
page-id (uuid/next)
group-id (uuid/next)
child-a (uuid/next)
child-b (uuid/next)
state (-> (fb/create-state)
(fb/add-file {:id file-id :name "Test file"})
(fb/add-page {:id page-id :name "Page 1"})
(fb/add-group {:id group-id :name "Group A"})
(fb/add-shape {:id child-a
:type :rect
:name "A"
:x 0
:y 0
:width 10
:height 10
:strokes (stroke "#ff0000")})
(fb/add-shape {:id child-b
:type :rect
:name "B"
:x 20
:y 0
:width 10
:height 10
:strokes (stroke "#00ff00")})
(fb/close-group)
(fb/add-bool {:group-id group-id
:type :difference}))
bool (fb/get-shape state group-id)]
(t/is (= :bool (:type bool)))
(t/is (= (stroke "#ff0000") (:strokes bool)))))
(t/deftest add-file-media-validates-and-persists-media
(let [file-id (uuid/next)
page-id (uuid/next)
image-id (uuid/next)
state (-> (fb/create-state)
(fb/add-file {:id file-id :name "Test file"})
(fb/add-page {:id page-id :name "Page 1"})
(fb/add-file-media {:id image-id
:name "Image"
:width 128
:height 64}
(fb/map->BlobWrapper {:mtype "image/png"
:size 42
:blob nil})))
media (get-in state [::fb/file-media image-id])]
(t/is (= image-id (::fb/last-id state)))
(t/is (= "Image" (:name media)))
(t/is (= 128 (:width media)))
(t/is (= 64 (:height media)))))

526
common/test/common_tests/fressian_test.clj Normal file
View File

@ -0,0 +1,526 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns common-tests.fressian-test
"Exhaustive unit tests for app.common.fressian encode/decode functions.
Tests cover every custom handler registered in the fressian namespace
(char, java/instant, clj/ratio, clj/map, linked/map, clj/keyword,
clj/symbol, clj/bigint, clj/set, clj/vector, clj/list, clj/seq,
linked/set) plus the built-in Fressian primitives (nil, boolean,
integer, long, double, string, bytes, UUID).
The file is JVM-only because Fressian is a JVM library."
(:require
[app.common.data :as d]
[app.common.fressian :as fres]
[clojure.test :as t])
(:import
java.time.Instant
java.time.OffsetDateTime
java.time.ZoneOffset))
;; ---------------------------------------------------------------------------
;; Helpers
;; ---------------------------------------------------------------------------
(defn roundtrip
"Encode then decode a value; the result must equal the original."
[v]
(-> v fres/encode fres/decode))
(defn roundtrip=
"Returns true when encode→decode produces an equal value."
[v]
(= v (roundtrip v)))
;; ---------------------------------------------------------------------------
;; Encode returns a byte array
;; ---------------------------------------------------------------------------
(t/deftest encode-returns-byte-array
(t/is (bytes? (fres/encode nil)))
(t/is (bytes? (fres/encode 42)))
(t/is (bytes? (fres/encode "hello")))
(t/is (bytes? (fres/encode {:a 1})))
(t/is (bytes? (fres/encode [])))
(t/is (pos? (alength ^bytes (fres/encode 0))))
(t/testing "different values produce different byte arrays"
(t/is (not= (vec (fres/encode 1)) (vec (fres/encode 2))))))
;; ---------------------------------------------------------------------------
;; nil
;; ---------------------------------------------------------------------------
(t/deftest nil-roundtrip
(t/is (nil? (roundtrip nil))))
;; ---------------------------------------------------------------------------
;; Booleans
;; ---------------------------------------------------------------------------
(t/deftest boolean-roundtrip
(t/is (true? (roundtrip true)))
(t/is (false? (roundtrip false))))
;; ---------------------------------------------------------------------------
;; Integers and longs
;; ---------------------------------------------------------------------------
(t/deftest integer-roundtrip
(t/is (= 0 (roundtrip 0)))
(t/is (= 1 (roundtrip 1)))
(t/is (= -1 (roundtrip -1)))
(t/is (= 42 (roundtrip 42)))
(t/is (= Integer/MAX_VALUE (roundtrip Integer/MAX_VALUE)))
(t/is (= Integer/MIN_VALUE (roundtrip Integer/MIN_VALUE))))
(t/deftest long-roundtrip
(t/is (= Long/MAX_VALUE (roundtrip Long/MAX_VALUE)))
(t/is (= Long/MIN_VALUE (roundtrip Long/MIN_VALUE)))
(t/is (= 1000000000000 (roundtrip 1000000000000))))
;; ---------------------------------------------------------------------------
;; Doubles / floats
;; ---------------------------------------------------------------------------
(t/deftest double-roundtrip
(t/is (= 0.0 (roundtrip 0.0)))
(t/is (= 3.14 (roundtrip 3.14)))
(t/is (= -2.718 (roundtrip -2.718)))
(t/is (= Double/MAX_VALUE (roundtrip Double/MAX_VALUE)))
(t/is (= Double/MIN_VALUE (roundtrip Double/MIN_VALUE)))
(t/is (Double/isInfinite ^double (roundtrip Double/POSITIVE_INFINITY)))
(t/is (Double/isInfinite ^double (roundtrip Double/NEGATIVE_INFINITY)))
(t/is (Double/isNaN ^double (roundtrip Double/NaN))))
;; ---------------------------------------------------------------------------
;; Strings
;; ---------------------------------------------------------------------------
(t/deftest string-roundtrip
(t/is (= "" (roundtrip "")))
(t/is (= "hello" (roundtrip "hello")))
(t/is (= "hello world" (roundtrip "hello world")))
(t/is (= "αβγδ" (roundtrip "αβγδ")))
(t/is (= "emoji: 🎨" (roundtrip "emoji: 🎨")))
(t/is (= (apply str (repeat 10000 "x")) (roundtrip (apply str (repeat 10000 "x"))))))
;; ---------------------------------------------------------------------------
;; Characters (custom "char" handler)
;; ---------------------------------------------------------------------------
(t/deftest char-roundtrip
(t/is (= \a (roundtrip \a)))
(t/is (= \A (roundtrip \A)))
(t/is (= \space (roundtrip \space)))
(t/is (= \newline (roundtrip \newline)))
(t/is (= \0 (roundtrip \0)))
(t/is (= \ü (roundtrip \ü)))
(t/testing "char type is preserved"
(t/is (char? (roundtrip \x)))))
;; ---------------------------------------------------------------------------
;; Keywords (custom "clj/keyword" handler)
;; ---------------------------------------------------------------------------
(t/deftest keyword-roundtrip
(t/is (= :foo (roundtrip :foo)))
(t/is (= :bar (roundtrip :bar)))
(t/is (= :ns/foo (roundtrip :ns/foo)))
(t/is (= :app.common.data/something (roundtrip :app.common.data/something)))
(t/testing "keyword? is preserved"
(t/is (keyword? (roundtrip :anything))))
(t/testing "namespace is preserved"
(let [kw :my-ns/my-name]
(t/is (= (namespace kw) (namespace (roundtrip kw))))
(t/is (= (name kw) (name (roundtrip kw)))))))
;; ---------------------------------------------------------------------------
;; Symbols (custom "clj/symbol" handler)
;; ---------------------------------------------------------------------------
(t/deftest symbol-roundtrip
(t/is (= 'foo (roundtrip 'foo)))
(t/is (= 'bar (roundtrip 'bar)))
(t/is (= 'ns/foo (roundtrip 'ns/foo)))
(t/is (= 'clojure.core/map (roundtrip 'clojure.core/map)))
(t/testing "symbol? is preserved"
(t/is (symbol? (roundtrip 'anything))))
(t/testing "namespace is preserved"
(let [sym 'my-ns/my-name]
(t/is (= (namespace sym) (namespace (roundtrip sym))))
(t/is (= (name sym) (name (roundtrip sym)))))))
;; ---------------------------------------------------------------------------
;; Vectors (custom "clj/vector" handler)
;; ---------------------------------------------------------------------------
(t/deftest vector-roundtrip
(t/is (= [] (roundtrip [])))
(t/is (= [1 2 3] (roundtrip [1 2 3])))
(t/is (= [:a :b :c] (roundtrip [:a :b :c])))
(t/is (= [nil nil nil] (roundtrip [nil nil nil])))
(t/is (= [[1 2] [3 4]] (roundtrip [[1 2] [3 4]])))
(t/is (= ["hello" :world 42] (roundtrip ["hello" :world 42])))
(t/testing "vector? is preserved"
(t/is (vector? (roundtrip [1 2 3])))))
;; ---------------------------------------------------------------------------
;; Sets (custom "clj/set" handler)
;; ---------------------------------------------------------------------------
(t/deftest set-roundtrip
(t/is (= #{} (roundtrip #{})))
(t/is (= #{1 2 3} (roundtrip #{1 2 3})))
(t/is (= #{:a :b :c} (roundtrip #{:a :b :c})))
(t/is (= #{"x" "y"} (roundtrip #{"x" "y"})))
(t/testing "set? is preserved"
(t/is (set? (roundtrip #{:foo})))))
;; ---------------------------------------------------------------------------
;; Maps (custom "clj/map" handler)
;; ---------------------------------------------------------------------------
(t/deftest small-map-roundtrip
"Maps with fewer than 8 entries decode as PersistentArrayMap."
(t/is (= {} (roundtrip {})))
(t/is (= {:a 1} (roundtrip {:a 1})))
(t/is (= {:a 1 :b 2} (roundtrip {:a 1 :b 2})))
(t/is (= {:a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7} (roundtrip {:a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7})))
(t/testing "map? is preserved"
(t/is (map? (roundtrip {:x 1})))))
(t/deftest large-map-roundtrip
"Maps with 8+ entries decode as PersistentHashMap (>= 16 kvs in list)."
(let [large (into {} (map (fn [i] [(keyword (str "k" i)) i]) (range 20)))]
(t/is (= large (roundtrip large)))
(t/is (map? (roundtrip large)))))
(t/deftest map-with-mixed-keys-roundtrip
(let [m {:keyword-key 1
"string-key" 2
42 3}]
(t/is (= m (roundtrip m)))))
(t/deftest map-with-nil-value-roundtrip
(t/is (= {:a nil :b 2} (roundtrip {:a nil :b 2}))))
;; ---------------------------------------------------------------------------
;; Sequences (custom "clj/seq" handler)
;; ---------------------------------------------------------------------------
(t/deftest seq-roundtrip
(let [s (seq [1 2 3])]
(t/is (= (sequence s) (roundtrip s))))
(let [s (map inc [1 2 3])]
(t/is (= (sequence s) (roundtrip s))))
(t/testing "result is a sequence"
(t/is (seq? (roundtrip (seq [1 2 3]))))))
;; ---------------------------------------------------------------------------
;; Ratio (custom "clj/ratio" handler)
;; ---------------------------------------------------------------------------
(t/deftest ratio-roundtrip
(t/is (= 1/3 (roundtrip 1/3)))
(t/is (= 22/7 (roundtrip 22/7)))
(t/is (= -5/6 (roundtrip -5/6)))
(t/is (= 1/1000000 (roundtrip 1/1000000)))
(t/testing "ratio? is preserved"
(t/is (ratio? (roundtrip 1/3)))))
;; ---------------------------------------------------------------------------
;; BigInt (custom "clj/bigint" handler)
;; ---------------------------------------------------------------------------
(t/deftest bigint-roundtrip
(t/is (= 0N (roundtrip 0N)))
(t/is (= 1N (roundtrip 1N)))
(t/is (= -1N (roundtrip -1N)))
(t/is (= 123456789012345678901234567890N (roundtrip 123456789012345678901234567890N)))
(t/is (= -999999999999999999999999999999N (roundtrip -999999999999999999999999999999N)))
(t/testing "bigint? is preserved"
(t/is (instance? clojure.lang.BigInt (roundtrip 42N)))))
;; ---------------------------------------------------------------------------
;; java.time.Instant (custom "java/instant" handler)
;; ---------------------------------------------------------------------------
(t/deftest instant-roundtrip
(let [now (Instant/now)]
(t/is (= (.toEpochMilli now) (.toEpochMilli ^Instant (roundtrip now)))))
(t/testing "epoch zero"
(let [epoch (Instant/ofEpochMilli 0)]
(t/is (= epoch (roundtrip epoch)))))
(t/testing "far past"
(let [past (Instant/ofEpochMilli -62135596800000)]
(t/is (= past (roundtrip past)))))
(t/testing "far future"
(let [future (Instant/ofEpochMilli 32503680000000)]
(t/is (= future (roundtrip future)))))
(t/testing "result type is Instant"
(t/is (instance? Instant (roundtrip (Instant/now))))))
;; ---------------------------------------------------------------------------
;; java.time.OffsetDateTime (written as "java/instant", read back as Instant)
;; ---------------------------------------------------------------------------
(t/deftest offset-date-time-roundtrip
(t/testing "OffsetDateTime is written and decoded as Instant (millis preserved)"
(let [odt (OffsetDateTime/now ZoneOffset/UTC)
millis (.toEpochMilli (.toInstant odt))
result (roundtrip odt)]
(t/is (instance? Instant result))
(t/is (= millis (.toEpochMilli ^Instant result)))))
(t/testing "non-UTC offset"
(let [odt (OffsetDateTime/now (ZoneOffset/ofHours 5))
millis (.toEpochMilli (.toInstant odt))
result (roundtrip odt)]
(t/is (= millis (.toEpochMilli ^Instant result))))))
;; ---------------------------------------------------------------------------
;; Ordered map (custom "linked/map" handler)
;; ---------------------------------------------------------------------------
(t/deftest ordered-map-roundtrip
(t/is (= (d/ordered-map) (roundtrip (d/ordered-map))))
(t/is (= (d/ordered-map :a 1) (roundtrip (d/ordered-map :a 1))))
(t/is (= (d/ordered-map :a 1 :b 2 :c 3) (roundtrip (d/ordered-map :a 1 :b 2 :c 3))))
(t/testing "ordered-map? is preserved"
(t/is (d/ordered-map? (roundtrip (d/ordered-map :x 1 :y 2)))))
(t/testing "insertion order is preserved"
(let [om (d/ordered-map :c 3 :a 1 :b 2)
rt (roundtrip om)]
(t/is (= [:c :a :b] (vec (keys rt))))))
(t/testing "large ordered-map"
(let [om (reduce (fn [m i] (assoc m (keyword (str "k" i)) i))
(d/ordered-map)
(range 20))
rt (roundtrip om)]
(t/is (d/ordered-map? rt))
(t/is (= om rt))
(t/is (= (keys om) (keys rt))))))
;; ---------------------------------------------------------------------------
;; Ordered set (custom "linked/set" handler)
;; ---------------------------------------------------------------------------
(t/deftest ordered-set-roundtrip
(t/is (= (d/ordered-set) (roundtrip (d/ordered-set))))
(t/is (= (d/ordered-set :a) (roundtrip (d/ordered-set :a))))
(t/is (= (d/ordered-set :a :b :c) (roundtrip (d/ordered-set :a :b :c))))
(t/testing "ordered-set? is preserved"
(t/is (d/ordered-set? (roundtrip (d/ordered-set :x :y)))))
(t/testing "insertion order is preserved"
(let [os (d/ordered-set :c :a :b)
rt (roundtrip os)]
(t/is (= [:c :a :b] (vec rt)))))
(t/testing "large ordered-set"
(let [os (reduce conj (d/ordered-set) (range 20))
rt (roundtrip os)]
(t/is (d/ordered-set? rt))
(t/is (= os rt)))))
;; ---------------------------------------------------------------------------
;; UUID (handled by built-in Fressian handlers)
;; ---------------------------------------------------------------------------
(t/deftest uuid-roundtrip
(let [id (java.util.UUID/randomUUID)]
(t/is (= id (roundtrip id))))
(t/testing "nil UUID"
(let [nil-uuid (java.util.UUID/fromString "00000000-0000-0000-0000-000000000000")]
(t/is (= nil-uuid (roundtrip nil-uuid)))))
(t/testing "max UUID"
(let [max-uuid (java.util.UUID/fromString "ffffffff-ffff-ffff-ffff-ffffffffffff")]
(t/is (= max-uuid (roundtrip max-uuid)))))
(t/testing "specific well-known UUID"
(let [id (java.util.UUID/fromString "550e8400-e29b-41d4-a716-446655440000")]
(t/is (= id (roundtrip id)))))
(t/testing "uuid? is preserved"
(t/is (uuid? (roundtrip (java.util.UUID/randomUUID))))))
;; ---------------------------------------------------------------------------
;; Nested and mixed structures
;; ---------------------------------------------------------------------------
(t/deftest nested-map-roundtrip
(let [nested {:a {:b {:c 42 :d [1 2 3]} :e :keyword} :f "string"}]
(t/is (= nested (roundtrip nested)))))
(t/deftest map-with-vector-values
(let [m {:shapes [1 2 3] :colors [:red :green :blue]}]
(t/is (= m (roundtrip m)))))
(t/deftest vector-of-maps
(let [v [{:id 1 :name "a"} {:id 2 :name "b"} {:id 3 :name "c"}]]
(t/is (= v (roundtrip v)))))
(t/deftest mixed-collection-types
(let [data {:vec [1 2 3]
:set #{:a :b :c}
:map {:nested true}
:kw :some/keyword
:sym 'some/symbol
:bigint 12345678901234567890N
:ratio 22/7
:str "hello"
:num 42
:bool true
:nil-val nil}]
(t/is (= data (roundtrip data)))))
(t/deftest deeply-nested-structure
(let [data (reduce (fn [acc i] {:level i :child acc})
{:leaf true}
(range 20))]
(t/is (= data (roundtrip data)))))
(t/deftest penpot-like-shape-map
"Simulates a Penpot shape-like structure with UUIDs, keywords, and nested maps."
(let [id (java.util.UUID/fromString "550e8400-e29b-41d4-a716-446655440001")
frame-id (java.util.UUID/fromString "550e8400-e29b-41d4-a716-446655440002")
shape {:id id
:frame-id frame-id
:type :rect
:name "My Shape"
:x 100.5
:y 200.0
:width 300.0
:height 150.0
:fills [{:fill-color "#FF0000" :fill-opacity 1.0}]
:strokes []
:hidden false
:blocked false}]
(t/is (= shape (roundtrip shape)))))
(t/deftest penpot-like-objects-map
"Simulates a Penpot page objects map with multiple shapes."
(let [ids (mapv #(java.util.UUID/fromString
(format "550e8400-e29b-41d4-a716-%012d" %))
(range 5))
objs (into {} (map (fn [id] [id {:id id :type :rect :name (str id)}]) ids))
data {:objects objs}]
(t/is (= data (roundtrip data)))))
;; ---------------------------------------------------------------------------
;; Idempotency: encode→decode→encode must yield equal bytes
;; ---------------------------------------------------------------------------
(t/deftest encode-idempotency
(doseq [v [nil true false 0 1 -1 42 Long/MAX_VALUE 3.14 "" "hello"
:kw :ns/kw 'sym 'ns/sym
[] [1 2 3] #{} #{:a} {} {:a 1}
1/3 42N]]
(let [enc1 (fres/encode v)
enc2 (-> v fres/encode fres/decode fres/encode)]
(t/is (= (vec enc1) (vec enc2))
(str "Idempotency failed for: " (pr-str v))))))
;; ---------------------------------------------------------------------------
;; Multiple encode/decode roundtrips in sequence (regression / ordering)
;; ---------------------------------------------------------------------------
(t/deftest multiple-roundtrips-are-independent
(t/testing "encoding multiple values independently does not cross-contaminate"
(let [a (fres/encode {:key :val-a})
b (fres/encode {:key :val-b})
da (fres/decode a)
db (fres/decode b)]
(t/is (= {:key :val-a} da))
(t/is (= {:key :val-b} db))
(t/is (not= da db)))))
;; ---------------------------------------------------------------------------
;; Edge cases: empty collections
;; ---------------------------------------------------------------------------
(t/deftest empty-collections-roundtrip
(t/is (= {} (roundtrip {})))
(t/is (= [] (roundtrip [])))
(t/is (= #{} (roundtrip #{})))
(t/is (= "" (roundtrip "")))
(t/is (= (d/ordered-map) (roundtrip (d/ordered-map))))
(t/is (= (d/ordered-set) (roundtrip (d/ordered-set)))))
;; ---------------------------------------------------------------------------
;; Edge cases: collections containing nil
;; ---------------------------------------------------------------------------
(t/deftest collections-with-nil-roundtrip
(t/is (= [nil] (roundtrip [nil])))
(t/is (= [nil nil nil] (roundtrip [nil nil nil])))
(t/is (= {:a nil :b nil} (roundtrip {:a nil :b nil})))
(t/is (= [1 nil 3] (roundtrip [1 nil 3]))))
;; ---------------------------------------------------------------------------
;; Edge cases: single-element collections
;; ---------------------------------------------------------------------------
(t/deftest single-element-collections
(t/is (= [42] (roundtrip [42])))
(t/is (= #{:only} (roundtrip #{:only})))
(t/is (= {:only-key "only-val"} (roundtrip {:only-key "only-val"}))))
;; ---------------------------------------------------------------------------
;; Edge cases: boundary map sizes (ArrayMap/HashMap threshold)
;; ---------------------------------------------------------------------------
(t/deftest map-size-boundary
(t/testing "7-entry map (below threshold → ArrayMap)"
(let [m (into {} (map (fn [i] [(keyword (str "k" i)) i]) (range 7)))]
(t/is (= m (roundtrip m)))))
(t/testing "8-entry map (at/above threshold → may become HashMap)"
(let [m (into {} (map (fn [i] [(keyword (str "k" i)) i]) (range 8)))]
(t/is (= m (roundtrip m)))))
(t/testing "16-entry map (well above threshold)"
(let [m (into {} (map (fn [i] [(keyword (str "k" i)) i]) (range 16)))]
(t/is (= m (roundtrip m))))))
;; ---------------------------------------------------------------------------
;; Edge cases: byte arrays
;; ---------------------------------------------------------------------------
(t/deftest byte-array-roundtrip
(let [data (byte-array [0 1 2 3 127 -128 -1])]
(t/is (= (vec data) (vec ^bytes (roundtrip data))))))
;; ---------------------------------------------------------------------------
;; Ordered-map key ordering survives large number of keys
;; ---------------------------------------------------------------------------
(t/deftest ordered-map-key-ordering-stress
(let [keys-in-order (mapv #(keyword (str "key-" (format "%03d" %))) (range 50))
om (reduce (fn [m k] (assoc m k (name k))) (d/ordered-map) keys-in-order)
rt (roundtrip om)]
(t/is (= keys-in-order (vec (keys rt))))))
;; ---------------------------------------------------------------------------
;; Ordered-set element ordering survives large number of elements
;; ---------------------------------------------------------------------------
(t/deftest ordered-set-element-ordering-stress
(let [elems-in-order (mapv #(keyword (str "elem-" (format "%03d" %))) (range 50))
os (reduce conj (d/ordered-set) elems-in-order)
rt (roundtrip os)]
(t/is (= elems-in-order (vec rt)))))
;; ---------------------------------------------------------------------------
;; Complex Penpot-domain: ordered-map with UUID keys and shape values
;; ---------------------------------------------------------------------------
(t/deftest ordered-map-with-uuid-keys
(let [ids (mapv #(java.util.UUID/fromString
(format "550e8400-e29b-41d4-a716-%012d" %))
(range 5))
om (reduce (fn [m id] (assoc m id {:type :rect :id id}))
(d/ordered-map)
ids)
rt (roundtrip om)]
(t/is (d/ordered-map? rt))
(t/is (= om rt))
(t/is (= (keys om) (keys rt)))))

106
common/test/common_tests/geom_flex_layout_test.cljc Normal file
View File

@ -0,0 +1,106 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns common-tests.geom-flex-layout-test
(:require
[app.common.geom.rect :as grc]
[app.common.geom.shapes.flex-layout.positions :as flp]
[app.common.math :as mth]
[app.common.types.shape :as cts]
[app.common.types.shape.layout :as ctl]
[clojure.test :as t]))
;; ---- helpers ----
(defn- make-col-frame
"Minimal col? flex frame with wrap enabled.
wrap is required for the content-around? predicate to activate."
[& {:as opts}]
(cts/setup-shape (merge {:type :frame
:layout :flex
:layout-flex-dir :column
:layout-wrap-type :wrap
:x 0 :y 0 :width 200 :height 200}
opts)))
(defn- rect->bounds
"Convert a rect to the 4-point layout-bounds vector expected by gpo/*."
[rect]
(grc/rect->points rect))
;; ---- get-base-line (around? branch) ----
;;
;; Bug: in positions.cljc the col? + around? branch had a mis-parenthesised
;; expression `(/ free-width num-lines) 2`, which was parsed as three
;; arguments to `max`:
;; (max lines-gap-col (/ free-width num-lines) 2)
;; instead of the intended two-argument max with a nested division:
;; (max lines-gap-col (/ free-width num-lines 2))
;;
;; For a col? layout the cross-axis is horizontal (hv), so the around? offset
;; is applied as hv(delta) — i.e. the delta ends up in (:x base-p).
(t/deftest get-base-line-around-uses-half-per-line-free-width
(t/testing "col? + content-around? offset is free-width / num-lines / 2"
;; Layout: col? wrap, width=200, 3 lines each 20px wide → free-width=140
;; lines-gap-col = 0 (no gap defined)
;; Expected horizontal offset = max(0, 140/3/2) ≈ 23.33
;; Before the bug fix the formula was (max ... (/ 140 3) 2) ≈ 46.67.
(let [frame (make-col-frame :layout-align-content :space-around)
bounds (rect->bounds (grc/make-rect 0 0 200 200))
;; 3 lines of 20px each (widths); no row gap
num-lines 3
total-width 60
total-height 0
base-p (flp/get-base-line frame bounds total-width total-height num-lines)
free-width (- 200 total-width)
;; lines-gap-col = (dec 3) * 0 = 0; max(0, free-width/num-lines/2)
expected-x (/ free-width num-lines 2)]
;; The base point x-coordinate (hv offset) should equal half per-line free space.
(t/is (mth/close? expected-x (:x base-p) 0.01))))
(t/testing "col? + content-around? offset respects lines-gap-col minimum"
;; When the accumulated column gap exceeds the computed half-per-line value
;; max(lines-gap-col, free-width/num-lines/2) returns the gap.
(let [frame (make-col-frame :layout-align-content :space-around
:layout-gap {:column-gap 50 :row-gap 0})
bounds (rect->bounds (grc/make-rect 0 0 200 200))
;; 4 lines × 20px = 80px used; free-width=120; half-per-line = 120/4/2 = 15
;; lines-gap-col = (dec 4)*50 = 150 → max(150, 15) = 150
num-lines 4
total-width 80
total-height 0
base-p (flp/get-base-line frame bounds total-width total-height num-lines)
lines-gap-col (* (dec num-lines) 50)]
(t/is (mth/close? lines-gap-col (:x base-p) 0.01)))))
;; ---- v-end? guard (drop-line-area) ----
;;
;; Bug: `v-end?` inside `drop-line-area` was guarded by `row?` instead of
;; `col?`, so vertical-end alignment in a column layout was never triggered.
;; We verify the predicate behaviour directly via ctl/v-end?.
(t/deftest v-end-guard-uses-col-not-row
(t/testing "v-end? is true for col? frame with justify-content :end"
;; col? + justify-content=:end → ctl/v-end? must be true
(let [frame (cts/setup-shape {:type :frame
:layout :flex
:layout-flex-dir :column
:layout-justify-content :end
:x 0 :y 0 :width 100 :height 100})]
(t/is (true? (ctl/v-end? frame)))))
(t/testing "v-end? is false for row? frame with only justify-content :end"
;; row? + justify-content=:end alone does NOT set v-end?; for row layouts
;; v-end? checks align-items, not justify-content.
(let [frame (cts/setup-shape {:type :frame
:layout :flex
:layout-flex-dir :row
:layout-justify-content :end
:x 0 :y 0 :width 100 :height 100})]
(t/is (not (ctl/v-end? frame))))))

410
common/test/common_tests/geom_grid_layout_test.cljc Normal file
View File

@ -0,0 +1,410 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns common-tests.geom-grid-layout-test
(:require
;; Requiring modifiers triggers the side-effect that wires
;; -child-min-width / -child-min-height into grid layout-data.
[app.common.geom.modifiers]
[app.common.geom.rect :as grc]
[app.common.geom.shapes.grid-layout.layout-data :as gld]
[app.common.math :as mth]
[app.common.types.shape :as cts]
[clojure.test :as t]))
;; ---------------------------------------------------------------------------
;; Shared test-data builders
;; ---------------------------------------------------------------------------
(defn- make-grid-frame
"Minimal grid-layout frame with two fixed columns of 50.0 px
and one fixed row. Width and height are explicit, no padding.
Track values are floats to avoid JVM integer-divide-by-zero when
there are no flex tracks (column-frs = 0)."
[& {:as opts}]
(cts/setup-shape
(merge {:type :frame
:layout :grid
:layout-grid-dir :row
:layout-grid-columns [{:type :fixed :value 50.0}
{:type :fixed :value 50.0}]
:layout-grid-rows [{:type :fixed :value 100.0}]
:layout-grid-cells {}
:layout-padding-type :multiple
:layout-padding {:p1 0 :p2 0 :p3 0 :p4 0}
:layout-gap {:column-gap 0 :row-gap 0}
:x 0 :y 0 :width 200 :height 100}
opts)))
(defn- bounds-for
"Return the 4-point layout-bounds for the frame."
[frame]
(grc/rect->points (grc/make-rect (:x frame) (:y frame) (:width frame) (:height frame))))
;; Build a simple non-fill child shape with explicit width/height.
;; No layout-item-margin → child-width-margin = 0.
(defn- make-child
[w h]
(cts/setup-shape {:type :rect :width w :height h :x 0 :y 0}))
;; Build the 4-point bounds vector for a child with the given dimensions.
(defn- child-bounds
[w h]
(grc/rect->points (grc/make-rect 0 0 w h)))
;; Build an auto track at its initial size (0.01) with infinite max.
(defn- auto-track [] {:type :auto :size 0.01 :max-size ##Inf})
;; Build a fixed track with the given size.
(defn- fixed-track [v]
{:type :fixed :value v :size (double v) :max-size (double v)})
;; Build a flex track (value = number of fr units) at initial size 0.01.
(defn- flex-track [fr]
{:type :flex :value fr :size 0.01 :max-size ##Inf})
;; Build a parent frame for column testing with given column-gap.
(defn- auto-col-parent
([] (auto-col-parent 0))
([column-gap]
(cts/setup-shape
{:type :frame
:layout :grid
:layout-grid-dir :row
:layout-padding-type :multiple
:layout-padding {:p1 0 :p2 0 :p3 0 :p4 0}
:layout-gap {:column-gap column-gap :row-gap 0}
:x 0 :y 0 :width 500 :height 500})))
;; Build a parent frame for row type testing with given row-gap.
(defn- auto-row-parent
([] (auto-row-parent 0))
([row-gap]
(cts/setup-shape
{:type :frame
:layout :grid
:layout-grid-dir :row
:layout-padding-type :multiple
:layout-padding {:p1 0 :p2 0 :p3 0 :p4 0}
:layout-gap {:column-gap 0 :row-gap row-gap}
:x 0 :y 0 :width 500 :height 500})))
;; Generic frame-bounds (large enough not to interfere).
(def ^:private frame-bounds
(grc/rect->points (grc/make-rect 0 0 500 500)))
;; Build a cell map for a single shape occupying column/row at given span.
;; col and row are 1-based.
(defn- make-cell
[shape-id col row col-span row-span]
{:shapes [shape-id]
:column col :column-span col-span
:row row :row-span row-span})
;; ---------------------------------------------------------------------------
;; Note on set-auto-multi-span indexing
;; ---------------------------------------------------------------------------
;;
;; Inside set-auto-multi-span, indexed-tracks is computed as:
;; from-idx = clamp(col - 1, 0, count-1)
;; to-idx = clamp((col - 1) + col-span, 0, count-1)
;; indexed-tracks = subvec(enumerate(tracks), from-idx, to-idx)
;;
;; Because to-idx is clamped to (dec count), the LAST track of the span is
;; always excluded unless there is at least one extra track beyond the span.
;;
;; Practical implication for tests: to cover N spanned tracks, provide a
;; track-list with at least N+1 tracks (the extra track acts as a sentinel
;; that absorbs the off-by-one from the clamp).
;;
;; Example: col=1, span=2, 3 total tracks:
;; to-idx = clamp(0+2, 0, 2) = 2 → subvec(v, 0, 2) = [track0, track1] ✓
;;
;; Tests that deliberately check boundary behavior (flex exclusion,
;; non-spanned tracks) use 2 total tracks so only track 0 is covered.
;; ---------------------------------------------------------------------------
;; Tests: column-gap with justify-content (case → cond fix)
;; ---------------------------------------------------------------------------
;;
;; In get-cell-data, column-gap and row-gap were computed with (case ...)
;; using boolean locals as dispatch values. case compares compile-time
;; constants, so those branches never matched at runtime. Fixed with cond.
(t/deftest grid-column-gap-space-evenly
(t/testing "justify-content :space-evenly increases column-gap correctly"
;; 2 fixed cols × 50 px = 100 px occupied; bound-width = 200; free = 100
;; formula: free / (num-cols + 1) = 100/3 ≈ 33.33
(let [frame (make-grid-frame :layout-justify-content :space-evenly
:layout-gap {:column-gap 0 :row-gap 0})
bounds (bounds-for frame)
result (gld/calc-layout-data frame bounds [] {} {})
col-gap (:column-gap result)]
(t/is (mth/close? (/ 100.0 3.0) col-gap 0.01)))))
(t/deftest grid-column-gap-space-around
(t/testing "justify-content :space-around increases column-gap correctly"
;; free = 100; formula: 100 / num-cols = 100/2 = 50
(let [frame (make-grid-frame :layout-justify-content :space-around
:layout-gap {:column-gap 0 :row-gap 0})
bounds (bounds-for frame)
result (gld/calc-layout-data frame bounds [] {} {})
col-gap (:column-gap result)]
(t/is (mth/close? 50.0 col-gap 0.01)))))
(t/deftest grid-column-gap-space-between
(t/testing "justify-content :space-between increases column-gap correctly"
;; free = 100; num-cols = 2; formula: 100 / (2-1) = 100
(let [frame (make-grid-frame :layout-justify-content :space-between
:layout-gap {:column-gap 0 :row-gap 0})
bounds (bounds-for frame)
result (gld/calc-layout-data frame bounds [] {} {})
col-gap (:column-gap result)]
(t/is (mth/close? 100.0 col-gap 0.01)))))
(t/deftest grid-column-gap-auto-width-bypasses-justify-content
(t/testing "auto-width? bypasses justify-content gap recalc → gap stays as initial"
(let [frame (make-grid-frame :layout-justify-content :space-evenly
:layout-gap {:column-gap 5 :row-gap 0}
:layout-item-h-sizing :auto)
bounds (bounds-for frame)
result (gld/calc-layout-data frame bounds [] {} {})
col-gap (:column-gap result)]
(t/is (mth/close? 5.0 col-gap 0.01)))))
;; ---------------------------------------------------------------------------
;; Tests: set-auto-multi-span
;; ---------------------------------------------------------------------------
;;
;; set-auto-multi-span grows auto tracks to accommodate children whose cell
;; spans more than one track column (or row), but only for spans that contain
;; no flex tracks (those are handled by set-flex-multi-span).
;;
;; The function signature:
;; (set-auto-multi-span parent track-list children-map shape-cells
;; bounds objects type)
;; type – :column or :row
;; children-map – {shape-id [child-bounds child-shape]}
;; shape-cells – {cell-id cell-map}
(t/deftest set-auto-multi-span-span-1-cells-ignored
(t/testing "span=1 cells are filtered out; track-list is unchanged"
(let [sid (random-uuid)
child (make-child 200 100)
;; 2 tracks + 1 sentinel (so the span would cover tracks 0-1 if span were 2)
tracks [(auto-track) (auto-track) (auto-track)]
cells {:c1 (make-cell sid 1 1 1 1)} ; span = 1 → ignored
cmap {sid [(child-bounds 200 100) child]}
result (gld/set-auto-multi-span (auto-col-parent) tracks cmap cells frame-bounds {} :column)]
(t/is (mth/close? 0.01 (:size (nth result 0)) 0.001))
(t/is (mth/close? 0.01 (:size (nth result 1)) 0.001))
(t/is (mth/close? 0.01 (:size (nth result 2)) 0.001)))))
(t/deftest set-auto-multi-span-empty-cells
(t/testing "empty shape-cells → track-list unchanged"
(let [tracks [(auto-track) (auto-track)]
result (gld/set-auto-multi-span (auto-col-parent) tracks {} {} frame-bounds {} :column)]
(t/is (mth/close? 0.01 (:size (nth result 0)) 0.001))
(t/is (mth/close? 0.01 (:size (nth result 1)) 0.001)))))
(t/deftest set-auto-multi-span-two-auto-tracks-split-evenly
(t/testing "child spanning 2 auto tracks (with sentinel): budget split between the 2 covered tracks"
;; 3 tracks total (sentinel at index 2 keeps to-idx from being clamped).
;; col=1, span=2:
;; from-idx = clamp(0, 0, 2) = 0
;; to-idx = clamp(2, 0, 2) = 2
;; subvec(enumerate, 0, 2) = [[0, auto0], [1, auto1]]
;; size-to-allocate = 200 (child width, no gap)
;; allocate-auto-tracks pass 1 (non-assigned = both):
;; idx0: max(0.01, 200/2, 0.01) = 100; rem = 100
;; idx1: max(0.01, 100/1, 0.01) = 100; rem = 0
;; pass 2 (to-allocate=0): no change → both 100
;; sentinel track 2 is never spanned → stays at 0.01.
(let [sid (random-uuid)
child (make-child 200 100)
tracks [(auto-track) (auto-track) (auto-track)] ; sentinel at [2]
cells {:c1 (make-cell sid 1 1 2 1)}
cmap {sid [(child-bounds 200 100) child]}
result (gld/set-auto-multi-span (auto-col-parent) tracks cmap cells frame-bounds {} :column)]
(t/is (mth/close? 100.0 (:size (nth result 0)) 0.001))
(t/is (mth/close? 100.0 (:size (nth result 1)) 0.001))
;; sentinel unaffected
(t/is (mth/close? 0.01 (:size (nth result 2)) 0.001)))))
(t/deftest set-auto-multi-span-gap-deducted-from-budget
(t/testing "column-gap is subtracted once per extra span track from size-to-allocate"
;; child width = 210, column-gap = 10, span = 2
;; size-to-allocate = child-min-width - gap*(span-1) = 210 - 10*1 = 200
;; 3 tracks (sentinel at [2]) → indexed = [[0,auto],[1,auto]]
;; each auto track gets 100
(let [sid (random-uuid)
child (make-child 210 100)
tracks [(auto-track) (auto-track) (auto-track)]
cells {:c1 (make-cell sid 1 1 2 1)}
cmap {sid [(child-bounds 210 100) child]}
result (gld/set-auto-multi-span (auto-col-parent 10) tracks cmap cells frame-bounds {} :column)]
(t/is (mth/close? 100.0 (:size (nth result 0)) 0.001))
(t/is (mth/close? 100.0 (:size (nth result 1)) 0.001))
(t/is (mth/close? 0.01 (:size (nth result 2)) 0.001)))))
(t/deftest set-auto-multi-span-fixed-track-reduces-budget
(t/testing "fixed track in span is deducted from budget; only the auto track grows"
;; tracks: [fixed 60, auto 0.01, auto-sentinel] (sentinel at [2])
;; col=1, span=2 → indexed = [[0, fixed60], [1, auto]]
;; find-auto-allocations: fixed→subtract 60; auto→keep
;; to-allocate after fixed = 200 - 60 = 140; indexed-auto = [[1, auto]]
;; pass 1: idx1: max(0.01, 140/1, 0.01) = 140
;; apply: track0 = max(60, 0) = 60; track1 = max(0.01, 140) = 140
(let [sid (random-uuid)
child (make-child 200 100)
tracks [(fixed-track 60) (auto-track) (auto-track)]
cells {:c1 (make-cell sid 1 1 2 1)}
cmap {sid [(child-bounds 200 100) child]}
result (gld/set-auto-multi-span (auto-col-parent) tracks cmap cells frame-bounds {} :column)]
(t/is (mth/close? 60.0 (:size (nth result 0)) 0.001))
(t/is (mth/close? 140.0 (:size (nth result 1)) 0.001))
(t/is (mth/close? 0.01 (:size (nth result 2)) 0.001)))))
(t/deftest set-auto-multi-span-child-smaller-than-existing-tracks
(t/testing "when child is smaller than the existing track sizes, tracks are not shrunk"
;; tracks: [auto 80, auto 80, auto-sentinel]
;; child width = 50; size-to-allocate = 50
;; indexed = [[0, auto80], [1, auto80]]
;; pass 1 (non-assigned, to-alloc=50):
;; idx0: max(0.01, 50/2, 80) = 80; rem = 50-80 = -30
;; idx1: max(0.01, max(-30,0)/1, 80) = 80
;; pass 2 (to-alloc=max(-30,0)=0): same max, no change
;; both tracks stay at 80
(let [sid (random-uuid)
child (make-child 50 100)
tracks [{:type :auto :size 80.0 :max-size ##Inf}
{:type :auto :size 80.0 :max-size ##Inf}
(auto-track)]
cells {:c1 (make-cell sid 1 1 2 1)}
cmap {sid [(child-bounds 50 100) child]}
result (gld/set-auto-multi-span (auto-col-parent) tracks cmap cells frame-bounds {} :column)]
(t/is (mth/close? 80.0 (:size (nth result 0)) 0.001))
(t/is (mth/close? 80.0 (:size (nth result 1)) 0.001)))))
(t/deftest set-auto-multi-span-flex-track-in-span-excluded
(t/testing "cells whose span contains a flex track are skipped (handled by set-flex-multi-span)"
;; tracks: [flex 1fr, auto] col=1, span=2 → has-flex-track? = true → cell excluded
;; 2 tracks total (no sentinel needed since the cell is excluded before indexing)
(let [sid (random-uuid)
child (make-child 300 100)
tracks [(flex-track 1) (auto-track)]
cells {:c1 (make-cell sid 1 1 2 1)}
cmap {sid [(child-bounds 300 100) child]}
result (gld/set-auto-multi-span (auto-col-parent) tracks cmap cells frame-bounds {} :column)]
(t/is (mth/close? 0.01 (:size (nth result 0)) 0.001))
(t/is (mth/close? 0.01 (:size (nth result 1)) 0.001)))))
(t/deftest set-auto-multi-span-non-spanned-track-unaffected
(t/testing "tracks outside the span keep their size – tests (get allocated %1 0) default"
;; 4 tracks; child at col=2 span=2 → indexed covers tracks 1 and 2 (sentinel [3]).
;; Track 0 (before the span) and track 3 (sentinel) are never allocated.
;; from-idx = clamp(2-1, 0, 3) = 1
;; to-idx = clamp((2-1)+2, 0, 3) = 3
;; subvec(enumerate, 1, 3) = [[1,auto],[2,auto]]
;; size-to-allocate = 200 → both indexed tracks get 100
;; apply: track0 = max(0.01, get({},0,0)) = max(0.01,0) = 0.01 ← uses default 0
;; track1 = max(0.01, 100) = 100
;; track2 = max(0.01, 100) = 100
;; track3 = max(0.01, get({},3,0)) = 0.01 (sentinel)
(let [sid (random-uuid)
child (make-child 200 100)
tracks [(auto-track) (auto-track) (auto-track) (auto-track)]
cells {:c1 (make-cell sid 2 1 2 1)}
cmap {sid [(child-bounds 200 100) child]}
result (gld/set-auto-multi-span (auto-col-parent) tracks cmap cells frame-bounds {} :column)]
;; track before span: size stays at 0.01 (default 0 from missing allocation entry)
(t/is (mth/close? 0.01 (:size (nth result 0)) 0.001))
;; spanned tracks grow
(t/is (mth/close? 100.0 (:size (nth result 1)) 0.001))
(t/is (mth/close? 100.0 (:size (nth result 2)) 0.001))
;; sentinel after span also unaffected
(t/is (mth/close? 0.01 (:size (nth result 3)) 0.001)))))
(t/deftest set-auto-multi-span-row-type
(t/testing ":row type uses :row/:row-span and grows row tracks by child height"
;; child height = 200, row-gap = 0, row=1 span=2, 3 row tracks (sentinel at [2])
;; from-idx=0, to-idx=clamp(2,0,2)=2 → [[0,auto],[1,auto]]
;; size-to-allocate = 200 → each row track gets 100
(let [sid (random-uuid)
child (make-child 100 200)
tracks [(auto-track) (auto-track) (auto-track)]
cells {:c1 (make-cell sid 1 1 1 2)}
cmap {sid [(child-bounds 100 200) child]}
result (gld/set-auto-multi-span (auto-row-parent) tracks cmap cells frame-bounds {} :row)]
(t/is (mth/close? 100.0 (:size (nth result 0)) 0.001))
(t/is (mth/close? 100.0 (:size (nth result 1)) 0.001))
(t/is (mth/close? 0.01 (:size (nth result 2)) 0.001)))))
(t/deftest set-auto-multi-span-row-gap-deducted
(t/testing "row-gap is deducted from budget for :row type"
;; child height = 210, row-gap = 10, row-span = 2
;; size-to-allocate = 210 - 10*1 = 200 → each track gets 100
(let [sid (random-uuid)
child (make-child 100 210)
tracks [(auto-track) (auto-track) (auto-track)]
cells {:c1 (make-cell sid 1 1 1 2)}
cmap {sid [(child-bounds 100 210) child]}
result (gld/set-auto-multi-span (auto-row-parent 10) tracks cmap cells frame-bounds {} :row)]
(t/is (mth/close? 100.0 (:size (nth result 0)) 0.001))
(t/is (mth/close? 100.0 (:size (nth result 1)) 0.001))
(t/is (mth/close? 0.01 (:size (nth result 2)) 0.001)))))
(t/deftest set-auto-multi-span-smaller-span-processed-first
(t/testing "cells are sorted by span ascending (sort-by span -): smaller span allocates first"
;; NOTE: (sort-by prop-span -) uses `-` as a comparator; this yields ascending
;; order (smaller span first), not descending as the code comment implies.
;;
;; 4 tracks (sentinel at [3]):
;; cell-B: col=1 span=2 (covers indexed [0,1]) – processed first (span=2)
;; cell-A: col=1 span=3 (covers indexed [0,1,2]) – processed second (span=3)
;;
;; cell-B: child=100px, to-allocate=100.
;; non-assigned=[0,1]; pass1: idx0→max(0.01,50,0.01)=50; idx1→max(0.01,50,0.01)=50
;; allocated = {0:50, 1:50}
;;
;; cell-A: child=300px, to-allocate=300.
;; indexed=[0,1,2]; non-assigned=[2] (tracks 0,1 already allocated)
;; pass1 (non-assigned only): idx2→max(0.01,300/1,0.01)=300 ; rem=0
;; pass2 (to-alloc=0): max preserves existing values → no change
;; allocated = {0:50, 1:50, 2:300}
;;
;; Final: track0=50, track1=50, track2=300, track3(sentinel)=0.01
(let [sid-a (random-uuid)
sid-b (random-uuid)
child-a (make-child 300 100)
child-b (make-child 100 100)
tracks [(auto-track) (auto-track) (auto-track) (auto-track)] ; sentinel at [3]
cells {:ca (make-cell sid-a 1 1 3 1)
:cb (make-cell sid-b 1 1 2 1)}
cmap {sid-a [(child-bounds 300 100) child-a]
sid-b [(child-bounds 100 100) child-b]}
result (gld/set-auto-multi-span (auto-col-parent) tracks cmap cells frame-bounds {} :column)]
(t/is (mth/close? 50.0 (:size (nth result 0)) 0.001))
(t/is (mth/close? 50.0 (:size (nth result 1)) 0.001))
(t/is (mth/close? 300.0 (:size (nth result 2)) 0.001))
(t/is (mth/close? 0.01 (:size (nth result 3)) 0.001)))))
(t/deftest set-auto-multi-span-all-fixed-tracks-in-span
(t/testing "when all spanned tracks are fixed, no auto allocation occurs; fixed tracks unchanged"
;; tracks: [fixed 100, fixed 100, auto-sentinel]
;; col=1, span=2 → indexed = [[0,fixed100],[1,fixed100]]
;; find-auto-allocations: both fixed → auto-indexed-tracks = []
;; allocate-auto-tracks on empty list → no entries in allocated map
;; apply: track0 = max(100, get({},0,0)) = max(100,0) = 100 (unchanged)
;; track1 = max(100, get({},1,0)) = max(100,0) = 100 (unchanged)
(let [sid (random-uuid)
child (make-child 50 100)
tracks [(fixed-track 100) (fixed-track 100) (auto-track)]
cells {:c1 (make-cell sid 1 1 2 1)}
cmap {sid [(child-bounds 50 100) child]}
result (gld/set-auto-multi-span (auto-col-parent) tracks cmap cells frame-bounds {} :column)]
(t/is (mth/close? 100.0 (:size (nth result 0)) 0.001))
(t/is (mth/close? 100.0 (:size (nth result 1)) 0.001)))))

30
common/test/common_tests/geom_point_test.cljc
View File

@ -289,3 +289,33 @@
(t/is (mth/close? 1.2091818119288809 (:x rs)))
(t/is (mth/close? 1.8275638211757912 (:y rs)))))
;; ---- gpt/abs ----
(t/deftest abs-point-returns-point-instance
(t/testing "abs of a point with negative coordinates returns a Point record"
(let [p (gpt/point -3 -4)
rs (gpt/abs p)]
(t/is (gpt/point? rs))
(t/is (mth/close? 3 (:x rs)))
(t/is (mth/close? 4 (:y rs)))))
(t/testing "abs of a point with mixed-sign coordinates"
(let [p (gpt/point -5 7)
rs (gpt/abs p)]
(t/is (gpt/point? rs))
(t/is (mth/close? 5 (:x rs)))
(t/is (mth/close? 7 (:y rs)))))
(t/testing "abs of a point already positive is unchanged"
(let [p (gpt/point 2 9)
rs (gpt/abs p)]
(t/is (gpt/point? rs))
(t/is (mth/close? 2 (:x rs)))
(t/is (mth/close? 9 (:y rs)))))
(t/testing "abs of a zero point stays zero"
(let [rs (gpt/abs (gpt/point 0 0))]
(t/is (gpt/point? rs))
(t/is (mth/close? 0 (:x rs)))
(t/is (mth/close? 0 (:y rs))))))

94
common/test/common_tests/geom_rect_test.cljc Normal file
View File

@ -0,0 +1,94 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns common-tests.geom-rect-test
(:require
[app.common.geom.rect :as grc]
[app.common.math :as mth]
[clojure.test :as t]))
;; ---- update-rect :size ----
(t/deftest update-rect-size-sets-all-corners
(t/testing ":size updates x1/y1 as well as x2/y2 from x/y/width/height"
(let [r (grc/make-rect 10 20 30 40)
r' (grc/update-rect r :size)]
;; x1/y1 must mirror x/y
(t/is (mth/close? (:x r) (:x1 r')))
(t/is (mth/close? (:y r) (:y1 r')))
;; x2/y2 must be x+width / y+height
(t/is (mth/close? (+ (:x r) (:width r)) (:x2 r')))
(t/is (mth/close? (+ (:y r) (:height r)) (:y2 r')))))
(t/testing ":size is consistent with :corners round-trip"
;; Applying :size then :corners should recover the original x/y/w/h
(let [r (grc/make-rect 5 15 100 50)
r' (-> r (grc/update-rect :size) (grc/update-rect :corners))]
(t/is (mth/close? (:x r) (:x r')))
(t/is (mth/close? (:y r) (:y r')))
(t/is (mth/close? (:width r) (:width r')))
(t/is (mth/close? (:height r) (:height r')))))
(t/testing ":size works for a rect at the origin"
(let [r (grc/make-rect 0 0 200 100)
r' (grc/update-rect r :size)]
(t/is (mth/close? 0 (:x1 r')))
(t/is (mth/close? 0 (:y1 r')))
(t/is (mth/close? 200 (:x2 r')))
(t/is (mth/close? 100 (:y2 r'))))))
;; ---- corners->rect ----
(t/deftest corners->rect-normal-order
(t/testing "p1 top-left, p2 bottom-right yields a valid rect"
(let [r (grc/corners->rect 0 0 10 20)]
(t/is (grc/rect? r))
(t/is (mth/close? 0 (:x r)))
(t/is (mth/close? 0 (:y r)))
(t/is (mth/close? 10 (:width r)))
(t/is (mth/close? 20 (:height r))))))
(t/deftest corners->rect-reversed-corners
(t/testing "reversed x-coordinates still produce a positive-width rect"
(let [r (grc/corners->rect 10 0 0 20)]
(t/is (grc/rect? r))
(t/is (mth/close? 0 (:x r)))
(t/is (mth/close? 10 (:width r)))))
(t/testing "reversed y-coordinates still produce a positive-height rect"
(let [r (grc/corners->rect 0 20 10 0)]
(t/is (grc/rect? r))
(t/is (mth/close? 0 (:y r)))
(t/is (mth/close? 20 (:height r)))))
(t/testing "both axes reversed yield the same rect as normal order"
(let [r-normal (grc/corners->rect 0 0 10 20)
r-reversed (grc/corners->rect 10 20 0 0)]
(t/is (mth/close? (:x r-normal) (:x r-reversed)))
(t/is (mth/close? (:y r-normal) (:y r-reversed)))
(t/is (mth/close? (:width r-normal) (:width r-reversed)))
(t/is (mth/close? (:height r-normal) (:height r-reversed))))))
(t/deftest corners->rect-from-points
(t/testing "two-arity overload taking point maps works identically"
(let [p1 {:x 5 :y 10}
p2 {:x 15 :y 30}
r (grc/corners->rect p1 p2)]
(t/is (grc/rect? r))
(t/is (mth/close? 5 (:x r)))
(t/is (mth/close? 10 (:y r)))
(t/is (mth/close? 10 (:width r)))
(t/is (mth/close? 20 (:height r)))))
(t/testing "two-arity overload with reversed points"
(let [p1 {:x 15 :y 30}
p2 {:x 5 :y 10}
r (grc/corners->rect p1 p2)]
(t/is (grc/rect? r))
(t/is (mth/close? 5 (:x r)))
(t/is (mth/close? 10 (:y r)))
(t/is (mth/close? 10 (:width r)))
(t/is (mth/close? 20 (:height r))))))

27
common/test/common_tests/geom_shapes_constraints_test.cljc Normal file
View File

@ -0,0 +1,27 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns common-tests.geom-shapes-constraints-test
(:require
[app.common.geom.shapes.constraints :as gsc]
[clojure.test :as t]))
;; ---- constraint-modifier :default ----
(t/deftest constraint-modifier-default-returns-empty-vector
(t/testing ":default method accepts 6 args and returns an empty vector"
;; Before the fix the :default method only accepted 5 positional args
;; (plus the dispatch value), so calling it with 6 args would throw an
;; arity error. After the fix it takes [_ _ _ _ _ _] and returns [].
(let [result (gsc/constraint-modifier :unknown-constraint-type
:x nil nil nil nil)]
(t/is (vector? result))
(t/is (empty? result))))
(t/testing ":default method returns [] for :scale-like unknown type on :y axis"
(let [result (gsc/constraint-modifier :some-other-unknown
:y nil nil nil nil)]
(t/is (= [] result)))))

10
common/test/common_tests/geom_shapes_intersect_test.cljc
View File

@ -52,12 +52,10 @@
[(pt 0 5) (pt 10 5)]))))
(t/testing "Two collinear overlapping segments"
;; NOTE: The implementation compares orientation result (namespaced keyword ::coplanar)
;; against unnamespaced :coplanar, so the collinear branch never triggers.
;; Collinear overlapping segments are NOT detected as intersecting.
(t/is (false? (gint/intersect-segments?
[(pt 0 0) (pt 10 0)]
[(pt 5 0) (pt 15 0)]))))
;; Collinear overlapping segments correctly detected as intersecting.
(t/is (true? (gint/intersect-segments?
[(pt 0 0) (pt 10 0)]
[(pt 5 0) (pt 15 0)]))))
(t/testing "Two non-overlapping collinear segments"
(t/is (false? (gint/intersect-segments?

41
common/test/common_tests/geom_shapes_test.cljc
View File

@ -230,3 +230,44 @@
(t/is (true? (gsin/slow-has-point? shape point1)))
(t/is (false? (gsin/fast-has-point? shape point2)))
(t/is (false? (gsin/fast-has-point? shape point2)))))
;; ---- adjust-shape-flips (via apply-transform / transform-shape) ----
(t/deftest flip-x-only-toggles-flip-x-and-negates-rotation
(t/testing "Flipping only X axis toggles flip-x and negates rotation"
;; Build a rect with a known rotation, then apply a scale(-1, 1)
;; from the left edge to simulate an X-axis flip.
(let [shape (create-test-shape :rect {:rotation 30})
;; Flip horizontally about x=0 (left edge of shape)
origin (gpt/point (get-in shape [:selrect :x]) (get-in shape [:selrect :y]))
mods (ctm/resize-modifiers (gpt/point -1 1) origin)
result (gsh/transform-shape shape mods)]
;; flip-x should have been toggled (from nil/false to true)
(t/is (true? (:flip-x result)))
;; flip-y should NOT be set
(t/is (not (true? (:flip-y result))))
;; rotation is negated then normalised into [0,360): -30 mod 360 = 330
(t/is (mth/close? 330 (:rotation result))))))
(t/deftest flip-y-only-toggles-flip-y-and-negates-rotation
(t/testing "Flipping only Y axis toggles flip-y and negates rotation"
(let [shape (create-test-shape :rect {:rotation 45})
origin (gpt/point (get-in shape [:selrect :x]) (get-in shape [:selrect :y]))
mods (ctm/resize-modifiers (gpt/point 1 -1) origin)
result (gsh/transform-shape shape mods)]
(t/is (not (true? (:flip-x result))))
(t/is (true? (:flip-y result)))
;; -45 mod 360 = 315
(t/is (mth/close? 315 (:rotation result))))))
(t/deftest flip-both-axes-toggles-both-flags-but-preserves-rotation
(t/testing "Flipping both axes toggles flip-x and flip-y, but does NOT negate rotation"
;; Two simultaneous axis flips = 180° rotation, so stored rotation is unchanged.
(let [shape (create-test-shape :rect {:rotation 30})
origin (gpt/point (get-in shape [:selrect :x]) (get-in shape [:selrect :y]))
mods (ctm/resize-modifiers (gpt/point -1 -1) origin)
result (gsh/transform-shape shape mods)]
(t/is (true? (:flip-x result)))
(t/is (true? (:flip-y result)))
;; rotation must not be negated when both axes are flipped
(t/is (mth/close? 30 (:rotation result))))))

26
common/test/common_tests/geom_test.cljc
View File

@ -9,6 +9,7 @@
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.math :as mth]
[app.common.schema :as sm]
[clojure.test :as t]))
(t/deftest point-constructors-test
@ -100,3 +101,28 @@
(let [m (-> (gmt/matrix)
(gmt/rotate 10))]
(t/is (= m (gmt/matrix 0.984807753012208 0.17364817766693033 -0.17364817766693033 0.984807753012208 0 0)))))
;; ---- matrix->str (no trailing comma) ----
(t/deftest matrix-str-roundtrip-test
(t/testing "Identity matrix encodes and decodes back to equal matrix"
(let [m (gmt/matrix)
enc (sm/encode gmt/schema:matrix m (sm/string-transformer))
dec (sm/decode gmt/schema:matrix enc (sm/string-transformer))]
(t/is (string? enc))
;; Must not end with a comma
(t/is (not= \, (last enc)))
(t/is (gmt/close? m dec))))
(t/testing "Arbitrary matrix encodes without trailing comma and round-trips"
(let [m (gmt/matrix 2 0.5 -0.5 3 10 20)
enc (sm/encode gmt/schema:matrix m (sm/string-transformer))
dec (sm/decode gmt/schema:matrix enc (sm/string-transformer))]
(t/is (string? enc))
(t/is (not= \, (last enc)))
(t/is (gmt/close? m dec))))
(t/testing "Encoded string contains exactly 5 commas (6 fields)"
(let [m (gmt/matrix 1 0 0 1 0 0)
enc (sm/encode gmt/schema:matrix m (sm/string-transformer))]
(t/is (= 5 (count (filter #(= \, %) enc)))))))

14
common/test/common_tests/runner.cljc
View File

@ -6,21 +6,27 @@
(ns common-tests.runner
(:require
#?(:clj [common-tests.fressian-test])
[clojure.test :as t]
[common-tests.buffer-test]
[common-tests.colors-test]
[common-tests.data-test]
[common-tests.files-builder-test]
[common-tests.files-changes-test]
[common-tests.files-migrations-test]
[common-tests.geom-align-test]
[common-tests.geom-bounds-map-test]
[common-tests.geom-flex-layout-test]
[common-tests.geom-grid-layout-test]
[common-tests.geom-grid-test]
[common-tests.geom-line-test]
[common-tests.geom-modif-tree-test]
[common-tests.geom-modifiers-test]
[common-tests.geom-point-test]
[common-tests.geom-proportions-test]
[common-tests.geom-rect-test]
[common-tests.geom-shapes-common-test]
[common-tests.geom-shapes-constraints-test]
[common-tests.geom-shapes-corners-test]
[common-tests.geom-shapes-effects-test]
[common-tests.geom-shapes-intersect-test]
@ -53,6 +59,7 @@
[common-tests.text-test]
[common-tests.time-test]
[common-tests.types.absorb-assets-test]
[common-tests.types.color-test]
[common-tests.types.components-test]
[common-tests.types.container-test]
[common-tests.types.fill-test]
@ -81,17 +88,23 @@
'common-tests.buffer-test
'common-tests.colors-test
'common-tests.data-test
#?(:clj 'common-tests.fressian-test)
'common-tests.files-changes-test
'common-tests.files-builder-test
'common-tests.files-migrations-test
'common-tests.geom-align-test
'common-tests.geom-bounds-map-test
'common-tests.geom-flex-layout-test
'common-tests.geom-grid-layout-test
'common-tests.geom-grid-test
'common-tests.geom-line-test
'common-tests.geom-modif-tree-test
'common-tests.geom-modifiers-test
'common-tests.geom-point-test
'common-tests.geom-proportions-test
'common-tests.geom-rect-test
'common-tests.geom-shapes-common-test
'common-tests.geom-shapes-constraints-test
'common-tests.geom-shapes-corners-test
'common-tests.geom-shapes-effects-test
'common-tests.geom-shapes-intersect-test
@ -124,6 +137,7 @@
'common-tests.text-test
'common-tests.time-test
'common-tests.types.absorb-assets-test
'common-tests.types.color-test
'common-tests.types.components-test
'common-tests.types.container-test
'common-tests.types.fill-test

166
common/test/common_tests/types/color_test.cljc Normal file
View File

@ -0,0 +1,166 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns common-tests.types.color-test
(:require
[app.common.math :as mth]
[app.common.types.color :as colors]
[clojure.test :as t]))
;; --- Predicates
(t/deftest valid-hex-color
(t/is (false? (colors/valid-hex-color? nil)))
(t/is (false? (colors/valid-hex-color? "")))
(t/is (false? (colors/valid-hex-color? "#")))
(t/is (false? (colors/valid-hex-color? "#qqqqqq")))
(t/is (true? (colors/valid-hex-color? "#aaa")))
(t/is (false? (colors/valid-hex-color? "#aaaa")))
(t/is (true? (colors/valid-hex-color? "#fabada"))))
(t/deftest valid-rgb-color
(t/is (false? (colors/valid-rgb-color? nil)))
(t/is (false? (colors/valid-rgb-color? "")))
(t/is (false? (colors/valid-rgb-color? "()")))
(t/is (true? (colors/valid-rgb-color? "(255, 30, 30)")))
(t/is (true? (colors/valid-rgb-color? "rgb(255, 30, 30)"))))
;; --- Conversions
(t/deftest rgb-to-str
(t/is (= "rgb(1,2,3)" (colors/rgb->str [1 2 3])))
(t/is (= "rgba(1,2,3,4)" (colors/rgb->str [1 2 3 4]))))
(t/deftest rgb-to-hsv
(t/is (= [210.0 0.6666666666666666 3.0] (colors/rgb->hsv [1.0 2.0 3.0]))))
(t/deftest hsv-to-rgb
(t/is (= [1 2 3]
(colors/hsv->rgb [210 0.6666666666666666 3]))))
(t/deftest rgb-to-hex
(t/is (= "#010203" (colors/rgb->hex [1 2 3]))))
(t/deftest hex-to-rgb
(t/is (= [0 0 0] (colors/hex->rgb "#kkk")))
(t/is (= [1 2 3] (colors/hex->rgb "#010203"))))
(t/deftest format-hsla
(t/is (= "210, 50%, 0.78%, 1" (colors/format-hsla [210.0 0.5 0.00784313725490196 1])))
(t/is (= "220, 5%, 30%, 0.8" (colors/format-hsla [220.0 0.05 0.3 0.8]))))
(t/deftest format-rgba
(t/is (= "210, 199, 12, 0.08" (colors/format-rgba [210 199 12 0.08])))
(t/is (= "210, 199, 12, 1" (colors/format-rgba [210 199 12 1]))))
(t/deftest rgb-to-hsl
(t/is (= [210.0 0.5 0.00784313725490196] (colors/rgb->hsl [1 2 3]))))
(t/deftest hsl-to-rgb
(t/is (= [1 2 3] (colors/hsl->rgb [210.0 0.5 0.00784313725490196])))
(t/is (= [210.0 0.5 0.00784313725490196] (colors/rgb->hsl [1 2 3]))))
(t/deftest expand-hex
(t/is (= "aaaaaa" (colors/expand-hex "a")))
(t/is (= "aaaaaa" (colors/expand-hex "aa")))
(t/is (= "aaaaaa" (colors/expand-hex "aaa")))
(t/is (= "aaaa" (colors/expand-hex "aaaa"))))
(t/deftest prepend-hash
(t/is "#aaa" (colors/prepend-hash "aaa"))
(t/is "#aaa" (colors/prepend-hash "#aaa")))
(t/deftest remove-hash
(t/is "aaa" (colors/remove-hash "aaa"))
(t/is "aaa" (colors/remove-hash "#aaa")))
(t/deftest color-string-pred
(t/is (true? (colors/color-string? "#aaa")))
(t/is (true? (colors/color-string? "(10,10,10)")))
(t/is (true? (colors/color-string? "rgb(10,10,10)")))
(t/is (true? (colors/color-string? "magenta")))
(t/is (false? (colors/color-string? nil)))
(t/is (false? (colors/color-string? "")))
(t/is (false? (colors/color-string? "kkkkkk"))))
;; --- Gradient helpers
(t/deftest interpolate-color
(t/testing "at c1 offset returns c1 color"
(let [c1 {:color "#000000" :opacity 0.0 :offset 0.0}
c2 {:color "#ffffff" :opacity 1.0 :offset 1.0}
result (colors/interpolate-color c1 c2 0.0)]
(t/is (= "#000000" (:color result)))
(t/is (= 0.0 (:opacity result)))))
(t/testing "at c2 offset returns c2 color"
(let [c1 {:color "#000000" :opacity 0.0 :offset 0.0}
c2 {:color "#ffffff" :opacity 1.0 :offset 1.0}
result (colors/interpolate-color c1 c2 1.0)]
(t/is (= "#ffffff" (:color result)))
(t/is (= 1.0 (:opacity result)))))
(t/testing "at midpoint returns interpolated gray"
(let [c1 {:color "#000000" :opacity 0.0 :offset 0.0}
c2 {:color "#ffffff" :opacity 1.0 :offset 1.0}
result (colors/interpolate-color c1 c2 0.5)]
(t/is (= "#7f7f7f" (:color result)))
(t/is (mth/close? (:opacity result) 0.5)))))
(t/deftest uniform-spread
(t/testing "produces correct count and offsets"
(let [c1 {:color "#000000" :opacity 0.0 :offset 0.0}
c2 {:color "#ffffff" :opacity 1.0 :offset 1.0}
stops (colors/uniform-spread c1 c2 3)]
(t/is (= 3 (count stops)))
(t/is (= 0.0 (:offset (first stops))))
(t/is (mth/close? 0.5 (:offset (second stops))))
(t/is (= 1.0 (:offset (last stops))))))
(t/testing "single stop returns a vector of one element (no division by zero)"
(let [c1 {:color "#ff0000" :opacity 1.0 :offset 0.0}
stops (colors/uniform-spread c1 c1 1)]
(t/is (= 1 (count stops))))))
(t/deftest uniform-spread?
(t/testing "uniformly spread stops are detected as uniform"
(let [c1 {:color "#000000" :opacity 0.0 :offset 0.0}
c2 {:color "#ffffff" :opacity 1.0 :offset 1.0}
stops (colors/uniform-spread c1 c2 3)]
(t/is (true? (colors/uniform-spread? stops)))))
(t/testing "two-stop gradient is uniform by definition"
(let [stops [{:color "#ff0000" :opacity 1.0 :offset 0.0}
{:color "#0000ff" :opacity 1.0 :offset 1.0}]]
(t/is (true? (colors/uniform-spread? stops)))))
(t/testing "stops with wrong offset are not uniform"
(let [stops [{:color "#000000" :opacity 0.0 :offset 0.0}
{:color "#888888" :opacity 0.5 :offset 0.3}
{:color "#ffffff" :opacity 1.0 :offset 1.0}]]
(t/is (false? (colors/uniform-spread? stops)))))
(t/testing "stops with correct offset but wrong color are not uniform"
(let [stops [{:color "#000000" :opacity 0.0 :offset 0.0}
{:color "#aaaaaa" :opacity 0.5 :offset 0.5}
{:color "#ffffff" :opacity 1.0 :offset 1.0}]]
(t/is (false? (colors/uniform-spread? stops))))))
(t/deftest interpolate-gradient
(t/testing "at start offset returns first stop color"
(let [stops [{:color "#000000" :opacity 0.0 :offset 0.0}
{:color "#ffffff" :opacity 1.0 :offset 1.0}]
result (colors/interpolate-gradient stops 0.0)]
(t/is (= "#000000" (:color result)))))
(t/testing "at end offset returns last stop color"
(let [stops [{:color "#000000" :opacity 0.0 :offset 0.0}
{:color "#ffffff" :opacity 1.0 :offset 1.0}]
result (colors/interpolate-gradient stops 1.0)]
(t/is (= "#ffffff" (:color result)))))
(t/testing "at midpoint returns interpolated gray"
(let [stops [{:color "#000000" :opacity 0.0 :offset 0.0}
{:color "#ffffff" :opacity 1.0 :offset 1.0}]
result (colors/interpolate-gradient stops 0.5)]
(t/is (= "#7f7f7f" (:color result)))))
(t/testing "offset beyond last stop returns last stop color (nil idx guard)"
(let [stops [{:color "#000000" :opacity 0.0 :offset 0.0}
{:color "#ffffff" :opacity 1.0 :offset 0.5}]
result (colors/interpolate-gradient stops 1.0)]
(t/is (= "#ffffff" (:color result))))))

15
common/test/common_tests/types/fill_test.cljc
View File

@ -207,3 +207,18 @@
fill1 (nth fills1 1)]
(t/is (nil? fill1))
(t/is (equivalent-fill? fill0 sample-fill-6))))
(t/deftest indexed-access-with-default
(t/testing "nth with default returns fill for valid index"
;; Regression: CLJS -nth with default had reversed d/in-range? args,
;; so it always fell through to the default even for valid indices.
(let [fills (types.fills/from-plain [sample-fill-6])
sentinel ::not-found
result (nth fills 0 sentinel)]
(t/is (not= sentinel result))
(t/is (equivalent-fill? result sample-fill-6))))
(t/testing "nth with default returns default for out-of-range index"
(let [fills (types.fills/from-plain [sample-fill-6])
sentinel ::not-found]
(t/is (= sentinel (nth fills 1 sentinel)))
(t/is (= sentinel (nth fills -1 sentinel))))))

25
common/test/common_tests/types/path_data_test.cljc
View File

@ -973,6 +973,31 @@
(t/is (mth/close? 10.0 (:x2 rect) 0.1))
(t/is (mth/close? 10.0 (:y2 rect) 0.1))))
(t/deftest segment-content->selrect-multi-line
;; Regression: calculate-extremities used move-p instead of from-p in
;; the :line-to branch. For a subpath with multiple consecutive line-to
;; commands, the selrect must still match the reference implementation.
(let [;; A subpath that starts away from the origin and has three
;; line-to segments so that move-p diverges from from-p for the
;; later segments.
segments [{:command :move-to :params {:x 5.0 :y 5.0}}
{:command :line-to :params {:x 15.0 :y 0.0}}
{:command :line-to :params {:x 20.0 :y 8.0}}
{:command :line-to :params {:x 10.0 :y 12.0}}]
content (path/content segments)
rect (path.segment/content->selrect content)
ref-pts (calculate-extremities segments)]
;; Bounding box must enclose all four vertices exactly.
(t/is (some? rect))
(t/is (mth/close? 5.0 (:x1 rect) 0.1))
(t/is (mth/close? 0.0 (:y1 rect) 0.1))
(t/is (mth/close? 20.0 (:x2 rect) 0.1))
(t/is (mth/close? 12.0 (:y2 rect) 0.1))
;; Must agree with the reference implementation.
(t/is (= ref-pts (calculate-extremities content)))))
(t/deftest segment-content-center
(let [content (path/content sample-content-square)
center (path.segment/content-center content)]

8
common/test/common_tests/types/shape_layout_test.cljc
View File

@ -186,13 +186,9 @@
flex (make-flex-frame :parent-id root-id)
child (make-shape :parent-id (:id flex))]
;; Note: inside-layout? calls (cfh/frame-shape? current-id) with a UUID id,
;; but frame-shape? checks (:type uuid) which is nil for a UUID value.
;; The function therefore always returns false regardless of structure.
;; These tests document the actual (not the intended) behavior.
(t/testing "returns false when child is under a flex frame"
(t/testing "returns true when child is under a flex frame"
(let [objects {root-id root (:id flex) flex (:id child) child}]
(t/is (not (layout/inside-layout? objects child)))))
(t/is (layout/inside-layout? objects child))))
(t/testing "returns false for root shape"
(let [objects {root-id root (:id flex) flex (:id child) child}]

2
common/test/common_tests/types/tokens_lib_test.cljc
View File

@ -1930,7 +1930,7 @@
(let [token (ctob/get-token-by-name lib "shadow-test" "test.shadow-with-type")]
(t/is (some? token))
(t/is (= :shadow (:type token)))
(t/is (= [{:offset-x "0", :offset-y "4px", :blur "8px", :spread "0", :color "rgba(0,0,0,0.2)", :inset false}]
(t/is (= [{:offset-x "0", :offset-y "4px", :blur "8px", :spread "0", :color "rgba(0,0,0,0.2)", :inset true}]
(:value token)))))
(t/testing "shadow token with description"

6
frontend/src/app/config.cljs
View File

@ -161,6 +161,7 @@
(def plugins-list-uri (obj/get global "penpotPluginsListUri" "https://penpot.app/penpothub/plugins"))
(def plugins-whitelist (into #{} (obj/get global "penpotPluginsWhitelist" [])))
(def templates-uri (obj/get global "penpotTemplatesUri" "https://penpot.github.io/penpot-files/"))
(def upload-chunk-size (obj/get global "penpotUploadChunkSize" (* 1024 1024 25))) ;; 25 MiB
;; We set the current parsed flags under common for make
;; it available for common code without the need to pass
@ -204,6 +205,11 @@
(let [f (obj/get global "externalContextInfo")]
(when (fn? f) (f))))
(defn external-notify-register-success
[profile-id]
(let [f (obj/get global "externalNotifyRegisterSuccess")]
(when (fn? f) (f (str profile-id)))))
(defn initialize-external-context-info
[]
(let [f (obj/get global "initializeExternalConfigInfo")]

70
frontend/src/app/main/data/uploads.cljs Normal file
View File

@ -0,0 +1,70 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.main.data.uploads
"Generic chunked-upload helpers.
Provides a purpose-agnostic three-step session API that can be used
by any feature that needs to upload large binary blobs:
1. create-upload-session – obtain a session-id
2. upload-chunk – upload each slice (max-parallel-chunk-uploads in-flight)
3. caller-specific step – e.g. assemble-file-media-object or import-binfile
`upload-blob-chunked` drives steps 1 and 2 and emits the completed
`{:session-id …}` map so that the caller can proceed with its own
step 3."
(:require
[app.common.data.macros :as dm]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.main.repo :as rp]
[beicon.v2.core :as rx]))
;; Size of each upload chunk in bytes. Reads the penpotUploadChunkSize global
;; variable at startup; defaults to 25 MiB (overridden in production).
(def ^:private chunk-size cf/upload-chunk-size)
(def ^:private max-parallel-chunk-uploads
"Maximum number of chunk upload requests that may be in-flight at the
same time within a single chunked upload session."
2)
(defn upload-blob-chunked
"Uploads `blob` via the three-step chunked session API.
Steps performed:
1. Creates an upload session (`create-upload-session`).
2. Slices `blob` and uploads every chunk (`upload-chunk`),
with at most `max-parallel-chunk-uploads` concurrent requests.
Returns an observable that emits exactly one map:
`{:session-id <uuid>}`
The caller is responsible for the final step (assemble / import)."
[blob]
(let [total-size (.-size blob)
total-chunks (js/Math.ceil (/ total-size chunk-size))]
(->> (rp/cmd! :create-upload-session
{:total-chunks total-chunks})
(rx/mapcat
(fn [{raw-session-id :session-id}]
(let [session-id (cond-> raw-session-id
(string? raw-session-id) uuid/uuid)
chunk-uploads
(->> (range total-chunks)
(map (fn [idx]
(let [start (* idx chunk-size)
end (min (+ start chunk-size) total-size)
chunk (.slice blob start end)]
(rp/cmd! :upload-chunk
{:session-id session-id
:index idx
:content (list chunk (dm/str "chunk-" idx))})))))]
(->> (rx/from chunk-uploads)
(rx/merge-all max-parallel-chunk-uploads)
(rx/last)
(rx/map (fn [_] {:session-id session-id})))))))))

14
frontend/src/app/main/data/viewer.cljs
View File

@ -204,7 +204,7 @@
(watch [_ state _]
(let [route (:route state)
qparams (:query-params route)
index (some-> (:index qparams) parse-long)
index (some-> (rt/get-query-param qparams :index) parse-long)
frame-id (some-> (:frame-id qparams) uuid/parse)]
(rx/merge
(rx/of (case (:zoom qparams)
@ -301,7 +301,7 @@
(update [_ state]
(let [params (rt/get-params state)
page-id (some-> (:page-id params) uuid/parse)
index (some-> (:index params) parse-long)
index (some-> (rt/get-query-param params :index) parse-long)
frames (dm/get-in state [:viewer :pages page-id :frames])
index (min (or index 0) (max 0 (dec (count frames))))
@ -325,7 +325,7 @@
(let [params (rt/get-params state)
page-id (some-> (:page-id params) uuid/parse)
index (some-> (:index params) parse-long)
index (some-> (rt/get-query-param params :index) parse-long)
frames (dm/get-in state [:viewer :pages page-id :frames])
index (min (or index 0) (max 0 (dec (count frames))))
@ -399,7 +399,7 @@
ptk/WatchEvent
(watch [_ state _]
(let [params (rt/get-params state)
index (some-> params :index parse-long)]
index (some-> (rt/get-query-param params :index) parse-long)]
(when (pos? index)
(rx/of
(dcmt/close-thread)
@ -415,7 +415,7 @@
ptk/WatchEvent
(watch [_ state _]
(let [params (rt/get-params state)
index (some-> params :index parse-long)
index (some-> (rt/get-query-param params :index) parse-long)
page-id (some-> params :page-id uuid/parse)
total (count (get-in state [:viewer :pages page-id :frames]))]
@ -530,7 +530,7 @@
(let [route (:route state)
qparams (:query-params route)
page-id (some-> (:page-id qparams) uuid/parse)
index (some-> (:index qparams) parse-long)
index (some-> (rt/get-query-param qparams :index) parse-long)
frames (get-in state [:viewer :pages page-id :frames])
frame (get frames index)]
(cond-> state
@ -744,7 +744,7 @@
(let [route (:route state)
qparams (:query-params route)
page-id (some-> (:page-id qparams) uuid/parse)
index (some-> (:index qparams) parse-long)
index (some-> (rt/get-query-param qparams :index) parse-long)
objects (get-in state [:viewer :pages page-id :objects])
frame-id (get-in state [:viewer :pages page-id :frames index :id])

13
frontend/src/app/main/data/workspace/libraries.cljs
View File

@ -411,9 +411,16 @@
(when id-ref
(reset! id-ref component-id))
(when-not (empty? (:redo-changes changes))
(rx/of (dch/commit-changes changes)
(dws/select-shapes (d/ordered-set (:id root)))
(ptk/data-event :layout/update {:ids parents}))))))))))
(rx/concat
(rx/of (dch/commit-changes changes)
(dws/select-shapes (d/ordered-set (:id root)))
(ptk/data-event :layout/update {:ids parents}))
;; When activated the wasm rendering we need to recreate its thumbnail on creation
(if (features/active-feature? state "render-wasm/v1")
(rx/of (dwt.wasm/render-thumbnail file-id page-id (:id root))
(dwt.wasm/persist-thumbnail file-id page-id (:id root)))
(rx/empty)))))))))))
(defn add-component
"Add a new component to current file library, from the currently selected shapes.

62
frontend/src/app/main/data/workspace/media.cljs
View File

@ -24,6 +24,7 @@
[app.main.data.helpers :as dsh]
[app.main.data.media :as dmm]
[app.main.data.notifications :as ntf]
[app.main.data.uploads :as uploads]
[app.main.data.workspace.shapes :as dwsh]
[app.main.data.workspace.svg-upload :as svg]
[app.main.repo :as rp]
@ -103,6 +104,26 @@
:url url
:is-local true}))
;; Size of each upload chunk in bytes — read from config directly,
;; same source used by the uploads namespace.
(def ^:private chunk-size cf/upload-chunk-size)
(defn- upload-blob-chunked
"Uploads `blob` to `file-id` as a chunked media object using the
three-step session API. Returns an observable that emits the
assembled file-media-object map."
[{:keys [file-id name is-local blob]}]
(let [mtype (.-type blob)]
(->> (uploads/upload-blob-chunked blob)
(rx/mapcat
(fn [{:keys [session-id]}]
(rp/cmd! :assemble-file-media-object
{:session-id session-id
:file-id file-id
:is-local is-local
:name name
:mtype mtype}))))))
(defn process-uris
[{:keys [file-id local? name uris mtype on-image on-svg]}]
(letfn [(svg-url? [url]
@ -143,12 +164,18 @@
(and (not force-media)
(= (.-type blob) "image/svg+xml")))
(prepare-blob [blob]
(let [name (or name (if (dmm/file? blob) (media/strip-image-extension (.-name blob)) "blob"))]
{:file-id file-id
:name name
:is-local local?
:content blob}))
(upload-blob [blob]
(let [params {:file-id file-id
:name (or name (if (dmm/file? blob) (media/strip-image-extension (.-name blob)) "blob"))
:is-local local?
:blob blob}]
(if (>= (.-size blob) chunk-size)
(upload-blob-chunked params)
(rp/cmd! :upload-file-media-object
{:file-id file-id
:name (:name params)
:is-local local?
:content blob}))))
(extract-content [blob]
(let [name (or name (.-name blob))]
@ -159,8 +186,7 @@
(->> (rx/from blobs)
(rx/map dmm/validate-file)
(rx/filter (comp not svg-blob?))
(rx/map prepare-blob)
(rx/mapcat #(rp/cmd! :upload-file-media-object %))
(rx/mapcat upload-blob)
(rx/tap on-image))
(->> (rx/from blobs)
@ -170,9 +196,10 @@
(rx/merge-map svg->clj)
(rx/tap on-svg)))))
(defn handle-media-error [error on-error]
(if (ex/ex-info? error)
(handle-media-error (ex-data error) on-error)
(defn handle-media-error
[cause]
(ex/print-throwable cause)
(let [error (ex-data cause)]
(cond
(= (:code error) :invalid-svg-file)
(rx/of (ntf/error (tr "errors.media-type-not-allowed")))
@ -195,13 +222,8 @@
(= (:code error) :unable-to-optimize)
(rx/of (ntf/error (:hint error)))
(fn? on-error)
(on-error error)
:else
(do
(.error js/console "ERROR" error)
(rx/of (ntf/error (tr "errors.cannot-upload")))))))
(rx/of (ntf/error (tr "errors.cannot-upload"))))))
(def ^:private
@ -215,7 +237,7 @@
[:mtype {:optional true} :string]])
(defn- process-media-objects
[{:keys [uris on-error] :as params}]
[{:keys [uris] :as params}]
(dm/assert!
(and (sm/check schema:process-media-objects params)
(or (contains? params :blobs)
@ -238,7 +260,7 @@
;; Every stream has its own sideeffect. We need to ignore the result
(rx/ignore)
(rx/catch #(handle-media-error % on-error))
(rx/catch handle-media-error)
(rx/finalize #(st/emit! (ntf/hide :tag :media-loading))))))))
(defn upload-media-workspace
@ -278,8 +300,6 @@
(rx/tap on-upload-success)
(rx/catch handle-media-error))))))
;; --- Upload File Media objects
(defn create-shapes-svg
"Convert svg elements into penpot shapes."
[file-id objects pos svg-data]

50
frontend/src/app/main/data/workspace/texts.cljs
View File

@ -400,7 +400,11 @@
shape-ids (cond (cfh/text-shape? shape) [id]
(cfh/group-shape? shape) (cfh/get-children-ids objects id))]
(rx/of (dwsh/update-shapes shape-ids update-fn))))))
(rx/concat
(rx/of (dwsh/update-shapes shape-ids update-fn))
(if (features/active-feature? state "render-wasm/v1")
(dwwt/resize-wasm-text-debounce id)
(rx/empty)))))))
(defn update-root-attrs
[{:keys [id attrs]}]
@ -503,13 +507,9 @@
ptk/WatchEvent
(watch [_ state _]
(when (or
(and (features/active-feature? state "text-editor-wasm/v1")
(nil? (get-in state [:workspace-wasm-editor-styles id])))
(and (features/active-feature? state "text-editor/v2")
(not (features/active-feature? state "text-editor-wasm/v1"))
(nil? (:workspace-editor state)))
(and (not (features/active-feature? state "text-editor/v2"))
(not (features/active-feature? state "text-editor-wasm/v1"))
(nil? (get-in state [:workspace-editor-state id]))))
(let [page-id (or (get options :page-id)
(get state :current-page-id))
@ -533,16 +533,20 @@
(-> shape
(dissoc :fills)
(d/update-when :content update-content)))]
(rx/of (dwsh/update-shapes shape-ids update-shape options)))))
(rx/concat (rx/of (dwsh/update-shapes shape-ids update-shape options))
(when (features/active-feature? state "text-editor-wasm/v1")
(let [styles ((comp update-node-fn migrate-node))
result (wasm.api/apply-styles-to-selection styles)]
(when result
(rx/of (v2-update-text-shape-content
(:shape-id result)
(:content result)
:update-name? true)))))))))
ptk/EffectEvent
(effect [_ state _]
(cond
(features/active-feature? state "text-editor-wasm/v1")
(let [styles ((comp update-node-fn migrate-node))]
(wasm.api/apply-styles-to-selection styles))
(features/active-feature? state "text-editor/v2")
(when (features/active-feature? state "text-editor/v2")
(when-let [instance (:workspace-editor state)]
(let [styles (some-> (editor.v2/getCurrentStyle instance)
(styles/get-styles-from-style-declaration :removed-mixed true)
@ -786,11 +790,18 @@
(rx/of (update-position-data id position-data))))
(rx/empty))))))
(defn font-loaded-event?
[font-id]
(fn [event]
(and
(= :font-loaded (ptk/type event))
(= (:font-id (deref event)) font-id))))
(defn update-attrs
[id attrs]
(ptk/reify ::update-attrs
ptk/WatchEvent
(watch [_ state _]
(watch [_ state stream]
(let [text-editor-instance (:workspace-editor state)]
(if (and (features/active-feature? state "text-editor/v2")
(some? text-editor-instance))
@ -811,7 +822,8 @@
(rx/of (update-text-attrs {:id id :attrs attrs}))
(rx/empty)))
(when (features/active-feature? state "text-editor/v2")
(when (and (features/active-feature? state "text-editor/v2")
(not (features/active-feature? state "text-editor-wasm/v1")))
(rx/of (v2-update-text-editor-styles id attrs)))
(when (features/active-feature? state "render-wasm/v1")
@ -827,9 +839,13 @@
(:shape-id result) (:content result)
:update-name? true))))))))
;; Resize (with delay for font-id changes)
(cond->> (rx/of (dwwt/resize-wasm-text id))
(contains? attrs :font-id)
(rx/delay 200))))))))
(if (contains? attrs :font-id)
(->> stream
(rx/filter (font-loaded-event? (:font-id attrs)))
(rx/take 1)
(rx/observe-on :async)
(rx/map #(dwwt/resize-wasm-text id)))
(rx/of (dwwt/resize-wasm-text id)))))))))
ptk/EffectEvent
(effect [_ state _]

99
frontend/src/app/main/data/workspace/thumbnails_wasm.cljs
View File

@ -15,11 +15,15 @@
- persist-thumbnail: pushes current data-uri to the server (debounced)"
(:require
[app.common.data.macros :as dm]
[app.common.files.helpers :as cfh]
[app.common.logging :as l]
[app.common.math :as mth]
[app.common.thumbnails :as thc]
[app.common.time :as ct]
[app.main.data.helpers :as dsh]
[app.main.data.workspace.thumbnails :as dwt]
[app.main.repo :as rp]
[app.main.store :as st]
[app.render-wasm.api :as wasm.api]
[app.util.webapi :as wapi]
[beicon.v2.core :as rx]
@ -41,59 +45,100 @@
(fn [e] (reject e)))
(.readAsDataURL reader blob)))))
;; This constant stores the target thumbnail minimum max-size so
;; the images doesn't lose quality when rendered
(def ^:private ^:const target-size 200)
(defn- render-component-pixels
"Renders a component frame using the workspace WASM context.
Returns an observable that emits a data-uri string.
Deferred by one animation frame so that process-shape-changes!
has time to sync all child shapes to WASM memory first."
[frame-id]
[file-id page-id frame-id]
(rx/create
(fn [subs]
(js/requestAnimationFrame
(fn [_]
(try
(let [png-bytes (wasm.api/render-shape-pixels frame-id 1)]
(if (or (nil? png-bytes) (zero? (.-length png-bytes)))
(do (js/console.error "[thumbnails] render-shape-pixels returned empty for" (str frame-id))
(rx/end! subs))
(.then (png-bytes->data-uri png-bytes)
(let [req-id
(js/requestAnimationFrame
(fn [_]
(try
(let [objects (dsh/lookup-page-objects @st/state file-id page-id)
frame (get objects frame-id)
{:keys [width height]} (:selrect frame)
max-size (mth/max width height)
scale (mth/max 1 (/ target-size max-size))
png-bytes (wasm.api/render-shape-pixels frame-id scale)]
(if (or (nil? png-bytes) (zero? (.-length png-bytes)))
(do
(l/error :hint "render-shape-pixels returned empty" :frame-id (str frame-id))
(rx/end! subs))
(.then
(png-bytes->data-uri png-bytes)
(fn [data-uri]
(rx/push! subs data-uri)
(rx/end! subs))
(fn [err]
(rx/error! subs err)))))
(catch :default err
(rx/error! subs err)))))
nil)))
(catch :default err
(rx/error! subs err)))))]
#(js/cancelAnimationFrame req-id)))))
(defn render-thumbnail
"Renders a component thumbnail via WASM and updates the UI immediately.
Does NOT persist to the server — persistence is handled separately
by `persist-thumbnail` on a debounced schedule."
[file-id page-id frame-id]
(let [object-id (thc/fmt-object-id file-id page-id frame-id "component")]
(ptk/reify ::render-thumbnail
cljs.core/IDeref
(-deref [_] object-id)
ptk/WatchEvent
(watch [_ _ stream]
(let [tp (ct/tpoint-ms)]
(->> (render-component-pixels frame-id)
(rx/map
(fn [data-uri]
(l/dbg :hint "component thumbnail rendered (wasm)"
:elapsed (dm/str (tp) "ms"))
(dwt/assoc-thumbnail object-id data-uri)))
(watch [_ state stream]
;; When the component is removed it can arrived a render
;; request with frame-id=null
(when (some? frame-id)
(letfn [(load-objects-stream
[]
(rx/create
(fn [subs]
(let [objects (dsh/lookup-page-objects state file-id page-id)
(rx/catch (fn [err]
(js/console.error "[thumbnails] error rendering component thumbnail" err)
(rx/empty)))
;; retrieves a subtree with only the id and its children
;; to be loaded before rendering the thumbnail
subtree
(into {}
(map #(vector (:id %) %))
(cfh/get-children-with-self objects frame-id))]
(try
(wasm.api/set-objects subtree #(rx/push! subs %))
(catch :default err
(rx/error! subs err)))))))
(rx/take-until
(->> stream
(rx/filter (ptk/type? ::dwt/clear-thumbnail))
(rx/filter #(= (deref %) object-id))))))))))
(do-render-thumbnail
[]
(let [tp (ct/tpoint-ms)]
(->> (render-component-pixels file-id page-id frame-id)
(rx/map
(fn [data-uri]
(l/dbg :hint "component thumbnail rendered (wasm)"
:elapsed (dm/str (tp) "ms"))
(dwt/assoc-thumbnail object-id data-uri)))
(rx/catch (fn [err]
(js/console.error err)
(l/error :hint "error rendering component thumbnail" :frame-id (str frame-id))
(rx/empty)))
(rx/take-until
(->> stream
(rx/filter (ptk/type? ::dwt/clear-thumbnail))
(rx/filter #(= (deref %) object-id)))))))]
(if (not= page-id (:current-page-id state))
(->> (load-objects-stream)
(rx/mapcat do-render-thumbnail))
(do-render-thumbnail))))))))
(defn persist-thumbnail
"Persists the current component thumbnail data-uri to the server.

6
frontend/src/app/main/data/workspace/wasm_text.cljs
View File

@ -23,6 +23,8 @@
[beicon.v2.core :as rx]
[potok.v2.core :as ptk]))
(def debounce-resize-text-time 40)
(defn get-wasm-text-new-size
"Computes the new {width, height} for a text shape from WASM text layout.
For :fixed grow-type, updates WASM content and returns current dimensions (no resize)."
@ -144,7 +146,7 @@
(rx/merge
(->> stream
(rx/filter (ptk/type? ::resize-wasm-text-debounce-inner))
(rx/debounce 40)
(rx/debounce debounce-resize-text-time)
(rx/take 1)
(rx/map (fn [evt]
(resize-wasm-text-debounce-commit
@ -194,4 +196,4 @@
ptk/WatchEvent
(watch [_ _ _]
(->> (rx/from ids)
(rx/map resize-wasm-text)))))
(rx/map resize-wasm-text-debounce)))))

48
frontend/src/app/main/errors.cljs
View File

@ -43,6 +43,12 @@
[_]
false)
;; Re-entrancy guard: prevents on-error from calling itself recursively.
;; If an error occurs while we are already handling an error (e.g. the
;; notification emit itself throws), we log it and bail out immediately
;; instead of recursing until the call-stack overflows.
(def ^:private handling-error? (volatile! false))
;; --- Stale-asset error detection and auto-reload
;;
;; When the browser loads JS modules from different builds (e.g. shared.js from
@ -90,12 +96,24 @@
(assoc ::trace (.-stack cause)))))
(defn on-error
"A general purpose error handler."
"A general purpose error handler.
Protected by a re-entrancy guard: if an error is raised while this
function is already on the call stack (e.g. the notification emit
itself fails), we print it to the console and return immediately
instead of recursing until the call-stack is exhausted."
[error]
(if (map? error)
(ptk/handle-error error)
(let [data (exception->error-data error)]
(ptk/handle-error data))))
(if @handling-error?
(.error js/console "[on-error] re-entrant call suppressed" error)
(do
(vreset! handling-error? true)
(try
(if (map? error)
(ptk/handle-error error)
(let [data (exception->error-data error)]
(ptk/handle-error data)))
(finally
(vreset! handling-error? false))))))
;; Inject dependency to remove circular dependency
(set! app.main.worker/on-error on-error)
@ -148,7 +166,14 @@
:report report}))))
(defn flash
"Show error notification banner and emit error report"
"Show error notification banner and emit error report.
The notification is scheduled asynchronously (via tm/schedule) to
avoid pushing a new event into the potok store while the store's own
error-handling pipeline is still on the call stack. Emitting
synchronously from inside an error handler creates a re-entrant
event-processing cycle that can exhaust the JS call stack
(RangeError: Maximum call stack size exceeded)."
[& {:keys [type hint cause] :or {type :handled}}]
(when (ex/exception? cause)
(when-let [event-name (case type
@ -160,11 +185,12 @@
:report report
:hint (ex/get-hint cause)))))
(st/emit!
(ntf/show {:content (or ^boolean hint (tr "errors.generic"))
:type :toast
:level :error
:timeout 5000})))
(ts/schedule
#(st/emit!
(ntf/show {:content (or ^boolean hint (tr "errors.generic"))
:type :toast
:level :error
:timeout 5000}))))
(defmethod ptk/handle-error :network
[error]

4
frontend/src/app/main/render.cljs
View File

@ -492,7 +492,9 @@
(try
(when (wasm.api/init-canvas-context os-canvas)
(wasm.api/initialize-viewport
objects scale bounds "#000000" 0
objects scale bounds
:background-opacity 0
:on-render
(fn []
(wasm.api/render-sync-shape object-id)
(ts/raf

4
frontend/src/app/main/repo.cljs
View File

@ -139,8 +139,7 @@
{:stream? true}
::sse/import-binfile
{:stream? true
:form-data? true}
{:stream? true}
::sse/permanently-delete-team-files
{:stream? true}
@ -273,6 +272,7 @@
(send-export (merge default params))))
(derive :upload-file-media-object ::multipart-upload)
(derive :upload-chunk ::multipart-upload)
(derive :update-profile-photo ::multipart-upload)
(derive :update-team-photo ::multipart-upload)

10
frontend/src/app/main/router.cljs
View File

@ -136,6 +136,16 @@
[state]
(dm/get-in state [:route :params :query]))
(defn get-query-param
"Safely extracts a scalar value for a query param key from a params
map. When the same key appears multiple times in a URL,
query-string->map returns a vector for that key; this function
always returns a single (last) element in that case, so downstream
consumers such as parse-long always receive a plain string or nil."
[params k]
(let [v (get params k)]
(if (sequential? v) (peek v) v)))
(defn nav-back
[]
(ptk/reify ::nav-back

2
frontend/src/app/main/ui.cljs
View File

@ -286,7 +286,7 @@
:viewer
(let [params (get params :query)
index (some-> (:index params) parse-long)
index (some-> (rt/get-query-param params :index) parse-long)
share-id (some-> (:share-id params) uuid/parse*)
section (or (some-> (:section params) keyword)
:interactions)

1
frontend/src/app/main/ui/auth/register.cljs
View File

@ -277,6 +277,7 @@
(mf/use-fn
(mf/deps on-success-callback)
(fn [params]
(cf/external-notify-register-success (:id params))
(if (fn? on-success-callback)
(on-success-callback (:email params))

2
frontend/src/app/main/ui/auth/verify_token.cljs
View File

@ -6,6 +6,7 @@
(ns app.main.ui.auth.verify-token
(:require
[app.config :as cf]
[app.main.data.auth :as da]
[app.main.data.common :as dcm]
[app.main.data.notifications :as ntf]
@ -25,6 +26,7 @@
(defmethod handle-token :verify-email
[data]
(cf/external-notify-register-success (:profile-id data))
(let [msg (tr "dashboard.notifications.email-verified-successfully")]
(ts/schedule 1000 #(st/emit! (ntf/success msg)))
(st/emit! (da/login-from-token data))))

3
frontend/src/app/main/ui/dashboard/file_menu.cljs
View File

@ -78,7 +78,8 @@
current-team (get teams current-team-id)
other-teams (remove #(= (:id %) current-team-id) (vals teams))
current-projects (remove #(= (:id %) (:project-id file))
file-project-ids (into #{} (map :project-id) files)
current-projects (remove #(contains? file-project-ids (:id %))
(:projects current-team))
on-new-tab

2
frontend/src/app/main/ui/ds/tooltip/tooltip.cljs
View File

@ -160,7 +160,7 @@
tooltip-ref (mf/use-ref nil)
container (hooks/use-portal-container)
container (hooks/use-portal-container :tooltip)
id
(d/nilv id internal-id)

38
frontend/src/app/main/ui/hooks.cljs
View File

@ -380,17 +380,35 @@
state))
(defn- get-or-create-portal-container
"Returns the singleton container div for the given category, creating
and appending it to document.body on first access."
[category]
(let [body (dom/get-body)
id (str "portal-container-" category)]
(or (dom/query body (str "#" id))
(let [container (dom/create-element "div")]
(dom/set-attribute! container "id" id)
(dom/append-child! body container)
container))))
(defn use-portal-container
"Creates a dedicated div container for React portals. The container
is appended to document.body on mount and removed on cleanup, preventing
removeChild race conditions when multiple portals target the same body."
[]
(let [container (mf/use-memo #(dom/create-element "div"))]
(mf/with-effect []
(let [body (dom/get-body)]
(dom/append-child! body container)
#(dom/remove-child! body container)))
container))
"Returns a shared singleton container div for React portals, identified
by a logical category. Available categories:
:modal — modal dialogs
:popup — popups, dropdowns, context menus
:tooltip — tooltips
:default — general portal use (default)
All portals in the same category share one <div> on document.body,
keeping the DOM clean and avoiding removeChild race conditions."
([]
(use-portal-container :default))
([category]
(let [category (name category)]
(mf/with-memo [category]
(get-or-create-portal-container category)))))
(defn use-dynamic-grid-item-width
([] (use-dynamic-grid-item-width nil))

2
frontend/src/app/main/ui/modal.cljs
View File

@ -84,7 +84,7 @@
(mf/defc modal-container*
{::mf/props :obj}
[]
(let [container (hooks/use-portal-container)]
(let [container (hooks/use-portal-container :modal)]
(when-let [modal (mf/deref ref:modal)]
(mf/portal
(mf/html [:> modal-wrapper* {:data modal :key (dm/str (:id modal))}])

2
frontend/src/app/main/ui/workspace.cljs
View File

@ -97,7 +97,7 @@
[:section {:class (stl/css :workspace-viewport)}
(when (dbg/enabled? :coordinates)
[:& coordinates/coordinates {:colorpalette? colorpalette?}])
[:> coordinates/coordinates* {:is-colorpalette colorpalette?}])
(when (dbg/enabled? :history-overlay)
[:div {:class (stl/css :history-debug-overlay)}

45
frontend/src/app/main/ui/workspace/colorpicker.cljs
View File

@ -33,12 +33,12 @@
[app.main.ui.ds.layout.tab-switcher :refer [tab-switcher*]]
[app.main.ui.hooks :as hooks]
[app.main.ui.icons :as deprecated-icon]
[app.main.ui.workspace.colorpicker.color-inputs :refer [color-inputs]]
[app.main.ui.workspace.colorpicker.color-inputs :refer [color-inputs*]]
[app.main.ui.workspace.colorpicker.color-tokens :refer [token-section*]]
[app.main.ui.workspace.colorpicker.gradients :refer [gradients*]]
[app.main.ui.workspace.colorpicker.harmony :refer [harmony-selector]]
[app.main.ui.workspace.colorpicker.hsva :refer [hsva-selector]]
[app.main.ui.workspace.colorpicker.libraries :refer [libraries]]
[app.main.ui.workspace.colorpicker.harmony :refer [harmony-selector*]]
[app.main.ui.workspace.colorpicker.hsva :refer [hsva-selector*]]
[app.main.ui.workspace.colorpicker.libraries :refer [libraries*]]
[app.main.ui.workspace.colorpicker.ramp :refer [ramp-selector*]]
[app.main.ui.workspace.colorpicker.shortcuts :as sc]
[app.util.dom :as dom]
@ -93,7 +93,7 @@
(dom/set-css-property! node "--saturation-grad-from" (format-hsl hsl-from))
(dom/set-css-property! node "--saturation-grad-to" (format-hsl hsl-to)))))
(mf/defc colorpicker
(mf/defc colorpicker*
[{:keys [data disable-gradient disable-opacity disable-image on-change on-accept origin combined-tokens color-origin on-token-change tab applied-token]}]
(let [state (mf/deref refs/colorpicker)
node-ref (mf/use-ref)
@ -511,27 +511,28 @@
:on-finish-drag on-finish-drag}]
"harmony"
[:& harmony-selector
[:> harmony-selector*
{:color current-color
:disable-opacity disable-opacity
:on-change handle-change-color
:on-start-drag on-start-drag}]
:on-start-drag on-start-drag
:on-finish-drag on-finish-drag}]
"hsva"
[:& hsva-selector
[:> hsva-selector*
{:color current-color
:disable-opacity disable-opacity
:on-change handle-change-color
:on-start-drag on-start-drag
:on-finish-drag on-finish-drag}]))]]
[:& color-inputs
[:> color-inputs*
{:type type
:disable-opacity disable-opacity
:color current-color
:on-change handle-change-color}]
[:& libraries
[:> libraries*
{:state state
:current-color current-color
:disable-gradient disable-gradient
@ -786,15 +787,15 @@
:data-testid "colorpicker"
:style style}
[:& colorpicker {:data data
:combined-tokens grouped-tokens-by-set
:disable-gradient disable-gradient
:disable-opacity disable-opacity
:disable-image disable-image
:on-token-change on-token-change
:applied-token applied-token
:on-change on-change'
:origin origin
:tab tab
:color-origin color-origin
:on-accept on-accept}]]))
[:> colorpicker* {:data data
:combined-tokens grouped-tokens-by-set
:disable-gradient disable-gradient
:disable-opacity disable-opacity
:disable-image disable-image
:on-token-change on-token-change
:applied-token applied-token
:on-change on-change'
:origin origin
:tab tab
:color-origin color-origin
:on-accept on-accept}]]))

2
frontend/src/app/main/ui/workspace/colorpicker/color_inputs.cljs
View File

@ -28,7 +28,7 @@
[val]
(* (/ val 255) 100))
(mf/defc color-inputs [{:keys [type color disable-opacity on-change]}]
(mf/defc color-inputs* [{:keys [type color disable-opacity on-change]}]
(let [{red :r green :g blue :b
hue :h saturation :s value :v
hex :hex alpha :alpha} color

27
frontend/src/app/main/ui/workspace/colorpicker/harmony.cljs
View File

@ -11,7 +11,7 @@
[app.common.geom.point :as gpt]
[app.common.math :as mth]
[app.common.types.color :as cc]
[app.main.ui.workspace.colorpicker.slider-selector :refer [slider-selector]]
[app.main.ui.workspace.colorpicker.slider-selector :refer [slider-selector*]]
[app.util.dom :as dom]
[app.util.object :as obj]
[cuerdas.core :as str]
@ -58,7 +58,7 @@
y (+ (/ canvas-side 2) (* comp-y (/ canvas-side 2)))]
(gpt/point x y)))
(mf/defc harmony-selector [{:keys [color disable-opacity on-change on-start-drag on-finish-drag]}]
(mf/defc harmony-selector* [{:keys [color disable-opacity on-change on-start-drag on-finish-drag]}]
(let [canvas-ref (mf/use-ref nil)
canvas-side 192
{hue :h saturation :s value :v alpha :alpha} color
@ -134,24 +134,21 @@
:style {"--hue-from" (dm/str "hsl(" h1 ", " (* s1 100) "%, " (* l1 100) "%)")
"--hue-to" (dm/str "hsl(" h2 ", " (* s2 100) "%, " (* l2 100) "%)")}}
[:div {:class (stl/css :handlers-wrapper)}
[:& slider-selector {:type :value
:vertical? true
:reverse? false
:value value
:max-value 255
:vertical true
:on-change on-change-value
:on-start-drag on-start-drag
:on-finish-drag on-finish-drag}]
[:> slider-selector* {:type :value
:is-vertical true
:value value
:max-value 255
:on-change on-change-value
:on-start-drag on-start-drag
:on-finish-drag on-finish-drag}]
(when (not disable-opacity)
[[:& slider-selector {:type :opacity
:vertical? true
[:> slider-selector* {:type :opacity
:is-vertical true
:value alpha
:max-value 1
:vertical true
:on-change on-change-opacity
:on-start-drag on-start-drag
:on-finish-drag on-finish-drag}]])]
:on-finish-drag on-finish-drag}])]
[:div {:class (stl/css :hue-wheel-wrapper)}
[:canvas {:class (stl/css :hue-wheel)

13
frontend/src/app/main/ui/workspace/colorpicker/hsva.cljs
View File

@ -8,10 +8,10 @@
(:require-macros [app.main.style :as stl])
(:require
[app.common.types.color :as cc]
[app.main.ui.workspace.colorpicker.slider-selector :refer [slider-selector]]
[app.main.ui.workspace.colorpicker.slider-selector :refer [slider-selector*]]
[rumext.v2 :as mf]))
(mf/defc hsva-selector [{:keys [color disable-opacity on-change on-start-drag on-finish-drag]}]
(mf/defc hsva-selector* [{:keys [color disable-opacity on-change on-start-drag on-finish-drag]}]
(let [{hue :h saturation :s value :v alpha :alpha} color
handle-change-slider (fn [key]
(fn [new-value]
@ -26,7 +26,7 @@
[:div {:class (stl/css :hsva-selector)}
[:div {:class (stl/css :hsva-row)}
[:span {:class (stl/css :hsva-selector-label)} "H"]
[:& slider-selector
[:> slider-selector*
{:class (stl/css :hsva-bar)
:type :hue
:max-value 360
@ -36,7 +36,7 @@
:on-finish-drag on-finish-drag}]]
[:div {:class (stl/css :hsva-row)}
[:span {:class (stl/css :hsva-selector-label)} "S"]
[:& slider-selector
[:> slider-selector*
{:class (stl/css :hsva-bar)
:type :saturation
:max-value 1
@ -46,10 +46,9 @@
:on-finish-drag on-finish-drag}]]
[:div {:class (stl/css :hsva-row)}
[:span {:class (stl/css :hsva-selector-label)} "V"]
[:& slider-selector
[:> slider-selector*
{:class (stl/css :hsva-bar)
:type :value
:reverse? false
:max-value 255
:value value
:on-change (handle-change-slider :v)
@ -58,7 +57,7 @@
(when (not disable-opacity)
[:div {:class (stl/css :hsva-row)}
[:span {:class (stl/css :hsva-selector-label)} "A"]
[:& slider-selector
[:> slider-selector*
{:class (stl/css :hsva-bar)
:type :opacity
:max-value 1

2
frontend/src/app/main/ui/workspace/colorpicker/libraries.cljs
View File

@ -27,7 +27,7 @@
[potok.v2.core :as ptk]
[rumext.v2 :as mf]))
(mf/defc libraries
(mf/defc libraries*
[{:keys [state on-select-color on-add-library-color disable-gradient disable-opacity disable-image]}]
(let [selected* (h/use-shared-state mdc/colorpicker-selected-broadcast-key :recent)
selected (deref selected*)

30
frontend/src/app/main/ui/workspace/colorpicker/ramp.cljs
View File

@ -11,11 +11,11 @@
[app.common.math :as mth]
[app.common.types.color :as cc]
[app.main.ui.components.color-bullet :as cb]
[app.main.ui.workspace.colorpicker.slider-selector :refer [slider-selector]]
[app.main.ui.workspace.colorpicker.slider-selector :refer [slider-selector*]]
[app.util.dom :as dom]
[rumext.v2 :as mf]))
(mf/defc value-saturation-selector [{:keys [saturation value on-change on-start-drag on-finish-drag]}]
(mf/defc value-saturation-selector* [{:keys [saturation value on-change on-start-drag on-finish-drag]}]
(let [dragging?* (mf/use-state false)
dragging? (deref dragging?*)
calculate-pos
@ -127,7 +127,7 @@
(reset! internal-color* (enrich-color-map color))))
[:*
[:& value-saturation-selector
[:> value-saturation-selector*
{:hue h
:saturation s
:value v
@ -140,17 +140,17 @@
[:& cb/color-bullet {:color bullet-color
:area true}]
[:div {:class (stl/css :sliders-wrapper)}
[:& slider-selector {:type :hue
:max-value 360
:value h
:on-change on-change-hue
:on-start-drag on-start-drag
:on-finish-drag on-finish-drag}]
[:> slider-selector* {:type :hue
:max-value 360
:value h
:on-change on-change-hue
:on-start-drag on-start-drag
:on-finish-drag on-finish-drag}]
(when (not disable-opacity)
[:& slider-selector {:type :opacity
:max-value 1
:value alpha
:on-change on-change-opacity
:on-start-drag on-start-drag
:on-finish-drag on-finish-drag}])]]]))
[:> slider-selector* {:type :opacity
:max-value 1
:value alpha
:on-change on-change-opacity
:on-start-drag on-start-drag
:on-finish-drag on-finish-drag}])]]]))

17
frontend/src/app/main/ui/workspace/colorpicker/slider_selector.cljs
View File

@ -13,8 +13,8 @@
[app.util.object :as obj]
[rumext.v2 :as mf]))
(mf/defc slider-selector
[{:keys [value class min-value max-value vertical? reverse? on-change on-start-drag on-finish-drag type]}]
(mf/defc slider-selector*
[{:keys [value class min-value max-value is-vertical on-change on-start-drag on-finish-drag type]}]
(let [min-value (or min-value 0)
max-value (or max-value 1)
dragging? (mf/use-state false)
@ -42,17 +42,14 @@
(when on-change
(let [{:keys [left right top bottom]} (-> ev dom/get-target dom/get-bounding-rect)
{:keys [x y]} (-> ev dom/get-client-position)
unit-value (if vertical?
unit-value (if is-vertical
(mth/clamp (/ (- bottom y) (- bottom top)) 0 1)
(mth/clamp (/ (- x left) (- right left)) 0 1))
unit-value (if reverse?
(mth/abs (- unit-value 1.0))
unit-value)
value (+ min-value (* unit-value (- max-value min-value)))]
(on-change value))))]
[:div {:class (dm/str class (stl/css-case :vertical vertical?
[:div {:class (dm/str class (stl/css-case :vertical is-vertical
:slider-selector true
:hue (= type :hue)
:opacity (= type :opacity)
@ -65,14 +62,10 @@
:on-pointer-move #(when @dragging? (calculate-pos %))}
(let [value-percent (* (/ (- value min-value)
(- max-value min-value)) 100)
value-percent (if reverse?
(mth/abs (- value-percent 100))
value-percent)
value-percent-str (str value-percent "%")
style-common #js {:pointerEvents "none"}
style-horizontal (obj/merge! #js {:left value-percent-str} style-common)
style-vertical (obj/merge! #js {:bottom value-percent-str} style-common)]
[:div {:class (stl/css :handler)
:style (if vertical? style-vertical style-horizontal)}])]))
:style (if is-vertical style-vertical style-horizontal)}])]))

6
frontend/src/app/main/ui/workspace/coordinates.cljs
View File

@ -11,10 +11,10 @@
[app.main.ui.hooks :as hooks]
[rumext.v2 :as mf]))
(mf/defc coordinates
[{:keys [colorpalette?]}]
(mf/defc coordinates*
[{:keys [is-colorpalette]}]
(let [coords (hooks/use-rxsub ms/mouse-position)]
[:div {:class (stl/css-case :container-color-palette-open colorpalette?
[:div {:class (stl/css-case :container-color-palette-open is-colorpalette
:container true)}
[:span {:alt "x" :class (stl/css :coordinate)}
(str "X: " (:x coords "-"))]

8
frontend/src/app/main/ui/workspace/palette.cljs
View File

@ -23,7 +23,7 @@
[app.main.ui.icons :as deprecated-icon]
[app.main.ui.workspace.color-palette :refer [color-palette*]]
[app.main.ui.workspace.color-palette-ctx-menu :refer [color-palette-ctx-menu*]]
[app.main.ui.workspace.text-palette :refer [text-palette]]
[app.main.ui.workspace.text-palette :refer [text-palette*]]
[app.main.ui.workspace.text-palette-ctx-menu :refer [text-palette-ctx-menu]]
[app.util.dom :as dom]
[app.util.i18n :refer [tr]]
@ -207,9 +207,9 @@
:close-menu on-close-menu
:on-select-palette on-select-text-palette-menu
:selected selected-text}]
[:& text-palette {:size size
:selected selected-text
:width vport-width}]])
[:> text-palette* {:size size
:selected selected-text
:width vport-width}]])
(when color-palette?
[:*
[:> color-palette-ctx-menu* {:show show-menu?

2
frontend/src/app/main/ui/workspace/presence.cljs
View File

@ -29,7 +29,7 @@
:style {:background-color color}
:src (cfg/resolve-profile-photo-url profile)}]]))
(mf/defc active-sessions
(mf/defc active-sessions*
{::mf/memo true}
[]
(let [profiles (mf/deref refs/profiles)

4
frontend/src/app/main/ui/workspace/right_header.cljs
View File

@ -25,7 +25,7 @@
[app.main.ui.exports.assets :refer [progress-widget]]
[app.main.ui.formats :as fmt]
[app.main.ui.icons :as deprecated-icon]
[app.main.ui.workspace.presence :refer [active-sessions]]
[app.main.ui.workspace.presence :refer [active-sessions*]]
[app.util.dom :as dom]
[app.util.i18n :as i18n :refer [tr]]
[okulary.core :as l]
@ -196,7 +196,7 @@
[:div {:class (stl/css :workspace-header-right)}
[:div {:class (stl/css :users-section)}
[:& active-sessions]]
[:> active-sessions*]]
[:& progress-widget]

10
frontend/src/app/main/ui/workspace/sidebar/options/menus/text.cljs
View File

@ -16,6 +16,7 @@
[app.main.data.workspace.shortcuts :as sc]
[app.main.data.workspace.texts :as dwt]
[app.main.data.workspace.tokens.application :as dwta]
[app.main.data.workspace.texts-v3 :as dwt-v3]
[app.main.data.workspace.undo :as dwu]
[app.main.data.workspace.wasm-text :as dwwt]
[app.main.features :as features]
@ -333,9 +334,12 @@
(mf/use-fn
(mf/deps values)
(fn [ids attrs]
(st/emit! (dwt/save-font (-> (merge (txt/get-default-text-attrs) values attrs)
(select-keys txt/text-node-attrs)))
(dwt/update-all-attrs ids attrs))))
(let [updated-attrs (-> (merge (txt/get-default-text-attrs) values attrs)
(select-keys txt/text-node-attrs))]
(when (features/active-feature? @st/state "text-editor-wasm/v1")
(st/emit! (dwt-v3/v3-update-text-editor-styles (first ids) attrs)))
(st/emit! (dwt/save-font updated-attrs)
(dwt/update-all-attrs ids attrs)))))
on-change
(mf/use-fn

22
frontend/src/app/main/ui/workspace/sidebar/sitemap.cljs
View File

@ -30,6 +30,7 @@
[app.util.timers :as timers]
[cuerdas.core :as str]
[okulary.core :as l]
[promesa.core :as p]
[rumext.v2 :as mf]))
;; FIXME: can we unify this two refs in one?
@ -77,18 +78,21 @@
(mf/deps id current-page-id is-separator?)
(fn []
(when-not is-separator?
;; For the wasm renderer, apply a blur effect to the viewport canvas
;; when we navigate to a different page.
;; WASM page transitions:
;; - Capture the current page (A) once
;; - Show a blurred snapshot while the target page (B/C/...) renders
;; - If the user clicks again during the transition, keep showing the original (A) snapshot
(if (and (features/active-feature? @st/state "render-wasm/v1")
(not= id current-page-id))
(do
(wasm.api/capture-canvas-pixels)
(wasm.api/apply-canvas-blur)
;; NOTE: it seems we need two RAF so the blur is actually applied and visible
;; in the canvas :(
(timers/raf
(fn []
(timers/raf navigate-fn))))
(-> (wasm.api/apply-canvas-blur)
(p/finally
(fn []
;; NOTE: it seems we need two RAF so the blur is actually applied and visible
;; in the canvas :(
(timers/raf
(fn []
(timers/raf navigate-fn)))))))
(navigate-fn)))))
on-delete

35
frontend/src/app/main/ui/workspace/text_palette.cljs
View File

@ -22,8 +22,9 @@
[potok.v2.core :as ptk]
[rumext.v2 :as mf]))
(mf/defc typography-item
[{:keys [file-id selected-ids typography name-only? size current-file-id]}]
(mf/defc typography-item*
{::mf/private true}
[{:keys [file-id selected-ids typography size current-file-id]}]
(let [font-data (f/get-font-data (:font-id typography))
font-variant-id (:font-variant-id typography)
variant-data (->> font-data :variants (d/seek #(= (:id %) font-variant-id)))
@ -60,14 +61,12 @@
:font-weight (:font-weight typography)
:font-style (:font-style typography)}}
(:name typography)]
(when-not name-only?
[:*
[:div {:class (stl/css :typography-font)}
(:name font-data)]
[:div {:class (stl/css :typography-data)}
(str (:font-size typography) "px | " (:name variant-data))]])]))
[:div {:class (stl/css :typography-font)}
(:name font-data)]
[:div {:class (stl/css :typography-data)}
(str (:font-size typography) "px | " (or (:name variant-data) "--"))]]))
(mf/defc palette
(mf/defc palette*
[{:keys [selected selected-ids current-file-id file-typographies libraries size width]}]
(let [file-id
(case selected
@ -165,7 +164,7 @@
:max-width (str width "px")
:right (str (* offset-step offset) "px")}}
(for [[idx item] (map-indexed vector current-typographies)]
[:& typography-item
[:> typography-item*
{:key idx
:file-id file-id
:current-file-id current-file-id
@ -178,7 +177,7 @@
:disabled (= offset max-offset)
:on-click on-right-arrow-click} deprecated-icon/arrow])]))
(mf/defc text-palette
(mf/defc text-palette*
{::mf/wrap [mf/memo]}
[{:keys [size width selected] :as props}]
(let [selected-ids (mf/deref refs/selected-shapes)
@ -189,10 +188,10 @@
file-typographies (mf/deref refs/workspace-file-typography)
libraries (mf/deref refs/files)
current-file-id (mf/use-ctx ctx/current-file-id)]
[:& palette {:current-file-id current-file-id
:selected-ids selected-ids
:file-typographies file-typographies
:libraries libraries
:width width
:selected selected
:size size}]))
[:> palette* {:current-file-id current-file-id
:selected-ids selected-ids
:file-typographies file-typographies
:libraries libraries
:width width
:selected selected
:size size}]))

2
frontend/src/app/main/ui/workspace/tokens/management/context_menu.cljs
View File

@ -522,7 +522,7 @@
dropdown-direction-change* (mf/use-ref 0)
top (+ (get-in mdata [:position :y]) 5)
left (+ (get-in mdata [:position :x]) 5)
container (hooks/use-portal-container)]
container (hooks/use-portal-container :popup)]
(mf/use-effect
(mf/deps is-open?)

4
frontend/src/app/main/ui/workspace/tokens/management/node_context_menu.cljs
View File

@ -37,6 +37,8 @@
dropdown-direction-change* (mf/use-ref 0)
top (+ (get-in mdata [:position :y]) 5)
left (+ (get-in mdata [:position :x]) 5)
container (hooks/use-portal-container :popup)
rename-node (mf/use-fn
(mf/deps mdata on-rename-node)
(fn []
@ -44,6 +46,7 @@
type (get mdata :type)]
(when node
(on-rename-node node type)))))
duplicate-node (mf/use-fn
(mf/deps mdata on-duplicate-node)
(fn []
@ -52,7 +55,6 @@
(when node
(on-duplicate-node node type)))))
container (hooks/use-portal-container)
delete-node (mf/use-fn
(mf/deps mdata)
(fn []

2
frontend/src/app/main/ui/workspace/tokens/themes/theme_selector.cljs
View File

@ -114,7 +114,7 @@
:is-open? true
:rect rect))))))
container (hooks/use-portal-container)]
container (hooks/use-portal-container :popup)]
[:div {:on-click on-open-dropdown
:disabled (not can-edit?)

10
frontend/src/app/main/ui/workspace/viewport.cljs
View File

@ -578,7 +578,7 @@
:tool drawing-tool}])
(when show-grids?
[:& frame-grid/frame-grid
[:> frame-grid/frame-grid*
{:zoom zoom
:selected selected
:transform transform
@ -589,7 +589,7 @@
:zoom zoom}])
(when show-snap-points?
[:& snap-points/snap-points
[:> snap-points/snap-points*
{:layout layout
:transform transform
:drawing drawing-obj
@ -690,13 +690,13 @@
:disabled (or drawing-tool @space?)}])))
(when show-prototypes?
[:& interactions/interactions
[:> interactions/interactions*
{:selected selected
:page-id page-id
:zoom zoom
:objects objects-modified
:current-transform transform
:hover-disabled? hover-disabled?}])])
:is-hover-disabled hover-disabled?}])])
(when show-gradient-handlers?
[:> gradients/gradient-handlers*
@ -727,7 +727,7 @@
:view-only true}]))]
[:g.scrollbar-wrapper {:clipPath "url(#clip-handlers)"}
[:& scroll-bars/viewport-scrollbars
[:> scroll-bars/viewport-scrollbars*
{:objects base-objects
:zoom zoom
:vbox vbox

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