From 71f7e6a178b9b5e694975729f276548fc5461c21 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Mon, 18 Apr 2016 14:04:20 -0400
Subject: fix drop hang reported by musicmatze

Fix hang when dropping content needs to lock the content on a ssh remote,
which occurred when the remote has git-annex version 5.20151019 or newer.

Analysis: `race` runs 2 threads at once, and the hGetLine finishes first.
So, it tries to cancel the waitForProcess, but unfortunately that is making
a foreign call and so cannot be canceled. The remote git-annex-shell
is waiting for a line on stdin before it will exit. Deadlock.

This only occurred sometimes; I reproduced it going from darkstar to
elephant, but not from darkstar to darkstar. Not sure how that fits into
the above analysis -- perhaps a race condition is also involved?

Fixed by not using `race`; now the hGetLine will fail with an exception
if the remote git-annex-shell exits without any output.
---
 Remote/Git.hs | 21 +++++++++------------
 1 file changed, 9 insertions(+), 12 deletions(-)

(limited to 'Remote')

diff --git a/Remote/Git.hs b/Remote/Git.hs
index 256428137..284d6a49c 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -57,7 +57,6 @@ import Types.NumCopies
 
 import Control.Concurrent
 import Control.Concurrent.MSampleVar
-import Control.Concurrent.Async
 import qualified Data.Map as M
 import Network.URI
 
@@ -387,17 +386,14 @@ lockKey r key callback
 						, std_out = CreatePipe
 						, std_err = UseHandle nullh
 						}
-		-- Wait for either the process to exit, or for it to
-		-- indicate the content is locked.
-		v <- liftIO $ race 
-			(waitForProcess p)
-			(hGetLine hout)
-		let signaldone = void $ tryNonAsync $ liftIO $ do
-			hPutStrLn hout ""
-			hFlush hout
-			hClose hin
-			hClose hout
-			void $ waitForProcess p
+		v <- liftIO $ tryIO $ hGetLine hout
+		let signaldone = void $ tryNonAsync $ liftIO $ mapM_ tryNonAsync
+			[ hPutStrLn hout ""
+			, hFlush hout
+			, hClose hin
+			, hClose hout
+			, void $ waitForProcess p
+			]
 		let checkexited = not . isJust <$> getProcessExitCode p
 		case v of
 			Left _exited -> do
@@ -405,6 +401,7 @@ lockKey r key callback
 				liftIO $ do
 					hClose hin
 					hClose hout
+					void $ waitForProcess p
 				failedlock
 			Right l 
 				| l == Ssh.contentLockedMarker -> bracket_
-- 
cgit v1.2.3