From acd6e049c4628f595546a750d83bd9097829b929 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 21 Jan 2022 12:01:29 -0600 Subject: [PATCH] Add progress bar to migration and add prompt to begin migration. --- .../U/Codebase/Sqlite/Queries.hs | 17 +++++++ .../src/Unison/Codebase/SqliteCodebase.hs | 6 ++- .../SqliteCodebase/MigrateSchema12.hs | 46 ++++++++++++++----- 3 files changed, 56 insertions(+), 13 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 492d1233b..984669ad8 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -112,6 +112,11 @@ module U.Codebase.Sqlite.Queries ( garbageCollectObjectsWithoutHashes, garbageCollectWatchesWithoutObjects, + -- migrations + countObjects, + countCausals, + countWatches, + -- * db misc createSchema, schemaVersion, @@ -279,6 +284,18 @@ setSchemaVersion schemaVersion = execute sql (Only schemaVersion) SET version = ? |] +countObjects :: DB m => m Int +countObjects = head <$> queryAtoms_ sql + where sql = [here| SELECT COUNT(*) FROM object |] + +countCausals :: DB m => m Int +countCausals = head <$> queryAtoms_ sql + where sql = [here| SELECT COUNT(*) FROM causal |] + +countWatches :: DB m => m Int +countWatches = head <$> queryAtoms_ sql + where sql = [here| SELECT COUNT(*) FROM watch |] + saveHash :: DB m => Base32Hex -> m HashId saveHash base32 = execute sql (Only base32) >> queryOne (loadHashId base32) where sql = [here| diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index befccabdf..5f3d0017b 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -839,13 +839,17 @@ sqliteCodebase debugName root localOrRemote action = do (`finally` finalizer) $ runReaderT Q.schemaVersion conn >>= \case SchemaVersion 2 -> Right <$> action codebase SchemaVersion 1 -> do + liftIO $ putStrLn ("Migrating from schema version 1 -> 2.") case localOrRemote of Local -> liftIO do backupPath <- backupCodebasePath <$> getPOSIXTime copyFile (root codebasePath) (root backupPath) -- FIXME prettify - putStrLn ("I backed up your codebase to " ++ (root backupPath)) + putStrLn ("📋 I backed up your codebase to " ++ (root backupPath)) + putStrLn "⚠️ Please close all other ucm processes and wait for the migration to complete before interacting with your codebase." + putStrLn "Press to start the migration once all other ucm processes are shutdown..." + void $ liftIO getLine Remote -> pure () migrateSchema12 conn codebase -- it's ok to pass codebase along; whatever it cached during the migration won't break anything diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/MigrateSchema12.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/MigrateSchema12.hs index 467413594..10b254203 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/MigrateSchema12.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/MigrateSchema12.hs @@ -24,6 +24,8 @@ import qualified Data.Set as Set import Data.Tuple (swap) import Data.Tuple.Extra ((***)) import qualified Data.Zip as Zip +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO) import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..)) import qualified U.Codebase.Reference as UReference import qualified U.Codebase.Referent as UReferent @@ -104,18 +106,26 @@ import UnliftIO.Exception (bracket_, onException) -- * [x] Update the schema version in the database after migrating so we only migrate -- once. +verboseOutput :: Bool +verboseOutput = + isJust (unsafePerformIO (lookupEnv "UNISON_MIGRATION_DEBUG")) +{-# NOINLINE verboseOutput #-} + migrateSchema12 :: forall a m v. (MonadUnliftIO m, Var v) => Connection -> Codebase m v a -> m () migrateSchema12 conn codebase = do withinSavepoint "MIGRATESCHEMA12" $ do + liftIO $ putStrLn $ "Starting codebase migration, this may take a while." rootCausalHashId <- runDB conn (liftQ Q.loadNamespaceRoot) + numEntitiesToMigrate <- runDB conn . liftQ $ do + sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches] watches <- foldMapM (\watchKind -> map (W watchKind) <$> Codebase.watches codebase (Cv.watchKind2to1 watchKind)) [WK.RegularWatch, WK.TestWatch] migrationState <- - (Sync.sync @_ @Entity migrationSync progress (CausalE rootCausalHashId : watches)) + (Sync.sync @_ @Entity migrationSync (progress numEntitiesToMigrate) (CausalE rootCausalHashId : watches)) `runReaderT` Env {db = conn, codebase} - `execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty + `execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId liftIO $ putStrLn $ "Updating Namespace Root..." runDB conn . liftQ $ Q.setNamespaceRoot newRootCausalHashId @@ -138,17 +148,28 @@ migrateSchema12 conn codebase = do (runDB conn $ Q.savepoint name) (runDB conn $ Q.release name) (act `onException` runDB conn (Q.rollbackTo name)) - progress :: Sync.Progress (ReaderT (Env m v a) (StateT MigrationState m)) Entity - progress = - let need :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) () - need e = liftIO $ putStrLn $ "Need: " ++ show e + progress :: Int -> Sync.Progress (ReaderT (Env m v a) (StateT MigrationState m)) Entity + progress numToMigrate = + let incrementProgress :: ReaderT (Env m v a) (StateT MigrationState m) () + incrementProgress = do + numDone <- field @"numMigrated" <+= 1 + liftIO $ putStr $ "\r 🏗 " <> show numDone <> " / ~" <> show numToMigrate <> " entities migrated. 🚧" + need :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) () + need e = when verboseOutput $ liftIO $ putStrLn $ "Need: " ++ show e done :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) () - done e = liftIO $ putStrLn $ "Done: " ++ show e - error :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) () - error e = liftIO $ putStrLn $ "Error: " ++ show e + done e = do + when verboseOutput $ liftIO $ putStrLn $ "Done: " ++ show e + incrementProgress + errorHandler :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) () + errorHandler e = do + case e of + -- We expect non-fatal errors when migrating watches. + W {} -> pure () + e -> liftIO $ putStrLn $ "Error: " ++ show e + incrementProgress allDone :: ReaderT (Env m v a) (StateT MigrationState m) () - allDone = liftIO $ putStrLn $ "Finished migrating, initiating cleanup." - in Sync.Progress {need, done, error, allDone} + allDone = liftIO $ putStrLn $ "\nFinished migrating, initiating cleanup.\n This will take a moment..." + in Sync.Progress {need, done, error = errorHandler, allDone} type Old a = a @@ -166,7 +187,8 @@ data MigrationState = MigrationState -- convert Object Reference IDs into Hash Reference IDs so we can use the referenceMapping. objLookup :: Map (Old ObjectId) (New ObjectId, New HashId, New Hash, Old Hash), -- Remember the hashes of term/decls that we have already migrated to avoid migrating them twice. - migratedDefnHashes :: Set (Old Hash) + migratedDefnHashes :: Set (Old Hash), + numMigrated :: Int } deriving (Generic)