unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-21 15:28:15 +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 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 Control.Monad.Extra (ifM, unlessM)
import qualified Control.Monad.Extra as Monad
@ -110,7 +110,6 @@ import qualified UnliftIO
import UnliftIO.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
import UnliftIO.STM
import UnliftIO.Exception (catch, bracket)
import Control.Monad.Trans.Except (mapExceptT)
debug, debugProcessBranches, debugCommitFailedTransaction :: Bool
debug = False
@ -174,16 +173,17 @@ createCodebaseOrError' debugName path action = do
fmap (Either.mapLeft CreateCodebaseUnknownSchemaVersion) (sqliteCodebase debugName path action)
openOrCreateCodebaseConnection ::
MonadIO m =>
withOpenOrCreateCodebaseConnection ::
(MonadUnliftIO m) =>
Codebase.DebugName ->
FilePath ->
m (IO (), Connection)
openOrCreateCodebaseConnection debugName path = do
(Connection -> m r) ->
m r
withOpenOrCreateCodebaseConnection debugName path action = do
unlessM
(doesFileExist $ path </> codebasePath)
(initSchemaIfNotExist path)
unsafeGetConnection debugName path
withConnection debugName path action
-- get the codebase in dir
getCodebaseOrError ::
@ -1113,13 +1113,12 @@ pushGitBranch srcConn branch repo (PushGitBranchOpts setRoot _syncMode) = runExc
-- set up the cache dir
remotePath <- time "Git fetch" $ withExceptT C.GitProtocolError $ pullBranch (writeToRead repo)
(closeDestConn, destConn) <- openOrCreateCodebaseConnection "push.dest" remotePath
mapExceptT (`finally` liftIO closeDestConn) $ do
ExceptT . withOpenOrCreateCodebaseConnection "push.dest" remotePath $ \destConn -> do
flip runReaderT destConn $ Q.savepoint "push"
lift . flip State.execStateT emptySyncProgressState $
flip State.execStateT emptySyncProgressState $
syncInternal syncProgress srcConn destConn (Branch.transform lift branch)
flip runReaderT destConn do
if setRoot
result <- if setRoot
then do
let newRootHash = Branch.headHash branch
-- 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
setRepoRoot newRootHash
Q.release "push"
pure $ Right ()
Just oldRootHash -> do
before oldRootHash newRootHash >>= \case
Nothing ->
@ -1139,13 +1139,17 @@ pushGitBranch srcConn branch repo (PushGitBranchOpts setRoot _syncMode) = runExc
++ "."
Just False -> do
Q.rollbackRelease "push"
throwError . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo
pure . Left . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo
Just True -> do
setRepoRoot newRootHash
Q.release "push"
else Q.release "push"
pure $ Right ()
else do
Q.release "push"
pure $ Right ()
Q.setJournalMode JournalMode.DELETE
pure result
liftIO do
void $ push remotePath repo
where