Penpot/penpot
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-04-15 00:12:33 -05:00
Code Issues Activity

✨ Add safety mechanism for direct object deletion

Browse source 
The main objective is prevent deletion of objects that can leave
unreachable orphan objects which we are unable to correctly track.

Additionally, this commit includes:

1. Properly implement safe cascade deletion of all participating
   tables on soft deletion in the objects-gc task;

2. Make the file thumbnail related tables also participate in the
   touch/refcount mechanism applyign to the same safety checks;

3. Add helper for db query lazy iteration using PostgreSQL support
   for server side cursors;

4. Fix efficiency issues on gc related task using server side
   cursors instead of custom chunked iteration for processing data.

   The problem resided when a large chunk of rows that has identical
   value on the deleted_at column and the chunk size is small (the
   default); when the custom chunked iteration only reads a first N
   items and skip the rest of the set to the next run.

   This has caused many objects to remain pending to be eliminated,
   taking up space for longer than expected. The server side cursor
   based iteration does not has this problem and iterates correctly
   over all objects.

5. Fix refcount issues on font variant deletion RPC methods
This commit is contained in:
Andrey Antukh 2023-12-29 15:21:14 +01:00
parent e6fb96c4c2
commit addb392ecc
37 changed files with 1918 additions and 1026 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
backend/src/app/db.clj
View file

@ -341,6 +341,25 @@
(-> (get-connectable ds)
(jdbc/plan sql sql/default-opts)))
(defn cursor
"Return a lazy seq of rows using server side cursors"
[conn query & {:keys [chunk-size] :or {chunk-size 25}}]
(let [cname (str (gensym "cursor_"))
fquery [(str "FETCH " chunk-size " FROM " cname)]]
;; declare cursor
(exec-one! conn
(if (vector? query)
(into [(str "DECLARE " cname " CURSOR FOR " (nth query 0))]
(rest query))
[(str "DECLARE " cname " CURSOR FOR " query)]))
;; return a lazy seq
((fn fetch-more []
(lazy-seq
(when-let [chunk (seq (exec! conn fquery))]
(concat chunk (fetch-more))))))))
(defn get-by-id
[ds table id & {:as opts}]
(get ds table {:id id} opts))

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

@ -133,7 +133,7 @@
[_ {:keys [::db/pool] :as cfg}]
(cond
(db/read-only? pool)
(l/warn :hint "audit: disabled (db is read-only)")
(l/warn :hint "audit disabled (db is read-only)")
:else
cfg))
@ -187,8 +187,7 @@
false)}))
(defn- handle-event!
[conn-or-pool event]
(us/verify! ::event event)
[cfg event]
(let [params {:id (uuid/next)
:name (::name event)
:type (::type event)
@ -201,19 +200,22 @@
;; NOTE: this operation may cause primary key conflicts on inserts
;; because of the timestamp precission (two concurrent requests), in
;; this case we just retry the operation.
(rtry/with-retry {::rtry/when rtry/conflict-exception?
::rtry/max-retries 6
::rtry/label "persist-audit-log"
::db/conn (dm/check db/connection? conn-or-pool)}
(let [now (dt/now)]
(db/insert! conn-or-pool :audit-log
(-> params
(update :props db/tjson)
(update :context db/tjson)
(update :ip-addr db/inet)
(assoc :created-at now)
(assoc :tracked-at now)
(assoc :source "backend"))))))
(let [cfg (-> cfg
(assoc ::rtry/when rtry/conflict-exception?)
(assoc ::rtry/max-retries 6)
(assoc ::rtry/label "persist-audit-log"))
params (-> params
(update :props db/tjson)
(update :context db/tjson)
(update :ip-addr db/inet)
(assoc :source "backend"))]
(rtry/invoke cfg (fn [cfg]
(let [tnow (dt/now)
params (-> params
(assoc :created-at tnow)
(assoc :tracked-at tnow))]
(db/insert! cfg :audit-log params))))))
(when (and (contains? cf/flags :webhooks)
(::webhooks/event? event))
@ -226,7 +228,7 @@
:else label)
dedupe? (boolean (and batch-key batch-timeout))]
(wrk/submit! ::wrk/conn conn-or-pool
(wrk/submit! ::wrk/conn (::db/conn cfg)
::wrk/task :process-webhook-event
::wrk/queue :webhooks
::wrk/max-retries 0
@ -243,12 +245,12 @@
(defn submit!
"Submit audit event to the collector."
[cfg params]
(let [conn (or (::db/conn cfg) (::db/pool cfg))]
(us/assert! ::db/pool-or-conn conn)
(try
(handle-event! conn (d/without-nils params))
(catch Throwable cause
(l/error :hint "audit: unexpected error processing event" :cause cause)))))
(try
(let [event (d/without-nils params)]
(us/verify! ::event event)
(db/tx-run! cfg handle-event! event))
(catch Throwable cause
(l/error :hint "unexpected error processing event" :cause cause))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TASK: ARCHIVE

17
backend/src/app/main.clj
View file

@ -34,6 +34,8 @@
[app.srepl :as-alias srepl]
[app.storage :as-alias sto]
[app.storage.fs :as-alias sto.fs]
[app.storage.gc-deleted :as-alias sto.gc-deleted]
[app.storage.gc-touched :as-alias sto.gc-touched]
[app.storage.s3 :as-alias sto.s3]
[app.util.time :as dt]
[app.worker :as-alias wrk]
@ -202,11 +204,11 @@
:app.storage.tmp/cleaner
{::wrk/executor (ig/ref ::wrk/executor)}
::sto/gc-deleted-task
::sto.gc-deleted/handler
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)}
::sto/gc-touched-task
::sto.gc-touched/handler
{::db/pool (ig/ref ::db/pool)}
::http.client/client
@ -337,12 +339,13 @@
::wrk/tasks
{:sendmail (ig/ref ::email/handler)
:objects-gc (ig/ref :app.tasks.objects-gc/handler)
:orphan-teams-gc (ig/ref :app.tasks.orphan-teams-gc/handler)
:file-gc (ig/ref :app.tasks.file-gc/handler)
:file-xlog-gc (ig/ref :app.tasks.file-xlog-gc/handler)
:storage-gc-deleted (ig/ref ::sto/gc-deleted-task)
:storage-gc-touched (ig/ref ::sto/gc-touched-task)
:tasks-gc (ig/ref :app.tasks.tasks-gc/handler)
:telemetry (ig/ref :app.tasks.telemetry/handler)
:storage-gc-deleted (ig/ref ::sto.gc-deleted/handler)
:storage-gc-touched (ig/ref ::sto.gc-touched/handler)
:session-gc (ig/ref ::session.tasks/gc)
:audit-log-archive (ig/ref ::audit.tasks/archive)
:audit-log-gc (ig/ref ::audit.tasks/gc)
@ -373,6 +376,9 @@
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)}
:app.tasks.orphan-teams-gc/handler
{::db/pool (ig/ref ::db/pool)}
:app.tasks.file-gc/handler
{::db/pool (ig/ref ::db/pool)
::sto/storage (ig/ref ::sto/storage)}
@ -458,6 +464,9 @@
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :objects-gc}
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :orphan-teams-gc}
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :storage-gc-deleted}

35
backend/src/app/migrations.clj
View file

@ -337,7 +337,40 @@
:fn (mg/resource "app/migrations/sql/0106-mod-team-table.sql")}
{:name "0107-mod-file-tagged-object-thumbnail-table"
:fn (mg/resource "app/migrations/sql/0107-mod-file-tagged-object-thumbnail-table.sql")}])
:fn (mg/resource "app/migrations/sql/0107-mod-file-tagged-object-thumbnail-table.sql")}
{:name "0107-add-deletion-protection-trigger-function"
:fn (mg/resource "app/migrations/sql/0107-add-deletion-protection-trigger-function.sql")}
{:name "0108-mod-file-thumbnail-table"
:fn (mg/resource "app/migrations/sql/0108-mod-file-thumbnail-table.sql")}
{:name "0109-mod-file-tagged-object-thumbnail-table"
:fn (mg/resource "app/migrations/sql/0109-mod-file-tagged-object-thumbnail-table.sql")}
{:name "0110-mod-file-media-object-table"
:fn (mg/resource "app/migrations/sql/0110-mod-file-media-object-table.sql")}
{:name "0111-mod-file-data-fragment-table"
:fn (mg/resource "app/migrations/sql/0111-mod-file-data-fragment-table.sql")}
{:name "0112-mod-profile-table"
:fn (mg/resource "app/migrations/sql/0112-mod-profile-table.sql")}
{:name "0113-mod-team-font-variant-table"
:fn (mg/resource "app/migrations/sql/0113-mod-team-font-variant-table.sql")}
{:name "0114-mod-team-table"
:fn (mg/resource "app/migrations/sql/0114-mod-team-table.sql")}
{:name "0115-mod-project-table"
:fn (mg/resource "app/migrations/sql/0115-mod-project-table.sql")}
{:name "0116-mod-file-table"
:fn (mg/resource "app/migrations/sql/0116-mod-file-table.sql")}
{:name "0117-mod-file-object-thumbnail-table"
:fn (mg/resource "app/migrations/sql/0117-mod-file-object-thumbnail-table.sql")}])
(defn apply-migrations!
[pool name migrations]

8
backend/src/app/migrations/sql/0107-add-deletion-protection-trigger-function.sql Normal file
View file

@ -0,0 +1,8 @@
CREATE OR REPLACE FUNCTION raise_deletion_protection()
RETURNS TRIGGER AS $$
BEGIN
RAISE EXCEPTION 'unable to proceed to delete row on "%"', TG_TABLE_NAME
USING HINT = 'disable deletion protection with "SET rules.deletion_protection TO off"';
RETURN NULL;
END;
$$ LANGUAGE plpgsql;

25
backend/src/app/migrations/sql/0108-mod-file-thumbnail-table.sql Normal file
View file

@ -0,0 +1,25 @@
--- Add missing index for deleted_at column, we include all related
--- columns because we expect the index to be small and expect use
--- index-only scans.
CREATE INDEX IF NOT EXISTS file_thumbnail__deleted_at__idx
ON file_thumbnail (deleted_at, file_id, revn, media_id)
WHERE deleted_at IS NOT NULL;
--- Add missing for media_id column, used mainly for refs checking
CREATE INDEX IF NOT EXISTS file_thumbnail__media_id__idx ON file_thumbnail (media_id);
--- Remove CASCADE from media_id and file_id foreign constraint
ALTER TABLE file_thumbnail
DROP CONSTRAINT file_thumbnail_file_id_fkey,
ADD FOREIGN KEY (file_id) REFERENCES file(id) DEFERRABLE;
ALTER TABLE file_thumbnail
DROP CONSTRAINT file_thumbnail_media_id_fkey,
ADD FOREIGN KEY (media_id) REFERENCES storage_object(id) DEFERRABLE;
--- Add deletion protection
CREATE OR REPLACE TRIGGER deletion_protection__tgr
BEFORE DELETE ON file_thumbnail FOR EACH STATEMENT
WHEN ((current_setting('rules.deletion_protection', true) IN ('on', '')) OR
(current_setting('rules.deletion_protection', true) IS NULL))
EXECUTE PROCEDURE raise_deletion_protection();

26
backend/src/app/migrations/sql/0109-mod-file-tagged-object-thumbnail-table.sql Normal file
View file

@ -0,0 +1,26 @@
ALTER TABLE file_tagged_object_thumbnail
ADD COLUMN updated_at timestamptz NULL,
ADD COLUMN deleted_at timestamptz NULL;
--- Add index for deleted_at column, we include all related columns
--- because we expect the index to be small and expect use index-only
--- scans.
CREATE INDEX IF NOT EXISTS file_tagged_object_thumbnail__deleted_at__idx
ON file_tagged_object_thumbnail (deleted_at, file_id, object_id, media_id)
WHERE deleted_at IS NOT NULL;
--- Remove CASCADE from media_id and file_id foreign constraint
ALTER TABLE file_tagged_object_thumbnail
DROP CONSTRAINT file_tagged_object_thumbnail_media_id_fkey,
ADD FOREIGN KEY (media_id) REFERENCES storage_object(id) DEFERRABLE;
ALTER TABLE file_tagged_object_thumbnail
DROP CONSTRAINT file_tagged_object_thumbnail_file_id_fkey,
ADD FOREIGN KEY (file_id) REFERENCES file(id) DEFERRABLE;
--- Add deletion protection
CREATE OR REPLACE TRIGGER deletion_protection__tgr
BEFORE DELETE ON file_tagged_object_thumbnail FOR EACH STATEMENT
WHEN ((current_setting('rules.deletion_protection', true) IN ('on', '')) OR
(current_setting('rules.deletion_protection', true) IS NULL))
EXECUTE PROCEDURE raise_deletion_protection();

27
backend/src/app/migrations/sql/0110-mod-file-media-object-table.sql Normal file
View file

@ -0,0 +1,27 @@
--- Fix legacy naming
ALTER INDEX media_object_pkey RENAME TO file_media_object_pkey;
ALTER INDEX media_object__file_id__idx RENAME TO file_media_object__file_id__idx;
--- Create index for the deleted_at column
CREATE INDEX IF NOT EXISTS file_media_object__deleted_at__idx
ON file_media_object (deleted_at, id, media_id)
WHERE deleted_at IS NOT NULL;
--- Drop now unnecesary trigger because this will be handled by the
--- application code
DROP TRIGGER file_media_object__on_delete__tgr ON file_media_object;
DROP FUNCTION on_delete_file_media_object ( ) CASCADE;
DROP TRIGGER file_media_object__on_insert__tgr ON file_media_object;
DROP FUNCTION on_media_object_insert () CASCADE;
--- Remove CASCADE from file FOREIGN KEY
ALTER TABLE file_media_object
DROP CONSTRAINT file_media_object_file_id_fkey,
ADD FOREIGN KEY (file_id) REFERENCES file(id) DEFERRABLE;
--- Add deletion protection
CREATE OR REPLACE TRIGGER deletion_protection__tgr
BEFORE DELETE ON file_media_object FOR EACH STATEMENT
WHEN ((current_setting('rules.deletion_protection', true) IN ('on', '')) OR
(current_setting('rules.deletion_protection', true) IS NULL))
EXECUTE PROCEDURE raise_deletion_protection();

9
backend/src/app/migrations/sql/0111-mod-file-data-fragment-table.sql Normal file
View file

@ -0,0 +1,9 @@
ALTER TABLE file_data_fragment
ADD COLUMN deleted_at timestamptz NULL;
--- Add index for deleted_at column, we include all related columns
--- because we expect the index to be small and expect use index-only
--- scans.
CREATE INDEX IF NOT EXISTS file_data_fragment__deleted_at__idx
ON file_data_fragment (deleted_at, file_id, id)
WHERE deleted_at IS NOT NULL;

15
backend/src/app/migrations/sql/0112-mod-profile-table.sql Normal file
View file

@ -0,0 +1,15 @@
ALTER TABLE profile
DROP CONSTRAINT profile_photo_id_fkey,
ADD FOREIGN KEY (photo_id) REFERENCES storage_object(id) DEFERRABLE,
DROP CONSTRAINT profile_default_project_id_fkey,
ADD FOREIGN KEY (default_project_id) REFERENCES project(id) DEFERRABLE,
DROP CONSTRAINT profile_default_team_id_fkey,
ADD FOREIGN KEY (default_team_id) REFERENCES team(id) DEFERRABLE;
--- Add deletion protection
CREATE OR REPLACE TRIGGER deletion_protection__tgr
BEFORE DELETE ON profile FOR EACH STATEMENT
WHEN ((current_setting('rules.deletion_protection', true) IN ('on', '')) OR
(current_setting('rules.deletion_protection', true) IS NULL))
EXECUTE PROCEDURE raise_deletion_protection();

20
backend/src/app/migrations/sql/0113-mod-team-font-variant-table.sql Normal file
View file

@ -0,0 +1,20 @@
--- Remove ON DELETE SET NULL from foreign constraint on
--- storage_object table
ALTER TABLE team_font_variant
DROP CONSTRAINT team_font_variant_otf_file_id_fkey,
ADD FOREIGN KEY (otf_file_id) REFERENCES storage_object(id) DEFERRABLE,
DROP CONSTRAINT team_font_variant_ttf_file_id_fkey,
ADD FOREIGN KEY (ttf_file_id) REFERENCES storage_object(id) DEFERRABLE,
DROP CONSTRAINT team_font_variant_woff1_file_id_fkey,
ADD FOREIGN KEY (woff1_file_id) REFERENCES storage_object(id) DEFERRABLE,
DROP CONSTRAINT team_font_variant_woff2_file_id_fkey,
ADD FOREIGN KEY (woff2_file_id) REFERENCES storage_object(id) DEFERRABLE,
DROP CONSTRAINT team_font_variant_team_id_fkey,
ADD FOREIGN KEY (team_id) REFERENCES team(id) DEFERRABLE;
--- Add deletion protection
CREATE OR REPLACE TRIGGER deletion_protection__tgr
BEFORE DELETE ON team_font_variant FOR EACH STATEMENT
WHEN ((current_setting('rules.deletion_protection', true) IN ('on', '')) OR
(current_setting('rules.deletion_protection', true) IS NULL))
EXECUTE PROCEDURE raise_deletion_protection();

10
backend/src/app/migrations/sql/0114-mod-team-table.sql Normal file
View file

@ -0,0 +1,10 @@
--- Add deletion protection
CREATE OR REPLACE TRIGGER deletion_protection__tgr
BEFORE DELETE ON team FOR EACH STATEMENT
WHEN ((current_setting('rules.deletion_protection', true) IN ('on', '')) OR
(current_setting('rules.deletion_protection', true) IS NULL))
EXECUTE PROCEDURE raise_deletion_protection();
ALTER TABLE team
DROP CONSTRAINT team_photo_id_fkey,
ADD FOREIGN KEY (photo_id) REFERENCES storage_object(id) DEFERRABLE;

3
backend/src/app/migrations/sql/0115-mod-project-table.sql Normal file
View file

@ -0,0 +1,3 @@
ALTER TABLE project
DROP CONSTRAINT project_team_id_fkey,
ADD FOREIGN KEY (team_id) REFERENCES team(id) DEFERRABLE;

3
backend/src/app/migrations/sql/0116-mod-file-table.sql Normal file
View file

@ -0,0 +1,3 @@
ALTER TABLE file
DROP CONSTRAINT file_project_id_fkey,
ADD FOREIGN KEY (project_id) REFERENCES project(id) DEFERRABLE;

12
backend/src/app/migrations/sql/0117-mod-file-object-thumbnail-table.sql Normal file
View file

@ -0,0 +1,12 @@
ALTER TABLE file_object_thumbnail
DROP CONSTRAINT file_object_thumbnail_file_id_fkey,
ADD FOREIGN KEY (file_id) REFERENCES file(id) DEFERRABLE,
DROP CONSTRAINT file_object_thumbnail_media_id_fkey,
ADD FOREIGN KEY (media_id) REFERENCES storage_object(id) DEFERRABLE;
--- Mark all related storage_object row as touched
-- UPDATE storage_object SET touched_at = now()
-- WHERE id IN (SELECT DISTINCT media_id
-- FROM file_object_thumbnail
-- WHERE media_id IS NOT NULL)
-- AND touched_at IS NULL;

4
backend/src/app/rpc/commands/auth.clj
View file

@ -54,7 +54,9 @@
:hint "the current account does not have password")
(let [result (profile/verify-password cfg password (:password profile))]
(when (:update result)
(l/trace :hint "updating profile password" :id (:id profile) :email (:email profile))
(l/trc :hint "updating profile password"
:id (str (:id profile))
:email (:email profile))
(profile/update-profile-password! conn (assoc profile :password password)))
(:valid result))))

26
backend/src/app/rpc/commands/comments.clj
View file

@ -309,23 +309,21 @@
::quotes/project-id project-id
::quotes/file-id file-id}))
(rtry/with-retry {::rtry/when rtry/conflict-exception?
::rtry/max-retries 3
::rtry/label "create-comment-thread"
::db/conn conn}
(create-comment-thread conn
{:created-at request-at
:profile-id profile-id
:file-id file-id
:page-id page-id
:page-name page-name
:position position
:content content
:frame-id frame-id}))))))
(-> cfg
(assoc ::rtry/when rtry/conflict-exception?)
(assoc ::rtry/label "create-comment-thread")
(rtry/invoke create-comment-thread {:created-at request-at
:profile-id profile-id
:file-id file-id
:page-id page-id
:page-name page-name
:position position
:content content
:frame-id frame-id}))))))
(defn- create-comment-thread
[conn {:keys [profile-id file-id page-id page-name created-at position content frame-id]}]
[{:keys [::db/conn]} {:keys [profile-id file-id page-id page-name created-at position content frame-id]}]
(let [;; NOTE: we take the next seq number from a separate query because the whole
;; operation can be retried on conflict, and in this case the new seq shold be
;; retrieved from the database.

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

@ -516,7 +516,7 @@
ft.media_id
from file as f
inner join project as p on (p.id = f.project_id)
left join file_thumbnail as ft on (ft.file_id = f.id and ft.revn = f.revn)
left join file_thumbnail as ft on (ft.file_id = f.id and ft.revn = f.revn and ft.deleted_at is null)
where f.is_shared = true
and f.deleted_at is null
and p.deleted_at is null

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

@ -27,6 +27,7 @@
[app.rpc.commands.teams :as teams]
[app.rpc.cond :as-alias cond]
[app.rpc.doc :as-alias doc]
[app.rpc.retry :as rtry]
[app.storage :as sto]
[app.util.pointer-map :as pmap]
[app.util.services :as sv]
@ -46,7 +47,7 @@
(let [sql (str/concat
"select object_id, media_id, tag "
" from file_tagged_object_thumbnail"
" where file_id=? and tag=?")
" where file_id=? and tag=? and deleted_at is null")
res (db/exec! conn [sql file-id tag])]
(->> res
(d/index-by :object-id (fn [row]
@ -58,7 +59,7 @@
(let [sql (str/concat
"select object_id, media_id, tag "
" from file_tagged_object_thumbnail"
" where file_id=?")
" where file_id=? and deleted_at is null")
res (db/exec! conn [sql file-id])]
(->> res
(d/index-by :object-id (fn [row]
@ -69,7 +70,7 @@
(let [sql (str/concat
"select object_id, media_id, tag "
" from file_tagged_object_thumbnail"
" where file_id=? and object_id = ANY(?)")
" where file_id=? and object_id = ANY(?) and deleted_at is null")
ids (db/create-array conn "text" (seq object-ids))
res (db/exec! conn [sql file-id ids])]
@ -226,34 +227,54 @@
;; MUTATION COMMANDS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- MUTATION COMMAND: create-file-object-thumbnail
(def ^:private sql:create-object-thumbnail
"insert into file_tagged_object_thumbnail(file_id, object_id, media_id, tag)
values (?, ?, ?, ?)
on conflict(file_id, tag, object_id) do
update set media_id = ?
returning *;")
;; MUTATION COMMAND: create-file-object-thumbnail
(defn- create-file-object-thumbnail!
[{:keys [::db/conn ::sto/storage]} file-id object-id media tag]
(let [path (:path media)
(let [thumb (db/get* conn :file-tagged-object-thumbnail
{:file-id file-id
:object-id object-id
:tag tag}
{::db/remove-deleted? false
::db/for-update? true})
path (:path media)
mtype (:mtype media)
hash (sto/calculate-hash path)
data (-> (sto/content path)
(sto/wrap-with-hash hash))
tnow (dt/now)
media (sto/put-object! storage
{::sto/content data
::sto/deduplicate? true
::sto/touched-at (dt/now)
::sto/touched-at tnow
:content-type mtype
:bucket "file-object-thumbnail"})]
(db/exec-one! conn [sql:create-object-thumbnail file-id object-id
(:id media) tag (:id media)])))
(if (some? thumb)
(do
;; We mark the old media id as touched if it does not matches
(when (not= (:id media) (:media-id thumb))
(sto/touch-object! storage (:media-id thumb)))
(db/update! conn :file-tagged-object-thumbnail
{:media-id (:id media)
:deleted-at nil
:updated-at tnow}
{:file-id file-id
:object-id object-id
:tag tag}))
(db/insert! conn :file-tagged-object-thumbnail
{:file-id file-id
:object-id object-id
:created-at tnow
:updated-at tnow
:tag tag
:media-id (:id media)}))))
(def schema:create-file-object-thumbnail
(def ^:private
schema:create-file-object-thumbnail
[:map {:title "create-file-object-thumbnail"}
[:file-id ::sm/uuid]
[:object-id :string]
@ -268,32 +289,37 @@
::audit/skip true
::sm/params schema:create-file-object-thumbnail}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id object-id media tag]}]
(db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id file-id)
(media/validate-media-type! media)
(media/validate-media-size! media)
[cfg {:keys [::rpc/profile-id file-id object-id media tag]}]
(db/tx-run! cfg
(fn [{:keys [::db/conn] :as cfg}]
(files/check-edition-permissions! conn profile-id file-id)
(media/validate-media-type! media)
(media/validate-media-size! media)
(when-not (db/read-only? conn)
(-> cfg
(update ::sto/storage media/configure-assets-storage)
(assoc ::db/conn conn)
(create-file-object-thumbnail! file-id object-id media (or tag "frame"))))))
(when-not (db/read-only? conn)
(let [cfg (-> cfg
(update ::sto/storage media/configure-assets-storage)
(assoc ::rtry/when rtry/conflict-exception?)
(assoc ::rtry/max-retries 5)
(assoc ::rtry/label "create-file-object-thumbnail"))]
(rtry/invoke cfg create-file-object-thumbnail!
file-id object-id media (or tag "frame")))))))
;; --- MUTATION COMMAND: delete-file-object-thumbnail
(defn- delete-file-object-thumbnail!
[{:keys [::db/conn ::sto/storage]} file-id object-id]
(when-let [{:keys [media-id]} (db/get* conn :file-tagged-object-thumbnail
{:file-id file-id
:object-id object-id}
{::db/for-update? true})]
(when-let [{:keys [media-id tag]} (db/get* conn :file-tagged-object-thumbnail
{:file-id file-id
:object-id object-id}
{::db/for-update? true})]
(sto/touch-object! storage media-id)
(db/delete! conn :file-tagged-object-thumbnail
(db/update! conn :file-tagged-object-thumbnail
{:deleted-at (dt/now)}
{:file-id file-id
:object-id object-id})
nil))
:object-id object-id
:tag tag}
{::db/return-keys? false})))
(s/def ::delete-file-object-thumbnail
(s/keys :req [::rpc/profile-id]
@ -302,29 +328,21 @@
(sv/defmethod ::delete-file-object-thumbnail
{::doc/added "1.19"
::doc/module :files
::doc/deprecated "1.20"
::climit/id :file-thumbnail-ops
::climit/key-fn ::rpc/profile-id
::audit/skip true}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id object-id]}]
(db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id file-id)
(when-not (db/read-only? conn)
(-> cfg
(update ::sto/storage media/configure-assets-storage)
(assoc ::db/conn conn)
(delete-file-object-thumbnail! file-id object-id))
nil)))
[cfg {:keys [::rpc/profile-id file-id object-id]}]
(db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
(files/check-edition-permissions! conn profile-id file-id)
(when-not (db/read-only? conn)
(-> cfg
(update ::sto/storage media/configure-assets-storage conn)
(delete-file-object-thumbnail! file-id object-id))
nil))))
;; --- MUTATION COMMAND: create-file-thumbnail
(def ^:private sql:create-file-thumbnail
"insert into file_thumbnail (file_id, revn, media_id, props)
values (?, ?, ?, ?::jsonb)
on conflict(file_id, revn) do
update set media_id=?, props=?, updated_at=now();")
(defn- create-file-thumbnail!
[{:keys [::db/conn ::sto/storage]} {:keys [file-id revn props media] :as params}]
(media/validate-media-type! media)
@ -336,14 +354,42 @@
hash (sto/calculate-hash path)
data (-> (sto/content path)
(sto/wrap-with-hash hash))
tnow (dt/now)
media (sto/put-object! storage
{::sto/content data
::sto/deduplicate? false
::sto/deduplicate? true
::sto/touched-at tnow
:content-type mtype
:bucket "file-thumbnail"})]
(db/exec-one! conn [sql:create-file-thumbnail file-id revn
(:id media) props
(:id media) props])
:bucket "file-thumbnail"})
thumb (db/get* conn :file-thumbnail
{:file-id file-id
:revn revn}
{::db/remove-deleted? false
::db/for-update? true})]
(if (some? thumb)
(do
;; We mark the old media id as touched if it does not match
(when (not= (:id media) (:media-id thumb))
(sto/touch-object! storage (:media-id thumb)))
(db/update! conn :file-thumbnail
{:media-id (:id media)
:deleted-at nil
:updated-at tnow
:props props}
{:file-id file-id
:revn revn}))
(db/insert! conn :file-thumbnail
{:file-id file-id
:revn revn
:created-at tnow
:updated-at tnow
:props props
:media-id (:id media)}))
media))
(sv/defmethod ::create-file-thumbnail
@ -359,13 +405,14 @@
[:revn :int]
[:media ::media/upload]]}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id] :as params}]
(db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id file-id)
(when-not (db/read-only? conn)
(let [media (-> cfg
(update ::sto/storage media/configure-assets-storage)
(assoc ::db/conn conn)
(create-file-thumbnail! params))]
{:uri (files/resolve-public-uri (:id media))}))))
[cfg {:keys [::rpc/profile-id file-id] :as params}]
(db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
(files/check-edition-permissions! conn profile-id file-id)
(when-not (db/read-only? conn)
(let [cfg (-> cfg
(update ::sto/storage media/configure-assets-storage)
(assoc ::rtry/when rtry/conflict-exception?)
(assoc ::rtry/max-retries 5)
(assoc ::rtry/label "create-thumbnail"))
media (rtry/invoke cfg create-file-thumbnail! params)]
{:uri (files/resolve-public-uri (:id media))})))))

214
backend/src/app/rpc/commands/fonts.clj
View file

@ -8,7 +8,7 @@
(:require
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.schema :as sm]
[app.common.uuid :as uuid]
[app.db :as db]
[app.loggers.audit :as-alias audit]
@ -25,39 +25,27 @@
[app.storage :as sto]
[app.util.services :as sv]
[app.util.time :as dt]
[app.worker :as-alias wrk]
[clojure.spec.alpha :as s]))
[app.worker :as-alias wrk]))
(def valid-weight #{100 200 300 400 500 600 700 800 900 950})
(def valid-style #{"normal" "italic"})
(s/def ::data (s/map-of ::us/string any?))
(s/def ::file-id ::us/uuid)
(s/def ::font-id ::us/uuid)
(s/def ::id ::us/uuid)
(s/def ::name ::us/not-empty-string)
(s/def ::project-id ::us/uuid)
(s/def ::share-id ::us/uuid)
(s/def ::style valid-style)
(s/def ::team-id ::us/uuid)
(s/def ::weight valid-weight)
;; --- QUERY: Get font variants
(s/def ::get-font-variants
(s/and
(s/keys :req [::rpc/profile-id]
:opt-un [::team-id
::file-id
::project-id
::share-id])
(fn [o]
(or (contains? o :team-id)
(contains? o :file-id)
(contains? o :project-id)))))
(def ^:private
schema:get-font-variants
[:schema {:title "get-font-variants"}
[:and
[:map
[:team-id {:optional true} ::sm/uuid]
[:file-id {:optional true} ::sm/uuid]
[:project-id {:optional true} ::sm/uuid]
[:share-id {:optional true} ::sm/uuid]]
[::sm/contains-any #{:team-id :file-id :project-id}]]])
(sv/defmethod ::get-font-variants
{::doc/added "1.18"}
{::doc/added "1.18"
::sm/params schema:get-font-variants}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id file-id project-id share-id] :as params}]
(dm/with-open [conn (db/open pool)]
(cond
@ -87,28 +75,31 @@
(declare create-font-variant)
(s/def ::create-font-variant
(s/keys :req [::rpc/profile-id]
:req-un [::team-id
::data
::font-id
::font-family
::font-weight
::font-style]))
(def ^:private schema:create-font-variant
[:map {:title "create-font-variant"}
[:team-id ::sm/uuid]
[:data [:map-of :string :any]]
[:font-id ::sm/uuid]
[:font-family :string]
[:font-weight [::sm/one-of {:format "number"} valid-weight]]
[:font-style [::sm/one-of {:format "string"} valid-style]]])
(sv/defmethod ::create-font-variant
{::doc/added "1.18"
::webhooks/event? true}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id team-id] :as params}]
(let [cfg (update cfg ::sto/storage media/configure-assets-storage)]
(teams/check-edition-permissions! pool profile-id team-id)
(quotes/check-quote! pool {::quotes/id ::quotes/font-variants-per-team
::quotes/profile-id profile-id
::quotes/team-id team-id})
(create-font-variant cfg (assoc params :profile-id profile-id))))
::webhooks/event? true
::sm/params schema:create-font-variant}
[cfg {:keys [::rpc/profile-id team-id] :as params}]
(db/tx-run! cfg
(fn [{:keys [::db/conn] :as cfg}]
(let [cfg (update cfg ::sto/storage media/configure-assets-storage)]
(teams/check-edition-permissions! conn profile-id team-id)
(quotes/check-quote! conn {::quotes/id ::quotes/font-variants-per-team
::quotes/profile-id profile-id
::quotes/team-id team-id})
(create-font-variant cfg (assoc params :profile-id profile-id))))))
(defn create-font-variant
[{:keys [::sto/storage ::db/pool] :as cfg} {:keys [data] :as params}]
[{:keys [::sto/storage ::db/conn] :as cfg} {:keys [data] :as params}]
(letfn [(generate-missing! [data]
(let [data (media/run {:cmd :generate-fonts :input data})]
(when (and (not (contains? data "font/otf"))
@ -136,6 +127,7 @@
ttf-params (prepare-font data "font/ttf")
wf1-params (prepare-font data "font/woff")
wf2-params (prepare-font data "font/woff2")]
(cond-> {}
(some? otf-params)
(assoc :otf (sto/put-object! storage otf-params))
@ -147,7 +139,7 @@
(assoc :woff2 (sto/put-object! storage wf2-params)))))
(insert-font-variant! [{:keys [woff1 woff2 otf ttf]}]
(db/insert! pool :team-font-variant
(db/insert! conn :team-font-variant
{:id (uuid/next)
:team-id (:team-id params)
:font-id (:font-id params)
@ -168,63 +160,109 @@
;; --- UPDATE FONT FAMILY
(s/def ::update-font
(s/keys :req [::rpc/profile-id]
:req-un [::team-id ::id ::name]))
(def ^:private
schema:update-font
[:map {:title "update-font"}
[:team-id ::sm/uuid]
[:id ::sm/uuid]
[:name :string]])
(sv/defmethod ::update-font
{::doc/added "1.18"
::webhooks/event? true}
[{:keys [::db/pool]} {:keys [::rpc/profile-id team-id id name]}]
(db/with-atomic [conn pool]
(teams/check-edition-permissions! conn profile-id team-id)
(rph/with-meta
(db/update! conn :team-font-variant
{:font-family name}
{:font-id id
:team-id team-id})
{::audit/replace-props {:id id
:name name
:team-id team-id
:profile-id profile-id}})))
::webhooks/event? true
::sm/params schema:update-font}
[cfg {:keys [::rpc/profile-id team-id id name]}]
(db/tx-run! cfg
(fn [{:keys [::db/conn]}]
(teams/check-edition-permissions! conn profile-id team-id)
(db/update! conn :team-font-variant
{:font-family name}
{:font-id id
:team-id team-id}
{::db/return-keys? false})
(rph/with-meta (rph/wrap nil)
{::audit/replace-props {:id id
:name name
:team-id team-id
:profile-id profile-id}}))))
;; --- DELETE FONT
(s/def ::delete-font
(s/keys :req [::rpc/profile-id]
:req-un [::team-id ::id]))
(def ^:private
schema:delete-font
[:map {:title "delete-font"}
[:team-id ::sm/uuid]
[:id ::sm/uuid]])
(sv/defmethod ::delete-font
{::doc/added "1.18"
::webhooks/event? true}
[{:keys [::db/pool]} {:keys [::rpc/profile-id id team-id]}]
(db/with-atomic [conn pool]
(teams/check-edition-permissions! conn profile-id team-id)
(let [font (db/update! conn :team-font-variant
{:deleted-at (dt/now)}
{:font-id id :team-id team-id})]
(rph/with-meta (rph/wrap)
{::audit/props {:id id
:team-id team-id
:name (:font-family font)
:profile-id profile-id}}))))
::webhooks/event? true
::sm/params schema:delete-font}
[cfg {:keys [::rpc/profile-id id team-id]}]
(db/tx-run! cfg
(fn [{:keys [::db/conn ::sto/storage] :as cfg}]
(teams/check-edition-permissions! conn profile-id team-id)
(let [fonts (db/query conn :team-font-variant
{:team-id team-id
:font-id id
:deleted-at nil}
{::db/for-update? true})
storage (media/configure-assets-storage storage conn)
tnow (dt/now)]
(when-not (seq fonts)
(ex/raise :type :not-found
:code :object-not-found))
(doseq [font fonts]
(db/update! conn :team-font-variant
{:deleted-at tnow}
{:id (:id font)}
{::db/return-keys? false})
(some->> (:woff1-file-id font) (sto/touch-object! storage))
(some->> (:woff2-file-id font) (sto/touch-object! storage))
(some->> (:ttf-file-id font) (sto/touch-object! storage))
(some->> (:otf-file-id font) (sto/touch-object! storage)))
(rph/with-meta (rph/wrap)
{::audit/props {:id id
:team-id team-id
:name (:font-family (peek fonts))
:profile-id profile-id}})))))
;; --- DELETE FONT VARIANT
(s/def ::delete-font-variant
(s/keys :req [::rpc/profile-id]
:req-un [::team-id ::id]))
(def ^:private schema:delete-font-variant
[:map {:title "delete-font-variant"}
[:team-id ::sm/uuid]
[:id ::sm/uuid]])
(sv/defmethod ::delete-font-variant
{::doc/added "1.18"
::webhooks/event? true}
[{:keys [::db/pool]} {:keys [::rpc/profile-id id team-id]}]
(db/with-atomic [conn pool]
(teams/check-edition-permissions! conn profile-id team-id)
(let [variant (db/update! conn :team-font-variant
{:deleted-at (dt/now)}
{:id id :team-id team-id})]
(rph/with-meta (rph/wrap)
{::audit/props {:font-family (:font-family variant)
:font-id (:font-id variant)}}))))
::webhooks/event? true
::sm/params schema:delete-font-variant}
[cfg {:keys [::rpc/profile-id id team-id]}]
(db/tx-run! cfg
(fn [{:keys [::db/conn ::sto/storage] :as cfg}]
(teams/check-edition-permissions! conn profile-id team-id)
(let [variant (db/get conn :team-font-variant
{:id id :team-id team-id}
{::db/for-update? true})
storage (media/configure-assets-storage storage conn)]
(db/update! conn :team-font-variant
{:deleted-at (dt/now)}
{:id (:id variant)}
{::db/return-keys? false})
(some->> (:woff1-file-id variant) (sto/touch-object! storage))
(some->> (:woff2-file-id variant) (sto/touch-object! storage))
(some->> (:ttf-file-id variant) (sto/touch-object! storage))
(some->> (:otf-file-id variant) (sto/touch-object! storage))
(rph/with-meta (rph/wrap)
{::audit/props {:font-family (:font-family variant)
:font-id (:font-id variant)}})))))

7
backend/src/app/rpc/commands/media.clj
View file

@ -23,6 +23,7 @@
[app.storage :as sto]
[app.storage.tmp :as tmp]
[app.util.services :as sv]
[app.util.time :as dt]
[app.worker :as-alias wrk]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
@ -153,6 +154,12 @@
thumb (when-let [params (::thumb result)]
(sto/put-object! storage params))]
(db/update! conn :file
{:modified-at (dt/now)
:has-media-trimmed false}
{:id file-id}
{::db/return-keys? false})
(db/exec-one! conn [sql:create-file-media-object
(or id (uuid/next))
file-id is-local name

77
backend/src/app/rpc/retry.clj
View file

@ -18,46 +18,47 @@
(and (instance? PSQLException e)
(= "23505" (.getSQLState ^PSQLException e))))
(def ^:private always-false (constantly false))
(def ^:private always-false
(constantly false))
(defn wrap-retry
[_ f {:keys [::matches ::sv/name] :or {matches always-false} :as mdata}]
[_ f {:keys [::sv/name] :as mdata}]
(when (::enabled mdata)
(l/debug :hint "wrapping retry" :name name))
(if-let [max-retries (::max-retries mdata)]
(fn [cfg params]
((fn run [retry]
(try
(f cfg params)
(catch Throwable cause
(if (matches cause)
(let [current-retry (inc retry)]
(l/trace :hint "running retry algorithm" :retry current-retry)
(if (<= current-retry max-retries)
(run current-retry)
(throw cause)))
(throw cause))))) 1))
(if (::enabled mdata)
(let [max-retries (get mdata ::max-retries 3)
matches? (get mdata ::when always-false)]
(l/dbg :hint "wrapping retry" :name name :max-retries max-retries)
(fn [cfg params]
((fn recursive-invoke [retry]
(try
(f cfg params)
(catch Throwable cause
(if (matches? cause)
(let [current-retry (inc retry)]
(l/wrn :hint "retrying operation" :retry current-retry :service name)
(if (<= current-retry max-retries)
(recursive-invoke current-retry)
(throw cause)))
(throw cause))))) 1)))
f))
(defmacro with-retry
[{:keys [::when ::max-retries ::label ::db/conn] :or {max-retries 3}} & body]
`(let [conn# ~conn]
(assert (or (nil? conn#) (db/connection? conn#)) "invalid database connection")
(loop [tnum# 1]
(let [result# (let [sp# (some-> conn# db/savepoint)]
(try
(let [result# (do ~@body)]
(some->> sp# (db/release! conn#))
result#)
(catch Throwable cause#
(some->> sp# (db/rollback! conn#))
(if (and (~when cause#) (<= tnum# ~max-retries))
::retry
(throw cause#)))))]
(if (= ::retry result#)
(do
(l/warn :hint "retrying operation" :label ~label :retry tnum#)
(recur (inc tnum#)))
result#)))))
(defn invoke
[{:keys [::db/conn ::max-retries] :or {max-retries 3} :as cfg} f & args]
(assert (db/connection? conn) "invalid database connection")
(loop [rnum 1]
(let [match? (get cfg ::when always-false)
result (let [spoint (db/savepoint conn)]
(try
(let [result (apply f cfg args)]
(db/release! conn spoint)
result)
(catch Throwable cause
(db/rollback! conn spoint)
(if (and (match? cause) (<= rnum max-retries))
::retry
(throw cause)))))]
(if (= ::retry result)
(let [label (get cfg ::label "anonymous")]
(l/warn :hint "retrying operation" :label label :retry rnum)
(recur (inc rnum)))
result))))

224
backend/src/app/storage.clj
View file

@ -9,8 +9,6 @@
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.db :as db]
@ -228,225 +226,3 @@
(dm/export impl/resolve-backend)
(dm/export impl/calculate-hash)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Garbage Collection: Permanently delete objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; A task responsible to permanently delete already marked as deleted
;; storage files. The storage objects are practically never marked to
;; be deleted directly by the api call. The touched-gc is responsible
;; of collecting the usage of the object and mark it as deleted. Only
;; the TMP files are are created with expiration date in future.
(declare sql:retrieve-deleted-objects-chunk)
(defmethod ig/pre-init-spec ::gc-deleted-task [_]
(s/keys :req [::storage ::db/pool]))
(defmethod ig/prep-key ::gc-deleted-task
[_ cfg]
(assoc cfg ::min-age (dt/duration {:hours 2})))
(defmethod ig/init-key ::gc-deleted-task
[_ {:keys [::db/pool ::storage ::min-age]}]
(letfn [(get-to-delete-chunk [cursor]
(let [sql (str "select s.* "
" from storage_object as s "
" where s.deleted_at is not null "
" and s.deleted_at < ? "
" order by s.deleted_at desc "
" limit 25")
rows (db/exec! pool [sql cursor])]
[(some-> rows peek :deleted-at)
(some->> (seq rows) (d/group-by #(-> % :backend keyword) :id #{}) seq)]))
(get-to-delete-chunks [min-age]
(d/iteration get-to-delete-chunk
:initk (dt/minus (dt/now) min-age)
:vf second
:kf first))
(delete-in-bulk! [backend-id ids]
(try
(db/with-atomic [conn pool]
(let [sql "delete from storage_object where id = ANY(?)"
ids' (db/create-array conn "uuid" ids)
total (-> (db/exec-one! conn [sql ids'])
(db/get-update-count))]
(-> (impl/resolve-backend storage backend-id)
(impl/del-objects-in-bulk ids))
(doseq [id ids]
(l/dbg :hint "gc-deleted: permanently delete storage object" :backend backend-id :id id))
total))
(catch Throwable cause
(l/err :hint "gc-deleted: unexpected error on bulk deletion"
:ids (vec ids)
:cause cause)
0)))]
(fn [params]
(let [min-age (or (some-> params :min-age dt/duration) min-age)]
(loop [total 0
chunks (get-to-delete-chunks min-age)]
(if-let [[backend-id ids] (first chunks)]
(let [deleted (delete-in-bulk! backend-id ids)]
(recur (+ total deleted)
(rest chunks)))
(do
(l/inf :hint "gc-deleted: task finished"
:min-age (dt/format-duration min-age)
:total total)
{:deleted total})))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Garbage Collection: Analyze touched objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This task is part of the garbage collection process of storage
;; objects and is responsible on analyzing the touched objects and
;; mark them for deletion if corresponds.
;;
;; For example: when file_media_object is deleted, the depending
;; storage_object are marked as touched. This means that some files
;; that depend on a concrete storage_object are no longer exists and
;; maybe this storage_object is no longer necessary and can be
;; eligible for elimination. This task periodically analyzes touched
;; objects and mark them as freeze (means that has other references
;; and the object is still valid) or deleted (no more references to
;; this object so is ready to be deleted).
(declare sql:retrieve-file-media-object-nrefs)
(declare sql:retrieve-file-object-thumbnail-nrefs)
(declare sql:retrieve-profile-nrefs)
(declare sql:retrieve-team-font-variant-nrefs)
(declare sql:retrieve-touched-objects-chunk)
(defmethod ig/pre-init-spec ::gc-touched-task [_]
(s/keys :req [::db/pool]))
(defmethod ig/init-key ::gc-touched-task
[_ {:keys [::db/pool]}]
(letfn [(get-team-font-variant-nrefs [conn id]
(-> (db/exec-one! conn [sql:retrieve-team-font-variant-nrefs id id id id]) :nrefs))
(get-file-media-object-nrefs [conn id]
(-> (db/exec-one! conn [sql:retrieve-file-media-object-nrefs id id]) :nrefs))
(get-profile-nrefs [conn id]
(-> (db/exec-one! conn [sql:retrieve-profile-nrefs id id]) :nrefs))
(get-file-object-thumbnails [conn id]
(-> (db/exec-one! conn [sql:retrieve-file-object-thumbnail-nrefs id]) :nrefs))
(mark-freeze-in-bulk [conn ids]
(db/exec-one! conn ["update storage_object set touched_at=null where id = ANY(?)"
(db/create-array conn "uuid" ids)]))
(mark-delete-in-bulk [conn ids]
(db/exec-one! conn ["update storage_object set deleted_at=now(), touched_at=null where id = ANY(?)"
(db/create-array conn "uuid" ids)]))
;; NOTE: A getter that retrieves the key witch will be used
;; for group ids; previously we have no value, then we
;; introduced the `:reference` prop, and then it is renamed
;; to `:bucket` and now is string instead. This is
;; implemented in this way for backward comaptibilty.
;; NOTE: we use the "file-media-object" as default value for
;; backward compatibility because when we deploy it we can
;; have old backend instances running in the same time as
;; the new one and we can still have storage-objects created
;; without bucket value. And we know that if it does not
;; have value, it means :file-media-object.
(get-bucket [{:keys [metadata]}]
(or (some-> metadata :bucket)
(some-> metadata :reference d/name)
"file-media-object"))
(retrieve-touched-chunk [conn cursor]
(let [rows (->> (db/exec! conn [sql:retrieve-touched-objects-chunk cursor])
(mapv #(d/update-when % :metadata db/decode-transit-pgobject)))]
(when (seq rows)
[(-> rows peek :created-at)
(d/group-by get-bucket :id #{} rows)])))
(retrieve-touched [conn]
(d/iteration (partial retrieve-touched-chunk conn)
:initk (dt/now)
:vf second
:kf first))
(process-objects! [conn get-fn ids bucket]
(loop [to-freeze #{}
to-delete #{}
ids (seq ids)]
(if-let [id (first ids)]
(let [nrefs (get-fn conn id)]
(if (pos? nrefs)
(do
(l/debug :hint "gc-touched: processing storage object"
:id id :status "freeze"
:bucket bucket :refs nrefs)
(recur (conj to-freeze id) to-delete (rest ids)))
(do
(l/debug :hint "gc-touched: processing storage object"
:id id :status "delete"
:bucket bucket :refs nrefs)
(recur to-freeze (conj to-delete id) (rest ids)))))
(do
(some->> (seq to-freeze) (mark-freeze-in-bulk conn))
(some->> (seq to-delete) (mark-delete-in-bulk conn))
[(count to-freeze) (count to-delete)]))))]
(fn [_]
(db/with-atomic [conn pool]
(loop [to-freeze 0
to-delete 0
groups (retrieve-touched conn)]
(if-let [[bucket ids] (first groups)]
(let [[f d] (case bucket
"file-media-object" (process-objects! conn get-file-media-object-nrefs ids bucket)
"team-font-variant" (process-objects! conn get-team-font-variant-nrefs ids bucket)
"file-object-thumbnail" (process-objects! conn get-file-object-thumbnails ids bucket)
"profile" (process-objects! conn get-profile-nrefs ids bucket)
(ex/raise :type :internal
:code :unexpected-unknown-reference
:hint (dm/fmt "unknown reference %" bucket)))]
(recur (+ to-freeze (long f))
(+ to-delete (long d))
(rest groups)))
(do
(l/info :hint "gc-touched: task finished" :to-freeze to-freeze :to-delete to-delete)
{:freeze to-freeze :delete to-delete})))))))
(def sql:retrieve-touched-objects-chunk
"SELECT so.*
FROM storage_object AS so
WHERE so.touched_at IS NOT NULL
AND so.created_at < ?
ORDER by so.created_at DESC
LIMIT 500;")
(def sql:retrieve-file-media-object-nrefs
"select ((select count(*) from file_media_object where media_id = ?) +
(select count(*) from file_media_object where thumbnail_id = ?)) as nrefs")
(def sql:retrieve-file-object-thumbnail-nrefs
"select (select count(*) from file_tagged_object_thumbnail where media_id = ?) as nrefs")
(def sql:retrieve-team-font-variant-nrefs
"select ((select count(*) from team_font_variant where woff1_file_id = ?) +
(select count(*) from team_font_variant where woff2_file_id = ?) +
(select count(*) from team_font_variant where otf_file_id = ?) +
(select count(*) from team_font_variant where ttf_file_id = ?)) as nrefs")
(def sql:retrieve-profile-nrefs
"select ((select count(*) from profile where photo_id = ?) +
(select count(*) from team where photo_id = ?)) as nrefs")

128
backend/src/app/storage/gc_deleted.clj Normal file
View file

@ -0,0 +1,128 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.storage.gc-deleted
"A task responsible to permanently delete already marked as deleted
storage files. The storage objects are practically never marked to
be deleted directly by the api call.
The touched-gc is responsible of collecting the usage of the object
and mark it as deleted. Only the TMP files are are created with
expiration date in future."
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.db :as db]
[app.storage :as-alias sto]
[app.storage.impl :as impl]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(def ^:private sql:lock-sobjects
"SELECT id FROM storage_object
WHERE id = ANY(?::uuid[])
FOR UPDATE
SKIP LOCKED")
(defn- lock-ids
"Perform a select before delete for proper object locking and
prevent concurrent operations and we proceed only with successfully
locked objects."
[conn ids]
(let [ids (db/create-array conn "uuid" ids)]
(->> (db/exec! conn [sql:lock-sobjects ids])
(into #{} (map :id))
(not-empty))))
(def ^:private sql:delete-sobjects
"DELETE FROM storage_object
WHERE id = ANY(?::uuid[])")
(defn- delete-sobjects!
[conn ids]
(let [ids (db/create-array conn "uuid" ids)]
(-> (db/exec-one! conn [sql:delete-sobjects ids])
(db/get-update-count))))
(defn- delete-in-bulk!
[cfg backend-id ids]
;; We run the deletion on a separate transaction. This is
;; because if some exception is raised inside procesing
;; one chunk, it does not affects the rest of the chunks.
(try
(db/tx-run! cfg
(fn [{:keys [::db/conn ::sto/storage]}]
(when-let [ids (lock-ids conn ids)]
(let [total (delete-sobjects! conn ids)]
(-> (impl/resolve-backend storage backend-id)
(impl/del-objects-in-bulk ids))
(doseq [id ids]
(l/dbg :hint "permanently delete storage object"
:id (str id)
:backend (name backend-id)))
total))))
(catch Throwable cause
(l/err :hint "unexpected error on bulk deletion"
:ids ids
:cause cause))))
(defn- group-by-backend
[items]
(d/group-by (comp keyword :backend) :id #{} items))
(def ^:private sql:get-deleted-sobjects
"SELECT s.* FROM storage_object AS s
WHERE s.deleted_at IS NOT NULL
AND s.deleted_at < now() - ?::interval
ORDER BY s.deleted_at ASC")
(defn- get-buckets
[conn min-age]
(let [age (db/interval min-age)]
(sequence
(comp (partition-all 25)
(mapcat group-by-backend))
(db/cursor conn [sql:get-deleted-sobjects age]))))
(defn- clean-deleted!
[{:keys [::db/conn ::min-age] :as cfg}]
(reduce (fn [total [backend-id ids]]
(let [deleted (delete-in-bulk! cfg backend-id ids)]
(+ total (or deleted 0))))
0
(get-buckets conn min-age)))
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::sto/storage ::db/pool]))
(defmethod ig/prep-key ::handler
[_ cfg]
(assoc cfg ::min-age (dt/duration {:hours 2})))
(defmethod ig/init-key ::handler
[_ {:keys [::min-age] :as cfg}]
(fn [params]
(let [min-age (dt/duration (or (:min-age params) min-age))]
(db/tx-run! cfg (fn [cfg]
(let [cfg (assoc cfg ::min-age min-age)
total (clean-deleted! cfg)]
(l/inf :hint "task finished"
:min-age (dt/format-duration min-age)
:total total)
{:deleted total}))))))

208
backend/src/app/storage/gc_touched.clj Normal file
View file

@ -0,0 +1,208 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.storage.gc-touched
"This task is part of the garbage collection process of storage
objects and is responsible on analyzing the touched objects and mark
them for deletion if corresponds.
For example: when file_media_object is deleted, the depending
storage_object are marked as touched. This means that some files
that depend on a concrete storage_object are no longer exists and
maybe this storage_object is no longer necessary and can be eligible
for elimination. This task periodically analyzes touched objects and
mark them as freeze (means that has other references and the object
is still valid) or deleted (no more references to this object so is
ready to be deleted)."
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.db :as db]
[app.storage :as-alias sto]
[app.storage.impl :as impl]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(def ^:private sql:get-team-font-variant-nrefs
"SELECT ((SELECT count(*) FROM team_font_variant WHERE woff1_file_id = ?) +
(SELECT count(*) FROM team_font_variant WHERE woff2_file_id = ?) +
(SELECT count(*) FROM team_font_variant WHERE otf_file_id = ?) +
(SELECT count(*) FROM team_font_variant WHERE ttf_file_id = ?)) AS nrefs")
(defn- get-team-font-variant-nrefs
[conn id]
(-> (db/exec-one! conn [sql:get-team-font-variant-nrefs id id id id])
(get :nrefs)))
(def ^:private
sql:get-file-media-object-nrefs
"SELECT ((SELECT count(*) FROM file_media_object WHERE media_id = ?) +
(SELECT count(*) FROM file_media_object WHERE thumbnail_id = ?)) AS nrefs")
(defn- get-file-media-object-nrefs
[conn id]
(-> (db/exec-one! conn [sql:get-file-media-object-nrefs id id])
(get :nrefs)))
(def ^:private sql:get-profile-nrefs
"SELECT ((SELECT count(*) FROM profile WHERE photo_id = ?) +
(SELECT count(*) FROM team WHERE photo_id = ?)) AS nrefs")
(defn- get-profile-nrefs
[conn id]
(-> (db/exec-one! conn [sql:get-profile-nrefs id id])
(get :nrefs)))
(def ^:private
sql:get-file-object-thumbnail-nrefs
"SELECT (SELECT count(*) FROM file_tagged_object_thumbnail WHERE media_id = ?) AS nrefs")
(defn- get-file-object-thumbnails
[conn id]
(-> (db/exec-one! conn [sql:get-file-object-thumbnail-nrefs id])
(get :nrefs)))
(def ^:private
sql:get-file-thumbnail-nrefs
"SELECT (SELECT count(*) FROM file_thumbnail WHERE media_id = ?) AS nrefs")
(defn- get-file-thumbnails
[conn id]
(-> (db/exec-one! conn [sql:get-file-thumbnail-nrefs id])
(get :nrefs)))
(def ^:private sql:mark-freeze-in-bulk
"UPDATE storage_object
SET touched_at = NULL
WHERE id = ANY(?::uuid[])")
(defn- mark-freeze-in-bulk!
[conn ids]
(let [ids (db/create-array conn "uuid" ids)]
(db/exec-one! conn [sql:mark-freeze-in-bulk ids])))
(def ^:private sql:mark-delete-in-bulk
"UPDATE storage_object
SET deleted_at = now(),
touched_at = NULL
WHERE id = ANY(?::uuid[])")
(defn- mark-delete-in-bulk!
[conn ids]
(let [ids (db/create-array conn "uuid" ids)]
(db/exec-one! conn [sql:mark-delete-in-bulk ids])))
;; NOTE: A getter that retrieves the key which will be used for group
;; ids; previously we have no value, then we introduced the
;; `:reference` prop, and then it is renamed to `:bucket` and now is
;; string instead. This is implemented in this way for backward
;; comaptibilty.
;; NOTE: we use the "file-media-object" as default value for
;; backward compatibility because when we deploy it we can
;; have old backend instances running in the same time as
;; the new one and we can still have storage-objects created
;; without bucket value. And we know that if it does not
;; have value, it means :file-media-object.
(defn- lookup-bucket
[{:keys [metadata]}]
(or (some-> metadata :bucket)
(some-> metadata :reference d/name)
"file-media-object"))
(defn- process-objects!
[conn get-fn ids bucket]
(loop [to-freeze #{}
to-delete #{}
ids (seq ids)]
(if-let [id (first ids)]
(let [nrefs (get-fn conn id)]
(if (pos? nrefs)
(do
(l/debug :hint "processing object"
:id (str id)
:status "freeze"
:bucket bucket :refs nrefs)
(recur (conj to-freeze id) to-delete (rest ids)))
(do
(l/debug :hint "processing object"
:id (str id)
:status "delete"
:bucket bucket :refs nrefs)
(recur to-freeze (conj to-delete id) (rest ids)))))
(do
(some->> (seq to-freeze) (mark-freeze-in-bulk! conn))
(some->> (seq to-delete) (mark-delete-in-bulk! conn))
[(count to-freeze) (count to-delete)]))))
(defn- process-bucket!
[conn bucket ids]
(case bucket
"file-media-object" (process-objects! conn get-file-media-object-nrefs ids bucket)
"team-font-variant" (process-objects! conn get-team-font-variant-nrefs ids bucket)
"file-object-thumbnail" (process-objects! conn get-file-object-thumbnails ids bucket)
"file-thumbnail" (process-objects! conn get-file-thumbnails ids bucket)
"profile" (process-objects! conn get-profile-nrefs ids bucket)
(ex/raise :type :internal
:code :unexpected-unknown-reference
:hint (dm/fmt "unknown reference %" bucket))))
(def ^:private
sql:get-touched-storage-objects
"SELECT so.*
FROM storage_object AS so
WHERE so.touched_at IS NOT NULL
ORDER BY touched_at ASC
FOR UPDATE
SKIP LOCKED")
(defn- group-by-bucket
[row]
(d/group-by lookup-bucket :id #{} row))
(defn- get-buckets
[conn]
(sequence
(comp (map impl/decode-row)
(partition-all 25)
(mapcat group-by-bucket))
(db/cursor conn sql:get-touched-storage-objects)))
(defn- process-touched!
[{:keys [::db/conn]}]
(loop [buckets (get-buckets conn)
freezed 0
deleted 0]
(if-let [[bucket ids] (first buckets)]
(let [[nfo ndo] (process-bucket! conn bucket ids)]
(recur (rest buckets)
(+ freezed nfo)
(+ deleted ndo)))
(do
(l/inf :hint "task finished"
:to-freeze freezed
:to-delete deleted)
{:freeze freezed :delete deleted}))))
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::db/pool]))
(defmethod ig/init-key ::handler
[_ cfg]
(fn [_]
(db/tx-run! cfg process-touched!)))

9
backend/src/app/storage/impl.clj
View file

@ -9,7 +9,7 @@
(:require
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.db :as-alias db]
[app.db :as db]
[app.storage :as-alias sto]
[buddy.core.codecs :as bc]
[buddy.core.hash :as bh]
@ -22,6 +22,13 @@
java.nio.file.Path
java.util.UUID))
(defn decode-row
"Decode the storage-object row fields"
[{:keys [metadata] :as row}]
(cond-> row
(some? metadata)
(assoc :metadata (db/decode-transit-pgobject metadata))))
;; --- API Definition
(defmulti put-object (fn [cfg _ _] (::sto/type cfg)))

317
backend/src/app/tasks/file_gc.clj
View file

@ -10,7 +10,6 @@
file is eligible to be garbage collected after some period of
inactivity (the default threshold is 72h)."
(:require
[app.common.data :as d]
[app.common.files.migrations :as pmg]
[app.common.logging :as l]
[app.common.thumbnails :as thc]
@ -30,7 +29,7 @@
[integrant.core :as ig]))
(declare ^:private get-candidates)
(declare ^:private process-file)
(declare ^:private clean-file!)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HANDLER
@ -44,67 +43,61 @@
(assoc cfg ::min-age cf/deletion-delay))
(defmethod ig/init-key ::handler
[_ {:keys [::db/pool] :as cfg}]
[_ cfg]
(fn [{:keys [file-id] :as params}]
(db/tx-run! cfg
(fn [{:keys [::db/conn] :as cfg}]
(let [min-age (dt/duration (or (:min-age params) (::min-age cfg)))
cfg (-> cfg
(update ::sto/storage media/configure-assets-storage conn)
(assoc ::file-id file-id)
(assoc ::min-age min-age))
(db/with-atomic [conn pool]
(let [min-age (dt/duration (or (:min-age params) (::min-age cfg)))
cfg (-> cfg
(update ::sto/storage media/configure-assets-storage conn)
(assoc ::db/conn conn)
(assoc ::file-id file-id)
(assoc ::min-age min-age))
total (reduce (fn [total file]
(clean-file! cfg file)
(inc total))
0
(get-candidates cfg))]
total (reduce (fn [total file]
(process-file cfg file)
(inc total))
0
(get-candidates cfg))]
(l/inf :hint "task finished"
:min-age (dt/format-duration min-age)
:processed total)
(l/info :hint "task finished" :min-age (dt/format-duration min-age) :processed total)
;; Allow optional rollback passed by params
(when (:rollback? params)
(db/rollback! conn))
;; Allow optional rollback passed by params
(when (:rollback? params)
(db/rollback! conn))
{:processed total}))))
{:processed total})))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; IMPL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:private
sql:get-candidates-chunk
"select f.id,
sql:get-candidates
"SELECT f.id,
f.data,
f.revn,
f.features,
f.modified_at
from file as f
where f.has_media_trimmed is false
and f.modified_at < now() - ?::interval
and f.modified_at < ?
order by f.modified_at desc
limit 1
for update skip locked")
FROM file AS f
WHERE f.has_media_trimmed IS false
AND f.modified_at < now() - ?::interval
ORDER BY f.modified_at DESC
FOR UPDATE
SKIP LOCKED")
(defn- get-candidates
[{:keys [::db/conn ::min-age ::file-id]}]
(if (uuid? file-id)
(do
(l/warn :hint "explicit file id passed on params" :file-id file-id)
(l/warn :hint "explicit file id passed on params" :file-id (str file-id))
(->> (db/query conn :file {:id file-id})
(map #(update % :features db/decode-pgarray #{}))))
(let [interval (db/interval min-age)
get-chunk (fn [cursor]
(let [rows (db/exec! conn [sql:get-candidates-chunk interval cursor])]
[(some->> rows peek :modified-at)
(map #(update % :features db/decode-pgarray #{}) rows)]))]
(d/iteration get-chunk
:vf second
:kf first
:initk (dt/now)))))
(let [min-age (db/interval min-age)]
(->> (db/cursor conn [sql:get-candidates min-age] {:chunk-size 1})
(map #(update % :features db/decode-pgarray #{}))))))
(defn collect-used-media
"Given a fdata (file data), returns all media references."
@ -134,101 +127,93 @@
(into xform pages)
(into (keys (:media data))))))
(def ^:private sql:mark-file-media-object-deleted
"UPDATE file_media_object
SET deleted_at = now()
WHERE file_id = ? AND id != ALL(?::uuid[])
RETURNING id")
(defn- clean-file-media!
"Performs the garbage collection of file media objects."
[conn file-id data]
(let [used (collect-used-media data)
unused (->> (db/query conn :file-media-object {:file-id file-id})
(remove #(contains? used (:id %))))]
ids (db/create-array conn "uuid" used)
unused (->> (db/exec! conn [sql:mark-file-media-object-deleted file-id ids])
(into #{} (map :id)))]
(doseq [mobj unused]
(l/dbg :hint "delete file media object"
:id (:id mobj)
:media-id (:media-id mobj)
:thumbnail-id (:thumbnail-id mobj))
(doseq [id unused]
(l/trc :hint "mark deleted"
:rel "file-media-object"
:id (str id)
:file-id (str file-id)))
;; NOTE: deleting the file-media-object in the database
;; automatically marks as touched the referenced storage
;; objects. The touch mechanism is needed because many files can
;; point to the same storage objects and we can't just delete
;; them.
(db/delete! conn :file-media-object {:id (:id mobj)}))))
(count unused)))
(def ^:private sql:mark-file-object-thumbnails-deleted
"UPDATE file_tagged_object_thumbnail
SET deleted_at = now()
WHERE file_id = ? AND object_id != ALL(?::text[])
RETURNING object_id")
(defn- clean-file-object-thumbnails!
[{:keys [::db/conn ::sto/storage]} file-id data]
(let [stored (->> (db/query conn :file-tagged-object-thumbnail
{:file-id file-id}
{:columns [:object-id]})
(into #{} (map :object-id)))
[{:keys [::db/conn]} file-id data]
(let [using (->> (vals (:pages-index data))
(into #{} (comp
(mapcat (fn [{:keys [id objects]}]
(->> (ctt/get-frames objects)
(map #(assoc % :page-id id)))))
(mapcat (fn [{:keys [id page-id]}]
(list
(thc/fmt-object-id file-id page-id id "frame")
(thc/fmt-object-id file-id page-id id "component")))))))
using (into #{}
(comp
(mapcat (fn [{:keys [id objects]}]
(->> (ctt/get-frames objects)
(map #(assoc % :page-id id)))))
(mapcat (fn [{:keys [id page-id]}]
(list
(thc/fmt-object-id file-id page-id id "frame")
(thc/fmt-object-id file-id page-id id "component")))))
ids (db/create-array conn "text" using)
unused (->> (db/exec! conn [sql:mark-file-object-thumbnails-deleted file-id ids])
(into #{} (map :object-id)))]
(vals (:pages-index data)))
(doseq [object-id unused]
(l/trc :hint "mark deleted"
:rel "file-tagged-object-thumbnail"
:object-id object-id
:file-id (str file-id)))
unused (set/difference stored using)]
(count unused)))
(when (seq unused)
(let [sql (str "delete from file_tagged_object_thumbnail "
" where file_id=? and object_id=ANY(?)"
" returning media_id")
res (db/exec! conn [sql file-id (db/create-array conn "text" unused)])]
(l/dbg :hint "delete file object thumbnails"
:file-id (str file-id)
:total (count res))
(doseq [media-id (into #{} (keep :media-id) res)]
;; Mark as deleted the storage object related with the
;; photo-id field.
(l/trc :hint "touch file object thumbnail storage object" :id (str media-id))
(sto/touch-object! storage media-id))))))
(def ^:private sql:mark-file-thumbnails-deleted
"UPDATE file_thumbnail
SET deleted_at = now()
WHERE file_id = ? AND revn < ?
RETURNING revn")
(defn- clean-file-thumbnails!
[{:keys [::db/conn ::sto/storage]} file-id revn]
(let [sql (str "delete from file_thumbnail "
" where file_id=? and revn < ? "
" returning media_id")
res (db/exec! conn [sql file-id revn])]
[{:keys [::db/conn]} file-id revn]
(let [unused (->> (db/exec! conn [sql:mark-file-thumbnails-deleted file-id revn])
(into #{} (map :revn)))]
(when (seq res)
(l/dbg :hint "delete file thumbnails"
:file-id (str file-id)
:total (count res))
(doseq [revn unused]
(l/trc :hint "mark deleted"
:rel "file-thumbnail"
:revn revn
:file-id (str file-id)))
(doseq [media-id (into #{} (keep :media-id) res)]
;; Mark as deleted the storage object related with the
;; media-id field.
(l/trc :hint "delete file thumbnail storage object" :id (str media-id))
(sto/del-object! storage media-id)))))
(count unused)))
(def ^:private
sql:get-files-for-library
"select f.data, f.modified_at
from file as f
left join file_library_rel as fl on (fl.file_id = f.id)
where fl.library_file_id = ?
and f.modified_at < ?
and f.deleted_at is null
order by f.modified_at desc
limit 1")
(def ^:private sql:get-files-for-library
"SELECT f.id, f.data, f.modified_at
FROM file AS f
LEFT JOIN file_library_rel AS fl ON (fl.file_id = f.id)
WHERE fl.library_file_id = ?
AND f.deleted_at IS null
ORDER BY f.modified_at ASC")
(defn- clean-deleted-components!
"Performs the garbage collection of unreferenced deleted components."
[conn file-id data]
(letfn [(get-files-chunk [cursor]
(let [rows (db/exec! conn [sql:get-files-for-library file-id cursor])]
[(some-> rows peek :modified-at)
(map (comp blob/decode :data) rows)]))
(get-used-components [fdata components]
[{:keys [::db/conn] :as cfg} file-id data]
(letfn [(get-used-components [fdata components]
;; Find which of the components are used in the file.
(into #{}
(filter #(ctf/used-in? fdata file-id % :component))
@ -246,69 +231,91 @@
files-data))]
(let [deleted (into #{} (ctkl/deleted-components-seq data))
unused (->> (d/iteration get-files-chunk :vf second :kf first :initk (dt/now))
unused (->> (db/cursor conn [sql:get-files-for-library file-id] {:chunk-size 1})
(map (fn [{:keys [id data] :as file}]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)]
(-> (blob/decode data)
(feat.fdata/process-pointers deref)))))
(cons data)
(get-unused-components deleted)
(mapv :id))]
(when (seq unused)
(l/dbg :hint "clean deleted components" :total (count unused))
(doseq [id unused]
(l/trc :hint "delete component" :component-id (str id) :file-id (str file-id)))
(let [data (reduce ctkl/delete-component data unused)]
(db/update! conn :file
{:data (blob/encode data)}
{:id file-id}))))))
(when-let [data (some->> (seq unused)
(reduce ctkl/delete-component data)
(blob/encode))]
(db/update! conn :file
{:data data}
{:id file-id}
{::db/return-keys? false}))
(count unused))))
(def ^:private sql:get-changes
"SELECT id, data FROM file_change
WHERE file_id = ? AND data IS NOT NULL
ORDER BY created_at ASC")
(def ^:private sql:mark-deleted-data-fragments
"UPDATE file_data_fragment
SET deleted_at = now()
WHERE file_id = ?
AND id != ALL(?::uuid[])
RETURNING id")
(defn- clean-data-fragments!
[conn file-id data]
(letfn [(get-pointers-chunk [cursor]
(let [sql (str "select id, data, created_at "
" from file_change "
" where file_id = ? "
" and data is not null "
" and created_at < ? "
" order by created_at desc "
" limit 1;")
rows (db/exec! conn [sql file-id cursor])]
[(some-> rows peek :created-at)
(mapcat (comp feat.fdata/get-used-pointer-ids blob/decode :data) rows)]))]
(let [used (->> (db/cursor conn [sql:get-changes file-id])
(into (feat.fdata/get-used-pointer-ids data)
(comp (map :data)
(map blob/decode)
(mapcat feat.fdata/get-used-pointer-ids))))
(let [used (into (feat.fdata/get-used-pointer-ids data)
(d/iteration get-pointers-chunk
:vf second
:kf first
:initk (dt/now)))
unused (let [ids (db/create-array conn "uuid" used)]
(->> (db/exec! conn [sql:mark-deleted-data-fragments file-id ids])
(into #{} (map :id))))]
sql (str "select id from file_data_fragment "
" where file_id = ? AND id != ALL(?::uuid[])")
used (db/create-array conn "uuid" used)
rows (db/exec! conn [sql file-id used])]
(doseq [id unused]
(l/trc :hint "mark deleted"
:rel "file-data-fragment"
:id (str id)
:file-id (str file-id)))
(doseq [fragment-id (map :id rows)]
(l/trc :hint "remove unused file data fragment" :id (str fragment-id))
(db/delete! conn :file-data-fragment {:id fragment-id :file-id file-id})))))
(count unused)))
(defn- process-file
[{:keys [::db/conn] :as cfg} {:keys [id data revn modified-at features] :as file}]
(l/dbg :hint "processing file" :file-id (str id) :modified-at modified-at)
(defn- clean-file!
[{:keys [::db/conn] :as cfg} {:keys [id data revn modified-at] :as file}]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg id)
pmap/*tracked* (pmap/create-tracked)]
(let [data (-> (blob/decode data)
(assoc :id id)
(pmg/migrate-data))]
(pmg/migrate-data))
(clean-file-media! conn id data)
(clean-file-object-thumbnails! cfg id data)
(clean-file-thumbnails! cfg id revn)
(clean-deleted-components! conn id data)
nfm (clean-file-media! conn id data)
nfot (clean-file-object-thumbnails! cfg id data)
nft (clean-file-thumbnails! cfg id revn)
nc (clean-deleted-components! cfg id data)
ndf (clean-data-fragments! conn id data)]
(when (contains? features "fdata/pointer-map")
(clean-data-fragments! conn id data))
(l/dbg :hint "file clened"
:file-id (str id)
:modified-at (dt/format-instant modified-at)
:media-objects nfm
:thumbnails nft
:object-thumbnails nfot
:components nc
:data-fragments ndf)
;; Mark file as trimmed
(db/update! conn :file
{:has-media-trimmed true}
{:id id})
{:id id}
{::db/return-keys? false})
(feat.fdata/persist-pointers! cfg id))))

465
backend/src/app/tasks/objects_gc.clj
View file

@ -8,7 +8,6 @@
"A maintenance task that performs a general purpose garbage collection
of deleted or unreachable objects."
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.config :as cf]
[app.db :as db]
@ -18,12 +17,15 @@
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(declare ^:private delete-profiles!)
(declare ^:private delete-teams!)
(declare ^:private delete-fonts!)
(declare ^:private delete-projects!)
(declare ^:private delete-file-data-fragments!)
(declare ^:private delete-file-media-objects!)
(declare ^:private delete-file-object-thumbnails!)
(declare ^:private delete-file-thumbnails!)
(declare ^:private delete-files!)
(declare ^:private delete-orphan-teams!)
(declare ^:private delete-fonts!)
(declare ^:private delete-profiles!)
(declare ^:private delete-projects!)
(declare ^:private delete-teams!)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::db/pool ::sto/storage]))
@ -33,211 +35,320 @@
(assoc cfg ::min-age cf/deletion-delay))
(defmethod ig/init-key ::handler
[_ {:keys [::db/pool ::sto/storage] :as cfg}]
[_ cfg]
(fn [params]
(db/with-atomic [conn pool]
(let [min-age (or (:min-age params) (::min-age cfg))
_ (l/info :hint "gc started"
:min-age (dt/format-duration min-age)
:rollback? (boolean (:rollback? params)))
(db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
;; Disable deletion protection for the current transaction
(db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
(db/exec-one! conn ["SET CONSTRAINTS ALL DEFERRED"])
storage (media/configure-assets-storage storage conn)
cfg (-> cfg
(assoc ::min-age (db/interval min-age))
(assoc ::conn conn)
(assoc ::storage storage))
(let [min-age (dt/duration (or (:min-age params) (::min-age cfg)))
cfg (-> cfg
(assoc ::min-age (db/interval min-age))
(update ::sto/storage media/configure-assets-storage conn))
htotal (+ (delete-profiles! cfg)
(delete-teams! cfg)
(delete-projects! cfg)
(delete-files! cfg)
(delete-fonts! cfg))
stotal (delete-orphan-teams! cfg)]
total (reduce + 0
[(delete-profiles! cfg)
(delete-teams! cfg)
(delete-fonts! cfg)
(delete-projects! cfg)
(delete-files! cfg)
(delete-file-thumbnails! cfg)
(delete-file-object-thumbnails! cfg)
(delete-file-data-fragments! cfg)
(delete-file-media-objects! cfg)])]
(l/info :hint "gc finished"
:deleted htotal
:orphans stotal
:rollback? (boolean (:rollback? params)))
(l/info :hint "task finished"
:deleted total
:rollback? (boolean (:rollback? params)))
(when (:rollback? params)
(db/rollback! conn))
(when (:rollback? params)
(db/rollback! conn))
{:processed (+ stotal htotal)
:orphans stotal}))))
{:processed total})))))
(def ^:private sql:get-profiles-chunk
"select id, photo_id, created_at from profile
where deleted_at is not null
and deleted_at < now() - ?::interval
and created_at < ?
order by created_at desc
limit 10
for update skip locked")
(def ^:private sql:get-profiles
"SELECT id, photo_id FROM profile
WHERE deleted_at IS NOT NULL
AND deleted_at < now() - ?::interval
ORDER BY deleted_at ASC
FOR UPDATE
SKIP LOCKED")
(defn- delete-profiles!
[{:keys [::conn ::min-age ::storage] :as cfg}]
(letfn [(get-chunk [cursor]
(let [rows (db/exec! conn [sql:get-profiles-chunk min-age cursor])]
[(some->> rows peek :created-at) rows]))
[{:keys [::db/conn ::min-age ::sto/storage] :as cfg}]
(->> (db/cursor conn [sql:get-profiles min-age])
(reduce (fn [total {:keys [id photo-id]}]
(l/trc :hint "permanently delete" :rel "profile" :id (str id))
(process-profile [total {:keys [id photo-id]}]
(l/debug :hint "permanently delete profile" :id (str id))
;; Mark as deleted the storage object
(some->> photo-id (sto/touch-object! storage))
;; Mark as deleted the storage object related with the
;; photo-id field.
(some->> photo-id (sto/touch-object! storage))
;; And finally, permanently delete the profile. The
;; relevant objects will be deleted using DELETE
;; CASCADE database triggers. This may leave orphan
;; teams, but there is a special task for deleting
;; orphaned teams.
(db/delete! conn :profile
{:id id}
{::db/return-keys? false})
;; And finally, permanently delete the profile.
(db/delete! conn :profile {:id id})
(inc total))
0)))
(inc total))]
(->> (d/iteration get-chunk :vf second :kf first :initk (dt/now))
(reduce process-profile 0))))
(def ^:private sql:get-teams-chunk
"select id, photo_id, created_at from team
where deleted_at is not null
and deleted_at < now() - ?::interval
and created_at < ?
order by created_at desc
limit 10
for update skip locked")
(def ^:private sql:get-teams
"SELECT deleted_at, id, photo_id FROM team
WHERE deleted_at IS NOT NULL
AND deleted_at < now() - ?::interval
ORDER BY deleted_at ASC
FOR UPDATE
SKIP LOCKED")
(defn- delete-teams!
[{:keys [::conn ::min-age ::storage] :as cfg}]
(letfn [(get-chunk [cursor]
(let [rows (db/exec! conn [sql:get-teams-chunk min-age cursor])]
[(some->> rows peek :created-at) rows]))
[{:keys [::db/conn ::min-age ::sto/storage] :as cfg}]
(process-team [total {:keys [id photo-id]}]
(l/debug :hint "permanently delete team" :id (str id))
(->> (db/cursor conn [sql:get-teams min-age])
(reduce (fn [total {:keys [id photo-id deleted-at]}]
(l/trc :hint "permanently delete"
:rel "team"
:id (str id)
:deleted-at (dt/format-instant deleted-at))
;; Mark as deleted the storage object related with the
;; photo-id field.
(some->> photo-id (sto/touch-object! storage))
;; Mark as deleted the storage object
(some->> photo-id (sto/touch-object! storage))
;; And finally, permanently delete the team.
(db/delete! conn :team {:id id})
;; And finally, permanently delete the team.
(db/delete! conn :team
{:id id}
{::db/return-keys? false})
(inc total))]
;; Mark for deletion in cascade
(db/update! conn :team-font-variant
{:deleted-at deleted-at}
{:team-id id}
{::db/return-keys? false})
(->> (d/iteration get-chunk :vf second :kf first :initk (dt/now))
(reduce process-team 0))))
(db/update! conn :project
{:deleted-at deleted-at}
{:team-id id}
{::db/return-keys? false})
(def ^:private sql:get-orphan-teams-chunk
"select t.id, t.created_at
from team as t
left join team_profile_rel as tpr
on (t.id = tpr.team_id)
where tpr.profile_id is null
and t.created_at < ?
order by t.created_at desc
limit 10
for update of t skip locked;")
(inc total))
0)))
(defn- delete-orphan-teams!
"Find all orphan teams (with no members and mark them for
deletion (soft delete)."
[{:keys [::conn] :as cfg}]
(letfn [(get-chunk [cursor]
(let [rows (db/exec! conn [sql:get-orphan-teams-chunk cursor])]
[(some->> rows peek :created-at) rows]))
(process-team [total {:keys [id]}]
(let [result (db/update! conn :team
{:deleted-at (dt/now)}
{:id id :deleted-at nil}
{::db/return-keys? false})
count (db/get-update-count result)]
(when (pos? count)
(l/debug :hint "mark team for deletion" :id (str id)))
(+ total count)))]
(->> (d/iteration get-chunk :vf second :kf first :initk (dt/now))
(reduce process-team 0))))
(def ^:private sql:get-fonts-chunk
"select id, created_at, woff1_file_id, woff2_file_id, otf_file_id, ttf_file_id
from team_font_variant
where deleted_at is not null
and deleted_at < now() - ?::interval
and created_at < ?
order by created_at desc
limit 10
for update skip locked")
(def ^:private sql:get-fonts
"SELECT id, team_id, deleted_at, woff1_file_id, woff2_file_id, otf_file_id, ttf_file_id
FROM team_font_variant
WHERE deleted_at IS NOT NULL
AND deleted_at < now() - ?::interval
ORDER BY deleted_at ASC
FOR UPDATE
SKIP LOCKED")
(defn- delete-fonts!
[{:keys [::conn ::min-age ::storage] :as cfg}]
(letfn [(get-chunk [cursor]
(let [rows (db/exec! conn [sql:get-fonts-chunk min-age cursor])]
[(some->> rows peek :created-at) rows]))
[{:keys [::db/conn ::min-age ::sto/storage] :as cfg}]
(->> (db/cursor conn [sql:get-fonts min-age])
(reduce (fn [total {:keys [id team-id deleted-at] :as font}]
(l/trc :hint "permanently delete"
:rel "team-font-variant"
:id (str id)
:team-id (str team-id)
:deleted-at (dt/format-instant deleted-at))
(process-font [total {:keys [id] :as font}]
(l/debug :hint "permanently delete font variant" :id (str id))
;; Mark as deleted the all related storage objects
(some->> (:woff1-file-id font) (sto/touch-object! storage))
(some->> (:woff2-file-id font) (sto/touch-object! storage))
(some->> (:otf-file-id font) (sto/touch-object! storage))
(some->> (:ttf-file-id font) (sto/touch-object! storage))
;; Mark as deleted the all related storage objects
(some->> (:woff1-file-id font) (sto/touch-object! storage))
(some->> (:woff2-file-id font) (sto/touch-object! storage))
(some->> (:otf-file-id font) (sto/touch-object! storage))
(some->> (:ttf-file-id font) (sto/touch-object! storage))
;; And finally, permanently delete the team font variant
(db/delete! conn :team-font-variant
{:id id}
{::db/return-keys? false})
;; And finally, permanently delete the team font variant
(db/delete! conn :team-font-variant {:id id})
(inc total))
0)))
(inc total))]
(->> (d/iteration get-chunk :vf second :kf first :initk (dt/now))
(reduce process-font 0))))
(def ^:private sql:get-projects-chunk
"select id, created_at
from project
where deleted_at is not null
and deleted_at < now() - ?::interval
and created_at < ?
order by created_at desc
limit 10
for update skip locked")
(def ^:private sql:get-projects
"SELECT id, deleted_at, team_id
FROM project
WHERE deleted_at IS NOT NULL
AND deleted_at < now() - ?::interval
ORDER BY deleted_at ASC
FOR UPDATE
SKIP LOCKED")
(defn- delete-projects!
[{:keys [::conn ::min-age] :as cfg}]
(letfn [(get-chunk [cursor]
(let [rows (db/exec! conn [sql:get-projects-chunk min-age cursor])]
[(some->> rows peek :created-at) rows]))
[{:keys [::db/conn ::min-age] :as cfg}]
(->> (db/cursor conn [sql:get-projects min-age])
(reduce (fn [total {:keys [id team-id deleted-at]}]
(l/trc :hint "permanently delete"
:rel "project"
:id (str id)
:team-id (str team-id)
:deleted-at (dt/format-instant deleted-at))
;; And finally, permanently delete the project.
(db/delete! conn :project
{:id id}
{::db/return-keys? false})
(process-project [total {:keys [id]}]
(l/debug :hint "permanently delete project" :id (str id))
;; And finally, permanently delete the project.
(db/delete! conn :project {:id id})
;; Mark files to be deleted
(db/update! conn :file
{:deleted-at deleted-at}
{:project-id id}
{::db/return-keys? false})
(inc total))]
(inc total))
0)))
(->> (d/iteration get-chunk :vf second :kf first :initk (dt/now))
(reduce process-project 0))))
(def ^:private sql:get-files-chunk
"select id, created_at
from file
where deleted_at is not null
and deleted_at < now() - ?::interval
and created_at < ?
order by created_at desc
limit 10
for update skip locked")
(def ^:private sql:get-files
"SELECT id, deleted_at, project_id
FROM file
WHERE deleted_at IS NOT NULL
AND deleted_at < now() - ?::interval
ORDER BY deleted_at ASC
FOR UPDATE
SKIP LOCKED")
(defn- delete-files!
[{:keys [::conn ::min-age] :as cfg}]
(letfn [(get-chunk [cursor]
(let [rows (db/exec! conn [sql:get-files-chunk min-age cursor])]
[(some->> rows peek :created-at) rows]))
[{:keys [::db/conn ::min-age] :as cfg}]
(->> (db/cursor conn [sql:get-files min-age])
(reduce (fn [total {:keys [id deleted-at project-id]}]
(l/trc :hint "permanently delete"
:rel "file"
:id (str id)
:project-id (str project-id)
:deleted-at (dt/format-instant deleted-at))
(process-file [total {:keys [id]}]
(l/debug :hint "permanently delete file" :id (str id))
;; And finally, permanently delete the file.
(db/delete! conn :file {:id id})
(inc total))]
;; And finally, permanently delete the file.
(db/delete! conn :file
{:id id}
{::db/return-keys? false})
(->> (d/iteration get-chunk :vf second :kf first :initk (dt/now))
(reduce process-file 0))))
;; Mark file media objects to be deleted
(db/update! conn :file-media-object
{:deleted-at deleted-at}
{:file-id id}
{::db/return-keys? false})
;; Mark thumbnails to be deleted
(db/update! conn :file-thumbnail
{:deleted-at deleted-at}
{:file-id id}
{::db/return-keys? false})
(db/update! conn :file-tagged-object-thumbnail
{:deleted-at deleted-at}
{:file-id id}
{::db/return-keys? false})
(inc total))
0)))
(def ^:private sql:get-file-thumbnails
"SELECT file_id, revn, media_id, deleted_at
FROM file_thumbnail
WHERE deleted_at IS NOT NULL
AND deleted_at < now() - ?::interval
ORDER BY deleted_at ASC
FOR UPDATE
SKIP LOCKED")
(defn delete-file-thumbnails!
[{:keys [::db/conn ::min-age ::sto/storage] :as cfg}]
(->> (db/cursor conn [sql:get-file-thumbnails min-age])
(reduce (fn [total {:keys [file-id revn media-id deleted-at]}]
(l/trc :hint "permanently delete"
:rel "file-thumbnail"
:file-id (str file-id)
:revn revn
:deleted-at (dt/format-instant deleted-at))
;; Mark as deleted the storage object
(some->> media-id (sto/touch-object! storage))
;; And finally, permanently delete the object
(db/delete! conn :file-thumbnail {:file-id file-id :revn revn})
(inc total))
0)))
(def ^:private sql:get-file-object-thumbnails
"SELECT file_id, object_id, media_id, deleted_at
FROM file_tagged_object_thumbnail
WHERE deleted_at IS NOT NULL
AND deleted_at < now() - ?::interval
ORDER BY deleted_at ASC
FOR UPDATE
SKIP LOCKED")
(defn delete-file-object-thumbnails!
[{:keys [::db/conn ::min-age ::sto/storage] :as cfg}]
(->> (db/cursor conn [sql:get-file-object-thumbnails min-age])
(reduce (fn [total {:keys [file-id object-id media-id deleted-at]}]
(l/trc :hint "permanently delete"
:rel "file-tagged-object-thumbnail"
:file-id (str file-id)
:object-id object-id
:deleted-at (dt/format-instant deleted-at))
;; Mark as deleted the storage object
(some->> media-id (sto/touch-object! storage))
;; And finally, permanently delete the object
(db/delete! conn :file-tagged-object-thumbnail {:file-id file-id :object-id object-id})
(inc total))
0)))
(def ^:private sql:get-file-data-fragments
"SELECT file_id, id, deleted_at
FROM file_data_fragment
WHERE deleted_at IS NOT NULL
AND deleted_at < now() - ?::interval
ORDER BY deleted_at ASC
FOR UPDATE
SKIP LOCKED")
(defn- delete-file-data-fragments!
[{:keys [::db/conn ::min-age] :as cfg}]
(->> (db/cursor conn [sql:get-file-data-fragments min-age])
(reduce (fn [total {:keys [file-id id deleted-at]}]
(l/trc :hint "permanently delete"
:rel "file-data-fragment"
:id (str id)
:file-id (str file-id)
:deleted-at (dt/format-instant deleted-at))
(db/delete! conn :file-data-fragment {:file-id file-id :id id})
(inc total))
0)))
(def ^:private sql:get-file-media-objects
"SELECT id, file_id, media_id, thumbnail_id, deleted_at
FROM file_media_object
WHERE deleted_at IS NOT NULL
AND deleted_at < now() - ?::interval
ORDER BY deleted_at ASC
FOR UPDATE
SKIP LOCKED")
(defn- delete-file-media-objects!
[{:keys [::db/conn ::min-age ::sto/storage] :as cfg}]
(->> (db/cursor conn [sql:get-file-media-objects min-age])
(reduce (fn [total {:keys [id file-id deleted-at] :as fmo}]
(l/trc :hint "permanently delete"
:rel "file-media-object"
:id (str id)
:file-id (str file-id)
:deleted-at (dt/format-instant deleted-at))
;; Mark as deleted the all related storage objects
(some->> (:media-id fmo) (sto/touch-object! storage))
(some->> (:thumbnail-id fmo) (sto/touch-object! storage))
(db/delete! conn :file-media-object {:id id})
(inc total))
0)))

60
backend/src/app/tasks/orphan_teams_gc.clj Normal file
View file

@ -0,0 +1,60 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.tasks.orphan-teams-gc
"A maintenance task that performs orphan teams GC."
(:require
[app.common.logging :as l]
[app.db :as db]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(declare ^:private delete-orphan-teams!)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req [::db/pool]))
(defmethod ig/init-key ::handler
[_ cfg]
(fn [params]
(db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
(l/inf :hint "gc started" :rollback? (boolean (:rollback? params)))
(let [total (delete-orphan-teams! cfg)]
(l/inf :hint "task finished"
:teams total
:rollback? (boolean (:rollback? params)))
(when (:rollback? params)
(db/rollback! conn))
{:processed total})))))
(def ^:private sql:get-orphan-teams
"SELECT t.id
FROM team AS t
LEFT JOIN team_profile_rel AS tpr
ON (t.id = tpr.team_id)
WHERE tpr.profile_id IS NULL
AND t.deleted_at IS NULL
ORDER BY t.created_at ASC
FOR UPDATE OF t
SKIP LOCKED")
(defn- delete-orphan-teams!
"Find all orphan teams (with no members) and mark them for
deletion (soft delete)."
[{:keys [::db/conn] :as cfg}]
(->> (db/cursor conn sql:get-orphan-teams)
(map :id)
(reduce (fn [total team-id]
(l/trc :hint "mark orphan team for deletion" :id (str team-id))
(db/update! conn :team
{:deleted-at (dt/now)}
{:id team-id}
{::db/return-keys? false})
(inc total))
0)))

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

@ -175,12 +175,11 @@
" WHERE table_schema = 'public' "
" AND table_name != 'migrations';")]
(db/with-atomic [conn *pool*]
(db/exec-one! conn ["SET CONSTRAINTS ALL DEFERRED"])
(db/exec-one! conn ["SET LOCAL rules.deletion_protection TO off"])
(let [result (->> (db/exec! conn [sql])
(map :table-name)
(remove #(= "task" %)))
sql (str "TRUNCATE "
(apply str (interpose ", " result))
" CASCADE;")]
(remove #(= "task" %)))]
(doseq [table result]
(db/exec! conn [(str "delete from " table ";")]))))
@ -433,11 +432,11 @@
(us/pretty-explain data))
(= :params-validation (:code data))
(app.common.pprint/pprint
(println
(sm/humanize-explain (::sm/explain data)))
(= :data-validation (:code data))
(app.common.pprint/pprint
(println
(sm/humanize-explain (::sm/explain data)))
(= :service-error (:type data))
@ -512,6 +511,10 @@
[sql]
(db/exec! *pool* sql))
(defn db-exec-one!
[sql]
(db/exec-one! *pool* sql))
(defn db-delete!
[& params]
(apply db/delete! *pool* params))

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

@ -149,7 +149,7 @@
shape-id (uuid/random)]
;; Preventive file-gc
(let [res (th/run-task! "file-gc" {:min-age 0})]
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
;; Check the number of fragments before adding the page
@ -175,7 +175,7 @@
(t/is (= 2 (count rows))))
;; The file-gc should remove unused fragments
(let [res (th/run-task! "file-gc" {:min-age 0})]
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
@ -203,7 +203,7 @@
(t/is (= 3 (count rows))))
;; The file-gc should remove unused fragments
(let [res (th/run-task! "file-gc" {:min-age 0})]
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
;; Check the number of fragments; should be 3 because changes
@ -220,12 +220,23 @@
;; The file-gc should remove fragments related to changes
;; snapshots previously deleted.
(let [res (th/run-task! "file-gc" {:min-age 0})]
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
;; Check the number of fragments;
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(t/is (= 2 (count rows)))))))
;; (pp/pprint rows)
(t/is (= 3 (count rows)))
(t/is (= 2 (count (remove (comp some? :deleted-at) rows)))))
(let [res (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
(t/is (= 2 (count rows))))
)))
(t/deftest file-gc-task-with-thumbnails
(letfn [(add-file-media-object [& {:keys [profile-id file-id]}]
@ -301,17 +312,16 @@
;; freeze because of the deduplication (we have uploaded 2 times
;; the same files).
(let [task (:app.storage/gc-touched-task th/*system*)
res (task {:min-age (dt/duration 0)})]
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 2 (:freeze res)))
(t/is (= 0 (:delete res))))
;; run the file-gc task immediately without forced min-age
(let [res (th/run-task! "file-gc")]
(let [res (th/run-task! :file-gc)]
(t/is (= 0 (:processed res))))
;; run the task again
(let [res (th/run-task! "file-gc" {:min-age 0})]
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
;; retrieve file and check trimmed attribute
@ -319,8 +329,17 @@
(t/is (true? (:has-media-trimmed row))))
;; check file media objects
(let [rows (th/db-exec! ["select * from file_media_object where file_id = ?" (:id file)])]
(t/is (= 1 (count rows))))
(let [rows (th/db-query :file-media-object {:file-id (:id file)})]
(t/is (= 2 (count rows)))
(t/is (= 1 (count (remove (comp some? :deleted-at) rows)))))
(let [res (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 2 (:processed res))))
;; check file media objects
(let [rows (th/db-query :file-media-object {:file-id (:id file)})]
(t/is (= 1 (count rows)))
(t/is (= 1 (count (remove (comp some? :deleted-at) rows)))))
;; The underlying storage objects are still available.
(t/is (some? (sto/get-object storage (:media-id fmo2))))
@ -340,15 +359,16 @@
;; Now, we have deleted the usage of pointers to the
;; file-media-objects, if we paste file-gc, they should be marked
;; as deleted.
(let [task (:app.tasks.file-gc/handler th/*system*)
res (task {:min-age (dt/duration 0)})]
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
(let [res (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
;; Now that file-gc have deleted the file-media-object usage,
;; lets execute the touched-gc task, we should see that two of
;; them are marked to be deleted.
(let [task (:app.storage/gc-touched-task th/*system*)
res (task {:min-age (dt/duration 0)})]
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 0 (:freeze res)))
(t/is (= 2 (:delete res))))
@ -457,11 +477,14 @@
:strokes [{:opacity 1 :stroke-image {:id (:id fmo5) :width 100 :height 100 :mtype "image/jpeg"}}]})}])
;; run the file-gc task immediately without forced min-age
(let [res (th/run-task! "file-gc")]
(let [res (th/run-task! :file-gc)]
(t/is (= 0 (:processed res))))
;; run the task again
(let [res (th/run-task! "file-gc" {:min-age 0})]
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
(let [res (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
;; retrieve file and check trimmed attribute
@ -494,15 +517,16 @@
;; Now, we have deleted the usage of pointers to the
;; file-media-objects, if we paste file-gc, they should be marked
;; as deleted.
(let [task (:app.tasks.file-gc/handler th/*system*)
res (task {:min-age (dt/duration 0)})]
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
(let [res (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 5 (:processed res))))
;; Now that file-gc have deleted the file-media-object usage,
;; lets execute the touched-gc task, we should see that two of
;; them are marked to be deleted.
(let [task (:app.storage/gc-touched-task th/*system*)
res (task {:min-age (dt/duration 0)})]
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 0 (:freeze res)))
(t/is (= 2 (:delete res))))
@ -515,7 +539,6 @@
(t/is (nil? (sto/get-object storage (:media-id fmo2))))
(t/is (nil? (sto/get-object storage (:media-id fmo1)))))))
(t/deftest file-gc-task-with-object-thumbnails
(letfn [(insert-file-object-thumbnail! [& {:keys [profile-id file-id page-id frame-id]}]
(let [object-id (thc/fmt-object-id file-id page-id frame-id "frame")
@ -609,16 +632,16 @@
;; because of the deduplication (we have uploaded 2 times the
;; same files).
(let [res (th/run-task! "storage-gc-touched" {:min-age (dt/duration 0)})]
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 1 (:freeze res)))
(t/is (= 0 (:delete res))))
;; run the file-gc task immediately without forced min-age
(let [res (th/run-task! "file-gc")]
(let [res (th/run-task! :file-gc)]
(t/is (= 0 (:processed res))))
;; run the task again
(let [res (th/run-task! "file-gc" {:min-age 0})]
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
;; retrieve file and check trimmed attribute
@ -648,22 +671,29 @@
:page-id page-id
:id frame-id-2}])
(let [res (th/run-task! "file-gc" {:min-age (dt/duration 0)})]
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
(let [rows (th/db-exec! ["select * from file_tagged_object_thumbnail where file_id = ?" file-id])]
;; (pp/pprint rows)
(t/is (= 1 (count rows)))
(let [rows (th/db-query :file-tagged-object-thumbnail {:file-id file-id})]
(t/is (= 2 (count rows)))
(t/is (= 1 (count (remove (comp some? :deleted-at) rows))))
(t/is (= (thc/fmt-object-id file-id page-id frame-id-1 "frame")
(-> rows first :object-id))))
;; Now that file-gc have deleted the object thumbnail lets
;; Now that file-gc have marked for deletion the object
;; thumbnail lets execute the objects-gc task which remove
;; the rows and mark as touched the storage object rows
(let [res (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 2 (:processed res))))
;; Now that objects-gc have deleted the object thumbnail lets
;; execute the touched-gc task
(let [res (th/run-task! "storage-gc-touched" {:min-age (dt/duration 0)})]
(let [res (th/run-task! "storage-gc-touched" {:min-age 0})]
(t/is (= 1 (:freeze res))))
;; check file media objects
(let [rows (th/db-exec! ["select * from storage_object where deleted_at is null"])]
(let [rows (th/db-query :storage-object {:deleted-at nil})]
;; (pp/pprint rows)
(t/is (= 1 (count rows))))
@ -676,31 +706,32 @@
:page-id page-id
:id frame-id-1}])
(let [res (th/run-task! "file-gc" {:min-age (dt/duration 0)})]
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
(let [rows (th/db-exec! ["select * from file_tagged_object_thumbnail where file_id = ?" file-id])]
(t/is (= 0 (count rows))))
(let [rows (th/db-query :file-tagged-object-thumbnail {:file-id file-id})]
(t/is (= 1 (count rows)))
(t/is (= 0 (count (remove (comp some? :deleted-at) rows)))))
(let [res (th/run-task! :objects-gc {:min-age 0})]
;; (pp/pprint res)
(t/is (= 1 (:processed res))))
;; We still have th storage objects in the table
(let [rows (th/db-exec! ["select * from storage_object where deleted_at is null"])]
(let [rows (th/db-query :storage-object {:deleted-at nil})]
;; (pp/pprint rows)
(t/is (= 1 (count rows))))
;; Now that file-gc have deleted the object thumbnail lets
;; execute the touched-gc task
(let [res (th/run-task! "storage-gc-touched" {:min-age (dt/duration 0)})]
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 1 (:delete res))))
;; check file media objects
(let [rows (th/db-exec! ["select * from storage_object where deleted_at is null"])]
(let [rows (th/db-query :storage-object {:deleted-at nil})]
;; (pp/pprint rows)
(t/is (= 0 (count rows)))))))
(t/deftest permissions-checks-creating-file
(let [profile1 (th/create-profile* 1)
profile2 (th/create-profile* 2)
@ -811,13 +842,12 @@
(t/is (th/ex-of-type? error :not-found))))
(t/deftest deletion
(let [task (:app.tasks.objects-gc/handler th/*system*)
profile1 (th/create-profile* 1)
(let [profile1 (th/create-profile* 1)
file (th/create-file* 1 {:project-id (:default-project-id profile1)
:profile-id (:id profile1)})]
;; file is not deleted because it does not meet all
;; conditions to be deleted.
(let [result (task {:min-age (dt/duration 0)})]
(let [result (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 0 (:processed result))))
;; query the list of files
@ -848,7 +878,7 @@
(t/is (= 0 (count result)))))
;; run permanent deletion (should be noop)
(let [result (task {:min-age (dt/duration {:minutes 1})})]
(let [result (th/run-task! :objects-gc {:min-age (dt/duration {:minutes 1})})]
(t/is (= 0 (:processed result))))
;; query the list of file libraries of a after hard deletion
@ -862,7 +892,7 @@
(t/is (= 0 (count result)))))
;; run permanent deletion
(let [result (task {:min-age (dt/duration 0)})]
(let [result (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 1 (:processed result))))
;; query the list of file libraries of a after hard deletion
@ -874,7 +904,8 @@
(let [error (:error out)
error-data (ex-data error)]
(t/is (th/ex-info? error))
(t/is (= (:type error-data) :not-found))))))
(t/is (= (:type error-data) :not-found))))
))
(t/deftest object-thumbnails-ops
@ -1075,7 +1106,7 @@
(th/sleep 300)
;; run the task
(let [res (th/run-task! "file-gc" {:min-age 0})]
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
;; check that object thumbnails are still here
@ -1104,13 +1135,19 @@
(t/is (= 2 (count res))))
;; run the task again
(let [res (th/run-task! "file-gc" {:min-age 0})]
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
;; check that the unknown frame thumbnail is deleted
(let [res (th/db-exec! ["select * from file_tagged_object_thumbnail"])]
(t/is (= 1 (count res)))))))
(let [rows (th/db-query :file-tagged-object-thumbnail {:file-id (:id file)})]
(t/is (= 2 (count rows)))
(t/is (= 1 (count (remove (comp some? :deleted-at) rows)))))
(let [res (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 2 (:processed res))))
(let [rows (th/db-query :file-tagged-object-thumbnail {:file-id (:id file)})]
(t/is (= 1 (count rows)))))))
(t/deftest file-thumbnail-ops
(let [prof (th/create-profile* 1 {:is-active true})
@ -1155,12 +1192,19 @@
(t/testing "gc task"
;; make the file eligible for GC waiting 300ms (configured
;; timeout for testing)
(th/sleep 300)
(let [res (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
(let [res (th/run-task! "file-gc" {:min-age 0})]
(let [rows (th/db-query :file-thumbnail {:file-id (:id file)})]
(t/is (= 2 (count rows)))
(t/is (= 1 (count (remove (comp some? :deleted-at) rows)))))
(let [res (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
(let [rows (th/db-query :file-thumbnail {:file-id (:id file)})]
(t/is (= 1 (count rows)))))))

55
backend/test/backend_tests/rpc_file_thumbnails_test.clj
View file

@ -6,6 +6,7 @@
(ns backend-tests.rpc-file-thumbnails-test
(:require
[app.common.pprint :as pp]
[app.common.thumbnails :as thc]
[app.common.types.shape :as cts]
[app.common.uuid :as uuid]
@ -114,9 +115,12 @@
;; Run the File GC task that should remove unused file object
;; thumbnails
(let [result (th/run-task! :file-gc {:min-age (dt/duration 0)})]
(let [result (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed result))))
(let [result (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 2 (:processed result))))
;; check if row2 related thumbnail row still exists
(let [[row :as rows] (th/db-query :file-tagged-object-thumbnail
{:file-id (:id file)}
@ -141,7 +145,7 @@
;; Run the storage gc deleted task, it should permanently delete
;; all storage objects related to the deleted thumbnails
(let [result (th/run-task! :storage-gc-deleted {:min-age (dt/duration 0)})]
(let [result (th/run-task! :storage-gc-deleted {:min-age 0})]
(t/is (= 1 (:deleted result))))
(t/is (nil? (sto/get-object storage (:media-id row1))))
@ -188,13 +192,12 @@
(let [[row1 row2 :as rows] (th/db-query :file-thumbnail
{:file-id (:id file)}
{:order-by [[:created-at :asc]]})]
{:order-by [[:revn :asc]]})]
(t/is (= 2 (count rows)))
(t/is (= (:file-id data1) (:file-id row1)))
(t/is (= (:revn data1) (:revn row1)))
(t/is (uuid? (:media-id row1)))
(t/is (= (:file-id data2) (:file-id row2)))
(t/is (= (:revn data2) (:revn row2)))
(t/is (uuid? (:media-id row2)))
@ -215,7 +218,10 @@
;; Run the File GC task that should remove unused file object
;; thumbnails
(let [result (th/run-task! :file-gc {:min-age (dt/duration 0)})]
(let [result (th/run-task! :file-gc {:min-age 0})]
(t/is (= 1 (:processed result))))
(let [result (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 1 (:processed result))))
;; check if row1 related thumbnail row still exists
@ -227,6 +233,9 @@
(t/is (= (:object-id data1) (:object-id row)))
(t/is (uuid? (:media-id row1))))
(let [result (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 1 (:delete result))))
;; Check if storage objects still exists after file-gc
(t/is (nil? (sto/get-object storage (:media-id row1))))
(t/is (some? (sto/get-object storage (:media-id row2))))
@ -236,10 +245,42 @@
;; Run the storage gc deleted task, it should permanently delete
;; all storage objects related to the deleted thumbnails
(let [result (th/run-task! :storage-gc-deleted {:min-age (dt/duration 0)})]
(let [result (th/run-task! :storage-gc-deleted {:min-age 0})]
(t/is (= 1 (:deleted result))))
(t/is (some? (sto/get-object storage (:media-id row2)))))))
(t/is (some? (sto/get-object storage (:media-id row2))))
)))
(t/deftest error-on-direct-storage-obj-deletion
(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 3})
data1 {::th/type :create-file-thumbnail
::rpc/profile-id (:id profile)
:file-id (:id file)
:revn 2
:media {:filename "sample.jpg"
:size 7923
:path (th/tempfile "backend_tests/test_files/sample2.jpg")
:mtype "image/jpeg"}}]
(let [out (th/command! data1)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(t/is (contains? (:result out) :uri)))
(let [[row1 :as rows] (th/db-query :file-thumbnail {:file-id (:id file)})]
(t/is (= 1 (count rows)))
(t/is (thrown? org.postgresql.util.PSQLException
(th/db-delete! :storage-object {:id (:media-id row1)}))))))
(t/deftest get-file-object-thumbnail
(let [storage (::sto/storage th/*system*)

189
backend/test/backend_tests/rpc_font_test.clj
View file

@ -92,3 +92,192 @@
:font-family
:font-weight
:font-style))))
(t/deftest font-deletion-1
(let [prof (th/create-profile* 1 {:is-active true})
team-id (:default-team-id prof)
proj-id (:default-project-id prof)
font-id (uuid/custom 10 1)
data1 (-> (io/resource "backend_tests/test_files/font-1.woff")
io/input-stream
io/read-as-bytes)
data2 (-> (io/resource "backend_tests/test_files/font-2.woff")
io/input-stream
io/read-as-bytes)]
;; Create front variant
(let [params {::th/type :create-font-variant
::rpc/profile-id (:id prof)
:team-id team-id
:font-id font-id
:font-family "somefont"
:font-weight 400
:font-style "normal"
:data {"font/woff" data1}}
out (th/command! params)]
;; (th/print-result! out)
(t/is (nil? (:error out))))
(let [params {::th/type :create-font-variant
::rpc/profile-id (:id prof)
:team-id team-id
:font-id font-id
:font-family "somefont"
:font-weight 500
:font-style "normal"
:data {"font/woff" data2}}
out (th/command! params)]
;; (th/print-result! out)
(t/is (nil? (:error out))))
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 6 (:freeze res))))
(let [params {::th/type :delete-font
::rpc/profile-id (:id prof)
:team-id team-id
:id font-id}
out (th/command! params)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(t/is (nil? (:result out))))
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 6 (:freeze res)))
(t/is (= 0 (:delete res))))
(let [res (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 2 (:processed res))))
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 0 (:freeze res)))
(t/is (= 6 (:delete res))))
))
(t/deftest font-deletion-2
(let [prof (th/create-profile* 1 {:is-active true})
team-id (:default-team-id prof)
proj-id (:default-project-id prof)
font-id (uuid/custom 10 1)
data1 (-> (io/resource "backend_tests/test_files/font-1.woff")
io/input-stream
io/read-as-bytes)
data2 (-> (io/resource "backend_tests/test_files/font-2.woff")
io/input-stream
io/read-as-bytes)]
;; Create front variant
(let [params {::th/type :create-font-variant
::rpc/profile-id (:id prof)
:team-id team-id
:font-id font-id
:font-family "somefont"
:font-weight 400
:font-style "normal"
:data {"font/woff" data1}}
out (th/command! params)]
;; (th/print-result! out)
(t/is (nil? (:error out))))
(let [params {::th/type :create-font-variant
::rpc/profile-id (:id prof)
:team-id team-id
:font-id (uuid/custom 10 2)
:font-family "somefont"
:font-weight 400
:font-style "normal"
:data {"font/woff" data2}}
out (th/command! params)]
;; (th/print-result! out)
(t/is (nil? (:error out))))
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 6 (:freeze res))))
(let [params {::th/type :delete-font
::rpc/profile-id (:id prof)
:team-id team-id
:id font-id}
out (th/command! params)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(t/is (nil? (:result out))))
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 3 (:freeze res)))
(t/is (= 0 (:delete res))))
(let [res (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 0 (:freeze res)))
(t/is (= 3 (:delete res))))
))
(t/deftest font-deletion-3
(let [prof (th/create-profile* 1 {:is-active true})
team-id (:default-team-id prof)
proj-id (:default-project-id prof)
font-id (uuid/custom 10 1)
data1 (-> (io/resource "backend_tests/test_files/font-1.woff")
io/input-stream
io/read-as-bytes)
data2 (-> (io/resource "backend_tests/test_files/font-2.woff")
io/input-stream
io/read-as-bytes)
params1 {::th/type :create-font-variant
::rpc/profile-id (:id prof)
:team-id team-id
:font-id font-id
:font-family "somefont"
:font-weight 400
:font-style "normal"
:data {"font/woff" data1}}
params2 {::th/type :create-font-variant
::rpc/profile-id (:id prof)
:team-id team-id
:font-id font-id
:font-family "somefont"
:font-weight 500
:font-style "normal"
:data {"font/woff" data2}}
out1 (th/command! params1)
out2 (th/command! params2)]
;; (th/print-result! out1)
(t/is (nil? (:error out1)))
(t/is (nil? (:error out2)))
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 6 (:freeze res))))
(let [params {::th/type :delete-font-variant
::rpc/profile-id (:id prof)
:team-id team-id
:id (-> out1 :result :id)}
out (th/command! params)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(t/is (nil? (:result out))))
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 3 (:freeze res)))
(t/is (= 0 (:delete res))))
(let [res (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
(let [res (th/run-task! :storage-gc-touched {:min-age 0})]
(t/is (= 0 (:freeze res)))
(t/is (= 3 (:delete res))))
))

76
backend/test/backend_tests/rpc_profile_test.clj
View file

@ -125,7 +125,7 @@
;; profile is not deleted because it does not meet all
;; conditions to be deleted.
(let [result (th/run-task! :objects-gc {:min-age (dt/duration 0)})]
(let [result (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 0 (:processed result))))
;; Request profile to be deleted
@ -144,8 +144,16 @@
(t/is (= 1 (count (:result out)))))
;; execute permanent deletion task
(let [result (th/run-task! :objects-gc {:min-age (dt/duration "-1m")})]
(t/is (= 2 (:processed result))))
(let [result (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 1 (:processed result))))
(let [row (th/db-get :team
{:id (:default-team-id prof)}
{::db/remove-deleted? false})]
(t/is (nil? (:deleted-at row))))
(let [result (th/run-task! :orphan-teams-gc {:min-age 0})]
(t/is (= 1 (:processed result))))
(let [row (th/db-get :team
{:id (:default-team-id prof)}
@ -158,67 +166,9 @@
out (th/command! params)]
;; (th/print-result! out)
(let [result (:result out)]
(t/is (= uuid/zero (:id result)))))))
(t/is (= uuid/zero (:id result)))))
(t/deftest profile-immediate-deletion
(let [prof1 (th/create-profile* 1)
prof2 (th/create-profile* 2)
file (th/create-file* 1 {:profile-id (:id prof1)
:project-id (:default-project-id prof1)
:is-shared false})
team (th/create-team* 1 {:profile-id (:id prof1)})
_ (th/create-team-role* {:team-id (:id team)
:profile-id (:id prof2)
:role :admin})]
;; profile is not deleted because it does not meet all
;; conditions to be deleted.
(let [result (th/run-task! :objects-gc {:min-age (dt/duration 0)})]
(t/is (= 0 (:orphans result)))
(t/is (= 0 (:processed result))))
;; just delete the profile
(th/db-delete! :profile {:id (:id prof1)})
;; query files after profile deletion, expecting not found
(let [params {::th/type :get-project-files
::rpc/profile-id (:id prof1)
:project-id (:default-project-id prof1)}
out (th/command! params)]
;; (th/print-result! out)
(t/is (not (th/success? out)))
(let [edata (-> out :error ex-data)]
(t/is (= :not-found (:type edata)))))
;; the files and projects still exists on the database
(let [files (th/db-query :file {:project-id (:default-project-id prof1)})
projects (th/db-query :project {:team-id (:default-team-id prof1)})]
(t/is (= 1 (count files)))
(t/is (= 1 (count projects))))
;; execute the gc task
(let [result (th/run-task! :objects-gc {:min-age (dt/duration "-1m")})]
(t/is (= 1 (:processed result)))
(t/is (= 1 (:orphans result))))
;; Check the deletion flag on the default profile team
(let [row (th/db-get :team
{:id (:default-team-id prof1)}
{::db/remove-deleted? false})]
(t/is (dt/instant? (:deleted-at row))))
;; Check the deletion flag on the shared team
(let [row (th/db-get :team
{:id (:id team)}
{::db/remove-deleted? false})]
(t/is (nil? (:deleted-at row))))
;; Check the roles on the shared team
(let [rows (th/db-query :team-profile-rel {:team-id (:id team)})]
(t/is (= 1 (count rows)))
(t/is (= (:id prof2) (get-in rows [0 :profile-id])))
(t/is (= false (get-in rows [0 :is-owner]))))))
))
(t/deftest registration-domain-whitelist
(let [whitelist #{"gmail.com" "hey.com" "ya.ru"}]

10
backend/test/backend_tests/rpc_project_test.clj
View file

@ -172,14 +172,13 @@
(t/deftest test-deletion
(let [task (:app.tasks.objects-gc/handler th/*system*)
profile1 (th/create-profile* 1)
(let [profile1 (th/create-profile* 1)
project (th/create-project* 1 {:team-id (:default-team-id profile1)
:profile-id (:id profile1)})]
;; project is not deleted because it does not meet all
;; conditions to be deleted.
(let [result (task {:min-age (dt/duration 0)})]
(let [result (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 0 (:processed result))))
;; query the list of projects
@ -187,6 +186,7 @@
::rpc/profile-id (:id profile1)
:team-id (:default-team-id profile1)}
out (th/command! data)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(let [result (:result out)]
@ -210,7 +210,7 @@
(t/is (= 1 (count result)))))
;; run permanent deletion (should be noop)
(let [result (task {:min-age (dt/duration {:minutes 1})})]
(let [result (th/run-task! :objects-gc {:min-age (dt/duration {:minutes 1})})]
(t/is (= 0 (:processed result))))
;; query the list of files of a after soft deletion
@ -224,7 +224,7 @@
(t/is (= 0 (count result)))))
;; run permanent deletion
(let [result (task {:min-age (dt/duration 0)})]
(let [result (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 1 (:processed result))))
;; query the list of files of a after hard deletion

186
backend/test/backend_tests/rpc_team_test.clj
View file

@ -269,76 +269,6 @@
(t/is (= 1 (count members)))
(t/is (true? (-> members first :can-edit))))))))
(t/deftest team-deletion
(let [profile1 (th/create-profile* 1 {:is-active true})
team (th/create-team* 1 {:profile-id (:id profile1)})
pool (:app.db/pool th/*system*)
data {::th/type :delete-team
::rpc/profile-id (:id profile1)
:team-id (:id team)}]
;; team is not deleted because it does not meet all
;; conditions to be deleted.
(let [result (th/run-task! :objects-gc {:min-age (dt/duration 0)})]
(t/is (= 0 (:processed result))))
;; query the list of teams
(let [data {::th/type :get-teams
::rpc/profile-id (:id profile1)}
out (th/command! data)]
;; (th/print-result! out)
(t/is (th/success? out))
(let [result (:result out)]
(t/is (= 2 (count result)))
(t/is (= (:id team) (get-in result [1 :id])))
(t/is (= (:default-team-id profile1) (get-in result [0 :id])))))
;; Request team to be deleted
(let [params {::th/type :delete-team
::rpc/profile-id (:id profile1)
:id (:id team)}
out (th/command! params)]
(t/is (th/success? out)))
;; query the list of teams after soft deletion
(let [data {::th/type :get-teams
::rpc/profile-id (:id profile1)}
out (th/command! data)]
;; (th/print-result! out)
(t/is (th/success? out))
(let [result (:result out)]
(t/is (= 1 (count result)))
(t/is (= (:default-team-id profile1) (get-in result [0 :id])))))
;; run permanent deletion (should be noop)
(let [result (th/run-task! :objects-gc {:min-age (dt/duration {:minutes 1})})]
(t/is (= 0 (:processed result))))
;; query the list of projects after hard deletion
(let [data {::th/type :get-projects
::rpc/profile-id (:id profile1)
:team-id (:id team)}
out (th/command! data)]
;; (th/print-result! out)
(t/is (not (th/success? out)))
(let [edata (-> out :error ex-data)]
(t/is (= :not-found (:type edata)))))
;; run permanent deletion
(let [result (th/run-task! :objects-gc {:min-age (dt/duration 0)})]
(t/is (= 1 (:processed result))))
;; query the list of projects of a after hard deletion
(let [data {::th/type :get-projects
::rpc/profile-id (:id profile1)
:team-id (:id team)}
out (th/command! data)]
;; (th/print-result! out)
(t/is (not (th/success? out)))
(let [edata (-> out :error ex-data)]
(t/is (= :not-found (:type edata)))))))
(t/deftest query-team-invitations
(let [prof (th/create-profile* 1 {:is-active true})
team (th/create-team* 1 {:profile-id (:id prof)})
@ -418,3 +348,119 @@
(t/is (th/success? out))
(t/is (nil? (:result out)))
(t/is (nil? res)))))
(t/deftest team-deletion-1
(let [profile1 (th/create-profile* 1 {:is-active true})
team (th/create-team* 1 {:profile-id (:id profile1)})
pool (:app.db/pool th/*system*)
data {::th/type :delete-team
::rpc/profile-id (:id profile1)
:team-id (:id team)}]
;; team is not deleted because it does not meet all
;; conditions to be deleted.
(let [result (th/run-task! :objects-gc {:min-age (dt/duration 0)})]
(t/is (= 0 (:processed result))))
;; query the list of teams
(let [data {::th/type :get-teams
::rpc/profile-id (:id profile1)}
out (th/command! data)]
;; (th/print-result! out)
(t/is (th/success? out))
(let [result (:result out)]
(t/is (= 2 (count result)))
(t/is (= (:id team) (get-in result [1 :id])))
(t/is (= (:default-team-id profile1) (get-in result [0 :id])))))
;; Request team to be deleted
(let [params {::th/type :delete-team
::rpc/profile-id (:id profile1)
:id (:id team)}
out (th/command! params)]
(t/is (th/success? out)))
;; query the list of teams after soft deletion
(let [data {::th/type :get-teams
::rpc/profile-id (:id profile1)}
out (th/command! data)]
;; (th/print-result! out)
(t/is (th/success? out))
(let [result (:result out)]
(t/is (= 1 (count result)))
(t/is (= (:default-team-id profile1) (get-in result [0 :id])))))
;; run permanent deletion (should be noop)
(let [result (th/run-task! :objects-gc {:min-age (dt/duration {:minutes 1})})]
(t/is (= 0 (:processed result))))
;; query the list of projects after hard deletion
(let [data {::th/type :get-projects
::rpc/profile-id (:id profile1)
:team-id (:id team)}
out (th/command! data)]
;; (th/print-result! out)
(t/is (not (th/success? out)))
(let [edata (-> out :error ex-data)]
(t/is (= :not-found (:type edata)))))
;; run permanent deletion
(let [result (th/run-task! :objects-gc {:min-age (dt/duration 0)})]
(t/is (= 2 (:processed result))))
;; query the list of projects of a after hard deletion
(let [data {::th/type :get-projects
::rpc/profile-id (:id profile1)
:team-id (:id team)}
out (th/command! data)]
;; (th/print-result! out)
(t/is (not (th/success? out)))
(let [edata (-> out :error ex-data)]
(t/is (= :not-found (:type edata)))))))
(t/deftest team-deletion-2
(let [storage (-> (:app.storage/storage th/*system*)
(assoc ::sto/backend :assets-fs))
prof (th/create-profile* 1)
team (th/create-team* 1 {:profile-id (:id prof)})
proj (th/create-project* 1 {:profile-id (:id prof)
:team-id (:id team)})
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id team)
:is-shared false})
mfile {:filename "sample.jpg"
:path (th/tempfile "backend_tests/test_files/sample.jpg")
:mtype "image/jpeg"
:size 312043}]
(let [params {::th/type :upload-file-media-object
::rpc/profile-id (:id prof)
:file-id (:id file)
:is-local true
:name "testfile"
:content mfile}
out (th/command! params)]
(t/is (nil? (:error out))))
(let [params {::th/type :delete-team
::rpc/profile-id (:id prof)
:id (:id team)}
out (th/command! params)]
#_(th/print-result! out)
(t/is (nil? (:error out))))
(let [rows (th/db-exec! ["select * from team where id = ?" (:id team)])]
(t/is (= 1 (count rows)))
(t/is (dt/instant? (:deleted-at (first rows)))))
(let [result (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 5 (:processed result))))
))

64
backend/test/backend_tests/storage_test.clj
View file

@ -113,7 +113,7 @@
(let [res (th/run-task! :storage-gc-deleted {})]
(t/is (= 1 (:deleted res))))
(let [res (db/exec-one! th/*pool* ["select count(*) from storage_object;"])]
(let [res (th/db-exec-one! ["select count(*) from storage_object;"])]
(t/is (= 2 (:count res))))))
(t/deftest test-touched-gc-task-1
@ -156,29 +156,33 @@
(t/is (= (:media-id result-1) (:media-id result-2)))
;; now we proceed to manually delete one file-media-object
(db/exec-one! th/*pool* ["delete from file_media_object where id = ?" (:id result-1)])
(th/db-update! :file-media-object
{:deleted-at (dt/now)}
{:id (:id result-1)})
;; run the objects gc task for permanent deletion
(let [res (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
;; check that we still have all the storage objects
(let [res (db/exec-one! th/*pool* ["select count(*) from storage_object"])]
(let [res (th/db-exec-one! ["select count(*) from storage_object"])]
(t/is (= 2 (:count res))))
;; now check if the storage objects are touched
(let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where touched_at is not null"])]
(let [res (th/db-exec-one! ["select count(*) from storage_object where touched_at is not null"])]
(t/is (= 2 (:count res))))
;; run the touched gc task
(let [task (:app.storage/gc-touched-task th/*system*)
res (task {})]
(let [res (th/run-task! :storage-gc-touched {})]
(t/is (= 2 (:freeze res)))
(t/is (= 0 (:delete res))))
;; now check that there are no touched objects
(let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where touched_at is not null"])]
(let [res (th/db-exec-one! ["select count(*) from storage_object where touched_at is not null"])]
(t/is (= 0 (:count res))))
;; now check that all objects are marked to be deleted
(let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where deleted_at is not null"])]
(let [res (th/db-exec-one! ["select count(*) from storage_object where deleted_at is not null"])]
(t/is (= 0 (:count res)))))))
@ -231,31 +235,35 @@
(t/is (nil? (:error out2)))
;; run the touched gc task
(let [task (:app.storage/gc-touched-task th/*system*)
res (task {})]
(let [res (th/run-task! :storage-gc-touched {})]
(t/is (= 5 (:freeze res)))
(t/is (= 0 (:delete res)))
(let [result-1 (:result out1)
result-2 (:result out2)]
;; now we proceed to manually delete one team-font-variant
(db/exec-one! th/*pool* ["delete from team_font_variant where id = ?" (:id result-2)])
(th/db-update! :team-font-variant
{:deleted-at (dt/now)}
{:id (:id result-2)})
;; run the objects gc task for permanent deletion
(let [res (th/run-task! :objects-gc {:min-age 0})]
(t/is (= 1 (:processed res))))
;; revert touched state to all storage objects
(db/exec-one! th/*pool* ["update storage_object set touched_at=now()"])
(th/db-exec-one! ["update storage_object set touched_at=now()"])
;; Run the task again
(let [res (task {})]
(let [res (th/run-task! :storage-gc-touched {})]
(t/is (= 2 (:freeze res)))
(t/is (= 3 (:delete res))))
;; now check that there are no touched objects
(let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where touched_at is not null"])]
(let [res (th/db-exec-one! ["select count(*) from storage_object where touched_at is not null"])]
(t/is (= 0 (:count res))))
;; now check that all objects are marked to be deleted
(let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where deleted_at is not null"])]
(let [res (th/db-exec-one! ["select count(*) from storage_object where deleted_at is not null"])]
(t/is (= 3 (:count res))))))))
(t/deftest test-touched-gc-task-3
@ -289,28 +297,28 @@
result-2 (:result out2)]
;; now we proceed to manually mark all storage objects touched
(db/exec-one! th/*pool* ["update storage_object set touched_at=now()"])
(th/db-exec! ["update storage_object set touched_at=now()"])
;; run the touched gc task
(let [task (:app.storage/gc-touched-task th/*system*)
res (task {})]
(let [res (th/run-task! "storage-gc-touched" {:min-age 0})]
(t/is (= 2 (:freeze res)))
(t/is (= 0 (:delete res))))
;; check that we have all object in the db
(let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where deleted_at is null"])]
(t/is (= 2 (:count res)))))
(let [rows (th/db-exec! ["select * from storage_object"])]
(t/is (= 2 (count rows)))))
;; now we proceed to manually delete all file_media_object
(db/exec-one! th/*pool* ["delete from file_media_object"])
(th/db-exec! ["update file_media_object set deleted_at = now()"])
(let [res (th/run-task! "objects-gc" {:min-age 0})]
(t/is (= 2 (:processed res))))
;; run the touched gc task
(let [task (:app.storage/gc-touched-task th/*system*)
res (task {})]
(let [res (th/run-task! "storage-gc-touched" {:min-age 0})]
(t/is (= 0 (:freeze res)))
(t/is (= 2 (:delete res))))
;; check that we have all no objects
(let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where deleted_at is null"])]
(t/is (= 0 (:count res))))))
(let [rows (th/db-exec! ["select * from storage_object where deleted_at is null"])]
(t/is (= 0 (count rows))))))