1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
|
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
module Tests.Writers.OOXML (ooxmlTest) where
import Prelude
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)
|
