Powerpoint tests: Convert to golden tests
This will allow us to rebuild the pptx files in the test dir more easily if we make a change in the writer.
This commit is contained in:
Jesse Rosenthal
parent
e9ed4832ed
commit
0e48c216bc
1 changed files with 133 additions and 122 deletions
|
|
@ -4,55 +4,18 @@
|
||||||
|
|
||||||
module Tests.Writers.Powerpoint (tests) where
|
module Tests.Writers.Powerpoint (tests) where
|
||||||
|
|
||||||
-- import Control.Exception (throwIO)
|
|
||||||
import Text.Pandoc
|
import Text.Pandoc
|
||||||
import Test.Tasty
|
import Test.Tasty
|
||||||
import Test.Tasty.HUnit
|
import Test.Tasty.Golden.Advanced
|
||||||
import Codec.Archive.Zip
|
import Codec.Archive.Zip
|
||||||
import Text.XML.Light
|
import Text.XML.Light
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
import qualified Data.ByteString.Lazy as BL
|
import qualified Data.ByteString.Lazy as BL
|
||||||
import qualified Data.Text.IO as T
|
import qualified Data.Text.IO as T
|
||||||
import Data.List (isPrefixOf, isSuffixOf, sort, (\\), intercalate)
|
import Data.List (isPrefixOf, isSuffixOf, sort, (\\), intercalate, union)
|
||||||
import Data.Maybe (fromJust, isNothing)
|
import Data.Maybe (catMaybes, mapMaybe)
|
||||||
import Tests.Helpers
|
import Tests.Helpers
|
||||||
import Data.Algorithm.Diff
|
import Data.Algorithm.Diff
|
||||||
import Control.Monad (when)
|
|
||||||
|
|
||||||
|
|
||||||
getPptxBytes :: WriterOptions
|
|
||||||
-> FilePath
|
|
||||||
-> FilePath
|
|
||||||
-> IO (BL.ByteString, BL.ByteString)
|
|
||||||
getPptxBytes opts nativeFp pptxFp = do
|
|
||||||
ntvTxt <- T.readFile nativeFp
|
|
||||||
ntv <- runIOorExplode $ readNative def ntvTxt
|
|
||||||
myPptxBs <- runIOorExplode $ writePowerpoint opts ntv
|
|
||||||
goodPptxBs <- BL.readFile pptxFp
|
|
||||||
return (myPptxBs, goodPptxBs)
|
|
||||||
|
|
||||||
|
|
||||||
assertSameFileList :: Archive -> Archive -> FilePath -> Assertion
|
|
||||||
assertSameFileList myArch goodArch pptxFp = do
|
|
||||||
let filesMy = filesInArchive myArch
|
|
||||||
filesGood = filesInArchive goodArch
|
|
||||||
diffMyGood = filesMy \\ filesGood
|
|
||||||
diffGoodMy = filesGood \\ filesMy
|
|
||||||
if | null diffMyGood && null diffGoodMy -> return ()
|
|
||||||
| null diffMyGood ->
|
|
||||||
assertFailure $
|
|
||||||
"Files in " ++ pptxFp ++ " but not in generated archive:\n" ++
|
|
||||||
intercalate ", " diffGoodMy
|
|
||||||
| null diffGoodMy ->
|
|
||||||
assertFailure $
|
|
||||||
"Files in generated archive but not in " ++ pptxFp ++ ":\n" ++
|
|
||||||
intercalate ", " diffMyGood
|
|
||||||
| otherwise ->
|
|
||||||
assertFailure $
|
|
||||||
"Files in " ++ pptxFp ++ " but not in generated archive:\n" ++
|
|
||||||
intercalate ", " diffGoodMy ++
|
|
||||||
"\n" ++
|
|
||||||
"Files in generated archive but not in " ++ pptxFp ++ ":\n" ++
|
|
||||||
intercalate ", " diffMyGood
|
|
||||||
|
|
||||||
compareXMLBool :: Content -> Content -> Bool
|
compareXMLBool :: Content -> Content -> Bool
|
||||||
-- We make a special exception for times at the moment, and just pass
|
-- We make a special exception for times at the moment, and just pass
|
||||||
|
|
@ -86,111 +49,159 @@ displayDiff :: Content -> Content -> String
|
||||||
displayDiff elemA elemB =
|
displayDiff elemA elemB =
|
||||||
showDiff (1,1) $ getDiff (lines $ ppContent elemA) (lines $ ppContent elemB)
|
showDiff (1,1) $ getDiff (lines $ ppContent elemA) (lines $ ppContent elemB)
|
||||||
|
|
||||||
compareXMLFile :: FilePath -> Archive -> Archive -> Assertion
|
goldenArchive :: FilePath -> IO Archive
|
||||||
compareXMLFile fp myArch goodArch = do
|
goldenArchive fp = (toArchive . BL.fromStrict) <$> BS.readFile fp
|
||||||
let mbMyEntry = findEntryByPath fp myArch
|
|
||||||
when (isNothing mbMyEntry)
|
|
||||||
(assertFailure $
|
|
||||||
"Can't extract " ++ fp ++ " from generated archive")
|
|
||||||
let mbMyXMLDoc = parseXMLDoc $ fromEntry $ fromJust mbMyEntry
|
|
||||||
when (isNothing mbMyXMLDoc)
|
|
||||||
(assertFailure $
|
|
||||||
"Can't parse xml in " ++ fp ++ " from generated archive")
|
|
||||||
let myContent = Elem $ fromJust mbMyXMLDoc
|
|
||||||
|
|
||||||
let mbGoodEntry = findEntryByPath fp goodArch
|
testArchive :: WriterOptions -> FilePath -> IO Archive
|
||||||
when (isNothing mbGoodEntry)
|
testArchive opts fp = do
|
||||||
(assertFailure $
|
txt <- T.readFile fp
|
||||||
"Can't extract " ++ fp ++ " from archive in stored pptx file")
|
bs <- runIOorExplode $ readNative def txt >>= writePowerpoint opts
|
||||||
let mbGoodXMLDoc = parseXMLDoc $ fromEntry $ fromJust mbGoodEntry
|
return $ toArchive bs
|
||||||
when (isNothing mbGoodXMLDoc)
|
|
||||||
(assertFailure $
|
|
||||||
"Can't parse xml in " ++ fp ++ " from archive in stored pptx file")
|
|
||||||
let goodContent = Elem $ fromJust mbGoodXMLDoc
|
|
||||||
|
|
||||||
assertBool
|
updateGoldenFile :: WriterOptions -> FilePath -> FilePath -> IO ()
|
||||||
("Non-matching xml in " ++ fp ++ ":\n" ++ displayDiff myContent goodContent)
|
updateGoldenFile opts nativeFP goldenFP = do
|
||||||
(compareXMLBool myContent goodContent)
|
txt <- T.readFile nativeFP
|
||||||
|
bs <- runIOorExplode $ readNative def txt >>= writePowerpoint opts
|
||||||
|
BL.writeFile goldenFP bs
|
||||||
|
|
||||||
compareBinaryFile :: FilePath -> Archive -> Archive -> Assertion
|
compareFileList :: FilePath -> Archive -> Archive -> Maybe String
|
||||||
compareBinaryFile fp myArch goodArch = do
|
compareFileList goldenFP goldenArch testArch =
|
||||||
let mbMyEntry = findEntryByPath fp myArch
|
let testFiles = filesInArchive testArch
|
||||||
when (isNothing mbMyEntry)
|
goldenFiles = filesInArchive goldenArch
|
||||||
(assertFailure $
|
diffTestGolden = testFiles \\ goldenFiles
|
||||||
"Can't extract " ++ fp ++ " from generated archive")
|
diffGoldenTest = goldenFiles \\ testFiles
|
||||||
let myBytes = fromEntry $ fromJust mbMyEntry
|
|
||||||
|
|
||||||
let mbGoodEntry = findEntryByPath fp goodArch
|
results =
|
||||||
when (isNothing mbGoodEntry)
|
[ if null diffGoldenTest
|
||||||
(assertFailure $
|
then Nothing
|
||||||
"Can't extract " ++ fp ++ " from archive in stored pptx file")
|
else Just $
|
||||||
let goodBytes = fromEntry $ fromJust mbGoodEntry
|
"Files in " ++ goldenFP ++ " but not in generated archive:\n" ++
|
||||||
|
intercalate ", " diffGoldenTest
|
||||||
|
, if null diffTestGolden
|
||||||
|
then Nothing
|
||||||
|
else Just $
|
||||||
|
"Files in generated archive but not in " ++ goldenFP ++ ":\n" ++
|
||||||
|
intercalate ", " diffTestGolden
|
||||||
|
]
|
||||||
|
in
|
||||||
|
if null $ catMaybes results
|
||||||
|
then Nothing
|
||||||
|
else Just $ intercalate "\n" $ catMaybes results
|
||||||
|
|
||||||
assertBool (fp ++ " doesn't match") (myBytes == goodBytes)
|
compareXMLFile' :: FilePath -> Archive -> Archive -> Either String ()
|
||||||
|
compareXMLFile' fp goldenArch testArch = do
|
||||||
|
testEntry <- case findEntryByPath fp testArch of
|
||||||
|
Just entry -> Right entry
|
||||||
|
Nothing -> Left $
|
||||||
|
"Can't extract " ++ fp ++ " from generated archive"
|
||||||
|
testXMLDoc <- case parseXMLDoc $ fromEntry testEntry of
|
||||||
|
Just doc -> Right doc
|
||||||
|
Nothing -> Left $
|
||||||
|
"Can't parse xml in " ++ fp ++ " from generated archive"
|
||||||
|
|
||||||
testSameFileList :: WriterOptions -> FilePath -> FilePath -> TestTree
|
goldenEntry <- case findEntryByPath fp goldenArch of
|
||||||
testSameFileList opts myFp goodFp =
|
Just entry -> Right entry
|
||||||
testCase ("Identical file list in archives") $ do
|
Nothing -> Left $
|
||||||
(myBS, goodBS) <- getPptxBytes opts myFp goodFp
|
"Can't extract " ++ fp ++ " from archive in stored pptx file"
|
||||||
let myArch = toArchive myBS
|
goldenXMLDoc <- case parseXMLDoc $ fromEntry goldenEntry of
|
||||||
goodArch = toArchive goodBS
|
Just doc -> Right doc
|
||||||
(assertSameFileList myArch goodArch goodFp)
|
Nothing -> Left $
|
||||||
|
"Can't parse xml in " ++ fp ++ " from archive in stored pptx file"
|
||||||
|
|
||||||
testSameXML :: WriterOptions -> FilePath -> FilePath -> TestTree
|
let testContent = Elem $ testXMLDoc
|
||||||
testSameXML opts myFp goodFp = testCaseSteps "Comparing extracted xml files" $
|
goldenContent = Elem $ goldenXMLDoc
|
||||||
\step -> do
|
|
||||||
(myBS, goodBS) <- getPptxBytes opts myFp goodFp
|
|
||||||
let myArch = toArchive myBS
|
|
||||||
goodArch = toArchive goodBS
|
|
||||||
|
|
||||||
let xmlFileList = sort $
|
if (compareXMLBool goldenContent testContent)
|
||||||
filter (\fp -> ".xml" `isSuffixOf` fp || ".rels" `isSuffixOf` fp)
|
then Right ()
|
||||||
(filesInArchive myArch)
|
else Left $
|
||||||
mapM_
|
"Non-matching xml in " ++ fp ++ ":\n" ++ displayDiff testContent goldenContent
|
||||||
(\fp -> step ("- " ++ fp) >> compareXMLFile fp myArch goodArch)
|
|
||||||
xmlFileList
|
|
||||||
|
|
||||||
testSameMedia :: WriterOptions -> FilePath -> FilePath -> TestTree
|
compareXMLFile :: FilePath -> Archive -> Archive -> Maybe String
|
||||||
testSameMedia opts myFp goodFp = testCaseSteps "Comparing media files" $
|
compareXMLFile fp goldenArch testArch =
|
||||||
\step -> do
|
case compareXMLFile' fp goldenArch testArch of
|
||||||
(myBS, goodBS) <- getPptxBytes opts myFp goodFp
|
Right _ -> Nothing
|
||||||
let myArch = toArchive myBS
|
Left s -> Just s
|
||||||
goodArch = toArchive goodBS
|
|
||||||
|
|
||||||
let mediaFileList = sort $
|
compareAllXMLFiles :: Archive -> Archive -> Maybe String
|
||||||
filter (\fp -> "ppt/media/" `isPrefixOf` fp)
|
compareAllXMLFiles goldenArch testArch =
|
||||||
(filesInArchive myArch)
|
let allFiles = filesInArchive goldenArch `union` filesInArchive testArch
|
||||||
|
allXMLFiles = sort $
|
||||||
|
filter
|
||||||
|
(\fp -> ".xml" `isSuffixOf` fp || ".rels" `isSuffixOf` fp)
|
||||||
|
allFiles
|
||||||
|
results =
|
||||||
|
mapMaybe (\fp -> compareXMLFile fp goldenArch testArch) allXMLFiles
|
||||||
|
in
|
||||||
|
if null results
|
||||||
|
then Nothing
|
||||||
|
else Just $ unlines results
|
||||||
|
|
||||||
mapM_
|
compareMediaFile' :: FilePath -> Archive -> Archive -> Either String ()
|
||||||
(\fp -> step ("- " ++ fp) >> compareBinaryFile fp myArch goodArch)
|
compareMediaFile' fp goldenArch testArch = do
|
||||||
mediaFileList
|
testEntry <- case findEntryByPath fp testArch of
|
||||||
|
Just entry -> Right entry
|
||||||
|
Nothing -> Left $
|
||||||
|
"Can't extract " ++ fp ++ " from generated archive"
|
||||||
|
goldenEntry <- case findEntryByPath fp goldenArch of
|
||||||
|
Just entry -> Right entry
|
||||||
|
Nothing -> Left $
|
||||||
|
"Can't extract " ++ fp ++ " from archive in stored pptx file"
|
||||||
|
|
||||||
testCompareWithOpts :: String -> WriterOptions ->FilePath -> FilePath -> TestTree
|
if (fromEntry testEntry == fromEntry goldenEntry)
|
||||||
testCompareWithOpts testName opts nativeFp pptxFp =
|
then Right ()
|
||||||
testGroup testName [ testSameFileList opts nativeFp pptxFp
|
else Left $
|
||||||
, testSameXML opts nativeFp pptxFp
|
"Non-matching binary file: " ++ fp
|
||||||
, testSameMedia opts nativeFp pptxFp
|
|
||||||
]
|
|
||||||
|
|
||||||
|
compareMediaFile :: FilePath -> Archive -> Archive -> Maybe String
|
||||||
|
compareMediaFile fp goldenArch testArch =
|
||||||
|
case compareMediaFile' fp goldenArch testArch of
|
||||||
|
Right _ -> Nothing
|
||||||
|
Left s -> Just s
|
||||||
|
|
||||||
testCompare :: String -> FilePath -> FilePath -> TestTree
|
compareAllMediaFiles :: Archive -> Archive -> Maybe String
|
||||||
testCompare testName nativeFp pptxFp =
|
compareAllMediaFiles goldenArch testArch =
|
||||||
testCompareWithOpts testName def nativeFp pptxFp
|
let allFiles = filesInArchive goldenArch `union` filesInArchive testArch
|
||||||
|
allMediaFiles = sort $
|
||||||
|
filter
|
||||||
|
(\fp -> "/ppt/media/" `isPrefixOf` fp)
|
||||||
|
allFiles
|
||||||
|
results =
|
||||||
|
mapMaybe (\fp -> compareMediaFile fp goldenArch testArch) allMediaFiles
|
||||||
|
in
|
||||||
|
if null results
|
||||||
|
then Nothing
|
||||||
|
else Just $ unlines results
|
||||||
|
|
||||||
|
pptxTest :: String -> WriterOptions -> FilePath -> FilePath -> TestTree
|
||||||
|
pptxTest testName opts nativeFP goldenFP =
|
||||||
|
goldenTest
|
||||||
|
testName
|
||||||
|
(goldenArchive goldenFP)
|
||||||
|
(testArchive opts nativeFP)
|
||||||
|
(\goldenArch testArch ->
|
||||||
|
let res = catMaybes [ compareFileList goldenFP goldenArch testArch
|
||||||
|
, compareAllXMLFiles goldenArch testArch
|
||||||
|
, compareAllMediaFiles goldenArch testArch
|
||||||
|
]
|
||||||
|
in return $ if null res then Nothing else Just $ unlines res)
|
||||||
|
(\_ -> updateGoldenFile opts nativeFP goldenFP)
|
||||||
|
|
||||||
--------------------------------------------------------------
|
--------------------------------------------------------------
|
||||||
|
|
||||||
tests :: [TestTree]
|
tests :: [TestTree]
|
||||||
tests = [ testCompare
|
tests = [ pptxTest
|
||||||
"Inline formatting"
|
"Inline formatting"
|
||||||
|
def
|
||||||
"pptx/inline_formatting.native"
|
"pptx/inline_formatting.native"
|
||||||
"pptx/inline_formatting.pptx"
|
"pptx/inline_formatting.pptx"
|
||||||
, testCompare
|
, pptxTest
|
||||||
"slide breaks (default slide-level)"
|
"Slide breaks (default slide-level)"
|
||||||
|
def
|
||||||
"pptx/slide_breaks.native"
|
"pptx/slide_breaks.native"
|
||||||
"pptx/slide_breaks.pptx"
|
"pptx/slide_breaks.pptx"
|
||||||
, testCompareWithOpts
|
, pptxTest
|
||||||
"slide breaks (slide-level set to 1)"
|
"slide breaks (slide-level set to 1)"
|
||||||
def{writerSlideLevel=Just 1}
|
def{ writerSlideLevel = Just 1 }
|
||||||
"pptx/slide_breaks.native"
|
"pptx/slide_breaks.native"
|
||||||
"pptx/slide_breaks_slide_level_1.pptx"
|
"pptx/slide_breaks_slide_level_1.pptx"
|
||||||
]
|
]
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue