diff --git a/Annex.hs b/Annex.hs index 78a6bf3699..d6834e24a6 100644 --- a/Annex.hs +++ b/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 diff --git a/Remote/Git.hs b/Remote/Git.hs index 9fa7158e5e..5c429c93c9 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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