diff --git a/backend/src/app/features/components_v2.clj b/backend/src/app/features/components_v2.clj index f0748e1a7..15017d298 100644 --- a/backend/src/app/features/components_v2.clj +++ b/backend/src/app/features/components_v2.clj @@ -619,6 +619,7 @@ (assoc :elapsed/total-by-file total) (assoc :processed/files completed))))))))))) + (defn migrate-team! [system team-id] (let [tpoint (dt/tpoint) @@ -627,14 +628,22 @@ team-id)] (l/dbg :hint "migrate:team:start" :team-id (dm/str team-id)) (try + ;; We execute this out of transaction because we want this + ;; change to be visible to all other sessions before starting + ;; the migration + (let [sql (str "UPDATE team SET features = " + " array_append(features, 'ephimeral/v2-migration') " + " WHERE id = ?")] + (db/exec-one! system [sql team-id])) + (db/tx-run! system (fn [{:keys [::db/conn] :as system}] ;; Lock the team (db/exec-one! conn ["SET idle_in_transaction_session_timeout = 0"]) - (db/exec-one! conn ["UPDATE team SET features = array_append(features, 'ephimeral/v2-migration') WHERE id = ?" team-id]) (let [{:keys [features] :as team} (-> (db/get conn :team {:id team-id}) (update :features db/decode-pgarray #{}))] + (if (contains? features "components/v2") (l/dbg :hint "team already migrated") (let [sql (str/concat @@ -650,6 +659,7 @@ (some-> *stats* (swap! assoc :current/files (count rows))) (let [features (-> features + (disj "ephimeral/v2-migration") (conj "components/v2") (conj "layout/grid") (conj "styles/v2"))] @@ -660,10 +670,6 @@ (some-> *semaphore* ps/release!) (let [elapsed (tpoint) stats (some-> *stats* deref)] - (l/dbg :hint "migrate:team:end" - :team-id (dm/str team-id) - :files (:current/files stats 0) - :elapsed (dt/format-duration elapsed)) (when (some? *stats*) (swap! *stats* (fn [stats] (let [elapsed (inst-ms elapsed) @@ -674,4 +680,19 @@ (update :elapsed/max-by-team (fnil max 0) elapsed) (assoc :elapsed/avg-by-team avg) (assoc :elapsed/total-by-team total) - (assoc :processed/teams completed))))))))))) + (assoc :processed/teams completed)))))) + + ;; We execute this out of transaction because we want this + ;; change to be visible to all other sessions before starting + ;; the migration + (let [sql (str "UPDATE team SET features = " + " array_remove(features, 'ephimeral/v2-migration') " + " WHERE id = ?")] + (db/exec-one! system [sql team-id])) + + (l/dbg :hint "migrate:team:end" + :team-id (dm/str team-id) + :files (:current/files stats 0) + :elapsed (dt/format-duration elapsed))))))) + + diff --git a/backend/src/app/srepl/components_v2.clj b/backend/src/app/srepl/components_v2.clj new file mode 100644 index 000000000..2b709b627 --- /dev/null +++ b/backend/src/app/srepl/components_v2.clj @@ -0,0 +1,271 @@ +;; 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.srepl.components-v2 + (:require + [app.common.data :as d] + [app.common.data.macros :as dm] + [app.common.logging :as l] + [app.common.pprint :as pp] + [app.db :as db] + [app.features.components-v2 :as feat] + [app.util.time :as dt] + [cuerdas.core :as str] + [promesa.core :as p] + [promesa.exec :as px] + [promesa.exec.semaphore :as ps] + [promesa.util :as pu])) + +(defn- print-stats! + [stats] + (let [stats (-> stats + (d/update-when :elapsed/max-by-team (comp dt/format-duration dt/duration int)) + (d/update-when :elapsed/avg-by-team (comp dt/format-duration dt/duration int)) + (d/update-when :elapsed/total-by-team (comp dt/format-duration dt/duration int)) + (d/update-when :elapsed/max-by-file (comp dt/format-duration dt/duration int)) + (d/update-when :elapsed/avg-by-file (comp dt/format-duration dt/duration int)) + (d/update-when :elapsed/total-by-file (comp dt/format-duration dt/duration int)) + )] + (->> stats + (into (sorted-map)) + (pp/pprint)))) + +(defn- report-progress-files + [tpoint] + (fn [_ _ oldv newv] + (when (not= (:processed/files oldv) + (:processed/files newv)) + (let [total (:total/files newv) + completed (:processed/files newv) + progress (/ (* completed 100.0) total) + elapsed (tpoint)] + (l/trc :hint "progress" + :completed (:processed/files newv) + :total (:total/files newv) + :progress (str (int progress) "%") + :elapsed (dt/format-duration elapsed)))))) + +(defn- report-progress-teams + [tpoint] + (fn [_ _ oldv newv] + (when (not= (:processed/teams oldv) + (:processed/teams newv)) + (let [total (:total/teams newv) + completed (:processed/teams newv) + progress (/ (* completed 100.0) total) + elapsed (tpoint)] + (l/trc :hint "progress" + :completed (:processed/teams newv) + :progress (str (int progress) "%") + :elapsed (dt/format-duration elapsed)))))) + +(defn- get-total-files + [pool & {:keys [team-id]}] + (if (some? team-id) + (let [sql (str/concat + "SELECT count(f.id) AS count FROM file AS f " + " JOIN project AS p ON (p.id = f.project_id) " + " WHERE p.team_id = ? AND f.deleted_at IS NULL " + " AND p.deleted_at IS NULL") + res (db/exec-one! pool [sql team-id])] + (:count res)) + + (let [sql (str/concat + "SELECT count(id) AS count FROM file " + " WHERE deleted_at IS NULL") + res (db/exec-one! pool [sql])] + (:count res)))) + +(defn- get-total-teams + [pool] + (let [sql (str/concat + "SELECT count(id) AS count FROM team " + " WHERE deleted_at IS NULL") + res (db/exec-one! pool [sql])] + (:count res))) + +(defn migrate-file! + [system file-id & {:keys [rollback] :or {rollback true}}] + + (l/dbg :hint "migrate:start") + (let [tpoint (dt/tpoint)] + (try + (binding [feat/*stats* (atom {})] + (-> (assoc system ::db/rollback rollback) + (feat/migrate-file! file-id)) + (-> (deref feat/*stats*) + (assoc :elapsed (dt/format-duration (tpoint))) + (dissoc :current/graphics) + (dissoc :current/components) + (dissoc :current/files))) + + (catch Throwable cause + (l/dbg :hint "migrate:error" :cause cause)) + + (finally + (let [elapsed (dt/format-duration (tpoint))] + (l/dbg :hint "migrate:end" :elapsed elapsed)))))) + +(defn migrate-files! + [{:keys [::db/pool] :as system} & {:keys [chunk-size max-jobs max-items start-at preset rollback skip-on-error] + :or {chunk-size 10 + skip-on-error true + max-jobs 10 + max-items Long/MAX_VALUE + preset :shutdown-on-failure + rollback true}}] + (letfn [(get-chunk [cursor] + (let [sql (str/concat + "SELECT id, created_at FROM file " + " WHERE created_at < ? AND deleted_at IS NULL " + " ORDER BY created_at desc LIMIT ?") + rows (db/exec! pool [sql cursor chunk-size])] + [(some->> rows peek :created-at) (seq rows)])) + + (get-candidates [] + (->> (d/iteration get-chunk + :vf second + :kf first + :initk (or start-at (dt/now))) + (take max-items) + (map :id)))] + + (l/dbg :hint "migrate:start") + (let [fsem (ps/create :permits max-jobs) + total (get-total-files pool) + stats (atom {:files/total total}) + tpoint (dt/tpoint)] + + (add-watch stats :progress-report (report-progress-files tpoint)) + + (binding [feat/*stats* stats + feat/*semaphore* fsem + feat/*skip-on-error* skip-on-error] + (try + (pu/with-open [scope (px/structured-task-scope :preset preset :factory :virtual)] + + (run! (fn [file-id] + (ps/acquire! feat/*semaphore*) + (px/submit! scope (fn [] + (-> (assoc system ::db/rollback rollback) + (feat/migrate-file! file-id))))) + (get-candidates)) + + (p/await! scope)) + + (-> (deref feat/*stats*) + (assoc :elapsed (dt/format-duration (tpoint))) + (dissoc :current/graphics) + (dissoc :current/components) + (dissoc :current/files)) + + (catch Throwable cause + (l/dbg :hint "migrate:error" :cause cause)) + + (finally + (let [elapsed (dt/format-duration (tpoint))] + (l/dbg :hint "migrate:end" :elapsed elapsed)))))))) + +(defn migrate-team! + [{:keys [::db/pool] :as system} team-id + & {:keys [rollback skip-on-error] + :or {rollback true skip-on-error true}}] + (l/dbg :hint "migrate:start") + + (let [total (get-total-files pool :team-id team-id) + stats (atom {:total/files total}) + tpoint (dt/tpoint)] + + (add-watch stats :progress-report (report-progress-files tpoint)) + + (try + (binding [feat/*stats* stats + feat/*skip-on-error* skip-on-error] + (-> (assoc system ::db/rollback rollback) + (feat/migrate-team! team-id)) + + (print-stats! + (-> (deref feat/*stats*) + (dissoc :total/files) + (dissoc :current/graphics) + (dissoc :current/components) + (dissoc :current/files)))) + + (catch Throwable cause + (l/dbg :hint "migrate:error" :cause cause)) + + (finally + (let [elapsed (dt/format-duration (tpoint))] + (l/dbg :hint "migrate:end" :elapsed elapsed)))))) + +(defn migrate-teams! + [{:keys [::db/pool] :as system} + & {:keys [chunk-size max-jobs max-items start-at rollback preset skip-on-error] + :or {chunk-size 10000 + rollback true + skip-on-error true + preset :shutdown-on-failure + max-jobs Integer/MAX_VALUE + max-items Long/MAX_VALUE}}] + (letfn [(get-chunk [cursor] + (let [sql (str/concat + "SELECT id, created_at, features FROM team " + " WHERE created_at < ? AND deleted_at IS NULL " + " ORDER BY created_at desc LIMIT ?") + rows (db/exec! pool [sql cursor chunk-size])] + [(some->> rows peek :created-at) (seq rows)])) + + (get-candidates [] + (->> (d/iteration get-chunk + :vf second + :kf first + :initk (or start-at (dt/now))) + (map #(update % :features db/decode-pgarray #{})) + (remove #(contains? (:features %) "ephimeral/v2-migration")) + (take max-items) + (map :id)))] + + (l/dbg :hint "migrate:start") + + (let [sem (ps/create :permits max-jobs) + total (get-total-teams pool) + stats (atom {:total/teams (min total max-items)}) + tpoint (dt/tpoint)] + + (add-watch stats :progress-report (report-progress-teams tpoint)) + + (binding [feat/*stats* stats + feat/*semaphore* sem + feat/*skip-on-error* skip-on-error] + (try + (pu/with-open [scope (px/structured-task-scope :preset preset + :factory :virtual)] + (run! (fn [team-id] + (l/trc :hint "scheduling task" :team-id (dm/str team-id)) + (ps/acquire! sem) + (px/submit! scope (fn [] + (try + (-> (assoc system ::db/rollback rollback) + (feat/migrate-team! team-id)) + (catch Throwable cause + (l/err :hint "unexpected error on processing team" :team-id (dm/str team-id) :cause cause)))))) + + (get-candidates)) + (p/await! scope)) + + (print-stats! + (-> (deref feat/*stats*) + (dissoc :total/teams) + (dissoc :current/graphics) + (dissoc :current/components) + (dissoc :current/files))) + + (catch Throwable cause + (l/dbg :hint "migrate:error" :cause cause)) + + (finally + (let [elapsed (dt/format-duration (tpoint))] + (l/dbg :hint "migrate:end" :elapsed elapsed)))))))) diff --git a/common/src/app/common/types/file.cljc b/common/src/app/common/types/file.cljc index f90d991a6..ad0e42e4b 100644 --- a/common/src/app/common/types/file.cljc +++ b/common/src/app/common/types/file.cljc @@ -369,273 +369,6 @@ (let [library-page (ctp/make-empty-page (uuid/next) "Library backup")] [(ctpl/add-page file-data library-page) (:id library-page) (gpt/point 0 0)])))) -(declare preprocess-file) - -(defn migrate-to-components-v2 - "If there is any component in the file library, add a new 'Library backup', generate - main instances for all components there and remove shapes from library components. - Mark the file with the :components-v2 option." - [file-data libraries] - (let [migrated? (dm/get-in file-data [:options :components-v2])] - (if migrated? - file-data - (let [components (ctkl/components-seq file-data)] - (if (empty? components) - (assoc-in file-data [:options :components-v2] true) - (let [grid-gap 50 - - [file-data page-id start-pos] - (get-or-add-library-page file-data grid-gap) - - migrate-component-shape - (fn [shape delta component-file component-id] - (cond-> shape - (nil? (:parent-id shape)) - (assoc :parent-id uuid/zero - :main-instance true - :component-root true - :component-file component-file - :component-id component-id - :type :frame ; Old groups must be converted - :fills [] ; to frames and conform to spec - :hide-in-viewer true - :rx 0 - :ry 0) - - - (nil? (:frame-id shape)) - (assoc :frame-id uuid/zero) - - :always - (gsh/move delta))) - - add-main-instance - (fn [file-data component position] - (let [shapes (cph/get-children-with-self (:objects component) - (:id component)) - - root-shape (first shapes) - orig-pos (gpt/point (:x root-shape) (:y root-shape)) - delta (gpt/subtract position orig-pos) - - xf-shape (map #(migrate-component-shape % - delta - (:id file-data) - (:id component))) - new-shapes - (into [] xf-shape shapes) - - add-shapes - (fn [page] - (reduce (fn [page shape] - (ctst/add-shape (:id shape) - shape - page - (:frame-id shape) - (:parent-id shape) - nil ; <- As shapes are ordered, we can safely add each - true)) ; one at the end of the parent's children list. - page - new-shapes)) - - update-component - (fn [component] - (-> component - (assoc :main-instance-id (:id root-shape) - :main-instance-page page-id) - (dissoc :objects)))] - - (-> file-data - (ctpl/update-page page-id add-shapes) - (ctkl/update-component (:id component) update-component)))) - - add-instance-grid - (fn [file-data] - (let [components (->> file-data - (ctkl/components-seq) - (sort-by :name) - (reverse)) - position-seq (ctst/generate-shape-grid - (map (partial get-component-root file-data) components) - start-pos - grid-gap)] - (loop [file-data file-data - components-seq (seq components) - position-seq position-seq] - (let [component (first components-seq) - position (first position-seq)] - (if (nil? component) - file-data - (recur (add-main-instance file-data component position) - (rest components-seq) - (rest position-seq)))))))] - - (-> file-data - (preprocess-file libraries) - (add-instance-grid) - (assoc-in [:options :components-v2] true)))))))) - -(defn- preprocess-file - "Apply some specific migrations or fixes to things that are allowed in v1 but not in v2, - or that are the result of old bugs." - [file-data libraries] - (let [detached-ids (volatile! #{}) - - detach-shape - (fn [container shape] - ; Detach a shape. If it's inside a component, add it to detached-ids, for further use. - (let [is-component? (let [root-shape (ctst/get-shape container (:id container))] - (and (some? root-shape) (nil? (:parent-id root-shape))))] - (when is-component? - (vswap! detached-ids conj (:id shape))) - (ctk/detach-shape shape))) - - fix-orphan-shapes - (fn [file-data] - ; Find shapes that are not listed in their parent's children list. - ; Remove them, and also their children - (letfn [(fix-container [container] - (reduce fix-shape container (ctn/shapes-seq container))) - - (fix-shape - [container shape] - (if-not (or (= (:id shape) uuid/zero) - (nil? (:parent-id shape))) - (let [parent (ctst/get-shape container (:parent-id shape)) - exists? (d/index-of (:shapes parent) (:id shape))] - (if (nil? exists?) - (let [ids (cph/get-children-ids-with-self (:objects container) (:id shape))] - (update container :objects #(reduce dissoc % ids))) - container)) - container))] - - (-> file-data - (update :pages-index update-vals fix-container) - (update :components update-vals fix-container)))) - - remove-nested-roots - (fn [file-data] - ; Remove :component-root in head shapes that are nested. - (letfn [(fix-container [container] - (update container :objects update-vals (partial fix-shape container))) - - (fix-shape [container shape] - (let [parent (ctst/get-shape container (:parent-id shape))] - (if (and (ctk/instance-root? shape) - (ctn/in-any-component? (:objects container) parent)) - (dissoc shape :component-root) - shape)))] - - (-> file-data - (update :pages-index update-vals fix-container) - (update :components update-vals fix-container)))) - - add-not-nested-roots - (fn [file-data] - ; Add :component-root in head shapes that are not nested. - (letfn [(fix-container [container] - (update container :objects update-vals (partial fix-shape container))) - - (fix-shape [container shape] - (let [parent (ctst/get-shape container (:parent-id shape))] - (if (and (ctk/subinstance-head? shape) - (not (ctn/in-any-component? (:objects container) parent))) - (assoc shape :component-root true) - shape)))] - - (-> file-data - (update :pages-index update-vals fix-container) - (update :components update-vals fix-container)))) - - fix-orphan-copies - (fn [file-data] - ; Detach shapes that were inside a copy (have :shape-ref) but now they aren't. - (letfn [(fix-container [container] - (update container :objects update-vals (partial fix-shape container))) - - (fix-shape [container shape] - (let [parent (ctst/get-shape container (:parent-id shape))] - (if (and (ctk/in-component-copy? shape) - (not (ctk/instance-head? shape)) - (not (ctk/in-component-copy? parent))) - (detach-shape container shape) - shape)))] - - (-> file-data - (update :pages-index update-vals fix-container) - (update :components update-vals fix-container)))) - - remap-refs - (fn [file-data] - ; Remap shape-refs so that they point to the near main. - ; At the same time, if there are any dangling ref, detach the shape and its children. - (letfn [(fix-container [container] - (reduce fix-shape container (ctn/shapes-seq container))) - - (fix-shape - [container shape] - (if (ctk/in-component-copy? shape) - ; First look for the direct shape. - (let [root (ctn/get-component-shape (:objects container) shape) - libraries (assoc-in libraries [(:id file-data) :data] file-data) - library (get libraries (:component-file root)) - component (ctkl/get-component (:data library) (:component-id root) true) - direct-shape (get-component-shape (:data library) component (:shape-ref shape))] - (if (some? direct-shape) - ; If it exists, there is nothing else to do. - container - ; If not found, find the near shape. - (let [near-shape (d/seek #(= (:shape-ref %) (:shape-ref shape)) - (get-component-shapes (:data library) component))] - (if (some? near-shape) - ; If found, update the ref to point to the near shape. - (ctn/update-shape container (:id shape) #(assoc % :shape-ref (:id near-shape))) - ; If not found, it may be a fostered component. Try to locate a direct shape - ; in the head component. - (let [head (ctn/get-head-shape (:objects container) shape) - library-2 (get libraries (:component-file head)) - component-2 (ctkl/get-component (:data library-2) (:component-id head) true) - direct-shape-2 (get-component-shape (:data library-2) component-2 (:shape-ref shape))] - (if (some? direct-shape-2) - ; If it exists, there is nothing else to do. - container - ; If not found, detach shape and all children (stopping if a nested instance is reached) - (let [children (ctn/get-children-in-instance (:objects container) (:id shape))] - (reduce #(ctn/update-shape %1 (:id %2) (partial detach-shape %1)) - container - children)))))))) - container))] - - (-> file-data - (update :pages-index update-vals fix-container) - (update :components update-vals fix-container)))) - - fix-copies-of-detached - (fn [file-data] - ; Find any copy that is referencing a detached shape inside a component, and - ; undo the nested copy, converting it into a direct copy. - (letfn [(fix-container [container] - (update container :objects update-vals fix-shape)) - - (fix-shape [shape] - (cond-> shape - (@detached-ids (:shape-ref shape)) - (dissoc shape - :component-id - :component-file - :component-root)))] - (-> file-data - (update :pages-index update-vals fix-container) - (update :components update-vals fix-container))))] - - (-> file-data - (fix-orphan-shapes) - (remove-nested-roots) - (add-not-nested-roots) - (fix-orphan-copies) - (remap-refs) - (fix-copies-of-detached)))) - (defn- absorb-components [file-data used-components library-data] (let [grid-gap 50