@@ -14,11 +14,17 @@ import Data.JsonSchema
1414import Data.Monoid
1515import Data.Text (Text)
1616import qualified Data.Text as T
17+import Data.Vector (Vector)
1718import qualified Data.Vector as V
1819import System.FilePath ((</>))
19−import Test.Framework
20−import Test.Framework.Providers.HUnit
21−import qualified Test.HUnit as HU
20+import Test.Framework (Test)
21+import Test.Framework.Providers.HUnit (testCase)
22+import Test.HUnit hiding (Test)
23+
24+isLocal :: String -> Bool
25+isLocal file = (file /= "definitions.json")
26+ && (file /= "ref.json")
27+ && (file /= "refRemote.json")
2228
2329data SchemaTest = SchemaTest
2430 { _stDescription :: Text
@@ -34,7 +40,7 @@ data SchemaTestCase = SchemaTestCase
3440
3541instance FromJSON RawSchema where
3642 parseJSON = withObject "Schema" $ \o ->
37− return $ RawSchema "" o
43+ return RawSchema { _rsURI = "", _rsObject = o }
3844
3945instance FromJSON SchemaTest where
4046 parseJSON = withObject "SchemaTest" $ \o -> SchemaTest
@@ -42,11 +48,6 @@ instance FromJSON SchemaTest where
4248 <*> o .: "schema"
4349 <*> o .: "tests" -- I wish this were "cases"
4450
45−isLocal :: String -> Bool
46−isLocal file = (file /= "definitions.json")
47− && (file /= "ref.json")
48− && (file /= "refRemote.json")
49−
5051readSchemaTests :: String -> [String] -> IO [SchemaTest]
5152readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles
5253 where
@@ -68,33 +69,37 @@ readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles
6869 concatMapM f xs = liftM concat (mapM f xs)
6970
7071toTest :: SchemaTest -> Test
71−toTest st = testGroup groupName (mkCase <$> _stCases st)
72− where
73− groupName :: String
74− groupName = T.unpack $ _stDescription st
72+toTest 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
7581
76− mkCase :: SchemaTestCase -> Test
77− mkCase sc = testCase caseName assertion
78− where
79− caseName = T.unpack $ _scDescription sc
80− assertion = if _scValid sc
81− then assertValid (_stSchema st) (_scData sc)
82− else assertInvalid (_stSchema st) (_scData sc)
82+assertValid :: SchemaTestCase -> Vector ValErr -> Assertion
83+assertValid 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+ ]
8390
84−assertValid, assertInvalid :: RawSchema -> Value -> HU.Assertion
85−assertValid r v = do
86− g <- assertRight =<< fetchRefs draft4 r H.empty
87− let es = validate (compile draft4 g r) v
88− unless (V.length es == 0) $ HU.assertFailure (show es)
89−assertInvalid r v = do
90− g <- assertRight =<< fetchRefs draft4 r H.empty
91− let es = validate (compile draft4 g r) v
92− when (V.length es == 0) $ HU.assertFailure "expected a validation error"
91+assertInvalid :: SchemaTestCase -> Vector ValErr -> Assertion
92+assertInvalid 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+ ]
9398
9499assertRight :: (Show a) => Either a b -> IO b
95100assertRight a =
96101 case a of
97− Left e -> HU.assertFailure (show e) >> fail "assertRight failed"
102+ Left e -> assertFailure (show e) >> fail "assertRight failed"
98103 Right b -> return b
99104
100105$(deriveFromJSON defaultOptions { fieldLabelModifier = map toLower . drop 3 } ''SchemaTestCase)