unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-21 23:37:23 +03:00
Code Issues Projects Releases Wiki Activity

Switch to withOpenOrCreateCodebase

Browse Source
This commit is contained in:
Chris Penner 2021-12-03 10:48:01 -06:00
parent ae27ca6e3b
commit e7b7d24c02
1 changed files with 17 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs
View File

@ -14,7 +14,7 @@ where
import qualified Control.Concurrent import qualified Control.Concurrent
import Control.Monad (filterM, unless, when, (>=>)) import Control.Monad (filterM, unless, when, (>=>))
import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT, withExceptT) import Control.Monad.Except (ExceptT (ExceptT), runExceptT, withExceptT)
import qualified Control.Monad.Except as Except import qualified Control.Monad.Except as Except
import Control.Monad.Extra (ifM, unlessM) import Control.Monad.Extra (ifM, unlessM)
import qualified Control.Monad.Extra as Monad import qualified Control.Monad.Extra as Monad
@ -110,7 +110,6 @@ import qualified UnliftIO
import UnliftIO.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import UnliftIO.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
import UnliftIO.STM import UnliftIO.STM
import UnliftIO.Exception (catch, bracket) import UnliftIO.Exception (catch, bracket)
import Control.Monad.Trans.Except (mapExceptT)
debug, debugProcessBranches, debugCommitFailedTransaction :: Bool debug, debugProcessBranches, debugCommitFailedTransaction :: Bool
debug = False debug = False
@ -174,16 +173,17 @@ createCodebaseOrError' debugName path action = do
fmap (Either.mapLeft CreateCodebaseUnknownSchemaVersion) (sqliteCodebase debugName path action) fmap (Either.mapLeft CreateCodebaseUnknownSchemaVersion) (sqliteCodebase debugName path action)
openOrCreateCodebaseConnection :: withOpenOrCreateCodebaseConnection ::
MonadIO m => (MonadUnliftIO m) =>
Codebase.DebugName -> Codebase.DebugName ->
FilePath -> FilePath ->
m (IO (), Connection) (Connection -> m r) ->
openOrCreateCodebaseConnection debugName path = do m r
withOpenOrCreateCodebaseConnection debugName path action = do
unlessM unlessM
(doesFileExist $ path </> codebasePath) (doesFileExist $ path </> codebasePath)
(initSchemaIfNotExist path) (initSchemaIfNotExist path)
unsafeGetConnection debugName path withConnection debugName path action
-- get the codebase in dir -- get the codebase in dir
getCodebaseOrError :: getCodebaseOrError ::
@ -1113,13 +1113,12 @@ pushGitBranch srcConn branch repo (PushGitBranchOpts setRoot _syncMode) = runExc
-- set up the cache dir -- set up the cache dir
remotePath <- time "Git fetch" $ withExceptT C.GitProtocolError $ pullBranch (writeToRead repo) remotePath <- time "Git fetch" $ withExceptT C.GitProtocolError $ pullBranch (writeToRead repo)
(closeDestConn, destConn) <- openOrCreateCodebaseConnection "push.dest" remotePath ExceptT . withOpenOrCreateCodebaseConnection "push.dest" remotePath $ \destConn -> do
mapExceptT (`finally` liftIO closeDestConn) $ do
flip runReaderT destConn $ Q.savepoint "push" flip runReaderT destConn $ Q.savepoint "push"
lift . flip State.execStateT emptySyncProgressState $ flip State.execStateT emptySyncProgressState $
syncInternal syncProgress srcConn destConn (Branch.transform lift branch) syncInternal syncProgress srcConn destConn (Branch.transform lift branch)
flip runReaderT destConn do flip runReaderT destConn do
if setRoot result <- if setRoot
then do then do
let newRootHash = Branch.headHash branch let newRootHash = Branch.headHash branch
-- the call to runDB "handles" the possible DB error by bombing -- the call to runDB "handles" the possible DB error by bombing
@ -1127,6 +1126,7 @@ pushGitBranch srcConn branch repo (PushGitBranchOpts setRoot _syncMode) = runExc
Nothing -> do Nothing -> do
setRepoRoot newRootHash setRepoRoot newRootHash
Q.release "push" Q.release "push"
pure $ Right ()
Just oldRootHash -> do Just oldRootHash -> do
before oldRootHash newRootHash >>= \case before oldRootHash newRootHash >>= \case
Nothing -> Nothing ->
@ -1139,13 +1139,17 @@ pushGitBranch srcConn branch repo (PushGitBranchOpts setRoot _syncMode) = runExc
++ "." ++ "."
Just False -> do Just False -> do
Q.rollbackRelease "push" Q.rollbackRelease "push"
throwError . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo pure . Left . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo
Just True -> do Just True -> do
setRepoRoot newRootHash setRepoRoot newRootHash
Q.release "push" Q.release "push"
else Q.release "push" pure $ Right ()
else do
Q.release "push"
pure $ Right ()
Q.setJournalMode JournalMode.DELETE Q.setJournalMode JournalMode.DELETE
pure result
liftIO do liftIO do
void $ push remotePath repo void $ push remotePath repo
where where