git.iko.soy/typeable/hjsonschema
on 0.5.3.2 help sign in
typeable/hjsonschema/tests/Lib.hs
105 lines 3.7 kB history raw
1{-# LANGUAGE TemplateHaskell #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
4module Lib where
6import Control.Applicative
7import Control.Monad
8import Data.Aeson
9import Data.Aeson.TH
10import qualified Data.ByteString.Lazy as LBS
11import Data.Char (toLower)
12import qualified Data.HashMap.Strict as H
13import Data.JsonSchema
14import Data.Monoid
15import Data.Text (Text)
16import qualified Data.Text as T
17import Data.Vector (Vector)
18import qualified Data.Vector as V
19import System.FilePath ((</>))
20import Test.Framework (Test)
21import Test.Framework.Providers.HUnit (testCase)
22import Test.HUnit hiding (Test)
24isLocal :: String -> Bool
25isLocal file = (file /= "definitions.json")
26 && (file /= "ref.json")
27 && (file /= "refRemote.json")
29data SchemaTest = SchemaTest
30 { _stDescription :: Text
31 , _stSchema :: RawSchema
32 , _stCases :: [SchemaTestCase]
33 }
35data SchemaTestCase = SchemaTestCase
36 { _scDescription :: Text
37 , _scData :: Value
38 , _scValid :: Bool
39 }
41instance FromJSON RawSchema where
42 parseJSON = withObject "Schema" $ \o ->
43 return RawSchema { _rsURI = "", _rsObject = o }
45instance FromJSON SchemaTest where
46 parseJSON = withObject "SchemaTest" $ \o -> SchemaTest
47 <$> o .: "description"
48 <*> o .: "schema"
49 <*> o .: "tests" -- I wish this were "cases"
51readSchemaTests :: String -> [String] -> IO [SchemaTest]
52readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles
53 where
54 -- Each file contains an array of SchemaTests, not just one.
55 fileToCases :: String -> IO [SchemaTest]
56 fileToCases name = do
57 let fullPath = dir </> name
58 jsonBS <- LBS.readFile fullPath
59 case eitherDecode jsonBS of
60 Left e -> fail $ "couldn't parse file '" <> fullPath <> "': " <> e
61 Right schemaTests -> return $ prependFileName name <$> schemaTests
63 prependFileName :: String -> SchemaTest -> SchemaTest
64 prependFileName fileName s = s
65 { _stDescription = T.pack fileName <> ": " <> _stDescription s
66 }
68 concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
69 concatMapM f xs = liftM concat (mapM f xs)
71toTest :: SchemaTest -> Test
72toTest st =
73 testCase (T.unpack $ _stDescription st) $ do
74 assertEqual "schema validity errors" V.empty $ isValidSchema (_stSchema st)
75 forM_ (_stCases st) $ \sc -> do
76 g <- assertRight =<< fetchRefs draft4 (_stSchema st) H.empty
77 let es = validate (compile draft4 g $ _stSchema st) (_scData sc)
78 if _scValid sc
79 then assertValid sc es
80 else assertInvalid sc es
82assertValid :: SchemaTestCase -> Vector ValErr -> Assertion
83assertValid sc es =
84 unless (V.length es == 0) $ assertFailure $ unlines
85 [ " Failed to validate data"
86 , " Description: " <> T.unpack (_scDescription sc)
87 , " Data: " <> show (_scData sc)
88 , " Errors: " <> show es
89 ]
91assertInvalid :: SchemaTestCase -> Vector ValErr -> Assertion
92assertInvalid sc es =
93 unless (V.length es > 0) $ assertFailure $ unlines
94 [ " Failed to invalidate data"
95 , " Description: " <> T.unpack (_scDescription sc)
96 , " Data: " <> show (_scData sc)
97 ]
99assertRight :: (Show a) => Either a b -> IO b
100assertRight a =
101 case a of
102 Left e -> assertFailure (show e) >> fail "assertRight failed"
103 Right b -> return b
105$(deriveFromJSON defaultOptions { fieldLabelModifier = map toLower . drop 3 } ''SchemaTestCase)