-- ------------------------------------------------------------ {- | Module : Text.XML.HXT.DTDValidation.IdValidation Copyright : Copyright (C) 2008 Uwe Schmidt License : MIT Maintainer : Uwe Schmidt (uwe@fh-wedel.de) Stability : experimental Portability: portable This module provides functions for checking special ID/IDREF/IDREFS constraints. Checking special ID\/IDREF\/IDREFS constraints means: - checking that all ID values are unique. - checking that all IDREF\/IDREFS values match the value of some ID attribute ID-Validation should be started before or after validating the document. First all nodes with ID attributes are collected from the document, then it is validated that values of ID attributes do not occure more than once. During a second iteration over the document it is validated that there exists an ID attribute value for IDREF\/IDREFS attribute values. -} -- ------------------------------------------------------------ module Text.XML.HXT.DTDValidation.IdValidation ( validateIds ) where import Data.Maybe import Text.XML.HXT.DTDValidation.TypeDefs import Text.XML.HXT.DTDValidation.AttributeValueValidation -- ------------------------------------------------------------ -- | -- Lookup-table which maps element names to their validation functions. The -- validation functions are XmlFilters. type IdEnvTable = [IdEnv] type IdEnv = (ElemName, IdFct) type ElemName = String type IdFct = XmlArrow -- ------------------------------------------------------------ -- | -- Perform the validation of the ID/IDREF/IDREFS constraints. -- -- * 1.parameter dtdPart : the DTD subset (Node @DOCTYPE@) of the XmlTree -- -- - 2.parameter doc : the document subset of the XmlTree -- -- - returns : a list of errors validateIds :: XmlTree -> XmlArrow validateIds dtdPart = validateIds' $< listA (traverseTree idEnv) where idAttrTypes = runLA (getChildren >>> isIdAttrType) dtdPart elements = runLA (getChildren >>> isDTDElement) dtdPart atts = runLA (getChildren >>> isDTDAttlist) dtdPart idEnv = buildIdCollectorFcts idAttrTypes validateIds' :: XmlTrees -> XmlArrow validateIds' idNodeList = ( constA idNodeList >>> checkForUniqueIds idAttrTypes ) <+> checkIdReferences idRefEnv where idRefEnv = buildIdrefValidationFcts idAttrTypes elements atts idNodeList -- | -- Traverse the XmlTree in preorder. -- -- * 1.parameter idEnv : lookup-table which maps element names to their validation functions -- -- - returns : list of errors traverseTree :: IdEnvTable -> XmlArrow traverseTree idEnv = multi (isElem `guards` (idFct $< getName)) where idFct :: String -> XmlArrow idFct name = fromMaybe none . lookup name $ idEnv -- | -- Returns the value of an element's ID attribute. The attribute name has to be -- retrieved first from the DTD. -- -- * 1.parameter dtdPart : list of ID attribute definitions from the DTD -- -- - 2.parameter n : element which ID attribute value should be returned -- -- - returns : normalized value of the ID attribute getIdValue :: XmlTrees -> XmlTree -> String getIdValue dns = concat . runLA (single getIdValue') where getIdValue' :: LA XmlTree String getIdValue' = isElem `guards` catA (map getIdVal dns) where getIdVal dn | isDTDAttlistNode dn = hasName elemName `guards` ( getAttrValue0 attrName >>> arr (normalizeAttributeValue (Just dn)) ) | otherwise = none where al = getDTDAttributes dn elemName = dtd_name al attrName = dtd_value al -- ------------------------------------------------------------ -- | -- Build collector functions which return XTag nodes with ID attributes from -- a document. -- -- * 1.parameter dtdPart : the children of the @DOCTYPE@ node -- -- - returns : lookup-table which maps element names to their collector function buildIdCollectorFcts :: XmlTrees -> IdEnvTable buildIdCollectorFcts idAttrTypes = concatMap buildIdCollectorFct idAttrTypes where buildIdCollectorFct :: XmlTree -> [IdEnv] buildIdCollectorFct dn | isDTDAttlistNode dn = [(elemName, hasAttr attrName)] | otherwise = [] where al = getDTDAttributes dn elemName = dtd_name al attrName = dtd_value al -- | -- Build validation functions for checking if IDREF\/IDREFS values match a value -- of some ID attributes. -- -- * 1.parameter dtdPart : the children of the @DOCTYPE@ node -- -- - 2.parameter idNodeList : list of all XTag nodes with ID attributes -- -- - returns : lookup-table which maps element names to their validation function buildIdrefValidationFcts :: XmlTrees -> XmlTrees -> XmlTrees -> XmlTrees -> IdEnvTable buildIdrefValidationFcts idAttrTypes elements atts idNodeList = concatMap buildElemValidationFct elements where idValueList = map (getIdValue idAttrTypes) idNodeList buildElemValidationFct :: XmlTree -> [IdEnv] buildElemValidationFct dn | isDTDElementNode dn = [(elemName, buildIdrefValidationFct idRefAttrTypes)] | otherwise = [] where al = getDTDAttributes dn elemName = dtd_name al idRefAttrTypes = (isAttlistOfElement elemName >>> isIdRefAttrType) $$ atts buildIdrefValidationFct :: XmlTrees -> XmlArrow buildIdrefValidationFct = catA . map buildIdref buildIdref :: XmlTree -> XmlArrow buildIdref dn | isDTDAttlistNode dn = isElem >>> (checkIdref $< getName) | otherwise = none where al = getDTDAttributes dn attrName = dtd_value al attrType = dtd_type al checkIdref :: String -> XmlArrow checkIdref name = hasAttr attrName `guards` ( checkIdVal $< getAttrValue attrName ) where checkIdVal :: String -> XmlArrow checkIdVal av | attrType == k_idref = checkValueDeclared attrValue | null valueList = err ( "Attribute " ++ show attrName ++ " of Element " ++ show name ++ " must have at least one name." ) | otherwise = catA . map checkValueDeclared $ valueList where valueList = words attrValue attrValue = normalizeAttributeValue (Just dn) av checkValueDeclared :: String -> XmlArrow checkValueDeclared attrValue = if attrValue `elem` idValueList then none else err ( "An Element with identifier " ++ show attrValue ++ " must appear in the document." ) -- ------------------------------------------------------------ -- | -- Validate that all ID values are unique within a document. -- Validity constraint: ID (3.3.1 \/p. 25 in Spec) -- -- * 1.parameter idNodeList : list of all XTag nodes with ID attributes -- -- - 2.parameter dtdPart : the children of the @DOCTYPE@ node -- -- - returns : a list of errors checkForUniqueIds :: XmlTrees -> LA XmlTrees XmlTree checkForUniqueIds idAttrTypes -- idNodeList = fromSLA [] ( unlistA >>> isElem >>> (checkForUniqueId $<< getName &&& this) ) where checkForUniqueId :: String -> XmlTree -> SLA [String] XmlTree XmlTree checkForUniqueId name x = ifA ( getState >>> isA (attrValue `elem`) ) (err ( "Attribute value " ++ show attrValue ++ " of type ID for element " ++ show name ++ " must be unique within the document." )) (nextState (attrValue:) >>> none) where attrValue = getIdValue (isAttlistOfElement name $$ idAttrTypes) x -- | -- Validate that all IDREF\/IDREFS values match the value of some ID attribute. -- Validity constraint: IDREF (3.3.1 \/ p.26 in Spec) -- -- * 1.parameter idRefEnv : lookup-table which maps element names to their validation function -- -- - 2.parameter doc : the document to validate -- -- - returns : a list of errors checkIdReferences :: IdEnvTable -> LA XmlTree XmlTree checkIdReferences idRefEnv = traverseTree idRefEnv -- ------------------------------------------------------------