Powerpoint Writer tests: Add quickcheck tests for content types.

We want to make sure we always have an override for each xml file in
the content types file.

2 files changed, 79 insertions, 15 deletions

diff --git a/pandoc.cabal b/pandoc.cabal
index dea141a8f..988241567 100644
--- a/pandoc.cabal
+++ b/pandoc.cabal
@@ -622,7 +622,8 @@ test-suite test-pandoc
                   QuickCheck >= 2.4 && < 2.11,
                   containers >= 0.4.2.1 && < 0.6,
                   executable-path >= 0.0 && < 0.1,
-                  zip-archive >= 0.2.3.4 && < 0.4
+                  zip-archive >= 0.2.3.4 && < 0.4,
+                  xml >= 1.3.12 && < 1.4
   if flag(old-locale)
      build-depends: old-locale >= 1 && < 1.1,
                     time >= 1.2 && < 1.5
diff --git a/test/Tests/Writers/Powerpoint.hs b/test/Tests/Writers/Powerpoint.hs
index 7c72f948e..39fd1bab5 100644
--- a/test/Tests/Writers/Powerpoint.hs
+++ b/test/Tests/Writers/Powerpoint.hs
@@ -5,27 +5,35 @@ module Tests.Writers.Powerpoint (tests) where
 import Control.Exception (throwIO)
 import Text.Pandoc
 import Text.Pandoc.Builder
+import Text.Pandoc.Arbitrary ()
+import Text.Pandoc.Walk
 import Test.Tasty
 import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck
 import Codec.Archive.Zip
-import Data.List (isPrefixOf, isSuffixOf)
+import Text.XML.Light
+import Data.List (isPrefixOf, isSuffixOf, sort)
+import Data.Maybe (mapMaybe)
+
+getPptxArchive :: WriterOptions -> Pandoc -> IO Archive
+getPptxArchive opts pd = do
+  mbs <- runIO $
+         do setUserDataDir $ Just "../data"
+            writePowerpoint opts pd
+  case mbs of
+       Left e   -> throwIO e
+       Right bs -> return $ toArchive bs
 
 ----- Number of Slides -----------
 
 numberOfSlides :: WriterOptions -> Pandoc -> IO Int
 numberOfSlides opts pd = do
-  mbs <- runIO $
-        do setUserDataDir $ Just "../data"
-           writePowerpoint opts pd
-  case mbs of
-       Left e   -> throwIO e
-       Right bs -> do
-         let archive = toArchive bs
-         return $
-           length $
-           filter (isSuffixOf ".xml") $
-           filter (isPrefixOf "ppt/slides/slide") $
-           filesInArchive archive
+  archive <- getPptxArchive opts pd
+  return $
+    length $
+    filter (isSuffixOf ".xml") $
+    filter (isPrefixOf "ppt/slides/slide") $
+    filesInArchive archive
 
 testNumberOfSlides :: TestName -> Int -> WriterOptions -> Pandoc -> TestTree
 testNumberOfSlides name n opts pd =
@@ -101,6 +109,61 @@ numSlideTests = testGroup "Number of slides in output"
       para $ text "Foo" <> note (para "note text"))
   ]
 
+----- Content Types -----------
+
+
+contentTypesFileExists :: WriterOptions -> Pandoc -> TestTree
+contentTypesFileExists opts pd =
+  testCase "Existence of [Content_Types].xml file" $
+  do archive <- getPptxArchive opts pd
+     assertBool "Missing [Content_Types].xml file" $
+       "[Content_Types].xml" `elem` (filesInArchive archive)
+
+
+
+-- We want an "Override" entry for each xml file under ppt/.
+prop_ContentOverrides :: Pandoc -> IO Bool
+prop_ContentOverrides pd = do
+  -- remove Math to avoid warnings
+  let go :: Inline -> Inline
+      go (Math _ _) = Str "Math"
+      go i = i
+      pd' = walk go pd
+  archive <- getPptxArchive def pd'
+  let xmlFiles = filter ("[Content_Types].xml" /=) $
+                  filter (isSuffixOf ".xml") $
+                  filesInArchive archive
+  contentTypes <- case findEntryByPath "[Content_Types].xml" archive of
+                    Just ent -> return $ fromEntry ent
+                    Nothing  -> throwIO $
+                      PandocSomeError "Missing [Content_Types].xml file"
+  typesElem <- case parseXMLDoc contentTypes of
+                    Just element -> return $ element
+                    Nothing      -> throwIO $
+                      PandocSomeError "[Content_Types].xml cannot be parsed"
+  let ns = findAttr (QName "xmlns" Nothing Nothing) typesElem
+      overrides = findChildren (QName "Override" ns Nothing) typesElem
+      partNames = mapMaybe (findAttr (QName "PartName" Nothing Nothing)) overrides
+      -- files in content_types are absolute
+      absXmlFiles = map (\fp -> case fp of
+                                  ('/':_) -> fp
+                                  _       -> '/': fp
+                        )
+                    xmlFiles
+  return $ sort absXmlFiles == sort partNames
+
+contentOverridesTests :: TestTree
+contentOverridesTests = localOption (QuickCheckTests 20) $
+                       testProperty "Content Overrides for each XML file" $
+                       \x -> ioProperty $ prop_ContentOverrides (x :: Pandoc)
+
+contentTypeTests :: TestTree
+contentTypeTests = testGroup "[Content_Types].xml file"
+  [ contentTypesFileExists def (doc $ para "foo")
+  , contentOverridesTests
+  ]
 
 tests :: [TestTree]
-tests = [numSlideTests]
+tests = [ numSlideTests
+        , contentTypeTests
+        ]