Validation.hs

{-# LANGUAGE BangPatterns #-}

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

{- |
   Module     : Text.XML.HXT.RelaxNG.Validation
   Copyright  : Copyright (C) 2008 Torben Kuseler, Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : stable
   Portability: portable

   Validation of a XML document with respect to a valid Relax NG schema in simple form.
   Copied and modified from \"An algorithm for RELAX NG validation\" by James Clark
   (<http://www.thaiopensource.com/relaxng/derivative.html>).

-}

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

module Text.XML.HXT.RelaxNG.Validation
    ( validateWithRelax
    , validateDocWithRelax
    , validateRelax
    , validateRelax'
    , readForRelax
    , normalizeForRelaxValidation
    , contains
    )
where

import           Control.Arrow.ListArrows

import           Data.Char.Properties.XMLCharProps      (isXmlSpaceChar)
import           Data.Maybe                             (fromJust)

import           Text.XML.HXT.DOM.Interface
import qualified Text.XML.HXT.DOM.XmlNode               as XN

import           Text.XML.HXT.Arrow.Edit                (canonicalizeAllNodes,
                                                         collapseAllXText)
import           Text.XML.HXT.Arrow.XmlArrow

import           Text.XML.HXT.Arrow.ProcessDocument     (getDocumentContents,
                                                         parseXmlDocument, propagateAndValidateNamespaces)
import           Text.XML.HXT.Arrow.XmlState
import           Text.XML.HXT.Arrow.XmlState.TypeDefs

import           Text.XML.HXT.RelaxNG.CreatePattern
import           Text.XML.HXT.RelaxNG.DataTypeLibraries
import           Text.XML.HXT.RelaxNG.DataTypes
import           Text.XML.HXT.RelaxNG.PatternToString
import           Text.XML.HXT.RelaxNG.Utils             (compareURI,
                                                         formatStringListQuot)

{-
import qualified Debug.Trace                            as T
-- -}

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

validateWithRelax       :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
validateWithRelax theSchema
    = traceMsg 2 "normalize document for validation"
      >>>
      normalizeForRelaxValidation             -- prepare the document for validation
      >>>
      traceMsg 2 "start validation"
      >>>
      ( validateRelax $< theSchema )          -- compute and issue validation errors

{- |
   normalize a document for validation with Relax NG: remove all namespace declaration attributes,
   remove all processing instructions and merge all sequences of text nodes into a single text node
-}

normalizeForRelaxValidation :: ArrowXml a => a XmlTree XmlTree
normalizeForRelaxValidation
  = processTopDownWithAttrl
    (
     ( none `when`                      -- remove all namespace attributes
       ( isAttr
         >>>
         getNamespaceUri
         >>>
         isA (compareURI xmlnsNamespace)
       )
     )
     >>>
     (none `when` isPi)                 -- processing instructions
    )
    >>>
    collapseAllXText                    -- all text node sequences are merged into a single text node

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

{- | Validates a xml document with respect to a Relax NG schema

   * 1.parameter  :  the arrow for computing the Relax NG schema

   - 2.parameter  :  list of configuration options for reading and validating

   - 3.parameter  :  XML document URI

   - arrow-input  :  ignored

   - arrow-output :  list of errors or 'none'
-}

validateDocWithRelax :: IOSArrow XmlTree XmlTree -> SysConfigList -> String -> IOSArrow XmlTree XmlTree
validateDocWithRelax theSchema config doc
    = localSysEnv
      ( configSysVars config
        >>>
        readForRelax doc
        >>>
        validateWithRelax theSchema
      )

{- | Validates an XML document with respect to a Relax NG schema
   and issues error messages.

   See also: `validateRelax'`

   * 1.parameter  :  Relax NG schema

   - arrow-input  :  XML document

   - arrow-output :  the document or in case of errors none
-}

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

validateRelax :: XmlTree -> IOSArrow XmlTree XmlTree
validateRelax rngSchema
    = fromLA (validateRelax' rngSchema)
      >>>
      filterErrorMsg

{- | Validates an XML document with respect to a Relax NG schema
   This arrow is pure. It does not need IO or any configuration parameters.

   * 1.parameter  :  Relax NG schema

   - arrow-input  :  XML document

   - arrow-output :  the unchanged document or an error message
-}

validateRelax' :: XmlTree -> LA XmlTree XmlTree
validateRelax' rngSchema
    = ( ( ( constA rngSchema
            >>>
            createPatternFromXmlTree
          )
          &&&
          ( getChildren                       -- remove the root node
            >>>
            isElem                            -- and select the root element
          )
        )
        >>>
        arr2 (\ !pattern !xmlDoc -> childDeriv ("", []) pattern xmlDoc)
        >>>
        isA (not . nullable)
        >>>
        arr ( take 1024                      -- pattern may be recursive, so the string representation
                                             -- is truncated to 1024 chars to assure termination
              . ("when validating with Relax NG schema: " ++)
              . show
            )
        >>>
        mkError c_err
      )
      `orElse`
      this

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

readForRelax    :: String -> IOSArrow b XmlTree
readForRelax schema
    = getDocumentContents schema
      >>>
      parseXmlDocument False True False True
      >>>
      canonicalizeAllNodes
      >>>
      propagateAndValidateNamespaces

-- ------------------------------------------------------------
--
-- | tests whether a 'NameClass' contains a particular 'QName'

contains :: NameClass -> QName -> Bool
contains AnyName _                      = True
contains (AnyNameExcept nc)    n        = not (contains nc n)
contains (NsName ns1)          qn       = ns1 == namespaceUri qn
contains (NsNameExcept ns1 nc) qn       = ns1 == namespaceUri qn && not (contains nc qn)
contains (Name ns1 ln1)        qn       = (ns1 == namespaceUri qn) && (ln1 == localPart qn)
contains (NameClassChoice nc1 nc2) n    = (contains nc1 n) || (contains nc2 n)
contains (NCError _) _                  = False


-- ------------------------------------------------------------
--
-- | tests whether a pattern matches the empty sequence
nullable:: Pattern -> Bool
nullable (Group p1 p2)          = nullable p1 && nullable p2
nullable (Interleave p1 p2)     = nullable p1 && nullable p2
nullable (Choice p1 p2)         = nullable p1 || nullable p2
nullable (OneOrMore p)          = nullable p
nullable (Element _ _)          = False
nullable (Attribute _ _)        = False
nullable (List _)               = False
nullable (Value _ _ _)          = False
nullable (Data _ _)             = False
nullable (DataExcept _ _ _)     = False
nullable (NotAllowed _)         = False
nullable Empty                  = True
nullable Text                   = True
nullable (After _ _)            = False


-- ------------------------------------------------------------
--
-- | computes the derivative of a pattern with respect to a XML-Child and a 'Context'

childDeriv :: Context -> Pattern -> XmlTree -> Pattern

childDeriv cx p t
    | XN.isText t       = textDeriv{- ' -}cx p . fromJust . XN.getText $ t
    | XN.isElem t       = endTagDeriv{- ' -} p4
    | otherwise         = notAllowed "Call to childDeriv with wrong arguments"
    where
    children    =            XN.getChildren $ t
    qn          = fromJust . XN.getElemName $ t
    atts        = fromJust . XN.getAttrl    $ t
    cx1         = ("",[])
    p1          = startTagOpenDeriv p qn
    p2          = attsDeriv{- ' -} cx1 p1 atts
    p3          = startTagCloseDeriv p2
    p4          = childrenDeriv cx1 p3 children

-- ------------------------------------------------------------
--
-- | computes the derivative of a pattern with respect to a text node

{-
textDeriv' cx p t
    = T.trace ("textDeriv: p=\n" ++ (take 10000 . show) p ++ ", t=\n" ++ t) $
      T.trace ("res=\n" ++ (take 10000 . show) res) res
    where
    res = textDeriv cx p t
-- -}


textDeriv :: Context -> Pattern -> String -> Pattern

textDeriv cx (Choice p1 p2) s
    = choice (textDeriv cx p1 s) (textDeriv cx p2 s)

textDeriv cx (Interleave p1 p2) s
    = choice
      (interleave (textDeriv cx p1 s) p2)
      (interleave p1 (textDeriv cx p2 s))

textDeriv cx (Group p1 p2) s
    = let
      p = group (textDeriv cx p1 s) p2
      in
      if nullable p1
      then choice p (textDeriv cx p2 s)
      else p

textDeriv cx (After p1 p2) s
    = after (textDeriv cx p1 s) p2

textDeriv cx (OneOrMore p) s
    = group (textDeriv cx p s) (choice (OneOrMore p) Empty)

textDeriv _ Text _
    = Text

textDeriv cx1 (Value (uri, s) value cx2) s1
    = case datatypeEqual uri s value cx2 s1 cx1
      of
      Nothing     -> Empty
      Just errStr -> notAllowed errStr

textDeriv cx (Data (uri, s) params) s1
    = case datatypeAllows uri s params s1 cx
      of
      Nothing     -> Empty
      Just errStr -> notAllowed2 errStr

textDeriv cx (DataExcept (uri, s) params p) s1
    = case (datatypeAllows uri s params s1 cx)
      of
      Nothing     -> if not $ nullable $ textDeriv cx p s1
                     then Empty
                     else notAllowed
                              ( "Any value except " ++
                                show (show p) ++
                                " expected, but value " ++
                                show (show s1) ++
                                " found"
                              )
      Just errStr -> notAllowed errStr

textDeriv cx (List p) s
    = if nullable (listDeriv cx p (words s))
      then Empty
      else notAllowed
               ( "List with value(s) " ++
                 show p ++
                 " expected, but value(s) " ++
                 formatStringListQuot (words s) ++
                 " found"
               )

textDeriv _ n@(NotAllowed _) _
    = n

textDeriv _ p s
    = notAllowed
      ( "Pattern " ++ show (getPatternName p) ++
        " expected, but text " ++ show s ++ " found"
      )


-- ------------------------------------------------------------
--
-- | To compute the derivative of a pattern with respect to a list of strings,
-- simply compute the derivative with respect to each member of the list in turn.

listDeriv :: Context -> Pattern -> [String] -> Pattern

listDeriv _ !p []
    = p

listDeriv cx !p (x:xs)
    = listDeriv cx (textDeriv cx p x) xs


-- ------------------------------------------------------------
--
-- | computes the derivative of a pattern with respect to a start tag open

startTagOpenDeriv :: Pattern -> QName -> Pattern

startTagOpenDeriv (Choice p1 p2) qn
    = choice (startTagOpenDeriv p1 qn) (startTagOpenDeriv p2 qn)

startTagOpenDeriv (Element nc p) qn
    | contains nc qn
        = after p Empty
    | otherwise
        = notAllowed $
          "Element with name " ++ nameClassToString nc ++
            " expected, but " ++ universalName qn ++ " found"

startTagOpenDeriv (Interleave p1 p2) qn
    = choice
      (applyAfter (flip interleave p2) (startTagOpenDeriv p1 qn))
      (applyAfter (interleave p1) (startTagOpenDeriv p2 qn))

startTagOpenDeriv (OneOrMore p) qn
    = applyAfter
      (flip group (choice (OneOrMore p) Empty))
      (startTagOpenDeriv p qn)

startTagOpenDeriv (Group p1 p2) qn
    = let
      x = applyAfter (flip group p2) (startTagOpenDeriv p1 qn)
      in
      if nullable p1
      then choice x (startTagOpenDeriv p2 qn)
      else x

startTagOpenDeriv (After p1 p2) qn
    = applyAfter (flip after p2) (startTagOpenDeriv p1 qn)

startTagOpenDeriv n@(NotAllowed _) _
    = n

startTagOpenDeriv p qn
    = notAllowed ( show p ++ " expected, but Element " ++ universalName qn ++ " found" )

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

-- auxiliary functions for tracing

{-
attsDeriv' cx p ts
    = T.trace ("attsDeriv: p=" ++ (take 1000 . show) p ++ ", t=" ++ showXts ts) $
      T.trace ("res= " ++ (take 1000 . show) res) res
    where
    res = attsDeriv cx p ts
-- -}

{-
attDeriv' cx p t
    = T.trace ("attDeriv: p=\n" ++ (take 10000 . show) p ++ ", t=\n" ++ showXts [t]) $
      T.trace ("res=\n" ++ (take 1000 . show) res) res
    where
    res = attDeriv cx p t
-- -}

-- | To compute the derivative of a pattern with respect to a sequence of attributes,
-- simply compute the derivative with respect to each attribute in turn.

attsDeriv :: Context -> Pattern -> XmlTrees -> Pattern

attsDeriv _ !p []
    = p
attsDeriv cx !p (t : ts)
    | XN.isAttr t
        = attsDeriv cx (attDeriv{- ' -} cx p t) ts
    | otherwise
        = notAllowed "Call to attsDeriv with wrong arguments"

attDeriv :: Context -> Pattern -> XmlTree -> Pattern

attDeriv cx (After p1 p2) att
    = after (attDeriv cx p1 att) p2

attDeriv cx (Choice p1 p2) att
    = choice (attDeriv cx p1 att) (attDeriv cx p2 att)

attDeriv cx (Group p1 p2) att
    = choice
      (group (attDeriv cx p1 att) p2)
      (group p1 (attDeriv cx p2 att))

attDeriv cx (Interleave p1 p2) att
    = choice
      (interleave (attDeriv cx p1 att) p2)
      (interleave p1 (attDeriv cx p2 att))

attDeriv cx (OneOrMore p) att
    = group
      (attDeriv cx p att)
      (choice (OneOrMore p) Empty)

attDeriv cx (Attribute nc p) att
    | isa
      &&
      not (contains nc qn)
        = notAllowed1 $
          "Attribute with name " ++ nameClassToString nc
          ++ " expected, but " ++ universalName qn ++ " found"
    | isa
      &&
      ( ( nullable p
          &&
          whitespace val
        )
        || nullable p'
      )
        = Empty
    | isa
        = err' p'
    where
    isa =            XN.isAttr      $ att
    qn  = fromJust . XN.getAttrName $ att
    av  =            XN.getChildren $ att
    val = showXts av
    p'  = textDeriv cx p val

    err' (NotAllowed (ErrMsg _l es))
        = err'' (": " ++ head es)
    err' _
        = err'' ""
    err'' e
        = notAllowed2 $
          "Attribute value \"" ++ val ++
          "\" does not match datatype spec " ++ show p ++ e

attDeriv _ n@(NotAllowed _) _
    = n

attDeriv _ _p att
    = notAllowed $
      "No matching pattern for attribute '" ++  showXts [att] ++ "' found"

-- ------------------------------------------------------------
--
-- | computes the derivative of a pattern with respect to a start tag close

startTagCloseDeriv :: Pattern -> Pattern

startTagCloseDeriv (After p1 p2)
    = after (startTagCloseDeriv p1) p2

startTagCloseDeriv (Choice p1 p2)
    = choice
      (startTagCloseDeriv p1)
      (startTagCloseDeriv p2)

startTagCloseDeriv (Group p1 p2)
    = group
      (startTagCloseDeriv p1)
      (startTagCloseDeriv p2)

startTagCloseDeriv (Interleave p1 p2)
    = interleave
      (startTagCloseDeriv p1)
      (startTagCloseDeriv p2)

startTagCloseDeriv (OneOrMore p)
    = oneOrMore (startTagCloseDeriv p)

startTagCloseDeriv (Attribute nc _)
    = notAllowed1 $
      "Attribut with name, " ++ show nc ++
      " expected, but no more attributes found"

startTagCloseDeriv p
    = p


-- ------------------------------------------------------------
--
-- | Computing the derivative of a pattern with respect to a list of children involves
-- computing the derivative with respect to each pattern in turn, except
-- that whitespace requires special treatment.

childrenDeriv :: Context -> Pattern -> XmlTrees -> Pattern
childrenDeriv _cx p@(NotAllowed _) _
    = p

childrenDeriv cx p []
    = childrenDeriv cx p [XN.mkText ""]

childrenDeriv cx p [tt]
    | ist
      &&
      whitespace s
        = choice p p1
    | ist
        = p1
    where
    ist =            XN.isText    tt
    s   = fromJust . XN.getText $ tt
    p1  = childDeriv cx p tt

childrenDeriv cx p children
    = stripChildrenDeriv cx p children

stripChildrenDeriv :: Context -> Pattern -> XmlTrees -> Pattern
stripChildrenDeriv _ !p []
    = p

stripChildrenDeriv cx !p (h:t)
    = stripChildrenDeriv cx
      ( if strip h
        then p
        else (childDeriv cx p h)
      ) t


-- ------------------------------------------------------------
--
-- | computes the derivative of a pattern with respect to a end tag

{-
endTagDeriv' p
    = T.trace ("endTagDeriv: p=\n" ++ (take 10000 . show) p) $
      T.trace ("res=\n" ++ (take 10000 . show) res) res
    where
    res = endTagDeriv p
-- -}

endTagDeriv :: Pattern -> Pattern
endTagDeriv (Choice p1 p2)
    = choice (endTagDeriv p1) (endTagDeriv p2)

endTagDeriv (After p1 p2)
    | nullable p1
        = p2
    | otherwise
        = notAllowed $
          show p1 ++ " expected"

endTagDeriv n@(NotAllowed _)
    = n

endTagDeriv _
    = notAllowed "Call to endTagDeriv with wrong arguments"

-- ------------------------------------------------------------
--
-- | applies a function (first parameter) to the second part of a after pattern

applyAfter :: (Pattern -> Pattern) -> Pattern -> Pattern

applyAfter f (After p1 p2)      = after p1 (f p2)
applyAfter f (Choice p1 p2)     = choice (applyAfter f p1) (applyAfter f p2)
applyAfter _ n@(NotAllowed _)   = n
applyAfter _ _                  = notAllowed "Call to applyAfter with wrong arguments"

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

-- mothers little helpers

strip           :: XmlTree -> Bool
strip           = maybe False whitespace . XN.getText

whitespace      :: String -> Bool
whitespace      = all isXmlSpaceChar

showXts         :: XmlTrees -> String
showXts         = concat . runLA (xshow $ arrL id)

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