make fuzztest honor annex.diskreserve

This commit is contained in:
Joey Hess 2013-05-26 16:04:52 -04:00
parent 62c368dd7c
commit 9978269b55

View file

@ -8,11 +8,13 @@
module Command.FuzzTest where module Command.FuzzTest where
import Common.Annex import Common.Annex
import qualified Annex
import Command import Command
import qualified Git.Config import qualified Git.Config
import Config import Config
import Utility.ThreadScheduler import Utility.ThreadScheduler
import Annex.Exception import Annex.Exception
import Utility.DiskFree
import Data.Time.Clock import Data.Time.Clock
import System.Random (getStdRandom, random, randomR) import System.Random (getStdRandom, random, randomR)
@ -67,18 +69,30 @@ record h tmpl = liftIO $ do
hFlush h hFlush h
{- Delay for either a fraction of a second, or a few seconds, or up {- Delay for either a fraction of a second, or a few seconds, or up
- to 1 minute. -} - to 1 minute.
randomDelay :: Delay -> IO () -
randomDelay TinyDelay = threadDelay =<< getStdRandom (randomR (10000, 1000000)) - The MinutesDelay is used as an opportunity to do housekeeping tasks.
randomDelay SecondsDelay = threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 10)) -}
randomDelay MinutesDelay = threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 60)) randomDelay :: Delay -> Annex ()
randomDelay NoDelay = noop 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 data Delay
= TinyDelay = TinyDelay
| SecondsDelay | SecondsDelay
| MinutesDelay | MinutesDelay
| NoDelay
deriving (Read, Show, Eq) deriving (Read, Show, Eq)
instance Arbitrary Delay where instance Arbitrary Delay where
@ -175,7 +189,7 @@ runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $
removeDirectoryRecursive d removeDirectoryRecursive d
runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $ runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $
rename src dest rename src dest
runFuzzAction (FuzzPause d) = liftIO $ randomDelay d runFuzzAction (FuzzPause d) = randomDelay d
genFuzzAction :: Annex FuzzAction genFuzzAction :: Annex FuzzAction
genFuzzAction = do genFuzzAction = do