0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-03-12 07:41:43 -05:00

Improve snapshot related internal API

This commit also adds the ability to take snapshot of all files
of the team in a single run/transaction.
This commit is contained in:
Andrey Antukh 2024-02-08 15:21:31 +01:00 committed by Andrés Moya
parent aaf457a792
commit 6d35cb2eb4
7 changed files with 433 additions and 286 deletions

View file

@ -1497,7 +1497,7 @@
(-> (db/get system :team {:id team-id}
{::db/remove-deleted false
::db/check-deleted false})
(decode-row)))
(update :features db/decode-pgarray #{})))
(defn- validate-file!
[file libs]
@ -1546,19 +1546,21 @@
AND f.deleted_at IS NULL
FOR UPDATE")
(defn get-and-lock-files
(defn get-and-lock-team-files
[conn team-id]
(->> (db/cursor conn [sql:get-and-lock-team-files team-id])
(map :id)))
(defn update-team!
[conn team]
(let [params (-> team
[system {:keys [id] :as team}]
(let [conn (db/get-connection system)
params (-> team
(update :features db/encode-pgarray conn "text")
(dissoc :id))]
(db/update! conn :team
params
{:id (:id team)})))
{:id id})
team))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC API
@ -1657,7 +1659,7 @@
:id id})
(run! (partial migrate-file system)
(get-and-lock-files conn id))
(get-and-lock-team-files conn id))
(->> (assoc team :features features)
(update-team! conn))))))]

View file

@ -414,12 +414,12 @@
:hint "provided invalid version"))
(binding [srepl/*system* cfg]
(srepl/update-file! :id file-id
:update-fn (fn [file]
(update file :data assoc :version version))
:migrate? false
:inc-revn? false
:save? true))
(srepl/process-file! :id file-id
:update-fn (fn [file]
(update file :data assoc :version version))
:migrate? false
:inc-revn? false
:save? true))
{::rres/status 200
::rres/headers {"content-type" "text/plain"}
::rres/body "OK"}))

View file

@ -285,8 +285,9 @@
file)))
(defn get-minimal-file
[{:keys [::db/pool] :as cfg} id]
(db/get pool :file {:id id} {:columns [:id :modified-at :revn]}))
[cfg id & {:as opts}]
(let [opts (assoc opts ::sql/columns [:id :modified-at :revn])]
(db/get cfg :file {:id id} opts)))
(defn get-file-etag
[{:keys [::rpc/profile-id]} {:keys [modified-at revn]}]

View file

@ -12,14 +12,17 @@
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.db.sql :as-alias sql]
[app.main :as-alias main]
[app.media :as media]
[app.rpc :as-alias rpc]
[app.rpc.commands.files :as files]
[app.rpc.commands.profile :as profile]
[app.rpc.doc :as-alias doc]
[app.storage :as sto]
[app.util.services :as sv]
[app.util.time :as dt]))
[app.util.time :as dt]
[cuerdas.core :as str]))
(defn check-authorized!
[{:keys [::db/pool]} profile-id]
@ -57,76 +60,119 @@
::sm/params schema:get-file-snapshots}
[cfg {:keys [::rpc/profile-id] :as params}]
(check-authorized! cfg profile-id)
(db/run! cfg #(get-file-snapshots % params)))
(db/run! cfg get-file-snapshots params))
(defn restore-file-snapshot!
[{:keys [::db/conn ::sto/storage] :as cfg} {:keys [file-id id]}]
(let [storage (media/configure-assets-storage storage conn)
params {:id id :file-id file-id}
options {:columns [:id :data :revn :features]}
snapshot (db/get* conn :file-change params options)]
file (files/get-minimal-file conn file-id {::db/for-update true})
snapshot (db/get* conn :file-change
{:file-id file-id
:id id}
{::db/for-share true})]
(when (and (some? snapshot)
(some? (:data snapshot)))
(when-not snapshot
(ex/raise :type :not-found
:code :snapshot-not-found
:hint "unable to find snapshot with the provided label"
:id id
:file-id file-id))
(l/dbg :hint "restoring snapshot"
:file-id (str file-id)
:snapshot-id (str (:id snapshot)))
(when-not (:data snapshot)
(ex/raise :type :precondition
:code :snapshot-without-data
:hint "snapshot has no data"
:label (:label snapshot)
:file-id file-id))
(db/update! conn :file
{:data (:data snapshot)
:revn (:revn snapshot)
:features (:features snapshot)}
{:id file-id})
(l/dbg :hint "restoring snapshot"
:file-id (str file-id)
:label (:label snapshot)
:snapshot-id (str (:id snapshot)))
;; clean object thumbnails
(let [sql (str "update file_tagged_object_thumbnail "
" set deleted_at = now() "
" where file_id=? returning media_id")
res (db/exec! conn [sql file-id])]
(db/update! conn :file
{:data (:data snapshot)
:revn (inc (:revn file))
:features (:features snapshot)}
{:id file-id})
(doseq [media-id (into #{} (keep :media-id) res)]
(sto/touch-object! storage media-id)))
;; clean object thumbnails
(let [sql (str "update file_tagged_object_thumbnail "
" set deleted_at = now() "
" where file_id=? returning media_id")
res (db/exec! conn [sql file-id])]
;; clean object thumbnails
(let [sql (str "update file_thumbnail "
" set deleted_at = now() "
" where file_id=? returning media_id")
res (db/exec! conn [sql file-id])]
(doseq [media-id (into #{} (keep :media-id) res)]
(sto/touch-object! storage media-id)))
(doseq [media-id (into #{} (keep :media-id) res)]
(sto/touch-object! storage media-id)))
{:id (:id snapshot)})))
;; clean object thumbnails
(let [sql (str "update file_thumbnail "
" set deleted_at = now() "
" where file_id=? returning media_id")
res (db/exec! conn [sql file-id])]
(doseq [media-id (into #{} (keep :media-id) res)]
(sto/touch-object! storage media-id)))
(def ^:private schema:restore-file-snapshot
[:map
[:file-id ::sm/uuid]
[:id ::sm/uuid]])
{:id (:id snapshot)
:label (:label snapshot)}))
(defn- resolve-snapshot-by-label
[conn file-id label]
(->> (db/query conn :file-change
{:file-id file-id
:label label}
{::sql/order-by [[:created-at :desc]]
::sql/columns [:file-id :id :label]})
(first)))
(def ^:private
schema:restore-file-snapshot
[:and
[:map
[:file-id ::sm/uuid]
[:id {:optional true} ::sm/uuid]
[:label {:optional true} :string]]
[::sm/contains-any #{:id :label}]])
(sv/defmethod ::restore-file-snapshot
{::doc/added "1.20"
::doc/skip true
::sm/params schema:restore-file-snapshot}
[cfg {:keys [::rpc/profile-id] :as params}]
[cfg {:keys [::rpc/profile-id file-id id label] :as params}]
(check-authorized! cfg profile-id)
(db/tx-run! cfg #(restore-file-snapshot! % params)))
(db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
(let [params (cond-> params
(and (not id) (string? label))
(merge (resolve-snapshot-by-label conn file-id label)))]
(restore-file-snapshot! cfg params)))))
(defn take-file-snapshot!
[{:keys [::db/conn]} {:keys [file-id label]}]
(when-let [file (db/get* conn :file {:id file-id})]
(let [id (uuid/next)
label (or label (str "Snapshot at " (dt/format-instant (dt/now) :rfc1123)))]
(l/debug :hint "persisting file snapshot"
:file-id (str file-id)
:label label)
(db/insert! conn :file-change
{:id id
:revn (:revn file)
:data (:data file)
:features (:features file)
:file-id (:id file)
:label label})
{:id id})))
(let [file (db/get conn :file {:id file-id})
id (uuid/next)]
(l/debug :hint "creating file snapshot"
:file-id (str file-id)
:label label)
(db/insert! conn :file-change
{:id id
:revn (:revn file)
:data (:data file)
:features (:features file)
:file-id (:id file)
:label label}
{::db/return-keys false})
{:id id :label label}))
(defn generate-snapshot-label
[]
(let [ts (-> (dt/now)
(dt/format-instant)
(str/replace #"[T:\.]" "-")
(str/rtrim "Z"))]
(str "snapshot-" ts)))
(def ^:private schema:take-file-snapshot
[:map [:file-id ::sm/uuid]])
@ -137,5 +183,8 @@
::sm/params schema:take-file-snapshot}
[cfg {:keys [::rpc/profile-id] :as params}]
(check-authorized! cfg profile-id)
(db/tx-run! cfg #(take-file-snapshot! % params)))
(db/tx-run! cfg (fn [cfg]
(let [params (update params :label (fn [label]
(or label (generate-snapshot-label))))]
(take-file-snapshot! cfg params)))))

View file

@ -12,7 +12,6 @@
[app.db :as db]
[app.features.components-v2 :as feat]
[app.main :as main]
[app.rpc.commands.files-snapshot :as rpc]
[app.srepl.helpers :as h]
[app.svgo :as svgo]
[app.util.cache :as cache]
@ -634,42 +633,3 @@
:file-name (:name file))
(assoc file :deleted-at (dt/now)))
file))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RESTORE SNAPSHOT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:private sql:snapshots-with-file
"SELECT f.id AS file_id,
fc.id AS id
FROM file AS f
JOIN file_change AS fc ON (fc.file_id = f.id)
WHERE fc.label = ? AND f.id = ANY(?)")
(defn restore-team!
[team-id label & {:keys [rollback?] :or {rollback? true}}]
(let [team-id (h/parse-uuid team-id)
get-file-snapshots
(fn [conn ids]
(let [label (str "migration/" label)]
(db/exec! conn [sql:snapshots-with-file label
(db/create-array conn "uuid" ids)])))
restore-snapshot
(fn [{:keys [::db/conn] :as system}]
(let [ids (into #{} (feat/get-and-lock-files conn team-id))
snap (get-file-snapshots conn ids)
ids' (into #{} (map :file-id) snap)
team (-> (feat/get-team conn team-id)
(update :features disj "components/v2"))]
(when (not= ids ids')
(throw (RuntimeException. "no uniform snapshot available")))
(feat/update-team! conn team)
(run! (partial rpc/restore-file-snapshot! system) snap)))]
(-> (assoc main/system ::db/rollback rollback?)
(db/tx-run! restore-snapshot))))

View file

@ -56,6 +56,75 @@
(d/parse-uuid v)
v))
;; (def ^:private sql:get-and-lock-team-files
;; "SELECT f.id
;; FROM file AS f
;; JOIN project AS p ON (p.id = f.project_id)
;; WHERE p.team_id = ?
;; FOR UPDATE")
;; (defn get-and-lock-team-files
;; [conn team-id]
;; (->> (db/exec! conn [sql:get-and-lock-team-files team-id])
;; (into #{} (map :id))))
;; (defn get-team
;; [system team-id]
;; (-> (db/get system :team {:id team-id}
;; {::db/remove-deleted false
;; ::db/check-deleted false})
;; (update :features db/decode-pgarray #{})))
(defn get-file
"Get the migrated data of one file."
([id] (get-file (or *system* main/system) id))
([system id]
(db/run! system
(fn [system]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer system id)]
(-> (files/get-file system id :migrate? false)
(update :data feat.fdata/process-pointers deref)
(update :data feat.fdata/process-objects (partial into {}))
(fmg/migrate-file)))))))
(defn update-file!
[system {:keys [id] :as file}]
(let [conn (db/get-connection system)
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! system id)
file))
file)
file (-> file
(update :features db/encode-pgarray conn "text")
(update :data blob/encode))]
(db/update! conn :file
{:revn (:revn file)
:data (:data file)
:features (:features file)
:data-backend nil
:modified-at (dt/now)
:has-media-trimmed false}
{:id (:id file)})))
(defn update-team!
[system {:keys [id] :as team}]
(let [conn (db/get-connection system)
params (-> team
(update :features db/encode-pgarray conn "text")
(dissoc :id))]
(db/update! conn :team
params
{:id id})
team))
(defn reset-file-data!
"Hardcode replace of the data of one file."
[id data]
@ -65,111 +134,90 @@
{:data data}
{:id id}))))
(defn- get-file*
"Get the migrated data of one file."
[system id]
(db/run! system
(fn [system]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer system id)]
(-> (files/get-file system id :migrate? false)
(update :data feat.fdata/process-pointers deref)
(update :data feat.fdata/process-objects (partial into {}))
(fmg/migrate-file))))))
(defn get-file
"Get the migrated data of one file."
[id]
(get-file* main/system id))
(defn validate
(defn validate-file
"Validate structure, referencial integrity and semantic coherence of
all contents of a file. Returns a list of errors."
[id]
(db/tx-run! main/system
(fn [{:keys [::db/conn] :as system}]
(let [id (if (string? id) (parse-uuid id) id)
file (get-file* system id)
file (get-file system id)
libs (->> (files/get-file-libraries conn id)
(into [file] (map (fn [{:keys [id]}]
(get-file* system id))))
(get-file system id))))
(d/index-by :id))]
(validate/validate-file file libs)))))
(defn repair!
(defn repair-file*
"Internal helper for validate and repair the file. The operation is
applied multiple times untile file is fixed or max iteration counter
is reached (default 10)"
[system id & {:keys [max-iterations] :or {max-iterations 10}}]
(let [id (parse-uuid id)
validate-and-repair
(fn [file libs iteration]
(when-let [errors (not-empty (validate/validate-file file libs))]
(l/trc :hint "repairing file"
:file-id (str id)
:iteration iteration
:errors (count errors))
(let [changes (repair/repair-file file libs errors)]
(-> file
(update :revn inc)
(update :data cpc/process-changes changes)))))
process-file
(fn [file libs]
(loop [file file
iteration 0]
(if (> iteration max-iterations)
(do
(l/wrn :hint "max retry num reached on repairing file"
:file-id (str id)
:iteration iteration)
file)
(if-let [file (validate-and-repair file libs iteration)]
(recur file (inc iteration))
file))))]
(db/tx-run! system
(fn [{:keys [::db/conn] :as system}]
(let [file (get-file system id)
libs (->> (files/get-file-libraries conn id)
(into [file] (map (fn [{:keys [id]}]
(get-file system id))))
(d/index-by :id))
file (process-file file libs)]
(update-file! system file))))))
(defn repair-file!
"Repair the list of errors detected by validation."
[id]
(db/tx-run! main/system
(fn [{:keys [::db/conn] :as system}]
(let [id (if (string? id) (parse-uuid id) id)
file (get-file* system id)
libs (->> (files/get-file-libraries conn id)
(into [file] (map (fn [{:keys [id]}]
(get-file* system id))))
(d/index-by :id))
errors (validate/validate-file file libs)
changes (repair/repair-file file libs errors)
[id & {:keys [rollback?] :or {rollback? true} :as opts}]
(let [system (or *system* (assoc main/system ::db/rollback rollback?))]
(repair-file* system id (dissoc opts :rollback?))))
file (-> file
(update :revn inc)
(update :data cpc/process-changes changes))
(defn process-file*
[system file-id update-fn]
(let [file (get-file system file-id)
file (-> (update-fn file)
(update :revn inc))]
file (if (contains? (:features file) "fdata/objects-map")
(feat.fdata/enable-objects-map file)
file)
(cfv/validate-file-schema! file)
(update-file! system file)
(dissoc file :data)))
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! system id)
file))
file)]
(db/update! conn :file
{:revn (:revn file)
:data (blob/encode (:data file))
:data-backend nil
:modified-at (dt/now)
:has-media-trimmed false}
{:id (:id file)})
:repaired))))
(defn update-file!
(defn process-file!
"Apply a function to the data of one file. Optionally save the changes or not.
The function receives the decoded and migrated file data."
[& {:keys [update-fn id rollback? inc-revn?]
:or {rollback? true inc-revn? true}}]
(letfn [(process-file [{:keys [::db/conn] :as system} file-id]
(let [file (get-file* system file-id)
file (cond-> (update-fn file)
inc-revn? (update :revn inc))
[& {:keys [update-fn id rollback?]
:or {rollback? true}}]
_ (cfv/validate-file-schema! file)
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! system id)
file))
file)]
(db/update! conn :file
{:data (blob/encode (:data file))
:features (db/create-array conn "text" (:features file))
:revn (:revn file)}
{:id (:id file)})
(dissoc file :data)))]
(db/tx-run! (or *system* (assoc main/system ::db/rollback rollback?))
(let [system (or *system* (assoc main/system ::db/rollback rollback?))]
(db/tx-run! system
(fn [system]
(binding [*system* system]
(process-file system id))))))
(process-file* system id update-fn))))))
(def ^:private sql:get-file-ids
@ -196,11 +244,11 @@
(strace/print-stack-trace cause))
(process-file [{:keys [::db/conn] :as system} file-id]
(let [file (get-file* system file-id)
(let [file (get-file system file-id)
libs (when with-libraries?
(->> (files/get-file-libraries conn file-id)
(into [file] (map (fn [{:keys [id]}]
(get-file* system id))))
(get-file system id))))
(d/index-by :id)))]
(try
(if with-libraries?
@ -220,38 +268,6 @@
(when (fn? on-end)
(ex/ignoring (on-end)))))))))
(defn repair-file-media
[{:keys [id data] :as file}]
(let [conn (db/get-connection *system*)
used (bfc/collect-used-media data)
ids (db/create-array conn "uuid" used)
sql (str "SELECT * FROM file_media_object WHERE id = ANY(?)")
rows (db/exec! conn [sql ids])
index (reduce (fn [index media]
(if (not= (:file-id media) id)
(let [media-id (uuid/next)]
(l/wrn :hint "found not referenced media"
:file-id (str id)
:media-id (str (:id media)))
(db/insert! *system* :file-media-object
(-> media
(assoc :file-id id)
(assoc :id media-id)))
(assoc index (:id media) media-id))
index))
{}
rows)]
(when (seq index)
(binding [bfc/*state* (atom {:index index})]
(update file :data (fn [fdata]
(-> fdata
(update :pages-index #'bfc/relink-shapes)
(update :components #'bfc/relink-shapes)
(update :media #'bfc/relink-media)
(d/without-nils))))))))
(defn process-files!
"Apply a function to all files in the database"
[& {:keys [max-items
@ -281,7 +297,7 @@
(l/trc :hint "process:file:start" :file-id (str file-id) :index idx)
(db/tx-run! (assoc main/system ::db/rollback rollback?)
(fn [{:keys [::db/conn] :as system}]
(let [file' (get-file* system file-id)
(let [file' (get-file system file-id)
file (binding [*system* system]
(on-file file'))]
@ -350,3 +366,37 @@
:rollback rollback?
:elapsed elapsed))))))
(defn repair-file-media
"A helper intended to be used with `process-files!` that fixes all
not propertly referenced file-media-object for a file"
[{:keys [id data] :as file}]
(let [conn (db/get-connection *system*)
used (bfc/collect-used-media data)
ids (db/create-array conn "uuid" used)
sql (str "SELECT * FROM file_media_object WHERE id = ANY(?)")
rows (db/exec! conn [sql ids])
index (reduce (fn [index media]
(if (not= (:file-id media) id)
(let [media-id (uuid/next)]
(l/wrn :hint "found not referenced media"
:file-id (str id)
:media-id (str (:id media)))
(db/insert! *system* :file-media-object
(-> media
(assoc :file-id id)
(assoc :id media-id)))
(assoc index (:id media) media-id))
index))
{}
rows)]
(when (seq index)
(binding [bfc/*state* (atom {:index index})]
(update file :data (fn [fdata]
(-> fdata
(update :pages-index #'bfc/relink-shapes)
(update :components #'bfc/relink-shapes)
(update :media #'bfc/relink-media)
(d/without-nils))))))))

View file

@ -19,7 +19,8 @@
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.features.fdata :as features.fdata]
[app.features.components-v2 :as feat.comp-v2]
[app.features.fdata :as feat.fdata]
[app.main :as main]
[app.msgbus :as mbus]
[app.rpc.commands.auth :as auth]
@ -38,7 +39,11 @@
[clojure.tools.namespace.repl :as repl]
[cuerdas.core :as str]))
(defn print-available-tasks
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TASKS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn print-tasks
[]
(let [tasks (:app.worker/registry main/system)]
(p/pprint (keys tasks) :level 200)))
@ -84,6 +89,10 @@
(auth/send-email-verification! pool sprops profile)
:email-sent))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PROFILES MANAGEMENT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn mark-profile-as-active!
"Mark the profile blocked and removes all the http sessiones
associated with the profile-id."
@ -121,19 +130,28 @@
(let [email (str/lower email)]
(db/exec! conn ["update profile set password=? where email=?" password email]))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FEATURES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn enable-objects-map-feature-on-file!
[& {:keys [save? id]}]
(h/update-file! main/system
:id id
:update-fn features.fdata/enable-objects-map
:save? save?))
(h/process-file! main/system
:id id
:update-fn feat.fdata/enable-objects-map
:save? save?))
(defn enable-pointer-map-feature-on-file!
[& {:keys [save? id]}]
(h/update-file! main/system
:id id
:update-fn features.fdata/enable-pointer-map
:save? save?))
(h/process-file! main/system
:id id
:update-fn feat.fdata/enable-pointer-map
:save? save?))
(defn enable-storage-features-on-file!
[& {:as params}]
(enable-objects-map-feature-on-file! main/system params)
(enable-pointer-map-feature-on-file! main/system params))
(defn enable-team-feature!
[team-id feature]
@ -171,57 +189,10 @@
{:id team-id})
:disabled))))))
(defn enable-storage-features-on-file!
[& {:as params}]
(enable-objects-map-feature-on-file! main/system params)
(enable-pointer-map-feature-on-file! main/system params))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; NOTIFICATIONS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn instrument-var
[var]
(alter-var-root var (fn [f]
(let [mf (meta f)]
(if (::original mf)
f
(with-meta
(fn [& params]
(tap> params)
(let [result (apply f params)]
(tap> result)
result))
{::original f}))))))
(defn uninstrument-var
[var]
(alter-var-root var (fn [f]
(or (::original (meta f)) f))))
(defn take-file-snapshot!
"An internal helper that persist the file snapshot using non-gc
collectable file-changes entry."
[& {:keys [file-id label]}]
(let [file-id (h/parse-uuid file-id)]
(db/tx-run! main/system fsnap/take-file-snapshot! {:file-id file-id :label label})))
(defn restore-file-snapshot!
[& {:keys [file-id id]}]
(db/tx-run! main/system
(fn [cfg]
(let [file-id (h/parse-uuid file-id)
id (h/parse-uuid id)]
(if (and (uuid? id) (uuid? file-id))
(fsnap/restore-file-snapshot! cfg {:id id :file-id file-id})
(println "=> invalid parameters"))))))
(defn list-file-snapshots!
[& {:keys [file-id limit]}]
(db/tx-run! main/system
(fn [system]
(let [params {:file-id (h/parse-uuid file-id)
:limit limit}]
(->> (fsnap/get-file-snapshots system (d/without-nils params))
(print-table [:id :revn :created-at :label]))))))
(defn notify!
[{:keys [::mbus/msgbus ::db/pool]} & {:keys [dest code message level]
@ -321,6 +292,121 @@
(into #{})
(run! send))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SNAPSHOTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn take-file-snapshot!
"An internal helper that persist the file snapshot using non-gc
collectable file-changes entry."
[& {:keys [file-id label]}]
(let [file-id (h/parse-uuid file-id)]
(db/tx-run! main/system fsnap/take-file-snapshot! {:file-id file-id :label label})))
(defn restore-file-snapshot!
[& {:keys [file-id id]}]
(db/tx-run! main/system
(fn [cfg]
(let [file-id (h/parse-uuid file-id)
id (h/parse-uuid id)]
(if (and (uuid? id) (uuid? file-id))
(fsnap/restore-file-snapshot! cfg {:id id :file-id file-id})
(println "=> invalid parameters"))))))
(defn list-file-snapshots!
[& {:keys [file-id limit]}]
(db/tx-run! main/system
(fn [system]
(let [params {:file-id (h/parse-uuid file-id)
:limit limit}]
(->> (fsnap/get-file-snapshots system (d/without-nils params))
(print-table [:id :revn :created-at :label]))))))
(defn take-team-snapshot!
[& {:keys [team-id label rollback?]
:or {rollback? true}}]
(let [team-id (h/parse-uuid team-id)
label (or label (fsnap/generate-snapshot-label))
take-snapshot
(fn [{:keys [::db/conn] :as system}]
(->> (feat.comp-v2/get-and-lock-team-files conn team-id)
(map (fn [file-id]
{:file-id file-id
:label label}))
(run! (partial fsnap/take-file-snapshot! system))))]
(-> (assoc main/system ::db/rollback rollback?)
(db/tx-run! take-snapshot))))
(def ^:private sql:snapshots-with-file
"WITH files AS (
SELECT f.id AS file_id,
(SELECT fc.id
FROM file_change AS fc
WHERE fc.label = ?
AND fc.file_id = f.id
ORDER BY fc.created_at DESC
LIMIT 1) AS id
FROM file AS f
) SELECT * FROM files
WHERE file_id = ANY(?)
AND id IS NOT NULL")
(defn restore-team-snapshot!
"Restore a snapshot on all files of the team. The snapshot should
exists for all files; if is not the case, an exception is raised."
[& {:keys [team-id label rollback?] :or {rollback? true}}]
(let [team-id (h/parse-uuid team-id)
get-file-snapshots
(fn [conn ids]
(db/exec! conn [sql:snapshots-with-file label
(db/create-array conn "uuid" ids)]))
restore-snapshot
(fn [{:keys [::db/conn] :as system}]
(let [ids (->> (feat.comp-v2/get-and-lock-team-files conn team-id)
(into #{}))
snap (get-file-snapshots conn ids)
ids' (into #{} (map :file-id) snap)
team (-> (feat.comp-v2/get-team conn team-id)
(update :features disj "components/v2"))]
(when (not= ids ids')
(throw (RuntimeException. "no uniform snapshot available")))
(feat.comp-v2/update-team! conn team)
(run! (partial fsnap/restore-file-snapshot! system) snap)))]
(-> (assoc main/system ::db/rollback rollback?)
(db/tx-run! restore-snapshot))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MISC
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn instrument-var
[var]
(alter-var-root var (fn [f]
(let [mf (meta f)]
(if (::original mf)
f
(with-meta
(fn [& params]
(tap> params)
(let [result (apply f params)]
(tap> result)
result))
{::original f}))))))
(defn uninstrument-var
[var]
(alter-var-root var (fn [f]
(or (::original (meta f)) f))))
(defn duplicate-team
[team-id & {:keys [name]}]
(let [team-id (h/parse-uuid team-id)]
@ -337,4 +423,3 @@
(assoc :team-id (:id team)))]
(db/insert! conn :team-profile-rel params
{::db/return-keys false}))))))))