Use Reader for tests
diff --git a/test/Test.hs b/test/Test.hs index d93412c..9ca654c 100644 --- a/test/Test.hs +++ b/test/Test.hs
@@ -1,6 +1,7 @@ module Main where import Control.Monad +import Control.Monad.Reader import Data.List import Data.Char import Data.Maybe @@ -16,6 +17,14 @@ import Test.QuickCheck.Test --import Debug.Trace +data Env = Env { shellMode :: ShellMode + , traceMode :: TraceMode + , spaceMode :: SpaceMode + , tmpDir :: FilePath + } + +type Prop = Reader Env Property + newtype Arg = Arg { unarg :: String } deriving (Show, Eq) instance Arbitrary Arg where @@ -37,18 +46,21 @@ isWindows :: Bool isWindows = os == "mingw32" -chkargs :: [Arg] -> String -> PropertyM IO () -chkargs args out = assert $ args == (Arg <$> read (head $ lines out)) +chkargs :: [Arg] -> IO String -> Property +chkargs args kout = monadicIO $ do + out <- run kout + assert $ args == (Arg <$> read (head $ lines out)) prop_rawargs :: [Arg] -> Property -prop_rawargs args = monadicIO $ run (readProcess "dumpargs" (map unarg args) "") >>= chkargs args +prop_rawargs args = chkargs args $ readProcess "dumpargs" (map unarg args) "" prop_args :: [Arg] -> Property -prop_args args = monadicIO $ run (outputFrom $ fsatrace "x" ++ "dumpargs" : map unarg args) >>= chkargs args +prop_args args = chkargs args $ outputFrom $ fsatrace "x" ++ "dumpargs" : map unarg args outputFrom :: [String] -> IO String outputFrom (cmd:args) = do - (_,out,_) <- readProcessWithExitCode cmd args "" + (_,out,err) <- readProcessWithExitCode cmd args "" + when (err /= "") $ putStrLn err return out outputFrom _ = undefined @@ -63,13 +75,17 @@ fsatrace flags = [cd </> ".." </> "fsatrace", flags, "-", "--"] parsedOutputFrom :: [String] -> IO [Access] -parsedOutputFrom x = outputFrom x >>= return . filter valid . parse +parsedOutputFrom x = outputFrom x >>= return . parse toStandard :: FilePath -> FilePath toStandard = if isWindows then map (\x -> if x == '\\' then '/' else x) else id parseDeps :: String -> [FilePath] -parseDeps = filter (/= "\\") . words . drop 1 . dropWhile (/= ':') +parseDeps = filter (/= " ") . map unhack . words . hack . drop 1 . dropWhile (/= ':') + where hack ('\\':_:xs) = '^':hack xs + hack (x:xs) = x:hack xs + hack [] = [] + unhack = map (\x -> if x == '^' then ' ' else x) parseClDeps :: String -> [FilePath] parseClDeps = mapMaybe parseLine . lines @@ -77,72 +93,89 @@ parseLine _ = Nothing skip c = drop 1 . dropWhile (/= c) -yields :: [String] -> [Access] -> Property -yields args res = monadicIO $ do - r <- run $ parsedOutputFrom args - let sr = nub $ sort r - ok = sr == res - unless ok $ do - run $ putStrLn $ "Expecting " ++ show res - run $ putStrLn $ "Got " ++ show sr - assert ok +yields :: Reader Env [String] -> Reader Env [Access] -> Prop +yields eargs eres = do + e <- ask + return $ monadicIO $ do + let args = runReader eargs e + res = runReader eres e + r <- run $ parsedOutputFrom args + let sr = nub $ sort $ filter (valid $ tmpDir e) r + ok = sr == res + unless ok $ run $ do + putStrLn $ "Expecting " ++ show res + putStrLn $ "Got " ++ show sr + assert ok -data ShellMode = Unshelled | Shelled deriving (Show, Enum, Bounded) -data TraceMode = Untraced | Traced deriving (Show, Enum, Bounded) -data SpaceMode = Unspaced | Spaced deriving (Show, Enum, Bounded) +data ShellMode = Unshelled | Shelled deriving (Show, Eq, Enum, Bounded) +data TraceMode = Untraced | Traced deriving (Show, Eq, Enum, Bounded) +data SpaceMode = Unspaced | Spaced deriving (Show, Eq, Enum, Bounded) -cp :: ShellMode -> String -cp Shelled | isWindows = "copy" -cp _ = "cp" - -rm :: ShellMode -> String -rm Shelled | isWindows = "del" -rm _ = "rm" +isShelled :: Reader Env Bool +isShelled = do + sm <- ask + return $ shellMode sm == Shelled quoted :: String -> String quoted x = "\"" ++ x ++ "\"" +command :: String -> [String] -> Reader Env [String] +command flags args = do + e <- ask + return $ cmd (shellMode e) (traceMode e) + where cmd :: ShellMode -> TraceMode -> [String] + cmd sm Traced = fsatrace flags ++ cmd sm Untraced + cmd Unshelled _ = args + cmd Shelled _ | isWindows = "cmd.exe" : "/c" : args + | otherwise = ["sh", "-c", unwords (map quoted args)] -command :: ShellMode -> TraceMode -> String -> [String] -> [String] -command sm Traced flags args = fsatrace flags ++ command sm Untraced flags args -command Unshelled _ _ args = args -command Shelled _ _ args | isWindows = "cmd.exe" : "/c" : args - | otherwise = ["sh", "-c", unwords (map quoted args)] +whenTracing :: [a] -> Reader Env [a] +whenTracing x = do + e <- ask + return $ if traceMode e == Traced then x else [] -whenTracing :: TraceMode -> [a] -> [a] -whenTracing Traced x = x -whenTracing _ _ = [] +prop_echo :: Path -> Prop +prop_echo src = command "rwmd" ["echo", unpath src] `yields` return [] -prop_echo :: ShellMode -> TraceMode -> Path -> Property -prop_echo sm tm src = command sm tm "rwmd" ["echo", unpath src] `yields` [] +prop_cp :: Path -> Path -> Prop +prop_cp src dst = do + cmd <- cp + command "rwmd" [cmd, unpath src, unpath dst] `yields` whenTracing [R src, W dst] + where cp :: Reader Env String + cp = do + s <- isShelled + return $ if isWindows && s then "copy" else "cp" -prop_cp :: ShellMode -> TraceMode -> Path -> Path -> Property -prop_cp sm tm src dst = command sm tm "rwmd" [cp sm, unpath src, unpath dst] `yields` whenTracing tm [R src, W dst] +prop_mv :: Path -> Path -> Prop +prop_mv src dst = command "rwmd" ["mv", unpath src, unpath dst] `yields` whenTracing [M dst src] -prop_mv :: ShellMode -> TraceMode -> Path -> Path -> Property -prop_mv sm tm src dst = command sm tm "rwmd" ["mv", unpath src, unpath dst] `yields` whenTracing tm [M dst src] +prop_touch :: Path -> Prop +prop_touch dst = command "t" ["touch", unpath dst] `yields` whenTracing [T dst] -prop_touch :: ShellMode -> TraceMode -> Path -> Property -prop_touch sm tm dst = command sm tm "t" ["touch", unpath dst] `yields` whenTracing tm [T dst] +prop_rm :: Path -> Prop +prop_rm dst = do + cmd <- rm + command "rwmd" [cmd, unpath dst] `yields` whenTracing [D dst] + where rm :: Reader Env String + rm = do + s <- isShelled + return $ if isWindows && s then "del" else "rm" -prop_rm :: ShellMode -> TraceMode -> Path -> Property -prop_rm sm tm dst = command sm tm "rwmd" [rm sm, unpath dst] `yields` whenTracing tm [D dst] +prop_gcc :: Path -> [Access] -> Prop +prop_gcc src deps = command "r" ["gcc", "-E", unpath src] `yields` whenTracing deps -prop_gcc :: ShellMode -> TraceMode -> Path -> [Access] -> Property -prop_gcc sm tm src deps = command sm tm "r" ["gcc", "-E", unpath src] `yields` whenTracing tm deps - -prop_cl :: ShellMode -> TraceMode -> Path -> [Access] -> Property -prop_cl sm tm src deps = command sm tm "r" ["cl", "/nologo", "/E", unpath src] `yields` whenTracing tm deps +prop_cl :: Path -> [Access] -> Prop +prop_cl src deps = command "r" ["cl", "/nologo", "/E", unpath src] `yields` whenTracing deps shelled :: [String] -> [String] shelled args | isWindows = "cmd.exe" : "/c" : args | otherwise = ["sh", "-c", unwords args] main :: IO () -main = sequence [allTests sp sm tm | sp <- allValues, sm <- allValues, tm <- allValues] +main = do + sequence [allTests sp sm tm | sp <- allValues, sm <- allValues, tm <- allValues] >>= mapM_ (mapM_ chk) - where qc n s p = noisy s >> quickCheckWithResult stdArgs {maxSuccess=n} p - chk x = unless (isSuccess x) exitFailure + where chk x = unless (isSuccess x) exitFailure noisy s = putStrLn ("Testing " ++ s) banner x = putStrLn $ "================ " ++ x ++ " ================" dirname Unspaced = "fsatrace" @@ -150,31 +183,35 @@ allValues :: (Enum a, Bounded a) => [a] allValues = enumFrom minBound allTests :: SpaceMode -> ShellMode -> TraceMode -> IO [Result] - allTests sp sm tm = withSystemTempDirectory (dirname sp) $ \tmp -> do + allTests sp sm tm = withSystemTempDirectory (dirname sp) $ \utmp -> do + t <- canonicalizePath utmp banner $ show sp ++ " " ++ show sm ++ " " ++ show tm - lic <- canonicalizePath $ ".." </> "LICENSE" - ctmp <- canonicalizePath tmp - csrc <- canonicalizePath $ ".." </> "src" </> "emit.c" - deps <- outputFrom ["gcc", "-MM", csrc] - ndeps <- mapM canonicalizePath (parseDeps deps) - cl <- findExecutable "cl" + src <- canonicalizePath $ ".." </> "src" + cl <- findExecutable "cl.exe" let hascl = isJust cl - clcsrc <- if hascl then canonicalizePath $ ".." </> "src" </> "win" </> "handle.c" else return "" - cldeps <- if hascl then errorFrom ["cl", "/nologo", "/showIncludes", "/E", "/DPATH_MAX=4096", clcsrc] else return [] - ncldeps <- mapM canonicalizePath (clcsrc : parseClDeps cldeps) - let tls = Path $ ctmp </> "LICENSE" - tfoo = Path $ ctmp </> "foo" - rvalid = sort . filter valid . map (R . Path) + tsrc = t </> "src" + emitc = Path $ tsrc </> "emit.c" + srcc = Path $ tsrc </> "src.c" + clcsrc = Path $ tsrc </> "win" </> "handle.c" + rvalid = sort . filter (valid t) . map (R . Path) + e = Env {shellMode = sm, traceMode = tm, spaceMode = sp, tmpDir = t} + qc1 s p = noisy s >> quickCheckWithResult (stdArgs {maxSuccess=1}) (runReader p e) + qc n s p = noisy s >> quickCheckWithResult (stdArgs {maxSuccess=n}) p + _ <- outputFrom ["cp", "-R", src, tsrc] + deps <- outputFrom ["gcc", "-MM", unpath emitc] + ndeps <- mapM canonicalizePath (parseDeps deps) + cldeps <- if hascl then errorFrom ["cl", "/nologo", "/showIncludes", "/E", "/DPATH_MAX=4096", unpath clcsrc] else return [] + ncldeps <- if hascl then mapM canonicalizePath (unpath clcsrc : parseClDeps cldeps) else return [] sequence $ [ qc 10 "rawargs" prop_rawargs , qc 10 "args" prop_args - , qc 1 "echo" $ prop_echo sm tm tls - , qc 1 "cp" $ prop_cp sm tm (Path lic) tls - , qc 1 "mv" $ prop_mv sm tm tls tfoo - , qc 1 "touch" $ prop_touch sm tm tfoo - , qc 1 "rm" $ prop_rm sm tm tfoo - , qc 1 "gcc" $ prop_gcc sm tm (Path csrc) (rvalid ndeps) - ] ++ if hascl then [ qc 1 "cl" $ prop_cl sm tm (Path clcsrc) (rvalid ncldeps) ] else [] + , qc1 "echo" $ prop_echo emitc + , qc1 "cp" $ prop_cp emitc srcc + , qc1 "touch" $ prop_touch srcc + , qc1 "gcc" $ prop_gcc emitc (rvalid ndeps) + , qc1 "mv" $ prop_mv emitc srcc + , qc1 "rm" $ prop_rm srcc + ] ++ if hascl then [ qc1 "cl" $ prop_cl clcsrc (rvalid ncldeps) ] else [] data Access = R Path | W Path @@ -206,18 +243,18 @@ f ('M':'|':xs) | (xs','|':ys) <- break (== '|') xs = Just $ RM (Path xs') (Path ys) f _ = Nothing -valid :: Access -> Bool -valid (R p) = inParent p -valid (Q p) = inParent p -valid (W p) = not $ "/dev/" `isPrefixOf` (unpath p) -valid _ = True - -inParent :: Path -> Bool -inParent = isPrefixOf (takeDirectory $ cased cd) . cased . unpath - cased :: String -> String cased | isWindows = map toLower | otherwise = id cd :: FilePath -cd = unsafePerformIO $ (getCurrentDirectory >>= canonicalizePath) +cd = unsafePerformIO (getCurrentDirectory >>= canonicalizePath) + +valid :: FilePath -> Access -> Bool +valid t (R p) = inTmp t p +valid t (Q p) = inTmp t p +valid _ (W p) = not $ "/dev/" `isPrefixOf` (unpath p) +valid _ _ = True + +inTmp :: FilePath -> Path -> Bool +inTmp t = isPrefixOf (cased t) . cased . unpath
diff --git a/test/fsatracetest.cabal b/test/fsatracetest.cabal index d2ec9a4..df543f0 100644 --- a/test/fsatracetest.cabal +++ b/test/fsatracetest.cabal
@@ -21,5 +21,6 @@ , directory , temporary , process + , mtl hs-source-dirs: . default-language: Haskell2010