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,
|
||||
run,
|
||||
eval,
|
||||
makeRunner,
|
||||
getState,
|
||||
changeState,
|
||||
withState,
|
||||
|
@ -203,6 +204,13 @@ eval s a = do
|
|||
mvar <- newMVar s
|
||||
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 selector = do
|
||||
mvar <- ask
|
||||
|
|
|
@ -361,10 +361,15 @@ dropKey r key
|
|||
| otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key
|
||||
|
||||
lockKey :: Remote -> Key -> (VerifiedCopy -> Annex r) -> Annex r
|
||||
lockKey r key a
|
||||
lockKey r key callback
|
||||
| not $ Git.repoIsUrl (repo r) =
|
||||
guardUsable (repo r) cantlock $
|
||||
onLocal r $ Annex.Content.lockContentShared key a
|
||||
guardUsable (repo r) cantlock $ do
|
||||
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
|
||||
| otherwise = error "TODO"
|
||||
where
|
||||
|
|
Loading…
Reference in a new issue