From ac491b4fac4e83f0319e0da7c82f86d81a5b7030 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Wed, 20 Nov 2013 20:20:14 -0400
Subject: 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.
---
 Git/Fsck.hs                | 13 +++++++--
 Utility/ThreadScheduler.hs | 69 ++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 79 insertions(+), 3 deletions(-)
 create mode 100644 Utility/ThreadScheduler.hs

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
diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs
new file mode 100644
index 0000000..c3e871c
--- /dev/null
+++ b/Utility/ThreadScheduler.hs
@@ -0,0 +1,69 @@
+{- thread scheduling
+ -
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2011 Bas van Dijk & Roel van Dijk
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.ThreadScheduler where
+
+import Common
+
+import Control.Concurrent
+#ifndef mingw32_HOST_OS
+import System.Posix.Signals
+#ifndef __ANDROID__
+import System.Posix.Terminal
+#endif
+#endif
+
+newtype Seconds = Seconds { fromSeconds :: Int }
+	deriving (Eq, Ord, Show)
+
+type Microseconds = Integer
+
+{- Runs an action repeatedly forever, sleeping at least the specified number
+ - of seconds in between. -}
+runEvery :: Seconds -> IO a -> IO a
+runEvery n a = forever $ do
+	threadDelaySeconds n
+	a
+
+threadDelaySeconds :: Seconds -> IO ()
+threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)
+
+{- Like threadDelay, but not bounded by an Int.
+ -
+ - There is no guarantee that the thread will be rescheduled promptly when the
+ - delay has expired, but the thread will never continue to run earlier than
+ - specified.
+ - 
+ - Taken from the unbounded-delay package to avoid a dependency for 4 lines
+ - of code.
+ -}
+unboundDelay :: Microseconds -> IO ()
+unboundDelay time = do
+	let maxWait = min time $ toInteger (maxBound :: Int)
+	threadDelay $ fromInteger maxWait
+	when (maxWait /= time) $ unboundDelay (time - maxWait)
+
+{- Pauses the main thread, letting children run until program termination. -}
+waitForTermination :: IO ()
+waitForTermination = do
+	lock <- newEmptyMVar
+#ifndef mingw32_HOST_OS
+	let check sig = void $
+		installHandler sig (CatchOnce $ putMVar lock ()) Nothing
+	check softwareTermination
+#ifndef __ANDROID__
+	whenM (queryTerminal stdInput) $
+		check keyboardSignal
+#endif
+#endif
+	takeMVar lock
+
+oneSecond :: Microseconds
+oneSecond = 1000000
-- 
cgit v1.2.3