HUnitExample.hs

-- |
-- HUnit - Haskell XML Toolbox examples and tests
--
-- Author: Uwe Schmidt uwe@fh-wedel.de
--
-- Version : $Id: HUnitExample.hs,v 1.8 2005/04/14 12:52:51 hxml Exp $

module Main where

import System
import Test.HUnit
import Text.XML.HXT.Parser
import Data.Char

aMinimalDoc	:: XmlTree
aMinimalDoc	= mkRootTree [] (xtext "<?xml version='1.0'?><x/>")

aSimpleXHTMLDoc	:: XmlTree
aSimpleXHTMLDoc
    = mkRootTree
      ( xattr a_source "simple.xml" )
      ( xtext 
	( concatMap (++ "\n")
	  [ "<?xml version='1.0'?>"
	  , "<html>"
	  , " <head><title>A Simple XHTML Document</title></head>"
	  , " <body>"
	  , " </body>"
	  , "</html>"
	  ]
	)
      )

mkMinimalDoc	:: String -> XmlTree
mkMinimalDoc cont
    = mkRootTree [] (xtext cont)

mkInputDoc	:: String -> XmlTree
mkInputDoc src
    = mkRootTree ( xattr a_source src) []

mkDoc	:: String -> XmlTree
mkDoc cont
    = mkRootTree
      ( xattr a_source "a test")
      ( xtext ("<?xml version='1.0' encoding='" ++ isoLatin1 ++ "'?>\n" ++ cont) )

-- |
-- compare trees

testEqualTrees	:: XmlTrees -> XmlTrees -> Test
testEqualTrees e1 e2
    = TestCase $
      assertEqual "" e1 e2

-- |
-- testDocFilter creates a test for the application of a pure
-- functional filter to a XML tree. The result is converted into
-- the external string representation and compared with the expected
-- result.
--
-- see also: 'testStateFilter' and 'testEditFilter'

testDocFilter	:: String -> XmlFilter -> XmlTree -> Test
testDocFilter expected xfilter doc
    = TestCase $
      assertEqual "" expected (xshow $ xfilter doc)

-- |
-- testStateFilter creates a test for monadic filters, doing IO and using
-- the internal state, consisting of program options and status information
-- The filter is applied to a XML tree, the result is converted to a string
-- and this result is compared with the expected result.
--
-- see also: 'testEditFilter' for pure functional filters

testStateFilter	:: String -> XmlStateFilter () -> XmlTree -> Test
testStateFilter expected xfilter input
    = TestCase $
      do
      res <- run' $ xfilter input
      assertEqual "" expected (xshow res)

-- |
-- The test bed for edit filter for external documents.
-- The input tree must specify the external document to be read.
-- This document is checked for wellformedness, canonicalized
-- (char refs substituted, ...) and processed with the edit filter.
-- The result is transformed into the string representation and compared
-- with the expected string.

testEditFilter	:: String -> XmlFilter -> XmlTree -> Test
testEditFilter expected xfilter input
    = TestCase $
      do
      res <- run'
	     $ ( getWellformedDoc					-- read the document
		 .>>
		 liftMf canonicalizeAllNodes				-- normalize the document and remove <?xml ... ?> decl
		 .>>
		 liftMf ( processChildren xfilter )			-- apply the editing filter only to the 'real' document
		 .>>				  			-- nodes, not to nodes surrounding the document tag
		 putXmlTree						-- just trace output
		 .>>
		 liftMf getChildren					-- just for comparing the document contents
	       )
	     input
      assertEqual "" expected (xshow res)


-- |
-- ausiliary function to make haskell string constants with quotes more readable

singleToDoubleQuote	:: String -> String
singleToDoubleQuote
    = map (\ c -> if c == '\'' then '"' else c)

-- |
-- the complete set of test cases

allTests	:: Test
allTests
    = TestList
      [ constructionTests
      , treeConstructionTests
      , parseTests
      , inputTests
      , removeTests
      , simpleSelectionTests
      , namespaceTests
      ]

-- |
-- tree versus filter construction tests
-- documents may be constructed by tree operations
-- or with the more flexible filter operations applied to an arbitray tree

treeConstructionTests :: Test
treeConstructionTests
    = TestLabel "tree and filter construction tests" $
      TestList $
      map (\ (t, f) -> testEqualTrees t (f undefined) )
      [ (xtext "xyz",				txt "xyz"			)
      , (xcmt "cmt",				cmt "cmt"			)
      , (xtag "img" [] [],			tag "img" [] []			)
      , (xtag "img" [] [],			etag "img"			)

      , (xtag "img" (xattr "b" "13") [],	tag "img" [sattr "b" "13"] []	)

      , (xtag "img" (xattr "b" "13") [],	atag "img" [sattr "b" "13"]	)

      , (xtag "t" (xattr "a" "42" ++ xattr "b" "id")
	          (xtext "abc"),
						tag "t" [sattr "a" "42", sattr "b" "id"]
	 						[txt "abc"]		)
      ]

-- |
-- construction tests are all applied to the empty document,
-- no information is used from that document,
-- but construction is lifted to the filter level.
-- this is more general than explicit construction.
-- in more complex examples some information may be extracted from
-- the source, some can be constant.
-- 
-- see also: 'testDocFilter'

constructionTests	:: Test
constructionTests
    = TestLabel "document construction tests" $
      TestList $
      map (\ (res, f) -> testDocFilter res f undefined)		-- undefined or something else, e.g. emptyRoot
      [ ("<x/>"		, mkXTag  "x" none none	)
      , ("<x/>"		, tag "x"  [] []	)		-- syntactically more comfortable shortcut for mkXTag
      , ("<x/>"		, stag "x" []		)		-- shortcut for tags without attributes
      , ("<x/>"		, atag "x" []		)		-- shortcut for empty tags with attributes
      , ("<x/>"		, etag "x"		)		-- shortcut for empty tags without attributes

      , ("<x a=\"1\"/>"
			, mkXTag "x" (mkXAttr "a" (mkXText "1")) none	)
      , ("<x a=\"1\">42</x>"
			, mkXTag "x" (mkXAttr "a" (mkXText "1")) (mkXText "42")	)
      , ("<x a=\"1\">42</x>"
			, tag "x" [ attr "a" $ txt "1" ] [ txt "42" ]	)
      , ("<x a=\"1\">42</x>"
			, tag "x" [ sattr "a" "1" ] [ txt "42" ]	)

      , ("<x a=\"1\"/>"	, atag "x" [ sattr "a" "1" ]	)

      , ("<x a=\"1\" b=\"2\">42<y/>43</x>"
			, tag "x" [ sattr "a" "1"
				  , sattr "b" "2"
				  ] [ txt  "42"
				    , etag "y"
				    , txt  "43"
				    ]	)
      , ("<!-- a comment -->"
			, mkXCmt $ txt " a comment "	)
      , ("<!--a comment-->"
			, cmt "a comment"	)		-- short cut for uncomputed comment

      , ("<!-- an illegal XML comment containing 2 -- in comment text -->"
			, cmt " an illegal XML comment containing 2 -- in comment text "	)

      , ("&#42;"   	, mkXCharRef 42		)
      , ("&lt;"    	, mkXEntityRef "lt"	)
      , ("<![CDATA[<abc>]]>"
			, mkXCdata $ txt "<abc>")
      , ("<![CDATA[<abc>]]>"			-- short cut for uncomputed cdata content
			, cdata "<abc>")
      , ("<?abc xyz?>"	, mkXPi "abc" $ txt "xyz"	)
      , ("<?abc xyz?>"	, spi "abc" "xyz"	)	-- short cut for an uncomputed pi content
      ]

-- |
-- simple selection tests

simpleSelectionTests	:: Test
simpleSelectionTests
    = TestLabel "simple tree selection tests" $
      TestList $
      map (\ (res, f) -> testDocFilter (singleToDoubleQuote res) f simpleDoc)
      [ (src		, this	)
      , ("1"		, getValue "a"	)
      , (""		, getValue "b"	)
      , (body1		, getChildren	)

				-- text selection
      , ("xyz"		, getChildren .> isXText	)
      , ("xyz"		, getChildren .> isText "xyz"	)
      , (""		, getChildren .> isText "abc"	)
      , ("xyz"		, getChildren .> isOfText (>="x")	)
      , (""		, getChildren .> isOfText (<"x")	)
      , (""		, getChildren .> isWhiteSpace	)

				-- tag selection
      , ("<t a='42' b='id'>abc</t><img b='13'/><y x='0'/><z/>"
			, getChildren .> isXTag	)

				-- comment selection
      , ("<!--cmt-->"	, getChildren .> isXCmt	)

				-- text OR tag selection
      , ("<t a='42' b='id'>abc</t><img b='13'/>xyz<y x='0'/><z/>"
			, getChildren .> (isXTag +++ isXText)	)

				-- generalised OR
      , ("<t a='42' b='id'>abc</t><img b='13'/>xyz<y x='0'/><z/>"
			, getChildren .> cat [isXTag, isXText]	)

      , ("abc"		, getChildren .> getChildren	)

				-- atribute value selection
      , ("1"		, getValue "a"	)

      , ("<t a='42' b='id'>abc</t>"
			, getChildren .> isTag "t"	)

				-- attribute selection
      , ("<t a='42' b='id'>abc</t>"
			, getChildren .> hasAttr "a"	)

      , ("42"		, getChildren .> getValue "a"	)
      , ("42"		, getChildren .> hasValue "a" (all isDigit)	)
      , ("13"		, getChildren .> hasValue "b" (all isDigit)	)
      , (""		, getChildren .> isTag "t" .> hasValue "b" (all isDigit)	)
      , ("42"		, getChildren .> hasValue "a" (== "42")	)
      , (""		, getChildren .> hasValue "a" (== "43")	)
      , ("42"		, getChildren .> hasValue "a" (\ str -> ((read str)::Int) > 40)	)
      , ("42"		, getChildren .> hasValue "a" (not . null)	)
      , ("id13"		, getChildren .> hasValue "b" (const True)	)
      , ("13"		, getChildren .> isTag "img" .> hasValue "b" (const True)	)
      , (""		, getChildren .> hasValue "c" (const True)	)

      , (" a='42' b='id' b='13' x='0'"
			, getChildren .> getAttrl	)

      , (" a='42' b='id'"
			, getChildren .> isTag "t" .> getAttrl	)

      , ("42id"		, getChildren .> isTag "t" .> getAttrl .> getChildren	)

      , (" b='id' b='13'"
			, getChildren .> getAttrl .> isAttr "b"	)

      , (" b='13'"	, getChildren .> isTag "img" .> getAttrl .> isAttr "b"	)
      , ("13"		, getChildren .> isTag "img" .> getAttrl .> isAttr "b" .> getChildren	)
      , ("13"		, getChildren .> isTag "img" .> getValue "b"	)
      , ("timgyz"	, getChildren .> getName	)
      , ("t"		, getChildren .> isTag "t" .> getName	)
      , ("abbx"		, getChildren .> getAttrl  .> getName	)
      , ("bb"		, getChildren .> getAttrl  .> isAttr "b" .> getName	)
      , ("ab"		, getChildren .> isTag "t" .> getAttrl   .> getName	)
      , ("b"		, getChildren .> isTag "t" .> getAttrl   .> isAttr "b" .> getName	)

				-- deep search for text or tags
      , ("abcxyz"       , deep isXText	)
      , ("abc"	        , deep (isTag "t") .> deep isXText	)
      ]
    where
    src = "<r a='1'>" ++ body1 ++ "</r>"
    body1 = "<!--cmt-->"
	    ++ "<t a='42' b='id'>abc</t>"
	    ++ "<img b='13'/>"
	    ++ "xyz"
	    ++ "<y x='0'/>"
	    ++ "<z/>"

    sDocFilter
	= tag "r" [ sattr "a" "1" ]
	    [ cmt "cmt"
	    , tag "t" [ sattr "a" "42", sattr "b" "id" ]
		[ txt "abc"
		]
	    , atag "img" [ sattr "b" "13" ]
	    , txt "xyz"
	    , atag "y" [ sattr "x" "0" ]
	    , etag "z"
	    ]
    simpleDoc = head $ sDocFilter undefined

-- |
-- simple tests with namespaces

namespaceTests	:: Test
namespaceTests
    = TestLabel "namespace tests" $
      TestList $
      map (\ (res, f) -> testDocFilter (singleToDoubleQuote res) f simpleDoc)
      [ (src		, this	)
					-- select all "t" tags, even nested ones (multi) and extract the text from the body
      , ("sssaaa"	, multi (isTag "t"                    .> getChildren .> isXText)	)

					-- select all text within all tags of a specific namespace
      , ("sssaaazzzeee"	, multi (isXTag .> hasNamespace "dns" .> getChildren .> isXText)	)
      , ("bbb"		, multi (isXTag .> hasNamespace "n1"  .> getChildren .> isXText)	)
      , ("cccdddfffggg"	, multi (isXTag .> hasNamespace "n2"  .> getChildren .> isXText)	)

					-- select all text within all tags with a specific local name
      , ("sssaaabbbcccdddzzz"
			, multi (isXTag .> hasLocalPart "t"   .> getChildren .> isXText)	)
      , ("eee"		, multi (isXTag .> hasLocalPart "e"   .> getChildren .> isXText)	)

					-- select all text within all tags with a specific prefix
      , ("bbbddd"	, multi (isXTag .> hasPrefix "x"      .> getChildren .> isXText)	)
      , ("ccc"		, multi (isXTag .> hasPrefix "y"      .> getChildren .> isXText)	)
      , ("zzz"		, multi (isXTag .> hasPrefix "z"      .> getChildren .> isXText)	)
      , ("sssaaaeeefffggg"
			, multi (isXTag .> hasPrefix ""       .> getChildren .> isXText)	)

					-- select all attribute values of a specific namespace
					-- !!! the default namespace is not propagated to attribute names
      , ("z5"		, multi (isXTag .> getAttrl .> hasNamespace "dns"   .> getChildren)	)
      , ("2z4"		, multi (isXTag .> getAttrl .> hasNamespace "n1"    .> getChildren)	)
      , ("x3y3u4"	, multi (isXTag .> getAttrl .> hasNamespace "n2"    .> getChildren)	)
      , ("dnsn2"	, multi (isXTag .> getAttrl .> hasLocalPart "xmlns" .> getChildren)	)

					-- select namespaces from all namespace declarations
      , ("dnsn1n2dnsn2n2"
			, multi (isXTag .> getAttrl .> isNamespaceDecl .> getChildren)	)

					-- all default namespace declarations
      , ("dnsn2"	, multi (isXTag .> getAttrl .> hasLocalPart "xmlns" .> getChildren)	)

					-- all none default namespace declarations
      , ("n1n2dnsn2"	, multi (isXTag .> getAttrl .> hasPrefix "xmlns" .> getChildren)	)
      , ("n1n2"		, multi (isXTag .> getAttrl .> hasPrefix "xmlns" .> hasLocalPart "x" .> getChildren)	)
      , ("n2"		, multi (isXTag .> getAttrl .> hasPrefix "xmlns" .> hasLocalPart "y" .> getChildren)	)
      , ("dns"		, multi (isXTag .> getAttrl .> hasPrefix "xmlns" .> hasLocalPart "z" .> getChildren)	)
      ]
    where
						-- the text representation of the tree
						-- with ' instead of " for readablility of the string constants
    src = "<t xmlns='dns' xmlns:x='n1' xmlns:y='n2' xmlns:z='dns'>"
	  ++ "sss"
	  ++ "<t a='1' x:a='2'>aaa</t>"
	  ++ "<x:t a='x1' y:a='x3'>bbb</x:t>"
	  ++ "<y:t a='y1' y:a='y3'>ccc</y:t>"
	  ++ "<x:t xmlns:x='n2' x:a='u4'>ddd</x:t>"
	  ++ "<z:t x:a='z4' z:a='z5'>zzz</z:t>"
	  ++ "<e b='42'>eee</e>"
	  ++ "<f xmlns='n2'>fff<g>ggg</g></f>" ++
	  "</t>"

						-- the filter for generating the test document
    sDocFilter
	= tag "t" [ sattr "xmlns"   "dns"	-- 4 namespace declarations
		  , sattr "xmlns:x" "n1"
		  , sattr "xmlns:y" "n2"
		  , sattr "xmlns:z" "dns"
		  ]
            [ txt "sss"
	    , tag "t" [ sattr "a"   "1"
		      , sattr "x:a" "2" ]
	        [ txt "aaa"
		]
	    , tag "x:t" [ sattr "a"   "x1"
			, sattr "y:a" "x3"
			]
	        [ txt "bbb"
		]
	    , tag "y:t" [ sattr "a"   "y1"
			, sattr "y:a" "y3"
			]
	        [ txt "ccc"
		]
	    , tag "x:t" [ sattr "xmlns:x" "n2"	-- redefinition of prefix x:
			, sattr "x:a" "u4"
			]
	        [ txt "ddd"
		]
	    , tag "z:t" [ sattr "x:a" "z4"
			, sattr "z:a" "z5"
			]
	        [ txt "zzz"
		]
	    , tag "e" [ sattr "b" "42" ]
                [ txt "eee"
		]
	    , tag "f" [ sattr "xmlns" "n2"	-- redefinition of default namespace
		      ]
                [ txt "fff"
		, tag "g" [ ]
		    [ txt "ggg" ]
		]
	    ]
						-- create document and propagate namespaces
    simpleDoc = head $ (sDocFilter .> propagateNamespaces) undefined

-- |
-- minimal tests for parsing data.
--
-- the tests are document trees with a root
-- node containing a single text node with the document source.
-- That tree is passed to the parser, which substitutes the text node with the parsed xml tree.
-- In general this may be a list of trees containing also the
-- surrounding parts like the xml declaraion, the document type definition
-- possibly comments and processing instructions.
--
-- see also: 'testStateFilter'

parseTests	:: Test
parseTests
    = TestLabel "minimal parser tests" $
      TestList 
      [ testStateFilter "</><x/><//>"	parseXmlDoc				mini	-- the tree inclusive root node
      , testStateFilter "<x/>"	(parseXmlDoc .>> liftMf getChildren)		mini	-- only the content
      , testStateFilter "<x/>"	(parseXmlDoc .>> liftMf getChildren)		min2	-- same content
      , testStateFilter ""	(parseXmlDoc .>> liftMf getChildren)		minErr	-- syntax error: content empty
      , testStateFilter errr	(parseXmlDoc .>> liftMf (getValue a_status))	minErr	-- syntax error reported in a_status
      ]
    where
    errr	= show c_err
    mini	= mkMinimalDoc "<x/>"
    min2	= mkMinimalDoc "<x></x>"
    minErr	= mkMinimalDoc "<x>"


-- |
-- simple external file containing one tag

mini1		:: XmlTree
mini1		= newDocument "mini1.xml"		-- test documents

-- |
-- simple external file containing one tag

mini2		:: XmlTree
mini2		= newDocument "mini2.xml"

-- |
-- simple not existing external file

notThere	:: XmlTree
notThere	= newDocument "notThere.xml"		-- does not exist

-- |
-- These test check the access to external files
-- and error reporting in case of input or parse errors
-- Some test issue tree like trace output of the documents read
-- to show the internal structure and nesting

inputTests	:: Test
inputTests
    = TestLabel "input tests" $
      TestList
      [ testStateFilter "mini1.xml"
	                        ( putXmlTree .>>
				  liftMf (getValue a_source)
				)					mini1
      , testStateFilter ok	( liftMf (getValue a_status)
				)					mini1
      , testStateFilter ""	( liftMf getChildren
				)					mini1
      , testStateFilter "<x/>"	( getXmlContents .>>
				  putXmlTree .>>
				  liftMf getChildren
				)					mini1
      , testStateFilter ok	( getXmlContents .>>
				  liftMf (getValue a_status)
				)					mini1
      , testStateFilter "4"	( getXmlContents .>>
				  liftMf getContentLength .>>
				  putXmlTree .>>
				  liftMf (getValue a_contentLength)
				)					mini1
      , testStateFilter ok	( getXmlContents .>>
				  liftMf (getValue a_status)
				)					mini2
      , testStateFilter ""	( getXmlContents .>>
				  putXmlTree .>>
				  liftMf getChildren
				)					notThere
      , testStateFilter fat	( getXmlContents .>>
				  liftMf (getValue a_status)
				)					notThere
      ]
    where
    ok	= show c_ok
    fat	= show c_fatal

-- |
-- A few tests for removing parts of a document tree.
-- As input tree the document in file mini2.xml is used.

removeTests	:: Test
removeTests
    = TestLabel "document transformation tests" $
      TestList
      [ testEditFilter allText	getAllText				mini2
      , testEditFilter allData  (removeAllWhiteSpace .> getAllText)	mini2
      , testEditFilter allImp	(removeIgnorableData .> getAllText)	mini2
      , testEditFilter allDat	(removeMeta .> getAllText)		mini2
      ]
    where
    getAllText			= deep isXText
    containsUnknownOrIgnore	= getChildren .> ( isText "unknown"
						   +++
						   isText "ignore"
						 )
    removeIgnorableData		= processTopDown ( none
						   `when`
						   ( isTag "data" .> containsUnknownOrIgnore )
						 )
    removeMeta			= processTopDown ( none
						   `when`
						   ( isTag "data" .> hasValue "class" ( == "meta" ) )
						 )
    allText	= " ignore unknown important important "
    allData	= "ignoreunknownimportantimportant"
    allImp	= "   important important "
    allDat	= " ignore  important  "


ys :: XmlTree
ys = head $
     tag "s:Envelope"
     [ sattr "xmlns:s" "http://schemas.xmlsoap.org/soap/envelope/",
       sattr "xmlns:xenc" "http://www.w3.org/2001/04/xmlenc#",
       sattr "xmlns:eg" "http://example.org/paymentv2",
       sattr "xmlns:wsse" "http://schemas.xmlsoap.org/ws/2002/12/secext"
     ]
     [ stag "s:Header"
       [ stag "wsse:Security"
         [ tag "wsse:BinarySecurityToken"
           [ sattr "ValueType" "wsse:Kerberosv5ST",
             sattr "EncodingType" "wsse:Base64Binary"
           ]
           [ txt "QMwcAG ..."
           ]
	 ]
       ],
       stag "s:Body"
       [ stag "eg:OrderCurrency"
         [ stag "eg:Name"
           [ txt "John Smith" ],
	   tag "eg:Amount"
           [ sattr "Currency" "'USD'" ]
	   [ txt "1000" ],
	   tag "eg:CreditCard"
           [ sattr "Limit" "'5000'",
	     sattr "Currency" "'GBP'"
	   ]
	   [ stag "xenc:EncryptedData"
             [ atag "xenc:EncryptionMethod"
               [ sattr "Algorithm" "http://www.w3.org/2001/04/xmlenc#tripledes-cbc" ]
             ],
	     stag "xenc:CipherData"
             [ stag "xenc:CipherValue"
               [ txt "r5KipsDV ..." ]
             ]
	   ]
         ]
       ]
     ]
     .> propagateNamespaces
     .> indentDoc
     $ undefined


main	:: IO ()
main
    = do
      c <- runTestTT allTests
      putStrLn $ show c
      let errs = errors c
	  fails = failures c
      System.exitWith (codeGet errs fails)

codeGet	:: Int -> Int -> ExitCode
codeGet errs fails
    | fails > 0       = ExitFailure 2
    | errs > 0        = ExitFailure 1
    | otherwise       = ExitSuccess

-- ----------------------------------------------------------