]> gitweb @ CieloNegro.org - Rakka.git/blob - Rakka/Validation.hs
misc changes
[Rakka.git] / Rakka / Validation.hs
1 module Rakka.Validation
2     ( getValidator
3     )
4     where
5
6 import           Control.Arrow
7 import           Control.Arrow.ArrowList
8 import           Control.Arrow.ArrowTree
9 import           Control.Monad.Reader
10 import           Paths_Rakka -- Cabal が用意する。
11 import           Rakka.Environment
12 import           System.Directory
13 import           System.FilePath
14 import           Text.XML.HXT.Arrow.XmlArrow
15 import           Text.XML.HXT.Arrow.XmlIOStateArrow
16 import           Text.XML.HXT.DOM.TypeDefs
17 import qualified Text.XML.HXT.RelaxNG.Schema as S
18 import           Text.XML.HXT.RelaxNG.Validator
19
20
21 loadSchema :: FilePath -> IO (IOSArrow XmlTree XmlTree)
22 loadSchema fpath
23     = do [schema] <- runX ( setErrorMsgHandler False fail
24                             >>>
25                             readForRelax [] fpath
26                             >>>
27                             perform (validateWithRelaxAndHandleErrors S.relaxSchemaArrow)
28                             >>>
29                             createSimpleForm [] True True True
30                             >>>
31                             perform ( getErrors
32                                       >>>
33                                       getChildren >>> getAttrValue "desc"
34                                       >>>
35                                       arr ("Relax NG validation: " ++ )
36                                       >>>
37                                       mkError c_err
38                                       >>>
39                                       filterErrorMsg
40                                     )
41                           )
42          return $ validateDocumentWithRelax schema
43
44
45 doesLocalDirExist :: IO Bool
46 doesLocalDirExist = doesDirectoryExist "schemas"
47
48
49 getValidator :: MonadIO m => Environment -> FilePath -> m (IOSArrow XmlTree XmlTree)
50 getValidator _ fname
51     = liftIO $
52       do let schemaPath = "schemas" </> fname
53
54          localDirExists <- doesLocalDirExist
55          if localDirExists then
56              loadSchema schemaPath
57            else
58              getDataFileName ("schemas" </> fname) >>= loadSchema