@@ -4,55 +4,18 @@
44
55module Tests.Writers.Powerpoint (tests) where
66
7−-- import Control.Exception (throwIO)
87import Text.Pandoc
98import Test.Tasty
10−import Test.Tasty.HUnit
9+import Test.Tasty.Golden.Advanced
1110import Codec.Archive.Zip
1211import Text.XML.Light
12+import qualified Data.ByteString as BS
1313import qualified Data.ByteString.Lazy as BL
1414import qualified Data.Text.IO as T
15−import Data.List (isPrefixOf, isSuffixOf, sort, (\\), intercalate)
16−import Data.Maybe (fromJust, isNothing)
15+import Data.List (isPrefixOf, isSuffixOf, sort, (\\), intercalate, union)
16+import Data.Maybe (catMaybes, mapMaybe)
1717import Tests.Helpers
1818import Data.Algorithm.Diff
19−import Control.Monad (when)
20−
21−
22−getPptxBytes :: WriterOptions
23− -> FilePath
24− -> FilePath
25− -> IO (BL.ByteString, BL.ByteString)
26−getPptxBytes opts nativeFp pptxFp = do
27− ntvTxt <- T.readFile nativeFp
28− ntv <- runIOorExplode $ readNative def ntvTxt
29− myPptxBs <- runIOorExplode $ writePowerpoint opts ntv
30− goodPptxBs <- BL.readFile pptxFp
31− return (myPptxBs, goodPptxBs)
32−
33−
34−assertSameFileList :: Archive -> Archive -> FilePath -> Assertion
35−assertSameFileList myArch goodArch pptxFp = do
36− let filesMy = filesInArchive myArch
37− filesGood = filesInArchive goodArch
38− diffMyGood = filesMy \\ filesGood
39− diffGoodMy = filesGood \\ filesMy
40− if | null diffMyGood && null diffGoodMy -> return ()
41− | null diffMyGood ->
42− assertFailure $
43− "Files in " ++ pptxFp ++ " but not in generated archive:\n" ++
44− intercalate ", " diffGoodMy
45− | null diffGoodMy ->
46− assertFailure $
47− "Files in generated archive but not in " ++ pptxFp ++ ":\n" ++
48− intercalate ", " diffMyGood
49− | otherwise ->
50− assertFailure $
51− "Files in " ++ pptxFp ++ " but not in generated archive:\n" ++
52− intercalate ", " diffGoodMy ++
53− "\n" ++
54− "Files in generated archive but not in " ++ pptxFp ++ ":\n" ++
55− intercalate ", " diffMyGood
5619
5720compareXMLBool :: Content -> Content -> Bool
5821-- We make a special exception for times at the moment, and just pass
@@ -86,111 +49,159 @@ displayDiff :: Content -> Content -> String
8649displayDiff elemA elemB =
8750 showDiff (1,1) $ getDiff (lines $ ppContent elemA) (lines $ ppContent elemB)
8851
89−compareXMLFile :: FilePath -> Archive -> Archive -> Assertion
90−compareXMLFile fp myArch goodArch = do
91− let mbMyEntry = findEntryByPath fp myArch
92− when (isNothing mbMyEntry)
93− (assertFailure $
94− "Can't extract " ++ fp ++ " from generated archive")
95− let mbMyXMLDoc = parseXMLDoc $ fromEntry $ fromJust mbMyEntry
96− when (isNothing mbMyXMLDoc)
97− (assertFailure $
98− "Can't parse xml in " ++ fp ++ " from generated archive")
99− let myContent = Elem $ fromJust mbMyXMLDoc
100−
101− let mbGoodEntry = findEntryByPath fp goodArch
102− when (isNothing mbGoodEntry)
103− (assertFailure $
104− "Can't extract " ++ fp ++ " from archive in stored pptx file")
105− let mbGoodXMLDoc = parseXMLDoc $ fromEntry $ fromJust mbGoodEntry
106− when (isNothing mbGoodXMLDoc)
107− (assertFailure $
108− "Can't parse xml in " ++ fp ++ " from archive in stored pptx file")
109− let goodContent = Elem $ fromJust mbGoodXMLDoc
110−
111− assertBool
112− ("Non-matching xml in " ++ fp ++ ":\n" ++ displayDiff myContent goodContent)
113− (compareXMLBool myContent goodContent)
114−
115−compareBinaryFile :: FilePath -> Archive -> Archive -> Assertion
116−compareBinaryFile fp myArch goodArch = do
117− let mbMyEntry = findEntryByPath fp myArch
118− when (isNothing mbMyEntry)
119− (assertFailure $
120− "Can't extract " ++ fp ++ " from generated archive")
121− let myBytes = fromEntry $ fromJust mbMyEntry
122−
123− let mbGoodEntry = findEntryByPath fp goodArch
124− when (isNothing mbGoodEntry)
125− (assertFailure $
126− "Can't extract " ++ fp ++ " from archive in stored pptx file")
127− let goodBytes = fromEntry $ fromJust mbGoodEntry
128−
129− assertBool (fp ++ " doesn't match") (myBytes == goodBytes)
130−
131−testSameFileList :: WriterOptions -> FilePath -> FilePath -> TestTree
132−testSameFileList opts myFp goodFp =
133− testCase ("Identical file list in archives") $ do
134− (myBS, goodBS) <- getPptxBytes opts myFp goodFp
135− let myArch = toArchive myBS
136− goodArch = toArchive goodBS
137− (assertSameFileList myArch goodArch goodFp)
138−
139−testSameXML :: WriterOptions -> FilePath -> FilePath -> TestTree
140−testSameXML opts myFp goodFp = testCaseSteps "Comparing extracted xml files" $
141− \step -> do
142− (myBS, goodBS) <- getPptxBytes opts myFp goodFp
143− let myArch = toArchive myBS
144− goodArch = toArchive goodBS
145−
146− let xmlFileList = sort $
147− filter (\fp -> ".xml" `isSuffixOf` fp || ".rels" `isSuffixOf` fp)
148− (filesInArchive myArch)
149− mapM_
150− (\fp -> step ("- " ++ fp) >> compareXMLFile fp myArch goodArch)
151− xmlFileList
152−
153−testSameMedia :: WriterOptions -> FilePath -> FilePath -> TestTree
154−testSameMedia opts myFp goodFp = testCaseSteps "Comparing media files" $
155− \step -> do
156− (myBS, goodBS) <- getPptxBytes opts myFp goodFp
157− let myArch = toArchive myBS
158− goodArch = toArchive goodBS
159−
160− let mediaFileList = sort $
161− filter (\fp -> "ppt/media/" `isPrefixOf` fp)
162− (filesInArchive myArch)
163−
164− mapM_
165− (\fp -> step ("- " ++ fp) >> compareBinaryFile fp myArch goodArch)
166− mediaFileList
167−
168−testCompareWithOpts :: String -> WriterOptions ->FilePath -> FilePath -> TestTree
169−testCompareWithOpts testName opts nativeFp pptxFp =
170− testGroup testName [ testSameFileList opts nativeFp pptxFp
171− , testSameXML opts nativeFp pptxFp
172− , testSameMedia opts nativeFp pptxFp
173− ]
174−
175−
176−testCompare :: String -> FilePath -> FilePath -> TestTree
177−testCompare testName nativeFp pptxFp =
178− testCompareWithOpts testName def nativeFp pptxFp
52+goldenArchive :: FilePath -> IO Archive
53+goldenArchive fp = (toArchive . BL.fromStrict) <$> BS.readFile fp
54+
55+testArchive :: WriterOptions -> FilePath -> IO Archive
56+testArchive opts fp = do
57+ txt <- T.readFile fp
58+ bs <- runIOorExplode $ readNative def txt >>= writePowerpoint opts
59+ return $ toArchive bs
60+
61+updateGoldenFile :: WriterOptions -> FilePath -> FilePath -> IO ()
62+updateGoldenFile opts nativeFP goldenFP = do
63+ txt <- T.readFile nativeFP
64+ bs <- runIOorExplode $ readNative def txt >>= writePowerpoint opts
65+ BL.writeFile goldenFP bs
66+
67+compareFileList :: FilePath -> Archive -> Archive -> Maybe String
68+compareFileList goldenFP goldenArch testArch =
69+ let testFiles = filesInArchive testArch
70+ goldenFiles = filesInArchive goldenArch
71+ diffTestGolden = testFiles \\ goldenFiles
72+ diffGoldenTest = goldenFiles \\ testFiles
73+
74+ results =
75+ [ if null diffGoldenTest
76+ then Nothing
77+ else Just $
78+ "Files in " ++ goldenFP ++ " but not in generated archive:\n" ++
79+ intercalate ", " diffGoldenTest
80+ , if null diffTestGolden
81+ then Nothing
82+ else Just $
83+ "Files in generated archive but not in " ++ goldenFP ++ ":\n" ++
84+ intercalate ", " diffTestGolden
85+ ]
86+ in
87+ if null $ catMaybes results
88+ then Nothing
89+ else Just $ intercalate "\n" $ catMaybes results
90+
91+compareXMLFile' :: FilePath -> Archive -> Archive -> Either String ()
92+compareXMLFile' fp goldenArch testArch = do
93+ testEntry <- case findEntryByPath fp testArch of
94+ Just entry -> Right entry
95+ Nothing -> Left $
96+ "Can't extract " ++ fp ++ " from generated archive"
97+ testXMLDoc <- case parseXMLDoc $ fromEntry testEntry of
98+ Just doc -> Right doc
99+ Nothing -> Left $
100+ "Can't parse xml in " ++ fp ++ " from generated archive"
101+
102+ goldenEntry <- case findEntryByPath fp goldenArch of
103+ Just entry -> Right entry
104+ Nothing -> Left $
105+ "Can't extract " ++ fp ++ " from archive in stored pptx file"
106+ goldenXMLDoc <- case parseXMLDoc $ fromEntry goldenEntry of
107+ Just doc -> Right doc
108+ Nothing -> Left $
109+ "Can't parse xml in " ++ fp ++ " from archive in stored pptx file"
110+
111+ let testContent = Elem $ testXMLDoc
112+ goldenContent = Elem $ goldenXMLDoc
113+
114+ if (compareXMLBool goldenContent testContent)
115+ then Right ()
116+ else Left $
117+ "Non-matching xml in " ++ fp ++ ":\n" ++ displayDiff testContent goldenContent
118+
119+compareXMLFile :: FilePath -> Archive -> Archive -> Maybe String
120+compareXMLFile fp goldenArch testArch =
121+ case compareXMLFile' fp goldenArch testArch of
122+ Right _ -> Nothing
123+ Left s -> Just s
124+
125+compareAllXMLFiles :: Archive -> Archive -> Maybe String
126+compareAllXMLFiles goldenArch testArch =
127+ let allFiles = filesInArchive goldenArch `union` filesInArchive testArch
128+ allXMLFiles = sort $
129+ filter
130+ (\fp -> ".xml" `isSuffixOf` fp || ".rels" `isSuffixOf` fp)
131+ allFiles
132+ results =
133+ mapMaybe (\fp -> compareXMLFile fp goldenArch testArch) allXMLFiles
134+ in
135+ if null results
136+ then Nothing
137+ else Just $ unlines results
138+
139+compareMediaFile' :: FilePath -> Archive -> Archive -> Either String ()
140+compareMediaFile' fp goldenArch testArch = do
141+ testEntry <- case findEntryByPath fp testArch of
142+ Just entry -> Right entry
143+ Nothing -> Left $
144+ "Can't extract " ++ fp ++ " from generated archive"
145+ goldenEntry <- case findEntryByPath fp goldenArch of
146+ Just entry -> Right entry
147+ Nothing -> Left $
148+ "Can't extract " ++ fp ++ " from archive in stored pptx file"
149+
150+ if (fromEntry testEntry == fromEntry goldenEntry)
151+ then Right ()
152+ else Left $
153+ "Non-matching binary file: " ++ fp
154+
155+compareMediaFile :: FilePath -> Archive -> Archive -> Maybe String
156+compareMediaFile fp goldenArch testArch =
157+ case compareMediaFile' fp goldenArch testArch of
158+ Right _ -> Nothing
159+ Left s -> Just s
160+
161+compareAllMediaFiles :: Archive -> Archive -> Maybe String
162+compareAllMediaFiles goldenArch testArch =
163+ let allFiles = filesInArchive goldenArch `union` filesInArchive testArch
164+ allMediaFiles = sort $
165+ filter
166+ (\fp -> "/ppt/media/" `isPrefixOf` fp)
167+ allFiles
168+ results =
169+ mapMaybe (\fp -> compareMediaFile fp goldenArch testArch) allMediaFiles
170+ in
171+ if null results
172+ then Nothing
173+ else Just $ unlines results
174+
175+pptxTest :: String -> WriterOptions -> FilePath -> FilePath -> TestTree
176+pptxTest testName opts nativeFP goldenFP =
177+ goldenTest
178+ testName
179+ (goldenArchive goldenFP)
180+ (testArchive opts nativeFP)
181+ (\goldenArch testArch ->
182+ let res = catMaybes [ compareFileList goldenFP goldenArch testArch
183+ , compareAllXMLFiles goldenArch testArch
184+ , compareAllMediaFiles goldenArch testArch
185+ ]
186+ in return $ if null res then Nothing else Just $ unlines res)
187+ (\_ -> updateGoldenFile opts nativeFP goldenFP)
179188
180189--------------------------------------------------------------
181190
182191tests :: [TestTree]
183−tests = [ testCompare
192+tests = [ pptxTest
184193 "Inline formatting"
194+ def
185195 "pptx/inline_formatting.native"
186196 "pptx/inline_formatting.pptx"
187− , testCompare
188− "slide breaks (default slide-level)"
197+ , pptxTest
198+ "Slide breaks (default slide-level)"
199+ def
189200 "pptx/slide_breaks.native"
190201 "pptx/slide_breaks.pptx"
191− , testCompareWithOpts
202+ , pptxTest
192203 "slide breaks (slide-level set to 1)"
193− def{writerSlideLevel=Just 1}
204+ def{ writerSlideLevel = Just 1 }
194205 "pptx/slide_breaks.native"
195206 "pptx/slide_breaks_slide_level_1.pptx"
196207 ]