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