fix lockKey to run callback in original Annex monad, not local remote's
This commit is contained in:
parent
4c6095b6f5
commit
865dd11dbf
2 changed files with 16 additions and 3 deletions
8
Annex.hs
8
Annex.hs
|
@ -13,6 +13,7 @@ module Annex (
|
||||||
new,
|
new,
|
||||||
run,
|
run,
|
||||||
eval,
|
eval,
|
||||||
|
makeRunner,
|
||||||
getState,
|
getState,
|
||||||
changeState,
|
changeState,
|
||||||
withState,
|
withState,
|
||||||
|
@ -203,6 +204,13 @@ eval s a = do
|
||||||
mvar <- newMVar s
|
mvar <- newMVar s
|
||||||
runReaderT (runAnnex a) mvar
|
runReaderT (runAnnex a) mvar
|
||||||
|
|
||||||
|
{- Makes a runner action, that allows diving into IO and from inside
|
||||||
|
- the IO action, running an Annex action. -}
|
||||||
|
makeRunner :: Annex (Annex a -> IO a)
|
||||||
|
makeRunner = do
|
||||||
|
mvar <- ask
|
||||||
|
return $ \a -> runReaderT (runAnnex a) mvar
|
||||||
|
|
||||||
getState :: (AnnexState -> v) -> Annex v
|
getState :: (AnnexState -> v) -> Annex v
|
||||||
getState selector = do
|
getState selector = do
|
||||||
mvar <- ask
|
mvar <- ask
|
||||||
|
|
|
@ -361,10 +361,15 @@ dropKey r key
|
||||||
| otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key
|
| otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key
|
||||||
|
|
||||||
lockKey :: Remote -> Key -> (VerifiedCopy -> Annex r) -> Annex r
|
lockKey :: Remote -> Key -> (VerifiedCopy -> Annex r) -> Annex r
|
||||||
lockKey r key a
|
lockKey r key callback
|
||||||
| not $ Git.repoIsUrl (repo r) =
|
| not $ Git.repoIsUrl (repo r) =
|
||||||
guardUsable (repo r) cantlock $
|
guardUsable (repo r) cantlock $ do
|
||||||
onLocal r $ Annex.Content.lockContentShared key a
|
inorigrepo <- Annex.makeRunner
|
||||||
|
-- Lock content from perspective of remote,
|
||||||
|
-- and then run the callback in the original
|
||||||
|
-- annex monad, not the remote's.
|
||||||
|
onLocal r $ Annex.Content.lockContentShared key $
|
||||||
|
liftIO . inorigrepo . callback
|
||||||
| Git.repoIsHttp (repo r) = cantlock
|
| Git.repoIsHttp (repo r) = cantlock
|
||||||
| otherwise = error "TODO"
|
| otherwise = error "TODO"
|
||||||
where
|
where
|
||||||
|
|
Loading…
Reference in a new issue