module Text.XML.HXT.Validator.AttributeValueValidation
( checkAttributeValue
, normalizeAttributeValue
)
where
import Text.XML.HXT.Parser.XmlParser
( parseNMToken
, parseName
)
import Text.XML.HXT.DOM.XmlTree
import Text.XML.HXT.DOM.Util
checkAttributeValue :: XmlTrees -> XmlTree -> XmlFilter
checkAttributeValue dtdPart attrDecl@(NTree (XDTD ATTLIST al) _) n@(NTree (XTag _ _al') _)
= checkValue attrType dtdPart normalizedVal attrDecl n
where
attrType = lookup1 a_type al
attrValue = valueOf (getAttrName al) n
normalizedVal = normalizeAttributeValue (Just attrDecl) attrValue
checkAttributeValue dtdPart attrDecl@(NTree (XDTD ATTLIST al) _) n@(NTree (XDTD ATTLIST al') _)
= checkValue attrType dtdPart normalizedVal attrDecl n
where
attrType = lookup1 a_type al
attrValue = lookup1 a_default al'
normalizedVal = normalizeAttributeValue (Just attrDecl) attrValue
checkAttributeValue _ nd n
= error ("checkAttributeValue: illegeal parameter:\n" ++ show nd ++ show n)
checkValue :: String -> XmlTrees -> String -> XmlTree -> XmlFilter
checkValue typ dtdPart attrValue attrDecl
| typ == k_cdata = none
| typ == k_enumeration = checkValueEnumeration attrDecl attrValue
| typ == k_entity = checkValueEntity dtdPart attrDecl attrValue
| typ == k_entities = checkValueEntities dtdPart attrDecl attrValue
| typ == k_id = checkValueId attrDecl attrValue
| typ == k_idref = checkValueIdref attrDecl attrValue
| typ == k_idrefs = checkValueIdrefs attrDecl attrValue
| typ == k_nmtoken = checkValueNmtoken attrDecl attrValue
| typ == k_nmtokens = checkValueNmtokens attrDecl attrValue
| typ == k_notation = checkValueEnumeration attrDecl attrValue
| otherwise = error ("Attribute type " ++ show typ ++ " unknown.")
checkValueEnumeration :: XmlTree -> String -> XmlFilter
checkValueEnumeration (NTree (XDTD ATTLIST al) cs) attrValue
= if attrValue `elem` enumVals
then none
else err ("Attribute " ++ show (getAttrName al) ++ " for element " ++ show (getElemName al) ++
" must have a value from list "++ show enumVals ++ ".")
where
enumVals :: [String]
enumVals = map (getEnumVal) cs
getEnumVal :: XmlTree -> String
getEnumVal (NTree (XDTD NAME al') _) = lookup1 a_name al'
getEnumVal _ = ""
checkValueEnumeration n _
= error ("checkValueEnumeration: illegeal parameter:\n" ++ show n)
checkValueEntity :: XmlTrees -> XmlTree -> String -> XmlFilter
checkValueEntity dtdPart (NTree (XDTD ATTLIST al) _) attrValue
= if attrValue `elem` upEntities
then none
else err ("Entity " ++ show attrValue ++ " of attribute " ++ show (getAttrName al) ++
" for element " ++ show (getElemName al) ++ " is not unparsed. " ++
"The following unparsed entities exist: " ++ show upEntities ++ ".")
where
upEntities :: [String]
upEntities = map (getEnumVal) (isUnparsedEntity $$ dtdPart)
getEnumVal :: XmlTree -> String
getEnumVal (NTree (XDTD ENTITY al') _) = lookup1 a_name al'
getEnumVal _ = ""
checkValueEntity _ n _
= error ("checkValueEntity: illegeal parameter:\n" ++ show n)
checkValueEntities ::XmlTrees -> XmlTree -> String -> XmlFilter
checkValueEntities dtdPart attrDecl@(NTree (XDTD ATTLIST al) _) attrValue
= if null valueList
then err ("Attribute " ++ show (getAttrName al) ++ " of element " ++
show (getElemName al) ++ " must be one or more names.")
else cat (map (checkValueEntity dtdPart attrDecl) valueList)
where
valueList = words attrValue
checkValueEntities _ n _
= error ("checkValueEntities: illegeal parameter:\n" ++ show n)
checkValueNmtoken :: XmlTree -> String -> XmlFilter
checkValueNmtoken (NTree (XDTD ATTLIST al) _) attrValue
= checkNmtoken parseRes
where
parseRes :: XmlTrees
parseRes = parseNMToken "" (mkXTextTree attrValue)
checkNmtoken :: XmlTrees -> XmlFilter
checkNmtoken ((NTree (XError _ s) _):_)
= err ("Attribute value " ++ show attrValue ++ " of attribute " ++ show (getAttrName al) ++
" for element " ++ show (getElemName al) ++ " must be a name token, "++ (lines s) !! 1 ++".")
checkNmtoken _ = none
checkValueNmtoken n _
= error ("checkValueNmtoken: illegeal parameter:\n" ++ show n)
checkValueNmtokens :: XmlTree -> String -> XmlFilter
checkValueNmtokens attrDecl@(NTree (XDTD ATTLIST al) _) attrValue
= if null valueList
then err ("Attribute "++ show (getAttrName al) ++" of element " ++
show (getElemName al) ++ " must be one or more name tokens.")
else cat (map (checkValueNmtoken attrDecl) valueList)
where
valueList = words attrValue
checkValueNmtokens n _
= error ("checkValueNmtokens: illegeal parameter:\n" ++ show n)
checkValueId :: XmlTree -> String -> XmlFilter
checkValueId attrDecl attrValue
= checkForName "Attribute value" attrDecl attrValue
checkValueIdref :: XmlTree -> String -> XmlFilter
checkValueIdref attrDecl attrValue
= checkForName "Attribute value" attrDecl attrValue
checkValueIdrefs :: XmlTree -> String -> XmlFilter
checkValueIdrefs attrDecl attrValue
= cat (map (checkValueIdref attrDecl) (words attrValue))
checkForName :: String -> XmlTree -> String -> XmlFilter
checkForName msg (NTree (XDTD ATTLIST al) _) attrValue
= checkName parseRes
where
parseRes :: XmlTrees
parseRes = parseName "" (mkXTextTree attrValue)
checkName :: XmlTrees -> XmlFilter
checkName ((NTree (XError _ s) _):_)
= err (msg ++ " "++ show attrValue ++" of attribute " ++ show (getAttrName al) ++
" for element "++ show (getElemName al) ++" must be a name, " ++ (lines s) !! 1 ++ ".")
checkName _ = none
checkForName _ n _
= error ("checkForName: illegeal parameter:\n" ++ show n)
getElemName :: Attributes -> String
getElemName = lookup1 a_name
getAttrName :: Attributes -> String
getAttrName = lookup1 a_value
normalizeAttributeValue :: Maybe XmlTree -> String -> String
normalizeAttributeValue (Just (NTree (XDTD ATTLIST al) _)) value
= normalizeAttribute attrType
where
attrType = lookup1 a_type al
normalizeAttribute :: String -> String
normalizeAttribute typ
| typ == k_cdata = cdataNormalization value
| otherwise = otherNormalization value
normalizeAttributeValue _ value
= cdataNormalization value
cdataNormalization :: String -> String
cdataNormalization = id
otherNormalization :: String -> String
otherNormalization = reduceWSSequences . stringTrim . cdataNormalization
reduceWSSequences :: String -> String
reduceWSSequences str = unwords (words str)