@@ -1,169 +1,196 @@
1+{-# LANGUAGE PatternGuards #-}
12{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE MultiWayIf #-}
24
35module Tests.Writers.Powerpoint (tests) where
46
5−import Control.Exception (throwIO)
7+-- import Control.Exception (throwIO)
68import Text.Pandoc
7−import Text.Pandoc.Builder
8−import Text.Pandoc.Arbitrary ()
9−import Text.Pandoc.Walk
109import Test.Tasty
1110import Test.Tasty.HUnit
12−import Test.Tasty.QuickCheck
1311import Codec.Archive.Zip
1412import Text.XML.Light
15−import Data.List (isPrefixOf, isSuffixOf, sort)
16−import Data.Maybe (mapMaybe)
17−
18−getPptxArchive :: WriterOptions -> Pandoc -> IO Archive
19−getPptxArchive opts pd = do
20− mbs <- runIO $
21− do setUserDataDir $ Just "../data"
22− writePowerpoint opts pd
23− case mbs of
24− Left e -> throwIO e
25− Right bs -> return $ toArchive bs
26−
27−----- Number of Slides -----------
28−
29−numberOfSlides :: WriterOptions -> Pandoc -> IO Int
30−numberOfSlides opts pd = do
31− archive <- getPptxArchive opts pd
32− return $
33− length $
34− filter (isSuffixOf ".xml") $
35− filter (isPrefixOf "ppt/slides/slide") $
36− filesInArchive archive
37−
38−testNumberOfSlides :: TestName -> Int -> WriterOptions -> Pandoc -> TestTree
39−testNumberOfSlides name n opts pd =
40− testCase name $ do
41− n' <- numberOfSlides opts pd
42− n' @=? n
43−
44−numSlideTests :: TestTree
45−numSlideTests = testGroup "Number of slides in output"
46− [ testNumberOfSlides
47− "simple one-slide deck" 1
48− def
49− (doc $ para "foo")
50− , testNumberOfSlides
51− "with metadata (header slide)" 2
52− def
53− (setTitle "My Title" $ doc $ para "foo")
54− , testNumberOfSlides
55− "With h1 slide (using default slide-level)" 1
56− def
57− (doc $ header 1 "Header" <> para "foo")
58− , testNumberOfSlides
59− "With h2 slide (using default slide-level)" 2
60− def
61− (doc $ header 1 "Header" <> header 2 "subeader" <> para "foo")
62− , testNumberOfSlides
63− "With h1 slide (using slide-level 3)" 2
64− def {writerSlideLevel= Just 3}
65− (doc $ header 1 "Header" <> para "foo")
66− , testNumberOfSlides
67− "With h2 slide (using slide-level 3)" 3
68− def {writerSlideLevel= Just 3}
69− (doc $ header 1 "Header" <> header 2 "subeader" <> para "foo")
70− , testNumberOfSlides
71− "With image slide, no header" 3
72− def
73− (doc $
74− para "first slide" <>
75− para (image "lalune.jpg" "" "") <>
76− para "foo")
77− , testNumberOfSlides
78− "With image slide, header" 3
79− def
80− (doc $
81− para "first slide" <>
82− header 2 "image header" <>
83− para (image "lalune.jpg" "" "") <>
84− para "foo")
85− , testNumberOfSlides
86− "With table, no header" 3
87− def
88− (doc $
89− para "first slide" <>
90− simpleTable [para "foo" <> para "bar"] [[para "this" <> para "that"]] <>
91− para "foo")
92− , testNumberOfSlides
93− "With table, header" 3
94− def
95− (doc $
96− para "first slide" <>
97− header 2 "table header" <>
98− simpleTable [para "foo" <> para "bar"] [[para "this" <> para "that"]] <>
99− para "foo")
100− , testNumberOfSlides
101− "hrule" 2
102− def
103− (doc $
104− para "first slide" <> horizontalRule <> para "last slide")
105− , testNumberOfSlides
106− "with notes slide" 2
107− def
108− (doc $
109− para $ text "Foo" <> note (para "note text"))
110− ]
111−
112−----- Content Types -----------
113−
114−
115−contentTypesFileExists :: WriterOptions -> Pandoc -> TestTree
116−contentTypesFileExists opts pd =
117− testCase "Existence of [Content_Types].xml file" $
118− do archive <- getPptxArchive opts pd
119− assertBool "Missing [Content_Types].xml file" $
120− "[Content_Types].xml" `elem` filesInArchive archive
121−
122−
123−
124−-- We want an "Override" entry for each xml file under ppt/.
125−prop_ContentOverrides :: Pandoc -> IO Bool
126−prop_ContentOverrides pd = do
127− -- remove Math to avoid warnings
128− let go :: Inline -> Inline
129− go (Math _ _) = Str "Math"
130− go i = i
131− pd' = walk go pd
132− archive <- getPptxArchive def pd'
133− let xmlFiles = filter ("[Content_Types].xml" /=) $
134− filter (isSuffixOf ".xml") $
135− filesInArchive archive
136− contentTypes <- case findEntryByPath "[Content_Types].xml" archive of
137− Just ent -> return $ fromEntry ent
138− Nothing -> throwIO $
139− PandocSomeError "Missing [Content_Types].xml file"
140− typesElem <- case parseXMLDoc contentTypes of
141− Just element -> return element
142− Nothing -> throwIO $
143− PandocSomeError "[Content_Types].xml cannot be parsed"
144− let ns = findAttr (QName "xmlns" Nothing Nothing) typesElem
145− overrides = findChildren (QName "Override" ns Nothing) typesElem
146− partNames = mapMaybe (findAttr (QName "PartName" Nothing Nothing)) overrides
147− -- files in content_types are absolute
148− absXmlFiles = map (\fp -> case fp of
149− ('/':_) -> fp
150− _ -> '/': fp
151− )
152− xmlFiles
153− return $ sort absXmlFiles == sort partNames
154−
155−contentOverridesTests :: TestTree
156−contentOverridesTests = localOption (QuickCheckTests 20) $
157− testProperty "Content Overrides for each XML file" $
158− \x -> ioProperty $ prop_ContentOverrides (x :: Pandoc)
159−
160−contentTypeTests :: TestTree
161−contentTypeTests = testGroup "[Content_Types].xml file"
162− [ contentTypesFileExists def (doc $ para "foo")
163− , contentOverridesTests
164− ]
13+import qualified Data.ByteString.Lazy as BL
14+import qualified Data.Text.IO as T
15+import Data.List (isPrefixOf, isSuffixOf, sort, (\\), intercalate)
16+import Data.Maybe (fromJust, isNothing)
17+import Tests.Helpers
18+import 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
56+
57+compareXMLBool :: Content -> Content -> Bool
58+-- We make a special exception for times at the moment, and just pass
59+-- them because we can't control the utctime when running IO. Besides,
60+-- so long as we have two times, we're okay.
61+compareXMLBool (Elem myElem) (Elem goodElem)
62+ | (QName "created" _ (Just "dcterms")) <- elName myElem
63+ , (QName "created" _ (Just "dcterms")) <- elName goodElem =
64+ True
65+compareXMLBool (Elem myElem) (Elem goodElem)
66+ | (QName "modified" _ (Just "dcterms")) <- elName myElem
67+ , (QName "modified" _ (Just "dcterms")) <- elName goodElem =
68+ True
69+compareXMLBool (Elem myElem) (Elem goodElem) =
70+ and [ elName myElem == elName goodElem
71+ , elAttribs myElem == elAttribs goodElem
72+ , and $
73+ map (uncurry compareXMLBool) $
74+ zip (elContent myElem) (elContent goodElem)
75+ ]
76+compareXMLBool (Text myCData) (Text goodCData) =
77+ and [ cdVerbatim myCData == cdVerbatim goodCData
78+ , cdData myCData == cdData goodCData
79+ , cdLine myCData == cdLine goodCData
80+ ]
81+compareXMLBool (CRef myStr) (CRef goodStr) =
82+ myStr == goodStr
83+compareXMLBool _ _ = False
84+
85+displayDiff :: Content -> Content -> String
86+displayDiff elemA elemB =
87+ showDiff (1,1) $ getDiff (lines $ ppContent elemA) (lines $ ppContent elemB)
88+
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
179+
180+--------------------------------------------------------------
165181
166182tests :: [TestTree]
167−tests = [ numSlideTests
168− , contentTypeTests
183+tests = [ testCompare
184+ "Inline formatting"
185+ "pptx/inline_formatting.native"
186+ "pptx/inline_formatting.pptx"
187+ , testCompare
188+ "slide breaks (default slide-level)"
189+ "pptx/slide_breaks.native"
190+ "pptx/slide_breaks.pptx"
191+ , testCompareWithOpts
192+ "slide breaks (slide-level set to 1)"
193+ def{writerSlideLevel=Just 1}
194+ "pptx/slide_breaks.native"
195+ "pptx/slide_breaks_slide_level_1.pptx"
169196 ]