fuzz tester

Command/FuzzTest.hs

@@ -0,0 +1,244 @@
+{- git-annex fuzz generator
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - 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)

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
 	]
 

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"