fix lockKey to run callback in original Annex monad, not local remote's

2 files changed, 16 insertions, 3 deletions

diff --git a/Annex.hs b/Annex.hs
index 78a6bf369..d6834e24a 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 9fa7158e5..5c429c93c 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