1{- git-annex fuzz generator
2 -
3 - Copyright 2013 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE OverloadedStrings #-}
9
10module Command.FuzzTest where
11
12import Command
13import qualified Annex
14import qualified Git.Config
15import Config
16import Annex.Perms
17import Utility.ThreadScheduler
18import Utility.DiskFree
19import Git.Types (fromConfigKey)
20import qualified Utility.RawFilePath as R
21
22import Data.Time.Clock
23import System.Random (getStdRandom, random, randomR)
24import Test.QuickCheck
25import Control.Concurrent
26
27cmd :: Command
28cmd = notBareRepo $
29	command "fuzztest" SectionTesting
30		"generates fuzz test files"
31		paramNothing (withParams seek)
32
33seek :: CmdParams -> CommandSeek
34seek = withNothing (commandAction start)
35
36start :: CommandStart
37start = do
38	guardTest
39	logf <- fromRepo gitAnnexFuzzTestLogFile
40	showStart "fuzztest" (toRawFilePath logf) (SeekInput [])
41	logh <- liftIO $ openFile logf WriteMode
42	void $ forever $ fuzz logh
43	stop
44
45guardTest :: Annex ()
46guardTest = unlessM (fromMaybe False . Git.Config.isTrueFalse' <$> getConfig key mempty) $
47	giveup $ unlines
48		[ "Running fuzz tests *writes* to and *deletes* files in"
49		, "this repository, and pushes those changes to other"
50		, "repositories! This is a developer tool, not something"
51		, "to play with."
52		, ""
53		, "Refusing to run fuzz tests, since " ++ fromConfigKey key ++ " is not set!"
54		]
55  where
56	key = annexConfig "eat-my-repository"
57
58fuzz :: Handle -> Annex ()
59fuzz logh = do
60	fuzzer <- genFuzzAction
61	record logh $ flip Started fuzzer
62	result <- tryNonAsync $ runFuzzAction fuzzer
63	record logh $ flip Finished $
64		either (const False) (const True) result
65
66record :: Handle -> (UTCTime -> TimeStampedFuzzAction) -> Annex ()
67record h tmpl = liftIO $ do
68	now <- getCurrentTime
69	let s = show $ tmpl now
70	print s
71	hPrint h s
72	hFlush h
73
74{- Delay for either a fraction of a second, or a few seconds, or up
75 - to 1 minute.
76 -
77 - The MinutesDelay is used as an opportunity to do housekeeping tasks.
78 -}
79randomDelay :: Delay -> Annex ()
80randomDelay TinyDelay = liftIO $
81	threadDelay =<< getStdRandom (randomR (10000, 1000000))
82randomDelay SecondsDelay = liftIO $
83	threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 10))
84randomDelay MinutesDelay = do
85	liftIO $ threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 60))
86	reserve <- annexDiskReserve <$> Annex.getGitConfig
87	free <- liftIO $ getDiskFree "."
88	case free of
89		Just have | have < reserve -> do
90			warning "Low disk space; fuzz test paused."
91			liftIO $ threadDelaySeconds (Seconds 60)
92			randomDelay MinutesDelay
93		_  -> noop
94
95data Delay
96	= TinyDelay
97	| SecondsDelay
98	| MinutesDelay
99	deriving (Read, Show, Eq)
100
101instance Arbitrary Delay where
102	arbitrary = elements [TinyDelay, SecondsDelay, MinutesDelay]
103
104data FuzzFile = FuzzFile FilePath
105	deriving (Read, Show, Eq)
106
107data FuzzDir = FuzzDir FilePath
108	deriving (Read, Show, Eq)
109
110instance Arbitrary FuzzFile where
111	arbitrary = FuzzFile <$> arbitrary
112
113instance Arbitrary FuzzDir where
114	arbitrary = FuzzDir <$> arbitrary
115
116class ToFilePath a where
117	toFilePath :: a -> FilePath
118
119instance ToFilePath FuzzFile where
120	toFilePath (FuzzFile f) = f
121
122instance ToFilePath FuzzDir where
123	toFilePath (FuzzDir d) = d
124
125isFuzzFile :: FilePath -> Bool
126isFuzzFile f = "fuzzfile_" `isPrefixOf` takeFileName f
127
128isFuzzDir :: FilePath -> Bool
129isFuzzDir d = "fuzzdir_" `isPrefixOf` d
130
131mkFuzzFile :: FilePath -> [FuzzDir] -> FuzzFile
132mkFuzzFile file dirs = FuzzFile $ joinPath (map toFilePath dirs) </> ("fuzzfile_" ++ file)
133
134mkFuzzDir :: Int -> FuzzDir
135mkFuzzDir n = FuzzDir $ "fuzzdir_" ++ show n
136
137{- File is placed inside a directory hierarchy up to 4 subdirectories deep. -}
138genFuzzFile :: IO FuzzFile
139genFuzzFile = do
140	n <- getStdRandom $ randomR (0, 4)
141	dirs <- replicateM n genFuzzDir
142	file <- show <$> (getStdRandom random :: IO Int)
143	return $ mkFuzzFile file dirs
144
145{- Only 16 distinct subdirectories are used. When nested 4 deep, this
146 - yields 69904 total directories max, which is below the default Linux
147 - inotify limit of 81920. The goal is not to run the assistant out of
148 - inotify descriptors. -}
149genFuzzDir :: IO FuzzDir
150genFuzzDir = mkFuzzDir <$> (getStdRandom (randomR (1,16)) :: IO Int)
151
152data TimeStampedFuzzAction
153	= Started UTCTime FuzzAction
154	| Finished UTCTime Bool
155	deriving (Read, Show)
156
157data FuzzAction
158	= FuzzAdd FuzzFile
159	| FuzzDelete FuzzFile
160	| FuzzMove FuzzFile FuzzFile
161	| FuzzDeleteDir FuzzDir
162	| FuzzMoveDir FuzzDir FuzzDir
163	| FuzzPause Delay
164	deriving (Read, Show, Eq)
165
166instance Arbitrary FuzzAction where
167	arbitrary = frequency
168		[ (50, FuzzAdd <$> arbitrary)
169		, (50, FuzzDelete <$> arbitrary)
170		, (10, FuzzMove <$> arbitrary <*> arbitrary)
171		, (10, FuzzDeleteDir <$> arbitrary)
172		, (10, FuzzMoveDir <$> arbitrary <*> arbitrary)
173		, (10, FuzzPause <$> arbitrary)
174		]
175
176runFuzzAction :: FuzzAction -> Annex ()
177runFuzzAction (FuzzAdd (FuzzFile f)) = do
178	createWorkTreeDirectory (parentDir (toRawFilePath f))
179	n <- liftIO (getStdRandom random :: IO Int)
180	liftIO $ writeFile f $ show n ++ "\n"
181runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $
182	removeWhenExistsWith R.removeLink (toRawFilePath f)
183runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $
184	rename src dest
185runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $
186	removeDirectoryRecursive d
187runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $
188	rename src dest
189runFuzzAction (FuzzPause d) = randomDelay d
190
191genFuzzAction :: Annex FuzzAction
192genFuzzAction = do
193	tmpl <- liftIO $ Prelude.head <$> sample' (arbitrary :: Gen FuzzAction)
194	-- Fix up template action to make sense in the current repo tree.
195	case tmpl of
196		FuzzAdd _ -> do
197			f <- liftIO newFile
198			maybe genFuzzAction (return . FuzzAdd) f
199		FuzzDelete _ -> do
200			f <- liftIO $ existingFile 0 ""
201			maybe genFuzzAction (return . FuzzDelete) f
202		FuzzMove _ _ -> do
203			src <- liftIO $ existingFile 0 ""
204			dest <- liftIO newFile
205			case (src, dest) of
206				(Just s, Just d) -> return $ FuzzMove s d
207				_ -> genFuzzAction
208		FuzzMoveDir _ _ -> do
209			md <- liftIO existingDir
210			case md of
211				Nothing -> genFuzzAction
212				Just d -> do
213					newd <- liftIO $ newDir (parentDir $ toRawFilePath $ toFilePath d)
214					maybe genFuzzAction (return . FuzzMoveDir d) newd
215		FuzzDeleteDir _ -> do
216			d <- liftIO existingDir
217			maybe genFuzzAction (return . FuzzDeleteDir) d
218		FuzzPause _ -> return tmpl
219
220existingFile :: Int -> FilePath -> IO (Maybe FuzzFile)
221existingFile 0 _ = return Nothing
222existingFile n top = do
223	dir <- existingDirIncludingTop
224	contents <- catchDefaultIO [] (getDirectoryContents dir)
225	let files = filter isFuzzFile contents
226	if null files
227		then do
228			let dirs = filter isFuzzDir contents
229			if null dirs
230				then return Nothing
231				else do
232					i <- getStdRandom $ randomR (0, length dirs - 1)
233					existingFile (n - 1) (top </> dirs !! i)
234		else do
235			i <- getStdRandom $ randomR (0, length files - 1)
236			return $ Just $ FuzzFile $ top </> dir </> files !! i
237
238existingDirIncludingTop :: IO FilePath
239existingDirIncludingTop = do
240	dirs <- filter isFuzzDir <$> getDirectoryContents "."
241	if null dirs
242		then return "."
243		else do
244			n <- getStdRandom $ randomR (0, length dirs)
245			return $ ("." : dirs) !! n
246
247existingDir :: IO (Maybe FuzzDir)
248existingDir = do
249	d <- existingDirIncludingTop
250	return $ if isFuzzDir d
251		then Just $ FuzzDir d
252		else Nothing
253
254newFile :: IO (Maybe FuzzFile)
255newFile = go (100 :: Int)
256  where
257	go 0 = return Nothing
258	go n = do
259		f <- genFuzzFile
260		ifM (doesnotexist (toFilePath f))
261			( return $ Just f
262			, go (n - 1)
263			)
264
265newDir :: RawFilePath -> IO (Maybe FuzzDir)
266newDir parent = go (100 :: Int)
267  where
268	go 0 = return Nothing
269	go n = do
270		(FuzzDir d) <- genFuzzDir
271		ifM (doesnotexist (fromRawFilePath parent </> d))
272			( return $ Just $ FuzzDir d
273			, go (n - 1)
274			)
275
276doesnotexist :: FilePath -> IO Bool
277doesnotexist f = isNothing <$> catchMaybeIO (getSymbolicLinkStatus f)
278