diff options
| -rw-r--r-- | Command/FuzzTest.hs | 30 |
1 files changed, 22 insertions, 8 deletions
diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index d75bb5a04..f555a7375 100644 --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -8,11 +8,13 @@ module Command.FuzzTest where import Common.Annex +import qualified Annex import Command import qualified Git.Config import Config import Utility.ThreadScheduler import Annex.Exception +import Utility.DiskFree import Data.Time.Clock import System.Random (getStdRandom, random, randomR) @@ -67,18 +69,30 @@ record h tmpl = liftIO $ do hFlush h {- Delay for either a fraction of a second, or a few seconds, or up - - to 1 minute. -} -randomDelay :: Delay -> IO () -randomDelay TinyDelay = threadDelay =<< getStdRandom (randomR (10000, 1000000)) -randomDelay SecondsDelay = threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 10)) -randomDelay MinutesDelay = threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 60)) -randomDelay NoDelay = noop + - to 1 minute. + - + - The MinutesDelay is used as an opportunity to do housekeeping tasks. + -} +randomDelay :: Delay -> Annex () +randomDelay TinyDelay = liftIO $ + threadDelay =<< getStdRandom (randomR (10000, 1000000)) +randomDelay SecondsDelay = liftIO $ + threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 10)) +randomDelay MinutesDelay = do + liftIO $ threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 60)) + reserve <- annexDiskReserve <$> Annex.getGitConfig + free <- liftIO $ getDiskFree "." + case free of + Just have | have < reserve -> do + warning "Low disk space; fuzz test paused." + liftIO $ threadDelaySeconds (Seconds 60) + randomDelay MinutesDelay + _ -> noop data Delay = TinyDelay | SecondsDelay | MinutesDelay - | NoDelay deriving (Read, Show, Eq) instance Arbitrary Delay where @@ -175,7 +189,7 @@ runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $ removeDirectoryRecursive d runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $ rename src dest -runFuzzAction (FuzzPause d) = liftIO $ randomDelay d +runFuzzAction (FuzzPause d) = randomDelay d genFuzzAction :: Annex FuzzAction genFuzzAction = do |