hxt-8.5.4: src/Text/XML/HXT/DTDValidation/DTDValidation.hs
-- ------------------------------------------------------------
{- |
Module : Text.XML.HXT.DTDValidation.TypeDefs
Copyright : Copyright (C) 2008 Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
Stability : experimental
Portability: portable
This module provides functions for validating the DTD of XML documents
represented as XmlTree.
Unlike other popular XML validation tools the validation process returns
a list of errors instead of aborting after the first error was found.
Unlike validation of the document, the DTD branch is traversed four times:
- Validation of Notations
- Validation of Unparsed Entities
- Validation of Element declarations
- Validation of Attribute declarations
-}
-- ------------------------------------------------------------
module Text.XML.HXT.DTDValidation.DTDValidation
( removeDoublicateDefs
, validateDTD
)
where
import Text.XML.HXT.DTDValidation.TypeDefs
import Text.XML.HXT.DTDValidation.AttributeValueValidation
-- |
-- Validate a DTD.
--
-- - returns : a functions which takes the DTD subset of the XmlTree, checks
-- if the DTD is valid and returns a list of errors
validateDTD :: XmlArrow
validateDTD -- dtdPart
= isDTDDoctype
`guards`
( listA getChildren
>>>
( validateParts $<< (getNotationNames &&& getElemNames) )
)
where
validateParts notationNames elemNames
= validateNotations
<+>
validateEntities notationNames
<+>
validateElements elemNames
<+>
validateAttributes elemNames notationNames
getNotationNames :: LA [XmlTree] [String]
getNotationNames = listA $ unlistA >>> isDTDNotation >>> getDTDAttrValue a_name
getElemNames :: LA [XmlTree] [String]
getElemNames = listA $ unlistA >>> isDTDElement >>> getDTDAttrValue a_name
-- ------------------------------------------------------------
checkName :: String -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
checkName name msg
= ifA ( getState
>>>
isA (name `elem`)
)
msg
(nextState (name:) >>> none)
-- ------------------------------------------------------------
-- |
-- Validation of Notations, checks if all notation names are unique.
-- Validity constraint: Unique Notation Name (4.7 \/ p.44 in Spec)
--
-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
--
-- - returns : a list of errors
validateNotations :: LA XmlTrees XmlTree
validateNotations
= fromSLA [] ( unlistA
>>>
isDTDNotation
>>>
(checkForUniqueNotation $< getDTDAttrl)
)
where
checkForUniqueNotation :: Attributes -> SLA [String] XmlTree XmlTree
checkForUniqueNotation al
= checkName name $
err ( "Notation "++ show name ++ " was already specified." )
where
name = dtd_name al
-- |
-- Validation of Entities.
--
-- 1. Issues a warning if entities are declared multiple times.
--
-- Optional warning: (4.2 \/ p.35 in Spec)
--
--
-- 2. Validates that a notation is declared for an unparsed entity.
--
-- Validity constraint: Notation Declared (4.2.2 \/ p.36 in Spec)
--
-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
--
-- - 2.parameter notationNames : list of all notation names declared in the DTD
--
-- - returns : a list of errors
validateEntities :: [String] -> LA XmlTrees XmlTree
validateEntities notationNames
= ( fromSLA [] ( unlistA
>>>
isDTDEntity
>>>
(checkForUniqueEntity $< getDTDAttrl)
)
)
<+>
( unlistA
>>>
isUnparsedEntity
>>>
(checkNotationDecl $< getDTDAttrl)
)
where
-- Check if entities are declared multiple times
checkForUniqueEntity :: Attributes -> SLA [String] XmlTree XmlTree
checkForUniqueEntity al
= checkName name $
warn ( "Entity "++ show name ++ " was already specified. " ++
"First declaration will be used." )
where
name = dtd_name al
-- Find unparsed entities for which no notation is specified
checkNotationDecl :: Attributes -> XmlArrow
checkNotationDecl al
| notationName `elem` notationNames
= none
| otherwise
= err ( "The notation " ++ show notationName ++ " must be declared " ++
"when referenced in the unparsed entity declaration for " ++
show upEntityName ++ "."
)
where
notationName = lookup1 k_ndata al
upEntityName = dtd_name al
-- |
-- Validation of Element declarations.
--
-- 1. Validates that an element is not declared multiple times.
--
-- Validity constraint: Unique Element Type Declaration (3.2 \/ p.21 in Spec)
--
--
-- 2. Validates that an element name only appears once in a mixed-content declaration.
--
-- Validity constraint: No Duplicate Types (3.2 \/ p.21 in Spec)
--
--
-- 3. Issues a warning if an element mentioned in a content model is not declared in the
-- DTD.
--
-- Optional warning: (3.2 \/ p.21 in Spec)
--
-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
--
-- - 2.parameter elemNames : list of all element names declared in the DTD
--
-- - returns : a list of errors
validateElements :: [String] -> LA XmlTrees XmlTree
validateElements elemNames -- dtdPart
= ( fromSLA [] ( unlistA
>>>
isDTDElement
>>>
(checkForUniqueElement $< getDTDAttrl)
)
)
<+>
( unlistA
>>>
isMixedContentElement
>>>
(checkMixedContent $< getDTDAttrl)
)
<+>
( unlistA
>>>
isDTDElement
>>>
(checkContentModel elemNames $< getDTDAttrl)
)
where
-- Validates that an element is not declared multiple times
checkForUniqueElement :: Attributes -> SLA [String] XmlTree XmlTree
checkForUniqueElement al
= checkName name $
err ( "Element type " ++ show name ++
" must not be declared more than once." )
where
name = dtd_name al
-- Validates that an element name only appears once in a mixed-content declaration
checkMixedContent :: Attributes -> XmlArrow
checkMixedContent al
= fromSLA [] ( getChildren
>>>
getChildren
>>>
isDTDName
>>>
(check $< getDTDAttrl)
)
where
elemName = dtd_name al
check al'
= checkName name $
err ( "The element type " ++ show name ++
" was already specified in the mixed-content model of the element declaration " ++
show elemName ++ "." )
where
name = dtd_name al'
-- Issues a warning if an element mentioned in a content model is not
-- declared in the DTD.
checkContentModel :: [String] -> Attributes -> XmlArrow
checkContentModel names al
| cm `elem` [v_children, v_mixed]
= getChildren >>> checkContent
| otherwise
= none
where
elemName = dtd_name al
cm = dtd_type al
checkContent :: XmlArrow
checkContent
= choiceA
[ isDTDName :-> ( checkName' $< getDTDAttrl )
, isDTDContent :-> ( getChildren >>> checkContent )
, this :-> none
]
where
checkName' al'
| childElemName `elem` names
= none
| otherwise
= warn ( "The element type "++ show childElemName ++
", used in content model of element "++ show elemName ++
", is not declared."
)
where
childElemName = dtd_name al'
-- |
-- Validation of Attribute declarations.
--
-- (1) Issues a warning if an attribute is declared for an element type not itself
-- decared.
--
-- Optinal warning: (3.3 \/ p. 24 in Spec)
--
--
-- 2. Issues a warning if more than one definition is provided for the same
-- attribute of a given element type. Fist declaration is binding, later
-- definitions are ignored.
--
-- Optional warning: (3.3 \/ p.24 in Spec)
--
--
-- 3. Issues a warning if the same Nmtoken occures more than once in enumerated
-- attribute types of a single element type.
--
-- Optional warning: (3.3.1 \/ p.27 in Spec)
--
--
-- 4. Validates that an element type has not more than one ID attribute defined.
--
-- Validity constraint: One ID per Element Type (3.3.1 \/ p.26 in Spec)
--
--
-- 5. Validates that an element type has not more than one NOTATION attribute defined.
--
-- Validity constraint: One Notation per Element Type (3.3.1 \/ p.27 in Spec)
--
--
-- 6. Validates that an ID attributes has the type #IMPLIED or #REQUIRED.
--
-- Validity constraint: ID Attribute Default (3.3.1 \/ p.26 in Spec)
--
--
-- 7. Validates that all referenced notations are declared.
--
-- Validity constraint: Notation Attributes (3.3.1 \/ p.27 in Spec)
--
--
-- 8. Validates that notations are not declared for EMPTY elements.
--
-- Validity constraint: No Notation on Empty Element (3.3.1 \/p.27 in Spec)
--
--
-- 9. Validates that the default value matches the lexical constraints of it's type.
--
-- Validity constraint: Attribute default legal (3.3.2 \/ p.28 in Spec)
--
--
-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
--
-- - 2.parameter elemNames : list of all element names declared in the DTD
--
-- - 3.parameter notationNames : list of all notation names declared in the DTD
--
-- - returns : a list of errors
validateAttributes :: [String] -> [String] -> LA XmlTrees XmlTree
validateAttributes elemNames notationNames
= -- 1. Find attributes for which no elements are declared
( runCheck this (checkDeclaredElements elemNames) )
<+>
-- 2. Find attributes which are declared more than once
( runNameCheck this checkForUniqueAttributeDeclaration )
<+>
-- 3. Find enumerated attribute types which nmtokens are declared more than once
( runCheck (isEnumAttrType `orElse` isNotationAttrType) checkEnumeratedTypes )
<+>
-- 4. Validate that there exists only one ID attribute for an element
( runNameCheck isIdAttrType checkForUniqueId )
<+>
-- 5. Validate that there exists only one NOTATION attribute for an element
( runNameCheck isNotationAttrType checkForUniqueNotation )
<+>
-- 6. Validate that ID attributes have the type #IMPLIED or #REQUIRED
( runCheck isIdAttrType checkIdKindConstraint )
<+>
-- 7. Validate that all referenced notations are declared
( runCheck isNotationAttrType (checkNotationDeclaration notationNames) )
<+>
-- 8. Validate that notations are not declared for EMPTY elements
( checkNoNotationForEmptyElements $< listA ( unlistA
>>>
isEmptyElement
>>>
getDTDAttrValue a_name
)
)
<+>
-- 9. Validate that the default value matches the lexical constraints of it's type
( checkDefaultValueTypes $< this )
where
-- ------------------------------------------------------------
-- control structures
runCheck select check
= unlistA >>> isDTDAttlist
>>>
select
>>>
(check $< getDTDAttrl)
runNameCheck select check
= fromSLA [] $ runCheck select check
--------------------------------------------------------------------------
-- 1. Find attributes for which no elements are declared
checkDeclaredElements :: [String] -> Attributes -> XmlArrow
checkDeclaredElements elemNames' al
| en `elem` elemNames'
= none
| otherwise
= warn ( "The element type \""++ en ++ "\" used in dclaration "++
"of attribute \""++ an ++"\" is not declared."
)
where
en = dtd_name al
an = dtd_value al
--------------------------------------------------------------------------
-- 2. Find attributes which are declared more than once
checkForUniqueAttributeDeclaration :: Attributes -> SLA [String] XmlTree XmlTree
checkForUniqueAttributeDeclaration al
= checkName name $
warn ( "Attribute \""++ aname ++"\" for element type \""++
ename ++"\" is already declared. First "++
"declaration will be used." )
where
ename = dtd_name al
aname = dtd_value al
name = ename ++ "|" ++ aname
--------------------------------------------------------------------------
-- 3. Find enumerated attribute types which nmtokens are declared more than once
checkEnumeratedTypes :: Attributes -> XmlArrow
checkEnumeratedTypes al
= fromSLA [] ( getChildren
>>>
isDTDName
>>>
(checkForUniqueType $< getDTDAttrl)
)
where
checkForUniqueType :: Attributes -> SLA [String] XmlTree XmlTree
checkForUniqueType al'
= checkName nmtoken $
warn ( "Nmtoken \""++ nmtoken ++"\" should not "++
"occur more than once in attribute \""++ dtd_value al ++
"\" for element \""++ dtd_name al ++ "\"." )
where
nmtoken = dtd_name al'
--------------------------------------------------------------------------
-- 4. Validate that there exists only one ID attribute for an element
checkForUniqueId :: Attributes -> SLA [String] XmlTree XmlTree
checkForUniqueId al
= checkName ename $
err ( "Element \""++ ename ++ "\" already has attribute of type "++
"ID, another attribute \""++ dtd_value al ++ "\" of type ID is "++
"not permitted." )
where
ename = dtd_name al
--------------------------------------------------------------------------
-- 5. Validate that there exists only one NOTATION attribute for an element
checkForUniqueNotation :: Attributes -> SLA [String] XmlTree XmlTree
checkForUniqueNotation al
= checkName ename $
err ( "Element \""++ ename ++ "\" already has attribute of type "++
"NOTATION, another attribute \""++ dtd_value al ++ "\" of type NOTATION "++
"is not permitted." )
where
ename = dtd_name al
--------------------------------------------------------------------------
-- 6. Validate that ID attributes have the type #IMPLIED or #REQUIRED
checkIdKindConstraint :: Attributes -> XmlArrow
checkIdKindConstraint al
| attKind `elem` [k_implied, k_required]
= none
| otherwise
= err ( "ID attribute \""++ dtd_value al ++"\" must have a declared default "++
"of \"#IMPLIED\" or \"REQUIRED\"")
where
attKind = dtd_kind al
--------------------------------------------------------------------------
-- 7. Validate that all referenced notations are declared
checkNotationDeclaration :: [String] -> Attributes -> XmlArrow
checkNotationDeclaration notations al
= getChildren
>>>
isDTDName
>>>
(checkNotations $< getDTDAttrl)
where
checkNotations :: Attributes -> XmlArrow
checkNotations al'
| notation `elem` notations
= none
| otherwise
= err ( "The notation \""++ notation ++"\" must be declared when "++
"referenced in the notation type list for attribute \""++ dtd_value al ++
"\" of element \""++ dtd_name al ++"\"."
)
where
notation = dtd_name al'
--------------------------------------------------------------------------
-- 8. Validate that notations are not declared for EMPTY elements
checkNoNotationForEmptyElements :: [String] -> LA XmlTrees XmlTree
checkNoNotationForEmptyElements emptyElems
= unlistA
>>>
isDTDAttlist
>>>
isNotationAttrType
>>>
(checkNoNotationForEmptyElement $< getDTDAttrl)
where
checkNoNotationForEmptyElement :: Attributes -> XmlArrow
checkNoNotationForEmptyElement al
| ename `elem` emptyElems
= err ( "Attribute \""++ dtd_value al ++"\" of type NOTATION must not be "++
"declared on the element \""++ ename ++"\" declared EMPTY."
)
| otherwise
= none
where
ename = dtd_name al
--------------------------------------------------------------------------
-- 9. Validate that default values meet the lexical constraints of the attribute types
checkDefaultValueTypes :: XmlTrees -> LA XmlTrees XmlTree
checkDefaultValueTypes dtdPart'
= unlistA >>> isDTDAttlist
>>>
isDefaultAttrKind
>>>
(checkAttributeValue dtdPart' $< this)
-- ------------------------------------------------------------
-- |
-- Removes doublicate declarations from the DTD, which first declaration is
-- binding. This is the case for ATTLIST and ENTITY declarations.
--
-- - returns : A function that replaces the children of DOCTYPE nodes by a list
-- where all multiple declarations are removed.
removeDoublicateDefs :: XmlArrow
removeDoublicateDefs
= replaceChildren
( fromSLA [] ( getChildren
>>>
choiceA [ isDTDAttlist :-> (removeDoubleAttlist $< getDTDAttrl)
, isDTDEntity :-> (removeDoubleEntity $< getDTDAttrl)
, this :-> this
]
)
)
`when`
isDTDDoctype
where
checkName' n'
= ifA ( getState
>>>
isA (n' `elem`)
)
none
(this >>> perform (nextState (n':)))
removeDoubleAttlist :: Attributes -> SLA [String] XmlTree XmlTree
removeDoubleAttlist al
= checkName' elemAttr
where
elemAttr = elemName ++ "|" ++ attrName
attrName = dtd_value al
elemName = dtd_name al
removeDoubleEntity :: Attributes -> SLA [String] XmlTree XmlTree
removeDoubleEntity al
= checkName' (dtd_name al)
-- ------------------------------------------------------------