6d8a402 · typeable/hjsonschema

README.md+6−6

compare with master

unifiedsplit

@@ -1,12 +1,10 @@

1# Intro

2

3−An implementation of [JSON Schema](http://json-schema.org/) v4 in haskell.

3+An implementation of [JSON Schema](http://json-schema.org/) Draft 4 in haskell.

4

5# Status

6

7−Still in development. Its handling of the `id` keyword passes tests, but is probably incorrect.

7+Still in development. Lacks documentation and solid code to fetch remote schemas.

8−

9−Also lacks documentation and example code.

10

8

11# Install Tests

9# Install Tests

12

10

@@ -23,10 +21,12 @@ Note that the tests require an internet connection.

23

21

24# Notes

22# Notes

25

23

26−This uses the [regexpr](https://hackage.haskell.org/package/regexpr-0.5.4) regular expression library fo the "pattern" validator. I have no idea if this is compatible with the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires.

24++ This uses the [regexpr](https://hackage.haskell.org/package/regexpr-0.5.4) regular expression library fo the "pattern" validator. I have no idea if this is compatible with the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires.

25+

26++ `draft4.json` is from commit # cc8ec81ce0abe2385ebd6c2a6f2d6deb646f874a [here](https://github.com/json-schema/json-schema).

27

28# Credits

29

30Thanks to [Julian Berman](https://github.com/Julian) for the fantastic test suite.

31

32−Also thanks to Tim Baumann for his [aeson-schema](https://hackage.haskell.org/package/aeson-schema) library. Hjsonschema is based on Aeson-Schema, and some code is directly from there.

32+Also thanks to Tim Baumann for his [aeson-schema](https://hackage.haskell.org/package/aeson-schema) library. Hjsonschema's test code and its implementation of Graph both come from Aeson-Schema.

draft4.jsonnew file+150

@@ -0,0 +1,150 @@

1+{

2+ "id": "http://json-schema.org/draft-04/schema#",

3+ "$schema": "http://json-schema.org/draft-04/schema#",

4+ "description": "Core schema meta-schema",

5+ "definitions": {

6+ "schemaArray": {

7+ "type": "array",

8+ "minItems": 1,

9+ "items": { "$ref": "#" }

10+ },

11+ "positiveInteger": {

12+ "type": "integer",

13+ "minimum": 0

14+ },

15+ "positiveIntegerDefault0": {

16+ "allOf": [ { "$ref": "#/definitions/positiveInteger" }, { "default": 0 } ]

17+ },

18+ "simpleTypes": {

19+ "enum": [ "array", "boolean", "integer", "null", "number", "object", "string" ]

20+ },

21+ "stringArray": {

22+ "type": "array",

23+ "items": { "type": "string" },

24+ "minItems": 1,

25+ "uniqueItems": true

26+ }

27+ },

28+ "type": "object",

29+ "properties": {

30+ "id": {

31+ "type": "string",

32+ "format": "uri"

33+ },

34+ "$schema": {

35+ "type": "string",

36+ "format": "uri"

37+ },

38+ "title": {

39+ "type": "string"

40+ },

41+ "description": {

42+ "type": "string"

43+ },

44+ "default": {},

45+ "multipleOf": {

46+ "type": "number",

47+ "minimum": 0,

48+ "exclusiveMinimum": true

49+ },

50+ "maximum": {

51+ "type": "number"

52+ },

53+ "exclusiveMaximum": {

54+ "type": "boolean",

55+ "default": false

56+ },

57+ "minimum": {

58+ "type": "number"

59+ },

60+ "exclusiveMinimum": {

61+ "type": "boolean",

62+ "default": false

63+ },

64+ "maxLength": { "$ref": "#/definitions/positiveInteger" },

65+ "minLength": { "$ref": "#/definitions/positiveIntegerDefault0" },

66+ "pattern": {

67+ "type": "string",

68+ "format": "regex"

69+ },

70+ "additionalItems": {

71+ "anyOf": [

72+ { "type": "boolean" },

73+ { "$ref": "#" }

74+ ],

75+ "default": {}

76+ },

77+ "items": {

78+ "anyOf": [

79+ { "$ref": "#" },

80+ { "$ref": "#/definitions/schemaArray" }

81+ ],

82+ "default": {}

83+ },

84+ "maxItems": { "$ref": "#/definitions/positiveInteger" },

85+ "minItems": { "$ref": "#/definitions/positiveIntegerDefault0" },

86+ "uniqueItems": {

87+ "type": "boolean",

88+ "default": false

89+ },

90+ "maxProperties": { "$ref": "#/definitions/positiveInteger" },

91+ "minProperties": { "$ref": "#/definitions/positiveIntegerDefault0" },

92+ "required": { "$ref": "#/definitions/stringArray" },

93+ "additionalProperties": {

94+ "anyOf": [

95+ { "type": "boolean" },

96+ { "$ref": "#" }

97+ ],

98+ "default": {}

99+ },

100+ "definitions": {

101+ "type": "object",

102+ "additionalProperties": { "$ref": "#" },

103+ "default": {}

104+ },

105+ "properties": {

106+ "type": "object",

107+ "additionalProperties": { "$ref": "#" },

108+ "default": {}

109+ },

110+ "patternProperties": {

111+ "type": "object",

112+ "additionalProperties": { "$ref": "#" },

113+ "default": {}

114+ },

115+ "dependencies": {

116+ "type": "object",

117+ "additionalProperties": {

118+ "anyOf": [

119+ { "$ref": "#" },

120+ { "$ref": "#/definitions/stringArray" }

121+ ]

122+ }

123+ },

124+ "enum": {

125+ "type": "array",

126+ "minItems": 1,

127+ "uniqueItems": true

128+ },

129+ "type": {

130+ "anyOf": [

131+ { "$ref": "#/definitions/simpleTypes" },

132+ {

133+ "type": "array",

134+ "items": { "$ref": "#/definitions/simpleTypes" },

135+ "minItems": 1,

136+ "uniqueItems": true

137+ }

138+ ]

139+ },

140+ "allOf": { "$ref": "#/definitions/schemaArray" },

141+ "anyOf": { "$ref": "#/definitions/schemaArray" },

142+ "oneOf": { "$ref": "#/definitions/schemaArray" },

143+ "not": { "$ref": "#" }

144+ },

145+ "dependencies": {

146+ "exclusiveMaximum": [ "maximum" ],

147+ "exclusiveMinimum": [ "minimum" ]

148+ },

149+ "default": {}

150+}

hjsonschema.cabal+20−15

@@ -1,6 +1,6 @@

1name: hjsonschema

2−version: 0.3.0.0

2+version: 0.4.0.0

3−synopsis: Haskell implementation of JSON Schema v4.

3+synopsis: Haskell implementation of JSON Schema Draft 4.

4homepage: https://github.com/seagreen/hjsonschema

5license: MIT

6license-file: MIT-LICENSE.txt

@@ -9,31 +9,36 @@ maintainer: ian@housejeffries.com

9category: Data

10build-type: Simple

11cabal-version: >=1.10

12−extra-source-files: README.md

12+extra-source-files: draft4.json

13 JSON-Schema-Test-Suite/tests/draft4/*.json

14+ README.md

14 tests/Lib.hs

15 tests/Lib.hs

15

16

16library

17library

17 hs-source-dirs: src

18 hs-source-dirs: src

18 exposed-modules: Data.JsonSchema

19 exposed-modules: Data.JsonSchema

19− , Data.JsonSchema.JsonReference

20+ , Data.JsonSchema.Reference

20 , Data.JsonSchema.Utils

21 , Data.JsonSchema.Utils

21 , Data.JsonSchema.Validators

22 , Data.JsonSchema.Validators

22 other-modules: Data.JsonSchema.Core

23 other-modules: Data.JsonSchema.Core

23 default-language: Haskell2010

24 default-language: Haskell2010

24 default-extensions: OverloadedStrings

25 default-extensions: OverloadedStrings

26+ other-extensions: TemplateHaskell

25 ghc-options: -Wall

27 ghc-options: -Wall

26− build-depends: aeson >= 0.8 && < 0.9

28+ build-depends: aeson >= 0.8 && < 0.9

27− , base >= 4.7 && < 4.8

29+ , base >= 4.7 && < 4.8

28− , bytestring >= 0.10 && < 0.11

30+ , bytestring >= 0.10 && < 0.11

31+ , file-embed >= 0.0.8 && < 0.0.9

29− , hashable >= 1.2 && < 1.3

32+ , hashable >= 1.2 && < 1.3

33+ , hjsonpointer >= 0.1 && < 0.2

34+ , http-types >= 0.8 && < 0.9

30− , lens >= 4.7 && < 4.8

35+ , lens >= 4.7 && < 4.8

31− , regexpr >= 0.5 && < 0.6

36+ , regexpr >= 0.5 && < 0.6

32− , scientific >= 0.3 && < 0.4

37+ , scientific >= 0.3 && < 0.4

33− , unordered-containers >= 0.2 && < 0.3

38+ , unordered-containers >= 0.2 && < 0.3

34− , text >= 1.2 && < 1.3

39+ , text >= 1.2 && < 1.3

35− , vector >= 0.10 && < 0.11

40+ , vector >= 0.10 && < 0.11

36− , wreq >= 0.3 && < 0.4

41+ , wreq >= 0.3 && < 0.4

37

42

38test-suite local

43test-suite local

39 type: exitcode-stdio-1.0

44 type: exitcode-stdio-1.0

src/Data/JsonSchema.hs+27−9

@@ -1,21 +1,26 @@

1+{-# LANGUAGE TemplateHaskell #-}

2+

1module Data.JsonSchema

3module Data.JsonSchema

2 ( module Data.JsonSchema

4 ( module Data.JsonSchema

3 , module Data.JsonSchema.Core

5 , module Data.JsonSchema.Core

4 ) where

6 ) where

5

7

6import Control.Applicative

8import Control.Applicative

9+import Data.Aeson

10+import Data.ByteString.Lazy (fromStrict)

11+import Data.FileEmbed

7import Data.Foldable

12import Data.Foldable

8−import qualified Data.HashMap.Strict as H

13+import qualified Data.HashMap.Strict as H

9import Data.JsonSchema.Core

14import Data.JsonSchema.Core

10−import Data.JsonSchema.JsonReference

15+import Data.JsonSchema.Reference

11import Data.JsonSchema.Utils

16import Data.JsonSchema.Utils

12import Data.JsonSchema.Validators

17import Data.JsonSchema.Validators

13import Data.Maybe

18import Data.Maybe

14−import Data.Text (Text)

19+import Data.Text (Text)

15−import qualified Data.Text as T

20+import qualified Data.Text as T

16−import Data.Vector (Vector)

21+import Data.Vector (Vector)

17−import qualified Data.Vector as V

22+import qualified Data.Vector as V

18−import Prelude hiding (foldr)

23+import Prelude hiding (foldr)

19

24

20draft4 :: Spec

25draft4 :: Spec

21draft4 = Spec $ H.fromList

26draft4 = Spec $ H.fromList

@@ -56,14 +61,14 @@ fetchRefs spec a graph =

56 -- TODO: optimize

61 -- TODO: optimize

57 includeSubschemas :: RawSchema -> Vector RawSchema

62 includeSubschemas :: RawSchema -> Vector RawSchema

58 includeSubschemas r =

63 includeSubschemas r =

59− let newId = updateId (_rsURI r) (_rsObject r)

64+ let newId = newResolutionScope (_rsURI r) (_rsObject r)

60 xs = H.intersectionWith (\(_,f) x -> f newId x) (_unSpec spec) (_rsObject r)

65 xs = H.intersectionWith (\(_,f) x -> f newId x) (_unSpec spec) (_rsObject r)

61 ys = V.concat . H.elems $ xs

66 ys = V.concat . H.elems $ xs

62 in V.cons r . V.concat . V.toList $ includeSubschemas <$> ys

67 in V.cons r . V.concat . V.toList $ includeSubschemas <$> ys

63

68

64 fetch :: Either Text Graph -> RawSchema -> IO (Either Text Graph)

69 fetch :: Either Text Graph -> RawSchema -> IO (Either Text Graph)

65 fetch (Right g) r =

70 fetch (Right g) r =

66− case H.lookup "$ref" (_rsObject r) >>= toTxt >>= refAndP of

71+ case H.lookup "$ref" (_rsObject r) >>= toTxt >>= refAndPointer of

67 Nothing -> return (Right g)

72 Nothing -> return (Right g)

68 Just (s, _) ->

73 Just (s, _) ->

69 let t = (_rsURI r `combineIdAndRef` s)

74 let t = (_rsURI r `combineIdAndRef` s)

@@ -75,3 +80,16 @@ fetchRefs spec a graph =

75 Left e -> return (Left e)

80 Left e -> return (Left e)

76 Right obj -> fetchRefs spec (RawSchema t obj) g

81 Right obj -> fetchRefs spec (RawSchema t obj) g

77 fetch leftGraph _ = return leftGraph

82 fetch leftGraph _ = return leftGraph

83+

84+-- | Check if a schema is valid or not. Just a helper function

85+-- built out of the JSON Schema document which describes valid

86+-- draft 4 schemas and the normal 'compile' and 'validate' functions.

87+isValidSchema :: RawSchema -> Vector ValErr

88+isValidSchema r =

89+ case decode . fromStrict $ $(embedFile "draft4.json") of

90+ Nothing -> V.singleton "Schema decode failed (this should never happen)"

91+ Just s -> do

92+ let draft4Schema = RawSchema { _rsURI = "", _rsObject = s }

93+ validate

94+ (compile draft4 H.empty draft4Schema)

95+ (Object . _rsObject $ r)

src/Data/JsonSchema/Core.hs+2−2

@@ -3,7 +3,7 @@ module Data.JsonSchema.Core where

3import Data.Aeson

4import Data.HashMap.Strict (HashMap)

5import qualified Data.HashMap.Strict as H

6−import Data.JsonSchema.JsonReference

6+import Data.JsonSchema.Reference

7import Data.Maybe

8import Data.Text (Text)

9import Data.Vector (Vector)

@@ -34,7 +34,7 @@ compile spec g (RawSchema t o) =

34 V.fromList . catMaybes . H.elems $ H.intersectionWith f (_unSpec spec) o

35 where

36 f :: (ValidatorGen, a) -> Value -> Maybe Validator

37− f (vGen,_) = vGen spec g $ RawSchema (updateId t o) o

37+ f (vGen,_) = vGen spec g $ RawSchema (newResolutionScope t o) o

38

39validate :: Schema -> Value -> Vector ValErr

40validate s x = s >>= ($ x)

src/Data/JsonSchema/JsonReference.hs → src/Data/JsonSchema/Reference.hsrenamed+7−36

@@ -1,6 +1,4 @@

1−-- | There should be a JSON Reference library for haskell.

2−

3−module Data.JsonSchema.JsonReference where

1+module Data.JsonSchema.Reference where

4

2

5import Control.Exception

3import Control.Exception

6import Control.Lens

4import Control.Lens

@@ -12,10 +10,8 @@ import qualified Data.HashMap.Strict as H

12import Data.Monoid

10import Data.Monoid

13import Data.Text (Text)

11import Data.Text (Text)

14import qualified Data.Text as T

12import qualified Data.Text as T

15−import qualified Data.Vector as V

16import Network.Wreq

13import Network.Wreq

17import Prelude hiding (foldr)

14import Prelude hiding (foldr)

18−import Text.Read (readMaybe)

19

15

20combineIdAndRef :: Text -> Text -> Text

16combineIdAndRef :: Text -> Text -> Text

21combineIdAndRef a b

17combineIdAndRef a b

@@ -32,14 +28,14 @@ combineIds a b

32 | T.last a == '#' && T.head b == '#' = a <> T.tail b

28 | T.last a == '#' && T.head b == '#' = a <> T.tail b

33 | otherwise = a <> b

29 | otherwise = a <> b

34

30

35−updateId :: Text -> HashMap Text Value -> Text

31+newResolutionScope :: Text -> HashMap Text Value -> Text

36−updateId t o =

32+newResolutionScope t o =

37 case H.lookup "id" o of

33 case H.lookup "id" o of

38− Just (String idVal) -> t `combineIds` idVal

34+ Just (String idKeyword) -> t `combineIds` idKeyword

39− _ -> t

35+ _ -> t

40

36

41−refAndP :: Text -> Maybe (Text, Text)

37+refAndPointer :: Text -> Maybe (Text, Text)

42−refAndP val = getParts $ T.splitOn "#" val

38+refAndPointer val = getParts $ T.splitOn "#" val

43 where

39 where

44 getParts :: [Text] -> Maybe (Text, Text)

40 getParts :: [Text] -> Maybe (Text, Text)

45 getParts [] = Just ("","")

41 getParts [] = Just ("","")

@@ -67,28 +63,3 @@ safeGet url =

67 where

63 where

68 handler :: SomeException -> IO (Either Text ByteString)

64 handler :: SomeException -> IO (Either Text ByteString)

69 handler e = return . Left . T.pack . show $ e

65 handler e = return . Left . T.pack . show $ e

70−

71−-- | There should be a JSON Pointer library.

72−--

73−-- Spec: http://tools.ietf.org/html/draft-ietf-appsawg-json-pointer-07

74−jsonPointer :: Text -> Value -> Maybe Value

75−jsonPointer pntr = resolve (T.splitOn "/" pntr)

76− where

77− resolve :: [Text] -> Value -> Maybe Value

78− resolve (referenceToken:ts) a =

79− let t = unescape referenceToken

80− in case T.length t of

81− 0 -> resolve ts a

82− _ ->

83− case a of

84− (Object b) -> H.lookup t b >>= resolve ts

85− (Array c) -> do

86− n <- readMaybe (T.unpack t)

87− when (n < 0 || n + 1 > V.length c) Nothing

88− resolve ts (c V.! n)

89− _ -> Nothing

90− resolve _ a = Just a

91−

92− -- TODO: do more things need to be escaped?

93− unescape :: Text -> Text

94− unescape t = T.replace "%25" "%" $ T.replace "~0" "~" $ T.replace "~1" "/" t

src/Data/JsonSchema/Utils.hs−2

@@ -1,5 +1,3 @@

1−{-# LANGUAGE OverloadedLists #-}

2−

3module Data.JsonSchema.Utils where

1module Data.JsonSchema.Utils where

4

2

5import Data.Aeson

3import Data.Aeson

src/Data/JsonSchema/Validators.hs+10−11

@@ -39,16 +39,19 @@ import Data.Fixed (mod')

39import Data.Hashable

40import Data.HashMap.Strict (HashMap)

41import qualified Data.HashMap.Strict as H

42+import Data.JsonPointer

42import Data.JsonSchema.Core

43import Data.JsonSchema.Core

43−import Data.JsonSchema.JsonReference

44+import Data.JsonSchema.Reference

44import Data.JsonSchema.Utils

45import Data.JsonSchema.Utils

45import Data.Maybe

46import Data.Maybe

46import Data.Monoid

47import Data.Monoid

47import Data.Text (Text)

48import Data.Text (Text)

48import qualified Data.Text as T

49import qualified Data.Text as T

50+import Data.Text.Encoding

49import Data.Traversable

51import Data.Traversable

50import Data.Vector (Vector)

52import Data.Vector (Vector)

51import qualified Data.Vector as V

53import qualified Data.Vector as V

54+import Network.HTTP.Types.URI

52import Text.RegexPR

55import Text.RegexPR

53

56

54--------------------------------------------------

57--------------------------------------------------

@@ -513,17 +516,13 @@ notValidator _ _ _ _ = Nothing

513-- ignored.

516-- ignored.

514ref :: ValidatorGen

517ref :: ValidatorGen

515ref spec g s (String val) = do

518ref spec g s (String val) = do

516− (reference, pointer) <- refAndP (_rsURI s `combineIdAndRef` val)

519+ (reference, pointer) <- refAndPointer (_rsURI s `combineIdAndRef` val)

517 r <- RawSchema reference <$> H.lookup reference g

520 r <- RawSchema reference <$> H.lookup reference g

518− sc <- pointerToSchema pointer r

521+ let p = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer

522+ case jsonPointer p >>= resolvePointer (Object $ _rsObject r) of

523+ Right (Object o) ->

519− Just $ validate (compile spec g sc)

524+ Just $ validate $ compile spec g $ RawSchema (_rsURI r) o

520− where

521− pointerToSchema :: Text -> RawSchema -> Maybe RawSchema

522− pointerToSchema pntr rawS = do

523− mVal <- jsonPointer pntr (Object . _rsObject $ rawS)

524− case mVal of

525− (Object o) -> Just $ RawSchema (_rsURI rawS) o

526− _ -> Nothing

525+ _ -> Nothing

527ref _ _ _ _ = Nothing

526ref _ _ _ _ = Nothing

528

527

529noVal :: ValidatorGen

528noVal :: ValidatorGen

tests/Lib.hs+35−30

@@ -14,11 +14,17 @@ import Data.JsonSchema

14import Data.Monoid

15import Data.Text (Text)

16import qualified Data.Text as T

17+import Data.Vector (Vector)

17import qualified Data.Vector as V

18import qualified Data.Vector as V

18import System.FilePath ((</>))

19import System.FilePath ((</>))

19−import Test.Framework

20+import Test.Framework (Test)

20−import Test.Framework.Providers.HUnit

21+import Test.Framework.Providers.HUnit (testCase)

21−import qualified Test.HUnit as HU

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")

22

28

23data SchemaTest = SchemaTest

29data SchemaTest = SchemaTest

24 { _stDescription :: Text

30 { _stDescription :: Text

@@ -34,7 +40,7 @@ data SchemaTestCase = SchemaTestCase

34

40

35instance FromJSON RawSchema where

41instance FromJSON RawSchema where

36 parseJSON = withObject "Schema" $ \o ->

42 parseJSON = withObject "Schema" $ \o ->

37− return $ RawSchema "" o

43+ return RawSchema { _rsURI = "", _rsObject = o }

38

44

39instance FromJSON SchemaTest where

45instance FromJSON SchemaTest where

40 parseJSON = withObject "SchemaTest" $ \o -> SchemaTest

46 parseJSON = withObject "SchemaTest" $ \o -> SchemaTest

@@ -42,11 +48,6 @@ instance FromJSON SchemaTest where

42 <*> o .: "schema"

48 <*> o .: "schema"

43 <*> o .: "tests" -- I wish this were "cases"

49 <*> o .: "tests" -- I wish this were "cases"

44

50

45−isLocal :: String -> Bool

46−isLocal file = (file /= "definitions.json")

47− && (file /= "ref.json")

48− && (file /= "refRemote.json")

49−

50readSchemaTests :: String -> [String] -> IO [SchemaTest]

51readSchemaTests :: String -> [String] -> IO [SchemaTest]

51readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles

52readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles

52 where

53 where

@@ -68,33 +69,37 @@ readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles

68 concatMapM f xs = liftM concat (mapM f xs)

69 concatMapM f xs = liftM concat (mapM f xs)

69

70

70toTest :: SchemaTest -> Test

71toTest :: SchemaTest -> Test

71−toTest st = testGroup groupName (mkCase <$> _stCases st)

72+toTest st =

72− where

73− groupName :: String

74− groupName = T.unpack $ _stDescription 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

75

81

76− mkCase :: SchemaTestCase -> Test

82+assertValid :: SchemaTestCase -> Vector ValErr -> Assertion

77− mkCase sc = testCase caseName assertion

83+assertValid sc es =

78− where

84+ unless (V.length es == 0) $ assertFailure $ unlines

85+ [ " Failed to validate data"

79− caseName = T.unpack $ _scDescription sc

86+ , " Description: " <> T.unpack (_scDescription sc)

80− assertion = if _scValid sc

87+ , " Data: " <> show (_scData sc)

81− then assertValid (_stSchema st) (_scData sc)

88+ , " Errors: " <> show es

82− else assertInvalid (_stSchema st) (_scData sc)

89+ ]

83

90

84−assertValid, assertInvalid :: RawSchema -> Value -> HU.Assertion

91+assertInvalid :: SchemaTestCase -> Vector ValErr -> Assertion

85−assertValid r v = do

92+assertInvalid sc es =

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)

93+ unless (V.length es > 0) $ assertFailure $ unlines

89−assertInvalid r v = do

94+ [ " Failed to invalidate data"

90− g <- assertRight =<< fetchRefs draft4 r H.empty

95+ , " Description: " <> T.unpack (_scDescription sc)

91− let es = validate (compile draft4 g r) v

96+ , " Data: " <> show (_scData sc)

92− when (V.length es == 0) $ HU.assertFailure "expected a validation error"

97+ ]

93

98

94assertRight :: (Show a) => Either a b -> IO b

99assertRight :: (Show a) => Either a b -> IO b

95assertRight a =

100assertRight a =

96 case a of

101 case a of

97− Left e -> HU.assertFailure (show e) >> fail "assertRight failed"

102+ Left e -> assertFailure (show e) >> fail "assertRight failed"

98 Right b -> return b

103 Right b -> return b

99

104

100$(deriveFromJSON defaultOptions { fieldLabelModifier = map toLower . drop 3 } ''SchemaTestCase)

105$(deriveFromJSON defaultOptions { fieldLabelModifier = map toLower . drop 3 } ''SchemaTestCase)

tests/Local.hs+3−3

@@ -8,9 +8,9 @@ import Test.Framework

8

9main :: IO ()

10main = do

11− files <- filter isLocal . filter (".json" `isSuffixOf`)

11+ filenames <- filter isLocal . filter (".json" `isSuffixOf`)

12− <$> getDirectoryContents dir

12+ <$> getDirectoryContents dir

13− ts <- readSchemaTests dir files

13+ ts <- readSchemaTests dir filenames

14 defaultMain (toTest <$> ts)

15

16 where

tests/Remote.hs+3−3