module Text.XML.HXT.Validator.DocValidation
( validateDoc
)
where
import Text.XML.HXT.DOM.XmlTree
import Text.XML.HXT.Validator.AttributeValueValidation
import Text.XML.HXT.Validator.XmlRE
type ValiEnvTable = [ValiEnv]
type ValiEnv = (ElemName, ValFct)
type ElemName = String
type ValFct = XmlFilter
validateDoc :: XmlTree -> XmlTree -> XmlTrees
validateDoc dtdPart doc
= traverseTree valTable doc
where
valTable = buildAllValidationFunctions dtdPart
traverseTree :: ValiEnvTable -> XmlFilter
traverseTree valiEnv n@(NTree (XTag name _) cs)
= (valFct n) ++ concatMap (traverseTree valiEnv) cs
where
valFct :: XmlFilter
valFct
= case (lookup (qualifiedName name) valiEnv) of
Nothing -> err ("Element " ++ show (qualifiedName name) ++ " not declared in DTD.")
Just f -> f
traverseTree _ _ = []
buildAllValidationFunctions :: XmlTree -> ValiEnvTable
buildAllValidationFunctions dtdPart
= buildValidateRoot dtdPart
:
map (buildValidateFunctions dtdNodes) (isElement $$ dtdNodes)
where
dtdNodes = getChildren dtdPart
buildValidateRoot :: XmlTree -> ValiEnv
buildValidateRoot (NTree (XDTD DOCTYPE al) _)
= (t_root, valFct)
where
name = lookup1 a_name al
valFct :: XmlFilter
valFct nd@(NTree (XTag _ _) cs)
= if msg == ""
then []
else err ("Root Element must be " ++ show name ++ ". " ++ msg) nd
where
re = re_sym (name)
msg = checkRE (matches re cs)
valFct n = error ("buildValidateRoot: illegeal parameter:\n" ++ show n)
buildValidateRoot nd
= error ("buildValidateRoot: illegeal parameter:\n" ++ show nd)
buildValidateFunctions :: XmlTrees -> XmlTree -> ValiEnv
buildValidateFunctions dtdPart nd@(NTree (XDTD ELEMENT al) _)
= (elemName, valFct)
where
elemName = lookup1 a_name al
valFct :: XmlFilter
valFct = buildContentValidation nd
+++
buildAttributeValidation dtdPart nd
buildValidateFunctions _ nd
= error ("buildValidateFunctions: illegeal parameter:\n" ++ show nd)
buildContentValidation :: XmlTree -> XmlFilter
buildContentValidation nd@(NTree (XDTD ELEMENT al) _)
= contentValidation attrType nd
where
attrType = lookup1 a_type al
contentValidation :: String -> XmlTree -> XmlFilter
contentValidation typ (NTree (XDTD ELEMENT _) cs)
| typ == k_pcdata = contentValidationPcdata
| typ == k_empty = contentValidationEmpty
| typ == k_any = contentValidationAny
| typ == v_children = contentValidationChildren cs
| typ == v_mixed = contentValidationMixed cs
| otherwise = error ("contentValidation: unknown type: " ++ show typ)
contentValidation _ nd'
= error ("contentValidation: illegeal parameter:\n" ++ show nd')
contentValidationPcdata :: XmlFilter
contentValidationPcdata n@(NTree (XTag name _) cs)
= if msg == ""
then []
else err ("The content of element "++ show (qualifiedName name) ++
" must match (#PCDATA). "++ msg) n
where
re = re_rep (re_sym k_pcdata)
msg = checkRE (matches re cs)
contentValidationPcdata n
= error ("contentValidationPcdata: illegeal parameter:\n" ++ show n)
contentValidationEmpty :: XmlFilter
contentValidationEmpty n@(NTree (XTag name _) cs)
= if msg == ""
then []
else err ("The content of element " ++ show (qualifiedName name) ++
" must match EMPTY. " ++ msg) n
where
re = re_unit
msg = checkRE (matches re cs)
contentValidationEmpty n
= error ("contentValidationEmpty: illegeal parameter:\n" ++ show n)
contentValidationAny :: XmlFilter
contentValidationAny n@(NTree (XTag name _) cs)
= if msg == ""
then []
else err ("The content of element " ++ show (qualifiedName name) ++
" must match ANY. " ++ msg) n
where
re = re_rep (re_dot)
msg = checkRE (matches re cs)
contentValidationAny n
= error ("contentValidationAny: illegeal parameter:\n" ++ show n)
contentValidationChildren :: XmlTrees -> XmlFilter
contentValidationChildren cm n@(NTree (XTag name _) cs)
= if msg == ""
then []
else err ("The content of element " ++ show (qualifiedName name) ++
" must match " ++ printRE re ++ ". " ++ msg) n
where
re = createRE (head cm)
msg = checkRE (matches re cs)
contentValidationChildren _ n
= error ("contentValidationChildren: illegeal parameter:\n" ++ show n)
contentValidationMixed :: XmlTrees -> XmlFilter
contentValidationMixed cm n@(NTree (XTag name _) cs)
= if msg == ""
then []
else err ("The content of element "++ show (qualifiedName name) ++
" must match " ++ printRE re ++ ". " ++ msg) n
where
re = re_rep (re_alt (re_sym k_pcdata) (createRE (head cm)))
msg = checkRE (matches re cs)
contentValidationMixed _ n
= error ("contentValidationMixed: illegeal parameter:\n" ++ show n)
buildContentValidation nd
= error ("buildContentValidation: illegeal parameter:\n" ++ show nd)
createRE :: XmlTree -> RE String
createRE (NTree (XDTD CONTENT al) cs)
= processModifier modifier
where
modifier = lookup1 a_modifier al
kind = lookup1 a_kind al
processModifier :: String -> RE String
processModifier m
| m == v_plus = re_plus (processKind kind)
| m == v_star = re_rep (processKind kind)
| m == v_option = re_opt (processKind kind)
| m == v_null = processKind kind
| otherwise = error ("Unknown modifier: " ++ show m)
processKind :: String -> RE String
processKind k
| k == v_seq = makeSequence cs
| k == v_choice = makeChoice cs
| otherwise = error ("Unknown kind: " ++ show k)
makeSequence :: XmlTrees -> RE String
makeSequence [] = re_unit
makeSequence (x:xs) = re_seq (createRE x) (makeSequence xs)
makeChoice :: XmlTrees -> RE String
makeChoice [] = re_zero ""
makeChoice (x:xs) = re_alt (createRE x) (makeChoice xs)
createRE (NTree (XDTD NAME al) _)
= re_sym (lookup1 a_name al)
createRE nd
= error ("createRE: illegeal parameter:\n" ++ show nd)
buildAttributeValidation :: XmlTrees -> XmlTree -> XmlFilter
buildAttributeValidation dtdPart nd =
noDoublicateAttributes
+++
checkNotDeclardAttributes attrDecls nd
+++
checkRequiredAttributes attrDecls nd
+++
checkFixedAttributes attrDecls nd
+++
checkValuesOfAttributes attrDecls dtdPart nd
where
attrDecls = isAttlist $$ dtdPart
noDoublicateAttributes :: XmlFilter
noDoublicateAttributes n@(NTree (XTag _ _) _)
= doubles . reverse $ names
where
tagname = nameOf n
names = map nameOf . getAttrl $ n
doubles :: [String] -> XmlTrees
doubles []
= []
doubles (n1:ns)
= ( if n1 `elem` ns
then err ("Attribute " ++ show n1 ++ " was already specified for element " ++ show tagname ++ ".") n
else []
) ++ doubles ns
noDoublicateAttributes n
= error ("noDoublicateAttributes: illegeal parameter:\n" ++ show n)
checkRequiredAttributes :: XmlTrees -> XmlTree -> XmlFilter
checkRequiredAttributes attrDecls (NTree (XDTD ELEMENT al) _)
= checkRequired requiredAtts
where
elemName = lookup1 a_name al
requiredAtts = isRequiredAttrKind $$ (isAttlistOfElement elemName $$ attrDecls)
checkRequired :: XmlTrees -> XmlFilter
checkRequired ((NTree (XDTD ATTLIST al') _):xs) n@(NTree (XTag name _) _)
= if satisfies (hasAttr attName) n
then checkRequired xs n
else err ("Attribute " ++ show attName ++ " must be declared for element type " ++
show (qualifiedName name) ++ ".") n
++
checkRequired xs n
where
attName = lookup1 a_value al'
checkRequired [] _ = []
checkRequired nd n
= error ("checkRequired: illegeal parameter:\n" ++ show nd ++ show n)
checkRequiredAttributes _ nd
= error ("checkRequiredAttributes: illegeal parameter:\n" ++ show nd)
checkFixedAttributes :: XmlTrees -> XmlTree -> XmlFilter
checkFixedAttributes attrDecls (NTree (XDTD ELEMENT al) _)
= checkFixed fixedAtts
where
elemName = lookup1 a_name al
fixedAtts = isFixedAttrKind $$ (isAttlistOfElement elemName $$ attrDecls)
checkFixed :: XmlTrees -> XmlFilter
checkFixed (x@(NTree (XDTD ATTLIST al') _):xs) n@(NTree (XTag name _) _)
= if satisfies (hasAttr attName) n
then if attValue == fixedValue
then checkFixed xs n
else err ("Attribute " ++ show attName ++ " of element " ++ show (qualifiedName name) ++
" with value " ++ show attValue ++ " must have a value of " ++
show fixedValue ++ ".") n
++
checkFixed xs n
else checkFixed xs n
where
attName = lookup1 a_value al'
fixedValue = normalizeAttributeValue (Just x) (lookup1 a_default al')
attValue = normalizeAttributeValue (Just x) (valueOf attName n)
checkFixed [] _ = []
checkFixed nd n
= error ("checkFixed: illegeal parameter:\n" ++ show nd ++ show n)
checkFixedAttributes _ nd
= error ("checkFixedAttributes: illegeal parameter:\n" ++ show nd)
checkNotDeclardAttributes :: XmlTrees -> XmlTree -> XmlFilter
checkNotDeclardAttributes attrDecls elemDescr
= checkNotDeclared
where
elemName = valueOfDTD a_name elemDescr
decls = isAttlistOfElement elemName $$ attrDecls
checkNotDeclared :: XmlFilter
checkNotDeclared n
= ( isXTag
`guards`
cat (map (searchForDeclaredAtt elemName decls) (getAttrl n))
) n
searchForDeclaredAtt :: String -> XmlTrees -> XmlTree -> XmlFilter
searchForDeclaredAtt name ((NTree (XDTD ATTLIST al') _):xs) att
= if (lookup1 a_value al') == nameOf att
then none
else searchForDeclaredAtt name xs att
searchForDeclaredAtt name [] (NTree (XAttr attrName) _)
= err ("Attribute " ++ show (qualifiedName attrName) ++ " of element " ++ show name ++ " is not declared in DTD.")
searchForDeclaredAtt _ nd a
= error ("searchForDeclaredAtt: illegeal paramter:\n" ++ show nd ++ show a)
checkValuesOfAttributes :: XmlTrees -> XmlTrees -> XmlTree -> XmlFilter
checkValuesOfAttributes attrDecls dtdPart elemDescr
= checkValues
where
elemName = valueOfDTD a_name elemDescr
decls = isAttlistOfElement elemName $$ attrDecls
checkValues :: XmlFilter
checkValues n
= ( isXTag
`guards`
cat (map (checkValue decls) (getAttrl n))
) n
checkValue :: XmlTrees -> XmlTree -> XmlFilter
checkValue (attrDecl@(NTree (XDTD ATTLIST al') _):xs) att
= if (lookup1 a_value al') == nameOf att
then checkAttributeValue dtdPart attrDecl
else checkValue xs att
checkValue [] _
= none
checkValue n _
= error ("checkValue: illegeal parameter:\n" ++ show n)