module Ideas.Main.BlackBoxTests (blackBoxTests) where
import Control.Monad
import Control.Monad.Error
import Data.List
import Ideas.Common.Utils (useFixedStdGen, snd3)
import Ideas.Common.Utils.TestSuite
import Ideas.Encoding.ModeJSON
import Ideas.Encoding.ModeXML
import Ideas.Service.DomainReasoner
import Ideas.Service.Request
import System.Directory
import System.IO
blackBoxTests :: DomainReasoner -> String -> IO TestSuite
blackBoxTests dr path = do
putStrLn ("Scanning " ++ path)
xs0 <- getDirectoryContents path
let (xml, xs1) = partition (".xml" `isSuffixOf`) xs0
(json, xs2) = partition (".json" `isSuffixOf`) xs1
ts1 <- forM json $ \x ->
doBlackBoxTest dr JSON (path ++ "/" ++ x)
ts2 <- forM xml $ \x ->
doBlackBoxTest dr XML (path ++ "/" ++ x)
ts3 <- forM (filter ((/= ".") . take 1) xs2) $ \x -> do
let p = path ++ "/" ++ x
valid <- doesDirectoryExist p
if not valid
then return (return ())
else liftM (suite $ "Directory " ++ simplerDirectory p)
(blackBoxTests dr p)
return $
sequence_ (ts1 ++ ts2 ++ ts3)
doBlackBoxTest :: DomainReasoner -> DataFormat -> FilePath -> IO TestSuite
doBlackBoxTest dr format path = do
hSetBinaryMode stdout True
b <- doesFileExist expPath
return $ if not b
then warn $ expPath ++ " does not exist"
else assertIO (stripDirectoryPart path) $ do
(h1, h2, txt, expt) <- liftIO $ do
useFixedStdGen
h1 <- openBinaryFile path ReadMode
txt <- hGetContents h1
h2 <- openBinaryFile expPath ReadMode
expt <- hGetContents h2
return (h1, h2, txt, expt)
out <- case format of
JSON -> liftM snd3 (processJSON False dr txt)
XML -> liftM snd3 (processXML dr Nothing txt)
let result = out ~= expt
liftIO $ result `seq` (hClose h1 >> hClose h2 >> return result)
`catchError`
\_ -> return False
where
expPath = baseOf path ++ ".exp"
baseOf = reverse . drop 1 . dropWhile (/= '.') . reverse
x ~= y = filterVersion x == filterVersion y
filterVersion =
let p s = not (null s || "version" `isInfixOf` s)
in filter p . lines . filter (/= '\r')
simplerDirectory :: String -> String
simplerDirectory s
| "../" `isPrefixOf` s = simplerDirectory (drop 3 s)
| "test/" `isPrefixOf` s = simplerDirectory (drop 5 s)
| otherwise = s
stripDirectoryPart :: String -> String
stripDirectoryPart = reverse . takeWhile (/= '/') . reverse