diff options
Diffstat (limited to 'test/Tests/Writers/OOXML.hs')
-rw-r--r-- | test/Tests/Writers/OOXML.hs | 184 |
1 files changed, 184 insertions, 0 deletions
diff --git a/test/Tests/Writers/OOXML.hs b/test/Tests/Writers/OOXML.hs new file mode 100644 index 000000000..bdfdea145 --- /dev/null +++ b/test/Tests/Writers/OOXML.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE OverloadedStrings #-} + +module Tests.Writers.OOXML (ooxmlTest) where + +import Text.Pandoc +import Test.Tasty +import Test.Tasty.Golden.Advanced +import Codec.Archive.Zip +import Text.XML.Light +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.IO as T +import Data.List (isSuffixOf, sort, (\\), intercalate, union) +import Data.Maybe (catMaybes, mapMaybe) +import Tests.Helpers +import Data.Algorithm.Diff +import System.FilePath.Glob (compile, match) + +compareXMLBool :: Content -> Content -> Bool +-- We make a special exception for times at the moment, and just pass +-- them because we can't control the utctime when running IO. Besides, +-- so long as we have two times, we're okay. +compareXMLBool (Elem myElem) (Elem goodElem) + | (QName "created" _ (Just "dcterms")) <- elName myElem + , (QName "created" _ (Just "dcterms")) <- elName goodElem = + True +compareXMLBool (Elem myElem) (Elem goodElem) + | (QName "modified" _ (Just "dcterms")) <- elName myElem + , (QName "modified" _ (Just "dcterms")) <- elName goodElem = + True +compareXMLBool (Elem myElem) (Elem goodElem) = + elName myElem == elName goodElem && + elAttribs myElem == elAttribs goodElem && + and (zipWith compareXMLBool (elContent myElem) (elContent goodElem)) +compareXMLBool (Text myCData) (Text goodCData) = + cdVerbatim myCData == cdVerbatim goodCData && + cdData myCData == cdData goodCData && + cdLine myCData == cdLine goodCData +compareXMLBool (CRef myStr) (CRef goodStr) = + myStr == goodStr +compareXMLBool _ _ = False + +displayDiff :: Content -> Content -> String +displayDiff elemA elemB = + showDiff (1,1) $ getDiff (lines $ ppContent elemA) (lines $ ppContent elemB) + +goldenArchive :: FilePath -> IO Archive +goldenArchive fp = (toArchive . BL.fromStrict) <$> BS.readFile fp + +testArchive :: (WriterOptions -> Pandoc -> PandocIO BL.ByteString) + -> WriterOptions + -> FilePath + -> IO Archive +testArchive writerFn opts fp = do + txt <- T.readFile fp + bs <- runIOorExplode $ readNative def txt >>= writerFn opts + return $ toArchive bs + +compareFileList :: FilePath -> Archive -> Archive -> Maybe String +compareFileList goldenFP goldenArch testArch = + let testFiles = filesInArchive testArch + goldenFiles = filesInArchive goldenArch + diffTestGolden = testFiles \\ goldenFiles + diffGoldenTest = goldenFiles \\ testFiles + + results = + [ if null diffGoldenTest + then Nothing + else Just $ + "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 + +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" + + goldenEntry <- case findEntryByPath fp goldenArch of + Just entry -> Right entry + Nothing -> Left $ + "Can't extract " ++ fp ++ " from archive in stored file" + goldenXMLDoc <- case parseXMLDoc $ fromEntry goldenEntry of + Just doc -> Right doc + Nothing -> Left $ + "Can't parse xml in " ++ fp ++ " from archive in stored file" + + let testContent = Elem testXMLDoc + goldenContent = Elem goldenXMLDoc + + if compareXMLBool goldenContent testContent + then Right () + else Left $ + "Non-matching xml in " ++ fp ++ ":\n" ++ displayDiff testContent goldenContent + +compareXMLFile :: FilePath -> Archive -> Archive -> Maybe String +compareXMLFile fp goldenArch testArch = + case compareXMLFile' fp goldenArch testArch of + Right _ -> Nothing + Left s -> Just s + +compareAllXMLFiles :: Archive -> Archive -> Maybe String +compareAllXMLFiles goldenArch testArch = + 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 + +compareMediaFile' :: FilePath -> Archive -> Archive -> Either String () +compareMediaFile' fp goldenArch testArch = do + 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 file" + + if fromEntry testEntry == fromEntry goldenEntry + then Right () + else Left $ + "Non-matching binary file: " ++ fp + +compareMediaFile :: FilePath -> Archive -> Archive -> Maybe String +compareMediaFile fp goldenArch testArch = + case compareMediaFile' fp goldenArch testArch of + Right _ -> Nothing + Left s -> Just s + +compareAllMediaFiles :: Archive -> Archive -> Maybe String +compareAllMediaFiles goldenArch testArch = + let allFiles = filesInArchive goldenArch `union` filesInArchive testArch + mediaPattern = compile "*/media/*" + allMediaFiles = sort $ + filter (match mediaPattern) allFiles + results = + mapMaybe (\fp -> compareMediaFile fp goldenArch testArch) allMediaFiles + in + if null results + then Nothing + else Just $ unlines results + +ooxmlTest :: (WriterOptions -> Pandoc -> PandocIO BL.ByteString) + -> String + -> WriterOptions + -> FilePath + -> FilePath + -> TestTree +ooxmlTest writerFn testName opts nativeFP goldenFP = + goldenTest + testName + (goldenArchive goldenFP) + (testArchive writerFn 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) + (\a -> BL.writeFile goldenFP $ fromArchive a) |