Rakka/Validation.hs

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