hjsonschema 1.2.0.0 → 1.2.0.1

raw patch · 8 files changed

+145/−199 lines, 8 filesdep +hspecdep −HUnitdep −tastydep −tasty-hunitPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hspec

Dependencies removed: HUnit, tasty, tasty-hunit, tasty-quickcheck

API changes (from Hackage documentation)

Files

• changelog.txt +4/−0
• hjsonschema.cabal +15/−18
• test/Local.hs +33/−50
• test/Local/Failure.hs +15/−21
• test/Local/Reference.hs +27/−43
• test/Local/Validation.hs +28/−38
• test/Remote.hs +9/−12
• test/Shared.hs +14/−17

@@ -1,3 +1,7 @@+# 1.2.0.1+++ Switch to hspec for tests.+ # 1.2.0.0  + Return `AdditionalPropertiesObject` error correctly (was mistakenly

@@ -1,5 +1,5 @@ name:               hjsonschema-version:            1.2.0.0+version:            1.2.0.1 synopsis:           JSON Schema library homepage:           https://github.com/seagreen/hjsonschema license:            MIT@@ -58,9 +58,9 @@       Data.Validator.Draft4.Object.Properties     , Import   build-depends:+      base                 >= 4.7    && < 4.10     -- 0.11 is for `.:!`:-      aeson                >= 0.11   && < 1.1-    , base                 >= 4.7    && < 4.10+    , aeson                >= 0.11   && < 1.1     , bytestring           >= 0.10   && < 0.11     , containers           >= 0.5    && < 0.6     , file-embed           >= 0.0.8  && < 0.1@@ -82,6 +82,8 @@   hs-source-dirs:     test     examples+  main-is: Local.hs+  type: exitcode-stdio-1.0   default-language: Haskell2010   ghc-options:     -Wall@@ -89,8 +91,6 @@   default-extensions:     OverloadedStrings     ScopedTypeVariables-  type: exitcode-stdio-1.0-  main-is: Local.hs   other-modules:       Local.Failure     , Local.Reference@@ -101,8 +101,8 @@     , Full     , Simple   build-depends:-      aeson-    , base+      base+    , aeson     , bytestring     , filepath     , hjsonpointer@@ -113,17 +113,17 @@     , QuickCheck     , unordered-containers     , vector+     -- directory-1.2.5 required for `listDirectory`:     , directory            >= 1.2.5 && < 1.3-    , HUnit                >= 1.2   && < 1.4-    , tasty                >= 0.11  && < 0.12-    , tasty-hunit          >= 0.9   && < 0.10-    , tasty-quickcheck     >= 0.8   && < 0.9+    , hspec                >= 2.2 && < 2.3  test-suite remote   hs-source-dirs:     test     examples+  main-is: Remote.hs+  type: exitcode-stdio-1.0   default-language: Haskell2010   ghc-options:     -Wall@@ -131,16 +131,14 @@   default-extensions:     OverloadedStrings     ScopedTypeVariables-  type: exitcode-stdio-1.0-  main-is: Remote.hs   other-modules:       Shared     -- from ./examples:     , AlternateSchema   build-depends:-      aeson+      base+    , aeson     , async-    , base     , bytestring     , filepath     , hjsonpointer@@ -150,10 +148,9 @@     , text     , unordered-containers     , vector+     , directory-    , HUnit-    , tasty-    , tasty-hunit+    , hspec     , wai-app-static     , warp 

@@ -8,17 +8,15 @@ import qualified Data.List.NonEmpty     as N import           Data.Monoid import qualified System.Timeout         as TO-import           Test.Tasty             (TestTree, defaultMain, testGroup)-import qualified Test.Tasty.HUnit       as HU-import           Test.Tasty.QuickCheck  (testProperty)+import           Test.Hspec+import           Test.QuickCheck        (property)  import qualified Data.JsonSchema.Draft4 as D4 import           Data.JsonSchema.Fetch  (ReferencedSchemas(..)) import qualified Data.JsonSchema.Types  as JT-import           Local.Failure          (correctPaths)-import           Local.Validation       (fetchFromFilesystem,-                                         generalValidation)-import           Local.Reference        (referenceTests)+import qualified Local.Failure+import qualified Local.Validation+import qualified Local.Reference import           Shared  -- Examples@@ -45,47 +43,32 @@                         supplementDir                         (\a -> not (isHTTPTest a || skipOptional a)) -    defaultMain . testGroup "Tests not requiring an HTTP server" $-        [ testGroup-            "Check that examples compile and don't throw errors"-            exampleTests-        , testGroup-            "QuickCheck tests"-            quickCheckTests-        , testGroup-            "Report the path to invalid data correctly"-            correctPaths-        , testGroup-            "Test the Reference module"-            referenceTests-        , testGroup-            "Test the referencesViaFilesystem function"-            fetchFromFilesystem-        , testGroup-            "Supplementary validation tests written in Haskell"-            generalValidation-        , testGroup-            "Supplementary tests written in JSON (using the record based schema)"-            (toTest (fmap timeout . validate) <$> supplementTs)-        , testGroup-            "Supplementary tests written in JSON (using the 'Value' based schema)"-            (toTest (fmap timeout . validateExample) <$> supplementTs)-        , testGroup-            "Language agnostic local tests (using the record based schema)"-            (toTest validate <$> ts)-        , testGroup-            "Language agnostic local tests (using the 'Value' based schema)"-            (toTest validateExample <$> ts)-        ]+    hspec $ do+        describe "Examples" exampleTests+        describe "QuickCheck" quickCheckTests+        describe "Failure" Local.Failure.spec+        describe "Data.Validator.Reference" Local.Reference.spec+        describe "Supplementary validation tests written in Haskell"+            Local.Validation.spec++        describe "Supplementary tests written in JSON (using the record based schema)"+            (traverse_ (toTest (fmap timeout . validate)) supplementTs)+        describe "Supplementary tests written in JSON (using the 'Value' based schema)"+            (traverse_ (toTest (fmap timeout . validateExample)) supplementTs)++        describe "Language agnostic tests (using the record based schema)"+            (traverse_ (toTest validate) ts)+        describe "Language agnostic tests (using the 'Value' based schema)"+            (traverse_ (toTest validateExample) ts)   where-    timeout :: HU.Assertion -> HU.Assertion+    timeout :: Expectation -> Expectation     timeout f = do         res <- TO.timeout 3000000 f         case res of-            Nothing -> HU.assertFailure "timeout expired"+            Nothing -> expectationFailure "timeout expired"             Just a  -> pure a -    validate :: D4.Schema -> SchemaTestCase -> HU.Assertion+    validate :: D4.Schema -> SchemaTestCase -> Expectation     validate s sc = do         res <- D4.fetchHTTPAndValidate (D4.SchemaWithURI s Nothing) (_scData sc)         let failures = case res of@@ -96,7 +79,7 @@         traverse_ (checkPointer (_scData sc)) failures         assertResult sc failures -    validateExample :: JT.Schema -> SchemaTestCase -> HU.Assertion+    validateExample :: JT.Schema -> SchemaTestCase -> Expectation     validateExample s sc = do         res <- AlternateSchema.referencesViaHTTP (D4.SchemaWithURI s Nothing)         case res of@@ -108,15 +91,15 @@                 traverse_ (checkPointer (_scData sc)) failures                 assertResult sc failures -quickCheckTests :: [TestTree]+quickCheckTests :: Spec quickCheckTests =-    [testProperty "Invert schemas through JSON without change" invertSchema]+    it "schemas invert through JSON without change" $ do+        property invertSchema   where     invertSchema :: D4.Schema -> Bool     invertSchema a = Just a == decode (encode a) -exampleTests :: [TestTree]-exampleTests =-    [ HU.testCase "Full example" Full.example-    , HU.testCase "Simple example" Simple.example-    ]+exampleTests :: Spec+exampleTests = do+    it "Full.example compiles successfully" Full.example+    it "Simple.example compiles successfully" Simple.example

@@ -6,35 +6,31 @@ import           Data.Aeson import qualified Data.Aeson.Pointer          as P import           Data.Monoid-import           Test.Tasty                  (TestTree)-import qualified Test.Tasty.HUnit            as HU+import           Test.Hspec  import           Data.JsonSchema.Draft4 import           Data.JsonSchema.Draft4.Spec (validate) import qualified Data.Validator.Draft4.Array as AR -correctPaths :: [TestTree]-correctPaths =-    [ HU.testCase "Items object" itemsObject-    , HU.testCase "Items array" itemsArray-    ]+spec :: Spec+spec = do+    it "items array failures are constructed correctly" itemsArray+    it "items object failures are constructed correctly" itemsObject -itemsObject :: IO ()-itemsObject =-    HU.assertEqual-        "Path to invalid data"+itemsArray :: Expectation+itemsArray =+    failures `shouldBe`         [Failure (Items UniqueItems) (Bool True) (P.Pointer [P.Token "0"])                  (toJSON [True, True])         ]-        failures   where     failures = validate (ReferencedSchemas schema mempty)                         sw (toJSON [[True, True]])      schema :: Schema     schema = emptySchema-        { _schemaItems = Just $ AR.ItemsObject-            (emptySchema { _schemaUniqueItems = Just True })+        { _schemaItems = Just $ AR.ItemsArray+            [emptySchema { _schemaUniqueItems = Just True }]         }      sw :: SchemaWithURI Schema@@ -43,22 +39,20 @@         , _swURI    = Nothing         } -itemsArray :: IO ()-itemsArray =-    HU.assertEqual-        "Path to invalid data"+itemsObject :: Expectation+itemsObject =+    failures `shouldBe`         [Failure (Items UniqueItems) (Bool True) (P.Pointer [P.Token "0"])                  (toJSON [True, True])         ]-        failures   where     failures = validate (ReferencedSchemas schema mempty)                         sw (toJSON [[True, True]])      schema :: Schema     schema = emptySchema-        { _schemaItems = Just $ AR.ItemsArray-            [emptySchema { _schemaUniqueItems = Just True }]+        { _schemaItems = Just $ AR.ItemsObject+            (emptySchema { _schemaUniqueItems = Just True })         }      sw :: SchemaWithURI Schema

@@ -1,51 +1,35 @@  module Local.Reference where -import           Test.Tasty               (TestTree)-import qualified Test.Tasty.HUnit         as HU+import           Test.Hspec  import           Data.Validator.Reference -referenceTests :: [TestTree]-referenceTests =-    [ HU.testCase "updateResolutionScope test cases" updateResolutionScopeTests-    , HU.testCase "resolveReference test cases" resolveReferenceTests-    ]+spec :: Spec+spec = do+    it "updateResolutionScope gives correct results" $ do+        updateResolutionScope Nothing Nothing+            `shouldBe` Nothing -updateResolutionScopeTests :: IO ()-updateResolutionScopeTests = do-    HU.assertEqual-        "case 1 result"-        Nothing-        (updateResolutionScope Nothing Nothing)-    HU.assertEqual-        "case 2 result"-        Nothing-        (updateResolutionScope Nothing (Just "#"))-    HU.assertEqual-        "case 3 result"-        (Just "foo")-        (updateResolutionScope Nothing (Just "foo"))-    HU.assertEqual-        "case 4 result"-        (Just "/./bar") -- TODO: Normalize after updateResolutionScope.-        (updateResolutionScope (Just "/foo") (Just "./bar"))+        updateResolutionScope Nothing (Just "#")+            `shouldBe` Nothing -resolveReferenceTests :: IO ()-resolveReferenceTests = do-    HU.assertEqual-        "case 1 result"-        (Just "/bar", Nothing)-        (resolveReference (Just "/foo") "bar")-    HU.assertEqual-        "case 2 result"-        (Just "/baz", Nothing)-        (resolveReference (Just "/foo/bar") "/baz")-    HU.assertEqual-        "case 3 result"-        (Nothing, Just "/bar")-        (resolveReference Nothing "#/bar")-    HU.assertEqual-        "case 4 result"-        (Just "/foo", Just "/bar")-        (resolveReference (Just "/foo") "#/bar")+        updateResolutionScope Nothing (Just "foo")+            `shouldBe` Just "foo"++        -- TODO: Normalize after updateResolutionScope:+        updateResolutionScope (Just "/foo") (Just "./bar")+            `shouldBe` Just "/./bar"++    it "resolveReference  gives correct results" $ do+        resolveReference (Just "/foo") "bar"+            `shouldBe` (Just "/bar", Nothing)++        resolveReference (Just "/foo/bar") "/baz"+            `shouldBe` (Just "/baz", Nothing)++        resolveReference Nothing "#/bar"+            `shouldBe` (Nothing, Just "/bar")++        resolveReference (Just "/foo") "#/bar"+            `shouldBe` (Just "/foo", Just "/bar")

@@ -7,49 +7,50 @@ import qualified Data.HashMap.Strict    as HM import           Data.Monoid import           Data.Text              (Text)-import           Test.Tasty             (TestTree)-import qualified Test.Tasty.HUnit       as HU+import           Test.Hspec  import           Data.JsonSchema.Draft4 import qualified Data.JsonSchema.Types  as JT  import qualified AlternateSchema        as AS -fetchFromFilesystem :: [TestTree]-fetchFromFilesystem =-    [ HU.testCase-        "readFile exceptions are turned into Lefts"-        readFileExceptions+spec :: Spec+spec = do+    -- Fetching from filesystem. -    , HU.testCase-        "Relative reference to local file"-        (resolve "test/Local/schema.json")-    , HU.testCase-        "Chained relative references to local files"-        (resolve "./test/Local/schema-with-ref.json")-    ]+    it "a readFile exception during validation is turned into a left"+        readFileException+    it "Relative reference to local file"+        (resolutionInvalid "test/Local/schema.json")+    it "Chained relative references to local files"+        (resolutionInvalid "./test/Local/schema-with-ref.json") -readFileExceptions :: IO ()-readFileExceptions = do+    -- Validation tests that were hard to write in JSON for whatever reason.++    it "Don't parse schemas that have Null in a forbidden location"+        forbidNull+    it "The 'Value' based Schema's checkSchema should catch Nulls"+        exampleForbidNull++readFileException :: Expectation+readFileException = do+    let schema = emptySchema { _schemaRef = Just "does-not-exist.json" }     res <- referencesViaFilesystem (SchemaWithURI schema Nothing)     case res of         Left (FSReadFailure _) -> pure ()-        a                      -> error (msg <> show a)+        a                      -> expectationFailure (msg <> show a)   where-    schema :: Schema-    schema = emptySchema { _schemaRef = Just "does-not-exist.json" }-     msg :: String     msg = "expected referencesViaFilesystem to return ReadFailure,"        <> " instead got: " -resolve :: Text -> IO ()-resolve ref = do+resolutionInvalid :: Text -> Expectation+resolutionInvalid ref = do     let schema = emptySchema { _schemaRef = Just ref }     res <- fetchFilesystemAndValidate (SchemaWithURI schema Nothing) badData     case res of         Left (FVData _) -> pure ()-        a               -> error (msg <> show a)+        a               -> expectationFailure (msg <> show a)   where     badData :: Value     badData = toJSON [True, True]@@ -58,25 +59,14 @@     msg = "expected fetchFilesystemAndValidate to return"        <> " Left (FVData [_]), instead got: " --- | Validation tests that were hard to write in JSON for whatever reason.-generalValidation :: [TestTree]-generalValidation =-    [ HU.testCase-        "Don't parse schemas that have Null in a forbidden location"-        forbidNull-    , HU.testCase-        "The 'Value' based Schema's checkSchema should catch Nulls"-        exampleForbidNull-    ]--forbidNull :: IO ()+forbidNull :: Expectation forbidNull =     case fromJSON (Object (HM.singleton "type" Null)) of         AE.Error _   -> pure ()-        AE.Success a -> HU.assertFailure ("parsed to: " <> show (a :: Schema))+        AE.Success a -> expectationFailure ("parsed to: " <> show (a :: Schema)) -exampleForbidNull :: IO ()+exampleForbidNull :: Expectation exampleForbidNull =     case AS.checkSchema (JT.Schema (HM.singleton "type" Null)) of-        [] -> HU.assertFailure "No checkSchema failures"+        [] -> expectationFailure "No checkSchema failures"         _  -> pure ()

@@ -1,3 +1,4 @@+ module Main where  import           Control.Applicative@@ -8,8 +9,7 @@ import           Network.Wai.Application.Static (defaultFileServerSettings,                                                  staticApp) import           Network.Wai.Handler.Warp       (run)-import           Test.Tasty                     (defaultMain, testGroup)-import qualified Test.Tasty.HUnit               as HU+import           Test.Hspec  import qualified Data.JsonSchema.Draft4         as D4 import           Data.JsonSchema.Fetch          (ReferencedSchemas(..))@@ -25,16 +25,13 @@ main :: IO () main = withAsync serve $ \_ -> do     ts <- readSchemaTests dir isHTTPTest-    defaultMain . testGroup "Tests that run an HTTP server" $-        [ testGroup-            "Language agnostic remote tests (using the record based schema)"-            (toTest validate <$> ts)-        , testGroup-            "Language agnostic remote tests (using the 'Value' based schema)"-            (toTest validateExample <$> ts)-        ]+    hspec $ do+        describe "Language agnostic tests (using the record based schema)"+            (traverse_ (toTest validate) ts)+        describe "Language agnostic tests (using the 'Value' based schema)"+            (traverse_ (toTest validateExample) ts)   where-    validate :: D4.Schema -> SchemaTestCase -> HU.Assertion+    validate :: D4.Schema -> SchemaTestCase -> Expectation     validate s sc = do         res <- D4.fetchHTTPAndValidate (D4.SchemaWithURI s Nothing) (_scData sc)         let failures = case res of@@ -45,7 +42,7 @@         traverse_ (checkPointer (_scData sc)) failures         assertResult sc failures -    validateExample :: JT.Schema -> SchemaTestCase -> HU.Assertion+    validateExample :: JT.Schema -> SchemaTestCase -> Expectation     validateExample s sc = do         res <- AlternateSchema.referencesViaHTTP (D4.SchemaWithURI s Nothing)         case res of

@@ -20,8 +20,7 @@ import           GHC.Generics import qualified System.Directory       as SD import           System.FilePath        ((</>))-import           Test.Tasty             (TestTree)-import qualified Test.Tasty.HUnit       as HU+import           Test.Hspec  import qualified Data.JsonSchema.Draft4 as D4 @@ -48,7 +47,7 @@             fs <- fmap (path </>) <$> SD.listDirectory path             concat <$> traverse listFilesFullPath fs -checkPointer :: Value -> D4.Failure -> HU.Assertion+checkPointer :: Value -> D4.Failure -> Expectation checkPointer v failure =     case AP.resolve (D4._failureOffendingPointer failure) v of         Left e  -> error ("Couldn't resolve pointer: " <> show e)@@ -57,18 +56,16 @@     -- Some validators, such as 'additionalItems', only return a subset     -- of the data incated by their '_failureOffendingPointer'.     -- See the comments on 'Data.Validator.Failure.Failure' for more info.-    assertContains :: Value -> Value -> HU.Assertion+    assertContains :: Value -> Value -> Expectation     assertContains x y         | x == y    = pure ()         | otherwise =             case (x,y) of                 (Array xs, Array ys) ->-                    HU.assertBool "Pointer resolution incorrect"-                                  (V.toList ys `isInfixOf` V.toList xs)+                    V.toList ys `shouldSatisfy` (`isInfixOf` V.toList xs)                 (Object xhm, Object yhm) ->-                    HU.assertBool "Pointer resolution incorrect"-                                  (HM.toList yhm `isInfixOf` HM.toList xhm)-                _ -> HU.assertFailure+                    HM.toList yhm `shouldSatisfy` (`isInfixOf` HM.toList xhm)+                _ -> expectationFailure                         "Pointer resolution incorrect: result mismatch"  isHTTPTest :: String -> Bool@@ -132,11 +129,11 @@  toTest   :: forall schema. FromJSON schema-  => (schema -> SchemaTestCase -> HU.Assertion)+  => (schema -> SchemaTestCase -> Expectation)   -> SchemaTest-  -> TestTree+  -> Spec toTest validate st =-    HU.testCase (T.unpack (_stDescription st)) $+    it (T.unpack (_stDescription st)) $         forM_ (_stCases st) (validate schema)   where     schema :: schema@@ -144,24 +141,24 @@                  Error e   -> error ("Couldn't parse schema: " <> show e)                  Success a -> a -assertResult :: SchemaTestCase -> [D4.Failure] -> HU.Assertion+assertResult :: SchemaTestCase -> [D4.Failure] -> Expectation assertResult sc failures     | _scValid sc = assertValid sc failures     | otherwise   = assertInvalid sc failures -assertValid :: SchemaTestCase -> [D4.Failure] -> HU.Assertion+assertValid :: SchemaTestCase -> [D4.Failure] -> Expectation assertValid _ [] = pure () assertValid sc failures =-    HU.assertFailure $ unlines+    expectationFailure $ unlines         [ "    Failed to validate data"         , "    Description: "         <> T.unpack (_scDescription sc)         , "    Data: "                <> show (_scData sc)         , "    Validation failures: " <> show failures         ] -assertInvalid :: SchemaTestCase -> [D4.Failure] -> HU.Assertion+assertInvalid :: SchemaTestCase -> [D4.Failure] -> Expectation assertInvalid sc [] =-    HU.assertFailure $ unlines+    expectationFailure $ unlines         [ "    Validated invalid data"         , "    Description: " <> T.unpack (_scDescription sc)         , "    Data: "        <> show (_scData sc)