Merge pull request #3195 from unisonweb/22-07-05-local-ui-different-connections

Make Codebase object thread-safe

parser-typechecker/src/Unison/Codebase.hs

@@ -90,8 +90,10 @@ module Unison.Codebase
     CodebasePath,
     SyncToDir,
 
-    -- * Sqlite escape hatch
-    connection,
+    -- * Direct codebase access
+    runTransaction,
+    withConnection,
+    withConnectionIO,
 
     -- * Misc (organize these better)
     addDefsToCodebase,
@@ -154,6 +156,12 @@ import qualified Unison.UnisonFile as UF
 import qualified Unison.Util.Relation as Rel
 import Unison.Var (Var)
 import qualified Unison.WatchKind as WK
+import qualified Unison.Sqlite as Sqlite
+
+-- | Run a transaction on a codebase.
+runTransaction :: MonadIO m => Codebase m v a -> Sqlite.Transaction b -> m b
+runTransaction Codebase{withConnection} action =
+  withConnection \conn -> Sqlite.runTransaction conn action
 
 -- | Get the shallow representation of the root branches without loading the children or
 -- history.

parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs

@@ -56,6 +56,7 @@ import qualified Unison.Codebase.Init as Codebase
 import qualified Unison.Codebase.Init.CreateCodebaseError as Codebase1
 import qualified Unison.Codebase.Init.OpenCodebaseError as Codebase1
 import Unison.Codebase.Patch (Patch)
+import Unison.Codebase.Path (Path)
 import qualified Unison.Codebase.Reflog as Reflog
 import Unison.Codebase.ShortBranchHash (ShortBranchHash)
 import qualified Unison.Codebase.SqliteCodebase.Branch.Dependencies as BD
@@ -70,6 +71,7 @@ import Unison.Codebase.Type (LocalOrRemote (..), PushGitBranchOpts (..))
 import qualified Unison.Codebase.Type as C
 import Unison.DataDeclaration (Decl)
 import Unison.Hash (Hash)
+import Unison.Names.Scoped (ScopedNames)
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
 import Unison.Reference (Reference)
@@ -94,12 +96,9 @@ init :: HasCallStack => (MonadUnliftIO m) => Codebase.Init m Symbol Ann
 init =
   Codebase.Init
     { withOpenCodebase = withCodebaseOrError,
-      withCreatedCodebase = withCreatedCodebase',
+      withCreatedCodebase = createCodebaseOrError,
       codebasePath = makeCodebaseDirPath
     }
-  where
-    withCreatedCodebase' debugName path action =
-      createCodebaseOrError debugName path (action . fst)
 
 data CodebaseStatus
   = ExistingCodebase
@@ -112,7 +111,7 @@ withOpenOrCreateCodebase ::
   Codebase.DebugName ->
   CodebasePath ->
   LocalOrRemote ->
-  ((CodebaseStatus, Codebase m Symbol Ann, Sqlite.Connection) -> m r) ->
+  ((CodebaseStatus, Codebase m Symbol Ann) -> m r) ->
   m (Either Codebase1.OpenCodebaseError r)
 withOpenOrCreateCodebase debugName codebasePath localOrRemote action = do
   createCodebaseOrError debugName codebasePath (action' CreatedCodebase) >>= \case
@@ -120,14 +119,14 @@ withOpenOrCreateCodebase debugName codebasePath localOrRemote action = do
       sqliteCodebase debugName codebasePath localOrRemote (action' ExistingCodebase)
     Right r -> pure (Right r)
   where
-    action' openOrCreate (codebase, conn) = action (openOrCreate, codebase, conn)
+    action' openOrCreate codebase = action (openOrCreate, codebase)
 
 -- | Create a codebase at the given location.
 createCodebaseOrError ::
   (MonadUnliftIO m) =>
   Codebase.DebugName ->
   CodebasePath ->
-  ((Codebase m Symbol Ann, Sqlite.Connection) -> m r) ->
+  (Codebase m Symbol Ann -> m r) ->
   m (Either Codebase1.CreateCodebaseError r)
 createCodebaseOrError debugName path action = do
   ifM
@@ -157,8 +156,7 @@ withCodebaseOrError ::
 withCodebaseOrError debugName dir action = do
   doesFileExist (makeCodebasePath dir) >>= \case
     False -> pure (Left Codebase1.OpenCodebaseDoesntExist)
-    True ->
-      sqliteCodebase debugName dir Local (action . fst)
+    True -> sqliteCodebase debugName dir Local action
 
 initSchemaIfNotExist :: MonadIO m => FilePath -> m ()
 initSchemaIfNotExist path = liftIO do
@@ -192,324 +190,351 @@ sqliteCodebase ::
   CodebasePath ->
   -- | When local, back up the existing codebase before migrating, in case there's a catastrophic bug in the migration.
   LocalOrRemote ->
-  ((Codebase m Symbol Ann, Sqlite.Connection) -> m r) ->
+  (Codebase m Symbol Ann -> m r) ->
   m (Either Codebase1.OpenCodebaseError r)
 sqliteCodebase debugName root localOrRemote action = do
-  Monad.when debug $ traceM $ "sqliteCodebase " ++ debugName ++ " " ++ root
-  withConnection debugName root \conn -> do
-    termCache <- Cache.semispaceCache 8192 -- pure Cache.nullCache -- to disable
-    typeOfTermCache <- Cache.semispaceCache 8192
-    declCache <- Cache.semispaceCache 1024
-    rootBranchCache <- newTVarIO Nothing
-    getDeclType <- CodebaseOps.mkGetDeclType
-    -- The v1 codebase interface has operations to read and write individual definitions
-    -- whereas the v2 codebase writes them as complete components.  These two fields buffer
-    -- the individual definitions until a complete component has been written.
-    termBuffer :: TVar (Map Hash CodebaseOps.TermBufferEntry) <- newTVarIO Map.empty
-    declBuffer :: TVar (Map Hash CodebaseOps.DeclBufferEntry) <- newTVarIO Map.empty
-    let getTerm :: Reference.Id -> m (Maybe (Term Symbol Ann))
-        getTerm id =
-          Sqlite.runTransaction conn (CodebaseOps.getTerm getDeclType id)
+  termCache <- Cache.semispaceCache 8192 -- pure Cache.nullCache -- to disable
+  typeOfTermCache <- Cache.semispaceCache 8192
+  declCache <- Cache.semispaceCache 1024
+  rootBranchCache <- newTVarIO Nothing
+  getDeclType <- CodebaseOps.mkGetDeclType
+  -- The v1 codebase interface has operations to read and write individual definitions
+  -- whereas the v2 codebase writes them as complete components.  These two fields buffer
+  -- the individual definitions until a complete component has been written.
+  termBuffer :: TVar (Map Hash CodebaseOps.TermBufferEntry) <- newTVarIO Map.empty
+  declBuffer :: TVar (Map Hash CodebaseOps.DeclBufferEntry) <- newTVarIO Map.empty
 
-        getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type Symbol Ann))
-        getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined
-        getTypeOfTermImpl id =
-          Sqlite.runTransaction conn (CodebaseOps.getTypeOfTermImpl id)
+  -- Migrate if necessary.
+  result <-
+    withConn \conn ->
+      ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer conn
 
-        getTermComponentWithTypes :: Hash -> m (Maybe [(Term Symbol Ann, Type Symbol Ann)])
-        getTermComponentWithTypes h =
-          Sqlite.runTransaction conn (CodebaseOps.getTermComponentWithTypes getDeclType h)
+  case result of
+    Left err -> pure $ Left err
+    Right () -> do
+      let finalizer :: MonadIO m => m ()
+          finalizer = do
+            decls <- readTVarIO declBuffer
+            terms <- readTVarIO termBuffer
+            let printBuffer header b =
+                  liftIO
+                    if b /= mempty
+                      then putStrLn header >> putStrLn "" >> print b
+                      else pure ()
+            printBuffer "Decls:" decls
+            printBuffer "Terms:" terms
 
-        getTypeDeclaration :: Reference.Id -> m (Maybe (Decl Symbol Ann))
-        getTypeDeclaration id =
-          Sqlite.runTransaction conn (CodebaseOps.getTypeDeclaration id)
+      flip finally finalizer do
+        let getTerm :: Reference.Id -> m (Maybe (Term Symbol Ann))
+            getTerm id =
+              runTransaction (CodebaseOps.getTerm getDeclType id)
 
-        getDeclComponent :: Hash -> m (Maybe [Decl Symbol Ann])
-        getDeclComponent h =
-          Sqlite.runTransaction conn (CodebaseOps.getDeclComponent h)
+            getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type Symbol Ann))
+            getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined
+            getTypeOfTermImpl id =
+              runTransaction (CodebaseOps.getTypeOfTermImpl id)
 
-        getCycleLength :: Hash -> m (Maybe Reference.CycleSize)
-        getCycleLength h =
-          Sqlite.runTransaction conn (CodebaseOps.getCycleLength h)
+            getTermComponentWithTypes :: Hash -> m (Maybe [(Term Symbol Ann, Type Symbol Ann)])
+            getTermComponentWithTypes h =
+              runTransaction (CodebaseOps.getTermComponentWithTypes getDeclType h)
 
-        -- putTermComponent :: MonadIO m => Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> m ()
-        -- putTerms :: MonadIO m => Map Reference.Id (Term Symbol Ann, Type Symbol Ann) -> m () -- dies horribly if missing dependencies?
+            getTypeDeclaration :: Reference.Id -> m (Maybe (Decl Symbol Ann))
+            getTypeDeclaration id =
+              runTransaction (CodebaseOps.getTypeDeclaration id)
 
-        -- option 1: tweak putTerm to incrementally notice the cycle length until each component is full
-        -- option 2: switch codebase interface from putTerm to putTerms -- buffering can be local to the function
-        -- option 3: switch from putTerm to putTermComponent -- needs to buffer dependencies non-locally (or require application to manage + die horribly)
+            getDeclComponent :: Hash -> m (Maybe [Decl Symbol Ann])
+            getDeclComponent h =
+              runTransaction (CodebaseOps.getDeclComponent h)
 
-        putTerm :: Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> m ()
-        putTerm id tm tp | debug && trace ("SqliteCodebase.putTerm " ++ show id ++ " " ++ show tm ++ " " ++ show tp) False = undefined
-        putTerm id tm tp =
-          Sqlite.runTransaction conn (CodebaseOps.putTerm termBuffer declBuffer id tm tp)
+            getCycleLength :: Hash -> m (Maybe Reference.CycleSize)
+            getCycleLength h =
+              runTransaction (CodebaseOps.getCycleLength h)
 
-        putTypeDeclaration :: Reference.Id -> Decl Symbol Ann -> m ()
-        putTypeDeclaration id decl =
-          Sqlite.runTransaction conn (CodebaseOps.putTypeDeclaration termBuffer declBuffer id decl)
+            -- putTermComponent :: MonadIO m => Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> m ()
+            -- putTerms :: MonadIO m => Map Reference.Id (Term Symbol Ann, Type Symbol Ann) -> m () -- dies horribly if missing dependencies?
 
-        getRootBranchHash :: MonadIO m => m V2Branch.CausalHash
-        getRootBranchHash = do
-          Sqlite.runReadOnlyTransaction conn \run ->
-            run Ops.expectRootCausalHash
+            -- option 1: tweak putTerm to incrementally notice the cycle length until each component is full
+            -- option 2: switch codebase interface from putTerm to putTerms -- buffering can be local to the function
+            -- option 3: switch from putTerm to putTermComponent -- needs to buffer dependencies non-locally (or require application to manage + die horribly)
 
-        getShallowBranchForHash :: MonadIO m => V2Branch.CausalHash -> m (V2Branch.CausalBranch m)
-        getShallowBranchForHash bh =
-          Sqlite.runReadOnlyTransaction conn \run -> do
-            V2Branch.hoistCausalBranch run <$> run (Ops.expectCausalBranchByCausalHash bh)
+            putTerm :: Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> m ()
+            putTerm id tm tp | debug && trace ("SqliteCodebase.putTerm " ++ show id ++ " " ++ show tm ++ " " ++ show tp) False = undefined
+            putTerm id tm tp =
+              runTransaction (CodebaseOps.putTerm termBuffer declBuffer id tm tp)
 
-        getRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> m (Branch m)
-        getRootBranch rootBranchCache =
-          Sqlite.runReadOnlyTransaction conn \run ->
-            Branch.transform run <$> run (CodebaseOps.getRootBranch getDeclType rootBranchCache)
+            putTypeDeclaration :: Reference.Id -> Decl Symbol Ann -> m ()
+            putTypeDeclaration id decl =
+              runTransaction (CodebaseOps.putTypeDeclaration termBuffer declBuffer id decl)
 
-        getRootBranchExists :: m Bool
-        getRootBranchExists =
-          Sqlite.runTransaction conn CodebaseOps.getRootBranchExists
+            getRootBranchHash :: MonadIO m => m V2Branch.CausalHash
+            getRootBranchHash =
+              runTransaction Ops.expectRootCausalHash
 
-        putRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> Branch m -> m ()
-        putRootBranch rootBranchCache branch1 = do
-          withRunInIO \runInIO -> do
-            Sqlite.runTransaction conn do
-              CodebaseOps.putRootBranch rootBranchCache (Branch.transform (Sqlite.unsafeIO . runInIO) branch1)
+            getShallowBranchForHash :: MonadIO m => V2Branch.CausalHash -> m (V2Branch.CausalBranch m)
+            getShallowBranchForHash bh =
+              V2Branch.hoistCausalBranch runTransaction <$> runTransaction (Ops.expectCausalBranchByCausalHash bh)
 
-        rootBranchUpdates :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, a)) -> m (IO (), IO (Set Branch.CausalHash))
-        rootBranchUpdates _rootBranchCache = do
-          -- branchHeadChanges      <- TQueue.newIO
-          -- (cancelWatch, watcher) <- Watch.watchDirectory' (v2dir root)
-          -- watcher1               <-
-          --   liftIO . forkIO
-          --   $ forever
-          --   $ do
-          --       -- void ignores the name and time of the changed file,
-          --       -- and assume 'unison.sqlite3' has changed
-          --       (filename, time) <- watcher
-          --       traceM $ "SqliteCodebase.watcher " ++ show (filename, time)
-          --       readTVarIO rootBranchCache >>= \case
-          --         Nothing -> pure ()
-          --         Just (v, _) -> do
-          --           -- this use of `conn` in a separate thread may be problematic.
-          --           -- hopefully sqlite will produce an obvious error message if it is.
-          --           v' <- runDB conn Ops.dataVersion
-          --           if v /= v' then
-          --             atomically
-          --               . TQueue.enqueue branchHeadChanges =<< runDB conn Ops.loadRootCausalHash
-          --           else pure ()
+            getRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> m (Branch m)
+            getRootBranch rootBranchCache =
+              Branch.transform runTransaction <$> runTransaction (CodebaseOps.getRootBranch getDeclType rootBranchCache)
 
-          --       -- case hashFromFilePath filePath of
-          --       --   Nothing -> failWith $ CantParseBranchHead filePath
-          --       --   Just h ->
-          --       --     atomically . TQueue.enqueue branchHeadChanges $ Branch.CausalHash h
-          -- -- smooth out intermediate queue
-          -- pure
-          --   ( cancelWatch >> killThread watcher1
-          --   , Set.fromList <$> Watch.collectUntilPause branchHeadChanges 400000
-          --   )
-          pure (cleanup, liftIO newRootsDiscovered)
-          where
-            newRootsDiscovered = do
-              Control.Concurrent.threadDelay maxBound -- hold off on returning
-              pure mempty -- returning nothing
-            cleanup = pure ()
+            getRootBranchExists :: m Bool
+            getRootBranchExists =
+              runTransaction CodebaseOps.getRootBranchExists
 
-        -- if this blows up on cromulent hashes, then switch from `hashToHashId`
-        -- to one that returns Maybe.
-        getBranchForHash :: Branch.CausalHash -> m (Maybe (Branch m))
-        getBranchForHash h =
-          Sqlite.runReadOnlyTransaction conn \run ->
-            fmap (Branch.transform run) <$> run (CodebaseOps.getBranchForHash getDeclType h)
+            putRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> Branch m -> m ()
+            putRootBranch rootBranchCache branch1 = do
+              withRunInIO \runInIO -> do
+                runInIO do
+                  runTransaction do
+                    CodebaseOps.putRootBranch rootBranchCache (Branch.transform (Sqlite.unsafeIO . runInIO) branch1)
 
-        putBranch :: Branch m -> m ()
-        putBranch branch =
-          withRunInIO \runInIO ->
-            Sqlite.runTransaction conn (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch))
+            rootBranchUpdates :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, a)) -> m (IO (), IO (Set Branch.CausalHash))
+            rootBranchUpdates _rootBranchCache = do
+              -- branchHeadChanges      <- TQueue.newIO
+              -- (cancelWatch, watcher) <- Watch.watchDirectory' (v2dir root)
+              -- watcher1               <-
+              --   liftIO . forkIO
+              --   $ forever
+              --   $ do
+              --       -- void ignores the name and time of the changed file,
+              --       -- and assume 'unison.sqlite3' has changed
+              --       (filename, time) <- watcher
+              --       traceM $ "SqliteCodebase.watcher " ++ show (filename, time)
+              --       readTVarIO rootBranchCache >>= \case
+              --         Nothing -> pure ()
+              --         Just (v, _) -> do
+              --           -- this use of `conn` in a separate thread may be problematic.
+              --           -- hopefully sqlite will produce an obvious error message if it is.
+              --           v' <- runDB conn Ops.dataVersion
+              --           if v /= v' then
+              --             atomically
+              --               . TQueue.enqueue branchHeadChanges =<< runDB conn Ops.loadRootCausalHash
+              --           else pure ()
 
-        isCausalHash :: Branch.CausalHash -> m Bool
-        isCausalHash h =
-          Sqlite.runTransaction conn (CodebaseOps.isCausalHash h)
+              --       -- case hashFromFilePath filePath of
+              --       --   Nothing -> failWith $ CantParseBranchHead filePath
+              --       --   Just h ->
+              --       --     atomically . TQueue.enqueue branchHeadChanges $ Branch.CausalHash h
+              -- -- smooth out intermediate queue
+              -- pure
+              --   ( cancelWatch >> killThread watcher1
+              --   , Set.fromList <$> Watch.collectUntilPause branchHeadChanges 400000
+              --   )
+              pure (cleanup, liftIO newRootsDiscovered)
+              where
+                newRootsDiscovered = do
+                  Control.Concurrent.threadDelay maxBound -- hold off on returning
+                  pure mempty -- returning nothing
+                cleanup = pure ()
 
-        getPatch :: Branch.EditHash -> m (Maybe Patch)
-        getPatch h =
-          Sqlite.runTransaction conn (CodebaseOps.getPatch h)
+            -- if this blows up on cromulent hashes, then switch from `hashToHashId`
+            -- to one that returns Maybe.
+            getBranchForHash :: Branch.CausalHash -> m (Maybe (Branch m))
+            getBranchForHash h =
+              fmap (Branch.transform runTransaction) <$> runTransaction (CodebaseOps.getBranchForHash getDeclType h)
 
-        putPatch :: Branch.EditHash -> Patch -> m ()
-        putPatch h p =
-          Sqlite.runTransaction conn (CodebaseOps.putPatch h p)
+            putBranch :: Branch m -> m ()
+            putBranch branch =
+              withRunInIO \runInIO ->
+                runInIO (runTransaction (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch)))
 
-        patchExists :: Branch.EditHash -> m Bool
-        patchExists h =
-          Sqlite.runTransaction conn (CodebaseOps.patchExists h)
+            isCausalHash :: Branch.CausalHash -> m Bool
+            isCausalHash h =
+              runTransaction (CodebaseOps.isCausalHash h)
 
-        dependentsImpl :: Reference -> m (Set Reference.Id)
-        dependentsImpl r =
-          Sqlite.runTransaction conn (CodebaseOps.dependentsImpl r)
+            getPatch :: Branch.EditHash -> m (Maybe Patch)
+            getPatch h =
+              runTransaction (CodebaseOps.getPatch h)
 
-        dependentsOfComponentImpl :: Hash -> m (Set Reference.Id)
-        dependentsOfComponentImpl h =
-          Sqlite.runTransaction conn (CodebaseOps.dependentsOfComponentImpl h)
+            putPatch :: Branch.EditHash -> Patch -> m ()
+            putPatch h p =
+              runTransaction (CodebaseOps.putPatch h p)
 
-        syncFromDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m ()
-        syncFromDirectory srcRoot _syncMode b = do
-          withConnection (debugName ++ ".sync.src") srcRoot $ \srcConn -> do
-            progressStateRef <- liftIO (newIORef emptySyncProgressState)
-            Sqlite.runReadOnlyTransaction srcConn \runSrc ->
-              Sqlite.runWriteTransaction conn \runDest -> do
-                syncInternal (syncProgress progressStateRef) runSrc runDest b
+            patchExists :: Branch.EditHash -> m Bool
+            patchExists h =
+              runTransaction (CodebaseOps.patchExists h)
 
-        syncToDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m ()
-        syncToDirectory destRoot _syncMode b =
-          withConnection (debugName ++ ".sync.dest") destRoot $ \destConn -> do
-            progressStateRef <- liftIO (newIORef emptySyncProgressState)
-            initSchemaIfNotExist destRoot
-            Sqlite.runReadOnlyTransaction conn \runSrc ->
-              Sqlite.runWriteTransaction destConn \runDest -> do
-                syncInternal (syncProgress progressStateRef) runSrc runDest b
+            dependentsImpl :: Reference -> m (Set Reference.Id)
+            dependentsImpl r =
+              runTransaction (CodebaseOps.dependentsImpl r)
 
-        watches :: UF.WatchKind -> m [Reference.Id]
-        watches w =
-          Sqlite.runTransaction conn (CodebaseOps.watches w)
+            dependentsOfComponentImpl :: Hash -> m (Set Reference.Id)
+            dependentsOfComponentImpl h =
+              runTransaction (CodebaseOps.dependentsOfComponentImpl h)
 
-        getWatch :: UF.WatchKind -> Reference.Id -> m (Maybe (Term Symbol Ann))
-        getWatch k r =
-          Sqlite.runTransaction conn (CodebaseOps.getWatch getDeclType k r)
+            syncFromDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m ()
+            syncFromDirectory srcRoot _syncMode 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
 
-        putWatch :: UF.WatchKind -> Reference.Id -> Term Symbol Ann -> m ()
-        putWatch k r tm =
-          Sqlite.runTransaction conn (CodebaseOps.putWatch k r tm)
+            syncToDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m ()
+            syncToDirectory destRoot _syncMode 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
 
-        clearWatches :: m ()
-        clearWatches =
-          Sqlite.runTransaction conn CodebaseOps.clearWatches
+            watches :: UF.WatchKind -> m [Reference.Id]
+            watches w =
+              runTransaction (CodebaseOps.watches w)
 
-        getReflog :: m [Reflog.Entry Branch.CausalHash]
-        getReflog =
-          liftIO $
-            ( do
-                contents <- TextIO.readFile (reflogPath root)
-                let lines = Text.lines contents
-                let entries = parseEntry <$> lines
-                pure entries
-            )
-              `catchIO` const (pure [])
-          where
-            parseEntry t = fromMaybe (err t) (Reflog.fromText t)
-            err t =
-              error $
-                "I couldn't understand this line in " ++ reflogPath root ++ "\n\n"
-                  ++ Text.unpack t
+            getWatch :: UF.WatchKind -> Reference.Id -> m (Maybe (Term Symbol Ann))
+            getWatch k r =
+              runTransaction (CodebaseOps.getWatch getDeclType k r)
 
-        appendReflog :: Text -> Branch m -> Branch m -> m ()
-        appendReflog reason old new =
-          liftIO $ TextIO.appendFile (reflogPath root) (t <> "\n")
-          where
-            t = Reflog.toText $ Reflog.Entry (Branch.headHash old) (Branch.headHash new) reason
+            putWatch :: UF.WatchKind -> Reference.Id -> Term Symbol Ann -> m ()
+            putWatch k r tm =
+              runTransaction (CodebaseOps.putWatch k r tm)
 
-        reflogPath :: CodebasePath -> FilePath
-        reflogPath root = root </> "reflog"
+            clearWatches :: m ()
+            clearWatches =
+              runTransaction CodebaseOps.clearWatches
 
-        termsOfTypeImpl :: Reference -> m (Set Referent.Id)
-        termsOfTypeImpl r =
-          Sqlite.runTransaction conn (CodebaseOps.termsOfTypeImpl getDeclType r)
+            getReflog :: m [Reflog.Entry Branch.CausalHash]
+            getReflog =
+              liftIO $
+                ( do
+                    contents <- TextIO.readFile (reflogPath root)
+                    let lines = Text.lines contents
+                    let entries = parseEntry <$> lines
+                    pure entries
+                )
+                  `catchIO` const (pure [])
+              where
+                parseEntry t = fromMaybe (err t) (Reflog.fromText t)
+                err t =
+                  error $
+                    "I couldn't understand this line in " ++ reflogPath root ++ "\n\n"
+                      ++ Text.unpack t
 
-        termsMentioningTypeImpl :: Reference -> m (Set Referent.Id)
-        termsMentioningTypeImpl r =
-          Sqlite.runTransaction conn (CodebaseOps.termsMentioningTypeImpl getDeclType r)
+            appendReflog :: Text -> Branch m -> Branch m -> m ()
+            appendReflog reason old new =
+              liftIO $ TextIO.appendFile (reflogPath root) (t <> "\n")
+              where
+                t = Reflog.toText $ Reflog.Entry (Branch.headHash old) (Branch.headHash new) reason
 
-        hashLength :: m Int
-        hashLength =
-          Sqlite.runTransaction conn CodebaseOps.hashLength
+            reflogPath :: CodebasePath -> FilePath
+            reflogPath root = root </> "reflog"
 
-        branchHashLength :: m Int
-        branchHashLength =
-          Sqlite.runTransaction conn CodebaseOps.branchHashLength
+            termsOfTypeImpl :: Reference -> m (Set Referent.Id)
+            termsOfTypeImpl r =
+              runTransaction (CodebaseOps.termsOfTypeImpl getDeclType r)
 
-        termReferencesByPrefix :: ShortHash -> m (Set Reference.Id)
-        termReferencesByPrefix sh =
-          Sqlite.runTransaction conn (CodebaseOps.termReferencesByPrefix sh)
+            termsMentioningTypeImpl :: Reference -> m (Set Referent.Id)
+            termsMentioningTypeImpl r =
+              runTransaction (CodebaseOps.termsMentioningTypeImpl getDeclType r)
 
-        declReferencesByPrefix :: ShortHash -> m (Set Reference.Id)
-        declReferencesByPrefix sh =
-          Sqlite.runTransaction conn (CodebaseOps.declReferencesByPrefix sh)
+            hashLength :: m Int
+            hashLength =
+              runTransaction CodebaseOps.hashLength
 
-        referentsByPrefix :: ShortHash -> m (Set Referent.Id)
-        referentsByPrefix sh =
-          Sqlite.runTransaction conn (CodebaseOps.referentsByPrefix getDeclType sh)
+            branchHashLength :: m Int
+            branchHashLength =
+              runTransaction CodebaseOps.branchHashLength
 
-        branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.CausalHash)
-        branchHashesByPrefix sh =
-          Sqlite.runTransaction conn (CodebaseOps.branchHashesByPrefix sh)
+            termReferencesByPrefix :: ShortHash -> m (Set Reference.Id)
+            termReferencesByPrefix sh =
+              runTransaction (CodebaseOps.termReferencesByPrefix sh)
 
-        sqlLca :: Branch.CausalHash -> Branch.CausalHash -> m (Maybe (Branch.CausalHash))
-        sqlLca h1 h2 =
-          Sqlite.runTransaction conn (CodebaseOps.sqlLca h1 h2)
-    let codebase =
-          C.Codebase
-            { getTerm = (Cache.applyDefined termCache getTerm),
-              getTypeOfTermImpl = (Cache.applyDefined typeOfTermCache getTypeOfTermImpl),
-              getTypeDeclaration = (Cache.applyDefined declCache getTypeDeclaration),
-              getDeclType = \r -> Sqlite.runReadOnlyTransaction conn \run -> run (getDeclType r),
-              putTerm = putTerm,
-              putTypeDeclaration = putTypeDeclaration,
-              getTermComponentWithTypes = getTermComponentWithTypes,
-              getDeclComponent = getDeclComponent,
-              getComponentLength = getCycleLength,
-              getRootBranch = (getRootBranch rootBranchCache),
-              getRootBranchHash = getRootBranchHash,
-              getRootBranchExists = getRootBranchExists,
-              putRootBranch = (putRootBranch rootBranchCache),
-              rootBranchUpdates = (rootBranchUpdates rootBranchCache),
-              getShallowBranchForHash = getShallowBranchForHash,
-              getBranchForHashImpl = getBranchForHash,
-              putBranch = putBranch,
-              branchExists = isCausalHash,
-              getPatch = getPatch,
-              putPatch = putPatch,
-              patchExists = patchExists,
-              dependentsImpl = dependentsImpl,
-              dependentsOfComponentImpl = dependentsOfComponentImpl,
-              syncFromDirectory = syncFromDirectory,
-              syncToDirectory = syncToDirectory,
-              viewRemoteBranch' = viewRemoteBranch',
-              pushGitBranch = pushGitBranch conn,
-              watches = watches,
-              getWatch = getWatch,
-              putWatch = putWatch,
-              clearWatches = clearWatches,
-              getReflog = getReflog,
-              appendReflog = appendReflog,
-              termsOfTypeImpl = termsOfTypeImpl,
-              termsMentioningTypeImpl = termsMentioningTypeImpl,
-              hashLength = hashLength,
-              termReferencesByPrefix = termReferencesByPrefix,
-              typeReferencesByPrefix = declReferencesByPrefix,
-              termReferentsByPrefix = referentsByPrefix,
-              branchHashLength = branchHashLength,
-              branchHashesByPrefix = branchHashesByPrefix,
-              lcaImpl = (Just sqlLca),
-              beforeImpl = (Just \l r -> Sqlite.runTransaction conn $ fromJust <$> CodebaseOps.before l r),
-              namesAtPath = \path -> Sqlite.runReadOnlyTransaction conn \runTx ->
-                runTx (CodebaseOps.namesAtPath path),
-              updateNameLookup = Sqlite.runTransaction conn (CodebaseOps.updateNameLookupIndexFromV2Root getDeclType),
-              connection = conn,
-              withConnection = withConnection debugName root
-            }
-    let finalizer :: MonadIO m => m ()
-        finalizer = do
-          decls <- readTVarIO declBuffer
-          terms <- readTVarIO termBuffer
-          let printBuffer header b =
-                liftIO
-                  if b /= mempty
-                    then putStrLn header >> putStrLn "" >> print b
-                    else pure ()
-          printBuffer "Decls:" decls
-          printBuffer "Terms:" terms
+            declReferencesByPrefix :: ShortHash -> m (Set Reference.Id)
+            declReferencesByPrefix sh =
+              runTransaction (CodebaseOps.declReferencesByPrefix sh)
 
-    flip finally finalizer $ do
-      -- Migrate if necessary.
-      ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer conn >>= \case
-        Left err -> pure $ Left err
-        Right () -> Right <$> action (codebase, conn)
+            referentsByPrefix :: ShortHash -> m (Set Referent.Id)
+            referentsByPrefix sh =
+              runTransaction (CodebaseOps.referentsByPrefix getDeclType sh)
+
+            branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.CausalHash)
+            branchHashesByPrefix sh =
+              runTransaction (CodebaseOps.branchHashesByPrefix sh)
+
+            sqlLca :: Branch.CausalHash -> Branch.CausalHash -> m (Maybe (Branch.CausalHash))
+            sqlLca h1 h2 =
+              runTransaction (CodebaseOps.sqlLca h1 h2)
+
+            beforeImpl :: Maybe (Branch.CausalHash -> Branch.CausalHash -> m Bool)
+            beforeImpl =
+              Just \l r ->
+                runTransaction $ fromJust <$> CodebaseOps.before l r
+
+            namesAtPath :: Path -> m ScopedNames
+            namesAtPath path =
+              runTransaction (CodebaseOps.namesAtPath path)
+
+            updateNameLookup :: m ()
+            updateNameLookup =
+              runTransaction (CodebaseOps.updateNameLookupIndexFromV2Root getDeclType)
+
+        let codebase =
+              C.Codebase
+                { getTerm = Cache.applyDefined termCache getTerm,
+                  getTypeOfTermImpl = Cache.applyDefined typeOfTermCache getTypeOfTermImpl,
+                  getTypeDeclaration = Cache.applyDefined declCache getTypeDeclaration,
+                  getDeclType =
+                    \r ->
+                      withConn \conn ->
+                        Sqlite.runReadOnlyTransaction conn \run -> run (getDeclType r),
+                  putTerm,
+                  putTypeDeclaration,
+                  getTermComponentWithTypes,
+                  getDeclComponent,
+                  getComponentLength = getCycleLength,
+                  getRootBranch = getRootBranch rootBranchCache,
+                  getRootBranchHash,
+                  getRootBranchExists,
+                  putRootBranch = putRootBranch rootBranchCache,
+                  rootBranchUpdates = rootBranchUpdates rootBranchCache,
+                  getShallowBranchForHash,
+                  getBranchForHashImpl = getBranchForHash,
+                  putBranch,
+                  branchExists = isCausalHash,
+                  getPatch,
+                  putPatch,
+                  patchExists,
+                  dependentsImpl,
+                  dependentsOfComponentImpl,
+                  syncFromDirectory,
+                  syncToDirectory,
+                  viewRemoteBranch',
+                  pushGitBranch = \repo opts action -> withConn \conn -> pushGitBranch conn repo opts action,
+                  watches,
+                  getWatch,
+                  putWatch,
+                  clearWatches,
+                  getReflog,
+                  appendReflog,
+                  termsOfTypeImpl,
+                  termsMentioningTypeImpl,
+                  hashLength,
+                  termReferencesByPrefix,
+                  typeReferencesByPrefix = declReferencesByPrefix,
+                  termReferentsByPrefix = referentsByPrefix,
+                  branchHashLength,
+                  branchHashesByPrefix,
+                  lcaImpl = Just sqlLca,
+                  beforeImpl,
+                  namesAtPath,
+                  updateNameLookup,
+                  withConnection = withConn,
+                  withConnectionIO = withConnection debugName root
+                }
+        Right <$> action codebase
+  where
+    withConn :: (Sqlite.Connection -> m a) -> m a
+    withConn =
+      withConnection debugName root
+
+    runTransaction :: Sqlite.Transaction a -> m a
+    runTransaction action =
+      withConn \conn -> Sqlite.runTransaction conn action
 
 syncInternal ::
   forall m.
@@ -703,7 +728,7 @@ viewRemoteBranch' ReadGitRemoteNamespace {repo, sbh, path} gitBranchBehavior act
           then throwIO (C.GitSqliteCodebaseError (GitError.NoDatabaseFile repo remotePath))
           else throwIO exception
 
-      result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath Remote \(codebase, _conn) -> do
+      result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath Remote \codebase -> do
         -- try to load the requested branch from it
         branch <- time "Git fetch (sbh)" $ case sbh of
           -- no sub-branch was specified, so use the root.
@@ -729,7 +754,7 @@ viewRemoteBranch' ReadGitRemoteNamespace {repo, sbh, path} gitBranchBehavior act
 -- the existing root.
 pushGitBranch ::
   forall m e.
-  (MonadUnliftIO m) =>
+  MonadUnliftIO m =>
   Sqlite.Connection ->
   WriteGitRepo ->
   PushGitBranchOpts ->
@@ -754,7 +779,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift
   throwEitherMWith C.GitProtocolError . withRepo readRepo Git.CreateBranchIfMissing $ \pushStaging -> do
     newBranchOrErr <- throwEitherMWith (C.GitSqliteCodebaseError . C.gitErrorFromOpenCodebaseError (Git.gitDirToPath pushStaging) readRepo)
       . withOpenOrCreateCodebase "push.dest" (Git.gitDirToPath pushStaging) Remote
-      $ \(codebaseStatus, destCodebase, destConn) -> do
+      $ \(codebaseStatus, destCodebase) -> do
         currentRootBranch <-
           C.getRootBranchExists destCodebase >>= \case
             False -> pure Branch.empty
@@ -762,7 +787,8 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift
         action currentRootBranch >>= \case
           Left e -> pure $ Left e
           Right newBranch -> do
-            doSync codebaseStatus (Git.gitDirToPath pushStaging) destConn newBranch
+            C.withConnection destCodebase \destConn ->
+              doSync codebaseStatus (Git.gitDirToPath pushStaging) destConn newBranch
             pure (Right newBranch)
     for newBranchOrErr $ push pushStaging repo
     pure newBranchOrErr

parser-typechecker/src/Unison/Codebase/Type.hs

@@ -176,15 +176,10 @@ data Codebase m v a = Codebase
     -- Updates the root namespace names index.
     -- This isn't run automatically because it can be a bit slow.
     updateNameLookup :: m (),
-    -- | The SQLite connection this codebase closes over.
-    --
-    -- At one time the codebase was meant to abstract over the storage layer, but it has been cumbersome. Now we prefer
-    -- to interact with SQLite directly, and so provide this temporary escape hatch, until we can eliminate this
-    -- interface entirely.
-    connection :: Sqlite.Connection,
-    -- | Another escape hatch like the above connection, but this one makes a new connection to the same underlying
-    -- database file. This allows code (like pull-from-share) to use more than one connection concurrently.
-    withConnection :: forall x. (Sqlite.Connection -> IO x) -> IO x
+    -- | Acquire a new connection to the same underlying database file this codebase object connects to.
+    withConnection :: forall x. (Sqlite.Connection -> m x) -> m x,
+    -- | Acquire a new connection to the same underlying database file this codebase object connects to.
+    withConnectionIO :: forall x. (Sqlite.Connection -> IO x) -> IO x
   }
 
 -- | Whether a codebase is local or remote.

unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs

@@ -43,7 +43,6 @@ import qualified Unison.Reference as Reference
 import qualified Unison.Result as Result
 import qualified Unison.Server.Backend as Backend
 import qualified Unison.Server.CodebaseServer as Server
-import qualified Unison.Sqlite as Sqlite
 import Unison.Symbol (Symbol)
 import Unison.Term (Term)
 import qualified Unison.Term as Term
@@ -243,8 +242,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
               UnliftIO.UnliftIO toIO -> toIO . Free.fold go
         pure runF
       UCMVersion -> pure ucmVersion
-      AnalyzeCodebaseIntegrity -> do
-        Sqlite.runTransaction (Codebase.connection codebase) integrityCheckFullCodebase
+      AnalyzeCodebaseIntegrity -> lift (Codebase.runTransaction codebase integrityCheckFullCodebase)
 
     watchCache :: Reference.Id -> IO (Maybe (Term Symbol ()))
     watchCache h = do

unison-cli/src/Unison/Codebase/Editor/HandleInput.hs

@@ -99,7 +99,7 @@ import qualified Unison.Codebase.SyncMode as SyncMode
 import Unison.Codebase.TermEdit (TermEdit (..))
 import qualified Unison.Codebase.TermEdit as TermEdit
 import qualified Unison.Codebase.TermEdit.Typing as TermEdit
-import Unison.Codebase.Type (Codebase (..), GitError)
+import Unison.Codebase.Type (GitError)
 import qualified Unison.Codebase.TypeEdit as TypeEdit
 import qualified Unison.Codebase.Verbosity as Verbosity
 import qualified Unison.CommandLine.DisplayValues as DisplayValues
@@ -149,7 +149,6 @@ import qualified Unison.Share.Sync as Share
 import qualified Unison.Share.Sync.Types as Sync
 import Unison.Share.Types (codeserverBaseURL)
 import qualified Unison.ShortHash as SH
-import qualified Unison.Sqlite as Sqlite
 import Unison.Symbol (Symbol)
 import qualified Unison.Sync.Types as Share (Path (..))
 import Unison.Term (Term)
@@ -1866,45 +1865,44 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l
   let sharePath = Share.Path (repo Nel.:| pathToSegments remotePath)
   ensureAuthenticatedWithCodeserver codeserver
 
-  LoopState.Env {authHTTPClient, codebase = Codebase {connection, withConnection}} <- ask
+  LoopState.Env {authHTTPClient, codebase} <- ask
 
   -- doesn't handle the case where a non-existent path is supplied
-  Sqlite.runTransaction connection (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath)))
-    >>= \case
-      Nothing -> respond (BranchNotFound . Path.absoluteToPath' $ localPath)
-      Just localCausalHash ->
-        case behavior of
-          PushBehavior.RequireEmpty -> do
-            let push :: IO (Either (Sync.SyncError Share.CheckAndSetPushError) ())
-                push =
-                  withEntitiesUploadedProgressCallbacks \callbacks ->
-                    Share.checkAndSetPush
-                      authHTTPClient
-                      baseURL
-                      withConnection
-                      sharePath
-                      Nothing
-                      localCausalHash
-                      callbacks
-            liftIO push >>= \case
-              Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorCheckAndSetPush err))
-              Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err))
-              Right () -> pure ()
-          PushBehavior.RequireNonEmpty -> do
-            let push :: IO (Either (Sync.SyncError Share.FastForwardPushError) ())
-                push = do
-                  withEntitiesUploadedProgressCallbacks \callbacks ->
-                    Share.fastForwardPush
-                      authHTTPClient
-                      baseURL
-                      withConnection
-                      sharePath
-                      localCausalHash
-                      callbacks
-            liftIO push >>= \case
-              Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorFastForwardPush err))
-              Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err))
-              Right () -> pure ()
+  eval (Eval (Codebase.runTransaction codebase (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath))))) >>= \case
+    Nothing -> respond (BranchNotFound . Path.absoluteToPath' $ localPath)
+    Just localCausalHash ->
+      case behavior of
+        PushBehavior.RequireEmpty -> do
+          let push :: IO (Either (Sync.SyncError Share.CheckAndSetPushError) ())
+              push =
+                withEntitiesUploadedProgressCallbacks \callbacks ->
+                  Share.checkAndSetPush
+                    authHTTPClient
+                    baseURL
+                    (Codebase.withConnectionIO codebase)
+                    sharePath
+                    Nothing
+                    localCausalHash
+                    callbacks
+          liftIO push >>= \case
+            Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorCheckAndSetPush err))
+            Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err))
+            Right () -> pure ()
+        PushBehavior.RequireNonEmpty -> do
+          let push :: IO (Either (Sync.SyncError Share.FastForwardPushError) ())
+              push = do
+                withEntitiesUploadedProgressCallbacks \callbacks ->
+                  Share.fastForwardPush
+                    authHTTPClient
+                    baseURL
+                    (Codebase.withConnectionIO codebase)
+                    sharePath
+                    localCausalHash
+                    callbacks
+          liftIO push >>= \case
+            Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorFastForwardPush err))
+            Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err))
+            Right () -> pure ()
   where
     pathToSegments :: Path -> [Text]
     pathToSegments =
@@ -2322,14 +2320,14 @@ importRemoteShareBranch rrn@(ReadShareRemoteNamespace {server, repo, path}) = do
   when (not $ RemoteRepo.isPublic rrn) $ ensureAuthenticatedWithCodeserver codeserver
   mapLeft Output.ShareError <$> do
     let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path))
-    LoopState.Env {authHTTPClient, codebase = codebase@Codebase {withConnection}} <- ask
+    LoopState.Env {authHTTPClient, codebase} <- ask
     let pull :: IO (Either (Sync.SyncError Share.PullError) CausalHash)
         pull =
           withEntitiesDownloadedProgressCallbacks \callbacks ->
             Share.pull
               authHTTPClient
               baseURL
-              withConnection
+              (Codebase.withConnectionIO codebase)
               shareFlavoredPath
               callbacks
     liftIO pull >>= \case