module Text.XML.HXT.RelaxNG.Validator
( validateDocumentWithRelaxSchema
, validateDocumentWithRelax
, validateSchemaWithRelax
, validateWithSpezification
, validateSchemaWithSpezification
, module Text.XML.HXT.RelaxNG.Validation
, module Text.XML.HXT.RelaxNG.Simplification
)
where
import Control.Arrow.ListArrows
import Text.XML.HXT.DOM.Interface
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlState
import Text.XML.HXT.Arrow.XmlState.TypeDefs
import Text.XML.HXT.RelaxNG.BasicArrows
import Text.XML.HXT.RelaxNG.Validation
import Text.XML.HXT.RelaxNG.Simplification
import Text.XML.HXT.RelaxNG.Schema as S
validateDocumentWithRelaxSchema :: SysConfigList -> String -> IOStateArrow s XmlTree XmlTree
validateDocumentWithRelaxSchema config relaxSchema
= ( withoutUserState
$
localSysEnv
$
configSysVars config
>>>
traceMsg 1 ( "start validating document with Relax NG schema: " ++ show relaxSchema )
>>>
( ( ( validate' $< validateSchemaWithRelax relaxSchema)
>>>
traceMsg 1 ( "validating document with Relax NG schema done" )
)
`orElse`
( setDocumentStatusFromSystemState "validating Relax NG schema"
>>>
traceMsg 1 ( "no validation done, Relax NG schema is not correct" )
)
)
)
`when`
documentStatusOk
where
validate' schema
= setDocumentStatusFromSystemState "read and build Relax NG schema"
>>>
validateDocumentWithRelax schema
validateSchemaWithRelax :: String -> IOSArrow XmlTree XmlTree
validateSchemaWithRelax relaxSchema
= traceMsg 2 ( "read and check Relax NG schema document: " ++ show relaxSchema )
>>>
readForRelax relaxSchema
>>>
( let checkSchema = True in
if checkSchema
then validateWithRelax S.relaxSchemaArrow `guards` this
else this
)
>>>
traceMsg 2 "create simplified schema"
>>>
( (\ (b1, (b2, b3)) -> createSimpleForm b1 b2 b3)
$<
getSysVar (theRelaxCheckRestr .&&&.
theRelaxValidateExtRef .&&&.
theRelaxValidateInclude
)
)
>>>
traceDoc "simplified schema"
>>>
traceMsg 2 "collect and issue schema errors"
>>>
perform handleSimplificationErrors
>>>
resetStates
>>>
setDocumentStatusFromSystemState "validating Relax NG schema"
>>>
documentStatusOk
>>>
traceMsg 2 "Relax NG schema is o.k."
handleSimplificationErrors :: IOSArrow XmlTree XmlTree
handleSimplificationErrors
= traceDoc "simplification errors"
>>>
getErrors
>>>
getRngAttrDescr
>>>
arr ("Relax NG validation: " ++)
>>>
mkError c_err
>>>
filterErrorMsg
validateDocumentWithRelax :: XmlTree -> IOSArrow XmlTree XmlTree
validateDocumentWithRelax schema
= ( traceMsg 1 "validate document with Relax NG schema"
>>>
perform ( validateWithRelax (constA schema) )
>>>
setDocumentStatusFromSystemState "validate document with Relax NG schema"
)
`when` documentStatusOk
validateSchemaWithSpezification :: String -> IOSArrow XmlTree XmlTree
validateSchemaWithSpezification relaxSchema
= validateWithSpezification "" relaxSchema
validateWithSpezification :: String -> String -> IOSArrow XmlTree XmlTree
validateWithSpezification xmlDocument relaxSchema
= validDoc $< listA (validateSchemaWithRelax relaxSchema)
where
validDoc [theSchema]
| null xmlDocument
= none
| otherwise
= ifA ( readForRelax xmlDocument
>>>
normalizeForRelaxValidation
>>>
validateRelax theSchema
)
none
( err "Document is not valid with respect to Relax NG Schema" )
validDoc _
= err "Relax NG Schema not correct"