fix cat-file stall bug

Apparently some corruption to an object can cause cat-file to say it's N
bytes long, but only output N-M bytes of data. This causes Git.CatFile
to stall waiting for the rest. To fix, add a 1 minute timeout to the
cat-file, which should be enough time to read any reasonable object.

1 files changed, 10 insertions, 3 deletions

diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index 350b2bb..2c4d1cd 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -19,8 +19,10 @@ import Git.Command
 import Git.Sha
 import Git.CatFile
 import Utility.Batch
+import Utility.ThreadScheduler
 
 import qualified Data.Set as S
+import Control.Concurrent.Async
 
 type MissingObjects = S.Set Sha
 
@@ -57,8 +59,8 @@ foundBroken (Just s) = not (S.null s)
 
 {- Finds objects that are missing from the git repsitory, or are corrupt.
  -
- - Note that catting a corrupt object will cause cat-file to crash;
- - this is detected and it's restarted.
+ - Note that catting a corrupt object will cause cat-file to crash,
+ - or sometimes to stall; this is detected and it's restarted.
  -}
 findMissing :: [Sha] -> Repo -> IO MissingObjects
 findMissing objs r = go objs [] =<< start
@@ -68,7 +70,12 @@ findMissing objs r = go objs [] =<< start
 		void $ tryIO $ catFileStop h
 		return $ S.fromList c
 	go (o:os) c h = do
-		v <- tryNonAsync $ isNothing <$> catObjectDetails h o
+		reader <- async $ isNothing <$> catObjectDetails h o
+		killer <- async $ do
+			threadDelaySeconds (Seconds 60)
+			cancel reader
+		v <- waitCatch reader
+		cancel killer
 		case v of
 			Left _ -> do
 				void $ tryIO $ catFileStop h