♻️ Refactor exportation and duplicate mechanism

Previously the file processing was implemented 3 times using similar
approaches bug each own with its own bugs. This PR unifies the
loging to a single implementation used by the 3 operations.
This commit is contained in:
Andrey Antukh 2024-01-22 15:19:03 +01:00
parent a85a7c74c3
commit 7f60946204
12 changed files with 1587 additions and 1858 deletions

View file

@ -9,31 +9,24 @@
of entire team (or multiple teams) at once."
(:refer-clojure :exclude [read])
(:require
[app.binfile.common :as bfc]
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.features :as cfeat]
[app.common.files.defaults :as cfd]
[app.common.files.migrations :as fmg]
[app.common.files.validate :as fval]
[app.common.logging :as l]
[app.common.transit :as t]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as sql]
[app.features.fdata :as feat.fdata]
[app.http.sse :as sse]
[app.loggers.audit :as-alias audit]
[app.loggers.webhooks :as-alias webhooks]
[app.media :as media]
[app.storage :as sto]
[app.storage.tmp :as tmp]
[app.util.blob :as blob]
[app.util.pointer-map :as pmap]
[app.util.time :as dt]
[app.worker :as-alias wrk]
[clojure.set :as set]
[clojure.walk :as walk]
[cuerdas.core :as str]
[datoteka.io :as io]
[promesa.util :as pu])
@ -42,34 +35,10 @@
(set! *warn-on-reflection* true)
(def ^:dynamic *state* nil)
(def ^:dynamic *options* nil)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LOW LEVEL API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- lookup-index
[id]
(when-let [val (get-in @*state* [:index id])]
(l/trc :fn "lookup-index" :id (some-> id str) :result (some-> val str) ::l/sync? true)
(or val id)))
(defn- index-object
[index obj & attrs]
(reduce (fn [index attr-fn]
(let [old-id (attr-fn obj)
new-id (uuid/next)]
(assoc index old-id new-id)))
index
attrs))
(defn- update-index
([index coll]
(update-index index coll identity))
([index coll attr]
(reduce #(index-object %1 %2 attr) index coll)))
(defn- create-database
([cfg]
(let [path (tmp/tempfile :prefix "penpot.binfile." :suffix ".sqlite")]
@ -92,12 +61,6 @@
"CREATE INDEX kvdata__tag_key__idx
ON kvdata (tag, key)")
(defn- decode-row
[{:keys [data features] :as row}]
(cond-> row
features (assoc :features (db/decode-pgarray features #{}))
data (assoc :data (blob/decode data))))
(defn- setup-schema!
[{:keys [::db]}]
(db/exec-one! db [sql:create-kvdata-table])
@ -147,156 +110,62 @@
;; IMPORT/EXPORT IMPL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:private xf-map-id
(map :id))
(def ^:private xf-map-media-id
(comp
(mapcat (juxt :media-id
:thumbnail-id
:woff1-file-id
:woff2-file-id
:ttf-file-id
:otf-file-id))
(filter uuid?)))
;; NOTE: Will be used in future, commented for satisfy linter
;; (def ^:private sql:get-libraries
;; "WITH RECURSIVE libs AS (
;; SELECT fl.id
;; FROM file AS fl
;; JOIN file_library_rel AS flr ON (flr.library_file_id = fl.id)
;; WHERE flr.file_id = ANY(?)
;; UNION
;; SELECT fl.id
;; FROM file AS fl
;; JOIN file_library_rel AS flr ON (flr.library_file_id = fl.id)
;; JOIN libs AS l ON (flr.file_id = l.id)
;; )
;; SELECT DISTINCT l.id
;; FROM libs AS l")
;;
;; (defn- get-libraries
;; "Get all libraries ids related to provided file ids"
;; [{:keys [::db/conn]} ids]
;; (let [ids' (db/create-array conn "uuid" ids)]
;; (->> (db/exec! conn [sql:get-libraries ids])
;; (into #{} xf-map-id))))
;;
;; (def ^:private sql:get-project-files
;; "SELECT f.id FROM file AS f
;; WHERE f.project_id = ?")
;; (defn- get-project-files
;; "Get a set of file ids for the project"
;; [{:keys [::db/conn]} project-id]
;; (->> (db/exec! conn [sql:get-project-files project-id])
;; (into #{} xf-map-id)))
(def ^:private sql:get-team-files
"SELECT f.id FROM file AS f
JOIN project AS p ON (p.id = f.project_id)
WHERE p.team_id = ?")
(defn- get-team-files
"Get a set of file ids for the specified team-id"
[{:keys [::db/conn]} team-id]
(->> (db/exec! conn [sql:get-team-files team-id])
(into #{} xf-map-id)))
(def ^:private sql:get-team-projects
"SELECT p.id FROM project AS p
WHERE p.team_id = ?")
(defn- get-team-projects
"Get a set of project ids for the team"
[{:keys [::db/conn]} team-id]
(->> (db/exec! conn [sql:get-team-projects team-id])
(into #{} xf-map-id)))
(declare ^:private write-project!)
(declare ^:private write-file!)
(defn- write-team!
[{:keys [::db/conn] :as cfg} team-id]
[cfg team-id]
(sse/tap {:type :export-progress
:section :write-team
:id team-id})
(let [team (db/get conn :team {:id team-id}
::db/remove-deleted false
::db/check-deleted false)
team (decode-row team)
fonts (db/query conn :team-font-variant
{:team-id team-id
:deleted-at nil}
{::sql/for-share true})]
(let [team (bfc/get-team cfg team-id)
fonts (bfc/get-fonts cfg team-id)]
(l/trc :hint "write" :obj "team"
:id (str team-id)
:fonts (count fonts))
(vswap! *state* update :teams conj team-id)
(vswap! *state* update :storage-objects into xf-map-media-id fonts)
(vswap! bfc/*state* update :teams conj team-id)
(vswap! bfc/*state* bfc/collect-storage-objects fonts)
(write! cfg :team team-id team)
(doseq [{:keys [id] :as font} fonts]
(vswap! *state* update :team-font-variants conj id)
(vswap! bfc/*state* update :team-font-variants conj id)
(write! cfg :team-font-variant id font))))
(defn- write-project!
[{:keys [::db/conn] :as cfg} project-id]
[cfg project-id]
(sse/tap {:type :export-progress
:section :write-project
:id project-id})
(let [project (db/get conn :project {:id project-id}
::db/remove-deleted false
::db/check-deleted false)]
(let [project (bfc/get-project cfg project-id)]
(l/trc :hint "write" :obj "project" :id (str project-id))
(write! cfg :project (str project-id) project)
(vswap! *state* update :projects conj project-id)))
(vswap! bfc/*state* update :projects conj project-id)))
(defn- write-file!
[{:keys [::db/conn] :as cfg} file-id]
[cfg file-id]
(sse/tap {:type :export-progress
:section :write-file
:id file-id})
(let [file (binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg file-id)]
(-> (db/get conn :file {:id file-id}
::sql/for-share true
::db/remove-deleted false
::db/check-deleted false)
(decode-row)
(update :data feat.fdata/process-pointers deref)
(update :data feat.fdata/process-objects (partial into {}))))
(let [file (bfc/get-file cfg file-id)
thumbs (bfc/get-file-object-thumbnails cfg file-id)
media (bfc/get-file-media cfg file)
rels (bfc/get-files-rels cfg #{file-id})]
thumbs (db/query conn :file-tagged-object-thumbnail
{:file-id file-id
:deleted-at nil}
{::sql/for-share true})
media (db/query conn :file-media-object
{:file-id file-id
:deleted-at nil}
{::sql/for-share true})
rels (db/query conn :file-library-rel
{:file-id file-id})]
(vswap! *state* (fn [state]
(-> state
(update :files conj file-id)
(update :file-media-objects into (map :id) media)
(update :storage-objects into xf-map-media-id thumbs)
(update :storage-objects into xf-map-media-id media))))
(vswap! bfc/*state* (fn [state]
(-> state
(update :files conj file-id)
(update :file-media-objects into bfc/xf-map-id media)
(bfc/collect-storage-objects thumbs)
(bfc/collect-storage-objects media))))
(write! cfg :file file-id file)
(write! cfg :file-rels file-id rels)
@ -304,13 +173,8 @@
(run! (partial write! cfg :file-media-object file-id) media)
(run! (partial write! cfg :file-object-thumbnail file-id) thumbs)
(when-let [thumb (db/get* conn :file-thumbnail
{:file-id file-id
:revn (:revn file)
:data nil}
{::sql/for-share true
::sql/columns [:media-id :file-id :revn]})]
(vswap! *state* update :storage-objects into xf-map-media-id [thumb])
(when-let [thumb (bfc/get-file-thumbnail cfg file)]
(vswap! bfc/*state* bfc/collect-storage-objects [thumb])
(write! cfg :file-thumbnail file-id thumb))
(l/trc :hint "write" :obj "file"
@ -328,7 +192,7 @@
(write! cfg :storage-object id (meta sobj) data)))
(defn- read-storage-object!
[{:keys [::sto/storage ::timestamp] :as cfg} id]
[{:keys [::sto/storage ::bfc/timestamp] :as cfg} id]
(let [mdata (read-obj cfg :storage-object id)
data (read-blob cfg :storage-object id)
hash (sto/calculate-hash data)
@ -343,7 +207,7 @@
sobject (sto/put-object! storage params)]
(vswap! *state* update :index assoc id (:id sobject))
(vswap! bfc/*state* update :index assoc id (:id sobject))
(l/trc :hint "read" :obj "storage-object"
:id (str id)
@ -351,7 +215,7 @@
:size (:size sobject))))
(defn read-team!
[{:keys [::db/conn ::timestamp] :as cfg} team-id]
[{:keys [::db/conn ::bfc/timestamp] :as cfg} team-id]
(l/trc :hint "read" :obj "team" :id (str team-id))
(sse/tap {:type :import-progress
@ -360,8 +224,8 @@
(let [team (read-obj cfg :team team-id)
team (-> team
(update :id lookup-index)
(update :photo-id lookup-index)
(update :id bfc/lookup-index)
(update :photo-id bfc/lookup-index)
(assoc :created-at timestamp)
(assoc :modified-at timestamp))]
@ -372,12 +236,12 @@
(doseq [font (->> (read-seq cfg :team-font-variant)
(filter #(= team-id (:team-id %))))]
(let [font (-> font
(update :id lookup-index)
(update :team-id lookup-index)
(update :woff1-file-id lookup-index)
(update :woff2-file-id lookup-index)
(update :ttf-file-id lookup-index)
(update :otf-file-id lookup-index)
(update :id bfc/lookup-index)
(update :team-id bfc/lookup-index)
(update :woff1-file-id bfc/lookup-index)
(update :woff2-file-id bfc/lookup-index)
(update :ttf-file-id bfc/lookup-index)
(update :otf-file-id bfc/lookup-index)
(assoc :created-at timestamp)
(assoc :modified-at timestamp))]
(db/insert! conn :team-font-variant font
@ -386,7 +250,7 @@
team))
(defn read-project!
[{:keys [::db/conn ::timestamp] :as cfg} project-id]
[{:keys [::db/conn ::bfc/timestamp] :as cfg} project-id]
(l/trc :hint "read" :obj "project" :id (str project-id))
(sse/tap {:type :import-progress
@ -395,175 +259,40 @@
(let [project (read-obj cfg :project project-id)
project (-> project
(update :id lookup-index)
(update :team-id lookup-index)
(update :id bfc/lookup-index)
(update :team-id bfc/lookup-index)
(assoc :created-at timestamp)
(assoc :modified-at timestamp))]
(db/insert! conn :project project
::db/return-keys false)))
(defn- relink-shapes
"A function responsible to analyze all file data and
replace the old :component-file reference with the new
ones, using the provided file-index."
[data]
(letfn [(process-map-form [form]
(cond-> form
;; Relink image shapes
(and (map? (:metadata form))
(= :image (:type form)))
(update-in [:metadata :id] lookup-index)
;; Relink paths with fill image
(map? (:fill-image form))
(update-in [:fill-image :id] lookup-index)
;; This covers old shapes and the new :fills.
(uuid? (:fill-color-ref-file form))
(update :fill-color-ref-file lookup-index)
;; This covers the old shapes and the new :strokes
(uuid? (:storage-color-ref-file form))
(update :stroke-color-ref-file lookup-index)
;; This covers all text shapes that have typography referenced
(uuid? (:typography-ref-file form))
(update :typography-ref-file lookup-index)
;; This covers the component instance links
(uuid? (:component-file form))
(update :component-file lookup-index)
;; This covers the shadows and grids (they have directly
;; the :file-id prop)
(uuid? (:file-id form))
(update :file-id lookup-index)))]
(walk/postwalk (fn [form]
(if (map? form)
(try
(process-map-form form)
(catch Throwable cause
(l/warn :hint "failed form" :form (pr-str form) ::l/sync? true)
(throw cause)))
form))
data)))
(defn- relink-media
"A function responsible of process the :media attr of file data and
remap the old ids with the new ones."
[media]
(reduce-kv (fn [res k v]
(let [id (lookup-index k)]
(if (uuid? id)
(-> res
(assoc id (assoc v :id id))
(dissoc k))
res)))
media
media))
(defn- relink-colors
"A function responsible of process the :colors attr of file data and
remap the old ids with the new ones."
[colors]
(reduce-kv (fn [res k v]
(if (:image v)
(update-in res [k :image :id] lookup-index)
res))
colors
colors))
(defn- process-file
[{:keys [id] :as file}]
(-> file
(update :data (fn [fdata]
(-> fdata
(assoc :id id)
(dissoc :recent-colors)
(cond-> (> (:version fdata) cfd/version)
(assoc :version cfd/version))
;; FIXME: We're temporarily activating all
;; migrations because a problem in the
;; environments messed up with the version
;; numbers When this problem is fixed delete
;; the following line
(cond-> (> (:version fdata) 22)
(assoc :version 22)))))
(fmg/migrate-file)
(update :data (fn [fdata]
(-> fdata
(update :pages-index relink-shapes)
(update :components relink-shapes)
(update :media relink-media)
(update :colors relink-colors)
(d/without-nils))))))
(defn read-file!
[{:keys [::db/conn ::timestamp] :as cfg} file-id]
[{:keys [::db/conn ::bfc/timestamp] :as cfg} file-id]
(l/trc :hint "read" :obj "file" :id (str file-id))
(sse/tap {:type :import-progress
:section :read-file
:id file-id})
(let [file (read-obj cfg :file file-id)
(let [file (-> (read-obj cfg :file file-id)
(update :id bfc/lookup-index)
(update :project-id bfc/lookup-index)
(bfc/process-file))]
file (-> file
(update :id lookup-index)
(process-file))
;; All features that are enabled and requires explicit migration are
;; added to the state for a posterior migration step.
(doseq [feature (-> (::bfc/features cfg)
(set/difference cfeat/no-migration-features)
(set/difference (:features file)))]
(vswap! bfc/*state* update :pending-to-migrate (fnil conj []) [feature (:id file)]))
;; All features that are enabled and requires explicit migration are
;; added to the state for a posterior migration step.
_ (doseq [feature (-> (::features cfg)
(set/difference cfeat/no-migration-features)
(set/difference (:features file)))]
(vswap! *state* update :pending-to-migrate (fnil conj []) [feature (:id file)]))
file (-> file
(update :project-id lookup-index))
file (-> file
(assoc :created-at timestamp)
(assoc :modified-at timestamp)
(update :features
(fn [features]
(let [features (cfeat/check-supported-features! features)]
(-> (::features cfg)
(set/difference cfeat/frontend-only-features)
(set/union features))))))
_ (when (contains? cf/flags :file-schema-validation)
(fval/validate-file-schema! file))
_ (when (contains? cf/flags :soft-file-schema-validation)
(let [result (ex/try! (fval/validate-file-schema! file))]
(when (ex/exception? result)
(l/error :hint "file schema validation error" :cause result))))
file (if (contains? (:features file) "fdata/objects-map")
(feat.fdata/enable-objects-map file)
file)
file (if (contains? (:features file) "fdata/pointer-map")
(binding [pmap/*tracked* (pmap/create-tracked)]
(let [file (feat.fdata/enable-pointer-map file)]
(feat.fdata/persist-pointers! cfg (:id file))
file))
file)]
(db/insert! conn :file
(-> file
(update :features db/encode-pgarray conn "text")
(update :data blob/encode))
{::db/return-keys false}))
(bfc/persist-file! cfg file))
(doseq [thumbnail (read-seq cfg :file-object-thumbnail file-id)]
(let [thumbnail (-> thumbnail
(update :file-id lookup-index)
(update :media-id lookup-index))
(update :file-id bfc/lookup-index)
(update :media-id bfc/lookup-index))
file-id (:file-id thumbnail)
thumbnail (update thumbnail :object-id
@ -574,20 +303,21 @@
(doseq [rel (read-obj cfg :file-rels file-id)]
(let [rel (-> rel
(update :file-id lookup-index)
(update :library-file-id lookup-index)
(update :file-id bfc/lookup-index)
(update :library-file-id bfc/lookup-index)
(assoc :synced-at timestamp))]
(db/insert! conn :file-library-rel rel
::db/return-keys false)))
(doseq [media (read-seq cfg :file-media-object file-id)]
(let [media (-> media
(update :id lookup-index)
(update :file-id lookup-index)
(update :media-id lookup-index)
(update :thumbnail-id lookup-index))]
(update :id bfc/lookup-index)
(update :file-id bfc/lookup-index)
(update :media-id bfc/lookup-index)
(update :thumbnail-id bfc/lookup-index))]
(db/insert! conn :file-media-object media
::db/return-keys false))))
::db/return-keys false
::sql/on-conflict-do-nothing true))))
(def ^:private empty-summary
{:teams #{}
@ -617,20 +347,20 @@
(try
(db/tx-run! cfg (fn [cfg]
(setup-schema! cfg)
(binding [*state* (volatile! empty-summary)]
(binding [bfc/*state* (volatile! empty-summary)]
(write-team! cfg team-id)
(run! (partial write-project! cfg)
(get-team-projects cfg team-id))
(bfc/get-team-projects cfg team-id))
(run! (partial write-file! cfg)
(get-team-files cfg team-id))
(bfc/get-team-files cfg team-id))
(run! (partial write-storage-object! cfg)
(-> *state* deref :storage-objects))
(-> bfc/*state* deref :storage-objects))
(write! cfg :manifest "team-id" team-id)
(write! cfg :manifest "objects" (deref *state*))
(write! cfg :manifest "objects" (deref bfc/*state*))
(::path cfg))))
(finally
@ -642,19 +372,6 @@
:id (str id)
:elapsed (dt/format-duration elapsed)))))))
;; NOTE: will be used in future, commented for satisfy linter
;; (defn- run-pending-migrations!
;; [cfg]
;; ;; Run all pending migrations
;; (doseq [[feature file-id] (-> *state* deref :pending-to-migrate)]
;; (case feature
;; "components/v2"
;; (feat.compv2/migrate-file! cfg file-id :validate? (::validate cfg true))
;; (ex/raise :type :internal
;; :code :no-migration-defined
;; :hint (str/ffmt "no migation for feature '%' on file importation" feature)
;; :feature feature))))
(defn import-team!
[cfg path]
(let [id (uuid/next)
@ -662,7 +379,7 @@
cfg (-> (create-database cfg path)
(update ::sto/storage media/configure-assets-storage)
(assoc ::timestamp (dt/now)))]
(assoc ::bfc/timestamp (dt/now)))]
(l/inf :hint "start"
:operation "import"
@ -674,7 +391,7 @@
(db/exec-one! conn ["SET idle_in_transaction_session_timeout = 0"])
(db/exec-one! conn ["SET CONSTRAINTS ALL DEFERRED"])
(binding [*state* (volatile! {:index {}})]
(binding [bfc/*state* (volatile! {:index {}})]
(let [objects (read-obj cfg :manifest "objects")]
;; We first process all storage objects, they have
@ -683,19 +400,19 @@
(run! (partial read-storage-object! cfg) (:storage-objects objects))
;; Populate index with all the incoming objects
(vswap! *state* update :index
(vswap! bfc/*state* update :index
(fn [index]
(-> index
(update-index (:teams objects))
(update-index (:projects objects))
(update-index (:files objects))
(update-index (:file-media-objects objects))
(update-index (:team-font-variants objects)))))
(bfc/update-index (:teams objects))
(bfc/update-index (:projects objects))
(bfc/update-index (:files objects))
(bfc/update-index (:file-media-objects objects))
(bfc/update-index (:team-font-variants objects)))))
(let [team-id (read-obj cfg :manifest "team-id")
team (read-team! cfg team-id)
features (cfeat/get-team-enabled-features cf/flags team)
cfg (assoc cfg ::features features)]
cfg (assoc cfg ::bfc/features features)]
(run! (partial read-project! cfg) (:projects objects))
(run! (partial read-file! cfg) (:files objects))