From 62964ca2b633609c88c6aeac3f09088877977d71 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 28 May 2024 10:22:29 -0700 Subject: [PATCH 1/2] Remove Sync22 --- .../U/Codebase/Sqlite/Sync22.hs | 414 ------------------ .../unison-codebase-sqlite.cabal | 3 +- parser-typechecker/src/Unison/Codebase.hs | 4 - .../src/Unison/Codebase/SqliteCodebase.hs | 204 +-------- .../Codebase/SqliteCodebase/SyncEphemeral.hs | 4 +- .../src/Unison/Codebase/Type.hs | 4 - 6 files changed, 6 insertions(+), 627 deletions(-) delete mode 100644 codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs deleted file mode 100644 index beb2591be2..0000000000 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs +++ /dev/null @@ -1,414 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module U.Codebase.Sqlite.Sync22 where - -import Control.Monad.Except (MonadError (throwError)) -import Control.Monad.Validate (ValidateT, runValidateT) -import Control.Monad.Validate qualified as Validate -import Data.Bitraversable (bitraverse) -import Data.Bytes.Get (runGetS) -import Data.Bytes.Put (runPutS) -import Data.List.Extra (nubOrd) -import Data.Set qualified as Set -import Data.Vector qualified as Vector -import U.Codebase.Reference qualified as Reference -import U.Codebase.Sqlite.Branch.Format qualified as BL -import U.Codebase.Sqlite.DbId -import U.Codebase.Sqlite.Decl.Format qualified as DeclFormat -import U.Codebase.Sqlite.HashHandle (HashHandle) -import U.Codebase.Sqlite.LocalIds qualified as L -import U.Codebase.Sqlite.ObjectType qualified as OT -import U.Codebase.Sqlite.Patch.Format qualified as PL -import U.Codebase.Sqlite.Queries qualified as Q -import U.Codebase.Sqlite.Reference qualified as Sqlite -import U.Codebase.Sqlite.Reference qualified as Sqlite.Reference -import U.Codebase.Sqlite.Referent qualified as Sqlite.Referent -import U.Codebase.Sqlite.Serialization qualified as S -import U.Codebase.Sqlite.Term.Format qualified as TL -import U.Codebase.Sqlite.Term.Format qualified as TermFormat -import U.Codebase.Sync (Sync (Sync), TrySyncResult) -import U.Codebase.Sync qualified as Sync -import U.Codebase.WatchKind qualified as WK -import Unison.Prelude -import Unison.Sqlite (Transaction) -import Unison.Util.Cache (Cache) -import Unison.Util.Cache qualified as Cache - -data Entity - = O ObjectId - | C CausalHashId - | W WK.WatchKind Sqlite.Reference.IdH - deriving (Eq, Ord, Show) - -data DecodeError - = ErrTermComponent - | ErrDeclComponent - | ErrBranchFormat - | ErrPatchFormat - | ErrWatchResult - deriving (Show) - -type ErrString = String - -data Error - = DecodeError DecodeError ByteString ErrString - | -- | hashes corresponding to a single object in source codebase - -- correspond to multiple objects in destination codebase - HashObjectCorrespondence ObjectId [HashId] [HashId] [ObjectId] - | SourceDbNotExist - deriving (Show) - -data Env m = Env - { runSrc :: forall a. Transaction a -> m a, - runDest :: forall a. Transaction a -> m a, - -- | there are three caches of this size - idCacheSize :: Word - } - -hoistEnv :: (forall x. m x -> n x) -> Env m -> Env n -hoistEnv f Env {runSrc, runDest, idCacheSize} = - Env - { runSrc = f . runSrc, - runDest = f . runDest, - idCacheSize - } - -debug :: Bool -debug = False - --- data Mappings -sync22 :: - ( MonadIO m, - MonadError Error m - ) => - HashHandle -> - Env m -> - IO (Sync m Entity) -sync22 hh Env {runSrc, runDest, idCacheSize = size} = do - tCache <- Cache.semispaceCache size - hCache <- Cache.semispaceCache size - oCache <- Cache.semispaceCache size - cCache <- Cache.semispaceCache size - pure $ Sync (trySync hh runSrc runDest tCache hCache oCache cCache) - -trySync :: - forall m. - (MonadIO m, MonadError Error m) => - HashHandle -> - (forall a. Transaction a -> m a) -> - (forall a. Transaction a -> m a) -> - Cache TextId TextId -> - Cache HashId HashId -> - Cache ObjectId ObjectId -> - Cache CausalHashId CausalHashId -> - Entity -> - m (TrySyncResult Entity) -trySync hh runSrc runDest tCache hCache oCache cCache = \case - -- for causals, we need to get the value_hash_id of the thingo - -- - maybe enqueue their parents - -- - enqueue the self_ and value_ hashes - -- - enqueue the namespace object, if present - C chId -> - isSyncedCausal chId >>= \case - Just {} -> pure Sync.PreviouslyDone - Nothing -> do - result <- runValidateT @(Set Entity) @m @() do - bhId <- lift . runSrc $ Q.expectCausalValueHashId chId - mayBoId <- lift . runSrc . Q.loadObjectIdForAnyHashId $ unBranchHashId bhId - traverse_ syncLocalObjectId mayBoId - - parents' :: [CausalHashId] <- findParents' chId - bhId' <- lift $ syncBranchHashId bhId - chId' <- lift $ syncCausalHashId chId - lift (runDest (Q.saveCausal hh chId' bhId' parents')) - - case result of - Left deps -> pure . Sync.Missing $ toList deps - Right () -> pure Sync.Done - - -- objects are the hairiest. obviously, if they - -- exist, we're done; otherwise we do some fancy stuff - O oId -> - isSyncedObject oId >>= \case - Just {} -> pure Sync.PreviouslyDone - Nothing -> do - (hId, objType, bytes) <- runSrc $ Q.expectObjectWithHashIdAndType oId - hId' <- syncHashLiteral hId - result <- runValidateT @(Set Entity) @m @ObjectId case objType of - OT.TermComponent -> do - -- split up the localIds (parsed), term, and type blobs - case flip runGetS bytes S.decomposeTermFormat of - Left s -> throwError $ DecodeError ErrTermComponent bytes s - Right - ( TermFormat.SyncTerm - ( TermFormat.SyncLocallyIndexedComponent - (Vector.unzip -> (localIds, bytes)) - ) - ) -> do - -- iterate through the local ids looking for missing deps; - -- then either enqueue the missing deps, or proceed to move the object - when debug $ traceM $ "LocalIds for Source " ++ show oId ++ ": " ++ show localIds - localIds' <- traverse syncLocalIds localIds - when debug $ traceM $ "LocalIds for Dest: " ++ show localIds' - -- reassemble and save the reindexed term - let bytes' = - runPutS - . S.recomposeTermFormat - . TermFormat.SyncTerm - . TermFormat.SyncLocallyIndexedComponent - $ Vector.zip localIds' bytes - lift do - oId' <- runDest $ Q.saveObject hh hId' objType bytes' - -- copy reference-specific stuff - for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do - let ref = Reference.Id oId idx - refH = Reference.Id hId idx - ref' = Reference.Id oId' idx - -- sync watch results - for_ [WK.TestWatch] \wk -> - syncWatch wk refH - syncDependenciesIndex ref ref' - syncTypeIndex oId oId' - syncTypeMentionsIndex oId oId' - pure oId' - OT.DeclComponent -> do - -- split up the localIds (parsed), decl blobs - case flip runGetS bytes S.decomposeDeclFormat of - Left s -> throwError $ DecodeError ErrDeclComponent bytes s - Right - ( DeclFormat.SyncDecl - ( DeclFormat.SyncLocallyIndexedComponent - (Vector.unzip -> (localIds, declBytes)) - ) - ) -> do - -- iterate through the local ids looking for missing deps; - -- then either enqueue the missing deps, or proceed to move the object - localIds' <- traverse syncLocalIds localIds - -- reassemble and save the reindexed term - let bytes' = - runPutS - . S.recomposeDeclFormat - . DeclFormat.SyncDecl - . DeclFormat.SyncLocallyIndexedComponent - $ Vector.zip localIds' declBytes - lift do - oId' <- runDest $ Q.saveObject hh hId' objType bytes' - -- copy per-element-of-the-component stuff - for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do - let ref = Reference.Id oId idx - ref' = Reference.Id oId' idx - syncDependenciesIndex ref ref' - syncTypeIndex oId oId' - syncTypeMentionsIndex oId oId' - pure oId' - OT.Namespace -> case flip runGetS bytes S.decomposeBranchFormat of - Right (BL.SyncFull ids body) -> do - ids' <- syncBranchLocalIds ids - let bytes' = runPutS $ S.recomposeBranchFormat (BL.SyncFull ids' body) - oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes' - pure oId' - Right (BL.SyncDiff boId ids body) -> do - boId' <- syncBranchObjectId boId - ids' <- syncBranchLocalIds ids - let bytes' = runPutS $ S.recomposeBranchFormat (BL.SyncDiff boId' ids' body) - oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes' - pure oId' - Left s -> throwError $ DecodeError ErrBranchFormat bytes s - OT.Patch -> case flip runGetS bytes S.decomposePatchFormat of - Right (PL.SyncFull ids body) -> do - ids' <- syncPatchLocalIds ids - let bytes' = runPutS $ S.recomposePatchFormat (PL.SyncFull ids' body) - oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes' - pure oId' - Right (PL.SyncDiff poId ids body) -> do - poId' <- syncPatchObjectId poId - ids' <- syncPatchLocalIds ids - let bytes' = runPutS $ S.recomposePatchFormat (PL.SyncDiff poId' ids' body) - oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes' - pure oId' - Left s -> throwError $ DecodeError ErrPatchFormat bytes s - case result of - Left deps -> pure . Sync.Missing $ toList deps - Right oId' -> do - syncSecondaryHashes oId oId' - when debug $ traceM $ "Source " ++ show (hId, oId) ++ " becomes Dest " ++ show (hId', oId') - Cache.insert oCache oId oId' - pure Sync.Done - W k r -> syncWatch k r - where - syncLocalObjectId :: ObjectId -> ValidateT (Set Entity) m ObjectId - syncLocalObjectId oId = - lift (isSyncedObject oId) >>= \case - Just oId' -> pure oId' - Nothing -> Validate.refute . Set.singleton $ O oId - - syncPatchObjectId :: PatchObjectId -> ValidateT (Set Entity) m PatchObjectId - syncPatchObjectId = fmap PatchObjectId . syncLocalObjectId . unPatchObjectId - - syncBranchObjectId :: BranchObjectId -> ValidateT (Set Entity) m BranchObjectId - syncBranchObjectId = fmap BranchObjectId . syncLocalObjectId . unBranchObjectId - - syncCausal :: CausalHashId -> ValidateT (Set Entity) m CausalHashId - syncCausal chId = - lift (isSyncedCausal chId) >>= \case - Just chId' -> pure chId' - Nothing -> Validate.refute . Set.singleton $ C chId - - syncDependenciesIndex :: Sqlite.Reference.Id -> Sqlite.Reference.Id -> m () - syncDependenciesIndex ref ref' = do - deps <- runSrc (Q.getDependenciesForDependent ref) - deps' <- for deps expectSyncedObjectReference - runDest (Q.addToDependentsIndex deps' ref') - - syncLocalIds :: L.LocalIds -> ValidateT (Set Entity) m L.LocalIds - syncLocalIds (L.LocalIds tIds oIds) = do - oIds' <- traverse syncLocalObjectId oIds - tIds' <- lift $ traverse syncTextLiteral tIds - pure $ L.LocalIds tIds' oIds' - - syncPatchLocalIds :: PL.PatchLocalIds -> ValidateT (Set Entity) m PL.PatchLocalIds - syncPatchLocalIds (PL.LocalIds tIds hIds oIds) = do - oIds' <- traverse syncLocalObjectId oIds - tIds' <- lift $ traverse syncTextLiteral tIds - hIds' <- lift $ traverse syncHashLiteral hIds - pure $ PL.LocalIds tIds' hIds' oIds' - - syncBranchLocalIds :: BL.BranchLocalIds -> ValidateT (Set Entity) m BL.BranchLocalIds - syncBranchLocalIds (BL.LocalIds tIds oIds poIds chboIds) = do - oIds' <- traverse syncLocalObjectId oIds - poIds' <- traverse (fmap PatchObjectId . syncLocalObjectId . unPatchObjectId) poIds - chboIds' <- traverse (bitraverse syncBranchObjectId syncCausal) chboIds - tIds' <- lift $ traverse syncTextLiteral tIds - pure $ BL.LocalIds tIds' oIds' poIds' chboIds' - - syncTypeIndex :: ObjectId -> ObjectId -> m () - syncTypeIndex oId oId' = do - rows <- runSrc (Q.getTypeReferencesForComponent oId) - -- defensively nubOrd to guard against syncing from codebases with duplicate rows in their type (mentions) indexes - -- alternatively, we could put a unique constraint on the whole 6-tuple of the index tables, and optimistically - -- insert with an `on conflict do nothing`. - for_ (nubOrd rows) \row -> do - row' <- syncTypeIndexRow oId' row - runDest (uncurry Q.addToTypeIndex row') - - syncTypeMentionsIndex :: ObjectId -> ObjectId -> m () - syncTypeMentionsIndex oId oId' = do - rows <- runSrc (Q.getTypeMentionsReferencesForComponent oId) - -- see "defensively nubOrd..." comment above in `syncTypeIndex` - for_ (nubOrd rows) \row -> do - row' <- syncTypeIndexRow oId' row - runDest (uncurry Q.addToTypeMentionsIndex row') - - syncTypeIndexRow :: - ObjectId -> - (Sqlite.Reference.ReferenceH, Sqlite.Referent.Id) -> - m (Sqlite.Reference.ReferenceH, Sqlite.Referent.Id) - syncTypeIndexRow oId' = bitraverse syncHashReference (pure . rewriteTypeIndexReferent oId') - - rewriteTypeIndexReferent :: ObjectId -> Sqlite.Referent.Id -> Sqlite.Referent.Id - rewriteTypeIndexReferent oId' = bimap (const oId') (const oId') - - syncTextLiteral :: TextId -> m TextId - syncTextLiteral = Cache.apply tCache \tId -> do - t <- runSrc $ Q.expectText tId - tId' <- runDest $ Q.saveText t - when debug $ traceM $ "Source " ++ show tId ++ " is Dest " ++ show tId' ++ " (" ++ show t ++ ")" - pure tId' - - syncHashLiteral :: HashId -> m HashId - syncHashLiteral = Cache.apply hCache \hId -> do - b32hex <- runSrc $ Q.expectHash32 hId - hId' <- runDest $ Q.saveHash b32hex - when debug $ traceM $ "Source " ++ show hId ++ " is Dest " ++ show hId' ++ " (" ++ show b32hex ++ ")" - pure hId' - - isSyncedObjectReference :: Sqlite.Reference -> m (Maybe Sqlite.Reference) - isSyncedObjectReference = \case - Reference.ReferenceBuiltin t -> - Just . Reference.ReferenceBuiltin <$> syncTextLiteral t - Reference.ReferenceDerived id -> - fmap Reference.ReferenceDerived <$> isSyncedObjectReferenceId id - - isSyncedObjectReferenceId :: Sqlite.Reference.Id -> m (Maybe Sqlite.Reference.Id) - isSyncedObjectReferenceId (Reference.Id oId idx) = - isSyncedObject oId <&> fmap (\oId' -> Reference.Id oId' idx) - - -- Assert that a reference's component is already synced, and return the corresponding reference. - expectSyncedObjectReference :: Sqlite.Reference -> m Sqlite.Reference - expectSyncedObjectReference ref = - isSyncedObjectReference ref <&> \case - Nothing -> error (reportBug "E452280" ("unsynced object reference " ++ show ref)) - Just ref' -> ref' - - syncHashReference :: Sqlite.ReferenceH -> m Sqlite.ReferenceH - syncHashReference = bitraverse syncTextLiteral syncHashLiteral - - syncCausalHashId :: CausalHashId -> m CausalHashId - syncCausalHashId = fmap CausalHashId . syncHashLiteral . unCausalHashId - - syncBranchHashId :: BranchHashId -> m BranchHashId - syncBranchHashId = fmap BranchHashId . syncHashLiteral . unBranchHashId - - findParents' :: CausalHashId -> ValidateT (Set Entity) m [CausalHashId] - findParents' chId = do - srcParents <- lift . runSrc $ Q.loadCausalParents chId - traverse syncCausal srcParents - - -- Sync any watches of the given kinds to the dest if and only if watches of those kinds - -- exist in the src. - syncWatch :: WK.WatchKind -> Sqlite.Reference.IdH -> m (TrySyncResult Entity) - syncWatch wk r | debug && trace ("Sync22.syncWatch " ++ show wk ++ " " ++ show r) False = undefined - syncWatch wk r = do - runSrc (Q.loadWatch wk r (Right :: ByteString -> Either Void ByteString)) >>= \case - Nothing -> pure Sync.Done - Just blob -> do - r' <- traverse syncHashLiteral r - doneKinds <- runDest (Q.loadWatchKindsByReference r') - if (elem wk doneKinds) - then pure Sync.PreviouslyDone - else do - TL.SyncWatchResult li body <- - either (throwError . DecodeError ErrWatchResult blob) pure $ runGetS S.decomposeWatchFormat blob - li' <- bitraverse syncTextLiteral syncHashLiteral li - when debug $ traceM $ "LocalIds for Source watch result " ++ show r ++ ": " ++ show li - when debug $ traceM $ "LocalIds for Dest watch result " ++ show r' ++ ": " ++ show li' - let blob' = runPutS $ S.recomposeWatchFormat (TL.SyncWatchResult li' body) - runDest (Q.saveWatch wk r' blob') - pure Sync.Done - - syncSecondaryHashes oId oId' = - runSrc (Q.hashIdWithVersionForObject oId) >>= traverse_ (go oId') - where - go oId' (hId, hashVersion) = do - hId' <- syncHashLiteral hId - runDest $ Q.saveHashObject hId' oId' hashVersion - - isSyncedObject :: ObjectId -> m (Maybe ObjectId) - isSyncedObject = Cache.applyDefined oCache \oId -> do - hIds <- toList <$> runSrc (Q.expectHashIdsForObject oId) - hIds' <- traverse syncHashLiteral hIds - ( nubOrd . catMaybes - <$> traverse (runDest . Q.loadObjectIdForAnyHashId) hIds' - ) - >>= \case - [oId'] -> do - when debug $ traceM $ "Source " ++ show oId ++ " is Dest " ++ show oId' - pure $ Just oId' - [] -> pure $ Nothing - oIds' -> throwError (HashObjectCorrespondence oId hIds hIds' oIds') - - isSyncedCausal :: CausalHashId -> m (Maybe CausalHashId) - isSyncedCausal = Cache.applyDefined cCache \chId -> do - let hId = unCausalHashId chId - hId' <- syncHashLiteral hId - ifM - (runDest $ Q.isCausalHash hId') - (pure . Just $ CausalHashId hId') - (pure Nothing) diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index ac1f606921..4409badc91 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack @@ -61,7 +61,6 @@ library U.Codebase.Sqlite.RemoteProjectBranch U.Codebase.Sqlite.Serialization U.Codebase.Sqlite.Symbol - U.Codebase.Sqlite.Sync22 U.Codebase.Sqlite.TempEntity U.Codebase.Sqlite.TempEntityType U.Codebase.Sqlite.Term.Format diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 107b765c3e..a02535675c 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -82,10 +82,6 @@ module Unison.Codebase -- * Sync - -- ** Local sync - syncFromDirectory, - syncToDirectory, - -- * Codebase path getCodebaseDir, CodebasePath, diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 18f21330e2..068665ec32 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -12,22 +12,15 @@ module Unison.Codebase.SqliteCodebase ) where -import Control.Monad.Except qualified as Except -import Control.Monad.Extra qualified as Monad import Data.Either.Extra () -import Data.IORef import Data.Map qualified as Map -import Data.Set qualified as Set import Data.Time (getCurrentTime) -import System.Console.ANSI qualified as ANSI import System.FileLock (SharedExclusive (Exclusive), withTryFileLock) -import U.Codebase.HashTags (CausalHash, PatchHash (..)) +import U.Codebase.HashTags (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 U.Codebase.Sqlite.Sync22 qualified as Sync22 import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) -import U.Codebase.Sync qualified as Sync import Unison.Codebase (Codebase, CodebasePath) import Unison.Codebase qualified as Codebase1 import Unison.Codebase.Branch (Branch (..)) @@ -39,12 +32,10 @@ import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..)) import Unison.Codebase.Init.OpenCodebaseError qualified as Codebase1 import Unison.Codebase.RootBranchCache import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache) -import Unison.Codebase.SqliteCodebase.Branch.Dependencies qualified as BD import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.Codebase.SqliteCodebase.Migrations qualified as Migrations import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps import Unison.Codebase.SqliteCodebase.Paths -import Unison.Codebase.SqliteCodebase.SyncEphemeral qualified as SyncEphemeral import Unison.Codebase.Type (LocalOrRemote (..)) import Unison.Codebase.Type qualified as C import Unison.DataDeclaration (Decl) @@ -59,15 +50,13 @@ import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) import Unison.Term (Term) import Unison.Type (Type) -import Unison.Util.Timing (time) import Unison.WatchKind qualified as UF -import UnliftIO (UnliftIO (..), finally) -import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) +import UnliftIO (finally) +import UnliftIO.Directory (createDirectoryIfMissing, doesFileExist) import UnliftIO.STM -debug, debugProcessBranches :: Bool +debug :: Bool debug = False -debugProcessBranches = False init :: (HasCallStack, MonadUnliftIO m) => @@ -130,14 +119,6 @@ withCodebaseOrError debugName dir lockOption migrationStrategy action = do False -> pure (Left Codebase1.OpenCodebaseDoesntExist) True -> sqliteCodebase debugName dir Local lockOption migrationStrategy action -initSchemaIfNotExist :: (MonadIO m) => FilePath -> m () -initSchemaIfNotExist path = liftIO do - unlessM (doesDirectoryExist $ makeCodebaseDirPath path) $ - createDirectoryIfMissing True (makeCodebaseDirPath path) - unlessM (doesFileExist $ makeCodebasePath path) $ - withConnection "initSchemaIfNotExist" path \conn -> - Sqlite.runTransaction conn Q.createSchema - -- 1) buffer up the component -- 2) in the event that the component is complete, then what? -- * can write component provided all of its dependency components are complete. @@ -280,25 +261,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action withRunInIO \runInIO -> runInIO (runTransaction (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch))) - syncFromDirectory :: Codebase1.CodebasePath -> Branch m -> m () - syncFromDirectory srcRoot b = - withConnection (debugName ++ ".sync.src") srcRoot \srcConn -> - withConn \destConn -> do - progressStateRef <- liftIO (newIORef emptySyncProgressState) - Sqlite.runReadOnlyTransaction srcConn \runSrc -> - Sqlite.runWriteTransaction destConn \runDest -> do - syncInternal (syncProgress progressStateRef) runSrc runDest b - - syncToDirectory :: Codebase1.CodebasePath -> Branch m -> m () - syncToDirectory destRoot b = - withConn \srcConn -> - withConnection (debugName ++ ".sync.dest") destRoot \destConn -> do - progressStateRef <- liftIO (newIORef emptySyncProgressState) - initSchemaIfNotExist destRoot - Sqlite.runReadOnlyTransaction srcConn \runSrc -> - Sqlite.runWriteTransaction destConn \runDest -> do - syncInternal (syncProgress progressStateRef) runSrc runDest b - getWatch :: UF.WatchKind -> Reference.Id -> Sqlite.Transaction (Maybe (Term Symbol Ann)) getWatch = CodebaseOps.getWatch getDeclType @@ -338,8 +300,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action putRootBranch, getBranchForHash, putBranch, - syncFromDirectory, - syncToDirectory, getWatch, termsOfTypeImpl, termsMentioningTypeImpl, @@ -366,79 +326,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action Nothing -> Left OpenCodebaseFileLockFailed Just x -> x -syncInternal :: - forall m. - (MonadUnliftIO m) => - Sync.Progress m Sync22.Entity -> - (forall a. Sqlite.Transaction a -> m a) -> - (forall a. Sqlite.Transaction a -> m a) -> - Branch m -> - m () -syncInternal progress runSrc runDest b = time "syncInternal" do - UnliftIO runInIO <- askUnliftIO - - let syncEnv = Sync22.Env runSrc runDest (16 * 1024 * 1024) - -- we want to use sync22 wherever possible - -- so for each source branch, we'll check if it exists in the destination codebase - -- or if it exists in the source codebase, then we can sync22 it - -- if it doesn't exist in the dest or source branch, - -- then just use putBranch to the dest - sync <- liftIO (Sync22.sync22 v2HashHandle (Sync22.hoistEnv lift syncEnv)) - let doSync :: [Sync22.Entity] -> m () - doSync = - throwExceptT - . Except.withExceptT SyncEphemeral.Sync22Error - . Sync.sync' sync (Sync.transformProgress lift progress) - let processBranches :: [Entity m] -> m () - processBranches = \case - [] -> pure () - b0@(B h mb) : rest -> do - when debugProcessBranches do - traceM $ "processBranches " ++ show b0 - traceM $ " queue: " ++ show rest - ifM - (runDest (CodebaseOps.branchExists h)) - do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " already exists in dest db" - processBranches rest - do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in dest db" - runSrc (Q.loadCausalHashIdByCausalHash h) >>= \case - Just chId -> do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " exists in source db, so delegating to direct sync" - doSync [Sync22.C chId] - processBranches rest - Nothing -> - mb >>= \b -> do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in either db, so delegating to Codebase.putBranch" - let (branchDeps, BD.to' -> BD.Dependencies' es ts ds) = BD.fromBranch b - when debugProcessBranches do - traceM $ " branchDeps: " ++ show (fst <$> branchDeps) - traceM $ " terms: " ++ show ts - traceM $ " decls: " ++ show ds - traceM $ " edits: " ++ show es - (cs, es, ts, ds) <- runDest do - cs <- filterM (fmap not . CodebaseOps.branchExists . fst) branchDeps - es <- filterM (fmap not . CodebaseOps.patchExists) es - ts <- filterM (fmap not . CodebaseOps.termExists) ts - ds <- filterM (fmap not . CodebaseOps.declExists) ds - pure (cs, es, ts, ds) - if null cs && null es && null ts && null ds - then do - runDest (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) b)) - processBranches rest - else do - let bs = map (uncurry B) cs - os = map O (coerce @[PatchHash] @[Hash] es <> ts <> ds) - processBranches (os ++ bs ++ b0 : rest) - O h : rest -> do - when debugProcessBranches $ traceM $ "processBranches O " ++ take 10 (show h) - oId <- runSrc (Q.expectHashIdByHash h >>= Q.expectObjectIdForAnyHashId) - doSync [Sync22.O oId] - processBranches rest - let bHash = Branch.headHash b - time "SyncInternal.processBranches" $ processBranches [B bHash (pure b)] - data Entity m = B CausalHash (m (Branch m)) | O Hash @@ -447,89 +334,6 @@ instance Show (Entity m) where show (B h _) = "B " ++ take 10 (show h) show (O h) = "O " ++ take 10 (show h) -data SyncProgressState = SyncProgressState - { _needEntities :: Maybe (Set Sync22.Entity), - _doneEntities :: Either Int (Set Sync22.Entity), - _warnEntities :: Either Int (Set Sync22.Entity) - } - -emptySyncProgressState :: SyncProgressState -emptySyncProgressState = SyncProgressState (Just mempty) (Right mempty) (Right mempty) - -syncProgress :: forall m. (MonadIO m) => IORef SyncProgressState -> Sync.Progress m Sync22.Entity -syncProgress progressStateRef = Sync.Progress (liftIO . need) (liftIO . done) (liftIO . warn) (liftIO allDone) - where - quiet = False - maxTrackedHashCount = 1024 * 1024 - size :: SyncProgressState -> Int - size = \case - SyncProgressState Nothing (Left i) (Left j) -> i + j - SyncProgressState (Just need) (Right done) (Right warn) -> Set.size need + Set.size done + Set.size warn - SyncProgressState _ _ _ -> undefined - - need, done, warn :: Sync22.Entity -> IO () - need h = do - unless quiet $ Monad.whenM (readIORef progressStateRef <&> (== 0) . size) $ putStr "\n" - readIORef progressStateRef >>= \case - SyncProgressState Nothing Left {} Left {} -> pure () - SyncProgressState (Just need) (Right done) (Right warn) -> - if Set.size need + Set.size done + Set.size warn > maxTrackedHashCount - then writeIORef progressStateRef $ SyncProgressState Nothing (Left $ Set.size done) (Left $ Set.size warn) - else - if Set.member h done || Set.member h warn - then pure () - else writeIORef progressStateRef $ SyncProgressState (Just $ Set.insert h need) (Right done) (Right warn) - SyncProgressState _ _ _ -> undefined - unless quiet printSynced - - done h = do - unless quiet $ Monad.whenM (readIORef progressStateRef <&> (== 0) . size) $ putStr "\n" - readIORef progressStateRef >>= \case - SyncProgressState Nothing (Left done) warn -> - writeIORef progressStateRef $ SyncProgressState Nothing (Left (done + 1)) warn - SyncProgressState (Just need) (Right done) warn -> - writeIORef progressStateRef $ SyncProgressState (Just $ Set.delete h need) (Right $ Set.insert h done) warn - SyncProgressState _ _ _ -> undefined - unless quiet printSynced - - warn h = do - unless quiet $ Monad.whenM (readIORef progressStateRef <&> (== 0) . size) $ putStr "\n" - readIORef progressStateRef >>= \case - SyncProgressState Nothing done (Left warn) -> - writeIORef progressStateRef $ SyncProgressState Nothing done (Left $ warn + 1) - SyncProgressState (Just need) done (Right warn) -> - writeIORef progressStateRef $ SyncProgressState (Just $ Set.delete h need) done (Right $ Set.insert h warn) - SyncProgressState _ _ _ -> undefined - unless quiet printSynced - - allDone = do - readIORef progressStateRef >>= putStrLn . renderState (" " ++ "Done syncing ") - - printSynced :: IO () - printSynced = - readIORef progressStateRef >>= \s -> - finally - do ANSI.hideCursor; putStr . renderState (" " ++ "Synced ") $ s - ANSI.showCursor - - renderState :: String -> SyncProgressState -> String - renderState prefix = \case - SyncProgressState Nothing (Left done) (Left warn) -> - "\r" ++ prefix ++ show done ++ " entities" ++ if warn > 0 then " with " ++ show warn ++ " warnings." else "." - SyncProgressState (Just _need) (Right done) (Right warn) -> - "\r" - ++ prefix - ++ show (Set.size done + Set.size warn) - ++ " entities" - ++ if Set.size warn > 0 - then " with " ++ show (Set.size warn) ++ " warnings." - else "." - SyncProgressState need done warn -> - "invalid SyncProgressState " - ++ show (fmap v need, bimap id v done, bimap id v warn) - where - v = const () - -- | Given two codebase roots (e.g. "./mycodebase"), safely copy the codebase -- at the source to the destination. -- Note: this does not copy the .unisonConfig file. diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/SyncEphemeral.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/SyncEphemeral.hs index 1dcbb24b27..b9247fdf70 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/SyncEphemeral.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/SyncEphemeral.hs @@ -2,7 +2,6 @@ module Unison.Codebase.SqliteCodebase.SyncEphemeral where import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.DbId (SchemaVersion) -import U.Codebase.Sqlite.Sync22 qualified as Sync22 import Unison.Hash (Hash) import Unison.Prelude @@ -12,8 +11,7 @@ data Dependencies = Dependencies } data Error - = Sync22Error Sync22.Error - | SrcWrongSchema SchemaVersion + = SrcWrongSchema SchemaVersion | DestWrongSchema SchemaVersion | DisappearingBranch CausalHash deriving stock (Show) diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 0b803dd73a..ca97d29905 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -68,10 +68,6 @@ data Codebase m v a = Codebase -- -- The terms and type declarations that a branch references must already exist in the codebase. putBranch :: Branch m -> m (), - -- | Copy a branch and all of its dependencies from the given codebase into this one. - syncFromDirectory :: CodebasePath -> Branch m -> m (), - -- | Copy a branch and all of its dependencies from this codebase into the given codebase. - syncToDirectory :: CodebasePath -> Branch m -> m (), -- | @getWatch k r@ returns watch result @t@ that was previously put by @putWatch k r t@. getWatch :: WK.WatchKind -> Reference.Id -> Sqlite.Transaction (Maybe (Term v a)), -- | Get the set of user-defined terms-or-constructors that have the given type. From 18a0e8b0f50fdc46d0ec83c23537a4bb40289645 Mon Sep 17 00:00:00 2001 From: ChrisPenner Date: Fri, 30 Aug 2024 18:15:16 +0000 Subject: [PATCH 2/2] automatically run ormolu --- parser-typechecker/src/Unison/Codebase/Type.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 0359873acf..e7ee5ef640 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -15,7 +15,7 @@ import Unison.ConstructorType qualified as CT import Unison.DataDeclaration (Decl) import Unison.Hash (Hash) import Unison.Prelude -import Unison.Reference (Reference, TypeReference, TermReferenceId, TypeReferenceId) +import Unison.Reference (Reference, TermReferenceId, TypeReference, TypeReferenceId) import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.ShortHash (ShortHash)