1{-# LANGUAGE DeriveDataTypeable #-} 2{-# LANGUAGE OverloadedStrings #-} 3 4import Control.Exception (Exception, toException, 5 fromException) 6import Control.Monad.IO.Class (liftIO) 7import qualified Data.ByteString.Char8 as S 8import qualified Data.ByteString.Lazy.Char8 as L 9import Data.Typeable (Typeable) 10import Data.XML.Types 11import Test.Hspec 12import Test.HUnit hiding (Test) 13import qualified Text.XML as Res 14import qualified Text.XML.Cursor as Cu 15import Text.XML.Stream.Parse (def) 16import qualified Text.XML.Stream.Parse as P 17import qualified Text.XML.Unresolved as D 18 19import Control.Monad 20import qualified Data.Set as Set 21import Data.Text (Text) 22import qualified Data.Text as T 23import Text.XML.Cursor (($.//), ($/), ($//), ($|), 24 (&.//), (&/), (&//)) 25 26import qualified Control.Monad.Trans.Resource as C 27import Data.Conduit ((.|), runConduit, 28 runConduitRes, ConduitT) 29import Data.Conduit.Attoparsec (ParseError(..)) 30import qualified Data.Conduit as C 31import qualified Data.Conduit.List as CL 32import qualified Data.Map as Map 33import Text.Blaze (toMarkup) 34import Text.Blaze.Renderer.String (renderMarkup) 35 36main :: IO () 37main = hspec $ do 38 describe "XML parsing and rendering" $ do 39 it "is idempotent to parse and render a document" documentParseRender 40 it "has valid parser combinators" combinators 41 context "has working choose function" testChoose 42 it "has working many function" testMany 43 it "has working many' function" testMany' 44 it "has working manyYield function" testManyYield 45 it "has working takeContent function" testTakeContent 46 it "has working takeTree function" testTakeTree 47 it "has working takeAnyTreeContent function" testTakeAnyTreeContent 48 it "has working orE" testOrE 49 it "is idempotent to parse and pretty render a document" documentParsePrettyRender 50 it "ignores the BOM" parseIgnoreBOM 51 it "strips duplicated attributes" stripDuplicateAttributes 52 it "displays comments" testRenderComments 53 it "conduit parser" testConduitParser 54 it "can omit the XML declaration" omitXMLDeclaration 55 it "doesn't hang on malformed entity declarations" malformedEntityDeclaration 56 context "correctly parses hexadecimal entities" hexEntityParsing 57 describe "XML Cursors" $ do 58 it "has correct parent" cursorParent 59 it "has correct ancestor" cursorAncestor 60 it "has correct orSelf" cursorOrSelf 61 it "has correct preceding" cursorPreceding 62 it "has correct following" cursorFollowing 63 it "has correct precedingSibling" cursorPrecedingSib 64 it "has correct followingSibling" cursorFollowingSib 65 it "has correct descendant" cursorDescendant 66 it "has correct check" cursorCheck 67 it "has correct check with lists" cursorPredicate 68 it "has correct checkNode" cursorCheckNode 69 it "has correct checkElement" cursorCheckElement 70 it "has correct checkName" cursorCheckName 71 it "has correct anyElement" cursorAnyElement 72 it "has correct element" cursorElement 73 it "has correct laxElement" cursorLaxElement 74 it "has correct content" cursorContent 75 it "has correct attribute" cursorAttribute 76 it "has correct laxAttribute" cursorLaxAttribute 77 it "has correct &* and $* operators" cursorDeep 78 it "has correct force" cursorForce 79 it "has correct forceM" cursorForceM 80 it "has correct hasAttribute" cursorHasAttribute 81 it "has correct attributeIs" cursorAttributeIs 82 describe "resolved" $ do 83 it "identifies unresolved entities" resolvedIdentifies 84 it "decodeHtmlEntities" testHtmlEntities 85 it "works for resolvable entities" resolvedAllGood 86 it "merges adjacent content nodes" resolvedMergeContent 87 it "understands inline entity declarations" resolvedInline 88 it "understands complex inline with markup" resolvedInlineComplex 89 it "can expand inline entities recursively" resolvedInlineRecursive 90 it "doesn't explode with an inline entity loop" resolvedInlineLoop 91 it "doesn't explode with the billion laughs attack" billionLaughs 92 it "allows entity expansion size limit to be adjusted" thousandLaughs 93 it "ignores parameter entity declarations" parameterEntity 94 it "doesn't break on [] in doctype comments" doctypeComment 95 it "skips element declarations in doctype" doctypeElements 96 it "skips processing instructions in doctype" doctypePI 97 describe "pretty" $ do 98 it "works" casePretty 99 describe "top level namespaces" $ do 100 it "works" caseTopLevelNamespace 101 it "works with prefix" caseTopLevelNamespacePrefix 102 it "handles conflicts" caseTLNConflict 103 describe "blaze-html instances" $ do 104 it "works" caseBlazeHtml 105 describe "attribute reordering" $ do 106 it "works" caseAttrReorder 107 describe "ordering attributes explicitly" $ do 108 it "works" caseOrderAttrs 109 it "parsing CDATA" caseParseCdata 110 it "retains namespaces when asked" caseRetainNamespaces 111 it "handles iso-8859-1" caseIso8859_1 112 it "renders CDATA when asked" caseRenderCDATA 113 it "escapes CDATA closing tag in CDATA" caseEscapesCDATA 114 115documentParseRender :: IO () 116documentParseRender = 117 mapM_ go docs 118 where 119 go x = x @=? D.parseLBS_ def (D.renderLBS def x) 120 docs = 121 [ Document (Prologue [] Nothing []) 122 (Element "foo" [] []) 123 [] 124 , D.parseLBS_ def 125 "<?xml version=\"1.0\"?><!DOCTYPE foo>\n<foo/>" 126 , D.parseLBS_ def 127 "<?xml version=\"1.0\"?><!DOCTYPE foo>\n<foo><nested>&ignore;</nested></foo>" 128 , D.parseLBS_ def 129 "<foo><![CDATA[this is some<CDATA content>]]></foo>" 130 , D.parseLBS_ def 131 "<foo bar='baz&bin'/>" 132 , D.parseLBS_ def 133 "<foo><?instr this is a processing instruction?></foo>" 134 , D.parseLBS_ def 135 "<foo><!-- this is a comment --></foo>" 136 ] 137 138documentParsePrettyRender :: IO () 139documentParsePrettyRender = 140 L.unpack (D.renderLBS def { D.rsPretty = True } (D.parseLBS_ def doc)) @?= L.unpack doc 141 where 142 doc = L.unlines 143 [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" 144 , "<foo>" 145 , " <?bar bar?>" 146 , " text" 147 , " <?bin bin?>" 148 , "</foo>" 149 ] 150 151combinators :: Assertion 152combinators = runConduitRes $ P.parseLBS def input .| do 153 P.force "need hello" $ P.tag' "hello" (P.requireAttr "world") $ \world -> do 154 liftIO $ world @?= "true" 155 P.force "need child1" $ P.tagNoAttr "{mynamespace}child1" $ return () 156 P.force "need child2" $ P.tagNoAttr "child2" $ return () 157 P.force "need child3" $ P.tagNoAttr "child3" $ do 158 x <- P.contentMaybe 159 liftIO $ x @?= Just "combine <all> &content" 160 where 161 input = L.concat 162 [ "<?xml version='1.0'?>" 163 , "<!DOCTYPE foo []>\n" 164 , "<hello world='true'>" 165 , "<?this should be ignored?>" 166 , "<child1 xmlns='mynamespace'/>" 167 , "<!-- this should be ignored -->" 168 , "<child2> </child2>" 169 , "<child3>combine <all> <![CDATA[&content]]></child3>\n" 170 , "</hello>" 171 ] 172 173testChoose :: Spec 174testChoose = do 175 it "can choose between elements" 176 testChooseEitherElem 177 it "can choose between elements and text, returning text" 178 testChooseElemOrTextIsText 179 it "can choose between elements and text, returning elements" 180 testChooseElemOrTextIsElem 181 it "can choose between text and elements, returning text" 182 testChooseTextOrElemIsText 183 it "can choose between text and elements, returning elements" 184 testChooseTextOrElemIsElem 185 it "can choose between text and elements, when the text is encoded" 186 testChooseElemOrTextIsEncoded 187 it "can choose between text and elements, when the text is encoded, NBSP" 188 testChooseElemOrTextIsEncodedNBSP 189 it "can choose between elements and text, when the text is whitespace" 190 testChooseElemOrTextIsWhiteSpace 191 it "can choose between text and elements, when the text is whitespace" 192 testChooseTextOrElemIsWhiteSpace 193 it "can choose between text and elements, when the whitespace is both literal and encoded" 194 testChooseElemOrTextIsChunkedText 195 it "can choose between text and elements, when the text is chunked the other way" 196 testChooseElemOrTextIsChunkedText2 197 198testChooseElemOrTextIsText :: Assertion 199testChooseElemOrTextIsText = runConduitRes $ P.parseLBS def input .| do 200 P.force "need hello" $ P.tagNoAttr "hello" $ do 201 x <- P.choose 202 [ P.tagNoAttr "failure" $ return "boom" 203 , P.contentMaybe 204 ] 205 liftIO $ x @?= Just " something " 206 where 207 input = L.concat 208 [ "<?xml version='1.0'?>" 209 , "<!DOCTYPE foo []>\n" 210 , "<hello>" 211 , " something " 212 , "</hello>" 213 ] 214 215testChooseElemOrTextIsEncoded :: Assertion 216testChooseElemOrTextIsEncoded = runConduitRes $ P.parseLBS def input .| do 217 P.force "need hello" $ P.tagNoAttr "hello" $ do 218 x <- P.choose 219 [ P.tagNoAttr "failure" $ return "boom" 220 , P.contentMaybe 221 ] 222 liftIO $ x @?= Just "\x20something\x20" 223 where 224 input = L.concat 225 [ "<?xml version='1.0'?>" 226 , "<!DOCTYPE foo []>\n" 227 , "<hello>" 228 , " something " 229 , "</hello>" 230 ] 231 232testChooseElemOrTextIsEncodedNBSP :: Assertion 233testChooseElemOrTextIsEncodedNBSP = runConduitRes $ P.parseLBS def input .| do 234 P.force "need hello" $ P.tagNoAttr "hello" $ do 235 x <- P.choose 236 [ P.tagNoAttr "failure" $ return "boom" 237 , P.contentMaybe 238 ] 239 liftIO $ x @?= Just "\160something\160" 240 where 241 input = L.concat 242 [ "<?xml version='1.0'?>" 243 , "<!DOCTYPE foo []>\n" 244 , "<hello>" 245 , " something " 246 , "</hello>" 247 ] 248 249 250testChooseElemOrTextIsWhiteSpace :: Assertion 251testChooseElemOrTextIsWhiteSpace = runConduitRes $ P.parseLBS def input .| do 252 P.force "need hello" $ P.tagNoAttr "hello" $ do 253 x <- P.choose 254 [ P.tagNoAttr "failure" $ return "boom" 255 , P.contentMaybe 256 ] 257 liftIO $ x @?= Just "\x20\x20\x20" 258 where 259 input = L.concat 260 [ "<?xml version='1.0'?>" 261 , "<!DOCTYPE foo []>\n" 262 , "<hello> </hello>" 263 ] 264 265testChooseTextOrElemIsWhiteSpace :: Assertion 266testChooseTextOrElemIsWhiteSpace = runConduitRes $ P.parseLBS def input .| do 267 P.force "need hello" $ P.tagNoAttr "hello" $ do 268 x <- P.choose 269 [ P.contentMaybe 270 , P.tagNoAttr "failure" $ return "boom" 271 ] 272 liftIO $ x @?= Just "\x20\x20\x20" 273 where 274 input = L.concat 275 [ "<?xml version='1.0'?>" 276 , "<!DOCTYPE foo []>\n" 277 , "<hello> </hello>" 278 ] 279 280testChooseElemOrTextIsChunkedText :: Assertion 281testChooseElemOrTextIsChunkedText = runConduitRes $ P.parseLBS def input .| do 282 P.force "need hello" $ P.tagNoAttr "hello" $ do 283 x <- P.choose 284 [ P.tagNoAttr "failure" $ return "boom" 285 , P.contentMaybe 286 ] 287 liftIO $ x @?= Just "\x20\x20\x20" 288 where 289 input = L.concat 290 [ "<?xml version='1.0'?>" 291 , "<!DOCTYPE foo []>\n" 292 , "<hello>   </hello>" 293 ] 294 295testChooseElemOrTextIsChunkedText2 :: Assertion 296testChooseElemOrTextIsChunkedText2 = runConduitRes $ P.parseLBS def input .| do 297 P.force "need hello" $ P.tagNoAttr "hello" $ do 298 x <- P.choose 299 [ P.tagNoAttr "failure" $ return "boom" 300 , P.contentMaybe 301 ] 302 liftIO $ x @?= Just "\x20\x20\x20" 303 where 304 input = L.concat 305 [ "<?xml version='1.0'?>" 306 , "<!DOCTYPE foo []>\n" 307 , "<hello>   </hello>" 308 ] 309 310testChooseElemOrTextIsElem :: Assertion 311testChooseElemOrTextIsElem = runConduitRes $ P.parseLBS def input .| do 312 P.force "need hello" $ P.tagNoAttr "hello" $ do 313 x <- P.choose 314 [ P.tagNoAttr "success" $ return "success" 315 , P.contentMaybe 316 ] 317 liftIO $ x @?= Just "success" 318 where 319 input = L.concat 320 [ "<?xml version='1.0'?>" 321 , "<!DOCTYPE foo []>\n" 322 , "<hello>" 323 , "<success/>" 324 , "</hello>" 325 ] 326 327testChooseTextOrElemIsText :: Assertion 328testChooseTextOrElemIsText = runConduitRes $ P.parseLBS def input .| do 329 P.force "need hello" $ P.tagNoAttr "hello" $ do 330 x <- P.choose 331 [ P.contentMaybe 332 , P.tagNoAttr "failure" $ return "boom" 333 ] 334 liftIO $ x @?= Just " something " 335 where 336 input = L.concat 337 [ "<?xml version='1.0'?>" 338 , "<!DOCTYPE foo []>\n" 339 , "<hello>" 340 , " something " 341 , "</hello>" 342 ] 343 344testChooseTextOrElemIsElem :: Assertion 345testChooseTextOrElemIsElem = runConduitRes $ P.parseLBS def input .| do 346 P.force "need hello" $ P.tagNoAttr "hello" $ do 347 x <- P.choose 348 [ P.contentMaybe 349 , P.tagNoAttr "success" $ return "success" 350 ] 351 liftIO $ x @?= Just "success" 352 where 353 input = L.concat 354 [ "<?xml version='1.0'?>" 355 , "<!DOCTYPE foo []>\n" 356 , "<hello>" 357 , "<success/>" 358 , "</hello>" 359 ] 360 361testChooseEitherElem :: Assertion 362testChooseEitherElem = runConduitRes $ P.parseLBS def input .| do 363 P.force "need hello" $ P.tagNoAttr "hello" $ do 364 x <- P.choose 365 [ P.tagNoAttr "failure" $ return 1 366 , P.tagNoAttr "success" $ return 2 367 ] 368 liftIO $ x @?= Just (2 :: Int) 369 where 370 input = L.concat 371 [ "<?xml version='1.0'?>" 372 , "<!DOCTYPE foo []>\n" 373 , "<hello>" 374 , "<success/>" 375 , "</hello>" 376 ] 377 378testManyYield :: Assertion 379testManyYield = do 380 -- Basically the same as testMany, but consume the streamed result 381 result <- runConduitRes $ 382 P.parseLBS def input .| helloParser 383 .| CL.consume 384 length result @?= 5 385 where 386 helloParser = void $ P.tagNoAttr "hello" $ P.manyYield successParser 387 successParser = P.tagNoAttr "success" $ return () 388 input = L.concat 389 [ "<?xml version='1.0'?>" 390 , "<!DOCTYPE foo []>\n" 391 , "<hello>" 392 , "<success/>" 393 , "<success/>" 394 , "<success/>" 395 , "<success/>" 396 , "<success/>" 397 , "</hello>" 398 ] 399 400testTakeContent :: Assertion 401testTakeContent = do 402 result <- runConduitRes $ P.parseLBS def input .| rootParser 403 result @?= Just 404 [ EventContent (ContentText "Hello world !") 405 ] 406 where 407 rootParser = P.tagNoAttr "root" $ void (P.takeContent >> P.takeContent) .| CL.consume 408 input = L.concat 409 [ "<?xml version='1.0'?>" 410 , "<!DOCTYPE foo []>\n" 411 , "<root>" 412 , "Hello world !" 413 , "</root>" 414 ] 415 416testTakeTree :: Assertion 417testTakeTree = do 418 result <- runConduitRes $ P.parseLBS def input .| rootParser 419 result @?= 420 [ EventBeginDocument 421 , EventBeginDoctype "foo" Nothing 422 , EventEndDoctype 423 , EventBeginElement "a" [] 424 , EventBeginElement "em" [] 425 , EventContent (ContentText "Hello world !") 426 , EventEndElement "em" 427 , EventEndElement "a" 428 ] 429 where 430 rootParser = void (P.takeTree "a" P.ignoreAttrs) .| CL.consume 431 input = L.concat 432 [ "<?xml version='1.0'?>" 433 , "<!DOCTYPE foo []>\n" 434 , "<a>" 435 , "<em>Hello world !</em>" 436 , "</a>" 437 , "<b>" 438 , "</b>" 439 ] 440 441testTakeAnyTreeContent :: Assertion 442testTakeAnyTreeContent = do 443 result <- runConduitRes $ P.parseLBS def input .| rootParser 444 result @?= Just 445 [ EventBeginElement "b" [] 446 , EventContent (ContentText "Hello ") 447 , EventBeginElement "em" [] 448 , EventContent (ContentText "world") 449 , EventEndElement "em" 450 , EventContent (ContentText " !") 451 , EventEndElement "b" 452 ] 453 where 454 rootParser = P.tagNoAttr "root" $ (P.takeAnyTreeContent >> void P.ignoreAnyTreeContent) .| CL.consume 455 input = L.concat 456 [ "<?xml version='1.0'?>" 457 , "<!DOCTYPE foo []>\n" 458 , "<root>" 459 , "<b>Hello <em>world</em> !</b> Welcome !" 460 , "</root>" 461 ] 462 463 464testMany :: Assertion 465testMany = runConduitRes $ P.parseLBS def input .| do 466 P.force "need hello" $ P.tagNoAttr "hello" $ do 467 x <- P.many $ P.tagNoAttr "success" $ return () 468 liftIO $ length x @?= 5 469 where 470 input = L.concat 471 [ "<?xml version='1.0'?>" 472 , "<!DOCTYPE foo []>\n" 473 , "<hello>" 474 , "<success/>" 475 , "<success/>" 476 , "<success/>" 477 , "<success/>" 478 , "<success/>" 479 , "</hello>" 480 ] 481 482testMany' :: Assertion 483testMany' = runConduitRes $ P.parseLBS def input .| do 484 P.force "need hello" $ P.tagNoAttr "hello" $ do 485 x <- P.many' $ P.tagNoAttr "success" $ return () 486 liftIO $ length x @?= 5 487 where 488 input = L.concat 489 [ "<?xml version='1.0'?>" 490 , "<!DOCTYPE foo []>\n" 491 , "<hello>" 492 , "<success/>" 493 , "<success/>" 494 , "<success/>" 495 , "<foobar/>" 496 , "<success/>" 497 , "<foo><bar attr=\"1\">some content</bar></foo>" 498 , "<success/>" 499 , "</hello>" 500 ] 501 502testOrE :: IO () 503testOrE = runConduitRes $ runConduit $ P.parseLBS def input .| do 504 P.force "need hello" $ P.tagNoAttr "hello" $ do 505 x <- P.tagNoAttr "failure" (return 1) `P.orE` 506 P.tagNoAttr "success" (return 2) 507 y <- P.tag' "success" (P.requireAttr "failure") (const $ return 1) `P.orE` 508 P.tag' "success" (P.requireAttr "success") (const $ return 2) 509 liftIO $ x @?= Just (2 :: Int) 510 liftIO $ y @?= Just (2 :: Int) 511 where 512 input = L.concat 513 [ "<?xml version='1.0'?>" 514 , "<!DOCTYPE foo []>\n" 515 , "<hello>" 516 , "<success/>" 517 , "<success success=\"0\"/>" 518 , "</hello>" 519 ] 520 521testConduitParser :: Assertion 522testConduitParser = do 523 x <- runConduitRes 524 $ P.parseLBS def input 525 .| (P.force "need hello" $ P.tagNoAttr "hello" f) 526 .| CL.consume 527 liftIO $ x @?= [1, 1, 1] 528 where 529 input = L.concat 530 [ "<?xml version='1.0'?>" 531 , "<!DOCTYPE foo []>\n" 532 , "<hello>" 533 , "<item/>" 534 , "<item/>" 535 , "<item/>" 536 , "</hello>" 537 ] 538 f :: C.MonadThrow m => ConduitT Event Int m () 539 f = do 540 ma <- P.tagNoAttr "item" (return 1) 541 maybe (return ()) (\a -> C.yield a >> f) ma 542 543omitXMLDeclaration :: Assertion 544omitXMLDeclaration = Res.renderLBS settings input @?= spec 545 where 546 settings = def { Res.rsXMLDeclaration = False } 547 input = Res.Document (Prologue [] Nothing []) 548 (Res.Element "foo" Map.empty [Res.NodeContent "bar"]) 549 [] 550 spec = "<foo>bar</foo>" 551 552malformedEntityDeclaration :: Assertion 553malformedEntityDeclaration = do -- missing > after bim 554 assertBool "raises ParseError" $ 555 case Res.parseLBS Res.def "<!DOCTYPE foo [<!ENTITY bim \"Hello\"]><foo></foo>" of 556 Left e -> case fromException e of 557 Just (ParseError ["DOCTYPE"] _ _) -> True 558 _ -> False 559 _ -> False 560 561hexEntityParsing :: Spec 562hexEntityParsing = do 563 it "rejects leading 0x" $ 564 go "<foo>�xff;</foo>" @?= Nothing 565 it "rejects leading 0X" $ 566 go "<foo>�Xff;</foo>" @?= Nothing 567 it "accepts lowercase hex digits" $ 568 go "<foo>ÿ</foo>" @?= Just (spec "\xff") 569 it "accepts uppercase hex digits" $ 570 go "<foo>ÿ</foo>" @?= Just (spec "\xff") 571 --Note: this must be rejected, because, according to the XML spec, a 572 --legal EntityRef's entity matches Name, which can't start with a 573 --hash. 574 it "rejects trailing junk" $ 575 go "<foo>ÿhello;</foo>" @?= Nothing 576 --Some of these next tests are XML 1.0 specific (i.e., they would 577 --differ for XML 1.1), but approximately no-one uses XML 1.1. 578 it "rejects illegal character #x0" $ 579 go "<foo>�</foo>" @?= Nothing 580 it "rejects illegal character #xFFFE" $ 581 go "<foo></foo>" @?= Nothing 582 it "rejects illegal character #xFFFF" $ 583 go "<foo></foo>" @?= Nothing 584 it "rejects illegal character #xD900" $ 585 go "<foo>�</foo>" @?= Nothing 586 it "rejects illegal character #xC" $ 587 go "<foo></foo>" @?= Nothing 588 it "rejects illegal character #x1F" $ 589 go "<foo></foo>" @?= Nothing 590 it "accepts astral plane character" $ 591 go "<foo>􀛿</foo>" @?= Just (spec "\x1006ff") 592 it "accepts custom character references" $ 593 go' customSettings "<foo></foo>" @?= Just (spec "\xff") 594 where 595 spec content = Document (Prologue [] Nothing []) 596 (Element "foo" [] [NodeContent (ContentText content)]) 597 [] 598 599 go = either (const Nothing) Just . D.parseLBS def 600 go' settings = either (const Nothing) Just . D.parseLBS settings 601 customSettings = def { P.psDecodeIllegalCharacters = customDecoder } 602 customDecoder 12 = Just '\xff' 603 customDecoder _ = Nothing 604 605name :: [Cu.Cursor] -> [Text] 606name [] = [] 607name (c:cs) = ($ name cs) $ case Cu.node c of 608 Res.NodeElement e -> ((Res.nameLocalName $ Res.elementName e) :) 609 _ -> id 610 611cursor :: Cu.Cursor 612cursor = 613 Cu.fromDocument $ Res.parseLBS_ def input 614 where 615 input = L.concat 616 [ "<foo attr=\"x\">" 617 , "<bar1/>" 618 , "<bar2>" 619 , "<baz1/>" 620 , "<baz2 attr=\"y\"/>" 621 , "<baz3>a</baz3>" 622 , "</bar2>" 623 , "<bar3>" 624 , "<bin1/>" 625 , "b" 626 , "<bin2/>" 627 , "<bin3/>" 628 , "</bar3>" 629 , "<Bar1 xmlns=\"http://example.com\" Attr=\"q\"/>" 630 , "</foo>" 631 ] 632 633bar2, baz2, bar3, bin2 :: Cu.Cursor 634bar2 = Cu.child cursor !! 1 635baz2 = Cu.child bar2 !! 1 636 637bar3 = Cu.child cursor !! 2 638bin2 = Cu.child bar3 !! 1 639 640cursorParent, cursorAncestor, cursorOrSelf, cursorPreceding, cursorFollowing, 641 cursorPrecedingSib, cursorFollowingSib, cursorDescendant, cursorCheck, 642 cursorPredicate, cursorCheckNode, cursorCheckElement, cursorCheckName, 643 cursorAnyElement, cursorElement, cursorLaxElement, cursorContent, 644 cursorAttribute, cursorLaxAttribute, cursorHasAttribute, 645 cursorAttributeIs, cursorDeep, cursorForce, cursorForceM, 646 resolvedIdentifies, resolvedAllGood, resolvedMergeContent, 647 testHtmlEntities 648 :: Assertion 649cursorParent = name (Cu.parent bar2) @?= ["foo"] 650cursorAncestor = name (Cu.ancestor baz2) @?= ["bar2", "foo"] 651cursorOrSelf = name (Cu.orSelf Cu.ancestor baz2) @?= ["baz2", "bar2", "foo"] 652cursorPreceding = do 653 name (Cu.preceding baz2) @?= ["baz1", "bar1"] 654 name (Cu.preceding bin2) @?= ["bin1", "baz3", "baz2", "baz1", "bar2", "bar1"] 655cursorFollowing = do 656 name (Cu.following baz2) @?= ["baz3", "bar3", "bin1", "bin2", "bin3", "Bar1"] 657 name (Cu.following bar2) @?= ["bar3", "bin1", "bin2", "bin3", "Bar1"] 658cursorPrecedingSib = name (Cu.precedingSibling baz2) @?= ["baz1"] 659cursorFollowingSib = name (Cu.followingSibling baz2) @?= ["baz3"] 660cursorDescendant = (name $ Cu.descendant cursor) @?= T.words "bar1 bar2 baz1 baz2 baz3 bar3 bin1 bin2 bin3 Bar1" 661cursorCheck = null (cursor $.// Cu.check (const False)) @?= True 662cursorPredicate = (name $ cursor $.// Cu.check Cu.descendant) @?= T.words "foo bar2 baz3 bar3" 663cursorCheckNode = (name $ cursor $// Cu.checkNode f) @?= T.words "bar1 bar2 bar3" 664 where f (Res.NodeElement e) = "bar" `T.isPrefixOf` Res.nameLocalName (Res.elementName e) 665 f _ = False 666cursorCheckElement = (name $ cursor $// Cu.checkElement f) @?= T.words "bar1 bar2 bar3" 667 where f e = "bar" `T.isPrefixOf` Res.nameLocalName (Res.elementName e) 668cursorCheckName = (name $ cursor $// Cu.checkName f) @?= T.words "bar1 bar2 bar3" 669 where f n = "bar" `T.isPrefixOf` nameLocalName n 670cursorAnyElement = (name $ cursor $// Cu.anyElement) @?= T.words "bar1 bar2 baz1 baz2 baz3 bar3 bin1 bin2 bin3 Bar1" 671cursorElement = (name $ cursor $// Cu.element "bar1") @?= ["bar1"] 672cursorLaxElement = (name $ cursor $// Cu.laxElement "bar1") @?= ["bar1", "Bar1"] 673cursorContent = do 674 Cu.content cursor @?= [] 675 (cursor $.// Cu.content) @?= ["a", "b"] 676cursorAttribute = Cu.attribute "attr" cursor @?= ["x"] 677cursorLaxAttribute = (cursor $.// Cu.laxAttribute "Attr") @?= ["x", "y", "q"] 678 679cursorHasAttribute = (length $ cursor $.// Cu.hasAttribute "attr") @?= 2 680cursorAttributeIs = (length $ cursor $.// Cu.attributeIs "attr" "y") @?= 1 681 682cursorDeep = do 683 (Cu.element "foo" &/ Cu.element "bar2" &// Cu.attribute "attr") cursor @?= ["y"] 684 (return &.// Cu.attribute "attr") cursor @?= ["x", "y"] 685 (cursor $.// Cu.attribute "attr") @?= ["x", "y"] 686 (cursor $/ Cu.element "bar2" &// Cu.attribute "attr") @?= ["y"] 687 (cursor $/ Cu.element "bar2" &/ Cu.element "baz2" >=> Cu.attribute "attr") @?= ["y"] 688 null (cursor $| Cu.element "foo") @?= False 689cursorForce = do 690 Cu.force DummyEx [] @?= (Nothing :: Maybe Integer) 691 Cu.force DummyEx [1] @?= Just (1 :: Int) 692 Cu.force DummyEx [1,2] @?= Just (1 :: Int) 693cursorForceM = do 694 Cu.forceM DummyEx [] @?= (Nothing :: Maybe Integer) 695 Cu.forceM DummyEx [Just 1, Nothing] @?= Just (1 :: Int) 696 Cu.forceM DummyEx [Nothing, Just (1 :: Int)] @?= Nothing 697 698data DummyEx = DummyEx 699 deriving (Show, Typeable) 700instance Exception DummyEx 701 702showEq :: (Show a, Show b) => Either a b -> Either a b -> Assertion 703showEq x y = show x @=? show y 704 705resolvedIdentifies = 706 Left (toException $ Res.UnresolvedEntityException $ Set.fromList ["foo", "bar", "baz"]) `showEq` 707 Res.parseLBS def 708 "<root attr='&bar;'>&foo; --- &baz; &foo;</root>" 709 710testHtmlEntities = 711 Res.parseLBS_ def 712 { P.psDecodeEntities = P.decodeHtmlEntities 713 } xml1 @=? Res.parseLBS_ def xml2 714 where 715 xml1 = "<root> </root>" 716 xml2 = "<root> </root>" 717 718resolvedAllGood = 719 D.parseLBS_ def xml @=? 720 Res.toXMLDocument (Res.parseLBS_ def xml) 721 where 722 xml = "<foo><bar/><baz/></foo>" 723 724resolvedMergeContent = 725 Res.documentRoot (Res.parseLBS_ def xml) @=? 726 Res.Element "foo" Map.empty [Res.NodeContent "bar&baz"] 727 where 728 xml = "<foo>bar&baz</foo>" 729 730parseIgnoreBOM :: Assertion 731parseIgnoreBOM = do 732 either (const $ Left (1 :: Int)) Right (Res.parseText Res.def "\xfeef<foo/>") @?= 733 either (const $ Left (2 :: Int)) Right (Res.parseText Res.def "<foo/>") 734 735stripDuplicateAttributes :: Assertion 736stripDuplicateAttributes = do 737 "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo bar=\"baz\"/>" @=? 738 D.renderLBS def (Document (Prologue [] Nothing []) (Element "foo" [("bar", [ContentText "baz"]), ("bar", [ContentText "bin"])] []) []) 739 "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo x:bar=\"baz\" xmlns:x=\"namespace\"/>" @=? 740 D.renderLBS def (Document (Prologue [] Nothing []) (Element "foo" 741 [ ("x:bar", [ContentText "baz"]) 742 , (Name "bar" (Just "namespace") (Just "x"), [ContentText "bin"]) 743 ] []) []) 744 745testRenderComments :: Assertion 746testRenderComments =do 747 "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo><!--comment--></foo>" 748 @=? D.renderLBS def (Document (Prologue [] Nothing []) 749 (Element "foo" [] [NodeComment "comment"]) []) 750 751resolvedInline :: Assertion 752resolvedInline = do 753 Res.Document _ root _ <- return $ Res.parseLBS_ Res.def "<!DOCTYPE foo [<!ENTITY bar \"baz\">]><foo>&bar;</foo>" 754 root @?= Res.Element "foo" Map.empty [Res.NodeContent "baz"] 755 Res.Document _ root2 _ <- return $ Res.parseLBS_ Res.def "<!DOCTYPE foo [<!ENTITY bar \"baz\">]><foo bar='&bar;'/>" 756 root2 @?= Res.Element "foo" (Map.singleton "bar" "baz") [] 757 758resolvedInlineComplex :: Assertion 759resolvedInlineComplex = do 760 Res.Document _ root _ <- return $ Res.parseLBS_ Res.def "<!DOCTYPE foo [<!ENTITY bar \"<p>baz &bim;</p>\"><!ENTITY bim \"Hello\">]><foo>&bar;</foo>" 761 root @?= Res.Element "foo" Map.empty [Res.NodeElement (Res.Element "p" Map.empty [Res.NodeContent "baz Hello"])] 762 Res.Document _ root2 _ <- return $ Res.parseLBS_ Res.def "<!DOCTYPE foo [<!ENTITY bar \"<p>baz</p>\">]><foo class=\"&bar;\"/>" 763 root2 @?= Res.Element "foo" (Map.fromList [("class","baz")]) [] 764 765 766resolvedInlineRecursive :: Assertion 767resolvedInlineRecursive = do 768 Res.Document _ root _ <- return $ Res.parseLBS_ Res.def 769 "<!DOCTYPE foo [<!ENTITY bim \"baz\"><!ENTITY bar \"&bim;I&\">]><foo>&bar;</foo>" 770 root @?= Res.Element "foo" Map.empty [Res.NodeContent "bazI&"] 771 772resolvedInlineLoop :: Assertion 773resolvedInlineLoop = do 774 res <- return $ Res.parseLBS Res.def 775 "<!DOCTYPE foo [<!ENTITY bim \"&bim;\">]><foo>&bim;</foo>" 776 Left (toException $ Res.UnresolvedEntityException (Set.fromList ["bim"])) 777 `showEq` res 778 res2 <- return $ Res.parseLBS Res.def 779 "<!DOCTYPE foo [<!ENTITY bim \"&bim;\">]><foo class=\"&bim;\"/>" 780 Left (toException $ Res.UnresolvedEntityException (Set.fromList ["bim"])) 781 `showEq` res2 782 783billionLaughs :: Assertion 784billionLaughs = do 785 res <- return $ Res.parseLBS Res.def 786 "<?xml version=\"1.0\"?><!DOCTYPE lolz [<!ENTITY lol \"lol\"><!ELEMENT lolz (#PCDATA)><!ENTITY lol1 \"&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;\"><!ENTITY lol2 \"&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;\"><!ENTITY lol3 \"&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;\"><!ENTITY lol4 \"&lol3;&lol3;&lol3;&lol3;&lol3;&lol3;&lol3;&lol3;&lol3;&lol3;\"><!ENTITY lol5 \"&lol4;&lol4;&lol4;&lol4;&lol4;&lol4;&lol4;&lol4;&lol4;&lol4;\"><!ENTITY lol6 \"&lol5;&lol5;&lol5;&lol5;&lol5;&lol5;&lol5;&lol5;&lol5;&lol5;\"><!ENTITY lol7 \"&lol6;&lol6;&lol6;&lol6;&lol6;&lol6;&lol6;&lol6;&lol6;&lol6;\"><!ENTITY lol8 \"&lol7;&lol7;&lol7;&lol7;&lol7;&lol7;&lol7;&lol7;&lol7;&lol7;\"><!ENTITY lol9 \"&lol8;&lol8;&lol8;&lol8;&lol8;&lol8;&lol8;&lol8;&lol8;&lol8;\">]><lolz>&lol9;</lolz>" 787 Left (toException $ Res.UnresolvedEntityException (Set.fromList ["lol9"])) 788 `showEq` res 789 790thousandLaughs :: Assertion 791thousandLaughs = do 792 res <- return $ Res.parseLBS Res.def{ P.psEntityExpansionSizeLimit = 2999 } 793 "<?xml version=\"1.0\"?><!DOCTYPE lolz [<!ENTITY lol \"lol\"><!ELEMENT lolz (#PCDATA)><!ENTITY lol1 \"&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;\"><!ENTITY lol2 \"&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;\"><!ENTITY lol3 \"&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;\">]><lolz>&lol3;</lolz>" 794 Left (toException $ Res.UnresolvedEntityException (Set.fromList ["lol3"])) 795 `showEq` res 796 -- Raise the entity expansion limit and it should work: 797 Right (Res.Document {Res.documentRoot = Res.Element{ Res.elementNodes = [Res.NodeContent t] }}) <- return $ Res.parseLBS Res.def{ P.psEntityExpansionSizeLimit = 3001 } "<?xml version=\"1.0\"?><!DOCTYPE lolz [<!ENTITY lol \"lol\"><!ELEMENT lolz (#PCDATA)><!ENTITY lol1 \"&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;\"><!ENTITY lol2 \"&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;\"><!ENTITY lol3 \"&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;&lol2;\">]><lolz>&lol3;</lolz>" 798 t @?= T.replicate 1000 "lol" 799 800parameterEntity :: Assertion 801parameterEntity = do 802 let res = Res.parseLBS Res.def "<!DOCTYPE foo [<!ENTITY % bim \"Hello\">]><foo>&bim;</foo>" 803 Left (toException $ Res.UnresolvedEntityException (Set.fromList ["bim"])) 804 `showEq` res 805 806doctypeComment :: Assertion 807doctypeComment = do 808 Res.Document _ root _ <- return $ Res.parseLBS_ 809 Res.def "<!DOCTYPE foo [<!-- [comment] --> <!ENTITY bar \"baz\">]><foo>&bar;</foo>" 810 root @?= Res.Element "foo" Map.empty [Res.NodeContent "baz"] 811 812doctypeElements :: Assertion 813doctypeElements = do 814 Res.Document _ root _ <- return $ Res.parseLBS_ 815 Res.def "<!DOCTYPE foo [<!ELEMENT assessment (#PCDATA)>\n<!ELEMENT textbooks(author,title)>\n<!ATTLIST assessment assessment_type (exam | assignment) #IMPLIED>\n<!ENTITY bar \"baz\">]><foo>&bar;</foo>" 816 root @?= Res.Element "foo" Map.empty [Res.NodeContent "baz"] 817 818doctypePI :: Assertion 819doctypePI = do 820 Res.Document _ root _ <- return $ Res.parseLBS_ 821 Res.def "<!DOCTYPE foo [<?foobar \"[baz]\"?><!ENTITY bar \"baz\">]><foo>&bar;</foo>" 822 root @?= Res.Element "foo" Map.empty [Res.NodeContent "baz"] 823 824casePretty :: Assertion 825casePretty = do 826 let pretty = S.unlines 827 [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" 828 , "<!DOCTYPE foo>" 829 , "<foo bar=\"bar\" baz=\"baz\">" 830 , " <foo" 831 , " bar=\"bar\"" 832 , " baz=\"baz\"" 833 , " bin=\"bin\">" 834 , " Hello World" 835 , " </foo>" 836 , " <foo/>" 837 , " <?foo bar?>" 838 , " <!-- foo bar baz bin -->" 839 , " <bar>" 840 , " bar content" 841 , " </bar>" 842 , "</foo>" 843 ] 844 doctype = Res.Doctype "foo" Nothing 845 doc = Res.Document (Res.Prologue [] (Just doctype) []) root [] 846 root = Res.Element "foo" (Map.fromList [("bar", "bar"), ("baz", "baz")]) 847 [ Res.NodeElement $ Res.Element "foo" (Map.fromList [("bar", "bar"), ("baz", "baz"), ("bin", "bin")]) 848 [ Res.NodeContent " Hello World\n\n" 849 , Res.NodeContent " " 850 ] 851 , Res.NodeElement $ Res.Element "foo" Map.empty [] 852 , Res.NodeInstruction $ Res.Instruction "foo" "bar" 853 , Res.NodeComment "foo bar\n\r\nbaz \tbin " 854 , Res.NodeElement $ Res.Element "bar" Map.empty [Res.NodeContent "bar content"] 855 ] 856 pretty @=? S.concat (L.toChunks $ Res.renderLBS def { D.rsPretty = True } doc) 857 858caseTopLevelNamespace :: Assertion 859caseTopLevelNamespace = do 860 let lbs = S.concat 861 [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" 862 , "<foo xmlns:bar=\"baz\">" 863 , "<subfoo bar:bin=\"\"/>" 864 , "</foo>" 865 ] 866 rs = def { D.rsNamespaces = [("bar", "baz")] } 867 doc = Res.Document (Res.Prologue [] Nothing []) 868 (Res.Element "foo" Map.empty 869 [ Res.NodeElement 870 $ Res.Element "subfoo" (Map.singleton "{baz}bin" "") [] 871 ]) 872 [] 873 lbs @=? S.concat (L.toChunks $ Res.renderLBS rs doc) 874 875caseTopLevelNamespacePrefix :: Assertion 876caseTopLevelNamespacePrefix = do 877 let lbs = S.concat 878 [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" 879 , "<foo xmlns:bar=\"baz\">" 880 , "<subfoo bar:bin=\"\"/>" 881 , "</foo>" 882 ] 883 rs = def { D.rsNamespaces = [("bar", "baz")] } 884 doc = Res.Document (Res.Prologue [] Nothing []) 885 (Res.Element "foo" Map.empty 886 [ Res.NodeElement 887 $ Res.Element "subfoo" (Map.fromList [(Name "bin" (Just "baz") (Just "bar"), "")]) [] 888 ]) 889 [] 890 lbs @=? S.concat (L.toChunks $ Res.renderLBS rs doc) 891 892caseTLNConflict :: Assertion 893caseTLNConflict = do 894 let lbs = S.concat 895 [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" 896 , "<foo xmlns:bar=\"something\" bar:x=\"y\">" 897 , "<subfoo xmlns:bar_=\"baz\" bar_:bin=\"\"/>" 898 , "</foo>" 899 ] 900 rs = def { D.rsNamespaces = [("bar", "baz")] } 901 doc = Res.Document (Res.Prologue [] Nothing []) 902 (Res.Element "foo" (Map.fromList [(Name "x" (Just "something") (Just "bar"), "y")]) 903 [ Res.NodeElement 904 $ Res.Element "subfoo" (Map.fromList [(Name "bin" (Just "baz") (Just "bar"), "")]) [] 905 ]) 906 [] 907 lbs @=? S.concat (L.toChunks $ Res.renderLBS rs doc) 908 909caseBlazeHtml :: Assertion 910caseBlazeHtml = 911 expected @=? str 912 where 913 str = renderMarkup $ toMarkup $ Res.Document (Res.Prologue [] Nothing []) root [] 914 root :: Res.Element 915 root = Res.Element "html" Map.empty 916 [ Res.NodeElement $ Res.Element "head" Map.empty 917 [ Res.NodeElement $ Res.Element "title" Map.empty [Res.NodeContent "Test"] 918 , Res.NodeElement $ Res.Element "script" Map.empty 919 [Res.NodeContent "if (5 < 6 || 8 > 9) alert('Hello World!');"] 920 , Res.NodeElement $ Res.Element "{http://www.snoyman.com/xml2html}ie-cond" (Map.singleton "cond" "lt IE 7") 921 [Res.NodeElement $ Res.Element "link" (Map.singleton "href" "ie6.css") []] 922 , Res.NodeElement $ Res.Element "style" Map.empty 923 [Res.NodeContent "body > h1 { color: red }"] 924 ] 925 , Res.NodeElement $ Res.Element "body" Map.empty 926 [ Res.NodeElement $ Res.Element "h1" Map.empty [Res.NodeContent "Hello World!"] 927 ] 928 ] 929 expected :: String 930 expected = concat 931 [ "<!DOCTYPE HTML>\n" 932 , "<html><head><title>Test</title><script>if (5 < 6 || 8 > 9) alert('Hello World!');</script>" 933 , "<!--[if lt IE 7]><link href=\"ie6.css\" /><![endif]-->" 934 , "<style>body > h1 { color: red }</style>" 935 , "</head>" 936 , "<body><h1>Hello World!</h1></body></html>" 937 ] 938 939caseAttrReorder :: Assertion 940caseAttrReorder = do 941 let lbs = S.concat 942 [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" 943 , "<foo c=\"c\" b=\"b\" a=\"a\">" 944 , "<bar a=\"a\" b=\"b\" c=\"c\"/>" 945 , "</foo>" 946 ] 947 rs = def { Res.rsAttrOrder = \name' m -> 948 case name' of 949 "foo" -> reverse $ Map.toAscList m 950 _ -> Map.toAscList m 951 } 952 attrs = Map.fromList [("a", "a"), ("b", "b"), ("c", "c")] 953 doc = Res.Document (Res.Prologue [] Nothing []) 954 (Res.Element "foo" attrs 955 [ Res.NodeElement 956 $ Res.Element "bar" attrs [] 957 ]) 958 [] 959 lbs @=? S.concat (L.toChunks $ Res.renderLBS rs doc) 960 961caseOrderAttrs :: Assertion 962caseOrderAttrs = do 963 let lbs = S.concat 964 [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" 965 , "<foo c=\"c\" b=\"b\" a=\"a\">" 966 , "<bar a=\"a\" b=\"b\" c=\"c\"/>" 967 , "</foo>" 968 ] 969 rs = def { Res.rsAttrOrder = Res.orderAttrs 970 [("foo", ["c", "b"])] 971 } 972 attrs = Map.fromList [("a", "a"), ("b", "b"), ("c", "c")] 973 doc = Res.Document (Res.Prologue [] Nothing []) 974 (Res.Element "foo" attrs 975 [ Res.NodeElement 976 $ Res.Element "bar" attrs [] 977 ]) 978 [] 979 lbs @=? S.concat (L.toChunks $ Res.renderLBS rs doc) 980 981caseParseCdata :: Assertion 982caseParseCdata = do 983 let lbs = "<a><![CDATA[www.google.com]]></a>" 984 doc = Res.Document (Res.Prologue [] Nothing []) 985 (Res.Element "a" Map.empty 986 [ Res.NodeContent "www.google.com" 987 ]) 988 [] 989 Res.parseLBS_ def lbs @?= doc 990 991caseRetainNamespaces :: Assertion 992caseRetainNamespaces = do 993 let lbs = "<foo xmlns:bar='baz'><bar:bin/><bin3 xmlns='bin4'></bin3></foo>" 994 doc = Res.parseLBS_ def { Res.psRetainNamespaces = True } lbs 995 doc `shouldBe` Res.Document 996 (Res.Prologue [] Nothing []) 997 (Res.Element 998 "foo" 999 (Map.singleton "xmlns:bar" "baz") 1000 [ Res.NodeElement $ Res.Element 1001 "{baz}bin" 1002 Map.empty 1003 [] 1004 , Res.NodeElement $ Res.Element 1005 "{bin4}bin3" 1006 (Map.singleton "xmlns" "bin4") 1007 [] 1008 ]) 1009 [] 1010 1011caseIso8859_1 :: Assertion 1012caseIso8859_1 = do 1013 let lbs = "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><foo>\232</foo>" 1014 doc = Res.parseLBS_ def lbs 1015 doc `shouldBe` Res.Document 1016 (Res.Prologue [] Nothing []) 1017 (Res.Element 1018 "foo" 1019 Map.empty 1020 [Res.NodeContent "\232"]) 1021 [] 1022 1023caseRenderCDATA :: Assertion 1024caseRenderCDATA = do 1025 let doc = Res.Document (Res.Prologue [] Nothing []) 1026 (Res.Element "a" Map.empty 1027 [ Res.NodeContent "www.google.com" 1028 ]) 1029 [] 1030 withoutCDATA = Res.renderLBS def doc 1031 withCDATA = Res.renderLBS (def { Res.rsUseCDATA = const True }) doc 1032 withCDATA `shouldBe` "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a><![CDATA[www.google.com]]></a>" 1033 withoutCDATA `shouldBe` "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a>www.google.com</a>" 1034 1035caseEscapesCDATA :: Assertion 1036caseEscapesCDATA = do 1037 let doc = Res.Document (Res.Prologue [] Nothing []) 1038 (Res.Element "a" Map.empty 1039 [ Res.NodeContent "]]>" 1040 ]) 1041 [] 1042 result = Res.renderLBS (def { Res.rsUseCDATA = const True }) doc 1043 result `shouldBe` "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a><![CDATA[]]]]><![CDATA[>]]></a>" 1044