diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs new file mode 100644 index 0000000000..c01654462f --- /dev/null +++ b/Command/FuzzTest.hs @@ -0,0 +1,244 @@ +{- git-annex fuzz generator + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.FuzzTest where + +import Common.Annex +import Command +import qualified Git.Config +import Config +import Utility.ThreadScheduler +import Annex.Exception + +import Data.Time.Clock +import System.Random (getStdRandom, random, randomR) +import Test.QuickCheck +import Control.Concurrent + +def :: [Command] +def = [ notBareRepo $ command "fuzztest" paramNothing seek SectionPlumbing + "generates fuzz test files"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +start = do + guardTest + logf <- fromRepo gitAnnexFuzzTestLogFile + showStart "fuzztest" logf + logh <-liftIO $ openFile logf WriteMode + void $ forever $ fuzz logh + stop + +guardTest :: Annex () +guardTest = unlessM (fromMaybe False . Git.Config.isTrue <$> getConfig key "") $ + error $ unlines + [ "Running fuzz tests *writes* to and *deletes* files in" + , "this repository, and pushes those changes to other" + , "repositories! This is a developer tool, not something" + , "to play with." + , "" + , "Refusing to run fuzz tests, since " ++ keyname ++ " is not set!" + ] + where + key = annexConfig "eat-my-repository" + (ConfigKey keyname) = key + + +fuzz :: Handle -> Annex () +fuzz logh = do + action <- genFuzzAction + liftIO $ do + now <- getCurrentTime + hPrint logh $ Started now action + hFlush logh + result <- tryAnnex $ runFuzzAction action + liftIO $ do + now <- getCurrentTime + hPrint logh $ + Finished now $ + either (const False) (const True) result + hFlush logh + +{- 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 + +data Delay + = TinyDelay + | SecondsDelay + | MinutesDelay + | NoDelay + deriving (Read, Show, Eq) + +instance Arbitrary Delay where + arbitrary = elements [TinyDelay, SecondsDelay, MinutesDelay] + +data FuzzFile = FuzzFile FilePath + deriving (Read, Show, Eq) + +data FuzzDir = FuzzDir FilePath + deriving (Read, Show, Eq) + +instance Arbitrary FuzzFile where + arbitrary = FuzzFile <$> arbitrary + +instance Arbitrary FuzzDir where + arbitrary = FuzzDir <$> arbitrary + +class ToFilePath a where + toFilePath :: a -> FilePath + +instance ToFilePath FuzzFile where + toFilePath (FuzzFile f) = f + +instance ToFilePath FuzzDir where + toFilePath (FuzzDir d) = d + +isFuzzFile :: FilePath -> Bool +isFuzzFile f = "fuzzfile_" `isPrefixOf` takeFileName f + +isFuzzDir :: FilePath -> Bool +isFuzzDir d = "fuzzdir_" `isPrefixOf` d + +mkFuzzFile :: FilePath -> [FuzzDir] -> FuzzFile +mkFuzzFile file dirs = FuzzFile $ joinPath (map toFilePath dirs) ("fuzzfile_" ++ file) + +mkFuzzDir :: Int -> FuzzDir +mkFuzzDir n = FuzzDir $ "fuzzdir_" ++ show n + +genFuzzFile :: IO FuzzFile +genFuzzFile = do + n <- getStdRandom $ randomR (0, 5) + dirs <- replicateM n genFuzzDir + file <- show <$> (getStdRandom random :: IO Int) + return $ mkFuzzFile file dirs + +genFuzzDir :: IO FuzzDir +genFuzzDir = mkFuzzDir <$> (getStdRandom random :: IO Int) + +localFile :: FilePath -> Bool +localFile f + | isAbsolute f = False + | ".." `isInfixOf` f = False + | ".git" `isPrefixOf` f = False + | otherwise = True + +data TimeStampedFuzzAction + = Started UTCTime FuzzAction + | Finished UTCTime Bool + deriving (Read, Show) + +data FuzzAction + = FuzzAdd FuzzFile + | FuzzDelete FuzzFile + | FuzzMove FuzzFile FuzzFile + | FuzzModify FuzzFile + | FuzzDeleteDir FuzzDir + | FuzzMoveDir FuzzDir FuzzDir + | FuzzPause Delay + deriving (Read, Show, Eq) + +instance Arbitrary FuzzAction where + arbitrary = frequency + [ (100, FuzzAdd <$> arbitrary) + , (10, FuzzDelete <$> arbitrary) + , (10, FuzzMove <$> arbitrary <*> arbitrary) + , (10, FuzzModify <$> arbitrary) + , (10, FuzzDeleteDir <$> arbitrary) + , (10, FuzzMoveDir <$> arbitrary <*> arbitrary) + , (10, FuzzPause <$> arbitrary) + ] + +runFuzzAction :: FuzzAction -> Annex () +runFuzzAction (FuzzAdd (FuzzFile f)) = liftIO $ do + createDirectoryIfMissing True $ parentDir f + n <- getStdRandom random :: IO Int + writeFile f $ show n ++ "\n" +runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ nukeFile f +runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $ + rename src dest +runFuzzAction (FuzzModify (FuzzFile f)) = whenM isDirect $ liftIO $ do + n <- getStdRandom random :: IO Int + appendFile f $ show n ++ "\n" +runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $ + removeDirectoryRecursive d +runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $ + rename src dest +runFuzzAction (FuzzPause d) = liftIO $ randomDelay d + +genFuzzAction :: Annex FuzzAction +genFuzzAction = liftIO $ do + tmpl <- Prelude.head <$> sample' (arbitrary :: Gen FuzzAction) + -- Fix up template action to make sense in the current repo tree. + case tmpl of + FuzzAdd _ -> FuzzAdd <$> newFile + FuzzDelete _ -> FuzzDelete <$> existingFile "" + FuzzMove _ _ -> FuzzMove <$> existingFile "" <*> newFile + FuzzMoveDir _ _ -> do + d <- existingDir + newd <- newDir (parentDir $ toFilePath d) + return $ FuzzMoveDir d newd + FuzzDeleteDir _ -> FuzzDeleteDir <$> existingDir + FuzzModify _ -> FuzzModify <$> existingFile "" + FuzzPause _ -> return tmpl + +existingFile :: FilePath -> IO FuzzFile +existingFile top = do + dir <- toFilePath <$> existingDir + contents <- catchDefaultIO [] (getDirectoryContents dir) + let files = filter isFuzzFile contents + if null files + then do + let dirs = filter isFuzzDir contents + if null dirs + then return $ FuzzFile "" + else do + n <- getStdRandom $ randomR (0, length dirs - 1) + existingFile (top dirs !! n) + else do + n <- getStdRandom $ randomR (0, length files - 1) + return $ FuzzFile $ top dir files !! n + +existingDir :: IO FuzzDir +existingDir = do + dirs <- filter isFuzzDir <$> getDirectoryContents "." + if null dirs + then return $ FuzzDir "" + else do + n <- getStdRandom $ randomR (0, length dirs) + return $ FuzzDir $ ("." : dirs) !! n + +newFile :: IO FuzzFile +newFile = go (100 :: Int) + where + go 0 = return $ FuzzFile "" + go n = do + f <- genFuzzFile + ifM (doesnotexist (toFilePath f)) + ( return f + , go (n - 1) + ) + +newDir :: FilePath -> IO FuzzDir +newDir parent = go (100 :: Int) + where + go 0 = return $ FuzzDir "" + go n = do + (FuzzDir d) <- genFuzzDir + ifM (doesnotexist (parent d)) + ( return $ FuzzDir d + , go (n - 1) + ) + +doesnotexist :: FilePath -> IO Bool +doesnotexist f = isNothing <$> catchMaybeIO (getSymbolicLinkStatus f) diff --git a/GitAnnex.hs b/GitAnnex.hs index 65cb9363e2..4dbf7390ee 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -76,6 +76,7 @@ import qualified Command.XMPPGit #endif #ifdef WITH_TESTSUITE import qualified Command.Test +import qualified Command.FuzzTest #endif cmds :: [Command] @@ -142,6 +143,7 @@ cmds = concat #endif #ifdef WITH_TESTSUITE , Command.Test.def + , Command.FuzzTest.def #endif ] diff --git a/Locations.hs b/Locations.hs index ba1e74150d..7a897f837f 100644 --- a/Locations.hs +++ b/Locations.hs @@ -36,6 +36,7 @@ module Locations ( gitAnnexPidFile, gitAnnexDaemonStatusFile, gitAnnexLogFile, + gitAnnexFuzzTestLogFile, gitAnnexHtmlShim, gitAnnexUrlFile, gitAnnexTmpCfgFile, @@ -227,6 +228,10 @@ gitAnnexDaemonStatusFile r = gitAnnexDir r "daemon.status" gitAnnexLogFile :: Git.Repo -> FilePath gitAnnexLogFile r = gitAnnexDir r "daemon.log" +{- Log file for fuzz test. -} +gitAnnexFuzzTestLogFile :: Git.Repo -> FilePath +gitAnnexFuzzTestLogFile r = gitAnnexDir r "fuzztest.log" + {- Html shim file used to launch the webapp. -} gitAnnexHtmlShim :: Git.Repo -> FilePath gitAnnexHtmlShim r = gitAnnexDir r "webapp.html"