fd820ac · typeable/hjsonschema

changelog.txt+4

@@ -1,3 +1,7 @@

1+# 1.2.0.1

2+

3++ Switch to hspec for tests.

4+

15# 1.2.0.0

26

37+ Return `AdditionalPropertiesObject` error correctly (was mistakenly

hjsonschema.cabal+15−18

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

11name: hjsonschema

2−version: 1.2.0.0

2+version: 1.2.0.1

33synopsis: JSON Schema library

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

55license: MIT

@@ -58,9 +58,9 @@ library

5858 Data.Validator.Draft4.Object.Properties

5959 , Import

6060 build-depends:

61+ base >= 4.7 && < 4.10

6162 -- 0.11 is for `.:!`:

62− aeson >= 0.11 && < 1.1

63− , base >= 4.7 && < 4.10

63+ , aeson >= 0.11 && < 1.1

6464 , bytestring >= 0.10 && < 0.11

6565 , containers >= 0.5 && < 0.6

6666 , file-embed >= 0.0.8 && < 0.1

@@ -82,6 +82,8 @@ test-suite local

8282 hs-source-dirs:

8383 test

8484 examples

85+ main-is: Local.hs

86+ type: exitcode-stdio-1.0

8587 default-language: Haskell2010

8688 ghc-options:

8789 -Wall

@@ -89,8 +91,6 @@ test-suite local

8991 default-extensions:

9092 OverloadedStrings

9193 ScopedTypeVariables

92− type: exitcode-stdio-1.0

93− main-is: Local.hs

9494 other-modules:

9595 Local.Failure

9696 , Local.Reference

@@ -101,8 +101,8 @@ test-suite local

101101 , Full

102102 , Simple

103103 build-depends:

104− aeson

105− , base

104+ base

105+ , aeson

106106 , bytestring

107107 , filepath

108108 , hjsonpointer

@@ -113,17 +113,17 @@ test-suite local

113113 , QuickCheck

114114 , unordered-containers

115115 , vector

116+

116117 -- directory-1.2.5 required for `listDirectory`:

117118 , directory >= 1.2.5 && < 1.3

118− , HUnit >= 1.2 && < 1.4

119− , tasty >= 0.11 && < 0.12

120− , tasty-hunit >= 0.9 && < 0.10

121− , tasty-quickcheck >= 0.8 && < 0.9

119+ , hspec >= 2.2 && < 2.3

122120

123121test-suite remote

124122 hs-source-dirs:

125123 test

126124 examples

125+ main-is: Remote.hs

126+ type: exitcode-stdio-1.0

127127 default-language: Haskell2010

128128 ghc-options:

129129 -Wall

@@ -131,16 +131,14 @@ test-suite remote

131131 default-extensions:

132132 OverloadedStrings

133133 ScopedTypeVariables

134− type: exitcode-stdio-1.0

135− main-is: Remote.hs

136134 other-modules:

137135 Shared

138136 -- from ./examples:

139137 , AlternateSchema

140138 build-depends:

141− aeson

139+ base

140+ , aeson

142141 , async

143− , base

144142 , bytestring

145143 , filepath

146144 , hjsonpointer

@@ -150,10 +148,9 @@ test-suite remote

150148 , text

151149 , unordered-containers

152150 , vector

151+

153152 , directory

154− , HUnit

155− , tasty

156− , tasty-hunit

153+ , hspec

157154 , wai-app-static

158155 , warp

159156

shell.nix+1−3

@@ -2,10 +2,8 @@ with (import <nixpkgs> {});

22

33haskell.lib.buildStackProject {

44 name = "none";

5− ghc = haskell.compiler.ghc801;

5+ inherit ghc;

66 buildInputs = [

7− zlib.dev

8− zlib.out

97 pkgconfig

108 pcre

119 ];

test/Local.hs+33−50

@@ -8,17 +8,15 @@ import Data.Foldable (traverse_)

88import qualified Data.List.NonEmpty as N

99import Data.Monoid

1010import qualified System.Timeout as TO

11−import Test.Tasty (TestTree, defaultMain, testGroup)

12−import qualified Test.Tasty.HUnit as HU

13−import Test.Tasty.QuickCheck (testProperty)

11+import Test.Hspec

12+import Test.QuickCheck (property)

1413

1514import qualified Data.JsonSchema.Draft4 as D4

1615import Data.JsonSchema.Fetch (ReferencedSchemas(..))

1716import qualified Data.JsonSchema.Types as JT

18−import Local.Failure (correctPaths)

19−import Local.Validation (fetchFromFilesystem,

20− generalValidation)

21−import Local.Reference (referenceTests)

17+import qualified Local.Failure

18+import qualified Local.Validation

19+import qualified Local.Reference

2220import Shared

2321

2422-- Examples

@@ -45,47 +43,32 @@ main = do

4543 supplementDir

4644 (\a -> not (isHTTPTest a || skipOptional a))

4745

48− defaultMain . testGroup "Tests not requiring an HTTP server" $

49− [ testGroup

50− "Check that examples compile and don't throw errors"

51− exampleTests

52− , testGroup

53− "QuickCheck tests"

54− quickCheckTests

55− , testGroup

56− "Report the path to invalid data correctly"

57− correctPaths

58− , testGroup

59− "Test the Reference module"

60− referenceTests

61− , testGroup

62− "Test the referencesViaFilesystem function"

63− fetchFromFilesystem

64− , testGroup

65− "Supplementary validation tests written in Haskell"

66− generalValidation

67− , testGroup

68− "Supplementary tests written in JSON (using the record based schema)"

69− (toTest (fmap timeout . validate) <$> supplementTs)

70− , testGroup

71− "Supplementary tests written in JSON (using the 'Value' based schema)"

72− (toTest (fmap timeout . validateExample) <$> supplementTs)

73− , testGroup

74− "Language agnostic local tests (using the record based schema)"

75− (toTest validate <$> ts)

76− , testGroup

77− "Language agnostic local tests (using the 'Value' based schema)"

78− (toTest validateExample <$> ts)

79− ]

46+ hspec $ do

47+ describe "Examples" exampleTests

48+ describe "QuickCheck" quickCheckTests

49+ describe "Failure" Local.Failure.spec

50+ describe "Data.Validator.Reference" Local.Reference.spec

51+ describe "Supplementary validation tests written in Haskell"

52+ Local.Validation.spec

53+

54+ describe "Supplementary tests written in JSON (using the record based schema)"

55+ (traverse_ (toTest (fmap timeout . validate)) supplementTs)

56+ describe "Supplementary tests written in JSON (using the 'Value' based schema)"

57+ (traverse_ (toTest (fmap timeout . validateExample)) supplementTs)

58+

59+ describe "Language agnostic tests (using the record based schema)"

60+ (traverse_ (toTest validate) ts)

61+ describe "Language agnostic tests (using the 'Value' based schema)"

62+ (traverse_ (toTest validateExample) ts)

8063 where

81− timeout :: HU.Assertion -> HU.Assertion

64+ timeout :: Expectation -> Expectation

8265 timeout f = do

8366 res <- TO.timeout 3000000 f

8467 case res of

85− Nothing -> HU.assertFailure "timeout expired"

68+ Nothing -> expectationFailure "timeout expired"

8669 Just a -> pure a

8770

88− validate :: D4.Schema -> SchemaTestCase -> HU.Assertion

71+ validate :: D4.Schema -> SchemaTestCase -> Expectation

8972 validate s sc = do

9073 res <- D4.fetchHTTPAndValidate (D4.SchemaWithURI s Nothing) (_scData sc)

9174 let failures = case res of

@@ -96,7 +79,7 @@ main = do

9679 traverse_ (checkPointer (_scData sc)) failures

9780 assertResult sc failures

9881

99− validateExample :: JT.Schema -> SchemaTestCase -> HU.Assertion

82+ validateExample :: JT.Schema -> SchemaTestCase -> Expectation

10083 validateExample s sc = do

10184 res <- AlternateSchema.referencesViaHTTP (D4.SchemaWithURI s Nothing)

10285 case res of

@@ -108,15 +91,15 @@ main = do

10891 traverse_ (checkPointer (_scData sc)) failures

10992 assertResult sc failures

11093

111−quickCheckTests :: [TestTree]

94+quickCheckTests :: Spec

11295quickCheckTests =

113− [testProperty "Invert schemas through JSON without change" invertSchema]

96+ it "schemas invert through JSON without change" $ do

97+ property invertSchema

11498 where

11599 invertSchema :: D4.Schema -> Bool

116100 invertSchema a = Just a == decode (encode a)

117101

118−exampleTests :: [TestTree]

119−exampleTests =

120− [ HU.testCase "Full example" Full.example

121− , HU.testCase "Simple example" Simple.example

122− ]

102+exampleTests :: Spec

103+exampleTests = do

104+ it "Full.example compiles successfully" Full.example

105+ it "Simple.example compiles successfully" Simple.example

test/Local/Failure.hs+15−21

@@ -6,35 +6,31 @@ import Prelude

66import Data.Aeson

77import qualified Data.Aeson.Pointer as P

88import Data.Monoid

9−import Test.Tasty (TestTree)

10−import qualified Test.Tasty.HUnit as HU

9+import Test.Hspec

1110

1211import Data.JsonSchema.Draft4

1312import Data.JsonSchema.Draft4.Spec (validate)

1413import qualified Data.Validator.Draft4.Array as AR

1514

16−correctPaths :: [TestTree]

17−correctPaths =

18− [ HU.testCase "Items object" itemsObject

19− , HU.testCase "Items array" itemsArray

20− ]

15+spec :: Spec

16+spec = do

17+ it "items array failures are constructed correctly" itemsArray

18+ it "items object failures are constructed correctly" itemsObject

2119

22−itemsObject :: IO ()

23−itemsObject =

24− HU.assertEqual

25− "Path to invalid data"

20+itemsArray :: Expectation

21+itemsArray =

22+ failures `shouldBe`

2623 [Failure (Items UniqueItems) (Bool True) (P.Pointer [P.Token "0"])

2724 (toJSON [True, True])

2825 ]

29− failures

3026 where

3127 failures = validate (ReferencedSchemas schema mempty)

3228 sw (toJSON [[True, True]])

3329

3430 schema :: Schema

3531 schema = emptySchema

36− { _schemaItems = Just $ AR.ItemsObject

37− (emptySchema { _schemaUniqueItems = Just True })

32+ { _schemaItems = Just $ AR.ItemsArray

33+ [emptySchema { _schemaUniqueItems = Just True }]

3834 }

3935

4036 sw :: SchemaWithURI Schema

@@ -43,22 +39,20 @@ itemsObject =

4339 , _swURI = Nothing

4440 }

4541

46−itemsArray :: IO ()

47−itemsArray =

48− HU.assertEqual

49− "Path to invalid data"

42+itemsObject :: Expectation

43+itemsObject =

44+ failures `shouldBe`

5045 [Failure (Items UniqueItems) (Bool True) (P.Pointer [P.Token "0"])

5146 (toJSON [True, True])

5247 ]

53− failures

5448 where

5549 failures = validate (ReferencedSchemas schema mempty)

5650 sw (toJSON [[True, True]])

5751

5852 schema :: Schema

5953 schema = emptySchema

60− { _schemaItems = Just $ AR.ItemsArray

61− [emptySchema { _schemaUniqueItems = Just True }]

54+ { _schemaItems = Just $ AR.ItemsObject

55+ (emptySchema { _schemaUniqueItems = Just True })

6256 }

6357

6458 sw :: SchemaWithURI Schema

test/Local/Reference.hs+29−45

@@ -1,51 +1,35 @@

11

22module Local.Reference where

33

4−import Test.Tasty (TestTree)

5−import qualified Test.Tasty.HUnit as HU

4+import Test.Hspec

65

76import Data.Validator.Reference

87

9−referenceTests :: [TestTree]

10−referenceTests =

11− [ HU.testCase "updateResolutionScope test cases" updateResolutionScopeTests

12− , HU.testCase "resolveReference test cases" resolveReferenceTests

13− ]

14−

15−updateResolutionScopeTests :: IO ()

16−updateResolutionScopeTests = do

17− HU.assertEqual

18− "case 1 result"

19− Nothing

20− (updateResolutionScope Nothing Nothing)

21− HU.assertEqual

22− "case 2 result"

23− Nothing

24− (updateResolutionScope Nothing (Just "#"))

25− HU.assertEqual

26− "case 3 result"

27− (Just "foo")

28− (updateResolutionScope Nothing (Just "foo"))

29− HU.assertEqual

30− "case 4 result"

31− (Just "/./bar") -- TODO: Normalize after updateResolutionScope.

32− (updateResolutionScope (Just "/foo") (Just "./bar"))

33−

34−resolveReferenceTests :: IO ()

35−resolveReferenceTests = do

36− HU.assertEqual

37− "case 1 result"

38− (Just "/bar", Nothing)

39− (resolveReference (Just "/foo") "bar")

40− HU.assertEqual

41− "case 2 result"

42− (Just "/baz", Nothing)

43− (resolveReference (Just "/foo/bar") "/baz")

44− HU.assertEqual

45− "case 3 result"

46− (Nothing, Just "/bar")

47− (resolveReference Nothing "#/bar")

48− HU.assertEqual

49− "case 4 result"

50− (Just "/foo", Just "/bar")

51− (resolveReference (Just "/foo") "#/bar")

8+spec :: Spec

9+spec = do

10+ it "updateResolutionScope gives correct results" $ do

11+ updateResolutionScope Nothing Nothing

12+ `shouldBe` Nothing

13+

14+ updateResolutionScope Nothing (Just "#")

15+ `shouldBe` Nothing

16+

17+ updateResolutionScope Nothing (Just "foo")

18+ `shouldBe` Just "foo"

19+

20+ -- TODO: Normalize after updateResolutionScope:

21+ updateResolutionScope (Just "/foo") (Just "./bar")

22+ `shouldBe` Just "/./bar"

23+

24+ it "resolveReference gives correct results" $ do

25+ resolveReference (Just "/foo") "bar"

26+ `shouldBe` (Just "/bar", Nothing)

27+

28+ resolveReference (Just "/foo/bar") "/baz"

29+ `shouldBe` (Just "/baz", Nothing)

30+

31+ resolveReference Nothing "#/bar"

32+ `shouldBe` (Nothing, Just "/bar")

33+

34+ resolveReference (Just "/foo") "#/bar"

35+ `shouldBe` (Just "/foo", Just "/bar")

test/Local/Validation.hs+28−38

@@ -7,49 +7,50 @@ import qualified Data.Aeson as AE

77import qualified Data.HashMap.Strict as HM

88import Data.Monoid

99import Data.Text (Text)

10−import Test.Tasty (TestTree)

11−import qualified Test.Tasty.HUnit as HU

10+import Test.Hspec

1211

1312import Data.JsonSchema.Draft4

1413import qualified Data.JsonSchema.Types as JT

1514

1615import qualified AlternateSchema as AS

1716

18−fetchFromFilesystem :: [TestTree]

19−fetchFromFilesystem =

20− [ HU.testCase

21− "readFile exceptions are turned into Lefts"

22− readFileExceptions

17+spec :: Spec

18+spec = do

19+ -- Fetching from filesystem.

2320

24− , HU.testCase

25− "Relative reference to local file"

26− (resolve "test/Local/schema.json")

27− , HU.testCase

28− "Chained relative references to local files"

29− (resolve "./test/Local/schema-with-ref.json")

30− ]

21+ it "a readFile exception during validation is turned into a left"

22+ readFileException

23+ it "Relative reference to local file"

24+ (resolutionInvalid "test/Local/schema.json")

25+ it "Chained relative references to local files"

26+ (resolutionInvalid "./test/Local/schema-with-ref.json")

3127

32−readFileExceptions :: IO ()

33−readFileExceptions = do

28+ -- Validation tests that were hard to write in JSON for whatever reason.

29+

30+ it "Don't parse schemas that have Null in a forbidden location"

31+ forbidNull

32+ it "The 'Value' based Schema's checkSchema should catch Nulls"

33+ exampleForbidNull

34+

35+readFileException :: Expectation

36+readFileException = do

37+ let schema = emptySchema { _schemaRef = Just "does-not-exist.json" }

3438 res <- referencesViaFilesystem (SchemaWithURI schema Nothing)

3539 case res of

3640 Left (FSReadFailure _) -> pure ()

37− a -> error (msg <> show a)

41+ a -> expectationFailure (msg <> show a)

3842 where

39− schema :: Schema

40− schema = emptySchema { _schemaRef = Just "does-not-exist.json" }

41−

4243 msg :: String

4344 msg = "expected referencesViaFilesystem to return ReadFailure,"

4445 <> " instead got: "

4546

46−resolve :: Text -> IO ()

47−resolve ref = do

47+resolutionInvalid :: Text -> Expectation

48+resolutionInvalid ref = do

4849 let schema = emptySchema { _schemaRef = Just ref }

4950 res <- fetchFilesystemAndValidate (SchemaWithURI schema Nothing) badData

5051 case res of

5152 Left (FVData _) -> pure ()

52− a -> error (msg <> show a)

53+ a -> expectationFailure (msg <> show a)

5354 where

5455 badData :: Value

5556 badData = toJSON [True, True]

@@ -58,25 +59,14 @@ resolve ref = do

5859 msg = "expected fetchFilesystemAndValidate to return"

5960 <> " Left (FVData [_]), instead got: "

6061

61−-- | Validation tests that were hard to write in JSON for whatever reason.

62−generalValidation :: [TestTree]

63−generalValidation =

64− [ HU.testCase

65− "Don't parse schemas that have Null in a forbidden location"

66− forbidNull

67− , HU.testCase

68− "The 'Value' based Schema's checkSchema should catch Nulls"

69− exampleForbidNull

70− ]

71−

72−forbidNull :: IO ()

62+forbidNull :: Expectation

7363forbidNull =

7464 case fromJSON (Object (HM.singleton "type" Null)) of

7565 AE.Error _ -> pure ()

76− AE.Success a -> HU.assertFailure ("parsed to: " <> show (a :: Schema))

66+ AE.Success a -> expectationFailure ("parsed to: " <> show (a :: Schema))

7767

78−exampleForbidNull :: IO ()

68+exampleForbidNull :: Expectation

7969exampleForbidNull =

8070 case AS.checkSchema (JT.Schema (HM.singleton "type" Null)) of

81− [] -> HU.assertFailure "No checkSchema failures"

71+ [] -> expectationFailure "No checkSchema failures"

8272 _ -> pure ()

test/Remote.hs+9−12

@@ -1,3 +1,4 @@

1+

12module Main where

23

34import Control.Applicative

@@ -8,8 +9,7 @@ import Data.Monoid

89import Network.Wai.Application.Static (defaultFileServerSettings,

910 staticApp)

1011import Network.Wai.Handler.Warp (run)

11−import Test.Tasty (defaultMain, testGroup)

12−import qualified Test.Tasty.HUnit as HU

12+import Test.Hspec

1313

1414import qualified Data.JsonSchema.Draft4 as D4

1515import Data.JsonSchema.Fetch (ReferencedSchemas(..))

@@ -25,16 +25,13 @@ dir = "JSON-Schema-Test-Suite/tests/draft4"

2525main :: IO ()

2626main = withAsync serve $ \_ -> do

2727 ts <- readSchemaTests dir isHTTPTest

28− defaultMain . testGroup "Tests that run an HTTP server" $

29− [ testGroup

30− "Language agnostic remote tests (using the record based schema)"

31− (toTest validate <$> ts)

32− , testGroup

33− "Language agnostic remote tests (using the 'Value' based schema)"

34− (toTest validateExample <$> ts)

35− ]

28+ hspec $ do

29+ describe "Language agnostic tests (using the record based schema)"

30+ (traverse_ (toTest validate) ts)

31+ describe "Language agnostic tests (using the 'Value' based schema)"

32+ (traverse_ (toTest validateExample) ts)

3633 where

37− validate :: D4.Schema -> SchemaTestCase -> HU.Assertion

34+ validate :: D4.Schema -> SchemaTestCase -> Expectation

3835 validate s sc = do

3936 res <- D4.fetchHTTPAndValidate (D4.SchemaWithURI s Nothing) (_scData sc)

4037 let failures = case res of

@@ -45,7 +42,7 @@ main = withAsync serve $ \_ -> do

4542 traverse_ (checkPointer (_scData sc)) failures

4643 assertResult sc failures

4744

48− validateExample :: JT.Schema -> SchemaTestCase -> HU.Assertion

45+ validateExample :: JT.Schema -> SchemaTestCase -> Expectation

4946 validateExample s sc = do

5047 res <- AlternateSchema.referencesViaHTTP (D4.SchemaWithURI s Nothing)

5148 case res of

test/Shared.hs+14−17

@@ -20,8 +20,7 @@ import qualified Data.Vector as V

2020import GHC.Generics

2121import qualified System.Directory as SD

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

23−import Test.Tasty (TestTree)

24−import qualified Test.Tasty.HUnit as HU

23+import Test.Hspec

2524

2625import qualified Data.JsonSchema.Draft4 as D4

2726

@@ -48,7 +47,7 @@ listFilesFullPath path = do

4847 fs <- fmap (path </>) <$> SD.listDirectory path

4948 concat <$> traverse listFilesFullPath fs

5049

51−checkPointer :: Value -> D4.Failure -> HU.Assertion

50+checkPointer :: Value -> D4.Failure -> Expectation

5251checkPointer v failure =

5352 case AP.resolve (D4._failureOffendingPointer failure) v of

5453 Left e -> error ("Couldn't resolve pointer: " <> show e)

@@ -57,18 +56,16 @@ checkPointer v failure =

5756 -- Some validators, such as 'additionalItems', only return a subset

5857 -- of the data incated by their '_failureOffendingPointer'.

5958 -- See the comments on 'Data.Validator.Failure.Failure' for more info.

60− assertContains :: Value -> Value -> HU.Assertion

59+ assertContains :: Value -> Value -> Expectation

6160 assertContains x y

6261 | x == y = pure ()

6362 | otherwise =

6463 case (x,y) of

6564 (Array xs, Array ys) ->

66− HU.assertBool "Pointer resolution incorrect"

67− (V.toList ys `isInfixOf` V.toList xs)

65+ V.toList ys `shouldSatisfy` (`isInfixOf` V.toList xs)

6866 (Object xhm, Object yhm) ->

69− HU.assertBool "Pointer resolution incorrect"

70− (HM.toList yhm `isInfixOf` HM.toList xhm)

71− _ -> HU.assertFailure

67+ HM.toList yhm `shouldSatisfy` (`isInfixOf` HM.toList xhm)

68+ _ -> expectationFailure

7269 "Pointer resolution incorrect: result mismatch"

7370

7471isHTTPTest :: String -> Bool

@@ -132,11 +129,11 @@ readSchemaTests dir filterFunc = do

132129

133130toTest

134131 :: forall schema. FromJSON schema

135− => (schema -> SchemaTestCase -> HU.Assertion)

132+ => (schema -> SchemaTestCase -> Expectation)

136133 -> SchemaTest

137− -> TestTree

134+ -> Spec

138135toTest validate st =

139− HU.testCase (T.unpack (_stDescription st)) $

136+ it (T.unpack (_stDescription st)) $

140137 forM_ (_stCases st) (validate schema)

141138 where

142139 schema :: schema

@@ -144,24 +141,24 @@ toTest validate st =

144141 Error e -> error ("Couldn't parse schema: " <> show e)

145142 Success a -> a

146143

147−assertResult :: SchemaTestCase -> [D4.Failure] -> HU.Assertion

144+assertResult :: SchemaTestCase -> [D4.Failure] -> Expectation

148145assertResult sc failures

149146 | _scValid sc = assertValid sc failures

150147 | otherwise = assertInvalid sc failures

151148

152−assertValid :: SchemaTestCase -> [D4.Failure] -> HU.Assertion

149+assertValid :: SchemaTestCase -> [D4.Failure] -> Expectation

153150assertValid _ [] = pure ()

154151assertValid sc failures =

155− HU.assertFailure $ unlines

152+ expectationFailure $ unlines

156153 [ " Failed to validate data"

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

158155 , " Data: " <> show (_scData sc)

159156 , " Validation failures: " <> show failures

160157 ]

161158

162−assertInvalid :: SchemaTestCase -> [D4.Failure] -> HU.Assertion

159+assertInvalid :: SchemaTestCase -> [D4.Failure] -> Expectation

163160assertInvalid sc [] =

164− HU.assertFailure $ unlines

161+ expectationFailure $ unlines

165162 [ " Validated invalid data"

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

167164 , " Data: " <> show (_scData sc)