diff --git a/changelog.txt b/changelog.txt --- a/changelog.txt +++ b/changelog.txt @@ -1,3 +1,7 @@ +# 1.2.0.1 + ++ Switch to hspec for tests. + # 1.2.0.0 + Return `AdditionalPropertiesObject` error correctly (was mistakenly diff --git a/hjsonschema.cabal b/hjsonschema.cabal --- a/hjsonschema.cabal +++ b/hjsonschema.cabal @@ -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 diff --git a/test/Local.hs b/test/Local.hs --- a/test/Local.hs +++ b/test/Local.hs @@ -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 diff --git a/test/Local/Failure.hs b/test/Local/Failure.hs --- a/test/Local/Failure.hs +++ b/test/Local/Failure.hs @@ -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 diff --git a/test/Local/Reference.hs b/test/Local/Reference.hs --- a/test/Local/Reference.hs +++ b/test/Local/Reference.hs @@ -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") diff --git a/test/Local/Validation.hs b/test/Local/Validation.hs --- a/test/Local/Validation.hs +++ b/test/Local/Validation.hs @@ -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 () diff --git a/test/Remote.hs b/test/Remote.hs --- a/test/Remote.hs +++ b/test/Remote.hs @@ -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 diff --git a/test/Shared.hs b/test/Shared.hs --- a/test/Shared.hs +++ b/test/Shared.hs @@ -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)