🎉 Add migration scripts

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)))))))
+
+

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))))))))

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