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
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
|
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
#if !MIN_VERSION_base(4,6,0)
import Prelude hiding (catch)
#endif
import Control.Exception (catch, SomeException)
import System.Process
import System.Posix.Temp
import System.FilePath
import System.IO
import System.IO.Unsafe
import System.Environment
import System.Exit
import Data.Char (ord, chr)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSLC
import Text.XML.HXT.Core hiding (xshow)
import Text.XML.HXT.DOM.ShowXml (xshow)
import Data.Tree.NTree.TypeDefs
import Data.String
import qualified Data.Text as T
import qualified Test.HUnit as H
import qualified Test.QuickCheck as Q
import Text.XML.Generator
assertEqual_ :: (Eq a, Show a) => FilePath -> Int -> a -> a -> IO ()
assertEqual_ file line x y =
H.assertEqual (file ++ ":" ++ show line ++ ": Expected " ++ show x ++
", given: " ++ show y) x y
#define assertEqual assertEqual_ __FILE__ __LINE__
test :: Renderable r => FilePath -> Xml r -> IO ()
test f x = BSL.writeFile f (xrender x)
_NS_PR1_NS1_ = namespace "foo" "urn:foo"
_NS_PR4_NS1_ = namespace "___foo" "urn:foo"
_NS_PR2_NS2_ = namespace "_foo" "urn:_foo"
_NS_PR3_NS3_ = namespace "__foo" "urn:__foo"
_NS_PR1_NS3_ = namespace "foo" "urn:bar"
testNS :: Namespace
testNS = namespace "foo" "http://www.example.com"
xsample1 :: Xml Elem
xsample1 =
xelemQ _NS_PR3_NS3_ "foo"
(xattrQ _NS_PR2_NS2_ "key" "value" <>
xattrQ _NS_PR2_NS2_ "key2" "value",
xelemQ _NS_PR1_NS1_ "bar" (xattrQ _NS_PR2_NS2_ "key" "value" <#> xtext "BAR") <>
xelemQ _NS_PR1_NS1_ "bar"
(xelemQ _NS_PR1_NS3_ "spam" (xelemEmpty "egg" <> xtext "this is spam!")))
test_1 =
do out <- runXmllint xsample1
exp <- readExpected "1.xml"
assertEqual exp out
xsample2 :: Xml Elem
xsample2 = xelem "foo" $
xattr "key" "value" <>
xattr "key2" "value2" <#>
xelemEmpty "bar" <>
xelem "spam" (xattr "key" "value") <>
xelem "egg" (xtext "ham") <>
xelemQEmpty testNS "bar" <>
xelemQ testNS "spam" (xattrQ testNS "key" "value") <>
xelemQ testNS "egg" (xelemEmpty "ham")
test_2 =
do out <- runXmllint xsample2
exp <- readExpected "2.xml"
assertEqual exp out
xsample3 :: Xml Doc
xsample3 =
doc defaultDocInfo $ xelem "foo" $ xattr "key" "val\"'&<>ue" <#> xtext "<&;'"
test_3 =
do out <- runXmllint xsample3
exp <- readExpected "3.xml"
assertEqual exp out
xsample4 :: Xml Elem
xsample4 =
xelemQ ns "x" (attrs <#>
xelemQ noNamespace "y" (attrs <#> xelemQ ns "z" attrs))
where
attrs = xattrQ ns "a" "in URI" <>
xattrQ noNamespace "b" "in no ns" <>
xattrQ defaultNamespace "c" "in default ns"
ns = namespace "" "http://URI"
test_4 =
do out <- runXmllint xsample4
exp <- readExpected "4.xml"
assertEqual exp out
xsample5 :: Xml Doc
xsample5 =
doc defaultDocInfo $
xelem "people" $
xelems $ map (\(name, age) -> xelem "person" (xattr "age" age <#> xtext name)) people
where
people = [("Stefan", "32"), ("Judith", "4")]
test_5 =
do out <- runXmllint xsample5
exp <- readExpected "5.xml"
assertEqual exp out
xhtmlSample :: Xml Elem
xhtmlSample =
xhtmlRootElem "de" (xelem "head" (xelem "title" "Test") <> xelem "body" (xattr "foo" "1"))
test_xhtml =
do out <- runXmllint xhtmlSample
exp <- readExpected "xhtml.xml"
assertEqual exp out
readExpected name =
readFile ("test" </> name)
`catch` (\(e::SomeException) -> do hPutStrLn stderr (show e)
return "")
runXmllint :: Renderable r => Xml r -> IO String
runXmllint x =
do (name, handle) <- mkstemp "/tmp/xmlgen-test-XXXXXX"
let rx = xrender x
BSL.hPut handle rx
hClose handle
readProcess "xmllint" ["--format", name] ""
prop_textOk (ValidXmlString s) =
let docStr = xelem "root" (xattr "attr" s, xtext s)
docText = xelem "root" (xattr "attr" t, xtext t)
treeListStr = unsafePerformIO $ runX (readString [withWarnings no, withErrors no] (BSLC.unpack $ xrender docStr))
treeListText = unsafePerformIO $ runX (readString [withWarnings no, withErrors no] (BSLC.unpack $ xrender docText))
in treeListStr == treeListText
where
t = s
prop_quotingOk (ValidXmlString s) =
let doc = xelem "root" (xattr "attr" s, xtext s)
treeList = unsafePerformIO $ runX (readString [withWarnings no, withErrors no] (BSLC.unpack $ xrender doc))
root = head treeList
in case childrenOfNTree root of
[NTree root children] ->
let attrValue = case root of
XTag _ [NTree _ attrs] -> xshow attrs
XTag _ [NTree _ [NTree (XText attrValue) _]] -> attrValue
XTag _ [NTree _ []] -> ""
textValue = case children of
elems -> xshow elems
[NTree (XText textValue) _] -> textValue
[] -> ""
in normWsAttr s == T.pack attrValue && normWsElem s == T.pack textValue
l -> error (show root ++ "\n" ++ show l)
where
normWsAttr = T.replace "\r" " " . T.replace "\n" " " . T.replace "\n\r" " "
normWsElem = T.replace "\r" "\n" . T.replace "\n\r" "\b"
childrenOfNTree (NTree _ l) = l
newtype ValidXmlString = ValidXmlString T.Text
deriving (Eq, Show)
instance Q.Arbitrary ValidXmlString where
arbitrary = Q.sized $ \n ->
do k <- Q.choose (0, n)
s <- sequence [validXmlChar | _ <- [1..k] ]
return $ ValidXmlString (T.pack s)
where
validXmlChar =
let l = map chr ([0x9, 0xA, 0xD] ++ [0x20..0xD7FF] ++
[0xE000..0xFFFD] ++ [0x10000..0x10FFFF])
in Q.elements l
qcAsTest :: Q.Testable prop => String -> prop -> H.Test
qcAsTest name prop =
H.TestLabel name (H.TestCase checkProp)
where
checkProp =
do res <- Q.quickCheckResult prop
case res of
Q.Success _ _ _ -> return ()
_ -> H.assertFailure ("QC property " ++ name ++ " failed: "
++ show res)
allTests :: H.Test
allTests = H.TestList [H.TestLabel "test_1" (H.TestCase test_1)
,H.TestLabel "test_2" (H.TestCase test_2)
,H.TestLabel "test_3" (H.TestCase test_3)
,H.TestLabel "test_4" (H.TestCase test_4)
,H.TestLabel "test_5" (H.TestCase test_5)
,H.TestLabel "test_xhtml" (H.TestCase test_xhtml)
,qcAsTest "prop_textOk" prop_textOk
,qcAsTest "prop_quotingOk" prop_quotingOk]
main =
do counts <- H.runTestTT allTests
if H.errors counts > 0 || H.failures counts > 0
then exitWith (ExitFailure 1)
else exitWith ExitSuccess
|
