From 4cc93a3632af5ebbc950ca78458ff6a1762cb759 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 13 Jun 2024 15:20:15 -0700 Subject: [PATCH] Remove migrations which are more than a year old. --- .../src/Unison/Codebase/SqliteCodebase.hs | 4 +- .../Codebase/SqliteCodebase/Migrations.hs | 110 +-- .../Migrations/MigrateSchema1To2.hs | 873 ------------------ .../Migrations/MigrateSchema3To4.hs | 343 ------- .../Migrations/MigrateSchema5To6.hs | 64 -- .../Migrations/MigrateSchema6To7.hs | 77 -- .../Migrations/MigrateSchema7To8.hs | 134 --- .../unison-parser-typechecker.cabal | 5 - 8 files changed, 16 insertions(+), 1594 deletions(-) delete mode 100644 parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema5To6.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema7To8.hs diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 18f21330e2..e19c713e65 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -185,10 +185,10 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action DontMigrate -> pure $ Left (OpenCodebaseRequiresMigration fromSv toSv) MigrateAfterPrompt backupStrategy vacuumStrategy -> do let shouldPrompt = True - Migrations.ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer shouldPrompt backupStrategy vacuumStrategy conn + Migrations.ensureCodebaseIsUpToDate localOrRemote root shouldPrompt backupStrategy vacuumStrategy conn MigrateAutomatically backupStrategy vacuumStrategy -> do let shouldPrompt = False - Migrations.ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer shouldPrompt backupStrategy vacuumStrategy conn + Migrations.ensureCodebaseIsUpToDate localOrRemote root shouldPrompt backupStrategy vacuumStrategy conn case result of Left err -> pure $ Left err diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index 68dc7c0a9f..308f679e3e 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -3,77 +3,31 @@ module Unison.Codebase.SqliteCodebase.Migrations where import Control.Concurrent.MVar -import Control.Concurrent.STM (TVar) import Control.Monad.Reader import Data.Map qualified as Map -import Data.Text qualified as Text import Data.Time.Clock.POSIX (getPOSIXTime) import System.Console.Regions qualified as Region import System.FilePath (()) -import Text.Printf (printf) -import U.Codebase.Reference qualified as C.Reference -import U.Codebase.Sqlite.DbId (HashVersion (..), SchemaVersion (..)) +import U.Codebase.Sqlite.DbId (SchemaVersion (..)) import U.Codebase.Sqlite.Queries qualified as Q import Unison.Codebase (CodebasePath) import Unison.Codebase.Init (BackupStrategy (..), VacuumStrategy (..)) import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (OpenCodebaseUnknownSchemaVersion)) import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase -import Unison.Codebase.IntegrityCheck (IntegrityResult (..), integrityCheckAllBranches, integrityCheckAllCausals, prettyPrintIntegrityErrors) -import Unison.Codebase.SqliteCodebase.Migrations.Helpers (abortMigration) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12 (migrateSchema11To12) -import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 (migrateSchema1To2) -import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4) -import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema5To6 (migrateSchema5To6) -import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema6To7 (migrateSchema6To7) -import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema7To8 (migrateSchema7To8) -import Unison.Codebase.SqliteCodebase.Operations qualified as Ops2 import Unison.Codebase.SqliteCodebase.Paths (backupCodebasePath) import Unison.Codebase.Type (LocalOrRemote (..)) -import Unison.ConstructorType qualified as CT -import Unison.Hash (Hash) import Unison.Prelude import Unison.Sqlite qualified as Sqlite import Unison.Sqlite.Connection qualified as Sqlite.Connection -import Unison.Util.Monoid (foldMapM) -import Unison.Util.Monoid qualified as Monoid -import Unison.Util.Pretty qualified as Pretty import UnliftIO qualified -- | Mapping from schema version to the migration required to get there. -- E.g. The migration at index 2 must be run on a codebase at version 1. -migrations :: - -- | A 'getDeclType'-like lookup, possibly backed by a cache. - (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> - TVar (Map Hash Ops2.TermBufferEntry) -> - TVar (Map Hash Ops2.DeclBufferEntry) -> - CodebasePath -> - Map SchemaVersion (Sqlite.Transaction ()) -migrations getDeclType termBuffer declBuffer rootCodebasePath = +migrations :: Map SchemaVersion (Sqlite.Transaction ()) +migrations = Map.fromList - [ (2, migrateSchema1To2 getDeclType termBuffer declBuffer), - -- The 1 to 2 migration kept around hash objects of hash version 1, unfortunately this - -- caused an issue: - -- - -- The migration would detect causals whose value hash did not have a corresponding branch - -- object, this was caused by a race-condition in sync which could end up in a partial sync. - -- When a branch object was determined to be missing, the migration would replace it with the - -- empty branch. This worked well, but led to a situation where related parent or successors - -- of that causal would have their hash objects mapped to the new v2 object which contained - -- the empty branch in place of missing branches. This is fine, but, if a different codebase - -- migrated the same branch and wasn't missing the branch in question it would migrate - -- successfully and each database now have the same v1 hash object mapped to two distinct v2 - -- objects, which rightfully causes a crash when syncing. - -- - -- This migration drops all the v1 hash objects to avoid this issue, since these hash objects - -- weren't being used for anything anyways. - sqlMigration 3 (Q.removeHashObjectsByHashingVersion (HashVersion 1)), - (4, migrateSchema3To4), - -- The 4 to 5 migration adds initial support for out-of-order sync i.e. Unison Share - sqlMigration 5 Q.addTempEntityTables, - (6, migrateSchema5To6 rootCodebasePath), - (7, migrateSchema6To7), - (8, migrateSchema7To8), - -- Recreates the name lookup tables because the primary key was missing the root hash id. + [ -- Recreates the name lookup tables because the primary key was missing the root hash id. sqlMigration 9 Q.fixScopedNameLookupTables, sqlMigration 10 Q.addProjectTables, sqlMigration 11 Q.addMostRecentBranchTable, @@ -120,16 +74,12 @@ ensureCodebaseIsUpToDate :: (MonadIO m) => LocalOrRemote -> CodebasePath -> - -- | A 'getDeclType'-like lookup, possibly backed by a cache. - (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> - TVar (Map Hash Ops2.TermBufferEntry) -> - TVar (Map Hash Ops2.DeclBufferEntry) -> Bool -> BackupStrategy -> VacuumStrategy -> Sqlite.Connection -> m (Either Codebase.OpenCodebaseError ()) -ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer shouldPrompt backupStrategy vacuumStrategy conn = +ensureCodebaseIsUpToDate localOrRemote root shouldPrompt backupStrategy vacuumStrategy conn = (liftIO . UnliftIO.try) do regionVar <- newEmptyMVar let finalizeRegion :: IO () @@ -140,7 +90,7 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh Region.displayConsoleRegions do (`UnliftIO.finally` finalizeRegion) do - let migs = migrations getDeclType termBuffer declBuffer root + let migs = migrations -- The highest schema that this ucm knows how to migrate to. let highestKnownSchemaVersion = fst . head $ Map.toDescList migs currentSchemaVersion <- Sqlite.runTransaction conn Q.schemaVersion @@ -153,51 +103,19 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer sh Sqlite.runWriteTransaction conn \run -> do -- Get the schema version again now that we're in a transaction. currentSchemaVersion <- run Q.schemaVersion + case Map.minViewWithKey migrations of + Nothing -> error "No migrations found" + Just ((minMigrationVersion, _), _) -> do + when (currentSchemaVersion < (minMigrationVersion - 1)) do + putStrLn $ "šŸšØ Your codebase is at schema version " <> show currentSchemaVersion <> " but this UCM binary only knows how to migrate from codebases of at least version " <> show (minMigrationVersion - 1) + putStrLn $ "šŸšØ You may need to find a slightly older version of the UCM binary to bridge the gap. Please file an issue or contact the Unison team for help." + error $ "Migration aborted." + let migrationsToRun = Map.filterWithKey (\v _ -> v > currentSchemaVersion) migs - -- This is a bit of a hack, hopefully we can remove this when we have a more - -- reliable way to freeze old migration code in time. - -- The problem is that 'saveObject' has been changed to flush temp entity tables, - -- but old schema versions still use 'saveObject', but don't have the tables! - -- We can create the tables no matter what, there won't be anything to flush, so - -- everything still works as expected. - -- - -- Hopefully we can remove this once we've got better methods of freezing migration - -- code in time. - when (currentSchemaVersion < 5) $ run Q.addTempEntityTables - when (currentSchemaVersion < 6) $ run Q.addNamespaceStatsTables for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do putStrLn $ "šŸ”Ø Migrating codebase to version " <> show v <> "..." run migration let ranMigrations = not (null migrationsToRun) - when ranMigrations do - region <- - UnliftIO.mask_ do - region <- Region.openConsoleRegion Region.Linear - putMVar regionVar region - pure region - result <- do - -- Ideally we'd check everything here, but certain codebases are known to have objects - -- with missing Hash Objects, we'll want to clean that up in a future migration. - -- integrityCheckAllHashObjects, - let checks = - Monoid.whenM - (currentSchemaVersion < 7) -- Only certain migrations actually make changes which reasonably need to be checked - [ integrityCheckAllBranches, - integrityCheckAllCausals - ] - - zip [(1 :: Int) ..] checks & foldMapM \(i, check) -> do - Region.setConsoleRegion - region - (Text.pack (printf "šŸ•µļø Checking codebase integrity (step %d of %d)..." i (length checks))) - run check - case result of - NoIntegrityErrors -> pure () - IntegrityErrorDetected errs -> do - let msg = prettyPrintIntegrityErrors errs - let rendered = Pretty.toPlain 80 (Pretty.border 2 msg) - Region.setConsoleRegion region (Text.pack rendered) - run (abortMigration "Codebase integrity error detected.") pure ranMigrations when ranMigrations do region <- readMVar regionVar diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs deleted file mode 100644 index 475e19d338..0000000000 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ /dev/null @@ -1,873 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RecordWildCards #-} - -module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 - ( migrateSchema1To2, - ) -where - -import Control.Concurrent.STM (TVar) -import Control.Lens hiding (from) -import Control.Lens qualified as Lens -import Control.Monad.Except (runExceptT) -import Control.Monad.State.Strict -import Control.Monad.Trans.Except (throwE) -import Control.Monad.Trans.Writer.CPS (Writer, execWriter, tell) -import Data.Generics.Product -import Data.Generics.Sum (_Ctor) -import Data.List.Extra (nubOrd) -import Data.Map qualified as Map -import Data.Set qualified as Set -import Data.Tuple (swap) -import Data.Tuple.Extra ((***)) -import Data.Zip qualified as Zip -import System.Environment (lookupEnv) -import System.IO.Unsafe (unsafePerformIO) -import U.Codebase.Branch (NamespaceStats (..)) -import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..)) -import U.Codebase.Reference qualified as C.Reference -import U.Codebase.Reference qualified as UReference -import U.Codebase.Referent qualified as UReferent -import U.Codebase.Sqlite.Branch.Full qualified as S -import U.Codebase.Sqlite.Branch.Full qualified as S.Branch.Full -import U.Codebase.Sqlite.Causal (GDbCausal (..)) -import U.Codebase.Sqlite.Causal qualified as SC.DbCausal (GDbCausal (..)) -import U.Codebase.Sqlite.DbId - ( BranchHashId (..), - BranchObjectId (..), - CausalHashId (..), - HashId, - ObjectId, - PatchObjectId (..), - TextId, - ) -import U.Codebase.Sqlite.LocalizeObject qualified as S.LocalizeObject -import U.Codebase.Sqlite.Operations qualified as Ops -import U.Codebase.Sqlite.Patch.Format qualified as S.Patch.Format -import U.Codebase.Sqlite.Patch.Full qualified as S -import U.Codebase.Sqlite.Patch.TermEdit qualified as TermEdit -import U.Codebase.Sqlite.Patch.TypeEdit qualified as TypeEdit -import U.Codebase.Sqlite.Queries qualified as Q -import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) -import U.Codebase.Sync (Sync (Sync)) -import U.Codebase.Sync qualified as Sync -import U.Codebase.WatchKind (WatchKind) -import U.Codebase.WatchKind qualified as WK -import Unison.ABT qualified as ABT -import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv -import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers qualified as Hashing -import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps -import Unison.ConstructorReference qualified as ConstructorReference -import Unison.ConstructorType qualified as CT -import Unison.DataDeclaration qualified as DD -import Unison.DataDeclaration.ConstructorId (ConstructorId) -import Unison.Hash (Hash) -import Unison.Hash qualified as Unison -import Unison.Hashing.V2 qualified as Hashing -import Unison.Hashing.V2.Convert qualified as Convert -import Unison.Parser.Ann (Ann) -import Unison.Pattern (Pattern) -import Unison.Pattern qualified as Pattern -import Unison.Prelude -import Unison.Reference qualified as Reference -import Unison.Referent qualified as Referent -import Unison.Referent' qualified as Referent' -import Unison.Sqlite qualified as Sqlite -import Unison.Symbol (Symbol) -import Unison.Term qualified as Term -import Unison.Type (Type) -import Unison.Type qualified as Type -import Unison.Util.Monoid (foldMapM) -import Unison.Util.Set qualified as Set -import Prelude hiding (log) - -verboseOutput :: Bool -verboseOutput = - isJust (unsafePerformIO (lookupEnv "UNISON_MIGRATION_DEBUG")) -{-# NOINLINE verboseOutput #-} - -migrateSchema1To2 :: - -- | A 'getDeclType'-like lookup, possibly backed by a cache. - (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> - TVar (Map Hash CodebaseOps.TermBufferEntry) -> - TVar (Map Hash CodebaseOps.DeclBufferEntry) -> - Sqlite.Transaction () -migrateSchema1To2 getDeclType termBuffer declBuffer = do - log "Starting codebase migration. This may take a while, it's a good time to make some tea ā˜•ļø" - corruptedCausals <- Q.getCausalsWithoutBranchObjects - when (not . null $ corruptedCausals) do - log $ "āš ļø I detected " <> show (length corruptedCausals) <> " corrupted namespace(s) in the history of the codebase." - log "This is due to a bug in a previous version of ucm." - log "This only affects the history of your codebase, the most up-to-date iteration will remain intact." - log "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones." - - log "Updating Namespace Root..." - rootCausalHashId <- Q.expectNamespaceRoot - numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches] - v2EmptyBranchHashInfo <- saveV2EmptyBranch - watches <- - foldMapM - (\watchKind -> map (W watchKind) <$> CodebaseOps.watches (Cv.watchKind2to1 watchKind)) - [WK.RegularWatch, WK.TestWatch] - migrationState <- - Sync.sync @_ @Entity (migrationSync getDeclType termBuffer declBuffer) (progress numEntitiesToMigrate) (CausalE rootCausalHashId : watches) - `execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo - let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId - log "Updating Namespace Root..." - Q.setNamespaceRoot newRootCausalHashId - log "Rewriting old object IDs..." - ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do - Q.recordObjectRehash oldObjId newObjId - log "Garbage collecting orphaned objects..." - Q.garbageCollectObjectsWithoutHashes - log "Garbage collecting orphaned watches..." - Q.garbageCollectWatchesWithoutObjects - log "Updating Schema Version..." - Q.setSchemaVersion 2 - where - progress :: Int -> Sync.Progress (StateT MigrationState Sqlite.Transaction) Entity - progress numToMigrate = - let incrementProgress :: StateT MigrationState Sqlite.Transaction () - incrementProgress = do - numDone <- field @"numMigrated" <+= 1 - lift $ Sqlite.unsafeIO $ putStr $ "\r šŸ— " <> show numDone <> " / ~" <> show numToMigrate <> " entities migrated. šŸš§" - need :: Entity -> StateT MigrationState Sqlite.Transaction () - need e = when verboseOutput $ lift $ log $ "Need: " ++ show e - done :: Entity -> StateT MigrationState Sqlite.Transaction () - done e = do - when verboseOutput $ lift $ log $ "Done: " ++ show e - incrementProgress - errorHandler :: Entity -> StateT MigrationState Sqlite.Transaction () - errorHandler e = do - case e of - -- We expect non-fatal errors when migrating watches. - W {} -> pure () - e -> lift $ log $ "Error: " ++ show e - incrementProgress - allDone :: StateT MigrationState Sqlite.Transaction () - allDone = lift $ log $ "\nFinished migrating, initiating cleanup." - in Sync.Progress {need, done, error = errorHandler, allDone} - -log :: String -> Sqlite.Transaction () -log = - Sqlite.unsafeIO . putStrLn - -type Old a = a - -type New a = a - -type ConstructorName v = v - -type DeclName v = v - -data MigrationState = MigrationState - -- Mapping between old cycle-position -> new cycle-position for a given Decl object. - { referenceMapping :: Map (Old SomeReferenceId) (New SomeReferenceId), - causalMapping :: Map (Old CausalHashId) (New (CausalHash, CausalHashId)), - -- We also store the old hash for this object ID since we need a way to - -- 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), - numMigrated :: Int, - v2EmptyBranchHashInfo :: (BranchHashId, BranchHash) - } - deriving (Generic) - -data Entity - = TermComponent Unison.Hash - | DeclComponent Unison.Hash - | CausalE CausalHashId - | BranchE ObjectId - | PatchE ObjectId - | W WK.WatchKind Reference.Id - deriving (Eq, Ord, Show) - -migrationSync :: - -- | A 'getDeclType'-like lookup, possibly backed by a cache. - (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> - TVar (Map Hash CodebaseOps.TermBufferEntry) -> - TVar (Map Hash CodebaseOps.DeclBufferEntry) -> - Sync (StateT MigrationState Sqlite.Transaction) Entity -migrationSync getDeclType termBuffer declBuffer = Sync \case - TermComponent hash -> migrateTermComponent getDeclType termBuffer declBuffer hash - DeclComponent hash -> migrateDeclComponent termBuffer declBuffer hash - BranchE objectId -> migrateBranch objectId - CausalE causalHashId -> migrateCausal causalHashId - PatchE objectId -> migratePatch (PatchObjectId objectId) - W watchKind watchId -> migrateWatch getDeclType watchKind watchId - -migrateCausal :: CausalHashId -> StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity) -migrateCausal oldCausalHashId = fmap (either id id) . runExceptT $ do - whenM (Map.member oldCausalHashId <$> use (field @"causalMapping")) (throwE Sync.PreviouslyDone) - - oldBranchHashId <- lift . lift $ Q.expectCausalValueHashId oldCausalHashId - oldCausalParentHashIds <- lift . lift $ Q.loadCausalParents oldCausalHashId - - maybeOldBranchObjId <- - lift . lift $ - Q.loadObjectIdForAnyHashId (unBranchHashId oldBranchHashId) - migratedObjIds <- gets objLookup - -- If the branch for this causal hasn't been migrated, migrate it first. - let unmigratedBranch = - case maybeOldBranchObjId of - Just branchObjId | branchObjId `Map.notMember` migratedObjIds -> [BranchE branchObjId] - _ -> [] - - migratedCausals <- gets causalMapping - let unmigratedParents = - oldCausalParentHashIds - & filter (`Map.notMember` migratedCausals) - & fmap CausalE - let unmigratedEntities = unmigratedBranch <> unmigratedParents - when (not . null $ unmigratedParents <> unmigratedBranch) (throwE $ Sync.Missing unmigratedEntities) - - (newBranchHashId, newBranchHash) <- case maybeOldBranchObjId of - -- Some codebases are corrupted, likely due to interrupted save operations. - -- It's unfortunate, but rather than fail the whole migration we'll just replace them - -- with an empty branch. - Nothing -> use (field @"v2EmptyBranchHashInfo") - Just branchObjId -> do - let (_, newBranchHashId, newBranchHash, _) = migratedObjIds ^?! ix branchObjId - pure (BranchHashId newBranchHashId, BranchHash newBranchHash) - - let (newParentHashes, newParentHashIds) = - oldCausalParentHashIds - & fmap (\oldParentHashId -> migratedCausals ^?! ix oldParentHashId) - & unzip - & bimap (Set.fromList . map unCausalHash) Set.fromList - - let newCausalHash :: CausalHash - newCausalHash = - CausalHash $ - Hashing.contentHash - Hashing.Causal - { branchHash = unBranchHash newBranchHash, - parents = newParentHashes - } - newCausalHashId <- lift . lift $ Q.saveCausalHash newCausalHash - let newCausal = - DbCausal - { selfHash = newCausalHashId, - valueHash = newBranchHashId, - parents = newParentHashIds - } - (lift . lift) do - Q.saveCausal - v2HashHandle - (SC.DbCausal.selfHash newCausal) - (SC.DbCausal.valueHash newCausal) - (Set.toList $ SC.DbCausal.parents newCausal) - - field @"causalMapping" %= Map.insert oldCausalHashId (newCausalHash, newCausalHashId) - - pure Sync.Done - -migrateBranch :: ObjectId -> StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity) -migrateBranch oldObjectId = fmap (either id id) . runExceptT $ do - whenM (Map.member oldObjectId <$> use (field @"objLookup")) (throwE Sync.PreviouslyDone) - - oldBranch <- lift . lift $ Ops.expectDbBranch (BranchObjectId oldObjectId) - oldHash <- lift . lift $ Q.expectPrimaryHashByObjectId oldObjectId - oldBranchWithHashes <- lift . lift $ traverseOf S.branchHashes_ Q.expectPrimaryHashByObjectId oldBranch - migratedRefs <- gets referenceMapping - migratedObjects <- gets objLookup - migratedCausals <- gets causalMapping - let allMissingTypesAndTerms :: [Entity] - allMissingTypesAndTerms = - oldBranchWithHashes - ^.. branchSomeRefs_ - . uRefIdAsRefId_ - . filtered (`Map.notMember` migratedRefs) - . to someReferenceIdToEntity - - let allMissingPatches :: [Entity] = - oldBranch - ^.. S.patches_ - . to unPatchObjectId - . filtered (`Map.notMember` migratedObjects) - . to PatchE - - let allMissingChildBranches :: [Entity] = - oldBranch - ^.. S.childrenHashes_ - . _1 - . to unBranchObjectId - . filtered (`Map.notMember` migratedObjects) - . to BranchE - - let allMissingChildCausals :: [Entity] = - oldBranch - ^.. S.childrenHashes_ - . _2 - . filtered (`Map.notMember` migratedCausals) - . to CausalE - - -- Identify dependencies and bail out if they aren't all built - let allMissingReferences :: [Entity] - allMissingReferences = - allMissingTypesAndTerms - ++ allMissingPatches - ++ allMissingChildBranches - ++ allMissingChildCausals - - when (not . null $ allMissingReferences) $ - throwE $ - Sync.Missing allMissingReferences - - let remapPatchObjectId patchObjId = case Map.lookup (unPatchObjectId patchObjId) migratedObjects of - Nothing -> error $ "Expected patch: " <> show patchObjId <> " to be migrated" - Just (newPatchObjId, _, _, _) -> PatchObjectId newPatchObjId - let remapCausalHashId causalHashId = case Map.lookup causalHashId migratedCausals of - Nothing -> error $ "Expected causal hash id: " <> show causalHashId <> " to be migrated" - Just (_, newCausalHashId) -> newCausalHashId - let remapBranchObjectId objId = case Map.lookup (unBranchObjectId objId) migratedObjects of - Nothing -> error $ "Expected object: " <> show objId <> " to be migrated" - Just (newBranchObjId, _, _, _) -> BranchObjectId newBranchObjId - - let newBranch :: S.DbBranch - newBranch = - oldBranch - & branchSomeRefs_ %~ remapObjIdRefs migratedObjects migratedRefs - & S.patches_ %~ remapPatchObjectId - & S.childrenHashes_ %~ (remapBranchObjectId *** remapCausalHashId) - - newHash <- lift . lift $ Hashing.dbBranchHash newBranch - newHashId <- lift . lift $ Q.saveBranchHash newHash - stats <- lift . lift $ Ops.namespaceStatsForDbBranch (Ops.DbBranchV2 newBranch) - newObjectId <- lift . lift $ Ops.saveDbBranchUnderHashId v2HashHandle newHashId stats (Ops.DbBranchV2 newBranch) - field @"objLookup" - %= Map.insert - oldObjectId - ( unBranchObjectId newObjectId, - unBranchHashId newHashId, - unBranchHash newHash, - oldHash - ) - pure Sync.Done - -migratePatch :: Old PatchObjectId -> StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity) -migratePatch oldObjectId = fmap (either id id) . runExceptT $ do - whenM (Map.member (unPatchObjectId oldObjectId) <$> use (field @"objLookup")) (throwE Sync.PreviouslyDone) - - oldHash <- lift . lift $ Q.expectPrimaryHashByObjectId (unPatchObjectId oldObjectId) - oldPatch <- lift . lift $ Ops.expectDbPatch oldObjectId - - oldPatchWithHashes :: S.Patch' TextId Hash Hash <- - lift . lift $ - (oldPatch & S.patchH_ %%~ Q.expectHash) - >>= (S.patchO_ %%~ Q.expectPrimaryHashByObjectId) - - migratedRefs <- gets referenceMapping - let isUnmigratedRef ref = Map.notMember ref migratedRefs - -- 2. Determine whether all things the patch refers to are built. - let unmigratedDependencies :: [Entity] - unmigratedDependencies = - oldPatchWithHashes ^.. patchSomeRefsH_ . uRefIdAsRefId_ . filtered isUnmigratedRef . to someReferenceIdToEntity - <> oldPatchWithHashes ^.. patchSomeRefsO_ . uRefIdAsRefId_ . filtered isUnmigratedRef . to someReferenceIdToEntity - when (not . null $ unmigratedDependencies) (throwE (Sync.Missing unmigratedDependencies)) - - let hashToHashId :: Hash -> Sqlite.Transaction HashId - hashToHashId h = - fromMaybe (error $ "expected hashId for hash: " <> show h) <$> Q.loadHashIdByHash h - let hashToObjectId :: Hash -> Sqlite.Transaction ObjectId - hashToObjectId = hashToHashId >=> Q.expectObjectIdForPrimaryHashId - - migratedReferences <- gets referenceMapping - let remapRef :: SomeReferenceId -> SomeReferenceId - remapRef ref = Map.findWithDefault ref ref migratedReferences - - let newPatch = - oldPatchWithHashes - & patchSomeRefsH_ . uRefIdAsRefId_ %~ remapRef - & patchSomeRefsO_ . uRefIdAsRefId_ %~ remapRef - - newPatchWithIds :: S.Patch <- - lift . lift $ - (newPatch & S.patchH_ %%~ hashToHashId) - >>= (S.patchO_ %%~ hashToObjectId) - - let (localPatchIds, localPatch) = S.LocalizeObject.localizePatch newPatchWithIds - newHash <- lift . lift $ Hashing.dbPatchHash newPatchWithIds - newObjectId <- - lift . lift $ - Ops.saveDbPatch - v2HashHandle - newHash - (S.Patch.Format.Full localPatchIds localPatch) - newHashId <- lift . lift $ Q.expectHashIdByHash (unPatchHash newHash) - field @"objLookup" - %= Map.insert - (unPatchObjectId oldObjectId) - ( unPatchObjectId newObjectId, - newHashId, - unPatchHash newHash, - oldHash - ) - pure Sync.Done - --- | PLAN --- * --- NOTE: this implementation assumes that watches will be migrated AFTER everything else is finished. --- This is because it's difficult for us to know otherwise whether a reference refers to something which doesn't exist, or just --- something that hasn't been migrated yet. If we do it last, we know that missing references are indeed just missing from the codebase. -migrateWatch :: - -- | A 'getDeclType'-like lookup, possibly backed by a cache. - (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> - WatchKind -> - Reference.Id -> - StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity) -migrateWatch getDeclType watchKind oldWatchId = fmap (either id id) . runExceptT $ do - let watchKindV1 = Cv.watchKind2to1 watchKind - watchResultTerm <- - (lift . lift) (CodebaseOps.getWatch getDeclType watchKindV1 oldWatchId) >>= \case - -- The hash which we're watching doesn't exist in the codebase, throw out this watch. - Nothing -> throwE Sync.Done - Just term -> pure term - migratedReferences <- gets referenceMapping - newWatchId <- case Map.lookup (TermReference oldWatchId) migratedReferences of - (Just (TermReference newRef)) -> pure newRef - _ -> throwE Sync.NonFatalError - let maybeRemappedTerm :: Maybe (Term.Term Symbol Ann) - maybeRemappedTerm = - watchResultTerm - & termReferences_ %%~ \someRef -> Map.lookup someRef migratedReferences - case maybeRemappedTerm of - -- One or more references in the result didn't exist in our codebase. - Nothing -> pure Sync.NonFatalError - Just remappedTerm -> do - lift . lift $ CodebaseOps.putWatch watchKindV1 newWatchId remappedTerm - pure Sync.Done - -uRefIdAsRefId_ :: Iso' (SomeReference (UReference.Id' Hash)) SomeReferenceId -uRefIdAsRefId_ = mapping uRefAsRef_ - -uRefAsRef_ :: Iso' (UReference.Id' Hash) Reference.Id -uRefAsRef_ = iso intoRef intoURef - where - intoRef (UReference.Id hash pos) = Reference.Id hash pos - intoURef (Reference.Id hash pos) = UReference.Id hash pos - --- Project an S.Referent'' into its SomeReferenceObjId's -someReferent_ :: - forall t h. - (forall ref. Traversal' ref (SomeReference ref)) -> - Traversal' (S.Branch.Full.Referent'' t h) (SomeReference (UReference.Id' h)) -someReferent_ typeOrTermTraversal_ = - (UReferent._Ref . someReference_ typeOrTermTraversal_) - `failing` ( UReferent._Con - . asPair_ -- Need to unpack the embedded reference AND remap between mismatched Constructor ID types. - . asConstructorReference_ - ) - where - asPair_ f (UReference.ReferenceDerived id', conId) = - f (ConstructorReference.ConstructorReference id' (fromIntegral conId)) - <&> \(ConstructorReference.ConstructorReference newId newConId) -> - (UReference.ReferenceDerived newId, fromIntegral newConId) - asPair_ _ (UReference.ReferenceBuiltin x, conId) = pure (UReference.ReferenceBuiltin x, conId) - -someReference_ :: - (forall ref. Traversal' ref (SomeReference ref)) -> - Traversal' (UReference.Reference' t h) (SomeReference (UReference.Id' h)) -someReference_ typeOrTermTraversal_ = UReference._ReferenceDerived . typeOrTermTraversal_ - -someMetadataSetFormat_ :: - (Ord t, Ord h) => - (forall ref. Traversal' ref (SomeReference ref)) -> - Traversal' (S.Branch.Full.MetadataSetFormat' t h) (SomeReference (UReference.Id' h)) -someMetadataSetFormat_ typeOrTermTraversal_ = - S.Branch.Full.metadataSetFormatReferences_ . someReference_ typeOrTermTraversal_ - -someReferenceMetadata_ :: - (Ord k, Ord t, Ord h) => - Traversal' k (SomeReference (UReference.Id' h)) -> - Traversal' - (Map k (S.Branch.Full.MetadataSetFormat' t h)) - (SomeReference (UReference.Id' h)) -someReferenceMetadata_ keyTraversal_ f m = - Map.toList m - & traversed . beside keyTraversal_ (someMetadataSetFormat_ asTermReference_) %%~ f - <&> Map.fromList - -branchSomeRefs_ :: (Ord t, Ord h) => Traversal' (S.Branch' t h p c) (SomeReference (UReference.Id' h)) -branchSomeRefs_ f S.Branch.Full.Branch {children, patches, terms, types} = do - let newTypesMap = types & traversed . someReferenceMetadata_ (someReference_ asTypeReference_) %%~ f - let newTermsMap = terms & traversed . someReferenceMetadata_ (someReferent_ asTermReference_) %%~ f - S.Branch.Full.Branch <$> newTermsMap <*> newTypesMap <*> pure patches <*> pure children - -patchSomeRefsH_ :: (Ord t, Ord h) => Traversal (S.Patch' t h o) (S.Patch' t h o) (SomeReference (UReference.Id' h)) (SomeReference (UReference.Id' h)) -patchSomeRefsH_ f S.Patch {termEdits, typeEdits} = do - newTermEdits <- Map.fromList <$> (Map.toList termEdits & traversed . _1 . (someReferent_ asTermReference_) %%~ f) - newTypeEdits <- Map.fromList <$> (Map.toList typeEdits & traversed . _1 . (someReference_ asTypeReference_) %%~ f) - pure S.Patch {termEdits = newTermEdits, typeEdits = newTypeEdits} - -patchSomeRefsO_ :: (Ord t, Ord h, Ord o) => Traversal' (S.Patch' t h o) (SomeReference (UReference.Id' o)) -patchSomeRefsO_ f S.Patch {termEdits, typeEdits} = do - newTermEdits <- (termEdits & traversed . Set.traverse . termEditRefs_ %%~ f) - newTypeEdits <- (typeEdits & traversed . Set.traverse . typeEditRefs_ %%~ f) - pure (S.Patch {termEdits = newTermEdits, typeEdits = newTypeEdits}) - -termEditRefs_ :: Traversal' (TermEdit.TermEdit' t h) (SomeReference (UReference.Id' h)) -termEditRefs_ f (TermEdit.Replace ref typing) = - TermEdit.Replace <$> (ref & someReferent_ asTermReference_ %%~ f) <*> pure typing -termEditRefs_ _f (TermEdit.Deprecate) = pure TermEdit.Deprecate - -typeEditRefs_ :: Traversal' (TypeEdit.TypeEdit' t h) (SomeReference (UReference.Id' h)) -typeEditRefs_ f (TypeEdit.Replace ref) = - TypeEdit.Replace <$> (ref & someReference_ asTypeReference_ %%~ f) -typeEditRefs_ _f (TypeEdit.Deprecate) = pure TypeEdit.Deprecate - -migrateTermComponent :: - -- | A 'getDeclType'-like lookup, possibly backed by a cache. - (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> - TVar (Map Hash CodebaseOps.TermBufferEntry) -> - TVar (Map Hash CodebaseOps.DeclBufferEntry) -> - Unison.Hash -> - StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity) -migrateTermComponent getDeclType termBuffer declBuffer oldHash = fmap (either id id) . runExceptT $ do - whenM (Set.member oldHash <$> use (field @"migratedDefnHashes")) (throwE Sync.PreviouslyDone) - - oldComponent <- - (lift . lift $ CodebaseOps.getTermComponentWithTypes getDeclType oldHash) >>= \case - Nothing -> error $ "Hash was missing from codebase: " <> show oldHash - Just c -> pure c - - let componentIDMap :: Map (Old Reference.Id) (Term.Term Symbol Ann, Type Symbol Ann) - componentIDMap = Map.fromList $ Reference.componentFor oldHash oldComponent - let unhashed :: Map (Old Reference.Id) (Symbol, Term.Term Symbol Ann) - unhashed = Term.unhashComponent (fst <$> componentIDMap) - let vToOldReferenceMapping :: Map Symbol (Old Reference.Id) - vToOldReferenceMapping = - unhashed - & Map.toList - & fmap (\(refId, (v, _trm)) -> (v, refId)) - & Map.fromList - - referencesMap <- gets referenceMapping - - let allMissingReferences :: [Old SomeReferenceId] - allMissingReferences = - let missingTermRefs = - unhashed & foldSetter (traversed . _2 . termReferences_) - missingTypeRefs = - componentIDMap - & foldSetter (traversed . _2 . typeReferences_) - in filter (`Map.notMember` referencesMap) (missingTermRefs <> missingTypeRefs) - - when (not . null $ allMissingReferences) $ - throwE $ - Sync.Missing . nubOrd $ - (someReferenceIdToEntity <$> allMissingReferences) - - let getMigratedReference :: Old SomeReferenceId -> New SomeReferenceId - getMigratedReference ref = - Map.findWithDefault (error $ "unmigrated reference" <> show ref) ref referencesMap - - let remappedReferences :: Map (Old Reference.Id) (Symbol, Term.Term Symbol Ann, Type Symbol Ann) = - Zip.zipWith - ( \(v, trm) (_, typ) -> - ( v, - trm & termReferences_ %~ getMigratedReference, - typ & typeReferences_ %~ getMigratedReference - ) - ) - unhashed - componentIDMap - - let newTermComponents :: Map Symbol (New Reference.Id, Term.Term Symbol Ann, Type Symbol Ann) - newTermComponents = - remappedReferences - & Map.elems - & fmap (\(v, trm, typ) -> (v, (trm, typ, ()))) - & Map.fromList - & Convert.hashTermComponents - & fmap (\(ref, trm, typ, _) -> (ref, trm, typ)) - - ifor newTermComponents $ \v (newReferenceId, trm, typ) -> do - let oldReferenceId = vToOldReferenceMapping ^?! ix v - field @"referenceMapping" %= Map.insert (TermReference oldReferenceId) (TermReference newReferenceId) - lift . lift $ CodebaseOps.putTerm termBuffer declBuffer newReferenceId trm typ - - -- Need to get one of the new references to grab its hash, doesn't matter which one since - -- all hashes in the component are the same. - case newTermComponents ^? traversed . _1 . to Reference.idToHash of - Nothing -> pure () - Just newHash -> lift (insertObjectMappingForHash oldHash newHash) - - field @"migratedDefnHashes" %= Set.insert oldHash - pure Sync.Done - -migrateDeclComponent :: - TVar (Map Hash CodebaseOps.TermBufferEntry) -> - TVar (Map Hash CodebaseOps.DeclBufferEntry) -> - Unison.Hash -> - StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity) -migrateDeclComponent termBuffer declBuffer oldHash = fmap (either id id) . runExceptT $ do - whenM (Set.member oldHash <$> use (field @"migratedDefnHashes")) (throwE Sync.PreviouslyDone) - - declComponent :: [DD.Decl v a] <- - (lift . lift $ CodebaseOps.getDeclComponent oldHash) >>= \case - Nothing -> error $ "Expected decl component for hash:" <> show oldHash - Just dc -> pure dc - - let componentIDMap :: Map (Old Reference.Id) (DD.Decl v a) - componentIDMap = Map.fromList $ Reference.componentFor oldHash declComponent - - let unhashed :: Map (Old Reference.Id) (DeclName v, DD.Decl v a) - unhashed = DD.unhashComponent componentIDMap - - let allTypes :: [Type v a] - allTypes = - unhashed - ^.. traversed - . _2 - . beside DD.asDataDecl_ id - . to DD.constructors' - . traversed - . _3 - - migratedReferences <- gets referenceMapping - let unmigratedRefIds :: [SomeReferenceId] - unmigratedRefIds = - allTypes - & foldSetter - ( traversed -- Every type in the list - . typeReferences_ - . filtered (`Map.notMember` migratedReferences) - ) - - when (not . null $ unmigratedRefIds) do - throwE (Sync.Missing (nubOrd . fmap someReferenceIdToEntity $ unmigratedRefIds)) - - -- At this point we know we have all the required mappings from old references to new ones. - let remapTerm :: Type v a -> Type v a - remapTerm = typeReferences_ %~ \ref -> Map.findWithDefault (error "unmigrated reference") ref migratedReferences - - let remappedReferences :: Map (Old Reference.Id) (DeclName v, DD.Decl v a) - remappedReferences = - unhashed - & traversed -- Traverse map of reference IDs - . _2 -- Select the DataDeclaration - . beside DD.asDataDecl_ id -- Unpack effect decls - . DD.constructors_ -- Get the data constructors - . traversed -- traverse the list of them - . _3 -- Select the Type term. - %~ remapTerm - - let declNameToOldReference :: Map (DeclName v) (Old Reference.Id) - declNameToOldReference = Map.fromList . fmap swap . Map.toList . fmap fst $ remappedReferences - - let newComponent :: [(DeclName v, Reference.Id, DD.Decl v a)] - newComponent = - remappedReferences - & Map.elems - & Map.fromList - & Convert.hashDecls - & fromRight (error "unexpected resolution error") - - for_ newComponent $ \(declName, newReferenceId, dd) -> do - let oldReferenceId = declNameToOldReference ^?! ix declName - field @"referenceMapping" %= Map.insert (TypeReference oldReferenceId) (TypeReference newReferenceId) - - let oldConstructorIds :: Map (ConstructorName v) (Old ConstructorId) - oldConstructorIds = - (componentIDMap ^?! ix oldReferenceId) - & DD.asDataDecl - & DD.constructors' - & imap (\constructorId (_ann, constructorName, _type) -> (constructorName, fromIntegral constructorId)) - & Map.fromList - - ifor_ (DD.constructors' (DD.asDataDecl dd)) \(fromIntegral -> newConstructorId) (_ann, constructorName, _type) -> do - field @"referenceMapping" - %= Map.insert - (ConstructorReference oldReferenceId (oldConstructorIds ^?! ix constructorName)) - (ConstructorReference newReferenceId newConstructorId) - - lift . lift $ CodebaseOps.putTypeDeclaration termBuffer declBuffer newReferenceId dd - - -- Need to get one of the new references to grab its hash, doesn't matter which one since - -- all hashes in the component are the same. - case newComponent ^? traversed . _2 . to Reference.idToHash of - Nothing -> pure () - Just newHash -> lift (insertObjectMappingForHash oldHash newHash) - field @"migratedDefnHashes" %= Set.insert oldHash - - pure Sync.Done - -insertObjectMappingForHash :: Old Hash -> New Hash -> StateT MigrationState Sqlite.Transaction () -insertObjectMappingForHash oldHash newHash = do - (oldObjectId, newHashId, newObjectId) <- lift do - oldHashId <- Q.expectHashIdByHash oldHash - oldObjectId <- Q.expectObjectIdForPrimaryHashId oldHashId - newHashId <- Q.expectHashIdByHash newHash - newObjectId <- Q.expectObjectIdForPrimaryHashId newHashId - pure (oldObjectId, newHashId, newObjectId) - field @"objLookup" %= Map.insert oldObjectId (newObjectId, newHashId, newHash, oldHash) - -typeReferences_ :: (Monad m, Ord v) => LensLike' m (Type v a) SomeReferenceId -typeReferences_ = - ABT.rewriteDown_ -- Focus all terms - . ABT.baseFunctor_ -- Focus Type.F - . Type._Ref -- Only the Ref constructor has references - . Reference._DerivedId - . asTypeReference_ - -termReferences_ :: (Monad m, Ord v) => LensLike' m (Term.Term v a) SomeReferenceId -termReferences_ = - ABT.rewriteDown_ -- Focus all terms - . ABT.baseFunctor_ -- Focus Term.F - . termFReferences_ - -termFReferences_ :: (Ord tv, Monad m) => LensLike' m (Term.F tv ta pa a) SomeReferenceId -termFReferences_ f t = - (t & Term._Ref . Reference._DerivedId . asTermReference_ %%~ f) - >>= Term._Constructor . someRefCon_ %%~ f - >>= Term._Request . someRefCon_ %%~ f - >>= Term._Ann . _2 . typeReferences_ %%~ f - >>= Term._Match . _2 . traversed . Term.matchPattern_ . patternReferences_ %%~ f - >>= Term._TermLink . referentAsSomeTermReference_ %%~ f - >>= Term._TypeLink . Reference._DerivedId . asTypeReference_ %%~ f - --- | Build a SomeConstructorReference -someRefCon_ :: Traversal' ConstructorReference.ConstructorReference SomeReferenceId -someRefCon_ = refConPair_ . asConstructorReference_ - where - refConPair_ :: Traversal' ConstructorReference.ConstructorReference ConstructorReference.ConstructorReferenceId - refConPair_ f s = - case s of - ConstructorReference.ConstructorReference (Reference.Builtin _) _ -> pure s - ConstructorReference.ConstructorReference (Reference.DerivedId n) c -> - ( \(ConstructorReference.ConstructorReference n' c') -> - ConstructorReference.ConstructorReference (Reference.DerivedId n') c' - ) - <$> f (ConstructorReference.ConstructorReference n c) - -patternReferences_ :: Traversal' (Pattern loc) SomeReferenceId -patternReferences_ f = \case - p@(Pattern.Unbound {}) -> pure p - p@(Pattern.Var {}) -> pure p - p@(Pattern.Boolean {}) -> pure p - p@(Pattern.Int {}) -> pure p - p@(Pattern.Nat {}) -> pure p - p@(Pattern.Float {}) -> pure p - p@(Pattern.Text {}) -> pure p - p@(Pattern.Char {}) -> pure p - (Pattern.Constructor loc ref patterns) -> - (\newRef newPatterns -> Pattern.Constructor loc newRef newPatterns) - <$> (ref & someRefCon_ %%~ f) - <*> (patterns & traversed . patternReferences_ %%~ f) - (Pattern.As loc pat) -> Pattern.As loc <$> patternReferences_ f pat - (Pattern.EffectPure loc pat) -> Pattern.EffectPure loc <$> patternReferences_ f pat - (Pattern.EffectBind loc ref patterns pat) -> - do - (\newRef newPatterns newPat -> Pattern.EffectBind loc newRef newPatterns newPat) - <$> (ref & someRefCon_ %%~ f) - <*> (patterns & traversed . patternReferences_ %%~ f) - <*> (patternReferences_ f pat) - (Pattern.SequenceLiteral loc patterns) -> - Pattern.SequenceLiteral loc <$> (patterns & traversed . patternReferences_ %%~ f) - Pattern.SequenceOp loc pat seqOp pat2 -> do - Pattern.SequenceOp loc <$> patternReferences_ f pat <*> pure seqOp <*> patternReferences_ f pat2 - -referentAsSomeTermReference_ :: Traversal' Referent.Referent SomeReferenceId -referentAsSomeTermReference_ f = \case - (Referent'.Ref' (Reference.DerivedId refId)) -> do - newRefId <- refId & asTermReference_ %%~ f - pure (Referent'.Ref' (Reference.DerivedId newRefId)) - (Referent'.Con' (ConstructorReference.ConstructorReference (Reference.DerivedId refId) conId) conType) -> - (ConstructorReference.ConstructorReference refId conId & asConstructorReference_ %%~ f) - <&> \(ConstructorReference.ConstructorReference newRefId newConId) -> - Referent'.Con' - (ConstructorReference.ConstructorReference (Reference.DerivedId newRefId) newConId) - conType - r -> pure r - -type SomeReferenceId = SomeReference Reference.Id - -type SomeReferenceObjId = SomeReference (UReference.Id' ObjectId) - -remapObjIdRefs :: - (Map (Old ObjectId) (New ObjectId, New HashId, New Hash, Old Hash)) -> - (Map SomeReferenceId SomeReferenceId) -> - SomeReferenceObjId -> - SomeReferenceObjId -remapObjIdRefs objMapping refMapping someObjIdRef = newSomeObjId - where - oldObjId :: ObjectId - oldObjId = someObjIdRef ^. someRef_ . UReference.idH - (newObjId, _, _, oldHash) = - case Map.lookup oldObjId objMapping of - Nothing -> error $ "Expected object mapping for ID: " <> show oldObjId - Just found -> found - oldSomeRefId :: SomeReferenceId - oldSomeRefId = (someObjIdRef & someRef_ . UReference.idH .~ oldHash) ^. uRefIdAsRefId_ - newSomeRefId :: SomeReferenceId - newSomeRefId = case Map.lookup oldSomeRefId refMapping of - Nothing -> error $ "Expected reference mapping for ID: " <> show oldSomeRefId - Just r -> r - newSomeObjId :: SomeReference (UReference.Id' (New ObjectId)) - newSomeObjId = (newSomeRefId ^. Lens.from uRefIdAsRefId_) & someRef_ . UReference.idH .~ newObjId - -data SomeReference ref - = TermReference ref - | TypeReference ref - | ConstructorReference ref ConstructorId - deriving (Eq, Functor, Generic, Ord, Show, Foldable, Traversable) - -someRef_ :: Lens (SomeReference ref) (SomeReference ref') ref ref' -someRef_ = lens getter setter - where - setter (TermReference _) r = TermReference r - setter (TypeReference _) r = TypeReference r - setter (ConstructorReference _ conId) r = (ConstructorReference r conId) - getter = \case - TermReference r -> r - TypeReference r -> r - ConstructorReference r _ -> r - -_TermReference :: Prism' (SomeReference ref) ref -_TermReference = _Ctor @"TermReference" - --- | This is only safe as long as you don't change the constructor of your SomeReference -asTermReference_ :: Traversal' ref (SomeReference ref) -asTermReference_ f ref = - f (TermReference ref) <&> \case - TermReference ref' -> ref' - _ -> error "asTermReference_: SomeReferenceId constructor was changed." - --- | This is only safe as long as you don't change the constructor of your SomeReference -asTypeReference_ :: Traversal' ref (SomeReference ref) -asTypeReference_ f ref = - f (TypeReference ref) <&> \case - TypeReference ref' -> ref' - _ -> error "asTypeReference_: SomeReferenceId constructor was changed." - --- | This is only safe as long as you don't change the constructor of your SomeReference -asConstructorReference_ :: Traversal' (ConstructorReference.GConstructorReference ref) (SomeReference ref) -asConstructorReference_ f (ConstructorReference.ConstructorReference ref cId) = - f (ConstructorReference ref cId) <&> \case - ConstructorReference ref' cId -> ConstructorReference.ConstructorReference ref' cId - _ -> error "asConstructorReference_: SomeReferenceId constructor was changed." - -someReferenceIdToEntity :: SomeReferenceId -> Entity -someReferenceIdToEntity = \case - (TermReference ref) -> TermComponent (Reference.idToHash ref) - (TypeReference ref) -> DeclComponent (Reference.idToHash ref) - -- Constructors are migrated by their decl component. - (ConstructorReference ref _conId) -> DeclComponent (Reference.idToHash ref) - -foldSetter :: LensLike (Writer [a]) s t a a -> s -> [a] -foldSetter t s = execWriter (s & t %%~ \a -> tell [a] *> pure a) - --- | Save an empty branch and get its new hash to use when replacing --- branches which are missing due to database corruption. -saveV2EmptyBranch :: Sqlite.Transaction (BranchHashId, BranchHash) -saveV2EmptyBranch = do - let branch = S.emptyBranch - newHash <- Hashing.dbBranchHash branch - newHashId <- Q.saveBranchHash newHash - -- Stats are empty for the empty branch. - let emptyStats = NamespaceStats 0 0 0 - _ <- Ops.saveDbBranchUnderHashId v2HashHandle newHashId emptyStats (Ops.DbBranchV2 branch) - pure (newHashId, newHash) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs deleted file mode 100644 index 57dbdea27b..0000000000 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs +++ /dev/null @@ -1,343 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE QuasiQuotes #-} - -module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4) where - -import Control.Lens -import Control.Monad.Except -import Control.Monad.State -import Data.Generics.Product -import Data.Map qualified as Map -import Data.Semigroup -import Data.Set.Lens (setOf) -import U.Codebase.Sqlite.Branch.Format qualified as S.BranchFormat -import U.Codebase.Sqlite.Branch.Full qualified as DBBranch -import U.Codebase.Sqlite.DbId qualified as DB -import U.Codebase.Sqlite.LocalizeObject qualified as S.LocalizeObject -import U.Codebase.Sqlite.Operations qualified as Ops -import U.Codebase.Sqlite.Queries qualified as Q -import U.Codebase.Sqlite.Serialization qualified as S -import U.Codebase.Sync qualified as Sync -import U.Util.Serialization qualified as S -import Unison.Codebase.SqliteCodebase.Migrations.Helpers (abortMigration) -import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers qualified as Helpers -import Unison.Debug qualified as Debug -import Unison.Prelude -import Unison.Sqlite qualified as Sqlite -import Prelude hiding (log) - -data MigrationState = MigrationState - { -- A mapping from a causal hash to the _corrected_ and _canonicalized_ branch hash and - -- object. - _canonicalBranchForCausalHashId :: Map DB.CausalHashId (DB.BranchHashId, DB.BranchObjectId), - -- A mapping of branch hashes which were found to be correct and don't need to be - -- re-hashed/re-canonicalized, it allows us to skip some redundant work. - _validBranchHashIds :: Map DB.BranchHashId DB.BranchObjectId, - _numMigrated :: Int - } - deriving (Generic) - -canonicalBranchForCausalHashId :: Lens' MigrationState (Map DB.CausalHashId (DB.BranchHashId, DB.BranchObjectId)) -canonicalBranchForCausalHashId = - field @"_canonicalBranchForCausalHashId" - -validBranchHashIds :: Lens' MigrationState (Map DB.BranchHashId DB.BranchObjectId) -validBranchHashIds = - field @"_validBranchHashIds" - -numMigrated :: Lens' MigrationState Int -numMigrated = - field @"_numMigrated" - --- | There was a bug in previous versions of UCM which incorrectly used causal hashes as branch hashes. --- This remained undetected because there was never a need for this hash to be verifiable, --- and the hashes were still unique because the namespace hash was PART of the causal hash. --- It did however result in many identical branches being stored multiple times under --- different `primary_hash_id`s. --- --- However, with the advent of Share and Sync, we now need to correctly verify these namespace --- hashes. --- --- This migration fixes the issue by re-hashing namespace objects where the value_hash_id of a --- causal matches the self_hash_id. --- Luckily this doesn't change any causal hashes. --- --- However, due to the possibility of multiple identical objects stored under different --- `primary_hash_id`s, we may now have multiple objects with the same `primary_hash_id`, which --- our DB schema doesn't allow. --- --- To address this, we keep exactly one 'canonical' object for each hash, then remap all --- references to old objects into this canonical object instead. Unfortunately this requires --- mapping over every branch object and traversing the child references. --- --- It was also discovered that some developers had many branches which referenced objects --- which weren't in their codebase. We're not yet sure how this happened, but it's unlikely --- to be the case for most end users, and it turned out that these references were in causals --- and branches which were unreachable from the root namespace. As a fix, this migration also --- tracks every causal and branch which is reachable from the root namespace and deletes all --- causals and namespaces which are unreachable. Note that this may orphan some definitions, --- patches, etc. which were previously referenced in an 'unreachable' branch, but they were --- already floating around in an unreachable state. -migrateSchema3To4 :: Sqlite.Transaction () -migrateSchema3To4 = do - Q.expectSchemaVersion 3 - rootCausalHashId <- Q.expectNamespaceRoot - totalCausals <- causalCount - migrationState <- flip execStateT (MigrationState mempty mempty 0) $ Sync.sync migrationSync (migrationProgress totalCausals) [rootCausalHashId] - let MigrationState {_canonicalBranchForCausalHashId = mapping} = migrationState - let reachableCausalHashes = Map.keysSet mapping - let reachableBranchObjIds = setOf (traversed . _2) mapping - log $ "šŸ›  Cleaning up unreachable branches and causals..." - dropUnreachableCausalsAndBranches reachableCausalHashes reachableBranchObjIds - Q.setSchemaVersion 4 - where - causalCount :: Sqlite.Transaction Int - causalCount = do - Sqlite.queryOneCol - [Sqlite.sql| - SELECT count(*) FROM causal; - |] - -migrationProgress :: Int -> Sync.Progress (StateT MigrationState Sqlite.Transaction) DB.CausalHashId -migrationProgress totalCausals = - Sync.Progress {Sync.need, Sync.done, Sync.error, Sync.allDone} - where - need e = lift $ debugLog $ "Need " <> show e - done _ = - do - numDone <- numMigrated <+= 1 - lift $ Sqlite.unsafeIO $ putStr $ "\ršŸ— " <> show numDone <> " / ~" <> show totalCausals <> " entities migrated. šŸš§" - error e = lift . log $ "Error " <> show e - allDone = do - -- In some corrupted codebases we don't necessarily process every causal, or there may - -- be unreachable causals. We'll show the final number here just so everything looks - -- good to users. It's okay since we'll process the other branches and clean them up in - -- a batch step. - lift $ Sqlite.unsafeIO $ putStrLn $ "\ršŸ— " <> show totalCausals <> " / ~" <> show totalCausals <> " entities migrated. šŸš§" - lift . Sqlite.unsafeIO . putStrLn $ "Finished." - -migrationSync :: Sync.Sync (StateT MigrationState Sqlite.Transaction) DB.CausalHashId -migrationSync = - Sync.Sync \e -> do - (runExceptT $ migrateCausal e) >>= \case - Left syncResult -> pure syncResult - Right _ -> pure Sync.Done - -liftT :: Sqlite.Transaction a -> ExceptT (Sync.TrySyncResult DB.CausalHashId) (StateT MigrationState Sqlite.Transaction) a -liftT = lift . lift - -dropUnreachableCausalsAndBranches :: Set DB.CausalHashId -> Set DB.BranchObjectId -> Sqlite.Transaction () -dropUnreachableCausalsAndBranches reachableCausals reachableBranchObjs = do - createReachabilityTables - traverse_ insertReachableCausalSql reachableCausals - traverse_ insertReachableBranchObjectSql reachableBranchObjs - deleteUnreachableHashObjects - deleteUnreachableBranchObjects - deleteUnreachableCausalParents - deleteUnreachableCausals - where - deleteUnreachableHashObjects = - Sqlite.execute - [Sqlite.sql| - DELETE FROM hash_object AS ho - WHERE - NOT EXISTS (SELECT 1 FROM reachable_branch_objects AS ro WHERE ho.object_id = ro.object_id) - -- Ensure hash objects we're deleting are for branch objects. - AND EXISTS (SELECT 1 FROM object AS o WHERE o.id = ho.object_id AND type_id = 2) - |] - deleteUnreachableBranchObjects = - Sqlite.execute - [Sqlite.sql| - DELETE FROM object AS o - WHERE - o.type_id = 2 -- Filter for only branches - AND NOT EXISTS (SELECT 1 FROM reachable_branch_objects AS ro WHERE o.id = ro.object_id) - |] - deleteUnreachableCausals = - Sqlite.execute - [Sqlite.sql| - DELETE FROM causal AS c - WHERE NOT EXISTS (SELECT 1 FROM reachable_causals AS rc WHERE c.self_hash_id = rc.self_hash_id) - |] - deleteUnreachableCausalParents = - Sqlite.execute - [Sqlite.sql| - DELETE FROM causal_parent AS cp - WHERE - -- We only need to check the children, because if it's impossible for a parent to be - -- unreachable if the child is reachable. A.k.a. reachable(child) =implies> reachable(parent) - NOT EXISTS (SELECT 1 FROM reachable_causals AS rc WHERE cp.causal_id = rc.self_hash_id) - |] - insertReachableCausalSql h = - Sqlite.execute - [Sqlite.sql| - INSERT INTO reachable_causals (self_hash_id) VALUES (:h) - ON CONFLICT DO NOTHING - |] - insertReachableBranchObjectSql o = - Sqlite.execute - [Sqlite.sql| - INSERT INTO reachable_branch_objects (object_id) VALUES (:o) - ON CONFLICT DO NOTHING - |] - createReachabilityTables = do - Sqlite.execute - [Sqlite.sql| - CREATE TEMP TABLE IF NOT EXISTS reachable_branch_objects ( - object_id INTEGER PRIMARY KEY NOT NULL - ) - |] - Sqlite.execute - [Sqlite.sql| - CREATE TEMP TABLE IF NOT EXISTS reachable_causals ( - self_hash_id INTEGER PRIMARY KEY NOT NULL - ) - |] - -migrateCausal :: DB.CausalHashId -> ExceptT (Sync.TrySyncResult DB.CausalHashId) (StateT MigrationState Sqlite.Transaction) () -migrateCausal causalHashId = do - preuse (canonicalBranchForCausalHashId . ix causalHashId) >>= \case - Just _ -> throwError Sync.PreviouslyDone - Nothing -> do - causalParents <- liftT $ Q.loadCausalParents causalHashId - unmigratedParents <- flip filterM causalParents $ \parentHashId -> (uses canonicalBranchForCausalHashId (Map.notMember parentHashId)) - when (not . null $ unmigratedParents) $ throwError (Sync.Missing unmigratedParents) - valueHashId <- liftT $ Q.expectCausalValueHashId causalHashId - preuse (validBranchHashIds . ix valueHashId) >>= \case - Nothing -> pure () - Just objId -> do - canonicalBranchForCausalHashId . at causalHashId ?= (valueHashId, objId) - throwError Sync.Done - liftT (Q.loadBranchObjectIdByCausalHashId causalHashId) >>= \case - Nothing -> do - liftT . abortMigration $ "Missing object for child branch of causal: " <> show causalHashId - Just branchObjId -> do - rehashAndCanonicalizeNamespace causalHashId valueHashId branchObjId - -rehashAndCanonicalizeNamespace :: DB.CausalHashId -> DB.BranchHashId -> DB.BranchObjectId -> ExceptT (Sync.TrySyncResult DB.CausalHashId) (StateT MigrationState Sqlite.Transaction) () -rehashAndCanonicalizeNamespace causalHashId possiblyIncorrectNamespaceHashId objId = do - dbBranch <- liftT $ Ops.expectDbBranch objId - canonicalBranchForCausalMap <- use canonicalBranchForCausalHashId - -- remap all of the object ID's of the child branches to the correct and canonical objects, - -- get a list of any unmigrated children, and also track whether any re-mappings actually - -- occurred, so we don't do extra work when nothing changed. - let ((unmigratedChildren, Any changes), remappedBranch) = - dbBranch - & DBBranch.childrenHashes_ %%~ \(ids@(childBranchObjId, childCausalHashId)) -> do - case Map.lookup childCausalHashId canonicalBranchForCausalMap of - Nothing -> (([childCausalHashId], Any False), ids) - Just (_, canonicalObjId) -> - let changed = canonicalObjId /= childBranchObjId - in (([], Any changed), (canonicalObjId, childCausalHashId)) - when (not . null $ unmigratedChildren) $ throwError (Sync.Missing unmigratedChildren) - when changes $ do - liftT $ replaceBranch objId remappedBranch - correctNamespaceHash <- liftT $ Helpers.dbBranchHash remappedBranch - liftT . debugLog $ "Correct namespace hash: " <> show correctNamespaceHash - correctNamespaceHashId <- liftT $ Q.saveBranchHash correctNamespaceHash - - when (correctNamespaceHashId == possiblyIncorrectNamespaceHashId) $ do - -- If the existing hash for this namespace was already correct, we don't need to - -- canonicalize the branch or worry about deleting/updating bad objects. - -- We just record the mapping and move on. - canonicalBranchForCausalHashId . at causalHashId ?= (correctNamespaceHashId, objId) - validBranchHashIds . at possiblyIncorrectNamespaceHashId ?= objId - throwError Sync.Done - - -- Update the value_hash_id on the causal to the correct hash for the branch - liftT $ updateCausalValueHash correctNamespaceHashId possiblyIncorrectNamespaceHashId - -- It's possible that an object already exists for this new hash - mayCanonical <- getCanonicalObjectForHash correctNamespaceHashId - liftT . debugLog $ "(objId, Canonical object ID):" <> show (objId, mayCanonical) - liftT . debugLog $ "Updating causal value hash (from, to)" <> show (possiblyIncorrectNamespaceHashId, correctNamespaceHashId) - canonicalObjId <- case mayCanonical of - -- If there's an existing canonical object, record the mapping from this object id to - -- that one. - Just canonicalObjectId - | canonicalObjectId /= objId -> do - -- Found an existing but different object with this hash, so the current object is a duplicate and - -- needs to be deleted. - liftT . debugLog $ "Mapping objID: " <> show objId <> " to canonical: " <> show canonicalObjectId - liftT . debugLog $ "Unilaterally deleting: " <> show objId - -- Remove possible foreign-key references before deleting the objects themselves - liftT $ deleteHashObjectsByObjectId objId - liftT $ deleteObjectById objId - pure canonicalObjectId - | otherwise -> do - -- This should be impossible. - error $ "We proved that the new hash is different from the existing one, but somehow found the same object for each hash. Please report this as a bug." <> show (objId, canonicalObjectId) - Nothing -> do - -- There's no existing canonical object, this object BECOMES the canonical one by - -- reassigning its primary hash. - liftT . debugLog $ "Updating in place: " <> show objId - liftT $ deleteHashObjectsByObjectId objId - liftT $ updateHashIdForObject correctNamespaceHashId objId - liftT $ Q.saveHashObject (DB.unBranchHashId correctNamespaceHashId) (DB.unBranchObjectId objId) 2 - pure objId - -- Save the canonical branch info for the causal for use in remappings. - canonicalBranchForCausalHashId . at causalHashId ?= (correctNamespaceHashId, canonicalObjId) - where - updateCausalValueHash :: DB.BranchHashId -> DB.BranchHashId -> Sqlite.Transaction () - updateCausalValueHash correctNamespaceHashId possiblyIncorrectNamespaceHashId = - Sqlite.execute - [Sqlite.sql| - UPDATE causal - SET value_hash_id = :correctNamespaceHashId - WHERE value_hash_id = :possiblyIncorrectNamespaceHashId - |] - - getCanonicalObjectForHash :: - DB.BranchHashId -> - ExceptT - (Sync.TrySyncResult DB.CausalHashId) - (StateT MigrationState Sqlite.Transaction) - (Maybe DB.BranchObjectId) - getCanonicalObjectForHash namespaceHashId = - liftT $ - Sqlite.queryMaybeCol - [Sqlite.sql| - SELECT id - FROM object - WHERE primary_hash_id = :namespaceHashId - |] - - updateHashIdForObject hashId objId = - Sqlite.execute - [Sqlite.sql| - UPDATE object - SET primary_hash_id = :hashId - WHERE id = :objId - |] - - -- Replace the bytes payload of a given branch in-place. - -- This does NOT update the hash of the object. - replaceBranch :: DB.BranchObjectId -> DBBranch.DbBranch -> Sqlite.Transaction () - replaceBranch objId branch = do - let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch branch - let bytes = S.putBytes S.putBranchFormat $ S.BranchFormat.Full localBranchIds localBranch - Sqlite.execute - [Sqlite.sql| - UPDATE object - SET bytes = :bytes - WHERE id = :objId - |] - - deleteHashObjectsByObjectId objId = - Sqlite.execute - [Sqlite.sql| - DELETE FROM hash_object - WHERE object_id = :objId - |] - - deleteObjectById objId = - Sqlite.execute - [Sqlite.sql| - DELETE FROM object - WHERE id = :objId - |] - -log :: String -> Sqlite.Transaction () -log = Sqlite.unsafeIO . putStrLn - -debugLog :: String -> Sqlite.Transaction () -debugLog = Debug.whenDebug Debug.Migration . Sqlite.unsafeIO . putStrLn diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema5To6.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema5To6.hs deleted file mode 100644 index 9395c3919d..0000000000 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema5To6.hs +++ /dev/null @@ -1,64 +0,0 @@ -module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema5To6 (migrateSchema5To6) where - -import Data.Text qualified as Text -import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) -import System.FilePath (()) -import U.Codebase.HashTags (CausalHash (CausalHash)) -import U.Codebase.Reflog qualified as Reflog -import U.Codebase.Sqlite.Operations qualified as Ops -import U.Codebase.Sqlite.Queries qualified as Q -import Unison.Codebase (CodebasePath) -import Unison.Hash qualified as Hash -import Unison.Prelude -import Unison.Sqlite qualified as Sqlite -import UnliftIO (catchIO) - --- | The 5 to 6 migration adds the reflog as a table in the DB -migrateSchema5To6 :: CodebasePath -> Sqlite.Transaction () -migrateSchema5To6 codebasePath = do - Q.expectSchemaVersion 5 - Q.addReflogTable - migrateCurrentReflog codebasePath - Q.setSchemaVersion 6 - -migrateCurrentReflog :: CodebasePath -> Sqlite.Transaction () -migrateCurrentReflog codebasePath = do - now <- Sqlite.unsafeIO $ getCurrentTime - oldEntries <- Sqlite.unsafeIO $ oldReflogEntries reflogPath now - for_ oldEntries \oldEntry -> do - -- There's no guarantee these causals actually exist in the DB, - -- so we check first to avoid triggering a bad foreign key constraint. - haveFrom <- isJust <$> Q.loadCausalByCausalHash (Reflog.fromRootCausalHash oldEntry) - haveTo <- isJust <$> Q.loadCausalByCausalHash (Reflog.toRootCausalHash oldEntry) - when (haveFrom && haveTo) $ Ops.appendReflog oldEntry - Sqlite.unsafeIO . putStrLn $ "I migrated old reflog entries from " <> reflogPath <> " into the codebase; you may delete that file now if you like." - where - reflogPath :: FilePath - reflogPath = codebasePath "reflog" - -oldReflogEntries :: CodebasePath -> UTCTime -> IO [Reflog.Entry CausalHash Text] -oldReflogEntries reflogPath now = - ( do - contents <- readUtf8 reflogPath - let lines = Text.lines contents - let entries = mapMaybe parseEntry (zip [0 ..] $ reverse lines) - pure entries - ) - `catchIO` const (pure []) - where - parseEntry :: (Integer, Text) -> Maybe (Reflog.Entry CausalHash Text) - parseEntry (n, txt) = - -- We offset existing entries by a number of seconds corresponding to their position in - -- the current file; we can't reclaim timestamps for old reflog entries, but this at - -- least puts them in the correct order chronologically. - let offsetTime = addUTCTime (negate $ fromInteger @NominalDiffTime n) now - in case Text.words txt of - (Hash.fromBase32HexText -> Just old) : (Hash.fromBase32HexText -> Just new) : (Text.unwords -> reason) -> - Just $ - Reflog.Entry - { time = offsetTime, - fromRootCausalHash = CausalHash old, - toRootCausalHash = CausalHash new, - reason - } - _ -> Nothing diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs deleted file mode 100644 index b62708f70c..0000000000 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE QuasiQuotes #-} - -module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema6To7 (migrateSchema6To7) where - -import Control.Monad.Except -import Control.Monad.State -import U.Codebase.Branch.Type (NamespaceStats) -import U.Codebase.Sqlite.DbId qualified as DB -import U.Codebase.Sqlite.DbId qualified as Db -import U.Codebase.Sqlite.Operations qualified as Ops -import U.Codebase.Sqlite.Queries qualified as Q -import U.Codebase.Sync qualified as Sync -import Unison.Debug qualified as Debug -import Unison.Sqlite qualified as Sqlite - --- | Adds a table for tracking namespace statistics --- Adds stats for all existing namespaces, even though missing stats are computed on-demand if missing. -migrateSchema6To7 :: Sqlite.Transaction () -migrateSchema6To7 = do - Q.expectSchemaVersion 6 - Q.addNamespaceStatsTables - addStatsToAllNamespaces - Q.setSchemaVersion 7 - -addStatsToAllNamespaces :: Sqlite.Transaction () -addStatsToAllNamespaces = do - totalToMigrate <- - Sqlite.queryOneCol - [Sqlite.sql| - SELECT COUNT(*) - FROM object - WHERE type_id = 2 - |] - allBranchObjIds <- - Sqlite.queryListCol - [Sqlite.sql| - SELECT id - FROM object - WHERE type_id = 2 - |] - _ <- flip runStateT 0 $ Sync.sync migrationSync (migrationProgress totalToMigrate) allBranchObjIds - pure () - -migrationSync :: Sync.Sync (StateT Int Sqlite.Transaction) DB.BranchObjectId -migrationSync = - Sync.Sync (lift . addStatsForBranch) - -addStatsForBranch :: DB.BranchObjectId -> Sqlite.Transaction (Sync.TrySyncResult DB.BranchObjectId) -addStatsForBranch boId = do - bhId <- Db.BranchHashId <$> Q.expectPrimaryHashIdForObject (Db.unBranchObjectId boId) - -- "expectNamespaceStatsByHashId" computes stats if they are missing. - _ :: NamespaceStats <- Ops.expectNamespaceStatsByHashId bhId - pure Sync.Done - -debugLog :: String -> Sqlite.Transaction () -debugLog = Debug.whenDebug Debug.Migration . Sqlite.unsafeIO . putStrLn - -migrationProgress :: Int -> Sync.Progress (StateT Int Sqlite.Transaction) DB.BranchObjectId -migrationProgress totalBranches = - Sync.Progress {Sync.need, Sync.done, Sync.error, Sync.allDone} - where - need e = lift $ debugLog $ "Need " <> show e - done _ = - do - modify succ - numDone <- get - lift $ Sqlite.unsafeIO $ putStr $ "\ršŸ— " <> show numDone <> " / ~" <> show totalBranches <> " entities migrated. šŸš§" - error e = lift . Sqlite.unsafeIO . putStrLn $ "Error " <> show e - allDone = lift do - -- In some corrupted codebases we don't necessarily process every causal, or there may - -- be unreachable causals. We'll show the final number here just so everything looks - -- good to users. It's okay since we'll process the other branches and clean them up in - -- a batch step. - Sqlite.unsafeIO $ putStrLn $ "\ršŸ— " <> show totalBranches <> " / ~" <> show totalBranches <> " entities migrated. šŸš§" - Sqlite.unsafeIO . putStrLn $ "Finished." diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema7To8.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema7To8.hs deleted file mode 100644 index 639f801561..0000000000 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema7To8.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema7To8 (migrateSchema7To8) where - -import U.Codebase.Sqlite.Queries qualified as Q -import Unison.Sqlite qualified as Sqlite - --- | Adds a table for tracking namespace statistics --- Adds stats for all existing namespaces, even though missing stats are computed on-demand if missing. -migrateSchema7To8 :: Sqlite.Transaction () -migrateSchema7To8 = do - Q.expectSchemaVersion 7 - createScopedNameLookupTables - Q.setSchemaVersion 8 - --- | Create the scoped name lookup tables. -createScopedNameLookupTables :: Sqlite.Transaction () -createScopedNameLookupTables = do - -- This table allows us to look up which causal hashes have a name lookup. - Sqlite.execute - [Sqlite.sql| - CREATE TABLE name_lookups ( - root_branch_hash_id INTEGER PRIMARY KEY REFERENCES hash(id) ON DELETE CASCADE - ) - |] - - Sqlite.execute - [Sqlite.sql| - CREATE TABLE scoped_term_name_lookup ( - root_branch_hash_id INTEGER NOT NULL REFERENCES hash(id) ON DELETE CASCADE, - - -- The name of the term in reversed form, with a trailing '.': - -- E.g. map.List.base. - -- - -- The trailing '.' is helpful when performing suffix queries where we may not know - -- whether the suffix is complete or not, e.g. we could suffix search using any of the - -- following globs and it would still find 'map.List.base.': - -- map.List.base.* - -- map.List.* - -- map.* - reversed_name TEXT NOT NULL, - - -- The last name segment of the name. This is used when looking up names for - -- suffixification when building PPEs. - -- E.g. for the name 'base.List.map' this would be 'map' - last_name_segment TEXT NOT NULL, - - -- The namespace containing this definition, not reversed, with a trailing '.' - -- The trailing '.' simplifies GLOB queries, so that 'base.*' matches both things in - -- 'base' and 'base.List', but not 'base1', which allows us to avoid an OR in our where - -- clauses which in turn helps the sqlite query planner use indexes more effectively. - -- - -- example value: 'base.List.' - namespace TEXT NOT NULL, - referent_builtin TEXT NULL, - referent_component_hash TEXT NULL, - referent_component_index INTEGER NULL, - referent_constructor_index INTEGER NULL, - referent_constructor_type INTEGER NULL, - PRIMARY KEY (root_branch_hash_id, reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index) - ) - |] - - -- This index allows finding all names we need to consider within a given namespace for - -- suffixification of a name. - -- It may seem strange to use last_name_segment rather than a suffix search over reversed_name name here; - -- but SQLite will only optimize for a single prefix-glob at once, so we can't glob search - -- over both namespace and reversed_name, but we can EXACT match on last_name_segment and - -- then glob search on the namespace prefix, and have SQLite do the final glob search on - -- reversed_name over rows with a matching last segment without using an index and should be plenty fast. - Sqlite.execute - [Sqlite.sql| - CREATE INDEX scoped_term_names_by_namespace_and_last_name_segment ON scoped_term_name_lookup(root_branch_hash_id, last_name_segment, namespace) - |] - -- This index allows us to find all names with a given ref within a specific namespace - Sqlite.execute - [Sqlite.sql| - CREATE INDEX scoped_term_name_by_referent_lookup ON scoped_term_name_lookup(root_branch_hash_id, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, namespace) - |] - - -- Allows fetching ALL names within a specific namespace prefix. We currently use this to - -- pretty-print on share, but will be replaced with a more precise set of queries soon. - Sqlite.execute - [Sqlite.sql| - CREATE INDEX scoped_term_names_by_namespace ON scoped_term_name_lookup(root_branch_hash_id, namespace) - |] - Sqlite.execute - [Sqlite.sql| - CREATE TABLE scoped_type_name_lookup ( - root_branch_hash_id INTEGER NOT NULL REFERENCES hash(id), - -- The name of the term: E.g. List.base - reversed_name TEXT NOT NULL, - -- The last name segment of the name. This is used when looking up names for - -- suffixification when building PPEs. - -- E.g. for the name 'base.List.map' this would be 'map' - last_name_segment TEXT NOT NULL, - -- The namespace containing this definition, not reversed, with a trailing '.' - -- The trailing '.' simplifies GLOB queries, so that 'base.*' matches both things in - -- 'base' and 'base.List', but not 'base1', which allows us to avoid an OR in our where - -- clauses which in turn helps the sqlite query planner use indexes more effectively. - -- - -- example value: 'base.List.' - namespace TEXT NOT NULL, - reference_builtin TEXT NULL, - reference_component_hash INTEGER NULL, - reference_component_index INTEGER NULL, - PRIMARY KEY (reversed_name, reference_builtin, reference_component_hash, reference_component_index) - ); - |] - - -- This index allows finding all names we need to consider within a given namespace for - -- suffixification of a name. - -- It may seem strange to use last_name_segment rather than a suffix search over reversed_name name here; - -- but SQLite will only optimize for a single prefix-glob at once, so we can't glob search - -- over both namespace and reversed_name, but we can EXACT match on last_name_segment and - -- then glob search on the namespace prefix, and have SQLite do the final glob search on - -- reversed_name over rows with a matching last segment without using an index and should be plenty fast. - Sqlite.execute - [Sqlite.sql| - CREATE INDEX scoped_type_names_by_namespace_and_last_name_segment ON scoped_type_name_lookup(root_branch_hash_id, last_name_segment, namespace) - |] - - -- This index allows us to find all names with a given ref within a specific namespace. - Sqlite.execute - [Sqlite.sql| - CREATE INDEX scoped_type_name_by_reference_lookup ON scoped_type_name_lookup(root_branch_hash_id, reference_builtin, reference_component_hash, reference_component_index, namespace) - |] - - -- Allows fetching ALL names within a specific namespace prefix. We currently use this to - -- pretty-print on share, but will be replaced with a more precise set of queries soon. - Sqlite.execute - [Sqlite.sql| - CREATE INDEX scoped_type_names_by_namespace ON scoped_type_name_lookup(root_branch_hash_id, namespace) - |] diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 7a9a467093..376f6199b1 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -72,12 +72,7 @@ library Unison.Codebase.SqliteCodebase.Migrations Unison.Codebase.SqliteCodebase.Migrations.Helpers Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12 - Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers - Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 - Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema5To6 - Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema6To7 - Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema7To8 Unison.Codebase.SqliteCodebase.Operations Unison.Codebase.SqliteCodebase.Paths Unison.Codebase.SqliteCodebase.SyncEphemeral