github/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2026-11-10 20:10:37 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/staging-2.19.x' into staging

Browse Source
This commit is contained in:
Andrey Antukh 2026-11-10 18:09:07 +01:00
commit e4fcc663c0
26 changed files with 2264 additions and 391 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.serena/memories/backend/auth-permissions-product-domains.md
View File

@ -25,12 +25,13 @@
- Team role flags are normalized as owner > admin > editor > viewer. Owner/admin imply edit; any membership row implies read.
- File/project role rows only count with a live team membership: the file/project permission queries require a matching `team_profile_rel` row, and leaving or removing a member deletes their team-scoped `file`/`project`/`team-project-profile-rel` rows (GHSA-v9r9-h77c-55m2).
- File/project/comment checks are implemented in the owning command namespaces, often via helpers imported from `files`, `teams`, or `projects`; do not bypass those helpers with direct DB lookups unless preserving their not-found semantics.
- Comment permission includes both logged-in state and the file/team comment policy. Shared viewer paths may pass `share-id`; preserve that path when changing comment queries.
- Comment permission includes both logged-in state and the file/team comment policy. Shared viewer paths may pass `share-id`; preserve that path when changing comment queries. RPCs that accept `share-id` enforce the link's page scope before mutating (`share-link-pages` + `check-page-scope`): a thread or page outside the link raises `:not-found`, and that check runs before the ownership checks. `get-profiles-for-file-comments` filters its query by the same pages. `mark-all-threads-as-read` does not take `share-id`.
## Teams, projects, and invitations
- Team/project commands mix DB changes, email, message bus notifications, media/storage cleanup, feature flags, quotas, and audit metadata. Keep mutations transactional when the existing command does so.
- Invitation flows validate muted/bounced emails before sending and use tokenized invitation state. Accepting an invitation is tied to the invited member identity, not just possession of a token.
- The whole invitation family is team-admin only: creating, updating and deleting invitations, minting the invitation token (`get-team-invitation-token`) and listing the pending ones (`get-team-invitations`, which carries the invited email and the offered role). The token of an invitation that grants the `owner` role is restricted to the team owner, because an admin cannot create nor promote an owner invitation (`cant-promote-to-owner`). This family is the exception to the rule above: it answers `:validation` / `:insufficient-permissions` instead of `:not-found`, so the five commands speak one language.
- Logical deletion is used for many product objects; prefer existing logical-deletion helpers over hard deletes unless the command already performs permanent cleanup.
- Bounced/spam-complaint emails can mute/block a profile for login/registration and email sending. Devenv Mailpit is the normal local path for registration/email-flow testing.

1
.serena/memories/backend/subtleties.md
View File

@ -84,6 +84,7 @@
- The `media-storage-bytes-per-team` quota check on `upload-file-media-object` is TEMPORARILY DISABLED (2026-10-19, kept commented in `app.rpc.commands.media` with its `sql:get-team-id-for-file` lookup still active for the audit props): the quote performs a full `SUM` over `storage_object` per upload and was too slow in production. The `upload-sessions-per-profile` quota is unaffected and stays active. Re-enable only with a cheaper approximation.
- Storage abstraction, backend configuration, logical buckets, object lifecycle, deduplication, access rules, and garbage collection: `mem:backend/storage`.
- SVG validation strips DOCTYPE and uses secure SAX parsing. Basic SVG info falls back to 100x100 dimensions when width/height/viewBox are missing.
- The SVG sanitizer (`app.media.svg`) is a **blocklist**, not an allowlist: it drops dangerous elements and attributes by name and escapes every text and attribute value when it writes the tree back, so a payload hidden in a value cannot become live markup again. The allowlist rework is [#12190](https://github.com/penpot/penpot/issues/12190) and lands in media-processor, not here. `sanitize-svg` also tracks the namespace bindings through the recursion and drops any element that is not in the SVG namespace, so a document whose root is not an `svg` element in the SVG namespace is rejected and a child that rebinds `xmlns` to XHTML (`iframe`/`srcdoc`/`meta`) is dropped with its subtree; it compares the scheme of an URL the way the browser does (dropping tab/CR/LF/spaces), so `java	script:` does not slip through the `javascript:` filter. The paths that store an uploaded SVG as its final object go through `app.media.svg/sanitize-svg-upload` (media upload, the URL download, both thumbnail writers and the organization logo); the three binfile imports go through `app.binfile.common/sanitize-imported-svg`, which calls `sanitize-svg` directly. The profile picture is not an SVG: `import-profile-picture` ignores an `image/svg+xml` download, because the avatar is always rendered as an image. The caller checks the size before calling it: the helper reads the whole file, and the size limit applies to the upload, not to the sanitized copy, which can be up to six times bigger.
- Raster metadata is shell-derived with ImageMagick `identify`, verifies detected MIME against the supplied MIME, and swaps dimensions for EXIF orientations 6/8.
- Remote image download requires 2xx status, `content-length`, a known MIME, and size under the configured maximum before writing the temp file; mismatched byte count is an internal error.
- Font processing shells out to FontForge and WOFF conversion tools and can derive TTF/OTF/WOFF variants from uploaded fonts.

1
.serena/memories/frontend/dashboard-viewer-subtleties.md
View File

@ -7,6 +7,7 @@
- Dashboard file/project mutations are often optimistic local updates with fire-and-forget RPC watchers. Bulk permanent delete/restore paths use SSE progress and progress notifications.
- The import wizard runs the package as a job of the backend: it reads the manifest of the file in the main thread (`app.main.data.imports`, no web worker) and follows the job, so its header paints the milestone of the job (the stage and its counter) instead of the messages the old SSE stream sent; every file of a container reports the same milestone, so `jp/current-milestone-text` writes it once and the rows never repeat it. Before the job exists, the header paints a client-side `:upload` milestone built from the chunked upload (`uploads/upload-blob-chunked` `:on-progress`, chunks done/total), which never comes from the backend; the chunks go one at a time and it writes them as a percentage of the file, not as a counter. Once created and still waiting for a worker, no row says anything: the header says the import waits for a slot while no job of it has started. The bar of the header measures the whole import, never a file: indeterminate while checking, waiting for a slot or rebuilding, because the client cannot know a global index and total of operations. The upload is the exception — the chunked upload knows its chunks, so the bar is determinate while the containers are sent, weighted by their size (`imp/upload-pct` over `:container-size`, the only percentage the client really knows). The export modal follows the same one-job-per-file model, but every file is queued up front (even the ones whose job is created only after the previous one is over) and its queue ends only with a milestone: `:start`/`:retry` do not end it there. Neither modal paints a generic "…ing file…" line on the rows any more: the rows of the import wizard carry only what is not progress — the name, the size, `Ready` once their container finished uploading, and the error text —, and the button that drops a file only shows while the wizard still offers its import step (the confirmation screen). Above the rows, the import wizard paints a stepper (Check/Upload/Import) plus one phase line: `imp/import-step` derives the step from the dialog status and the entries (upload holds while any file is pending, either `:import-ready` or carrying its own `:upload` milestone), so Check covers analyze, Upload covers the chunked client-side upload, and Import covers queue plus job. A file of a version 3 package shows what it occupies inside its container, computed while analyzing (`imp/file-sizes`): its own `files/<id>…` entries plus the storage objects its media and thumbnails reference, whose metadata is the only link to `objects/<id>…`. The container's own size stays in `:container-size` (what the dropped file weighs) and is what the upload bar weighs, never what a row shows. A file the manifest lists but the container holds no entry of has no size at all, and its row then shows no subtitle: what the package weighs never stands in for it. The subtitle is the size alone, with no extension. While analyzing with no failures nothing renders below the phase header — no rows, no spinner (`imp/awaiting-analysis?`); the header text is the only "Checking…" message. Rows appear once the analysis resolves (one per file inside the package), and a failed analysis takes the error-summary path instead. The ready step and its Continue wait for the end of the analysis (`imp/ready-to-import?`, fed with the completion of `imp/analyze`): a ready file is not enough, because the files still to arrive would never be imported. While rebuilding, the phase title counts the files and `imp/imported-count` counts them done with the job's own `:files` counter, so the number moves while a container rebuilds its files one by one. The `:error` of an import entry is user-facing text (the backend hint, or a translated label), never an i18n key: the wizard renders it as-is, it does not translate it again. The link-later step takes the file id from the `:id` of its resolution entry, never from the key of the resolution map: the map comes from the job result, so what a key holds depends on the result schema of the job-def that wrote it, while the wizard indexes its selection by the id of the entry. The legacy SSE import stays in the backend for other clients.
- File creation/duplication strips file `:data` before putting file summaries into dashboard state.
- The pending invitations are a team-admin only list (backend `:is-admin` already includes the owner). The dashboard hides the invitations entry from the header tabs and the team-options dropdown for non-admins, `invitations-section-content` keys the section on `:is-admin`, and `fetch-invitations` answers `insufficient-permissions` by emitting `invitations-fetched` with `[]`, so a demoted admin does not keep the cached emails and the header does not paint the invite button from a stale list. The organization `send-invitations` policy only gates inviting and resending, not the list.
## Viewer

233
backend/src/app/media/svg.clj
View File

@ -12,8 +12,10 @@
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.storage.tmp :as tmp]
[clojure.xml :as xml]
[cuerdas.core :as str])
[cuerdas.core :as str]
[datoteka.fs :as fs])
(:import
clojure.lang.XMLHandler
java.io.InputStream
@ -46,15 +48,85 @@
(xml/parse istream secure-parser-factory))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SVG SERIALIZATION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:private xml-declaration
"Declaration written at the top of every sanitized document."
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>")
(defn- escape-text
"Escape the characters that are special inside a XML text node."
[s]
(-> s
(str/replace "&" "&amp;")
(str/replace "<" "&lt;")
(str/replace ">" "&gt;")))
(defn- escape-attr
"Escape the characters that are special inside a XML attribute value.
The value is written between double quotes, so the quote itself is
escaped too.
Tabs and line breaks become spaces: that is what the XML parser does
with them on the next read, and it keeps the output stable."
[s]
(-> (str s)
(str/replace #"[\t\r\n]" " ")
(str/replace "&" "&amp;")
(str/replace "<" "&lt;")
(str/replace ">" "&gt;")
(str/replace "\"" "&quot;")
(str/replace "'" "&apos;")))
(defn- emit-element
"Serialize a parsed element, escaping every text and attribute value.
The tag and attribute names come from the parser, so they are valid
XML names; only their values can carry markup.
The attributes are sorted by name: the parser hands them over in the
reverse order of the document, so writing them as they come would
make the output change on every sanitization."
[{:keys [tag attrs content]}]
(let [attrs-str (apply str
(for [[k v] (sort-by (comp name key) attrs)]
(str " " (name k) "=\"" (escape-attr (str v)) "\"")))
content-str (apply str
(for [child content]
(if (map? child)
(emit-element child)
(escape-text child))))]
(if (seq content)
(str "<" (name tag) attrs-str ">" content-str "</" (name tag) ">")
(str "<" (name tag) attrs-str "/>"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SVG SANITIZATION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:private dangerous-attrs-pattern #"(?i)^on\w+$")
(def ^:private javascript-href-pattern #"(?i)^javascript:")
(def ^:private url-ignored-chars
"Characters that the URL parser discards before it interprets the
scheme of an URL."
#"[\u0000-\u0020\u007f]")
(defn- javascript-url?
"True when the value is a javascript: URL.
The comparison drops the characters the URL parser drops (tab, CR, LF
and spaces), so a scheme split with one of them (`java&#x09;script:`)
cannot slip through."
[v]
(let [v (str/replace (str v) url-ignored-chars "")]
(boolean (re-find javascript-href-pattern (str/trim v)))))
(def ^:private dangerous-tags
#{"script" "foreignObject" "set"
"animate" "animateTransform" "animateColor" "animateMotion"})
"animate" "animateTransform" "animateColor" "animateMotion"
"iframe" "meta" "embed" "link" "base"})
(defn- local-name
"Return the local name of a parsed tag or attribute keyword.
@ -70,24 +142,82 @@
(last (str/split n ":"))
n)))
(def ^:private svg-namespace "http://www.w3.org/2000/svg")
(defn- namespace-bindings
"Return the namespace bindings in scope for an element: `::default`
plus the keyword prefixes declared in `attrs`, merged over the
inherited ones. The default binding is stored under a namespaced
keyword because a prefix cannot contain `/`, so no prefixed binding
can produce the same key.
The XML parser does not process namespaces, so the declarations are
plain attributes (`:xmlns`, `:xmlns:svg`) and the prefix is part of
the tag name (`:svg:svg`)."
[attrs inherited]
(let [own (reduce-kv (fn [acc k v]
(let [n (name k)]
(cond
(= n "xmlns") (assoc acc ::default v)
(str/starts-with? n "xmlns:") (assoc acc (keyword (subs n 6)) v)
:else acc)))
{}
attrs)]
(merge inherited own)))
(defn- element-namespace
"Return the namespace URI of `tag` under `bindings`: the default
namespace when the tag has no prefix, the prefixed binding otherwise.
The prefix is part of the tag name (`:svg:svg`), so the binding key
is the prefix."
[tag bindings]
(let [n (name tag)
idx (str/last-index-of n ":")]
(if (nil? idx)
(::default bindings)
(get bindings (keyword (subs n 0 idx))))))
(defn- svg-root?
"True when the element is an `svg` element in the SVG namespace.
The namespace is resolved with the same model as the recursion
(`namespace-bindings` + `element-namespace`), so the check does not
introduce a second rule."
[{:keys [tag attrs]}]
(let [bindings (namespace-bindings attrs {})]
(and (= "svg" (local-name tag))
(= svg-namespace (element-namespace tag bindings)))))
(defn- sanitize-svg-element
"Recursively sanitize an SVG element by removing dangerous tags and attributes."
[{:keys [tag attrs content] :as element}]
(when (and (map? element) tag)
(when-not (contains? dangerous-tags (local-name tag))
(let [clean-attrs (->> attrs
(remove (fn [[k v]]
(or (re-matches dangerous-attrs-pattern (local-name k))
(and (= "href" (local-name k))
(string? v)
(re-find javascript-href-pattern (str/trim v))))))
(into {}))
"Recursively sanitize an SVG element by removing dangerous tags and
attributes.
The namespace bindings are tracked through the recursion: an element
that is not in the SVG namespace is dropped with its whole subtree,
because the filter only knows about SVG elements and a child that
rebinds the namespace to XHTML can carry live HTML."
[element bindings]
(let [{:keys [tag attrs content]} element
bindings (namespace-bindings attrs bindings)]
(when (and (map? element) tag
(not (contains? dangerous-tags (local-name tag)))
(= svg-namespace (element-namespace tag bindings)))
(let [clean-attrs (->> attrs
(remove (fn [[k v]]
(let [n (name k)]
(or (and (not (str/starts-with? n "xmlns"))
(re-matches dangerous-attrs-pattern (local-name k)))
(and (= "href" (local-name k))
(string? v)
(javascript-url? v))))))
(into {}))
clean-content (when content
(->> content
(filter #(or (string? %) (map? %)))
(map (fn [child]
(if (map? child)
(sanitize-svg-element child)
(sanitize-svg-element child bindings)
child)))
(filter some?)
vec))]
@ -97,22 +227,65 @@
(defn sanitize-svg
"Sanitize SVG content by removing dangerous elements and attributes.
Removes <script> tags, <foreignObject> elements, event handlers (on*),
and javascript: URLs from href attributes."
and javascript: URLs from href attributes.
The document must be an SVG document: any element that is not in the
SVG namespace is dropped with its subtree, so a root that is not an
`svg` element in the SVG namespace is rejected, because the filter
only knows about SVG elements and attributes.
The filtered tree is written back with an escaping serializer: a
payload hidden in an attribute value or in a text node would become
live markup again if the values were written verbatim."
[svg-text]
(try
(let [parsed (parse-svg svg-text)
sanitized (sanitize-svg-element parsed)]
(if sanitized
(with-out-str (xml/emit sanitized))
(ex/raise :type :validation
:code :invalid-svg-file
:hint "SVG sanitization produced no output")))
(catch Exception e
(l/warn :hint "SVG sanitization failed, rejecting upload" :cause e)
(let [parsed (try
(parse-svg svg-text)
(catch Exception e
(l/warn :hint "SVG parsing failed, rejecting upload" :cause e)
(ex/raise :type :validation
:code :invalid-svg-file
:hint "SVG parsing failed during sanitization"
:cause e)))
_ (when-not (svg-root? parsed)
(l/warn :hint "SVG sanitization rejected a document that is not an svg document")
(ex/raise :type :validation
:code :invalid-svg-file
:hint "the uploaded document is not an svg document"))
sanitized (sanitize-svg-element parsed {})]
(when-not sanitized
(l/warn :hint "SVG sanitization produced no output, rejecting upload")
(ex/raise :type :validation
:code :invalid-svg-file
:hint "SVG parsing failed during sanitization"
:cause e))))
:hint "SVG sanitization produced no output"))
(str xml-declaration (emit-element sanitized))))
(defn sanitize-svg-upload
"Return the upload untouched when its mtype is not `image/svg+xml`.
When it is, write a sanitized copy to a temporary file and return the
upload pointing to it, with the size of the sanitized content.
The caller must check the size of the upload before calling this: the
whole file is read into memory to sanitize it. The size limit applies
to the upload, not to the sanitized copy, which can be up to six times
bigger (a single quote becomes `&apos;`).
Every path that stores an uploaded SVG as its final object must go
through this function, or the stored file can carry live markup. Two
paths store raw bytes on purpose and do not: `upload-tempfile` (a
channel between processes, not publicly accessible) and
`upload-chunk` (the chunks of an upload; the assembled object goes
through this function). The profile picture is not an SVG either:
`import-profile-picture` ignores an `image/svg+xml` download."
[{:keys [mtype path] :as upload}]
(if (= "image/svg+xml" mtype)
(let [content (slurp (str path) :encoding "UTF-8")
clean (sanitize-svg content)
tmp-path (tmp/tempfile :prefix "penpot-svg-" :suffix ".svg" :min-age "1h")]
(spit (str tmp-path) clean :encoding "UTF-8")
(assoc upload :path tmp-path :size (fs/size tmp-path)))
upload))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SVG INFO EXTRACTION
@ -120,7 +293,11 @@
(defn get-basic-info-from-svg
[{:keys [tag attrs] :as data}]
(when (not= tag :svg)
;; The local name is enough here: this function only reads the
;; dimensions. Whether the document is a valid SVG is decided by
;; `sanitize-svg`, which rejects anything that is not an `svg` element
;; in the SVG namespace.
(when (not= "svg" (local-name tag))
(ex/raise :type :validation
:code :unable-to-parse-svg
:hint "uploaded svg has invalid content"))

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

@ -373,16 +373,23 @@
[cfg uri]
(try
(let [storage (sto/resolve cfg)
input (media/download-image cfg uri)
input (media/run cfg {:cmd :info :input input})
hash (sto/calculate-hash (:path input))
content (-> (sto/content (:path input) (:size input))
(sto/wrap-with-hash hash))
sobject (sto/put-object! storage {::sto/content content
::sto/deduplicate? true
:bucket "profile"
:content-type (:mtype input)})]
(:id sobject))
input (media/download-image cfg uri)]
(if (= "image/svg+xml" (:mtype input))
;; The avatar is always rendered as an image, so an SVG would only
;; add the risk of storing live markup: it is not allowed here.
(do
(l/wrn :hint "ignoring svg profile picture" :uri uri)
nil)
(let [input (media/run cfg {:cmd :info :input input})
hash (sto/calculate-hash (:path input))
content (-> (sto/content (:path input) (:size input))
(sto/wrap-with-hash hash))
sobject (sto/put-object! storage {::sto/content content
::sto/deduplicate? true
:bucket "profile"
:content-type (:mtype input)})]
(:id sobject))))
(catch Throwable cause
(l/wrn :hint "unable to import profile picture"
:uri uri

324
backend/src/app/rpc/commands/comments.clj
View File

@ -40,6 +40,23 @@
(def comment-max-length 750)
(defn- share-link-pages
"The set of pages granted by a share-link, or nil when the access to the
file is not restricted to a page scope."
[perms]
(when (= :share-link (:type perms))
(or (:pages perms) #{})))
(defn- check-page-scope
"Raises a :not-found error when `page-id` is outside the page scope granted
by a share-link."
[perms page-id]
(when-let [pages (share-link-pages perms)]
(when-not (contains? pages page-id)
(ex/raise :type :not-found
:code :object-not-found
:hint "not found"))))
(defn- format-comment
[{:keys [content]}]
(->> (d/interleave-all
@ -235,8 +252,8 @@
(db/run! cfg (fn [{:keys [::db/conn] :as cfg}]
(let [perms (files/check-comment-permissions! cfg profile-id file-id share-id)
threads (get-comment-threads conn profile-id file-id)]
(if (= :share-link (:type perms))
(filterv #(contains? (:pages perms) (:page-id %)) threads)
(if-let [pages (share-link-pages perms)]
(filterv #(contains? pages (:page-id %)) threads)
threads)))))
(defn- get-comment-threads-sql
@ -337,11 +354,8 @@
(let [perms (files/check-comment-permissions! cfg profile-id file-id share-id)
thread (some-> (db/exec-one! conn [sql:get-comment-thread profile-id file-id id])
(decode-row))]
(when (and thread (= :share-link (:type perms)))
(when-not (contains? (:pages perms) (:page-id thread))
(ex/raise :type :not-found
:code :object-not-found
:hint "not found")))
(when thread
(check-page-scope perms (:page-id thread)))
thread))))
;; --- COMMAND: Retrieve Comments
@ -361,11 +375,7 @@
(db/run! cfg (fn [{:keys [::db/conn] :as cfg}]
(let [{:keys [file-id page-id]} (get-comment-thread conn thread-id)
perms (files/check-comment-permissions! cfg profile-id file-id share-id)]
(when (and (= :share-link (:type perms))
(not (contains? (:pages perms) page-id)))
(ex/raise :type :not-found
:code :object-not-found
:hint "not found"))
(check-page-scope perms page-id)
(get-comments conn thread-id)))))
(def sql:get-comments
@ -390,32 +400,49 @@
;; All the profiles that had comment the file, plus the current
;; profile.
(defn- file-comment-users-sql
[where]
(str/ffmt
"WITH available_profiles AS (
SELECT DISTINCT c.owner_id AS id
FROM comment c
JOIN comment_thread ct
ON ct.id = c.thread_id
WHERE ct.file_id = ?::uuid
%1
),
profile_ids AS (
SELECT id FROM available_profiles
UNION
SELECT ?::uuid
)
SELECT p.id,
p.email,
p.fullname AS name,
p.fullname,
p.photo_id,
p.is_active
FROM profile p
JOIN profile_ids AS x
ON x.id = p.id;"
where))
(def ^:private sql:file-comment-users
"WITH available_profiles AS (
SELECT DISTINCT c.owner_id AS id
FROM comment c
JOIN comment_thread ct
ON ct.id = c.thread_id
WHERE ct.file_id = ?::uuid
),
profile_ids AS (
SELECT id FROM available_profiles
UNION
SELECT ?::uuid
)
SELECT p.id,
p.email,
p.fullname AS name,
p.fullname,
p.photo_id,
p.is_active
FROM profile p
JOIN profile_ids AS x
ON x.id = p.id;")
(file-comment-users-sql ""))
(def ^:private sql:file-comment-users-by-page
(file-comment-users-sql "AND ct.page_id = ANY(?::uuid[])"))
(defn get-file-comments-users
[conn file-id profile-id]
(db/exec! conn [sql:file-comment-users file-id profile-id]))
"Returns the profiles of the users that commented the file. When `pages` is
not nil, only the commenters of the threads on those pages are returned."
[conn file-id profile-id pages]
(if (some? pages)
(db/exec! conn [sql:file-comment-users-by-page
file-id
(db/create-array conn "uuid" pages)
profile-id])
(db/exec! conn [sql:file-comment-users file-id profile-id])))
(def ^:private
schema:get-profiles-for-file-comments
@ -425,14 +452,17 @@
(sv/defmethod ::get-profiles-for-file-comments
"Retrieves a list of profiles with limited set of properties of all
participants on comment threads of the file."
participants on comment threads of the file. When the request is done with
a share link, only the participants on the pages granted by the link are
returned."
{::doc/added "1.15"
::doc/changes ["1.15" "Imported from queries and renamed."]
::doc/changes ["1.15" "Imported from queries and renamed."
"2.19" "With a share link, only the participants on the pages granted by the link are returned."]
::sm/params schema:get-profiles-for-file-comments}
[cfg {:keys [::rpc/profile-id file-id share-id]}]
(db/run! cfg (fn [{:keys [::db/conn] :as cfg}]
(files/check-comment-permissions! cfg profile-id file-id share-id)
(get-file-comments-users conn file-id profile-id))))
(let [perms (files/check-comment-permissions! cfg profile-id file-id share-id)]
(get-file-comments-users conn file-id profile-id (share-link-pages perms))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MUTATION COMMANDS
@ -474,21 +504,22 @@
::rtry/when rtry/conflict-exception?
::sm/params schema:create-comment-thread}
[cfg {:keys [::rpc/profile-id file-id page-id share-id] :as params}]
(files/check-comment-permissions! cfg profile-id file-id share-id)
(let [perms (files/check-comment-permissions! cfg profile-id file-id share-id)]
(check-page-scope perms page-id)
(let [{:keys [team-id project-id] :as file} (get-file cfg file-id page-id)]
(-> cfg
(assoc ::quotes/profile-id profile-id)
(assoc ::quotes/team-id team-id)
(assoc ::quotes/project-id project-id)
(assoc ::quotes/file-id file-id)
(quotes/check! {::quotes/id ::quotes/comment-threads-per-file}
{::quotes/id ::quotes/comments-per-file}))
(let [{:keys [team-id project-id] :as file} (get-file cfg file-id page-id)]
(-> cfg
(assoc ::quotes/profile-id profile-id)
(assoc ::quotes/team-id team-id)
(assoc ::quotes/project-id project-id)
(assoc ::quotes/file-id file-id)
(quotes/check! {::quotes/id ::quotes/comment-threads-per-file}
{::quotes/id ::quotes/comments-per-file}))
(let [params (assoc params ::file file)
thread (db/tx-run! cfg create-comment-thread params)]
(let [params (assoc params ::file file)
thread (db/tx-run! cfg create-comment-thread params)]
(vary-meta thread assoc ::audit/props (assoc thread :team-id team-id)))))
(vary-meta thread assoc ::audit/props (assoc thread :team-id team-id))))))
(defn- create-comment-thread
[{:keys [::db/conn] :as cfg}
@ -559,8 +590,9 @@
::sm/params schema:update-comment-thread-status
::db/transaction true}
[{:keys [::db/conn] :as cfg} {:keys [::rpc/profile-id id share-id]}]
(let [{:keys [file-id]} (get-comment-thread conn id ::sql/for-update true)]
(files/check-comment-permissions! cfg profile-id file-id share-id)
(let [thread (get-comment-thread conn id ::sql/for-update true)
perms (files/check-comment-permissions! cfg profile-id (:file-id thread) share-id)]
(check-page-scope perms (:page-id thread))
(upsert-comment-thread-status! conn profile-id id)))
;; --- COMMAND: Update Comment Thread
@ -577,8 +609,9 @@
::sm/params schema:update-comment-thread
::db/transaction true}
[{:keys [::db/conn] :as cfg} {:keys [::rpc/profile-id id is-resolved share-id]}]
(let [{:keys [file-id]} (get-comment-thread conn id ::sql/for-update true)]
(files/check-comment-permissions! cfg profile-id file-id share-id)
(let [thread (get-comment-thread conn id ::sql/for-update true)
perms (files/check-comment-permissions! cfg profile-id (:file-id thread) share-id)]
(check-page-scope perms (:page-id thread))
(db/update! conn :comment-thread
{:is-resolved is-resolved}
{:id id})
@ -603,56 +636,58 @@
(let [{:keys [file-id page-id] :as thread}
(get-comment-thread conn thread-id ::sql/for-update true)
{:keys [team-id project-id] :as file}
(get-file cfg file-id page-id)]
perms (files/check-comment-permissions! cfg profile-id file-id share-id)]
(files/check-comment-permissions! cfg profile-id file-id share-id)
(check-page-scope perms page-id)
(quotes/check! cfg {::quotes/id ::quotes/comments-per-file
::quotes/profile-id profile-id
::quotes/team-id team-id
::quotes/project-id project-id
::quotes/file-id file-id})
(let [{:keys [team-id project-id] :as file}
(get-file cfg file-id page-id)]
(let [profile (profile/get-profile conn profile-id)
mentions (into #{} mentions)
params {:id (uuid/next)
:created-at request-at
:modified-at request-at
:thread-id thread-id
:owner-id profile-id
:content content
:mentions (db/encode-pgarray mentions conn "uuid")}
(quotes/check! cfg {::quotes/id ::quotes/comments-per-file
::quotes/profile-id profile-id
::quotes/team-id team-id
::quotes/project-id project-id
::quotes/file-id file-id})
comment (-> (db/insert! conn :comment params)
(decode-row)
(assoc :file-id file-id)
(add-owner profile))]
(let [profile (profile/get-profile conn profile-id)
mentions (into #{} mentions)
params {:id (uuid/next)
:created-at request-at
:modified-at request-at
:thread-id thread-id
:owner-id profile-id
:content content
:mentions (db/encode-pgarray mentions conn "uuid")}
;; Update thread modified-at attribute and assoc the current
;; profile to the participant set.
(let [mentions (into (:mentions thread) mentions)
participants (-> (:participants thread #{})
(conj profile-id))
params {:modified-at request-at
:participants (db/tjson participants)
:mentions (db/encode-pgarray mentions conn "uuid")}
comment (-> (db/insert! conn :comment params)
(decode-row)
(assoc :file-id file-id)
(add-owner profile))]
;; Update the page-name cached attribute on comment thread table.
params (cond-> params
(not= (:page-name file) (:page-name thread))
(assoc :page-name (:page-name file)))]
;; Update thread modified-at attribute and assoc the current
;; profile to the participant set.
(let [mentions (into (:mentions thread) mentions)
participants (-> (:participants thread #{})
(conj profile-id))
params {:modified-at request-at
:participants (db/tjson participants)
:mentions (db/encode-pgarray mentions conn "uuid")}
(db/update! conn :comment-thread params
{:id thread-id}
{::db/return-keys false}))
;; Update the page-name cached attribute on comment thread table.
params (cond-> params
(not= (:page-name file) (:page-name thread))
(assoc :page-name (:page-name file)))]
;; Update the current profile status in relation to the current thread
(upsert-comment-thread-status! conn profile-id thread-id)
(db/update! conn :comment-thread params
{:id thread-id}
{::db/return-keys false}))
(send-comment-emails! cfg profile comment thread file)
;; Update the current profile status in relation to the current thread
(upsert-comment-thread-status! conn profile-id thread-id)
(vary-meta comment assoc ::audit/props (assoc comment :team-id team-id)))))
(send-comment-emails! cfg profile comment thread file)
(vary-meta comment assoc ::audit/props (assoc comment :team-id team-id))))))
;; --- COMMAND: Update Comment
@ -675,9 +710,11 @@
(get-comment conn id ::sql/for-update true)
{:keys [file-id page-id] :as thread}
(get-comment-thread conn thread-id ::sql/for-update true)]
(get-comment-thread conn thread-id ::sql/for-update true)
(files/check-comment-permissions! cfg profile-id file-id share-id)
perms (files/check-comment-permissions! cfg profile-id file-id share-id)]
(check-page-scope perms page-id)
;; Don't allow edit comments to not owners
(when-not (= owner-id profile-id)
@ -715,8 +752,13 @@
::sm/params schema:delete-comment-thread
::db/transaction true}
[{:keys [::db/conn] :as cfg} {:keys [::rpc/profile-id id share-id]}]
(let [{:keys [owner-id file-id] :as thread} (get-comment-thread conn id ::sql/for-update true)]
(files/check-comment-permissions! cfg profile-id file-id share-id)
(let [{:keys [owner-id file-id page-id] :as thread}
(get-comment-thread conn id ::sql/for-update true)
perms (files/check-comment-permissions! cfg profile-id file-id share-id)]
(check-page-scope perms page-id)
(when-not (= owner-id profile-id)
(ex/raise :type :validation
:code :not-allowed))
@ -741,10 +783,12 @@
(let [{:keys [owner-id thread-id] :as comment}
(get-comment conn id ::sql/for-update true)
{:keys [file-id]}
(get-comment-thread conn thread-id)]
{:keys [file-id page-id]}
(get-comment-thread conn thread-id)
(files/check-comment-permissions! cfg profile-id file-id share-id)
perms (files/check-comment-permissions! cfg profile-id file-id share-id)]
(check-page-scope perms page-id)
(when-not (= owner-id profile-id)
(ex/raise :type :validation
:code :not-allowed))
@ -768,8 +812,9 @@
::sm/params schema:update-comment-thread-position
::db/transaction true}
[{:keys [::db/conn] :as cfg} {:keys [::rpc/profile-id ::rpc/request-at id position frame-id share-id]}]
(let [{:keys [file-id]} (get-comment-thread conn id ::sql/for-update true)]
(files/check-comment-permissions! cfg profile-id file-id share-id)
(let [thread (get-comment-thread conn id ::sql/for-update true)
perms (files/check-comment-permissions! cfg profile-id (:file-id thread) share-id)]
(check-page-scope perms (:page-id thread))
(db/update! conn :comment-thread
{:modified-at request-at
:position (db/pgpoint position)
@ -792,8 +837,9 @@
::sm/params schema:update-comment-thread-frame
::db/transaction true}
[{:keys [::db/conn] :as cfg} {:keys [::rpc/profile-id ::rpc/request-at id frame-id share-id]}]
(let [{:keys [file-id]} (get-comment-thread conn id ::sql/for-update true)]
(files/check-comment-permissions! cfg profile-id file-id share-id)
(let [thread (get-comment-thread conn id ::sql/for-update true)
perms (files/check-comment-permissions! cfg profile-id (:file-id thread) share-id)]
(check-page-scope perms (:page-id thread))
(db/update! conn :comment-thread
{:modified-at request-at
:frame-id frame-id}
@ -801,17 +847,69 @@
{::db/return-keys false})
nil))
;; --- COMMAND: Mark all comment threads as read
;; The dashboard sends the thread ids in batches of this same size
;; (frontend/src/app/main/data/comments.cljs), so the batch has to fit in
;; this limit.
(def ^:private max-mark-all-threads 500)
(def ^:private
schema:mark-all-threads-as-read
[:map {:title "mark-all-threads-as-read"}
[:threads [:vector ::sm/uuid]]])
[:threads [:vector {:max max-mark-all-threads} ::sm/uuid]]])
(def ^:private sql:comment-threads-files
"SELECT ct.id, ct.file_id
FROM comment_thread ct
WHERE ct.id = ANY(?::uuid[])")
(def ^:private sql:upsert-comment-thread-status-batch
"insert into comment_thread_status (thread_id, profile_id, modified_at)
select t.id, ?::uuid, ?::timestamptz
from unnest(?::uuid[]) as t(id)
on conflict (thread_id, profile_id)
do update set modified_at = excluded.modified_at;")
(defn- get-comment-threads-files
[conn thread-ids]
(db/exec! conn [sql:comment-threads-files
(db/create-array conn "uuid" thread-ids)]))
(defn- check-threads-access
"Raises a :not-found error when any of the threads does not exist or the
caller has no access to the file that owns it."
[cfg profile-id thread-ids]
(let [rows (get-comment-threads-files (::db/conn cfg) thread-ids)
found (into #{} (map :id) rows)]
(when-not (= (count thread-ids) (count found))
(ex/raise :type :not-found
:code :object-not-found
:hint "not found"))
(doseq [file-id (distinct (map :file-id rows))]
(files/check-comment-permissions! cfg profile-id file-id nil))))
(defn- upsert-comment-thread-status-batch
[conn profile-id thread-ids]
(db/exec! conn [sql:upsert-comment-thread-status-batch
profile-id
(ct/in-future "1s")
(db/create-array conn "uuid" thread-ids)]))
(sv/defmethod ::mark-all-threads-as-read
"Marks the given comment threads as read for the current profile. The
caller needs to have access to the file that owns every thread."
{::doc/added "1.15"
::doc/changes [["2.19" "The caller needs access to the file that owns every thread and the number of threads is limited to 500"]]
::sm/params schema:mark-all-threads-as-read}
[cfg {:keys [::rpc/profile-id threads] :as params}]
(db/tx-run!
cfg
(fn [{:keys [::db/conn]}]
(doseq [thread-id threads]
(upsert-comment-thread-status! conn profile-id thread-id)))))
[cfg {:keys [::rpc/profile-id threads]}]
(let [thread-ids (distinct threads)]
;; Nothing to check and nothing to write: an empty list must not open a
;; transaction nor run the queries with an empty array.
(when (seq thread-ids)
(db/tx-run!
cfg
(fn [{:keys [::db/conn] :as cfg}]
(check-threads-access cfg profile-id thread-ids)
(upsert-comment-thread-status-batch conn profile-id thread-ids)
nil)))))

6
backend/src/app/rpc/commands/files_thumbnails.clj
View File

@ -23,6 +23,7 @@
[app.features.fdata :as fdata]
[app.loggers.audit :as-alias audit]
[app.loggers.webhooks :as-alias webhooks]
[app.media.svg :as svg]
[app.media.validation :as media.v]
[app.rpc :as-alias rpc]
[app.rpc.climit :as-alias climit]
@ -247,8 +248,7 @@
(defn- persist-thumbnail!
[storage media created-at]
(let [path (:path media)
mtype (:mtype media)
(let [{:keys [path mtype]} (svg/sanitize-svg-upload media)
hash (sto/calculate-hash path)
data (-> (sto/content path)
(sto/wrap-with-hash hash))]
@ -415,7 +415,7 @@
(let [storage (::sto/storage cfg)
file (bfc/get-file cfg file-id :include-deleted? true :load-data? false)
props (db/tjson (or (:props params) {}))
{:keys [path mtype]} (:media params)
{:keys [path mtype]} (svg/sanitize-svg-upload (:media params))
hash (sto/calculate-hash path)
data (-> (sto/content path)
(sto/wrap-with-hash hash))

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

@ -137,15 +137,7 @@
(defn- process-main-image
[info]
(let [path (:path info)
mtype (:mtype info)
path (if (= mtype "image/svg+xml")
(let [content (slurp path)
sanitized (svg/sanitize-svg content)
temp-path (tmp/tempfile :prefix "penpot-svg-" :suffix ".svg" :min-age "5m")]
(spit (str temp-path) sanitized)
temp-path)
path)
(let [{:keys [path mtype]} (svg/sanitize-svg-upload info)
hash (sto/calculate-hash path)
data (-> (sto/content path)
(sto/wrap-with-hash hash))]

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

@ -85,6 +85,17 @@
(def check-read-permissions!
(perms/make-check-fn has-read-permissions?))
(defn check-invitation-permissions
"Returns the team permissions of `profile-id`, raising the error of the
invitation family when they are not the admin ones that every invitation
command requires. Accepts a connection, a pool or a cfg."
[conn profile-id team-id]
(let [perms (get-permissions conn profile-id team-id)]
(when-not (:is-admin perms)
(ex/raise :type :validation
:code :insufficient-permissions))
perms))
(defn decode-row
[{:keys [features subscription] :as row}]
(when row
@ -489,8 +500,9 @@
{::doc/added "1.17"
::sm/params schema:get-team-invitations}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id]}]
(check-invitation-permissions cfg profile-id team-id)
(dm/with-open [conn (db/open pool)]
(check-read-permissions! cfg profile-id team-id)
(get-team-invitations conn team-id)))

77
backend/src/app/rpc/commands/teams_invitations.clj
View File

@ -484,7 +484,7 @@
::doc/module :teams
::sm/params schema:create-team-invitations}
[cfg {:keys [::rpc/profile-id team-id role emails] :as params}]
(let [perms (teams/get-permissions cfg profile-id team-id)
(let [perms (teams/check-invitation-permissions cfg profile-id team-id)
profile (db/get-by-id cfg :profile profile-id)
team (db/get-by-id cfg :team team-id)
;; Strict lookup: a failed Nitrate call must not skip the
@ -503,10 +503,6 @@
(count emails)
(count (:invitations params)))]
(when-not (:is-admin perms)
(ex/raise :type :validation
:code :insufficient-permissions))
(when (and (contains? cf/flags :admin-console)
organization
(not (cto/allowed? :send-invitations
@ -633,26 +629,43 @@
::doc/module :teams
::sm/params schema:get-team-invitation-token}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id email] :as params}]
(teams/check-edition-permissions! cfg profile-id team-id)
(let [email (profile/clean-email email)
;; The token is a bearer credential that accepts the invitation with the
;; role of the invitation row, so it takes the same permissions as the
;; rest of the invitation commands.
(let [perms (teams/check-invitation-permissions cfg profile-id team-id)
email (profile/clean-email email)
invit (-> (db/get pool :team-invitation
{:team-id team-id
:email-to email})
(update :role keyword))
(update :role keyword))]
member (profile/get-profile-by-email pool (:email-to invit))
token (create-invitation-token cfg {:team-id (:team-id invit)
;; The inviter is the creator of
;; the invitation row, not the
;; profile requesting the token.
:profile-id (or (:created-by invit)
profile-id)
:valid-until (:valid-until invit)
:role (:role invit)
:member-id (:id member)
:member-email (or (:email member)
(profile/clean-email (:email-to invit)))})]
{:token token}))
;; An admin cannot create nor promote an owner invitation, so it
;; cannot mint its token either: only the team owner can.
(when (and (= :owner (:role invit))
(not (:is-owner perms)))
(ex/raise :type :validation
:code :cant-promote-to-owner
:hint "only the team owner can get an owner invitation token"))
(let [member (profile/get-profile-by-email pool (:email-to invit))
token (create-invitation-token cfg {:team-id (:team-id invit)
;; The inviter is the creator of
;; the invitation row, not the
;; profile requesting the token.
:profile-id (or (:created-by invit)
profile-id)
:valid-until (:valid-until invit)
:role (:role invit)
:member-id (:id member)
:member-email (or (:email member)
(profile/clean-email (:email-to invit)))})]
;; The event is named as an action and carries the granted role, so
;; the minting of the token is traceable in the audit log.
(rph/with-meta
{:token token}
{::audit/name "create-team-invitation-token"
::audit/props {:role (:role invit)
:invitation-id (:id invit)}}))))
;; --- Mutation: Update invitation role
@ -668,11 +681,7 @@
::sm/params schema:update-team-invitation-role
::db/transaction true}
[{:keys [::db/conn]} {:keys [::rpc/profile-id team-id email role] :as params}]
(let [perms (teams/get-permissions conn profile-id team-id)]
(when-not (:is-admin perms)
(ex/raise :type :validation
:code :insufficient-permissions))
(let [perms (teams/check-invitation-permissions conn profile-id team-id)]
;; Don't allow promote to owner to admin users.
(when (and (not (:is-owner perms)) (= role :owner))
@ -697,17 +706,13 @@
::sm/params schema:delete-team-invition
::db/transaction true}
[{:keys [::db/conn]} {:keys [::rpc/profile-id team-id email] :as params}]
(let [perms (teams/get-permissions conn profile-id team-id)]
(teams/check-invitation-permissions conn profile-id team-id)
(when-not (:is-admin perms)
(ex/raise :type :validation
:code :insufficient-permissions))
(let [invitation (db/delete! conn :team-invitation
{:team-id team-id
:email-to (profile/clean-email email)}
{::db/return-keys true})]
(rph/wrap nil {::audit/props {:invitation-id (:id invitation)}}))))
(let [invitation (db/delete! conn :team-invitation
{:team-id team-id
:email-to (profile/clean-email email)}
{::db/return-keys true})]
(rph/wrap nil {::audit/props {:invitation-id (:id invitation)}})))
;; --- Mutation: Request Team Invitation

9
backend/src/app/rpc/management/nitrate.clj
View File

@ -27,6 +27,7 @@
[app.http.session :as session]
[app.jobs :as jobs]
[app.loggers.audit :as audit]
[app.media.svg :as svg]
[app.media.validation :as media.v]
[app.nitrate :as nitrate]
[app.rpc :as rpc]
@ -210,16 +211,18 @@
::nitrate/sso false}
[{:keys [::sto/storage]} {:keys [content organization-id previous-id]}]
(media.v/check-media-type content cm/image-types)
(media.v/check-media-size content)
(media.v/check-upload-path content)
(when previous-id
(sto/touch-object! storage previous-id))
(let [hash (sto/calculate-hash (:path content))
data (-> (sto/content (:path content))
(let [{:keys [path mtype]} (svg/sanitize-svg-upload content)
hash (sto/calculate-hash path)
data (-> (sto/content path)
(sto/wrap-with-hash hash))
obj (sto/put-object! storage {::sto/content data
::sto/deduplicate? true
:bucket "organization"
:content-type (:mtype content)
:content-type mtype
:organization-id organization-id})]
{:id (:id obj)}))

15
backend/test/backend_tests/helpers.clj
View File

@ -777,6 +777,21 @@
(io/file tmp))
tmp))
(defmacro with-temp-file
"Evaluate `body` with `sym` bound to the path of a temporary file that
holds `content`. The file is created under /tmp/penpot, one of the two
places the upload validation accepts (/tmp/undertow is the other one),
and it is deleted when the body ends, also when it throws."
[[sym content] & body]
`(let [path# (fs/create-tempfile :dir "/tmp/penpot" :prefix "penpot-test-")]
(try
(spit (str path#) ~content :encoding "UTF-8")
(let [~sym path#]
~@body)
(finally
(when (fs/exists? path#)
(fs/delete path#))))))
(defn pause
[]
(let [^java.io.Console cnsl (System/console)]

394
backend/test/backend_tests/media_test.clj
View File

@ -11,6 +11,7 @@
[app.media.svg :as svg]
[backend-tests.helpers :as th]
[clojure.test :as t]
[cuerdas.core :as str]
[datoteka.fs :as fs]))
(t/use-fixtures :once th/state-init)
@ -60,45 +61,43 @@
(t/testing "sanitize-svg removes script tags"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\"><script>alert('xss')</script><rect width=\"50\" height=\"50\"/></svg>"
result (svg/sanitize-svg svg)]
(t/is (not (clojure.string/includes? result "<script>")))
(t/is (not (clojure.string/includes? result "alert")))
(t/is (clojure.string/includes? result "<rect")))))
(t/is (not (str/includes? result "<script>")))
(t/is (not (str/includes? result "alert")))
(t/is (str/includes? result "<rect")))))
(t/deftest sanitize-svg-event-handlers
(t/testing "sanitize-svg removes event handler attributes"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\" onload=\"alert('xss')\"><rect width=\"50\" height=\"50\" onmouseover=\"alert('xss')\"/></svg>"
result (svg/sanitize-svg svg)]
(t/is (not (clojure.string/includes? result "onload")))
(t/is (not (clojure.string/includes? result "onmouseover")))
(t/is (not (clojure.string/includes? result "alert")))
(t/is (clojure.string/includes? result "<rect")))))
(t/is (not (str/includes? result "onload")))
(t/is (not (str/includes? result "onmouseover")))
(t/is (not (str/includes? result "alert")))
(t/is (str/includes? result "<rect")))))
(t/deftest sanitize-svg-javascript-href
(t/testing "sanitize-svg removes javascript: URLs from href attributes"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www.w3.org/1999/xlink\" width=\"100\" height=\"100\"><a xlink:href=\"javascript:alert('xss')\"><rect width=\"50\" height=\"50\"/></a></svg>"
result (svg/sanitize-svg svg)]
(t/is (not (clojure.string/includes? result "javascript:")))
(t/is (not (clojure.string/includes? result "alert")))
(t/is (clojure.string/includes? result "<a")))))
(t/is (not (str/includes? result "javascript:")))
(t/is (not (str/includes? result "alert")))
(t/is (str/includes? result "<a")))))
(t/deftest sanitize-svg-foreign-object
(t/testing "sanitize-svg removes foreignObject elements"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\"><foreignObject width=\"100\" height=\"100\"><body xmlns=\"http://www.w3.org/1999/xhtml\"><script>alert('xss')</script></body></foreignObject><rect width=\"50\" height=\"50\"/></svg>"
result (svg/sanitize-svg svg)]
(t/is (not (clojure.string/includes? result "foreignObject")))
(t/is (not (clojure.string/includes? result "<script>")))
(t/is (clojure.string/includes? result "<rect")))))
(t/is (not (str/includes? result "foreignObject")))
(t/is (not (str/includes? result "<script>")))
(t/is (str/includes? result "<rect")))))
(t/deftest sanitize-svg-clean-content
(t/testing "sanitize-svg preserves clean SVG content"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\"><rect width=\"50\" height=\"50\" fill=\"red\"/><circle cx=\"75\" cy=\"75\" r=\"20\" fill=\"blue\"/></svg>"
result (svg/sanitize-svg svg)]
(t/is (clojure.string/includes? result "<rect"))
(t/is (clojure.string/includes? result "<circle"))
(t/is (or (clojure.string/includes? result "fill=\"red\"")
(clojure.string/includes? result "fill='red'")))
(t/is (or (clojure.string/includes? result "fill=\"blue\"")
(clojure.string/includes? result "fill='blue'"))))))
(t/is (str/includes? result "<rect"))
(t/is (str/includes? result "<circle"))
(t/is (str/includes? result "fill=\"red\""))
(t/is (str/includes? result "fill=\"blue\"")))))
(t/deftest sanitize-svg-invalid-svg-rejected
(t/testing "sanitize-svg rejects malformed SVG input"
@ -110,98 +109,381 @@
(t/testing "sanitize-svg preserves legitimate xlink:href attributes"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www.w3.org/1999/xlink\" width=\"100\" height=\"100\"><use xlink:href=\"#icon\"/></svg>"
result (svg/sanitize-svg svg)]
(t/is (clojure.string/includes? result "xlink:href"))
(t/is (clojure.string/includes? result "#icon")))))
(t/is (str/includes? result "xlink:href"))
(t/is (str/includes? result "#icon")))))
(t/deftest sanitize-svg-javascript-href-whitespace
(t/testing "sanitize-svg catches javascript: URLs with leading whitespace"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\"><a href=\" javascript:alert('xss')\"><rect width=\"50\" height=\"50\"/></a></svg>"
result (svg/sanitize-svg svg)]
(t/is (not (clojure.string/includes? result "javascript:")))
(t/is (not (clojure.string/includes? result "alert")))
(t/is (clojure.string/includes? result "<a")))))
(t/is (not (str/includes? result "javascript:")))
(t/is (not (str/includes? result "alert")))
(t/is (str/includes? result "<a")))))
(t/deftest sanitize-svg-nested-script
(t/testing "sanitize-svg removes script tags from nested elements"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\"><g><script>alert('xss')</script></g></svg>"
result (svg/sanitize-svg svg)]
(t/is (not (clojure.string/includes? result "<script")))
(t/is (not (clojure.string/includes? result "alert")))
(t/is (clojure.string/includes? result "<g")))))
(t/is (not (str/includes? result "<script")))
(t/is (not (str/includes? result "alert")))
(t/is (str/includes? result "<g")))))
(t/deftest sanitize-svg-smil-bypass
(t/testing "sanitize-svg removes SMIL animation elements that can set on* attrs"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\"><rect width=\"100\" height=\"100\" id=\"r\"/><set attributeName=\"onmouseover\" to=\"alert('xss')\" xlink:href=\"#r\" begin=\"0s\"/></svg>"
result (svg/sanitize-svg svg)]
(t/is (not (clojure.string/includes? result "<set")))
(t/is (not (clojure.string/includes? result "onmouseover")))
(t/is (clojure.string/includes? result "<rect")))))
(t/is (not (str/includes? result "<set")))
(t/is (not (str/includes? result "onmouseover")))
(t/is (str/includes? result "<rect")))))
(t/deftest sanitize-svg-namespace-prefixed-script
(t/testing "sanitize-svg removes script tags written with a namespace prefix bound to the SVG namespace"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:x=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\"><x:script>alert('xss')</x:script><rect width=\"50\" height=\"50\"/></svg>"
result (svg/sanitize-svg svg)]
(t/is (not (clojure.string/includes? result "<x:script")))
(t/is (not (clojure.string/includes? result "alert")))
(t/is (clojure.string/includes? result "<rect")))))
(t/is (not (str/includes? result "<x:script")))
(t/is (not (str/includes? result "alert")))
(t/is (str/includes? result "<rect")))))
(t/deftest sanitize-svg-arbitrary-prefixed-script
(t/testing "sanitize-svg removes script tags written with an arbitrary namespace prefix"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:p=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\"><p:script>alert('xss')</p:script><rect width=\"50\" height=\"50\"/></svg>"
result (svg/sanitize-svg svg)]
(t/is (not (clojure.string/includes? result "<p:script")))
(t/is (not (clojure.string/includes? result "alert")))
(t/is (clojure.string/includes? result "<rect")))))
(t/is (not (str/includes? result "<p:script")))
(t/is (not (str/includes? result "alert")))
(t/is (str/includes? result "<rect")))))
(t/deftest sanitize-svg-nested-prefixed-script
(t/testing "sanitize-svg removes namespace-prefixed script tags from nested elements"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:x=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\"><g><x:script>alert('xss')</x:script></g></svg>"
result (svg/sanitize-svg svg)]
(t/is (not (clojure.string/includes? result "<x:script")))
(t/is (not (clojure.string/includes? result "alert")))
(t/is (clojure.string/includes? result "<g")))))
(t/is (not (str/includes? result "<x:script")))
(t/is (not (str/includes? result "alert")))
(t/is (str/includes? result "<g")))))
(t/deftest sanitize-svg-prefixed-dangerous-tags
(t/testing "sanitize-svg removes dangerous animation elements written with a namespace prefix"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:x=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\"><x:foreignObject width=\"10\" height=\"10\"/><x:set attributeName=\"onmouseover\" to=\"alert('xss')\"/><x:animate attributeName=\"fill\" to=\"red\"/><x:animateTransform attributeName=\"transform\"/><rect width=\"50\" height=\"50\"/></svg>"
result (svg/sanitize-svg svg)]
(t/is (not (clojure.string/includes? result "foreignObject")))
(t/is (not (clojure.string/includes? result "<x:set")))
(t/is (not (clojure.string/includes? result "<x:animate")))
(t/is (not (clojure.string/includes? result "alert")))
(t/is (clojure.string/includes? result "<rect")))))
(t/is (not (str/includes? result "foreignObject")))
(t/is (not (str/includes? result "<x:set")))
(t/is (not (str/includes? result "<x:animate")))
(t/is (not (str/includes? result "alert")))
(t/is (str/includes? result "<rect")))))
(t/deftest sanitize-svg-prefixed-javascript-href
(t/testing "sanitize-svg removes javascript: URLs from href attributes written with a namespace prefix"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:x=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\"><a x:href=\"javascript:alert('xss')\"><rect width=\"50\" height=\"50\"/></a></svg>"
result (svg/sanitize-svg svg)]
(t/is (not (clojure.string/includes? result "javascript:")))
(t/is (not (clojure.string/includes? result "alert")))
(t/is (clojure.string/includes? result "<a")))))
(t/is (not (str/includes? result "javascript:")))
(t/is (not (str/includes? result "alert")))
(t/is (str/includes? result "<a")))))
(t/deftest sanitize-svg-prefixed-event-handlers
(t/testing "sanitize-svg removes event handler attributes written with a namespace prefix"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:x=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\" x:onload=\"alert('xss')\"><rect width=\"50\" height=\"50\" x:onclick=\"alert('xss')\"/></svg>"
result (svg/sanitize-svg svg)]
(t/is (not (clojure.string/includes? result "onload")))
(t/is (not (clojure.string/includes? result "onclick")))
(t/is (not (clojure.string/includes? result "alert")))
(t/is (clojure.string/includes? result "<rect")))))
(t/is (not (str/includes? result "onload")))
(t/is (not (str/includes? result "onclick")))
(t/is (not (str/includes? result "alert")))
(t/is (str/includes? result "<rect")))))
(t/deftest sanitize-svg-prefixed-xlink-namespace-href
(t/testing "sanitize-svg removes javascript: URLs from href written with a prefix bound to the xlink namespace"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:y=\"http://www.w3.org/1999/xlink\" width=\"100\" height=\"100\"><a y:href=\"javascript:alert('xss')\"><rect width=\"50\" height=\"50\"/></a></svg>"
result (svg/sanitize-svg svg)]
(t/is (not (clojure.string/includes? result "javascript:")))
(t/is (not (clojure.string/includes? result "alert")))
(t/is (clojure.string/includes? result "<a")))))
(t/is (not (str/includes? result "javascript:")))
(t/is (not (str/includes? result "alert")))
(t/is (str/includes? result "<a")))))
(t/deftest sanitize-svg-preserved-prefixed-attrs
(t/testing "sanitize-svg preserves legitimate attributes written with a namespace prefix"
(let [svg "<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:xml=\"http://www.w3.org/XML/1998/namespace\"><text xml:space=\"preserve\">hola</text></svg>"
result (svg/sanitize-svg svg)]
(t/is (clojure.string/includes? result "xml:space"))
(t/is (clojure.string/includes? result "hola")))))
(t/is (str/includes? result "xml:space"))
(t/is (str/includes? result "hola")))))
;; --- SVG sanitization: escaping on serialization
;;
;; The sanitizer filters dangerous elements and attributes by name, so the
;; escaping happens when the tree is written back. A payload hidden in an
;; attribute value or in a text node must not become live markup again.
(def ^:private clean-svg
"<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"10\" height=\"10\"><circle r=\"4\"/></svg>")
(def ^:private evil-attribute-svg
"<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\" id=\"x' onload='alert(1)\"><rect width=\"10\" height=\"10\"/></svg>")
(def ^:private evil-text-svg
"<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\"><text>&lt;/text&gt;&lt;script&gt;alert(1)&lt;/script&gt;&lt;text&gt;</text></svg>")
(def ^:private evil-cdata-svg
"<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\"><text><![CDATA[</text><script>alert(1)</script><text>]]></text></svg>")
(def ^:private evil-javascript-svg
"An SVG with a javascript: URL obfuscated with a tab inside the scheme."
"<svg xmlns=\"http://www.w3.org/2000/svg\"><a href=\"java&#x09;script:alert(1)\">x</a></svg>")
(def ^:private xhtml-document
"A document that is not an SVG at all, with HTML only elements."
"<html xmlns=\"http://www.w3.org/1999/xhtml\"><body><iframe srcdoc=\"&lt;script&gt;alert(1)&lt;/script&gt;\"/><object data=\"data:text/html,x\"/><meta http-equiv=\"refresh\" content=\"0;url=javascript:alert(1)\"/></body></html>")
(t/deftest sanitize-svg-escapes-attribute-values
(t/testing "an event handler smuggled in an attribute value is escaped"
(let [result (svg/sanitize-svg evil-attribute-svg)
parsed (svg/parse-svg result)]
(t/is (not (contains? (:attrs parsed) :onload)))
(t/is (= "x' onload='alert(1)"
(get (:attrs parsed) :id)))
(t/is (str/includes? result "&apos;")))))
(t/deftest sanitize-svg-escapes-text-content
(t/testing "entity encoded markup in a text node is escaped"
(let [result (svg/sanitize-svg evil-text-svg)]
(t/is (not (str/includes? result "<script")))
(t/is (str/includes? result "&lt;script&gt;")))))
(t/deftest sanitize-svg-escapes-cdata-content
(t/testing "markup hidden in a CDATA node is escaped"
(let [result (svg/sanitize-svg evil-cdata-svg)]
(t/is (not (str/includes? result "<script")))
(t/is (str/includes? result "&lt;script&gt;")))))
(t/deftest sanitize-svg-escapes-ampersands
(t/testing "ampersands in text and attribute values are escaped"
(let [result (svg/sanitize-svg "<svg xmlns=\"http://www.w3.org/2000/svg\" id=\"a&amp;b\"><text>a &amp; b</text></svg>")]
(t/is (str/includes? result "a &amp; b"))
(t/is (= "a&b"
(get-in (svg/parse-svg result) [:attrs :id]))))))
(t/deftest sanitize-svg-output-is-valid-xml
(t/testing "the sanitized output can be parsed back"
(doseq [payload [clean-svg
evil-attribute-svg
evil-text-svg
evil-cdata-svg]]
(t/is (some? (svg/parse-svg (svg/sanitize-svg payload)))))))
(t/deftest sanitize-svg-rejects-non-svg-documents
(t/testing "a document that is not an svg document is rejected"
(doseq [payload [xhtml-document
;; an svg element declared in the xhtml namespace
"<svg xmlns=\"http://www.w3.org/1999/xhtml\"><rect/></svg>"
;; an svg element without any namespace
"<svg><rect/></svg>"]]
(let [error (try (svg/sanitize-svg payload) nil
(catch clojure.lang.ExceptionInfo e e))]
(t/is (some? error))
(t/is (th/ex-of-type? error :validation))
(t/is (th/ex-of-code? error :invalid-svg-file))))))
(t/deftest sanitize-svg-rejects-non-svg-root-local-name
(t/testing "a root in the svg namespace whose local name is not svg is rejected"
(doseq [payload ["<rect xmlns=\"http://www.w3.org/2000/svg\" width=\"10\" height=\"10\"/>"
"<html xmlns=\"http://www.w3.org/2000/svg\"></html>"]]
(let [error (try (svg/sanitize-svg payload) nil
(catch clojure.lang.ExceptionInfo e e))]
(t/is (some? error))
(t/is (th/ex-of-code? error :invalid-svg-file))))))
(t/deftest sanitize-svg-reports-non-svg-root
(t/testing "a root without the svg namespace reports it, not a serializer failure"
(let [error (try (svg/sanitize-svg "<svg><rect/></svg>") nil
(catch clojure.lang.ExceptionInfo e e))]
(t/is (some? error))
(t/is (th/ex-of-code? error :invalid-svg-file))
(t/is (str/includes? (ex-message error) "not an svg document")))))
(t/deftest sanitize-svg-accepts-svg-roots
(t/testing "an svg root in the svg namespace is accepted"
(t/is (some? (svg/sanitize-svg "<svg xmlns=\"http://www.w3.org/2000/svg\"><rect/></svg>"))))
(t/testing "an svg root with a namespace prefix is accepted"
(t/is (some? (svg/sanitize-svg "<svg:svg xmlns:svg=\"http://www.w3.org/2000/svg\"><svg:rect/></svg:svg>")))))
(t/deftest sanitize-svg-upload-rejects-invalid-svg
(t/testing "the helper rejects an upload that does not hold a valid svg"
(doseq [content ["<svg xmlns=\"http://www.w3.org/2000/svg\"><rect>"
xhtml-document]]
(th/with-temp-file [path content]
(let [upload {:filename "evil.svg"
:path path
:mtype "image/svg+xml"
:size (fs/size path)}
error (try (svg/sanitize-svg-upload upload) nil
(catch clojure.lang.ExceptionInfo e e))]
(t/is (some? error))
(t/is (th/ex-of-code? error :invalid-svg-file)))))))
(t/deftest sanitize-svg-rejects-doctype
(t/testing "a document with a doctype and an internal subset is rejected"
(let [error (try (svg/sanitize-svg
"<!DOCTYPE svg [<!ENTITY x \"y\">]><svg xmlns=\"http://www.w3.org/2000/svg\"><text>&x;</text></svg>")
nil
(catch clojure.lang.ExceptionInfo e e))]
(t/is (some? error))
(t/is (th/ex-of-code? error :invalid-svg-file)))))
(t/deftest sanitize-svg-escapes-double-quote
(t/testing "a double quote in an attribute value is escaped"
(let [result (svg/sanitize-svg "<svg xmlns=\"http://www.w3.org/2000/svg\" id=\"a&quot;b\"/>")
parsed (svg/parse-svg result)]
(t/is (str/includes? result "&quot;"))
(t/is (= "a\"b" (get (:attrs parsed) :id))))))
(t/deftest sanitize-svg-filters-prefixed-root-children
(t/testing "dangerous elements and attributes are removed inside a prefixed root"
(let [result (svg/sanitize-svg "<svg:svg xmlns:svg=\"http://www.w3.org/2000/svg\"><svg:script>alert(1)</svg:script><svg:rect onload=\"alert(1)\"/></svg:svg>")
parsed (svg/parse-svg result)]
(t/is (not (str/includes? result "script")))
(t/is (not (str/includes? result "onload")))
(t/is (= 1 (count (:content parsed)))))))
(t/deftest sanitize-svg-rejects-wrong-namespace
(t/testing "a root that is not in the svg namespace is rejected"
(doseq [payload ["<svg xmlns:foo=\"http://www.w3.org/2000/svg\"><rect/></svg>"
"<svg xmlns=\"\"><rect/></svg>"
"<svg xmlns=\" http://www.w3.org/2000/svg \"><rect/></svg>"
"<svg xmlns=\"http://www.w3.org/2000/svg&#9;\"><rect/></svg>"]]
(let [error (try (svg/sanitize-svg payload) nil
(catch clojure.lang.ExceptionInfo e e))]
(t/is (some? error))
(t/is (th/ex-of-code? error :invalid-svg-file))))))
;; --- SVG sanitization: namespace in scope
;;
;; The XML parser does not process namespaces, so a child can rebind the
;; default namespace to XHTML and smuggle live HTML (iframe/srcdoc/meta).
;; The sanitizer drops any element that is not in the SVG namespace.
(def ^:private xhtml-child-svg
"An SVG whose root is in the SVG namespace but whose child rebinds the
default namespace to XHTML and embeds live HTML."
"<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"100\" height=\"100\"><g xmlns=\"http://www.w3.org/1999/xhtml\"><iframe srcdoc=\"&lt;script&gt;alert(1)&lt;/script&gt;\"/><meta http-equiv=\"refresh\" content=\"0;url=javascript:alert(1)\"/></g><rect width=\"10\" height=\"10\"/></svg>")
(t/deftest sanitize-svg-drops-non-svg-namespace-subtrees
(t/testing "a child that rebinds the default namespace to XHTML is dropped"
(let [result (svg/sanitize-svg xhtml-child-svg)]
(t/is (not (str/includes? result "iframe")))
(t/is (not (str/includes? result "meta")))
(t/is (not (str/includes? result "srcdoc")))
(t/is (not (str/includes? result "http-equiv")))
(t/is (str/includes? result "<rect")))))
(t/deftest sanitize-svg-drops-prefixed-non-svg-namespace-subtrees
(t/testing "a child whose prefix is bound to XHTML is dropped"
(let [result (svg/sanitize-svg
"<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:h=\"http://www.w3.org/1999/xhtml\"><h:iframe srcdoc=\"&lt;script&gt;alert(1)&lt;/script&gt;\"/></svg>")]
(t/is (not (str/includes? result "iframe")))
(t/is (not (str/includes? result "srcdoc"))))))
(t/deftest sanitize-svg-keeps-prefixed-svg-namespace-subtrees
(t/testing "a child whose prefix is bound to the SVG namespace is kept"
(let [result (svg/sanitize-svg
"<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:s=\"http://www.w3.org/2000/svg\"><s:rect width=\"10\" height=\"10\"/></svg>")]
(t/is (str/includes? result "<s:rect")))))
(def ^:private default-prefix-xhtml-svg
"An SVG whose root declares a prefix named `default` bound to XHTML."
"<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:default=\"http://www.w3.org/1999/xhtml\"><default:iframe srcdoc=\"&lt;script&gt;alert(1)&lt;/script&gt;\"/><default:meta http-equiv=\"refresh\" content=\"0;url=javascript:alert(1)\"/></svg>")
(t/deftest sanitize-svg-drops-default-prefix-xhtml-subtrees
(t/testing "a prefix named default bound to XHTML is not the default namespace"
(let [result (svg/sanitize-svg default-prefix-xhtml-svg)]
(t/is (not (str/includes? result "default:iframe")))
(t/is (not (str/includes? result "default:meta")))
(t/is (not (str/includes? result "srcdoc")))
(t/is (not (str/includes? result "http-equiv"))))))
(def ^:private xmlns-onload-svg
"An SVG that declares a prefix named like an event handler."
"<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:onload=\"http://www.w3.org/2000/svg\"><onload:rect width=\"10\" height=\"10\"/></svg>")
(t/deftest sanitize-svg-keeps-xmlns-declarations
(t/testing "a namespace declaration whose local name looks like an event handler is kept"
(let [result (svg/sanitize-svg xmlns-onload-svg)]
(t/is (str/includes? result "xmlns:onload"))
(t/is (str/includes? result "<onload:rect")))))
(t/deftest sanitize-svg-drops-html-only-tags
(t/testing "HTML-only elements written in the svg namespace are dropped"
(doseq [tag ["iframe" "meta" "embed" "link" "base"]]
(let [result (svg/sanitize-svg
(str "<svg xmlns=\"http://www.w3.org/2000/svg\"><" tag " src=\"https://evil\"/></svg>"))]
(t/is (not (str/includes? result (str "<" tag))))))))
(t/deftest sanitize-svg-javascript-href-control-char
(t/testing "a javascript: URL with a control char inside the scheme is removed"
(let [result (svg/sanitize-svg evil-javascript-svg)
parsed (svg/parse-svg result)]
(t/is (not (contains? (get-in parsed [:content 0 :attrs]) :href)))
(t/is (not (str/includes? result "script:alert")))))
(t/testing "a javascript: URL with a line break inside the scheme is removed"
(let [result (svg/sanitize-svg "<svg xmlns=\"http://www.w3.org/2000/svg\"><a href=\"java&#x0a;script:alert(1)\">x</a></svg>")]
(t/is (not (str/includes? result "script:alert"))))))
(t/deftest sanitize-svg-preserves-safe-href
(t/testing "a safe href is preserved"
(let [parsed (svg/parse-svg (svg/sanitize-svg "<svg xmlns=\"http://www.w3.org/2000/svg\"><a href=\"https://example.com/\">x</a></svg>"))]
(t/is (= "https://example.com/"
(get-in parsed [:content 0 :attrs :href]))))))
(t/deftest sanitize-svg-rejects-script-root
(t/testing "a document whose root is a script is rejected as not an svg document"
(let [error (try (svg/sanitize-svg "<script>alert(1)</script>") nil
(catch clojure.lang.ExceptionInfo e e))]
(t/is (th/ex-of-type? error :validation))
(t/is (th/ex-of-code? error :invalid-svg-file))
(t/is (str/includes? (ex-message error) "not an svg document")))))
(t/deftest sanitize-svg-is-idempotent
(t/testing "sanitizing an already sanitized document does not change it"
(doseq [payload [clean-svg
evil-attribute-svg
evil-text-svg
evil-cdata-svg
evil-javascript-svg]]
(let [once (svg/sanitize-svg payload)]
(t/is (= once (svg/sanitize-svg once)))))))
(t/deftest get-basic-info-from-svg-accepts-prefixed-root
(t/testing "an svg root with a namespace prefix provides its dimensions"
(let [info (svg/get-basic-info-from-svg
(svg/parse-svg "<svg:svg xmlns:svg=\"http://www.w3.org/2000/svg\" width=\"120\" height=\"80\"/>"))]
(t/is (= 120 (:width info)))
(t/is (= 80 (:height info))))))
(t/deftest get-basic-info-from-svg-rejects-non-svg
(t/testing "a document whose root is not an svg element is rejected"
(let [error (try (svg/get-basic-info-from-svg
(svg/parse-svg "<html xmlns=\"http://www.w3.org/1999/xhtml\"/>"))
nil
(catch clojure.lang.ExceptionInfo e e))]
(t/is (some? error))
(t/is (th/ex-of-code? error :unable-to-parse-svg)))))
(t/deftest sanitize-svg-upload-sanitizes-svg
(t/testing "an SVG upload is replaced by a sanitized copy"
(th/with-temp-file [path evil-attribute-svg]
(let [upload {:filename "evil.svg"
:path path
:mtype "image/svg+xml"
:size (fs/size path)}
result (svg/sanitize-svg-upload upload)
parsed (svg/parse-svg (slurp (str (:path result))))]
(t/is (not= path (:path result)))
(t/is (not (contains? (:attrs parsed) :onload)))
(t/is (= "x' onload='alert(1)"
(get (:attrs parsed) :id)))
(t/is (= (fs/size (:path result)) (:size result)))))))
(t/deftest sanitize-svg-upload-passes-non-svg
(t/testing "an upload that is not an SVG is returned untouched"
(let [path (th/tempfile "backend_tests/test_files/sample.jpg")
upload {:filename "sample.jpg"
:path path
:mtype "image/jpeg"
:size 312043}]
(t/is (= upload (svg/sanitize-svg-upload upload))))))
(t/deftest info-invalid-image
(t/testing "info on invalid image raises error"

32
backend/test/backend_tests/rpc_auth_test.clj
View File

@ -14,9 +14,13 @@
[app.http.session :as session]
[app.loggers.audit :as-alias audit]
[app.redis :as rds]
[app.rpc.commands.auth :as auth]
[app.rpc.commands.ldap :as ldap-cmd]
[app.storage :as sto]
[backend-tests.helpers :as th]
[clojure.test :as t]
[datoteka.io :as io]
[mockery.core :refer [with-mocks]]
[yetti.response :as yres])
(:import
java.lang.AutoCloseable))
@ -253,3 +257,31 @@
"session must not be bound to the typed-email profile")))))
;; --- Profile picture import
(def ^:private avatar-svg
"An SVG that smuggles a script element."
"<svg xmlns=\"http://www.w3.org/2000/svg\"><script>alert(1)</script></svg>")
(defn- mock-download
"Mock the http client so that any url answers with `body` and `mtype`."
[mtype body]
{:target 'app.http.client/req-with-redirects
:return {:status 200
:headers {"content-type" mtype
"content-length" (str (alength ^bytes body))}
:body (java.io.ByteArrayInputStream. ^bytes body)}})
(t/deftest import-profile-picture-rejects-svg
(t/testing "an svg profile picture is not imported"
(with-mocks [http-mock (mock-download "image/svg+xml"
(.getBytes ^String avatar-svg "UTF-8"))]
(let [result (auth/import-profile-picture th/*system* "https://example.com/avatar.svg")]
(t/is (nil? result)))))
(t/testing "a png profile picture is imported"
(let [body (io/read* (io/resource "backend_tests/test_files/sample.png"))]
(with-mocks [http-mock (mock-download "image/png" body)]
(let [result (auth/import-profile-picture th/*system* "https://example.com/avatar.png")]
(t/is (some? result))
(t/is (some? (sto/get-object (:app.storage/storage th/*system*) result))))))))

565
backend/test/backend_tests/rpc_comment_test.clj
View File

@ -323,6 +323,14 @@
:frame-id uuid/zero
:share-id share-id})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))
(t/testing "outsider with who-comment=team share-link cannot get-profiles-for-file-comments"
(let [out (th/command! {::th/type :get-profiles-for-file-comments
::rpc/profile-id (:id outsider)
:file-id (:id file)
:share-id share-id})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))))
(t/deftest share-link-who-comment-all-can-comment
@ -449,6 +457,292 @@
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))))
(t/deftest share-link-page-scope-enforced-for-comment-profiles
(let [owner (th/create-profile* 1 {:is-active true})
outsider (th/create-profile* 2 {:is-active true})
member (th/create-profile* 3 {:is-active true})
team (th/create-team* 1 {:profile-id (:id owner)})
_ (th/create-team-role* {:team-id (:id team)
:profile-id (:id member)
:role :editor})
project (th/create-project* 1 {:team-id (:id team)
:profile-id (:id owner)})
file (th/create-file* 1 {:profile-id (:id owner)
:project-id (:id project)})
page-a (get-in file [:data :pages 0])
page-b (uuid/random)
_ (th/command! {::th/type :update-file
::rpc/profile-id (:id owner)
:id (:id file)
:session-id (uuid/random)
:revn 0
:vern 0
:changes [{:type :add-page
:id page-b
:page {:id page-b
:name "Page B"
:options {}
:objects {}}}]})
thread-a (th/command! {::th/type :create-comment-thread
::rpc/profile-id (:id owner)
:file-id (:id file)
:page-id page-a
:position (gpt/point 0)
:content "comment on page A"
:frame-id uuid/zero})
thread-b (th/command! {::th/type :create-comment-thread
::rpc/profile-id (:id member)
:file-id (:id file)
:page-id page-b
:position (gpt/point 0)
:content "comment on page B"
:frame-id uuid/zero})
thread-a-id (get-in thread-a [:result :id])
thread-b-id (get-in thread-b [:result :id])
thread-b-comment-id (get-in thread-b [:result :comment-id])
share (th/command! {::th/type :create-share-link
::rpc/profile-id (:id owner)
:file-id (:id file)
:pages #{page-a}
:who-comment "all"
:who-inspect "all"})
share-id (get-in share [:result :id])
;; A link without pages grants access to nothing.
empty-share (th/command! {::th/type :create-share-link
::rpc/profile-id (:id owner)
:file-id (:id file)
:pages #{}
:who-comment "all"
:who-inspect "all"})
empty-share-id (get-in empty-share [:result :id])]
(t/testing "the comment threads are created"
(t/is (th/success? thread-a))
(t/is (th/success? thread-b)))
(t/testing "share-link holder only gets the profiles of the shared page commenters"
(let [out (th/command! {::th/type :get-profiles-for-file-comments
::rpc/profile-id (:id outsider)
:file-id (:id file)
:share-id share-id})
emails (set (map :email (:result out)))]
(t/is (th/success? out))
(t/is (contains? emails (:email owner)))
(t/is (contains? emails (:email outsider)))
(t/is (not (contains? emails (:email member))))))
(t/testing "share-link holder cannot update the status of a thread of an unshared page"
(let [out (th/command! {::th/type :update-comment-thread-status
::rpc/profile-id (:id outsider)
:id thread-b-id
:share-id share-id})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))
(t/testing "share-link holder cannot update a comment of an unshared page"
(let [out (th/command! {::th/type :update-comment
::rpc/profile-id (:id outsider)
:id thread-b-comment-id
:content "outsider edit on page B"
:share-id share-id})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))
(t/testing "share-link holder cannot delete a comment of an unshared page"
(let [out (th/command! {::th/type :delete-comment
::rpc/profile-id (:id outsider)
:id thread-b-comment-id
:share-id share-id})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))
(t/testing "share-link holder cannot delete a thread of an unshared page"
(let [out (th/command! {::th/type :delete-comment-thread
::rpc/profile-id (:id outsider)
:id thread-b-id
:share-id share-id})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))
(t/testing "share-link holder cannot create a thread on an unshared page"
(let [out (th/command! {::th/type :create-comment-thread
::rpc/profile-id (:id outsider)
:file-id (:id file)
:page-id page-b
:position (gpt/point 0)
:content "comment on page B"
:frame-id uuid/zero
:share-id share-id})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))
(t/testing "share-link holder cannot move a thread of an unshared page"
(let [out (th/command! {::th/type :update-comment-thread-position
::rpc/profile-id (:id outsider)
:id thread-b-id
:position (gpt/point 10 10)
:frame-id uuid/zero
:share-id share-id})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))
(t/testing "share-link holder cannot resize a thread of an unshared page"
(let [out (th/command! {::th/type :update-comment-thread-frame
::rpc/profile-id (:id outsider)
:id thread-b-id
:frame-id uuid/zero
:share-id share-id})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))
(t/testing "share-link holder can move a thread of the shared page"
(let [out (th/command! {::th/type :update-comment-thread-position
::rpc/profile-id (:id outsider)
:id thread-a-id
:position (gpt/point 10 10)
:frame-id uuid/zero
:share-id share-id})]
(t/is (th/success? out))))
(t/testing "share-link holder can resize a thread of the shared page"
(let [out (th/command! {::th/type :update-comment-thread-frame
::rpc/profile-id (:id outsider)
:id thread-a-id
:frame-id uuid/zero
:share-id share-id})]
(t/is (th/success? out))))
(t/testing "share-link holder cannot reply to a thread of an unshared page"
(let [out (th/command! {::th/type :create-comment
::rpc/profile-id (:id outsider)
:thread-id thread-b-id
:content "outsider reply on page B"
:share-id share-id})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))
(t/testing "share-link holder can reply to a thread of the shared page"
(let [out (th/command! {::th/type :create-comment
::rpc/profile-id (:id outsider)
:thread-id thread-a-id
:content "outsider reply on page A"
:share-id share-id})]
(t/is (th/success? out))))
(t/testing "share-link holder cannot resolve a thread of an unshared page"
(let [out (th/command! {::th/type :update-comment-thread
::rpc/profile-id (:id outsider)
:id thread-b-id
:is-resolved true
:share-id share-id})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))
(t/testing "share-link holder can resolve a thread of the shared page"
(let [out (th/command! {::th/type :update-comment-thread
::rpc/profile-id (:id outsider)
:id thread-a-id
:is-resolved true
:share-id share-id})]
(t/is (th/success? out))))
(t/testing "share-link holder can write on the shared page"
(let [thread (th/command! {::th/type :create-comment-thread
::rpc/profile-id (:id outsider)
:file-id (:id file)
:page-id page-a
:position (gpt/point 0)
:content "outsider comment on page A"
:frame-id uuid/zero
:share-id share-id})
thread-id (get-in thread [:result :id])
comment-id (get-in thread [:result :comment-id])]
(t/is (th/success? thread))
(t/testing "can mark a thread as read"
(let [out (th/command! {::th/type :update-comment-thread-status
::rpc/profile-id (:id outsider)
:id thread-id
:share-id share-id})]
(t/is (th/success? out))))
(t/testing "can edit its comment"
(let [out (th/command! {::th/type :update-comment
::rpc/profile-id (:id outsider)
:id comment-id
:content "outsider edit on page A"
:share-id share-id})]
(t/is (th/success? out))))
(t/testing "can delete its comment"
(let [out (th/command! {::th/type :delete-comment
::rpc/profile-id (:id outsider)
:id comment-id
:share-id share-id})]
(t/is (th/success? out))))
(t/testing "can delete its thread"
(let [out (th/command! {::th/type :delete-comment-thread
::rpc/profile-id (:id outsider)
:id thread-id
:share-id share-id})]
(t/is (th/success? out))))))
(t/testing "share-link without pages does not leak the commenter profiles"
(let [out (th/command! {::th/type :get-profiles-for-file-comments
::rpc/profile-id (:id outsider)
:file-id (:id file)
:share-id empty-share-id})
emails (set (map :email (:result out)))]
(t/is (th/success? out))
(t/is (= #{(:email outsider)} emails))))
(t/testing "share-link without pages cannot create a thread"
(let [out (th/command! {::th/type :create-comment-thread
::rpc/profile-id (:id outsider)
:file-id (:id file)
:page-id page-a
:position (gpt/point 0)
:content "outsider comment on page A"
:frame-id uuid/zero
:share-id empty-share-id})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))
(t/testing "share-link without pages lists no comment threads"
(let [out (th/command! {::th/type :get-comment-threads
::rpc/profile-id (:id outsider)
:file-id (:id file)
:share-id empty-share-id})]
(t/is (th/success? out))
(t/is (= [] (:result out)))))
(t/testing "share-link without pages cannot get a comment thread"
(let [out (th/command! {::th/type :get-comment-thread
::rpc/profile-id (:id outsider)
:file-id (:id file)
:id thread-a-id
:share-id empty-share-id})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))
(t/testing "share-link without pages cannot get the comments of a thread"
(let [out (th/command! {::th/type :get-comments
::rpc/profile-id (:id outsider)
:thread-id thread-a-id
:share-id empty-share-id})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))))
(t/deftest membership-can-still-comment
(let [owner (th/create-profile* 1 {:is-active true})
member (th/create-profile* 2 {:is-active true})
@ -461,7 +755,23 @@
:profile-id (:id owner)})
file (th/create-file* 1 {:profile-id (:id owner)
:project-id (:id project)})
page-id (get-in file [:data :pages 0])]
page-id (get-in file [:data :pages 0])
_ (th/command! {::th/type :create-comment-thread
::rpc/profile-id (:id owner)
:file-id (:id file)
:page-id page-id
:position (gpt/point 0)
:content "owner comment"
:frame-id uuid/zero})
thread (th/command! {::th/type :create-comment-thread
::rpc/profile-id (:id member)
:file-id (:id file)
:page-id page-id
:position (gpt/point 0)
:content "member comment"
:frame-id uuid/zero})]
(t/testing "team member can get-comment-threads without share-id"
(let [out (th/command! {::th/type :get-comment-threads
@ -470,14 +780,45 @@
(t/is (th/success? out))))
(t/testing "team member can create-comment-thread without share-id"
(let [out (th/command! {::th/type :create-comment-thread
(t/is (th/success? thread)))
(t/testing "team member can move a thread of the file"
(let [out (th/command! {::th/type :update-comment-thread-position
::rpc/profile-id (:id member)
:file-id (:id file)
:page-id page-id
:position (gpt/point 0)
:content "member comment"
:id (get-in thread [:result :id])
:position (gpt/point 10 10)
:frame-id uuid/zero})]
(t/is (th/success? out))))))
(t/is (th/success? out))))
(t/testing "team member can resize a thread of the file"
(let [out (th/command! {::th/type :update-comment-thread-frame
::rpc/profile-id (:id member)
:id (get-in thread [:result :id])
:frame-id uuid/zero})]
(t/is (th/success? out))))
(t/testing "team member can reply to a thread of the file"
(let [out (th/command! {::th/type :create-comment
::rpc/profile-id (:id member)
:thread-id (get-in thread [:result :id])
:content "member reply"})]
(t/is (th/success? out))))
(t/testing "team member can resolve a thread of the file"
(let [out (th/command! {::th/type :update-comment-thread
::rpc/profile-id (:id member)
:id (get-in thread [:result :id])
:is-resolved true})]
(t/is (th/success? out))))
(t/testing "team member gets the profiles of all the file commenters"
(let [out (th/command! {::th/type :get-profiles-for-file-comments
::rpc/profile-id (:id member)
:file-id (:id file)})
emails (set (map :email (:result out)))]
(t/is (th/success? out))
(t/is (contains? emails (:email member)))
(t/is (contains? emails (:email owner)))))))
(t/deftest comment-audit-events-carry-team-id
;; Comment events carry the file id, so the resolver could find the team; the
@ -507,3 +848,213 @@
(get-in (meta (:result thread)) [:app.loggers.audit/props :team-id])))
(t/is (= (:id team)
(get-in (meta (:result comment)) [:app.loggers.audit/props :team-id]))))))
(t/deftest mark-all-threads-as-read-requires-access-to-the-threads
(let [owner (th/create-profile* 1 {:is-active true})
stranger (th/create-profile* 2 {:is-active true})
team (th/create-team* 1 {:profile-id (:id owner)})
project (th/create-project* 1 {:team-id (:id team)
:profile-id (:id owner)})
file (th/create-file* 1 {:profile-id (:id owner)
:project-id (:id project)})
page-id (get-in file [:data :pages 0])
thread (th/command! {::th/type :create-comment-thread
::rpc/profile-id (:id owner)
:file-id (:id file)
:page-id page-id
:position (gpt/point 0)
:content "private thread"
:frame-id uuid/zero})
thread-id (get-in thread [:result :id])]
(t/testing "the sibling rpc already rejects a profile without access"
(let [out (th/command! {::th/type :update-comment-thread-status
::rpc/profile-id (:id stranger)
:id thread-id})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))
(t/testing "mark-all-threads-as-read rejects a profile without access"
(let [out (th/command! {::th/type :mark-all-threads-as-read
::rpc/profile-id (:id stranger)
:threads [thread-id]})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out)))))
(t/is (nil? (th/db-get :comment-thread-status
{:thread-id thread-id
:profile-id (:id stranger)}))))))
(t/deftest mark-all-threads-as-read-behaviour
(let [owner (th/create-profile* 1 {:is-active true})
member (th/create-profile* 2 {:is-active true})
viewer (th/create-profile* 3 {:is-active true})
outsider (th/create-profile* 4 {:is-active true})
team (th/create-team* 1 {:profile-id (:id owner)})
_ (th/create-team-role* {:team-id (:id team)
:profile-id (:id member)
:role :editor})
_ (th/create-team-role* {:team-id (:id team)
:profile-id (:id viewer)
:role :viewer})
project (th/create-project* 1 {:team-id (:id team)
:profile-id (:id owner)})
file (th/create-file* 1 {:profile-id (:id owner)
:project-id (:id project)})
page-id (get-in file [:data :pages 0])
thread (th/command! {::th/type :create-comment-thread
::rpc/profile-id (:id owner)
:file-id (:id file)
:page-id page-id
:position (gpt/point 0)
:content "hello"
:frame-id uuid/zero})
thread-id (get-in thread [:result :id])]
(t/testing "the thread is unread for a team member"
(let [out (th/command! {::th/type :get-unread-comment-threads
::rpc/profile-id (:id member)
:team-id (:id team)})]
(t/is (th/success? out))
(t/is (= 1 (count (:result out))))))
(t/testing "a team member can mark the threads as read"
(let [out (th/command! {::th/type :mark-all-threads-as-read
::rpc/profile-id (:id member)
:threads [thread-id]})]
(t/is (th/success? out)))
(let [out (th/command! {::th/type :get-unread-comment-threads
::rpc/profile-id (:id member)
:team-id (:id team)})]
(t/is (th/success? out))
(t/is (= 0 (count (:result out))))))
(t/testing "a viewer of the team can mark the threads as read"
(let [out (th/command! {::th/type :mark-all-threads-as-read
::rpc/profile-id (:id viewer)
:threads [thread-id]})]
(t/is (th/success? out))))
(t/testing "an unknown thread is rejected"
(let [out (th/command! {::th/type :mark-all-threads-as-read
::rpc/profile-id (:id member)
:threads [(uuid/random)]})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))
(t/testing "more threads than the allowed maximum are rejected"
(let [out (th/command! {::th/type :mark-all-threads-as-read
::rpc/profile-id (:id member)
:threads (vec (repeatedly 501 uuid/random))})]
(t/is (not (th/success? out)))
(t/is (= :validation (th/ex-type (:error out))))))
(t/testing "a list with an inaccessible thread writes nothing"
(let [other-team (th/create-team* 2 {:profile-id (:id owner)})
other-project (th/create-project* 2 {:team-id (:id other-team)
:profile-id (:id owner)})
other-file (th/create-file* 2 {:profile-id (:id owner)
:project-id (:id other-project)})
other-thread (th/command! {::th/type :create-comment-thread
::rpc/profile-id (:id owner)
:file-id (:id other-file)
:page-id (get-in other-file [:data :pages 0])
:position (gpt/point 0)
:content "other team"
:frame-id uuid/zero})
other-thread-id (get-in other-thread [:result :id])
accessible-thread (th/command! {::th/type :create-comment-thread
::rpc/profile-id (:id owner)
:file-id (:id file)
:page-id page-id
:position (gpt/point 0)
:content "accessible"
:frame-id uuid/zero})
accessible-thread-id (get-in accessible-thread [:result :id])
out (th/command! {::th/type :mark-all-threads-as-read
::rpc/profile-id (:id member)
:threads [accessible-thread-id other-thread-id]})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))
(t/is (nil? (th/db-get :comment-thread-status
{:thread-id accessible-thread-id
:profile-id (:id member)})))
(t/is (nil? (th/db-get :comment-thread-status
{:thread-id other-thread-id
:profile-id (:id member)})))))
(t/testing "a profile without any relation with the team is rejected"
(let [out (th/command! {::th/type :mark-all-threads-as-read
::rpc/profile-id (:id outsider)
:threads [thread-id]})]
(t/is (not (th/success? out)))
(t/is (= :not-found (th/ex-type (:error out))))))))
(t/deftest mark-all-threads-as-read-edge-cases
(let [owner (th/create-profile* 1 {:is-active true})
member (th/create-profile* 2 {:is-active true})
viewer (th/create-profile* 3 {:is-active true})
team (th/create-team* 1 {:profile-id (:id owner)})
_ (th/create-team-role* {:team-id (:id team)
:profile-id (:id member)
:role :editor})
_ (th/create-team-role* {:team-id (:id team)
:profile-id (:id viewer)
:role :viewer})
project (th/create-project* 1 {:team-id (:id team)
:profile-id (:id owner)})
file (th/create-file* 1 {:profile-id (:id owner)
:project-id (:id project)})
page-id (get-in file [:data :pages 0])
thread (th/command! {::th/type :create-comment-thread
::rpc/profile-id (:id owner)
:file-id (:id file)
:page-id page-id
:position (gpt/point 0)
:content "hello"
:frame-id uuid/zero})
thread-id (get-in thread [:result :id])]
(t/testing "repeated thread ids are accepted and written once"
(let [out (th/command! {::th/type :mark-all-threads-as-read
::rpc/profile-id (:id member)
:threads [thread-id thread-id]})]
(t/is (th/success? out))
(t/is (= 1 (count (th/db-query :comment-thread-status
{:thread-id thread-id
:profile-id (:id member)}))))))
(t/testing "an empty list of threads is accepted and writes nothing"
(let [out (th/command! {::th/type :mark-all-threads-as-read
::rpc/profile-id (:id viewer)
:threads []})]
(t/is (th/success? out))
(t/is (= 0 (count (th/db-query :comment-thread-status
{:thread-id thread-id
:profile-id (:id viewer)}))))))
(t/testing "marking a thread as read twice keeps a single status row"
(let [out (th/command! {::th/type :mark-all-threads-as-read
::rpc/profile-id (:id member)
:threads [thread-id]})]
(t/is (th/success? out)))
(t/is (= 1 (count (th/db-query :comment-thread-status
{:thread-id thread-id
:profile-id (:id member)}))))
(let [out (th/command! {::th/type :get-unread-comment-threads
::rpc/profile-id (:id member)
:team-id (:id team)})]
(t/is (th/success? out))
(t/is (= 0 (count (:result out))))))))

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

@ -13,6 +13,7 @@
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.media.svg :as svg]
[app.rpc :as-alias rpc]
[app.rpc.commands.auth :as cauth]
[app.setup.clock :as clock]
@ -28,6 +29,17 @@
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
(def ^:private evil-svg
"An SVG that smuggles an event handler inside an attribute value."
"<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"64\" height=\"64\" id=\"x' onload='alert(1)\"><rect width=\"10\" height=\"10\"/></svg>")
(defn- stored-svg-attrs
"Return the attributes of the SVG stored in the storage object `id`."
[storage id]
(let [sobject (sto/get-object storage id)
content (slurp (sto/get-object-data storage sobject))]
(:attrs (svg/parse-svg content))))
(t/deftest upsert-file-object-thumbnail
(let [storage (::sto/storage th/*system*)
profile (th/create-profile* 1)
@ -260,6 +272,63 @@
(t/is (some? (sto/get-object storage (:media-id row2)))))))
(t/deftest create-file-object-thumbnail-sanitizes-svg
(let [storage (::sto/storage th/*system*)
profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false})]
(th/with-temp-file [path evil-svg]
(let [data {::th/type :create-file-object-thumbnail
::rpc/profile-id (:id profile)
:file-id (:id file)
:object-id "test-key-svg"
:media {:filename "evil.svg"
:size (fs/size path)
:path path
:mtype "image/svg+xml"}}]
(let [out (th/multipart-command! data)]
(t/is (nil? (:error out))))
(let [[row] (th/db-query :file-tagged-object-thumbnail
{:file-id (:id file)}
{:order-by [[:created-at :asc]]})]
(t/is (some? row))
(let [attrs (stored-svg-attrs storage (:media-id row))]
(t/is (not (contains? attrs :onload)))
(t/is (= "x' onload='alert(1)" (get attrs :id)))))))))
(t/deftest create-file-thumbnail-sanitizes-svg
(let [storage (::sto/storage th/*system*)
profile (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id profile)
:project-id (:default-project-id profile)
:is-shared false
:revn 1})]
(th/with-temp-file [path evil-svg]
(let [data {::th/type :create-file-thumbnail
::rpc/profile-id (:id profile)
:file-id (:id file)
:revn 1
:media {:filename "evil.svg"
:size (fs/size path)
:path path
:mtype "image/svg+xml"}}]
(let [out (th/multipart-command! data)]
(t/is (nil? (:error out))))
(let [[row] (th/db-query :file-thumbnail
{:file-id (:id file)}
{:order-by [[:revn :asc]]})]
(t/is (some? row))
(let [attrs (stored-svg-attrs storage (:media-id row))]
(t/is (not (contains? attrs :onload)))
(t/is (= "x' onload='alert(1)" (get attrs :id)))))))))
(t/deftest create-file-thumbnail-requires-edit-permissions
(let [owner (th/create-profile* 1)
viewer (th/create-profile* 2)

43
backend/test/backend_tests/rpc_management_nitrate_test.clj
View File

@ -15,10 +15,12 @@
[app.email :as eml]
[app.http :as-alias http]
[app.jobs :as jobs]
[app.media.svg :as svg]
[app.msgbus :as mbus]
[app.nitrate :as nitrate]
[app.rpc :as-alias rpc]
[app.rpc.commands.profile :as profile]
[app.storage :as sto]
[app.util.ssrf :as ssrf]
[backend-tests.helpers :as th]
[clojure.set :as set]
@ -2311,3 +2313,44 @@
:size 123}}
out (th/management-command! params)]
(t/is (th/ex-of-code? (:error out) :params-validation)))))
(t/deftest upload-organization-logo-sanitizes-svg
;; The logo lands in a public bucket, so an SVG with live markup must
;; be sanitized before it is stored.
(with-mocks [nitrate-mock {:target 'app.nitrate/call :return nil}]
(let [profile (th/create-profile* 1 {:is-active true})
content "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"64\" height=\"64\" id=\"x' onload='alert(1)\"><rect width=\"10\" height=\"10\"/></svg>"]
(th/with-temp-file [path content]
(let [params {::th/type :upload-organization-logo
::rpc/profile-id (:id profile)
:organization-id (uuid/random)
:content {:filename "evil.svg"
:path path
:mtype "image/svg+xml"
:size (fs/size path)}}
out (th/multipart-management-command! params)]
(t/is (th/success? out))
(let [storage (:app.storage/storage th/*system*)
sobject (sto/get-object storage (get-in out [:result :id]))
stored (slurp (sto/get-object-data storage sobject))
parsed (svg/parse-svg stored)]
(t/is (not (contains? (:attrs parsed) :onload)))
(t/is (= "x' onload='alert(1)" (get (:attrs parsed) :id)))))))))
(t/deftest upload-organization-logo-rejects-oversized-file
;; The sanitizer reads the whole logo, so the logo must honor the media
;; size limit before it is read.
(with-mocks [nitrate-mock {:target 'app.nitrate/call :return nil}]
(let [profile (th/create-profile* 1 {:is-active true})]
(th/with-temp-file [path "<svg xmlns=\"http://www.w3.org/2000/svg\"><rect/></svg>"]
(with-redefs [app.config/config (assoc app.config/config :media-max-file-size 1)]
(let [params {::th/type :upload-organization-logo
::rpc/profile-id (:id profile)
:organization-id (uuid/random)
:content {:filename "big.svg"
:path path
:mtype "image/svg+xml"
:size (fs/size path)}}
out (th/multipart-management-command! params)]
(t/is (th/ex-of-type? (:error out) :restriction))
(t/is (th/ex-of-code? (:error out) :media-max-file-size-reached))))))))

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

@ -10,10 +10,12 @@
[app.db :as db]
[app.http.client :as http]
[app.media :as media]
[app.media.svg :as svg]
[app.rpc :as-alias rpc]
[app.storage :as sto]
[backend-tests.helpers :as th]
[clojure.test :as t]
[cuerdas.core :as str]
[datoteka.fs :as fs]
[datoteka.io :as io]
[mockery.core :refer [with-mocks]])
@ -23,6 +25,14 @@
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
(def ^:private evil-svg
"An SVG that smuggles an event handler inside an attribute value."
"<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"64\" height=\"64\" id=\"x' onload='alert(1)\"><rect width=\"10\" height=\"10\"/></svg>")
(def ^:private evil-text-svg
"An SVG that smuggles a script element inside a text node."
"<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"64\" height=\"64\"><text>&lt;/text&gt;&lt;script&gt;alert(1)&lt;/script&gt;</text></svg>")
(t/deftest media-object-from-url
(let [prof (th/create-profile* 1)
proj (th/create-project* 1 {:profile-id (:id prof)
@ -94,6 +104,123 @@
(t/is (= 3890 (:size mobj2)))))))
(t/deftest upload-file-media-object-sanitizes-svg
(let [prof (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof)
:is-shared false})]
(th/with-temp-file [path evil-svg]
(let [params {::th/type :upload-file-media-object
::rpc/profile-id (:id prof)
:file-id (:id file)
:is-local true
:name "evil.svg"
:content {:filename "evil.svg"
:path path
:mtype "image/svg+xml"
:size (fs/size path)}}
out (th/multipart-command! params)]
(t/is (nil? (:error out)))
(let [{:keys [media-id]} (:result out)
storage (:app.storage/storage th/*system*)
sobject (sto/get-object storage media-id)
content (slurp (sto/get-object-data storage sobject))
parsed (svg/parse-svg content)]
(t/is (not (contains? (:attrs parsed) :onload)))
(t/is (= "x' onload='alert(1)" (get (:attrs parsed) :id)))
(t/is (str/includes? content "&apos;")))))))
(t/deftest upload-file-media-object-sanitizes-svg-text
(let [prof (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof)
:is-shared false})]
(th/with-temp-file [path evil-text-svg]
(let [params {::th/type :upload-file-media-object
::rpc/profile-id (:id prof)
:file-id (:id file)
:is-local true
:name "evil.svg"
:content {:filename "evil.svg"
:path path
:mtype "image/svg+xml"
:size (fs/size path)}}
out (th/multipart-command! params)]
(t/is (nil? (:error out)))
(let [{:keys [media-id]} (:result out)
storage (:app.storage/storage th/*system*)
sobject (sto/get-object storage media-id)
content (slurp (sto/get-object-data storage sobject))
parsed (svg/parse-svg content)]
(t/is (not (str/includes? content "<script")))
(t/is (= "</text><script>alert(1)</script>"
(get-in parsed [:content 0 :content 0]))))))))
(t/deftest create-file-media-object-from-url-sanitizes-svg
(let [prof (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof)
:is-shared false})
body (.getBytes ^String evil-svg "UTF-8")]
(with-mocks [http-mock {:target 'app.http.client/req-with-redirects
:return {:status 200
:headers {"content-type" "image/svg+xml"
"content-length" (str (alength ^bytes body))}
:body (java.io.ByteArrayInputStream. ^bytes body)}}]
(let [params {::th/type :create-file-media-object-from-url
::rpc/profile-id (:id prof)
:file-id (:id file)
:is-local true
:url "https://example.com/evil.svg"}
out (th/command! params)]
(t/is (nil? (:error out)))
(let [{:keys [media-id]} (:result out)
storage (:app.storage/storage th/*system*)
sobject (sto/get-object storage media-id)
content (slurp (sto/get-object-data storage sobject))
parsed (svg/parse-svg content)]
(t/is (not (contains? (:attrs parsed) :onload)))
(t/is (not (str/includes? content "<script>")))
(t/is (= "x' onload='alert(1)" (get (:attrs parsed) :id)))
(t/is (str/includes? content "&apos;")))))))
(def ^:private xhtml-child-svg
"An SVG whose root is in the SVG namespace but whose child rebinds the
default namespace to XHTML and embeds live HTML."
"<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"64\" height=\"64\"><g xmlns=\"http://www.w3.org/1999/xhtml\"><iframe srcdoc=\"&lt;script&gt;alert(1)&lt;/script&gt;\"/><meta http-equiv=\"refresh\" content=\"0;url=javascript:alert(1)\"/></g><rect width=\"10\" height=\"10\"/></svg>")
(t/deftest create-file-media-object-from-url-sanitizes-xhtml-child
(let [prof (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof)
:is-shared false})
body (.getBytes ^String xhtml-child-svg "UTF-8")]
(with-mocks [http-mock {:target 'app.http.client/req-with-redirects
:return {:status 200
:headers {"content-type" "image/svg+xml"
"content-length" (str (alength ^bytes body))}
:body (java.io.ByteArrayInputStream. ^bytes body)}}]
(let [params {::th/type :create-file-media-object-from-url
::rpc/profile-id (:id prof)
:file-id (:id file)
:is-local true
:url "https://example.com/evil.svg"}
out (th/command! params)]
(t/is (nil? (:error out)))
(let [{:keys [media-id]} (:result out)
storage (:app.storage/storage th/*system*)
sobject (sto/get-object storage media-id)
content (slurp (sto/get-object-data storage sobject))]
(t/is (not (str/includes? content "iframe")))
(t/is (not (str/includes? content "srcdoc")))
(t/is (not (str/includes? content "http-equiv"))))))))
(t/deftest media-object-from-url-command
(let [prof (th/create-profile* 1)
proj (th/create-project* 1 {:profile-id (:id prof)

243
backend/test/backend_tests/rpc_team_test.clj
View File

@ -15,7 +15,7 @@
[app.db :as db]
[app.email.blacklist :as email.blacklist]
[app.http :as http]
[app.loggers.audit :as-alias audit]
[app.loggers.audit :as audit]
[app.nitrate :as nitrate]
[app.rpc :as-alias rpc]
[app.rpc.commands.teams :as teams]
@ -25,11 +25,23 @@
[backend-tests.helpers :as th]
[clojure.test :as t]
[datoteka.fs :as fs]
[mockery.core :refer [with-mocks]]))
[mockery.core :refer [with-mocks]]
[yetti.request]))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
;; Minimal request stub, so the audit event can be built the way the backend
;; builds it: with the client ip in the event context.
(def ^:private http-request
(reify
yetti.request/IRequest
(get-header [_ header]
(case header
"x-forwarded-for" "127.0.0.44"
"x-real-ip" "127.0.0.43"
nil))))
(t/deftest create-team-invitations
(with-mocks [mock {:target 'app.email/send-template :return nil}]
(let [profile1 (th/create-profile* 1 {:is-active true})
@ -479,26 +491,229 @@
(t/is (= (:id profile2) (:member-id claims))))))))
(t/deftest get-team-invitation-token-requires-edition-permissions
(let [profile1 (th/create-profile* 1 {:is-active true})
profile2 (th/create-profile* 2 {:is-active true})
team (th/create-team* 1 {:profile-id (:id profile1)})
(t/deftest get-team-invitation-token-requires-admin-permissions
;; The token is a bearer credential: whoever holds it accepts the
;; invitation with the role of the invitation row. Minting it takes the
;; same permissions as the rest of the invitation commands, so an editor
;; (the lowest role above viewer) must not get it.
(let [owner (th/create-profile* 1 {:is-active true})
viewer (th/create-profile* 2 {:is-active true})
editor (th/create-profile* 3 {:is-active true})
admin (th/create-profile* 4 {:is-active true})
team (th/create-team* 1 {:profile-id (:id owner)})
pool (:app.db/pool th/*system*)]
(th/create-team-role* {:team-id (:id team)
:profile-id (:id profile2)
:profile-id (:id viewer)
:role :viewer})
(th/create-team-role* {:team-id (:id team)
:profile-id (:id editor)
:role :editor})
(th/create-team-role* {:team-id (:id team)
:profile-id (:id admin)
:role :admin})
(db/insert! pool :team-invitation
{:team-id (:id team)
:email-to "victim@example.com"
:role "editor"
:created-by (:id owner)
:valid-until (ct/in-future "48h")})
(let [data {::th/type :get-team-invitation-token
::rpc/profile-id (:id profile2)
:team-id (:id team)
:email "victim@example.com"}
out (th/command! data)]
(t/is (not (th/success? out)))
(t/is (= :not-found (-> out :error ex-data :type))))))
(let [request (fn [profile-id]
{::th/type :get-team-invitation-token
::rpc/profile-id (:id profile-id)
:team-id (:id team)
:email "victim@example.com"})]
(t/testing "a viewer cannot get the token"
(let [out (th/command! (request viewer))]
(t/is (not (th/success? out)))
(t/is (= :validation (-> out :error ex-data :type)))
(t/is (th/ex-of-code? (:error out) :insufficient-permissions))))
(t/testing "an editor cannot get the token"
(let [out (th/command! (request editor))]
(t/is (not (th/success? out)))
(t/is (= :validation (-> out :error ex-data :type)))
(t/is (th/ex-of-code? (:error out) :insufficient-permissions))))
(t/testing "an admin can get the token"
(let [out (th/command! (request admin))]
(t/is (th/success? out))
(let [claims (tokens/decode th/*system* (-> out :result :token))]
(t/is (= :team-invitation (:iss claims)))
(t/is (= :editor (:role claims)))
(t/is (= (:id team) (:team-id claims)))
(t/is (= "victim@example.com" (:member-email claims))))))
(t/testing "the team owner can get the token"
(let [out (th/command! (request owner))]
(t/is (th/success? out)))))))
(t/deftest get-team-invitation-token-owner-invitation-requires-team-owner
;; An admin cannot create nor promote an owner invitation, so it cannot
;; mint the token of one either: only the team owner can.
(let [owner (th/create-profile* 1 {:is-active true})
admin (th/create-profile* 2 {:is-active true})
team (th/create-team* 1 {:profile-id (:id owner)})
pool (:app.db/pool th/*system*)]
(th/create-team-role* {:team-id (:id team)
:profile-id (:id admin)
:role :admin})
(db/insert! pool :team-invitation
{:team-id (:id team)
:email-to "new-owner@example.com"
:role "owner"
:created-by (:id owner)
:valid-until (ct/in-future "48h")})
(let [request (fn [profile-id]
{::th/type :get-team-invitation-token
::rpc/profile-id (:id profile-id)
:team-id (:id team)
:email "new-owner@example.com"})]
(t/testing "an admin cannot get the token of an owner invitation"
(let [out (th/command! (request admin))]
(t/is (not (th/success? out)))
(t/is (th/ex-of-code? (:error out) :cant-promote-to-owner))))
(t/testing "the team owner can get the token of an owner invitation"
(let [out (th/command! (request owner))]
(t/is (th/success? out))
(let [claims (tokens/decode th/*system* (-> out :result :token))]
(t/is (= :owner (:role claims)))
(t/is (= "new-owner@example.com" (:member-email claims)))))))))
(t/deftest get-team-invitation-token-emits-audit-event
;; Minting the token is an action, not a read: the event is named as such
;; and carries the granted role, so the extraction of the token does not go
;; unnoticed in the audit log.
(let [owner (th/create-profile* 1 {:is-active true})
admin (th/create-profile* 2 {:is-active true})
team (th/create-team* 1 {:profile-id (:id owner)})
pool (:app.db/pool th/*system*)]
(th/create-team-role* {:team-id (:id team)
:profile-id (:id admin)
:role :admin})
(let [invitation (db/insert! pool :team-invitation
{:team-id (:id team)
:email-to "victim@example.com"
:role "editor"
:created-by (:id owner)
:valid-until (ct/in-future "48h")})]
(let [params {::rpc/profile-id (:id admin)
:team-id (:id team)
:email "victim@example.com"}
result (th/command-raw! (assoc params ::th/type :get-team-invitation-token))
[mdata _] (get-in th/*system* [:app.rpc/methods :get-team-invitation-token])
;; The cfg of a command carries its type, the same way
;; `resolve-methods` does it in production.
event (audit/prepare-rpc-event (assoc th/*system* ::rpc/module "main"
::rpc/type "command")
mdata
(with-meta params {:app.http/request http-request})
result)]
(t/is (= "create-team-invitation-token" (:name event)))
(t/is (= "command" (:type event)))
(t/is (= (:id admin) (:profile-id event)))
(t/is (= (:id team) (get-in event [:props :team-id])))
(t/is (= "victim@example.com" (get-in event [:props :email])))
(t/is (= :editor (get-in event [:props :role])))
(t/is (= (:id invitation) (get-in event [:props :invitation-id])))
(t/is (not (contains? (:props event) :token)))))))
(t/deftest get-team-invitations-requires-admin-permissions
;; The pending invitations carry the email of the invited person and the
;; role offered to them: the same data the rest of the invitation
;; commands already require admin for.
(let [owner (th/create-profile* 1 {:is-active true})
viewer (th/create-profile* 2 {:is-active true})
editor (th/create-profile* 3 {:is-active true})
admin (th/create-profile* 4 {:is-active true})
team (th/create-team* 1 {:profile-id (:id owner)})
pool (:app.db/pool th/*system*)]
(th/create-team-role* {:team-id (:id team)
:profile-id (:id viewer)
:role :viewer})
(th/create-team-role* {:team-id (:id team)
:profile-id (:id editor)
:role :editor})
(th/create-team-role* {:team-id (:id team)
:profile-id (:id admin)
:role :admin})
(db/insert! pool :team-invitation
{:team-id (:id team)
:email-to "victim@example.com"
:role "editor"
:created-by (:id owner)
:valid-until (ct/in-future "48h")})
(let [request (fn [profile-id]
{::th/type :get-team-invitations
::rpc/profile-id (:id profile-id)
:team-id (:id team)})]
(t/testing "a viewer cannot list the pending invitations"
(let [out (th/command! (request viewer))]
(t/is (not (th/success? out)))
(t/is (= :validation (-> out :error ex-data :type)))
(t/is (th/ex-of-code? (:error out) :insufficient-permissions))))
(t/testing "an editor cannot list the pending invitations"
(let [out (th/command! (request editor))]
(t/is (not (th/success? out)))
(t/is (= :validation (-> out :error ex-data :type)))
(t/is (th/ex-of-code? (:error out) :insufficient-permissions))))
(t/testing "an admin can list the pending invitations"
(let [out (th/command! (request admin))]
(t/is (th/success? out))
(t/is (= 1 (count (:result out))))
(t/is (= "victim@example.com" (:email (first (:result out)))))))
(t/testing "the team owner can list the pending invitations"
(let [out (th/command! (request owner))]
(t/is (th/success? out))
(t/is (= 1 (count (:result out)))))))))
(t/deftest invitation-permissions-deny-non-members
;; A profile that is not a member of the team has no permissions row at
;; all, so the check gets nil instead of a map of flags. That is also
;; the case of an organization owner that is not a member of the team:
;; the team permissions lookup is membership only, so they are left out
;; of the invitation commands too.
;;
;; NOTE: the audit wrapper is installed when the system boots, and only
;; when the audit log, webhooks or telemetry flags are on, none of them
;; is on in the test environment. So there is no way to observe here
;; whether a denied call emits an event: that is a property of the
;; wrapper, shared by every command.
(let [owner (th/create-profile* 1 {:is-active true})
outsider (th/create-profile* 2 {:is-active true})
team (th/create-team* 1 {:profile-id (:id owner)})
pool (:app.db/pool th/*system*)]
(db/insert! pool :team-invitation
{:team-id (:id team)
:email-to "victim@example.com"
:role "editor"
:created-by (:id owner)
:valid-until (ct/in-future "48h")})
(t/testing "a non member cannot get the token"
(let [out (th/command! {::th/type :get-team-invitation-token
::rpc/profile-id (:id outsider)
:team-id (:id team)
:email "victim@example.com"})]
(t/is (not (th/success? out)))
(t/is (= :validation (-> out :error ex-data :type)))
(t/is (th/ex-of-code? (:error out) :insufficient-permissions))))
(t/testing "a non member cannot list the pending invitations"
(let [out (th/command! {::th/type :get-team-invitations
::rpc/profile-id (:id outsider)
:team-id (:id team)})]
(t/is (not (th/success? out)))
(t/is (= :validation (-> out :error ex-data :type)))
(t/is (th/ex-of-code? (:error out) :insufficient-permissions))))))
(t/deftest accept-invitation-tokens

32
frontend/src/app/main/data/comments.cljs
View File

@ -462,6 +462,18 @@
(rx/map #(partial fetched-comments %))
(rx/catch #(rx/throw {:type :comment-error})))))))
;; Has to fit in the limit of the backend rpc
;; (backend/src/app/rpc/commands/comments.clj).
(def ^:private mark-all-threads-batch-size 500)
(defn mark-all-threads-batches
"Splits the thread ids into the batches that the backend accepts on a
single call."
[thread-ids]
(->> thread-ids
(partition-all mark-all-threads-batch-size)
(mapv vec)))
(defn mark-all-threads-as-read
"Mark all threads as read"
[team-id]
@ -470,11 +482,23 @@
(-data [_] {})
ptk/WatchEvent
(watch [_ state _]
(let [threads (-> state :comment-threads vals)]
(let [threads (-> state :comment-threads vals)
batches (mark-all-threads-batches (mapv :id threads))
refresh-event (retrieve-unread-comment-threads team-id)]
(rx/concat
(->> (rp/cmd! :mark-all-threads-as-read {:threads (mapv :id threads)})
(rx/map #(retrieve-unread-comment-threads team-id))
(rx/catch #(rx/throw {:type :comment-error})))
(->> (rx/from batches)
(rx/mapcat (fn [batch]
(rp/cmd! :mark-all-threads-as-read {:threads batch})))
(rx/reduce (fn [_ _] nil) nil)
(rx/map (fn [_] refresh-event))
;; Each batch commits on the server on its own, so a failure in
;; a later batch leaves the previous ones already marked as
;; read. The unread list is re-read anyway and the error is
;; propagated afterwards, so the success toast below stays
;; limited to a full success.
(rx/catch (fn [_]
(rx/concat (rx/of refresh-event)
(rx/throw {:type :comment-error})))))
(rx/of (ntf/show {:level :info
:type :toast
:content (tr "dashboard.mark-all-as-read.success")

15
frontend/src/app/main/data/team.cljs
View File

@ -259,7 +259,20 @@
(watch [_ state _]
(let [team-id (:current-team-id state)]
(->> (rp/cmd! :get-team-invitations {:team-id team-id})
(rx/map (partial invitations-fetched team-id)))))))
(rx/map (partial invitations-fetched team-id))
(rx/catch (fn [cause]
(let [{:keys [type code]} (ex-data cause)]
(if (and (= :validation type)
(= :insufficient-permissions code))
;; The pending invitations are an admin only
;; list, so a denied refetch means the cached
;; copy is no longer valid: drop it instead of
;; leaving stale emails around.
(do
(log/warn :hint "fetch-invitations: no permission, clearing"
:team-id (str team-id))
(rx/of (invitations-fetched team-id [])))
(rx/throw cause))))))))))
(defn- team-initialized
[team-id]

10
frontend/src/app/main/ui/dashboard/organization_team_switch_menus.cljs
View File

@ -180,10 +180,12 @@
:data-testid "team-members"}
(tr "labels.members")]
[:> dropdown-menu-item* {:on-click on-invitations-click
:class (stl/css :options-item)
:data-testid "team-invitations"}
(tr "labels.invitations")]
;; The pending invitations are an admin only list.
(when (:is-admin permissions)
[:> dropdown-menu-item* {:on-click on-invitations-click
:class (stl/css :options-item)
:data-testid "team-invitations"}
(tr "labels.invitations")])
(when (contains? cf/flags :webhooks)
[:> dropdown-menu-item* {:on-click on-webhooks-click

225
frontend/src/app/main/ui/dashboard/team.cljs
View File

@ -70,6 +70,7 @@
invitations-section? (= section :dashboard-team-invitations)
webhooks-section? (= section :dashboard-team-webhooks)
permissions (:permissions team)
is-admin? (boolean (:is-admin permissions))
can-invite? (dnt/can-send-invitations?
{:organization (:organization team)
:profile-id (:id profile)
@ -110,10 +111,11 @@
[:a {:class (stl/css-case :dashboard-header-link true
:active members-section?)
:on-click on-nav-members} (tr "labels.members")]]
[:li
[:a {:class (stl/css-case :dashboard-header-link true
:active invitations-section?)
:on-click on-nav-invitations} (tr "labels.invitations")]]
(when is-admin?
[:li
[:a {:class (stl/css-case :dashboard-header-link true
:active invitations-section?)
:on-click on-nav-invitations} (tr "labels.invitations")]])
(when (contains? cfg/flags :webhooks)
[:li
[:a {:class (stl/css-case :dashboard-header-link true
@ -124,7 +126,9 @@
:active settings-section?)
:on-click on-nav-settings} (tr "labels.settings")]]]]
[:div {:class (stl/css :dashboard-buttons)}
(when (and (or invitations-section? members-section?) (not-empty invitations))
(when (and is-admin?
(or invitations-section? members-section?)
(not-empty invitations))
(let [invite-button (mf/html
[:> button* {:class (stl/css :invite-button)
:variant "secondary"
@ -661,7 +665,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(mf/defc invitation-role-selector*
[{:keys [can-invite role status on-change]}]
[{:keys [role status on-change]}]
(let [show? (mf/use-state false)
label (cond
(= role :owner) (tr "labels.owner")
@ -682,7 +686,7 @@
(on-change role event))))]
[:*
(if (and can-invite (= status :pending))
(if (= status :pending)
[:button {:class (stl/css :rol-selector :has-priv)
:type "button"
:aria-haspopup "listbox"
@ -709,9 +713,16 @@
:on-click on-change'}
(tr "labels.viewer")]]]]))
(defn invitation-link-copyable?
"The link of an owner invitation can only be copied by the team owner: an
admin cannot create nor promote an owner invitation, so the backend does
not mint its token for them."
[is-owner? role]
(or (not= :owner role) is-owner?))
(mf/defc invitation-actions*
{::mf/private true}
[{:keys [invitation team-id]}]
[{:keys [invitation team-id is-owner?]}]
(let [email (:email invitation)
copied* (mf/use-state false)
copied? (deref copied*)
@ -757,15 +768,16 @@
(-> (dtm/copy-invitation-link params)
(with-meta {::ev/origin :team}))))))]
[:> icon-button* {:variant "ghost"
:aria-label (tr "labels.copy-invitation-link")
:on-click on-copy
:icon (if copied? "tick" "clipboard")}]))
(when (invitation-link-copyable? is-owner? (:role invitation))
[:> icon-button* {:variant "ghost"
:aria-label (tr "labels.copy-invitation-link")
:on-click on-copy
:icon (if copied? "tick" "clipboard")}])))
(mf/defc invitation-row*
{::mf/wrap [mf/memo]
::mf/private true}
[{:keys [invitation can-invite team-id selected on-select-change]}]
[{:keys [invitation team-id selected on-select-change is-owner?]}]
(let [expired? (:expired invitation)
email (:email invitation)
@ -783,12 +795,11 @@
on-change
(mf/use-fn
(mf/deps can-invite on-select-change)
(mf/deps on-select-change)
(fn [event]
(when can-invite
(let [email (-> (dom/get-current-target event)
(dom/get-data "attr"))]
(on-select-change email)))))
(let [email (-> (dom/get-current-target event)
(dom/get-data "attr"))]
(on-select-change email))))
on-change-role
(mf/use-fn
@ -800,26 +811,23 @@
[:div {:class (stl/css :table-row :table-row-invitations)}
[:div {:class (stl/css :table-field :field-email)}
(if can-invite
[:div {:class (stl/css :input-wrapper)}
[:label
[:span {:class (stl/css-case :input-checkbox true
:global/checked (is-selected? email))}
deprecated-icon/status-tick]
[:div {:class (stl/css :input-wrapper)}
[:label
[:span {:class (stl/css-case :input-checkbox true
:global/checked (is-selected? email))}
deprecated-icon/status-tick]
[:input {:type "checkbox"
:id (dm/str "email-" email)
:data-attr email
:value email
:checked (is-selected? email)
:on-change on-change}]
email]]
[:div email])]
[:input {:type "checkbox"
:id (dm/str "email-" email)
:data-attr email
:value email
:checked (is-selected? email)
:on-change on-change}]
email]]]
[:div {:class (stl/css :table-field :field-roles)}
[:> invitation-role-selector*
{:can-invite can-invite
:role role
{:role role
:status status
:on-change on-change-role}]]
@ -827,14 +835,14 @@
[:& badge-notification {:type type :content badge-content}]]
[:div {:class (stl/css :table-field :field-actions)}
(when ^boolean can-invite
[:> invitation-actions*
{:invitation invitation
:team-id team-id}])]]))
[:> invitation-actions*
{:invitation invitation
:team-id team-id
:is-owner? is-owner?}]]]))
(mf/defc empty-invitation-table*
{::mf/private true}
[{:keys [can-invite team]}]
[{:keys [team]}]
(let
[route (mf/deref refs/route)
invite-email (-> route :query-params :invite-email)
@ -846,15 +854,12 @@
:invite-email invite-email}))))]
[:div {:class (stl/css :empty-invitations)}
[:div (tr "labels.no-invitations")]
(if ^boolean can-invite
[:*
[:div (tr "labels.no-invitations-gather-people")]
[:> button* {:variant "primary"
:class (stl/css :btn-empty-invitations)
:on-click on-invite-member
:data-testid "invite-member"}
(tr "dashboard.invite-profile")]]
[:div {:class (stl/css :no-permission-text)} (tr "dashboard.invitations.no-permission")])]))
[:div (tr "labels.no-invitations-gather-people")]
[:> button* {:variant "primary"
:class (stl/css :btn-empty-invitations)
:on-click on-invite-member
:data-testid "invite-member"}
(tr "dashboard.invite-profile")]]))
(mf/defc invitation-modal
{::mf/register modal/components
@ -1059,6 +1064,17 @@
:on-click on-confirm'}
accept]]]]]))
(defn invitations-section-content
"What the invitations section shows: the list of the pending invitations
for the team admins, or just the permission notice. The pending invitations
are an admin only list, and `:is-admin` already includes the team owner.
The organization invite policy does not gate the list, only the invite
actions."
[permissions]
(if (:is-admin permissions)
:list
:no-permission))
(mf/defc invitation-section*
{::mf/private true}
[{:keys [team profile]}]
@ -1072,6 +1088,8 @@
:profile-id (:id profile)
:team-permissions permissions})
is-owner? (boolean (:is-owner permissions))
selected (mf/use-state #{})
;; Sort state: {:field :status/:role, :direction :asc/:desc}
@ -1082,12 +1100,11 @@
on-select-change
(mf/use-fn
(mf/deps can-invite? selected)
(mf/deps selected)
(fn [email]
(when can-invite?
(if (contains? @selected email)
(swap! selected disj email)
(swap! selected conj email)))))
(if (contains? @selected email)
(swap! selected disj email)
(swap! selected conj email))))
on-confirm-delete
(mf/use-fn
@ -1197,57 +1214,63 @@
(reset! sort-state {:field nil :direction :asc}))
[:div {:class (stl/css :invitations)}
(when (and (not can-invite?)
(seq @invitations))
;; The pending invitations are an admin only list: a member that is not
;; a team admin does not get them, so there is nothing to show but the
;; permission notice.
(case (invitations-section-content permissions)
:no-permission
[:div {:class (stl/css :empty-invitations)}
[:div {:class (stl/css :no-permission-text)}
(tr "dashboard.invitations.no-permission")]])
(when (and can-invite?
(> (count @selected) 0))
(tr "dashboard.invitations.no-permission")]]
[:*
[:div {:class (stl/css :invitations-actions)}
[:div
(tr "team.invitations-selected" (i18n/c (count @selected)))]
[:div
[:> button* {:variant "secondary"
:type "button"
:on-click on-resend}
(tr "labels.resend-invitation")]]
[:> icon-button* {:on-click on-delete
:variant "destructive"
:aria-label (tr "labels.delete-invitation")
:icon "delete"}]]])
[:div {:class (stl/css :table-header)}
[:div {:class (stl/css :title-field-name)} (tr "labels.invitations")]
[:div {:class (stl/css :title-field-role)} (tr "labels.role")
[:> icon-button* {:variant "action"
:class (stl/css-case :sort-active (= (:field @sort-state) :role)
:sort-inactive (not= (:field @sort-state) :role))
:aria-label (tr "dashboard.order-invitations-by-role")
:icon (if (= (:field @sort-state) :role)
(if (= (:direction @sort-state) :asc) "arrow-down" "arrow-up")
"arrow-down")
:on-click on-order-by-role}]]
[:div {:class (stl/css :title-field-status)} (tr "labels.status")
[:> icon-button* {:variant "action"
:class (stl/css-case :sort-active (= (:field @sort-state) :status)
:sort-inactive (not= (:field @sort-state) :status))
:aria-label (tr "dashboard.order-invitations-by-status")
:icon (if (= (:field @sort-state) :status)
(if (= (:direction @sort-state) :asc) "arrow-down" "arrow-up")
"arrow-down")
:on-click on-order-by-status}]]]
(if (empty? @invitations)
[:> empty-invitation-table* {:can-invite can-invite? :team team}]
[:div {:class (stl/css :table-rows)}
(for [invitation @invitations]
[:> invitation-row*
{:key (:email invitation)
:invitation invitation
:can-invite can-invite?
:team-id team-id
:selected selected
:on-select-change on-select-change}])])]))
(when (> (count @selected) 0)
[:div {:class (stl/css :invitations-actions)}
[:div
(tr "team.invitations-selected" (i18n/c (count @selected)))]
;; Resending goes through the invite command, so it needs the
;; organization invite policy; deleting only needs team admin.
(when can-invite?
[:div
[:> button* {:variant "secondary"
:type "button"
:on-click on-resend}
(tr "labels.resend-invitation")]])
[:> icon-button* {:on-click on-delete
:variant "destructive"
:aria-label (tr "labels.delete-invitation")
:icon "delete"}]])
[:div {:class (stl/css :table-header)}
[:div {:class (stl/css :title-field-name)} (tr "labels.invitations")]
[:div {:class (stl/css :title-field-role)} (tr "labels.role")
[:> icon-button* {:variant "action"
:class (stl/css-case :sort-active (= (:field @sort-state) :role)
:sort-inactive (not= (:field @sort-state) :role))
:aria-label (tr "dashboard.order-invitations-by-role")
:icon (if (= (:field @sort-state) :role)
(if (= (:direction @sort-state) :asc) "arrow-down" "arrow-up")
"arrow-down")
:on-click on-order-by-role}]]
[:div {:class (stl/css :title-field-status)} (tr "labels.status")
[:> icon-button* {:variant "action"
:class (stl/css-case :sort-active (= (:field @sort-state) :status)
:sort-inactive (not= (:field @sort-state) :status))
:aria-label (tr "dashboard.order-invitations-by-status")
:icon (if (= (:field @sort-state) :status)
(if (= (:direction @sort-state) :asc) "arrow-down" "arrow-up")
"arrow-down")
:on-click on-order-by-status}]]]
(if (empty? @invitations)
[:> empty-invitation-table* {:team team}]
[:div {:class (stl/css :table-rows)}
(for [invitation @invitations]
[:> invitation-row*
{:key (:email invitation)
:invitation invitation
:is-owner? is-owner?
:team-id team-id
:selected selected
:on-select-change on-select-change}])])])]))
(mf/defc team-invitations-page*
[{:keys [team profile]}]

95
frontend/test/frontend_tests/data/comments_batches_test.cljs Normal file
View File

@ -0,0 +1,95 @@
;; 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/.
(ns frontend-tests.data.comments-batches-test
(:require
[app.common.uuid :as uuid]
[app.main.data.comments :as dcmt]
[app.main.data.notifications :as ntf]
[app.main.repo :as rp]
[beicon.v2.core :as rx]
[cljs.test :as t :include-macros true]
[frontend-tests.helpers.async :as async]
[frontend-tests.helpers.mock :as mock]
[potok.v2.core :as ptk]))
(defn- comment-threads-state
[n]
{:comment-threads (into {} (map (fn [_] [(uuid/next) {:id (uuid/next)}]) (range n)))})
(t/deftest mark-all-threads-batches-splits-the-ids
(t/is (= [] (dcmt/mark-all-threads-batches [])))
(t/is (= [[1 2 3]] (dcmt/mark-all-threads-batches [1 2 3])))
(t/is (= [500 1] (mapv count (dcmt/mark-all-threads-batches (range 501))))))
(t/deftest ^:async mark-all-threads-as-read-sends-the-ids-in-batches
(let [calls (atom [])
state (comment-threads-state 1200)
event (dcmt/mark-all-threads-as-read (uuid/next))]
(await
(mock/with-mocks*
{rp/cmd! (mock/stub
(fn [cmd params]
(swap! calls conj [cmd params])
(rx/of nil)))}
(await (async/observe (ptk/watch event state nil)))))
(t/is (= 3 (count @calls)))
(t/is (every? #(= :mark-all-threads-as-read (first %)) @calls))
(t/is (= [500 500 200] (mapv (comp count :threads second) @calls)))))
(t/deftest ^:async mark-all-threads-as-read-sends-a-single-batch
(let [calls (atom [])
state (comment-threads-state 10)
event (dcmt/mark-all-threads-as-read (uuid/next))]
(await
(mock/with-mocks*
{rp/cmd! (mock/stub
(fn [cmd params]
(swap! calls conj [cmd params])
(rx/of nil)))}
(await (async/observe (ptk/watch event state nil)))))
(t/is (= 1 (count @calls)))
(t/is (= 10 (count (:threads (second (first @calls))))))))
(t/deftest ^:async mark-all-threads-as-read-refreshes-the-unread-list-after-a-batch-fails
(let [calls (atom [])
state (comment-threads-state 1200)
event (dcmt/mark-all-threads-as-read (uuid/next))
seen (atom [])
errors (atom [])]
(await
(mock/with-mocks*
{rp/cmd! (mock/stub
(fn [cmd params]
(swap! calls conj [cmd params])
(if (= 2 (count @calls))
(rx/throw (ex-info "boom" {}))
(rx/of nil))))}
(await (async/observe (ptk/watch event state nil)
:on-next #(swap! seen conj (ptk/type %))
:on-error #(swap! errors conj %)))))
(t/is (= 2 (count @calls))
"the pipeline stops at the batch that fails")
(t/is (= [::dcmt/retrieve-unread-comment-threads] @seen)
"the unread list is re-read and no success toast is emitted")
(t/is (= [{:type :comment-error}] @errors))))
(t/deftest ^:async mark-all-threads-as-read-refreshes-and-shows-the-success-toast
(let [state (comment-threads-state 600)
event (dcmt/mark-all-threads-as-read (uuid/next))
seen (atom [])]
(await
(mock/with-mocks*
{rp/cmd! (mock/stub (fn [_ _] (rx/of nil)))}
(await (async/observe (ptk/watch event state nil)
:on-next #(swap! seen conj (ptk/type %))))))
(t/is (= [::dcmt/retrieve-unread-comment-threads ::ntf/show] @seen))))

81
frontend/test/frontend_tests/data/team_test.cljs Normal file
View File

@ -0,0 +1,81 @@
;; 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/.
(ns frontend-tests.data.team-test
(:require
[app.common.uuid :as uuid]
[app.main.data.team :as dtm]
[app.main.repo :as rp]
[app.main.ui.dashboard.team :as dtui]
[beicon.v2.core :as rx]
[cljs.test :as t :include-macros true]
[frontend-tests.helpers.async :as async]
[frontend-tests.helpers.mock :as mock]
[potok.v2.core :as ptk]))
(defn- fetch-invitations-events
"Runs the watch of `fetch-invitations` with `rp/cmd!` answering with
`response` and resolves to the team id and the events it emits."
[response]
(let [team-id (uuid/next)
state {:current-team-id team-id}
emitted (atom [])]
(-> (mock/with-mocks*
{rp/cmd! (mock/stub (fn [_cmd _params] response))}
(await (async/observe (ptk/watch (dtm/fetch-invitations) state nil)
:on-next #(swap! emitted conj %))))
(.then (fn [_] {:team-id team-id :events @emitted})))))
(t/deftest ^:async fetch-invitations-clears-the-list-on-permission-error
;; The pending invitations are an admin only list: a member that cannot
;; invite gets an insufficient permissions error. That must not become an
;; error toast, and the cached list must be dropped so the stale emails do
;; not stay around.
(let [{:keys [team-id events]}
(await (fetch-invitations-events
(rx/throw (ex-info "insufficient permissions"
{:type :validation
:code :insufficient-permissions}))))
event (first events)
state (ptk/update event {:teams {team-id {:id team-id
:invitations [{:email "stale@example.com"
:role :editor}]}}})]
(t/is (= 1 (count events)))
(t/is (= ::dtm/invitations-fetched (ptk/type event)))
(t/is (= [] (get-in state [:teams team-id :invitations])))))
(t/deftest ^:async fetch-invitations-propagates-other-errors
;; Only the permission failure is swallowed: any other error is a real
;; problem and must reach the error reporting.
(let [outcome (await (mock/with-mocks*
{rp/cmd! (mock/stub (fn [_cmd _params]
(rx/throw (ex-info "boom" {:type :server}))))}
(try
(await (async/observe (ptk/watch (dtm/fetch-invitations)
{:current-team-id (uuid/next)}
nil)))
:resolved
(catch js/Error _ :rejected))))]
(t/is (= :rejected outcome))))
(t/deftest ^:async fetch-invitations-emits-the-update-event
(let [{:keys [events]} (await (fetch-invitations-events
(rx/of [{:email "invited@example.com" :role :editor}])))]
(t/is (= 1 (count events)))
(t/is (= ::dtm/invitations-fetched (ptk/type (first events))))))
(t/deftest invitations-section-shows-the-list-only-to-the-team-admins
;; The list is admin only, and the backend normalizes `:is-admin` to
;; include the team owner. The organization invite policy does not gate it.
(t/is (= :list (dtui/invitations-section-content {:is-owner false :is-admin true})))
(t/is (= :list (dtui/invitations-section-content {:is-owner true :is-admin true})))
(t/is (= :no-permission (dtui/invitations-section-content {:is-owner false :is-admin false}))))
(t/deftest owner-invitation-link-is-copyable-only-by-the-team-owner
;; An admin cannot create nor promote an owner invitation, so the backend
;; does not mint its token for them: the action is not offered either.
(t/is (true? (dtui/invitation-link-copyable? true :owner)))
(t/is (false? (dtui/invitation-link-copyable? false :owner)))
(t/is (true? (dtui/invitation-link-copyable? false :editor)))
(t/is (true? (dtui/invitation-link-copyable? false :viewer))))

4
frontend/test/frontend_tests/runner.cljs
View File

@ -10,6 +10,7 @@
[frontend-tests.composable-tests.comp.sync-test]
[frontend-tests.copy-as-svg-test]
[frontend-tests.data.auth-test]
[frontend-tests.data.comments-batches-test]
[frontend-tests.data.comments-filters-test]
[frontend-tests.data.dashboard-test]
[frontend-tests.data.event-test]
@ -30,6 +31,7 @@
[frontend-tests.data.repo-test]
[frontend-tests.data.store-test]
[frontend-tests.data.svg-upload-test]
[frontend-tests.data.team-test]
[frontend-tests.data.uploads-test]
[frontend-tests.data.viewer-test]
[frontend-tests.data.workspace-colors-test]
@ -205,6 +207,7 @@
'frontend-tests.composable-tests.comp.sync-test
'frontend-tests.copy-as-svg-test
'frontend-tests.data.auth-test
'frontend-tests.data.comments-batches-test
'frontend-tests.data.comments-filters-test
'frontend-tests.data.dashboard-test
'frontend-tests.data.event-test
@ -228,6 +231,7 @@
'frontend-tests.worker.index-test
'frontend-tests.worker.trim-test
'frontend-tests.data.svg-upload-test
'frontend-tests.data.team-test
'frontend-tests.data.uploads-test
'frontend-tests.data.viewer-test
'frontend-tests.data.workspace-colors-test