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 :: SysConfigList -> String -> IOStateArrow s XmlTree XmlTree
validateDocumentWithRelaxSchema config :: SysConfigList
config relaxSchema :: String
relaxSchema
= ( IOSArrow XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall b c s0. IOSArrow b c -> IOStateArrow s0 b c
withoutUserState
(IOSArrow XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree)
-> IOSArrow XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall s a b. IOStateArrow s a b -> IOStateArrow s a b
localSysEnv
(IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree)
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
SysConfigList -> IOSArrow XmlTree XmlTree
forall s c. SysConfigList -> IOStateArrow s c c
configSysVars SysConfigList
config
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
Int -> String -> IOSArrow XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg 1 ( "start validating document with Relax NG schema: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
relaxSchema )
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
( ( ( XmlTree -> IOSArrow XmlTree XmlTree
validate' (XmlTree -> IOSArrow XmlTree XmlTree)
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< String -> IOSArrow XmlTree XmlTree
validateSchemaWithRelax String
relaxSchema)
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
Int -> String -> IOSArrow XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg 1 ( "validating document with Relax NG schema done" )
)
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse`
( String -> IOSArrow XmlTree XmlTree
forall s. String -> IOStateArrow s XmlTree XmlTree
setDocumentStatusFromSystemState "validating Relax NG schema"
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
Int -> String -> IOSArrow XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg 1 ( "no validation done, Relax NG schema is not correct" )
)
)
)
IOStateArrow s XmlTree XmlTree
-> IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
IOStateArrow s XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
documentStatusOk
where
validate' :: XmlTree -> IOSArrow XmlTree XmlTree
validate' schema :: XmlTree
schema
= String -> IOSArrow XmlTree XmlTree
forall s. String -> IOStateArrow s XmlTree XmlTree
setDocumentStatusFromSystemState "read and build Relax NG schema"
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
XmlTree -> IOSArrow XmlTree XmlTree
validateDocumentWithRelax XmlTree
schema
validateSchemaWithRelax :: String -> IOSArrow XmlTree XmlTree
validateSchemaWithRelax :: String -> IOSArrow XmlTree XmlTree
validateSchemaWithRelax relaxSchema :: String
relaxSchema
= Int -> String -> IOSArrow XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg 2 ( "read and check Relax NG schema document: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
relaxSchema )
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
String -> IOSArrow XmlTree XmlTree
forall b. String -> IOSArrow b XmlTree
readForRelax String
relaxSchema
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
( let checkSchema :: Bool
checkSchema = Bool
True in
if Bool
checkSchema
then IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
validateWithRelax IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b XmlTree
S.relaxSchemaArrow IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
else IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
)
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
Int -> String -> IOSArrow XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg 2 "create simplified schema"
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
( (\ (b1 :: Bool
b1, (b2 :: Bool
b2, b3 :: Bool
b3)) -> Bool -> Bool -> Bool -> IOSArrow XmlTree XmlTree
createSimpleForm Bool
b1 Bool
b2 Bool
b3)
((Bool, (Bool, Bool)) -> IOSArrow XmlTree XmlTree)
-> IOSLA (XIOState ()) XmlTree (Bool, (Bool, Bool))
-> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$<
Selector XIOSysState (Bool, (Bool, Bool))
-> IOSLA (XIOState ()) XmlTree (Bool, (Bool, Bool))
forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar (Selector XIOSysState Bool
theRelaxCheckRestr Selector XIOSysState Bool
-> Selector XIOSysState (Bool, Bool)
-> Selector XIOSysState (Bool, (Bool, Bool))
forall s a b. Selector s a -> Selector s b -> Selector s (a, b)
.&&&.
Selector XIOSysState Bool
theRelaxValidateExtRef Selector XIOSysState Bool
-> Selector XIOSysState Bool -> Selector XIOSysState (Bool, Bool)
forall s a b. Selector s a -> Selector s b -> Selector s (a, b)
.&&&.
Selector XIOSysState Bool
theRelaxValidateInclude
)
)
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
String -> IOSArrow XmlTree XmlTree
forall s. String -> IOStateArrow s XmlTree XmlTree
traceDoc "simplified schema"
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
Int -> String -> IOSArrow XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg 2 "collect and issue schema errors"
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform IOSArrow XmlTree XmlTree
handleSimplificationErrors
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
IOSArrow XmlTree XmlTree
resetStates
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
String -> IOSArrow XmlTree XmlTree
forall s. String -> IOStateArrow s XmlTree XmlTree
setDocumentStatusFromSystemState "validating Relax NG schema"
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
documentStatusOk
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
Int -> String -> IOSArrow XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg 2 "Relax NG schema is o.k."
handleSimplificationErrors :: IOSArrow XmlTree XmlTree
handleSimplificationErrors :: IOSArrow XmlTree XmlTree
handleSimplificationErrors
= String -> IOSArrow XmlTree XmlTree
forall s. String -> IOStateArrow s XmlTree XmlTree
traceDoc "simplification errors"
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
IOSArrow XmlTree XmlTree
getErrors
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
IOSLA (XIOState ()) XmlTree String
forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getRngAttrDescr
IOSLA (XIOState ()) XmlTree String
-> IOSLA (XIOState ()) String XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(String -> String) -> IOSLA (XIOState ()) String String
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ("Relax NG validation: " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
IOSLA (XIOState ()) String String
-> IOSLA (XIOState ()) String XmlTree
-> IOSLA (XIOState ()) String XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
Int -> IOSLA (XIOState ()) String XmlTree
forall (a :: * -> * -> *). ArrowXml a => Int -> a String XmlTree
mkError Int
c_err
IOSLA (XIOState ()) String XmlTree
-> IOSArrow XmlTree XmlTree -> IOSLA (XIOState ()) String XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
IOSArrow XmlTree XmlTree
forall s. IOStateArrow s XmlTree XmlTree
filterErrorMsg
validateDocumentWithRelax :: XmlTree -> IOSArrow XmlTree XmlTree
validateDocumentWithRelax :: XmlTree -> IOSArrow XmlTree XmlTree
validateDocumentWithRelax schema :: XmlTree
schema
= ( Int -> String -> IOSArrow XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg 1 "validate document with Relax NG schema"
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform ( IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
validateWithRelax (XmlTree -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA XmlTree
schema) )
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
String -> IOSArrow XmlTree XmlTree
forall s. String -> IOStateArrow s XmlTree XmlTree
setDocumentStatusFromSystemState "validate document with Relax NG schema"
)
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
documentStatusOk
validateSchemaWithSpezification :: String -> IOSArrow XmlTree XmlTree
validateSchemaWithSpezification :: String -> IOSArrow XmlTree XmlTree
validateSchemaWithSpezification relaxSchema :: String
relaxSchema
= String -> String -> IOSArrow XmlTree XmlTree
validateWithSpezification "" String
relaxSchema
validateWithSpezification :: String -> String -> IOSArrow XmlTree XmlTree
validateWithSpezification :: String -> String -> IOSArrow XmlTree XmlTree
validateWithSpezification xmlDocument :: String
xmlDocument relaxSchema :: String
relaxSchema
= [XmlTree] -> IOSArrow XmlTree XmlTree
forall b. [XmlTree] -> IOSLA (XIOState ()) b XmlTree
validDoc ([XmlTree] -> IOSArrow XmlTree XmlTree)
-> IOSLA (XIOState ()) XmlTree [XmlTree]
-> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< IOSArrow XmlTree XmlTree -> IOSLA (XIOState ()) XmlTree [XmlTree]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA (String -> IOSArrow XmlTree XmlTree
validateSchemaWithRelax String
relaxSchema)
where
validDoc :: [XmlTree] -> IOSLA (XIOState ()) b XmlTree
validDoc [theSchema :: XmlTree
theSchema]
| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
xmlDocument
= IOSLA (XIOState ()) b XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
| Bool
otherwise
= IOSLA (XIOState ()) b XmlTree
-> IOSLA (XIOState ()) b XmlTree
-> IOSLA (XIOState ()) b XmlTree
-> IOSLA (XIOState ()) b XmlTree
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d -> a b d
ifA ( String -> IOSLA (XIOState ()) b XmlTree
forall b. String -> IOSArrow b XmlTree
readForRelax String
xmlDocument
IOSLA (XIOState ()) b XmlTree
-> IOSArrow XmlTree XmlTree -> IOSLA (XIOState ()) b XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
normalizeForRelaxValidation
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
XmlTree -> IOSArrow XmlTree XmlTree
validateRelax XmlTree
theSchema
)
IOSLA (XIOState ()) b XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
( String -> IOSLA (XIOState ()) b XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err "Document is not valid with respect to Relax NG Schema" )
validDoc _
= String -> IOSLA (XIOState ()) b XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err "Relax NG Schema not correct"