| {-# LANGUAGE LambdaCase #-} |
| |
| -- | A test of the FSATrace program |
| module Utils( |
| Env(..), ShellMode(..), SpaceMode(..), |
| Prop, |
| Path(..), Arg(..), |
| Act(..), FSATest(..), showAct, |
| cased, valid, |
| command, yields, yieldsPrepare, |
| systemStdout, systemStderr, |
| no32to64 |
| ) where |
| |
| import Parse |
| |
| import Control.Monad |
| import Control.Monad.IO.Class |
| import Control.Monad.Trans.Reader |
| import Data.Char |
| import Data.List.Extra |
| import System.Exit |
| import System.IO |
| import System.Process |
| import System.FilePath |
| import System.Info.Extra |
| import Test.QuickCheck |
| import Test.QuickCheck.Monadic |
| --import Debug.Trace |
| |
| data Env = Env |
| { shellMode :: ShellMode |
| , tmpDir :: FilePath |
| , pwdDir :: FilePath |
| } |
| |
| type Prop = Reader Env Property |
| |
| newtype Arg = Arg { unarg :: String } deriving (Show, Eq) |
| |
| instance Arbitrary Arg where |
| arbitrary = Arg <$> listOf1 validChars |
| where validChars = arbitrary `suchThat` \x -> isLatin1 x && x `notElem` "\0>|" |
| shrink (Arg x) = map Arg $ shrink x |
| |
| newtype Path = Path { unpath :: FilePath } |
| |
| instance Eq Path where |
| (==) (Path a) (Path b) = equalFilePath a b |
| |
| instance Show Path where |
| show (Path p) = show p |
| |
| instance Ord Path where |
| compare (Path x) (Path y) = compare (cased x) (cased y) |
| |
| |
| data ShellMode = Unshelled | Shelled deriving (Show, Eq, Enum, Bounded) |
| data SpaceMode = Unspaced | Spaced deriving (Show, Eq, Enum, Bounded) |
| |
| cased :: String -> String |
| cased | isWindows = map toLower |
| | otherwise = id |
| |
| |
| |
| valid :: FilePath -> Access Path -> Bool |
| valid t (R p) = inTmp t p |
| valid t (Q p) = inTmp t p |
| valid t (W p) | isWindows = inTmp t p |
| | otherwise = not $ "/dev/" `isPrefixOf` unpath p |
| valid t (D p) = inTmp t p |
| valid t (T p) = inTmp t p |
| valid t (M p _) = inTmp t p |
| valid _ (RW _) = False -- sort on Windows produces this |
| valid _ _ = True |
| |
| inTmp :: FilePath -> Path -> Bool |
| inTmp t = isPrefixOf (cased t) . cased . unpath |
| |
| yields :: Reader Env [String] -> [Access Path] -> Prop |
| yields = yieldsPrepare True $ return () |
| |
| yieldsPrepare :: Bool -> IO () -> Reader Env [String] -> [Access Path] -> Prop |
| yieldsPrepare fatal prepare eargs res = do |
| e <- ask |
| return $ monadicIO $ do |
| liftIO prepare |
| let cmd = runReader eargs e |
| if length (unwords cmd) > 2000 then |
| fail "Excessively long command line" |
| else do |
| out <- liftIO $ if fatal then systemStdout cmd else Just <$> systemStdoutPass cmd |
| let cleanup = nubSort . filter (valid $ tmpDir e) |
| let r = fmap (cleanup . map (fmap Path) . parseFSATrace) out |
| let ok = fmap cleanup r == Just (cleanup res) |
| unless ok $ liftIO $ do |
| putStrLn $ "Expecting " ++ show (cleanup res) |
| putStrLn $ "Got " ++ show r |
| assert ok |
| |
| |
| command :: String -> [String] -> Reader Env [String] |
| command flags args = do |
| e <- ask |
| return $ [pwdDir e </> ".." </> "fsatrace", flags, "-", "--"] ++ cmd (shellMode e) |
| where cmd :: ShellMode -> [String] |
| cmd Unshelled = args |
| cmd Shelled | isWindows = "cmd.exe" : "/C" : args |
| | otherwise = ["sh", "-c", unwords (map quoted args)] |
| quoted :: String -> String |
| quoted "|" = "|" |
| quoted ">" = ">" |
| quoted x = "\"" ++ x ++ "\"" |
| |
| |
| systemStderr :: [String] -> IO (Maybe String) |
| systemStderr ~(cmd:args) = do |
| (res,_out,err) <- readProcessWithExitCode cmd args "" |
| return $ if res == ExitSuccess then Just err else Nothing |
| |
| systemStdout :: [String] -> IO (Maybe String) |
| systemStdout ~(cmd:args) = do |
| (res,out,err) <- readProcessWithExitCode cmd args "" |
| when (err /= "") $ hPutStrLn stderr err |
| return $ if res == ExitSuccess then Just out else Nothing |
| |
| systemStdoutPass :: [String] -> IO String |
| systemStdoutPass ~(cmd:args) = do |
| (_,out,err) <- readProcessWithExitCode cmd args "" |
| when (err /= "") $ hPutStrLn stderr err |
| return out |
| |
| data FSATest = FSATest | FSATest32 |
| deriving Eq |
| |
| instance Show FSATest where |
| show FSATest = "fsatest" |
| show FSATest32 = "fsatest32" |
| |
| instance Arbitrary FSATest where |
| arbitrary = elements [FSATest, FSATest32] |
| shrink x = [FSATest | x /= FSATest] |
| |
| data Act = ActR FilePath |
| | ActW FilePath |
| | ActE FSATest [Act] |
| | ActF |
| deriving Show |
| |
| instance Arbitrary Act where |
| arbitrary = sized $ \sz -> frequency |
| [(8, ActR <$> name) |
| ,(8, ActW <$> name) |
| ,(1, return ActF) |
| ,(if sz > 10 then 1 else 0, resize (min 20 $ sz-10) $ ActE <$> arbitrary <*> arbitrary)] |
| where name = vectorOf 2 $ choose ('a', 'z') |
| |
| shrink (ActE a b) = (flip ActE b <$> (shrink a)) ++ (ActE a <$> shrink b) ++ b |
| shrink _ = [] |
| |
| showAct :: Env -> [Act] -> [String] |
| showAct e = map f |
| where |
| f (ActR x) = "r" ++ tmpDir e </> x |
| f (ActW x) = "w" ++ tmpDir e </> x |
| f ActF = "f" |
| f (ActE p xs) = "e" ++ escape (unwords $ (pwdDir e </> ".." </> show p) : showAct e xs) |
| |
| escape = concatMap $ \case |
| '#' -> "##" |
| ' ' -> "#" |
| x -> [x] |
| |
| no32to64 :: FSATest -> Act -> Act |
| no32to64 FSATest32 (ActE _ xs) = ActE FSATest32 $ map (no32to64 FSATest32) xs |
| no32to64 _ (ActE p xs) = ActE p $ map (no32to64 p) xs |
| no32to64 _ x = x |