diff options
| -rw-r--r-- | Git/Fsck.hs | 13 | ||||
| -rw-r--r-- | Utility/ThreadScheduler.hs | 69 |
2 files changed, 79 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 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 |