Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Use @Julian's JSON-Schema-Test-Suite

  • Loading branch information...
commit a038314f1a304448fff6704e0116776dd81bd195 1 parent b209962
@timjb authored
View
3  .gitmodules
@@ -0,0 +1,3 @@
+[submodule "test/test-suite"]
+ path = test/test-suite
+ url = git://github.com/Julian/JSON-Schema-Test-Suite.git
View
4 aeson-schema.cabal
@@ -67,4 +67,6 @@ test-suite tests
bytestring,
hint,
temporary,
- mtl
+ mtl,
+ filepath,
+ directory
View
2  test/Data/Aeson/LitQQ.hs
@@ -13,7 +13,7 @@ import Language.Haskell.TH (ExpQ)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH.Syntax (lift)
-import Data.Aeson.Schema.CodeGen ()
+import Data.Aeson.Schema.CodeGen
aesonLitQQ :: QuasiQuoter
aesonLitQQ = QuasiQuoter { quoteExp = aesonLit }
View
25 test/Data/Aeson/Schema/Validator/Tests.hs
@@ -7,12 +7,15 @@ import Test.Framework.Providers.HUnit
import qualified Test.HUnit as HU
import Data.Aeson (Value)
-import Data.Text (Text)
+import qualified Data.Map as M
+import Data.Text (Text, unpack)
import Data.Aeson.Schema.Types
import Data.Aeson.Schema.Validator
import Data.Aeson.Schema.Examples (examples)
+import TestSuite.Types (SchemaTest (..),
+ SchemaTestCase (..))
assertValid, assertInvalid :: Graph Schema Text
-> Schema Text
@@ -25,5 +28,21 @@ assertInvalid graph schema value = case validate graph schema value of
[] -> HU.assertFailure "expected a validation error"
_ -> return ()
-tests :: [Test]
-tests = examples testCase assertValid assertInvalid
+tests :: [SchemaTest] -> [Test]
+tests schemaTests = examples testCase assertValid assertInvalid ++ map buildSchemaTest schemaTests
+ where
+ buildSchemaTest :: SchemaTest -> Test
+ buildSchemaTest schemaTest = testGroup testName cases
+ where
+ testName = unpack $ schemaTestDescription schemaTest
+ cases = map (buildSchemaTestCase $ schemaTestSchema schemaTest) $ schemaTestCases schemaTest
+ buildSchemaTestCase :: Schema Text -> SchemaTestCase -> Test
+ buildSchemaTestCase schema schemaTestCase = testCase testName assertion
+ where
+ testName = unpack $ schemaTestCaseDescription schemaTestCase
+ testData = schemaTestCaseData schemaTestCase
+ graph = M.empty
+ assertion = if schemaTestCaseValid schemaTestCase
+ then assertValid graph schema testData
+ else assertInvalid graph schema testData
+
View
8 test/TestSuite.hs
@@ -1,14 +1,16 @@
+import Control.Applicative ((<$>))
import Test.Framework
import qualified Data.Aeson.Schema.Choice.Tests
import qualified Data.Aeson.Schema.CodeGen.Tests
import qualified Data.Aeson.Schema.Types.Tests
import qualified Data.Aeson.Schema.Validator.Tests
+import TestSuite.Types (readSchemaTests)
main :: IO ()
-main = defaultMain
+main = readSchemaTests "test/test-suite/tests/draft3" >>= \schemaTests -> defaultMain
[ testGroup "Data.Aeson.Schema.Types" Data.Aeson.Schema.Types.Tests.tests
- , testGroup "Data.Aeson.Schema.Validator" Data.Aeson.Schema.Validator.Tests.tests
- , buildTest $ fmap (testGroup "Data.Aeson.Schema.CodeGen") Data.Aeson.Schema.CodeGen.Tests.tests
+ , testGroup "Data.Aeson.Schema.Validator" $ Data.Aeson.Schema.Validator.Tests.tests schemaTests
+ , buildTest $ testGroup "Data.Aeson.Schema.CodeGen" <$> Data.Aeson.Schema.CodeGen.Tests.tests
, testGroup "Data.Aeson.Schema.Choice" Data.Aeson.Schema.Choice.Tests.tests
]
View
57 test/TestSuite/Types.hs
@@ -0,0 +1,57 @@
+module TestSuite.Types
+ ( SchemaTest (..)
+ , SchemaTestCase (..)
+ , readSchemaTests
+ ) where
+
+import Control.Applicative ((*>), (<$>), (<*), (<*>))
+import Control.Monad (forM)
+import Data.Aeson
+import Data.Aeson.Schema
+import Data.Aeson.Types (parseEither)
+import Data.Attoparsec.Char8 (skipSpace)
+import Data.Attoparsec.Lazy (Result (..), parse)
+import qualified Data.ByteString.Lazy as LBS
+import Data.List (isSuffixOf)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import System.Directory (getDirectoryContents)
+import System.FilePath ((</>))
+
+data SchemaTest = SchemaTest
+ { schemaTestDescription :: Text
+ , schemaTestSchema :: Schema Text
+ , schemaTestCases :: [SchemaTestCase]
+ } deriving (Eq, Show)
+
+instance FromJSON SchemaTest where
+ parseJSON (Object o) = SchemaTest <$> (fromMaybe "" <$> o .:? "description")
+ <*> (o .: "schema")
+ <*> (o .: "tests")
+ parseJSON _ = fail "expected an object"
+
+data SchemaTestCase = SchemaTestCase
+ { schemaTestCaseDescription :: Text
+ , schemaTestCaseData :: Value
+ , schemaTestCaseValid :: Bool
+ } deriving (Eq, Show)
+
+instance FromJSON SchemaTestCase where
+ parseJSON (Object o) = SchemaTestCase <$> (o .: "description")
+ <*> (o .: "data")
+ <*> (o .: "valid")
+ parseJSON _ = fail "expected an object"
+
+-- | Read tests collected by Julian Berman (https://github.com/Julian/JSON-Schema-Test-Suite)
+readSchemaTests :: FilePath -> IO [SchemaTest]
+readSchemaTests dir = do
+ contents <- getDirectoryContents dir
+ let jsonFiles = filter (".json" `isSuffixOf`) contents
+ fmap concat $ forM jsonFiles $ \file -> do
+ let fullPath = dir </> file
+ jsonBS <- LBS.readFile fullPath
+ case parse (skipSpace *> json <* skipSpace) jsonBS of
+ Done _ value -> case parseEither parseJSON value of
+ Left err -> fail $ "couldn't parse file '" ++ fullPath ++ "': " ++ err
+ Right v -> return v
+ _ -> fail $ "not a valid json file: " ++ fullPath
1  test/test-suite
@@ -0,0 +1 @@
+Subproject commit 189e231e65d2f25f722fa362cb770ef1c264f7a2
Please sign in to comment.
Something went wrong with that request. Please try again.