diff --git a/examples/hrelaxng/Validate.hs b/examples/hrelaxng/Validate.hs new file mode 100644 --- /dev/null +++ b/examples/hrelaxng/Validate.hs @@ -0,0 +1,34 @@ +module Validate where + +import Data.Maybe + +import Text.XML.HXT.Core +import Text.XML.HXT.RelaxNG + +loadSchema :: String -> IO (Maybe XmlTree) +loadSchema schema = + runX ( validateSchemaWithRelax schema ) >>= return . listToMaybe + +validateWithSchema :: XmlTree -> XmlTree -> Maybe String +validateWithSchema schema doc + = listToMaybe $ + runLA + ( validateRelax' schema + >>> + getErrorMsg + ) doc + +main1 :: String -> String -> IO () +main1 sf df + = do + schema <- loadSchema sf >>= return . fromJust + doc <- runX ( readDocument [ withValidate no ] df ) >>= return . head + case validateWithSchema schema doc of + Just e -> putStrLn $ "Document " ++ show df ++ " is not valid for schema " ++ show sf ++ ": " ++ e + Nothing -> putStrLn $ "Document " ++ show df ++ " is valid for schema " ++ show sf + +main :: IO () +main + = do + main1 "valid1.rng" "valid1.xml" + main1 "valid1.rng" "invalid1.xml" diff --git a/hxt-relaxng.cabal b/hxt-relaxng.cabal --- a/hxt-relaxng.cabal +++ b/hxt-relaxng.cabal @@ -1,6 +1,6 @@ -- arch-tag: Haskell XML Toolbox main description file Name: hxt-relaxng -Version: 9.1.1 +Version: 9.1.2 Synopsis: The HXT RelaxNG validator Description: The HXT RelaxNG validator License: MIT @@ -25,6 +25,7 @@ examples/hparser/valid1.rng examples/hparser/valid1.xml examples/hrelaxng/HRelaxNG.hs + examples/hrelaxng/Validate.hs examples/hrelaxng/invalid1.xml examples/hrelaxng/invalid2.rng examples/hrelaxng/invalid3.rng diff --git a/src/Text/XML/HXT/RelaxNG/Validation.hs b/src/Text/XML/HXT/RelaxNG/Validation.hs --- a/src/Text/XML/HXT/RelaxNG/Validation.hs +++ b/src/Text/XML/HXT/RelaxNG/Validation.hs @@ -21,6 +21,7 @@ ( validateWithRelax , validateDocWithRelax , validateRelax + , validateRelax' , readForRelax , normalizeForRelaxValidation , contains @@ -117,8 +118,11 @@ validateWithRelax theSchema ) -{- | Validates a xml document with respect to a Relax NG schema +{- | 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 @@ -126,37 +130,51 @@ - arrow-output : the document or in case of errors none -} +-- ------------------------------------------------------------ + validateRelax :: XmlTree -> IOSArrow XmlTree XmlTree validateRelax rngSchema - = ( fromLA - ( ( ( constA rngSchema - >>> - createPatternFromXmlTree - ) - &&& - ( getChildren -- remove the root node - >>> - isElem -- and select the root element - ) + = 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 ) - >>> - 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 + &&& + ( getChildren -- remove the root node + >>> + isElem -- and select the root element + ) ) - `orElse` - this + >>> + 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 ) - >>> - filterErrorMsg + `orElse` + this -- ------------------------------------------------------------ diff --git a/src/Text/XML/HXT/RelaxNG/Validator.hs b/src/Text/XML/HXT/RelaxNG/Validator.hs --- a/src/Text/XML/HXT/RelaxNG/Validator.hs +++ b/src/Text/XML/HXT/RelaxNG/Validator.hs @@ -5,6 +5,7 @@ module Text.XML.HXT.RelaxNG.Validator ( validateDocumentWithRelaxSchema , validateDocumentWithRelax + , validateSchemaWithRelax , validateWithSpezification , validateSchemaWithSpezification @@ -64,7 +65,7 @@ >>> traceMsg 1 ( "start validating document with Relax NG schema: " ++ show relaxSchema ) >>> - ( ( ( validate' $< validateSchema relaxSchema) -- try to validate, only possible if schema is o.k. + ( ( ( validate' $< validateSchemaWithRelax relaxSchema) -- try to validate, only possible if schema is o.k. >>> traceMsg 1 ( "validating document with Relax NG schema done" ) ) @@ -83,8 +84,8 @@ >>> validateDocumentWithRelax schema -validateSchema :: String -> IOSArrow XmlTree XmlTree -validateSchema relaxSchema +validateSchemaWithRelax :: String -> IOSArrow XmlTree XmlTree +validateSchemaWithRelax relaxSchema = traceMsg 2 ( "read and check Relax NG schema document: " ++ show relaxSchema ) >>> readForRelax relaxSchema @@ -153,82 +154,11 @@ ) `when` documentStatusOk -- only do something when document status is ok - -{- | - normalize a document for Relax NG validation, - call the 'Text.XML.HXT.RelaxNG.Validation.validateRelax' function for doing the hard work, - and issue errors - - * 1.parameter : the arrow for computing the schema - - - arrow-input : the document to be validated - - - arrow-output : nothing --} - -- ------------------------------------------------------------ -{- | Document validation - -Validates a xml document with respect to a Relax NG schema. - -First, the schema is validated with respect to the Relax NG Spezification. If no error is found, the xml document is validated with respect to the schema. - - * 1.parameter : list of options; namespace progagation is always done - - - 2.parameter : XML document - - - 3.parameter : Relax NG schema file - -available options: - - * 'a_do_not_check_restrictions' : do not check Relax NG schema restrictions (includes do-not-validate-externalRef, do-not-validate-include) - - - 'a_do_not_validate_externalRef' : do not validate a Relax NG schema referenced by a externalRef-Pattern - - - 'a_validate_externalRef' : validate a Relax NG schema referenced by a externalRef-Pattern (default) - - - 'a_do_not_validate_include' : do not validate a Relax NG schema referenced by a include-Pattern - - - 'a_validate_include' : validate a Relax NG schema referenced by a include-Pattern (default) - - - 'a_output_changes' : output Pattern transformations in case of an error - - - 'a_do_not_collect_errors' : stop Relax NG simplification after the first error has occurred - - - all 'Text.XML.HXT.Arrow.ReadDocument.readDocument' options - -example: - -> validate [(a_do_not_check_restrictions, "1")] "test.xml" "testSchema.rng" - --} {- -validate :: String -> String -> IOSArrow n XmlTree -validate xmlDocument relaxSchema - = S.relaxSchemaArrow - >>> - validateWithSpezification xmlDocument relaxSchema --} - - - {- | Relax NG schema validation -Validates a Relax NG schema with respect to the Relax NG Spezification. - - * 1.parameter : Relax NG schema file - --} {- -validateSchema :: String -> IOSArrow n XmlTree -validateSchema relaxSchema - = validate "" relaxSchema --} - --- ------------------------------------------------------------ - -{- | Relax NG schema validation - - see 'validateSchema' and 'validateWithSpezification' + see 'validateSchemaWithRelax' and 'validateWithSpezification' * 1.parameter : Relax NG schema file @@ -253,7 +183,7 @@ validateWithSpezification :: String -> String -> IOSArrow XmlTree XmlTree validateWithSpezification xmlDocument relaxSchema - = validDoc $< listA (validateSchema relaxSchema) + = validDoc $< listA (validateSchemaWithRelax relaxSchema) where validDoc [theSchema] | null xmlDocument