DocValidation.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 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.

   Before the document is validated, a lookup-table is build on the basis of
   the DTD which maps element names to their validation functions.
   After this initialization phase the whole document is traversed in preorder
   and every element is validated by the XmlFilter from the lookup-table.

-}

-- ------------------------------------------------------------

module Text.XML.HXT.DTDValidation.DocValidation
    ( validateDoc
    )
where

import Text.XML.HXT.DTDValidation.TypeDefs

import Text.XML.HXT.DTDValidation.AttributeValueValidation
import Text.XML.HXT.DTDValidation.XmlRE

-- ------------------------------------------------------------

-- |
-- Lookup-table which maps element names to their validation functions. The
-- validation functions are XmlArrows.

type ValiEnvTable	= [ValiEnv]
type ValiEnv 		= (ElemName, ValFct)
type ElemName		= String
type ValFct		= XmlArrow


-- ------------------------------------------------------------

-- |
-- Validate a document.
--
--    * 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

validateDoc	:: XmlTree -> XmlArrow
validateDoc dtdPart
    = traverseTree valTable
    where
    valTable = buildAllValidationFunctions dtdPart


-- |
-- Traverse the XmlTree in preorder.
--
--    * 1.parameter valiEnv :  lookup-table which maps element names to their validation functions
--
--    - returns : list of errors

traverseTree	:: ValiEnvTable -> XmlArrow
traverseTree valiEnv
    = choiceA [ isElem	:-> (valFct $< getQName)
	      , this	:-> none
	      ]
      <+>
      ( getChildren >>> traverseTree valiEnv )
    where
    valFct	:: QName -> XmlArrow
    valFct name	= case (lookup (qualifiedName name) valiEnv) of
		  Nothing -> err ("Element " ++ show (qualifiedName name) ++ " not declared in DTD.")
		  Just f  -> f

-- ------------------------------------------------------------

-- |
-- Build all validation functions.
--
--    * 1.parameter dtdPart :  DTD subset, root node should be of type @DOCTYPE@
--
--    - returns : lookup-table which maps element names to their validation functions

buildAllValidationFunctions :: XmlTree -> ValiEnvTable
buildAllValidationFunctions dtdPart
    = concat $
      buildValidateRoot dtdPart :	      -- construct a list of validation filters for all element declarations
      map (buildValidateFunctions dtdNodes) dtdNodes
      where
      dtdNodes = runLA getChildren dtdPart

-- |
-- Build a validation function for the document root. By root node @\/@
-- is meant, which is the topmost dummy created by the parser.
--
--    * 1.parameter dtdPart :  DTD subset, root node should be of type @DOCTYPE@
--
--    - returns : entry for the lookup-table

buildValidateRoot :: XmlTree -> [ValiEnv]
buildValidateRoot dn
    | isDTDDoctypeNode dn	= [(t_root, valFct)]
    | otherwise			= []
      where
      name	= dtd_name . getDTDAttributes $ dn

      valFct	:: XmlArrow
      valFct	= isElem
		  `guards`
		  ( checkRegex (re_sym name)
		    >>>
		    msgToErr (("Root Element must be " ++ show name ++ ". ") ++)
		  )

checkRegex	:: RE String -> LA XmlTree String
checkRegex re	= listA getChildren
		  >>> arr (\ cs -> checkRE (matches re cs))

-- |
-- Build validation functions for an element.
--
--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
--
--    - 2.parameter nd :  element declaration for which the validation functions are
--                   created
--
--    - returns : entry for the lookup-table

buildValidateFunctions :: XmlTrees -> XmlTree -> [ValiEnv]

buildValidateFunctions dtdPart dn
    | isDTDElementNode dn	= [(elemName, valFct)]
    | otherwise			= []
      where
      elemName = dtd_name . getDTDAttributes $ dn

      valFct :: XmlArrow
      valFct = buildContentValidation dn
               <+>
	       buildAttributeValidation dtdPart dn

-- ------------------------------------------------------------


-- |
-- Build validation functions for the content model of an element.
-- Validity constraint: Element Valid (3 \/ p.18 in Spec)
--
--    * 1.parameter nd :  element declaration for which the content validation functions
--                  are built
--
--    - returns : a function which takes an element (XTag), checks if its
--                  children match its content model and returns a list of errors

buildContentValidation :: XmlTree -> XmlArrow
buildContentValidation nd
    = contentValidation attrType nd
      where
      attrType = dtd_type . getDTDAttributes $ nd


      -- Delegates construction of the validation function on the basis of the
      -- content model type
      contentValidation :: String -> XmlTree -> XmlArrow
      contentValidation typ dn
          | typ == k_pcdata   = contentValidationPcdata
          | typ == k_empty    = contentValidationEmpty
          | typ == k_any      = contentValidationAny
          | typ == v_children = contentValidationChildren cs
          | typ == v_mixed    = contentValidationMixed cs
          | otherwise         = none
	  where
	  cs = runLA getChildren dn

      -- Checks #PCDATA content models
      contentValidationPcdata :: XmlArrow
      contentValidationPcdata
	  = isElem `guards` (contentVal $< getQName)
	    where
	    contentVal name
		= checkRegex (re_rep (re_sym k_pcdata))
		  >>>
		  msgToErr ( ( "The content of element " ++
			       show (qualifiedName name) ++
			       " must match (#PCDATA). "
			     ) ++
			   )

      -- Checks EMPTY content models
      contentValidationEmpty :: XmlArrow
      contentValidationEmpty
	  = isElem `guards` (contentVal $< getQName)
	    where
	    contentVal name
		= checkRegex re_unit
		  >>>
		  msgToErr ( ( "The content of element " ++
				 show (qualifiedName name) ++
				 " must match EMPTY. "
			     ) ++
			   )

      -- Checks ANY content models
      contentValidationAny :: XmlArrow
      contentValidationAny
	  = isElem `guards` (contentVal $< getName)
	    where
	    contentVal name
		= checkRegex (re_rep (re_dot))
		  >>>
		  msgToErr ( ( "The content of element " ++
			       show name ++
			       " must match ANY. "
			     ) ++
			   )

      -- Checks "children" content models
      contentValidationChildren :: XmlTrees -> XmlArrow
      contentValidationChildren cm
	  = isElem `guards` (contentVal $< getName)
	    where
	    contentVal name
		= checkRegex re
		  >>>
		  msgToErr ( ( "The content of element " ++
			       show name ++
			       " must match " ++ printRE re ++ ". "
			     ) ++
			   )
	    re = createRE (head cm)

      -- Checks "mixed content" content models
      contentValidationMixed :: XmlTrees -> XmlArrow
      contentValidationMixed cm
	  = isElem `guards` (contentVal $< getName)
	    where
	    contentVal name
		= checkRegex re
		  >>>
		  msgToErr ( ( "The content of element " ++
			       show name ++
			       " must match " ++ printRE re ++ ". "
			     ) ++
			   )
	    re = re_rep (re_alt (re_sym k_pcdata) (createRE (head cm)))

-- |
-- Build a regular expression from the content model. The regular expression
-- is provided by the module XmlRE.
--
--    * 1.parameter nd :  node of the content model. Expected: @CONTENT@ or
--              @NAME@
--
--    - returns : regular expression of the content model

createRE	::  XmlTree -> RE String
createRE dn
    | isDTDContentNode dn
	= processModifier modifier
    | isDTDNameNode dn
	= re_sym name
    | otherwise
	= error ("createRE: illegeal parameter:\n" ++ show dn)
    where
    al		= getDTDAttributes dn
    name	= dtd_name     al
    modifier 	= dtd_modifier al
    kind     	= dtd_kind     al
    cs		= runLA getChildren dn

    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)

-- ------------------------------------------------------------

-- |
-- Build validation functions for the attributes of an element.
--
--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
--
--    - 2.parameter nd :  element declaration for which the attribute validation functions
--                  are created
--
--    - returns : a function which takes an element (XTag), checks if its
--                  attributes are valid and returns a list of errors

buildAttributeValidation :: XmlTrees -> XmlTree -> XmlArrow
buildAttributeValidation dtdPart nd =
    noDoublicateAttributes
    <+>
    checkNotDeclardAttributes attrDecls nd
    <+>
    checkRequiredAttributes attrDecls nd
    <+>
    checkFixedAttributes attrDecls nd
    <+>
    checkValuesOfAttributes attrDecls dtdPart nd
    where
    attrDecls = isDTDAttlist $$ dtdPart


-- |
-- Validate that all attributes of an element are unique.
-- Well-formdness constraint: Unique AttSpec (3.1 \/ p.19 in Spec)
--
--    - returns : a function which takes an element (XTag), checks if its
--                  attributes are unique and returns a list of errors

noDoublicateAttributes	:: XmlArrow
noDoublicateAttributes
    = isElem
      `guards`
      ( noDoubles' $< getName )
    where
    noDoubles' elemName
	= listA (getAttrl >>> getName)
	  >>> applyA (arr (catA . map toErr . doubles . reverse))
	where
	toErr n1 = err ( "Attribute " ++ show n1 ++
			 " was already specified for element " ++
			 show elemName ++ "."
		       )

-- |
-- Validate that all \#REQUIRED attributes are provided.
-- Validity constraint: Required Attributes (3.3.2 \/ p.28 in Spec)
--
--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
--
--    - 2.parameter nd :  element declaration which attributes have to be checked
--
--    - returns : a function which takes an element (XTag), checks if all
--                  required attributes are provided and returns a list of errors

checkRequiredAttributes	:: XmlTrees -> XmlTree -> XmlArrow
checkRequiredAttributes attrDecls dn
    | isDTDElementNode dn
	= isElem
	  `guards`
	  ( checkRequired $< getName )
    | otherwise
	= none
      where
      elemName     = dtd_name . getDTDAttributes $ dn
      requiredAtts = (isAttlistOfElement elemName >>> isRequiredAttrKind) $$ attrDecls

      checkRequired :: String -> XmlArrow
      checkRequired name
	  = catA . map checkReq $ requiredAtts
	  where
	  checkReq	:: XmlTree -> XmlArrow
	  checkReq attrDecl
	      = neg (hasAttr attName)
		`guards`
		err ( "Attribute " ++ show attName ++ " must be declared for element type " ++
		      show name ++ "." )
	      where
	      attName = dtd_value . getDTDAttributes $ attrDecl

-- |
-- Validate that \#FIXED attributes match the default value.
-- Validity constraint: Fixed Attribute Default (3.3.2 \/ p.28 in Spec)
--
--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
--
--    - 2.parameter nd :  element declaration which attributes have to be checked
--
--    - returns : a function which takes an element (XTag), checks if all
--                  fixed attributes match the default value and returns a list of errors

checkFixedAttributes :: XmlTrees -> XmlTree -> XmlArrow
checkFixedAttributes attrDecls dn
    | isDTDElementNode dn
	= isElem
	  `guards`
	  ( checkFixed $< getName )
    | otherwise
	= none
      where
      elemName  = dtd_name . getDTDAttributes $ dn
      fixedAtts = (isAttlistOfElement elemName >>> isFixedAttrKind) $$ attrDecls

      checkFixed :: String -> XmlArrow
      checkFixed name
	  = catA . map checkFix $ fixedAtts
	  where
	  checkFix	:: XmlTree -> XmlArrow
	  checkFix an
	      |  isDTDAttlistNode an
		  = checkFixedVal $< getAttrValue attName
	      | otherwise
		  = none
	      where
	      al'	= getDTDAttributes an
	      attName   = dtd_value   al'
	      defa	= dtd_default al'
	      fixedValue = normalizeAttributeValue (Just an) defa

              checkFixedVal	:: String -> XmlArrow
	      checkFixedVal val
		  = ( ( hasAttr attName
			>>>
			isA (const (attValue /= fixedValue))
		      )
		      `guards`
		      err ( "Attribute " ++ show attName ++ " of element " ++ show name ++
			    " with value " ++ show attValue ++ " must have a value of " ++
			    show fixedValue ++ "." )
		    )
		  where
		  attValue   = normalizeAttributeValue (Just an) val

-- |
-- Validate that an element has no attributes which are not declared.
-- Validity constraint: Attribute Value Type (3.1 \/ p.19 in Spec)
--
--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
--
--    - 2.parameter nd :  element declaration which attributes have to be checked
--
--    - returns : a function which takes an element (XTag), checks if all
--                  attributes are declared and returns a list of errors

checkNotDeclardAttributes :: XmlTrees -> XmlTree -> XmlArrow
checkNotDeclardAttributes attrDecls elemDescr
    = checkNotDeclared
      where
      elemName = valueOfDTD a_name elemDescr
      decls    = isAttlistOfElement elemName $$ attrDecls

      checkNotDeclared :: XmlArrow
      checkNotDeclared
	  = isElem
	    `guards`
	    ( getAttrl >>> searchForDeclaredAtt elemName decls )

      searchForDeclaredAtt :: String -> XmlTrees -> XmlArrow
      searchForDeclaredAtt name (dn : xs)
	  | isDTDAttlistNode dn
	      = ( getName >>> isA ( (dtd_value . getDTDAttributes $ dn) /= ) )
		`guards`
		searchForDeclaredAtt name xs
	  | otherwise
	      = searchForDeclaredAtt name xs

      searchForDeclaredAtt name []
	  = mkErr $< getName
	    where
	    mkErr n = err ( "Attribute " ++ show n ++ " of element " ++
			    show name ++ " is not declared in DTD." )

-- |
-- Validate that the attribute value meets the lexical constraints of its type.
-- Validity constaint: Attribute Value Type (3.1 \/ p.19 in Spec)
--
--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
--
--    - 2.parameter nd :  element declaration which attributes have to be checked
--
--    - returns : a function which takes an element (XTag), checks if all
--                  attributes meet the lexical constraints and returns a list of errors

checkValuesOfAttributes :: XmlTrees -> XmlTrees -> XmlTree -> XmlArrow
checkValuesOfAttributes attrDecls dtdPart elemDescr
    = checkValues
      where
      elemName	= dtd_name . getDTDAttributes $ elemDescr
      decls     = isAttlistOfElement elemName $$ attrDecls

      checkValues :: XmlArrow
      checkValues
	  = isElem
	    `guards`
	    ( checkValue $< getAttrl )

      checkValue att
	  = catA . map checkVal $ decls
	    where
	    checkVal :: XmlTree -> XmlArrow
	    checkVal attrDecl
		| isDTDAttlistNode attrDecl
		  &&
		  nameOfAttr att == dtd_value al'
		      = checkAttributeValue dtdPart attrDecl
		| otherwise
		    = none
		where
		al' = getDTDAttributes attrDecl

-- ------------------------------------------------------------