module Text.XML.HXT.RelaxNG.Validation
( validateWithRelax
, validateDocWithRelax
, validateRelax
, validateRelax'
, readForRelax
, normalizeForRelaxValidation
, contains
)
where
import Control.Arrow.ListArrows
import Data.Char.Properties.XMLCharProps (isXmlSpaceChar)
import Data.Maybe (fromJust)
import Text.XML.HXT.DOM.Interface
import qualified Text.XML.HXT.DOM.XmlNode as XN
import Text.XML.HXT.Arrow.Edit (canonicalizeAllNodes,
collapseAllXText)
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.ProcessDocument (getDocumentContents,
parseXmlDocument, propagateAndValidateNamespaces)
import Text.XML.HXT.Arrow.XmlState
import Text.XML.HXT.Arrow.XmlState.TypeDefs
import Text.XML.HXT.RelaxNG.CreatePattern
import Text.XML.HXT.RelaxNG.DataTypeLibraries
import Text.XML.HXT.RelaxNG.DataTypes
import Text.XML.HXT.RelaxNG.PatternToString
import Text.XML.HXT.RelaxNG.Utils (compareURI,
formatStringListQuot)
validateWithRelax :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
validateWithRelax theSchema
= traceMsg 2 "normalize document for validation"
>>>
normalizeForRelaxValidation
>>>
traceMsg 2 "start validation"
>>>
( validateRelax $< theSchema )
normalizeForRelaxValidation :: ArrowXml a => a XmlTree XmlTree
normalizeForRelaxValidation
= processTopDownWithAttrl
(
( none `when`
( isAttr
>>>
getNamespaceUri
>>>
isA (compareURI xmlnsNamespace)
)
)
>>>
(none `when` isPi)
)
>>>
collapseAllXText
validateDocWithRelax :: IOSArrow XmlTree XmlTree -> SysConfigList -> String -> IOSArrow XmlTree XmlTree
validateDocWithRelax theSchema config doc
= localSysEnv
( configSysVars config
>>>
readForRelax doc
>>>
validateWithRelax theSchema
)
validateRelax :: XmlTree -> IOSArrow XmlTree XmlTree
validateRelax rngSchema
= fromLA (validateRelax' rngSchema)
>>>
filterErrorMsg
validateRelax' :: XmlTree -> LA XmlTree XmlTree
validateRelax' rngSchema
= ( ( ( constA rngSchema
>>>
createPatternFromXmlTree
)
&&&
( getChildren
>>>
isElem
)
)
>>>
arr2 (\ !pattern !xmlDoc -> childDeriv ("", []) pattern xmlDoc)
>>>
isA (not . nullable)
>>>
arr ( take 1024
. ("when validating with Relax NG schema: " ++)
. show
)
>>>
mkError c_err
)
`orElse`
this
readForRelax :: String -> IOSArrow b XmlTree
readForRelax schema
= getDocumentContents schema
>>>
parseXmlDocument False True False True
>>>
canonicalizeAllNodes
>>>
propagateAndValidateNamespaces
contains :: NameClass -> QName -> Bool
contains AnyName _ = True
contains (AnyNameExcept nc) n = not (contains nc n)
contains (NsName ns1) qn = ns1 == namespaceUri qn
contains (NsNameExcept ns1 nc) qn = ns1 == namespaceUri qn && not (contains nc qn)
contains (Name ns1 ln1) qn = (ns1 == namespaceUri qn) && (ln1 == localPart qn)
contains (NameClassChoice nc1 nc2) n = (contains nc1 n) || (contains nc2 n)
contains (NCError _) _ = False
nullable:: Pattern -> Bool
nullable (Group p1 p2) = nullable p1 && nullable p2
nullable (Interleave p1 p2) = nullable p1 && nullable p2
nullable (Choice p1 p2) = nullable p1 || nullable p2
nullable (OneOrMore p) = nullable p
nullable (Element _ _) = False
nullable (Attribute _ _) = False
nullable (List _) = False
nullable (Value _ _ _) = False
nullable (Data _ _) = False
nullable (DataExcept _ _ _) = False
nullable (NotAllowed _) = False
nullable Empty = True
nullable Text = True
nullable (After _ _) = False
childDeriv :: Context -> Pattern -> XmlTree -> Pattern
childDeriv cx p t
| XN.isText t = textDerivcx p . fromJust . XN.getText $ t
| XN.isElem t = endTagDeriv p4
| otherwise = notAllowed "Call to childDeriv with wrong arguments"
where
children = XN.getChildren $ t
qn = fromJust . XN.getElemName $ t
atts = fromJust . XN.getAttrl $ t
cx1 = ("",[])
p1 = startTagOpenDeriv p qn
p2 = attsDeriv cx1 p1 atts
p3 = startTagCloseDeriv p2
p4 = childrenDeriv cx1 p3 children
textDeriv :: Context -> Pattern -> String -> Pattern
textDeriv cx (Choice p1 p2) s
= choice (textDeriv cx p1 s) (textDeriv cx p2 s)
textDeriv cx (Interleave p1 p2) s
= choice
(interleave (textDeriv cx p1 s) p2)
(interleave p1 (textDeriv cx p2 s))
textDeriv cx (Group p1 p2) s
= let
p = group (textDeriv cx p1 s) p2
in
if nullable p1
then choice p (textDeriv cx p2 s)
else p
textDeriv cx (After p1 p2) s
= after (textDeriv cx p1 s) p2
textDeriv cx (OneOrMore p) s
= group (textDeriv cx p s) (choice (OneOrMore p) Empty)
textDeriv _ Text _
= Text
textDeriv cx1 (Value (uri, s) value cx2) s1
= case datatypeEqual uri s value cx2 s1 cx1
of
Nothing -> Empty
Just errStr -> notAllowed errStr
textDeriv cx (Data (uri, s) params) s1
= case datatypeAllows uri s params s1 cx
of
Nothing -> Empty
Just errStr -> notAllowed2 errStr
textDeriv cx (DataExcept (uri, s) params p) s1
= case (datatypeAllows uri s params s1 cx)
of
Nothing -> if not $ nullable $ textDeriv cx p s1
then Empty
else notAllowed
( "Any value except " ++
show (show p) ++
" expected, but value " ++
show (show s1) ++
" found"
)
Just errStr -> notAllowed errStr
textDeriv cx (List p) s
= if nullable (listDeriv cx p (words s))
then Empty
else notAllowed
( "List with value(s) " ++
show p ++
" expected, but value(s) " ++
formatStringListQuot (words s) ++
" found"
)
textDeriv _ n@(NotAllowed _) _
= n
textDeriv _ p s
= notAllowed
( "Pattern " ++ show (getPatternName p) ++
" expected, but text " ++ show s ++ " found"
)
listDeriv :: Context -> Pattern -> [String] -> Pattern
listDeriv _ !p []
= p
listDeriv cx !p (x:xs)
= listDeriv cx (textDeriv cx p x) xs
startTagOpenDeriv :: Pattern -> QName -> Pattern
startTagOpenDeriv (Choice p1 p2) qn
= choice (startTagOpenDeriv p1 qn) (startTagOpenDeriv p2 qn)
startTagOpenDeriv (Element nc p) qn
| contains nc qn
= after p Empty
| otherwise
= notAllowed $
"Element with name " ++ nameClassToString nc ++
" expected, but " ++ universalName qn ++ " found"
startTagOpenDeriv (Interleave p1 p2) qn
= choice
(applyAfter (flip interleave p2) (startTagOpenDeriv p1 qn))
(applyAfter (interleave p1) (startTagOpenDeriv p2 qn))
startTagOpenDeriv (OneOrMore p) qn
= applyAfter
(flip group (choice (OneOrMore p) Empty))
(startTagOpenDeriv p qn)
startTagOpenDeriv (Group p1 p2) qn
= let
x = applyAfter (flip group p2) (startTagOpenDeriv p1 qn)
in
if nullable p1
then choice x (startTagOpenDeriv p2 qn)
else x
startTagOpenDeriv (After p1 p2) qn
= applyAfter (flip after p2) (startTagOpenDeriv p1 qn)
startTagOpenDeriv n@(NotAllowed _) _
= n
startTagOpenDeriv p qn
= notAllowed ( show p ++ " expected, but Element " ++ universalName qn ++ " found" )
attsDeriv :: Context -> Pattern -> XmlTrees -> Pattern
attsDeriv _ !p []
= p
attsDeriv cx !p (t : ts)
| XN.isAttr t
= attsDeriv cx (attDeriv cx p t) ts
| otherwise
= notAllowed "Call to attsDeriv with wrong arguments"
attDeriv :: Context -> Pattern -> XmlTree -> Pattern
attDeriv cx (After p1 p2) att
= after (attDeriv cx p1 att) p2
attDeriv cx (Choice p1 p2) att
= choice (attDeriv cx p1 att) (attDeriv cx p2 att)
attDeriv cx (Group p1 p2) att
= choice
(group (attDeriv cx p1 att) p2)
(group p1 (attDeriv cx p2 att))
attDeriv cx (Interleave p1 p2) att
= choice
(interleave (attDeriv cx p1 att) p2)
(interleave p1 (attDeriv cx p2 att))
attDeriv cx (OneOrMore p) att
= group
(attDeriv cx p att)
(choice (OneOrMore p) Empty)
attDeriv cx (Attribute nc p) att
| isa
&&
not (contains nc qn)
= notAllowed1 $
"Attribute with name " ++ nameClassToString nc
++ " expected, but " ++ universalName qn ++ " found"
| isa
&&
( ( nullable p
&&
whitespace val
)
|| nullable p'
)
= Empty
| isa
= err' p'
where
isa = XN.isAttr $ att
qn = fromJust . XN.getAttrName $ att
av = XN.getChildren $ att
val = showXts av
p' = textDeriv cx p val
err' (NotAllowed (ErrMsg _l es))
= err'' (": " ++ head es)
err' _
= err'' ""
err'' e
= notAllowed2 $
"Attribute value \"" ++ val ++
"\" does not match datatype spec " ++ show p ++ e
attDeriv _ n@(NotAllowed _) _
= n
attDeriv _ _p att
= notAllowed $
"No matching pattern for attribute '" ++ showXts [att] ++ "' found"
startTagCloseDeriv :: Pattern -> Pattern
startTagCloseDeriv (After p1 p2)
= after (startTagCloseDeriv p1) p2
startTagCloseDeriv (Choice p1 p2)
= choice
(startTagCloseDeriv p1)
(startTagCloseDeriv p2)
startTagCloseDeriv (Group p1 p2)
= group
(startTagCloseDeriv p1)
(startTagCloseDeriv p2)
startTagCloseDeriv (Interleave p1 p2)
= interleave
(startTagCloseDeriv p1)
(startTagCloseDeriv p2)
startTagCloseDeriv (OneOrMore p)
= oneOrMore (startTagCloseDeriv p)
startTagCloseDeriv (Attribute nc _)
= notAllowed1 $
"Attribut with name, " ++ show nc ++
" expected, but no more attributes found"
startTagCloseDeriv p
= p
childrenDeriv :: Context -> Pattern -> XmlTrees -> Pattern
childrenDeriv _cx p@(NotAllowed _) _
= p
childrenDeriv cx p []
= childrenDeriv cx p [XN.mkText ""]
childrenDeriv cx p [tt]
| ist
&&
whitespace s
= choice p p1
| ist
= p1
where
ist = XN.isText tt
s = fromJust . XN.getText $ tt
p1 = childDeriv cx p tt
childrenDeriv cx p children
= stripChildrenDeriv cx p children
stripChildrenDeriv :: Context -> Pattern -> XmlTrees -> Pattern
stripChildrenDeriv _ !p []
= p
stripChildrenDeriv cx !p (h:t)
= stripChildrenDeriv cx
( if strip h
then p
else (childDeriv cx p h)
) t
endTagDeriv :: Pattern -> Pattern
endTagDeriv (Choice p1 p2)
= choice (endTagDeriv p1) (endTagDeriv p2)
endTagDeriv (After p1 p2)
| nullable p1
= p2
| otherwise
= notAllowed $
show p1 ++ " expected"
endTagDeriv n@(NotAllowed _)
= n
endTagDeriv _
= notAllowed "Call to endTagDeriv with wrong arguments"
applyAfter :: (Pattern -> Pattern) -> Pattern -> Pattern
applyAfter f (After p1 p2) = after p1 (f p2)
applyAfter f (Choice p1 p2) = choice (applyAfter f p1) (applyAfter f p2)
applyAfter _ n@(NotAllowed _) = n
applyAfter _ _ = notAllowed "Call to applyAfter with wrong arguments"
strip :: XmlTree -> Bool
strip = maybe False whitespace . XN.getText
whitespace :: String -> Bool
whitespace = all isXmlSpaceChar
showXts :: XmlTrees -> String
showXts = concat . runLA (xshow $ arrL id)