git.iko.soy/typeable/hjsonschema
on master help sign in
0.9.0.0. Partial rewrite.

+ Validators can now be written in Haskell as well as JSON. + Store validators and schemas in separate module trees of the library (Data.Validator and Data.JsonSchema respectively). + To get the Draft 4 schema you now import 'Data.JsonSchema.Draft4' instead of 'Data.JsonSchema'. This will make forward compatibility easier if a Draft 5 ever comes out. + Add examples.

commit2b9f123d68ec11887a281e13c3ec0da31fcab54f authorIan Grant Jeffries <ian@housejeffries.com> dateSat 12 Dec 2015, 14:47 (11 years ago) parentf098625
37 files changed+2194−1287
compare with master
unifiedsplit
.gitignore+1 Example.hs−103 README.md+2−2 changelog.txt+7 examples/CustomSchema.hs+66 examples/Main.hs+19 examples/PrettyShowFailure.hs+47 examples/Standard.hs+52 hjsonschema.cabal+54−42 src/Data/JsonSchema.hs−86 src/Data/JsonSchema/Core.hs−91 src/Data/JsonSchema/Draft4.hs+66−138 src/Data/JsonSchema/Draft4/Any.hs−115 src/Data/JsonSchema/Draft4/Arrays.hs−100 src/Data/JsonSchema/Draft4/Failure.hs+68 src/Data/JsonSchema/Draft4/Internal.hs+280 src/Data/JsonSchema/Draft4/Numbers.hs−61 src/Data/JsonSchema/Draft4/Objects.hs−118 src/Data/JsonSchema/Draft4/Objects/Properties.hs−145 src/Data/JsonSchema/Draft4/Schema.hs+334 src/Data/JsonSchema/Draft4/Strings.hs−44 src/Data/JsonSchema/Fetch.hs+133 src/Data/JsonSchema/Helpers.hs−160 src/Data/Validator/Draft4.hs+8 src/Data/Validator/Draft4/Any.hs+179 src/Data/Validator/Draft4/Array.hs+168 src/Data/Validator/Draft4/Number.hs+51 src/Data/Validator/Draft4/Object.hs+147 src/Data/Validator/Draft4/Object/Properties.hs+187 src/Data/Validator/Draft4/String.hs+29 src/Data/Validator/Failure.hs+42 src/Data/JsonSchema/Reference.hs → src/Data/Validator/Reference.hs+19−17 src/Data/Validator/Utils.hs+122 src/Import.hs+1 tests/Local.hs+67−9 tests/Remote.hs+13−10 tests/Lib.hs → tests/Shared.hs+32−46
.gitignorenew file+1
@@ -0,0 +1 @@
1+stack.yaml
Example.hsdeleted−103
@@ -1,103 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−
3−module Main where
4−
5−import Control.Applicative
6−import Data.Aeson
7−import Data.HashMap.Strict (HashMap)
8−import qualified Data.HashMap.Strict as H
9−import Data.Monoid
10−import Data.Text (Text)
11−import qualified Data.Text as T
12−import qualified Data.Vector as V
13−
14−import qualified Data.JsonSchema as JS
15−
16−-- Data.JsonSchema is designed to be imported unqualified.
17−-- We're just being explicit here for example purposes.
18−
19−main :: IO ()
20−main = do
21− simpleExample
22− fullExample
23−
24−--------------------------------------------------
25−-- * Example Schema and Data
26−--------------------------------------------------
27−
28−schemaData :: JS.RawSchema
29−schemaData = JS.RawSchema
30− { JS._rsURI = Nothing
31− -- ^ If your schema has relative references to other schemas
32− -- then you'll need to include this.
33− , JS._rsData = schemaJSON
34− }
35− where
36− schemaJSON :: HashMap Text Value
37− schemaJSON = H.singleton "uniqueItems" (Bool True)
38−
39−badData :: Value
40−badData = Array $ V.fromList ["foo", "foo"]
41−
42−--------------------------------------------------
43−-- * Simple Example
44−--------------------------------------------------
45−
46−-- | Since our schema contains no references to other schemas,
47−-- we can skip the fetchGraph step.
48−simpleExample :: IO ()
49−simpleExample = do
50− schema <- compileSchema (JS.SchemaGraph schemaData H.empty) schemaData
51− checkResults (JS.validate schema badData)
52−
53−--------------------------------------------------
54−-- * Full Example
55−--------------------------------------------------
56−
57−-- | For a schema that might contain references to other schemas.
58−fullExample :: IO ()
59−fullExample = do
60− let currentSchemaCache = H.empty
61− schemaGraph <- fetchGraph currentSchemaCache schemaData
62−
63− -- We aren't going to use it for anything this time, but if we were caching
64− -- remote schemas this would be our new cache.
65− --
66− -- let newSchemaCache = _cachedSchemas schemaData <> currentSchemaGraph
67−
68− schema <- compileSchema schemaGraph schemaData
69− checkResults (JS.validate schema badData)
70−
71− where
72− fetchGraph :: HashMap Text (HashMap Text Value) -> JS.RawSchema -> IO JS.SchemaGraph
73− fetchGraph graph rs = do
74− eitherGraph <- JS.fetchReferencedSchemas JS.draft4 graph rs
75− case eitherGraph of
76− Left e -> error $ "Failed to fetch graph with error: " <> T.unpack e
77− Right g -> return g
78−
79−--------------------------------------------------
80−-- * Helper Functions
81−--------------------------------------------------
82−
83−compileSchema :: JS.SchemaGraph -> JS.RawSchema -> IO (JS.Schema JS.Draft4Failure)
84−compileSchema graph rs =
85− case JS.compileDraft4 graph rs of
86− Left failure -> error $ "Not a valid schema: " <> show failure
87− Right schema -> return schema
88−
89−checkResults :: [JS.ValidationFailure JS.Draft4Failure] -> IO ()
90−checkResults [] = error "OHNO we validated bad data!"
91−checkResults [JS.ValidationFailure JS.UniqueItems (JS.FailureInfo x y)] =
92− putStrLn . unlines $
93− [ ""
94− , "Success. We got a UniqueItems error as expected."
95− , "Here's the relevant part of the bad JSON document:"
96− , ""
97− , " " <> show y
98− , ""
99− , "And here's the content of the validator that caught it:"
100− , ""
101− , " " <> show x
102− ]
103−checkResults x = error $ "OHNO we got a different failure than we expected: " <> show x
README.md+2−2
@@ -4,11 +4,11 @@ A Haskell implementation of the current [JSON Schema](http://json-schema.org/) s
44
55[Hackage](https://hackage.haskell.org/package/hjsonschema) / [GitHub](https://github.com/seagreen/hjsonschema) / [Travis CI](https://travis-ci.org/seagreen/hjsonschema)
66
7−NOTE: You currently CANNOT use untrusted JSON data to make schemas. Schemas with circular references can cause infinite loops. This is being addressed: see the issue list.
7+NOTE: You CANNOT use untrusted JSON data to make schemas. Schemas with circular references can cause infinite loops. See the issue list for more info.
88
99# Example
1010
11−See [Example.hs on GitHub](https://github.com/seagreen/hjsonschema/blob/master/Example.hs).
11+See [here](https://github.com/seagreen/hjsonschema/blob/master/examples/Example.hs).
1212
1313# Tests
1414
changelog.txt+7
@@ -1,3 +1,10 @@
1+# 0.9
2+
3++ Partial rewrite. The API of the library has changed, see the examples
4+folder for how to use the new one.
5+
6++ Users of the library can now write schemas in Haskell as well as JSON.
7+
18# 0.8
29
310+ Improve scope updating and resolving.
examples/CustomSchema.hsnew file+66
@@ -0,0 +1,66 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+-- | A custom schema made up of one validator from 'Data.Validator.Draft4'
4+-- and one original validator.
5+--
6+-- This is a simple example because it doesn't allow references (so it
7+-- doesn't need to define an 'embed' function @Schema -> [Schema]@ for use
8+-- with 'fetchReferencedSchemas'.
9+
10+module CustomSchema where
11+
12+import Data.Aeson
13+import Data.Maybe (maybeToList)
14+import Data.Text (Text)
15+import qualified Data.Text as T
16+
17+import qualified Data.Validator.Draft4 as VA
18+import qualified Data.Validator.Failure as FR
19+
20+-- | Our custom validator.
21+oddLength :: Bool -> Text -> Maybe (FR.Failure () )
22+oddLength b t
23+ | b == odd (T.length t) = Nothing
24+ | otherwise = Just (FR.Failure () (Bool b) mempty)
25+
26+data CustomError
27+ = MaxLength
28+ | OddLength
29+
30+-- If we were really using the schema we would also need ToJSON and FromJSON
31+-- instances.
32+data Schema = Schema
33+ { _schemaMaxLength :: Maybe Int
34+ , _schemaOddLength :: Maybe Bool
35+ }
36+
37+-- | Since every 'Schema' is valid we don't need to bother defining something
38+-- like 'Data.JsonSchema.Draft4.checkValidity' for this schema.
39+validate :: Schema -> Value -> [FR.Failure CustomError]
40+validate s (String x) = concat
41+ [ f _schemaMaxLength (FR.setFailure MaxLength) (fmap maybeToList . VA.maxLength)
42+ , f _schemaOddLength (FR.setFailure OddLength) (fmap maybeToList . oddLength)
43+ ]
44+ where
45+ -- This pattern is overkill here, but is helpful if you have lots of
46+ -- validators (e.g. the Draft 4 schema has 27).
47+ f :: (Schema -> Maybe val)
48+ -> (err -> FR.Failure CustomError)
49+ -> (val -> Text -> [err])
50+ -> [FR.Failure CustomError]
51+ f field modifyError runVal =
52+ maybe mempty (\val -> modifyError <$> runVal val x) (field s)
53+validate _ _ = mempty -- Our schema passes everything that isn't a string.
54+
55+example :: IO ()
56+example =
57+ case validate schema badData of
58+ [] -> error "We validated bad data."
59+ [FR.Failure OddLength _ _] -> putStrLn "Success."
60+ _ -> error "We got a different failure than expected."
61+ where
62+ schema :: Schema
63+ schema = Schema (Just 100) (Just True)
64+
65+ badData :: Value
66+ badData = String "even"
examples/Main.hsnew file+19
@@ -0,0 +1,19 @@
1+
2+module Main where
3+
4+import qualified CustomSchema as C
5+import qualified PrettyShowFailure as P
6+import qualified Standard as S
7+
8+main :: IO ()
9+main = do
10+ putStrLn "# Standard Example"
11+ S.example
12+ putStrLn ""
13+
14+ putStrLn "# PrettyShowFailure Example"
15+ P.example
16+ putStrLn ""
17+
18+ putStrLn "# CustomSchema Example"
19+ C.example
examples/PrettyShowFailure.hsnew file+47
@@ -0,0 +1,47 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module PrettyShowFailure where
4+
5+import Data.Aeson
6+import qualified Data.Aeson.Pointer as AP
7+import Data.Monoid
8+
9+import qualified Data.JsonSchema.Draft4 as D4
10+
11+badData :: Value
12+badData = toJSON [1, 2 :: Int]
13+
14+failure :: D4.Failure
15+failure = D4.Failure
16+ { D4._failureValidatorsCalled = D4.Items D4.MultipleOf
17+ , D4._failureFinalValidator = Number 2
18+ , D4._failureOffendingData = AP.Pointer [AP.Token "0"]
19+ }
20+
21+subsetOfData :: Value
22+subsetOfData =
23+ -- This is the only really interesting part of this example. To resolve the
24+ -- pointer to the part of the data that triggered the validation failure we
25+ -- have to have hjsonpointer in our build-depends and use 'AP.resolve'.
26+ case AP.resolve (D4._failureOffendingData failure) badData of
27+ Left _ -> error "Couldn't resolve pointer."
28+ Right v -> v
29+
30+example :: IO ()
31+example = putStrLn . unlines $
32+ [ "Invalid data. Here's the sequence of validators that caught it:"
33+ , ""
34+ , " " <> show (D4._failureValidatorsCalled failure)
35+ , ""
36+ , "Here's the contents of the final validator in that sequence:"
37+ , ""
38+ , " " <> show (D4._failureFinalValidator failure)
39+ , ""
40+ , "Here's a JSON Pointer to the invalid part of the data:"
41+ , ""
42+ , " " <> show (D4._failureOffendingData failure)
43+ , ""
44+ , "Here's the invalid part of the data:"
45+ , ""
46+ , " " <> show subsetOfData
47+ ]
examples/Standard.hsnew file+52
@@ -0,0 +1,52 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Standard where
4+
5+import Data.Aeson
6+import qualified Data.HashMap.Strict as H
7+import qualified Data.Vector as V
8+
9+import qualified Data.JsonSchema.Draft4 as D4
10+
11+schema :: D4.Schema
12+schema = D4.emptySchema { D4._schemaUniqueItems = Just True }
13+
14+schemaContext :: D4.SchemaContext D4.Schema
15+schemaContext = D4.SchemaContext
16+ { D4._scURI = Nothing
17+ -- ^ If your schema has relative references to other schemas
18+ -- then you'll need to give its URI here.
19+ , D4._scSchema = schema
20+ }
21+
22+badData :: Value
23+badData = Array (V.fromList ["foo", "foo"])
24+
25+example :: IO ()
26+example = do
27+ -- Since we know our schema doesn't reference any other schemas we could
28+ -- skip this step and use @SchemaCache schema mempty@ instead.
29+ --
30+ -- If we make a mistake and out schema does include references to other
31+ -- schemas then those references will always return 'D4.RefResolution'
32+ -- validation failures.
33+ cache <- makeCache
34+
35+ let validate = case D4.checkSchema cache schemaContext of
36+ Left _ -> error "Not a valid schema."
37+ Right f -> f
38+
39+ case validate badData of
40+ [] -> error "We validated bad data."
41+ [D4.Failure D4.UniqueItems _ _] -> putStrLn "Success."
42+ _ -> error "We got a different failure than expected."
43+
44+ where
45+ makeCache :: IO (D4.SchemaCache D4.Schema)
46+ makeCache = do
47+ -- A HashMap of URIs (in the form of Text) to schemas.
48+ let currentlyStoredSchemas = H.empty
49+ res <- D4.fetchReferencedSchemas currentlyStoredSchemas schemaContext
50+ case res of
51+ Left _ -> error "Couldn't fetch referenced schemas."
52+ Right cache -> return cache
hjsonschema.cabal+54−42
@@ -1,5 +1,5 @@
11name: hjsonschema
2−version: 0.8.0.1
2+version: 0.9.0.0
33synopsis: JSON Schema library
44homepage: https://github.com/seagreen/hjsonschema
55license: MIT
@@ -14,73 +14,80 @@ extra-source-files: changelog.txt
1414 draft4.json
1515 JSON-Schema-Test-Suite/tests/draft4/*.json
1616 README.md
17− tests/Lib.hs
17+ tests/Shared.hs
1818
1919library
2020 hs-source-dirs: src
21− exposed-modules: Data.JsonSchema
22− , Data.JsonSchema.Draft4.Any
23− , Data.JsonSchema.Draft4.Arrays
24− , Data.JsonSchema.Draft4.Numbers
25− , Data.JsonSchema.Draft4.Objects
26− , Data.JsonSchema.Draft4.Strings
27− , Data.JsonSchema.Helpers
28− , Data.JsonSchema.Reference
29− other-modules: Data.JsonSchema.Core
30− Data.JsonSchema.Draft4
31− , Data.JsonSchema.Draft4.Objects.Properties
21+ exposed-modules: Data.JsonSchema.Draft4
22+ , Data.JsonSchema.Draft4.Internal
23+ , Data.JsonSchema.Fetch
24+ , Data.Validator.Draft4
25+ , Data.Validator.Failure
26+ , Data.Validator.Reference
27+ , Data.Validator.Utils
28+
29+ other-modules: Data.JsonSchema.Draft4.Failure
30+ , Data.JsonSchema.Draft4.Schema
31+ , Data.Validator.Draft4.Any
32+ , Data.Validator.Draft4.Array
33+ , Data.Validator.Draft4.Number
34+ , Data.Validator.Draft4.Object
35+ , Data.Validator.Draft4.Object.Properties
36+ , Data.Validator.Draft4.String
3237 , Import
3338 default-language: Haskell2010
3439 default-extensions: ScopedTypeVariables
3540 OverloadedStrings
36− other-extensions: TemplateHaskell
3741 ghc-options: -Wall
38− build-depends: aeson >= 0.7 && < 0.11
42+ build-depends: aeson >= 0.7 && < 0.12
3943 -- 4.6 doesn't have a Traversable Either instance:
40− , base >= 4.7 && < 4.9
41− , bytestring >= 0.10 && < 0.11
42− , containers >= 0.5 && < 0.6
43− , file-embed >= 0.0.8 && < 0.0.10
44− , hashable >= 1.2 && < 1.3
45− , hjsonpointer >= 0.2 && < 0.3
46− , http-client >= 0.4.9 && < 0.5
47− , http-types >= 0.8 && < 0.10
48− , mtl >= 2.2.1 && < 2.3
49− , regexpr >= 0.5 && < 0.6
50− , scientific >= 0.3 && < 0.4
51− , transformers >= 0.4.2 && < 0.5
52− , unordered-containers >= 0.2 && < 0.3
53− , text >= 1.2 && < 1.3
54− , vector >= 0.10 && < 0.12
44+ , base >= 4.7 && < 4.9
45+ , bytestring >= 0.10 && < 0.11
46+ , containers >= 0.5 && < 0.6
47+ , file-embed >= 0.0.8 && < 0.0.10
48+ , hjsonpointer >= 0.3 && < 0.4
49+ , http-client >= 0.4.9 && < 0.5
50+ , http-types >= 0.8 && < 0.10
51+ , QuickCheck >= 2.8.1 && < 2.9
52+ , regexpr >= 0.5 && < 0.6
53+ , scientific >= 0.3 && < 0.4
54+ , semigroups >= 0.18.0 && < 0.19
55+ , unordered-containers >= 0.2 && < 0.3
56+ , text >= 1.2 && < 1.3
57+ , vector >= 0.10 && < 0.12
5558
5659test-suite local
5760 type: exitcode-stdio-1.0
5861 hs-source-dirs: tests
5962 main-is: Local.hs
63+ other-modules: Shared
6064 default-language: Haskell2010
61− ghc-options: -Wall
65+ ghc-options: -Wall -fno-warn-orphans
6266 default-extensions: OverloadedStrings
63− other-extensions: TemplateHaskell
6467 build-depends: aeson
6568 , base
6669 , bytestring
70+ , hjsonpointer
6771 , hjsonschema
6872 , text
73+ , QuickCheck
74+ , unordered-containers
6975 , vector
70− , directory >= 1.2 && < 1.3
71− , filepath >= 1.3 && < 1.5
72− , HUnit >= 1.2 && < 1.4
73− , test-framework >= 0.8 && < 0.9
74− , test-framework-hunit >= 0.3 && < 0.4
76+ , directory >= 1.2 && < 1.3
77+ , filepath >= 1.3 && < 1.5
78+ , HUnit >= 1.2 && < 1.4
79+ , tasty >= 0.11 && < 0.12
80+ , tasty-hunit >= 0.9 && < 0.10
81+ , tasty-quickcheck >= 0.8 && < 0.9
7582
7683test-suite remote
7784 type: exitcode-stdio-1.0
7885 hs-source-dirs: tests
7986 main-is: Remote.hs
87+ other-modules: Shared
8088 default-language: Haskell2010
81− ghc-options: -Wall
89+ ghc-options: -Wall -fno-warn-orphans
8290 default-extensions: OverloadedStrings
83− other-extensions: TemplateHaskell
8491 build-depends: aeson
8592 , async
8693 , base
@@ -91,17 +98,22 @@ test-suite remote
9198 , directory
9299 , filepath
93100 , HUnit
94− , test-framework
95− , test-framework-hunit
101+ , tasty
102+ , tasty-hunit
96103 , wai-app-static
97104 , warp
98105
99106executable example
100− main-is: Example.hs
107+ hs-source-dirs: examples
108+ main-is: Main.hs
109+ other-modules: CustomSchema
110+ , PrettyShowFailure
111+ , Standard
101112 default-language: Haskell2010
102113 ghc-options: -Wall
103114 build-depends: aeson
104115 , base
116+ , hjsonpointer
105117 , hjsonschema
106118 , text
107119 , unordered-containers
src/Data/JsonSchema.hsdeleted−86
@@ -1,86 +0,0 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
2−
3−module Data.JsonSchema
4− ( module Data.JsonSchema.Core
5− -- * Schema feching tools
6− , module Data.JsonSchema
7− -- * Draft 4 specific
8− , module Data.JsonSchema.Draft4
9− ) where
10−
11−import Control.Monad.Except (MonadError, MonadIO, join, throwError)
12−import qualified Data.ByteString.Lazy as LBS
13−import Data.Foldable
14−import qualified Data.HashMap.Strict as H
15−import Data.String
16−
17−import Data.JsonSchema.Core
18−import Data.JsonSchema.Draft4
19−import qualified Data.JsonSchema.Helpers as HE
20−import Data.JsonSchema.Reference
21−import Import
22−
23−-- For GHCs before 7.10:
24−import Prelude hiding (concat, sequence)
25−
26−-- | Take a schema. Retrieve every document either it or its
27−-- subschemas include via the "$ref" keyword. Load a 'SchemaGraph' out
28−-- with them.
29−fetchReferencedSchemas :: Spec err -> SchemaCache -> RawSchema -> IO (Either Text SchemaGraph)
30−fetchReferencedSchemas = fetchReferencedSchemas' HE.defaultFetch
31−
32−-- | A version of fetchReferencedSchemas where the function to make requests
33−-- is provided by the user. This allows restrictions to be added, e.g. rejecting
34−-- non-local URIs.
35−fetchReferencedSchemas'
36− -- The `Functor m` declaration is for GHCs before 7.10.
37− :: forall m e t err. (MonadIO m, Functor m, MonadError t e, Traversable e, IsString t)
38− => (Text -> m (e LBS.ByteString))
39− -> Spec err
40− -> SchemaCache
41− -> RawSchema
42− -> m (e SchemaGraph)
43−fetchReferencedSchemas' fetchRef spec cache rawSchema = do
44− let startingCache = case _rsURI rawSchema of
45− Nothing -> cache
46− Just uri -> H.insert uri (_rsData rawSchema) cache
47− fmap (SchemaGraph rawSchema) <$> foldlM fetch (return startingCache) (includeSubschemas rawSchema)
48−
49− where
50− -- TODO: use a fold here
51− includeSubschemas :: RawSchema -> [RawSchema]
52− includeSubschemas r =
53− let scope = _rsURI r `newResolutionScope` _rsData r
54− xs = H.intersectionWith (\(ValSpec f _) x -> f scope x) (_unSpec spec) (_rsData r)
55− in r : (concat . concat . H.elems $ fmap includeSubschemas <$> xs)
56−
57− fetch :: e SchemaCache -> RawSchema -> m (e SchemaCache)
58− fetch eg r = join <$> sequence (run <$> eg)
59− where
60− run :: SchemaCache -> m (e SchemaCache)
61− run g = do
62− -- Resolving the new scope is necessary here because of situations like this:
63− --
64− -- {
65− -- "id": "http://localhost:1234/",
66− -- "items": {
67− -- "id": "folder/",
68− -- "items": {"$ref": "folderInteger.json"}
69− -- }
70− -- }
71− let scope = newResolutionScope (_rsURI r) (_rsData r)
72− case resolveReference scope <$> (H.lookup "$ref" (_rsData r) >>= HE.toTxt) of
73− Just (Just uri,_) ->
74− if not (isRemoteReference uri) || H.member uri g
75− then return (return g)
76− else fetchRef uri >>= decodeResponse g uri
77− _ -> return (return g)
78−
79− decodeResponse :: SchemaCache -> Text -> e LBS.ByteString -> m (e SchemaCache)
80− decodeResponse g uri eBts = join <$> sequence (runDecode g uri <$> eBts)
81−
82− runDecode :: SchemaCache -> Text -> LBS.ByteString -> m (e SchemaCache)
83− runDecode g uri bts =
84− case eitherDecode bts of
85− Left e -> return $ throwError (fromString e)
86− Right obj -> fmap _cachedSchemas <$> fetchReferencedSchemas' fetchRef spec g (RawSchema (Just uri) obj)
src/Data/JsonSchema/Core.hsdeleted−91
@@ -1,91 +0,0 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
2−
3−module Data.JsonSchema.Core where
4−
5−import qualified Data.HashMap.Strict as H
6−import Data.Maybe
7−
8−import Data.JsonSchema.Reference
9−import Import
10−
11−-- For GHCs before 7.10:
12−import Prelude hiding (concat, sequence)
13−
14−--------------------------------------------------
15−-- * Primary API
16−--------------------------------------------------
17−
18−compile :: forall err. Spec err -> SchemaGraph -> RawSchema -> Schema err
19−compile spec g (RawSchema t o) =
20− let maybeValidators = H.intersectionWith f (_unSpec spec) o
21− in Schema . catMaybes . H.elems $ maybeValidators
22− where
23− f :: ValSpec err -> Value -> Maybe (Value -> [ValidationFailure err])
24− f (ValSpec _ construct) valJSON = construct spec g (RawSchema (newResolutionScope t o) o) valJSON
25−
26−validate :: Schema err -> Value -> [ValidationFailure err]
27−validate schema x = concat . fmap ($ x) . _unSchema $ schema
28−
29−--------------------------------------------------
30−-- * Schemas
31−--------------------------------------------------
32−
33−newtype Spec err = Spec { _unSpec :: HashMap Text (ValSpec err) }
34−
35−newtype Schema err = Schema { _unSchema :: [Value -> [ValidationFailure err]] }
36−
37−data RawSchema = RawSchema
38− { _rsURI :: !(Maybe Text)
39− -- ^ NOTE: Must not include a URI fragment.
40− , _rsData :: !(HashMap Text Value)
41− } deriving (Show)
42−
43−-- | A set of RawSchemas, split into a HashMap.
44−--
45−-- Keys correspond to Schema _rsURIs. Values correspond to Schema _rsDatas.
46−type SchemaCache = HashMap Text (HashMap Text Value)
47−
48−data SchemaGraph = SchemaGraph
49− { _startingSchema :: !RawSchema
50− -- ^ The schema initially referenced by '#'.
51− , _cachedSchemas :: !SchemaCache
52− } deriving (Show)
53−
54−--------------------------------------------------
55−-- * Validators
56−--------------------------------------------------
57−
58−data ValSpec err = ValSpec EmbeddedSchemas (ValidatorConstructor err [ValidationFailure err])
59−
60−-- | Return a schema's immediate subschemas.
61−--
62−-- This is used by 'Data.JsonSchema.fetchRefs' to find all the
63−-- subschemas in a document. This allows it to process only
64−-- "$ref"s and "id"s that are actual schema keywords.
65−type EmbeddedSchemas = Maybe Text -> Value -> [RawSchema]
66−
67−-- | This is what's used to write most validators in practice.
68−--
69−-- Its important that particular validators don't know about the error sum type
70−-- of the Spec they're going to be used in. That way they can be included in
71−-- other Specs later without encouraging partial functions.
72−--
73−-- This means that a properly written ValidatorConstructor will need its error
74−-- type modified for use in a Spec. Data.JsonSchema.Helpers provides giveName
75−-- and modifyName for this purpose.
76−type ValidatorConstructor schemaErr valErr
77− = Spec schemaErr
78− -> SchemaGraph
79− -> RawSchema
80− -> Value
81− -> Maybe (Value -> valErr)
82−
83−data ValidationFailure err = ValidationFailure
84− { _failureName :: !err
85− , _failureInfo :: !FailureInfo
86− } deriving (Show)
87−
88−data FailureInfo = FailureInfo
89− { _validatingData :: !Value
90− , _offendingData :: !Value
91− } deriving (Show)
src/Data/JsonSchema/Draft4.hs+66−138
@@ -1,142 +1,70 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
3−module Data.JsonSchema.Draft4 where
4−
5−import qualified Data.ByteString.Lazy as LBS
1+{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE TemplateHaskell #-}
3+
4+module Data.JsonSchema.Draft4
5+ ( Schema(..)
6+ , emptySchema
7+ , checkSchema
8+
9+ -- * Fetching tools
10+ , SchemaContext(..)
11+ , SchemaCache(..)
12+ , fetchReferencedSchemas
13+
14+ -- * Failure
15+ , Failure(..)
16+ , ValidatorChain(..)
17+
18+ -- * Other Draft 4 things exported just in case
19+ , schemaValidity
20+ , IN.runValidate
21+ ) where
22+
23+import Data.Aeson
24+import qualified Data.ByteString.Lazy as LBS
625import Data.FileEmbed
7−import qualified Data.HashMap.Strict as H
8−
9−import Data.JsonSchema.Core
10−import Data.JsonSchema.Draft4.Any
11−import qualified Data.JsonSchema.Draft4.Arrays as AR
12−import qualified Data.JsonSchema.Draft4.Numbers as NU
13−import qualified Data.JsonSchema.Draft4.Objects as OB
14−import Data.JsonSchema.Draft4.Strings
15−import Data.JsonSchema.Helpers
26+import qualified Data.HashMap.Strict as H
27+import Data.Maybe (fromMaybe)
28+
29+import Data.JsonSchema.Draft4.Failure
30+import qualified Data.JsonSchema.Draft4.Internal as IN
31+import Data.JsonSchema.Draft4.Schema
32+import Data.JsonSchema.Fetch (SchemaCache(..),
33+ SchemaContext(..),
34+ URISchemaMap)
35+import qualified Data.JsonSchema.Fetch as FE
36+import Data.Validator.Reference (baseAndFragment)
1637import Import
1738
18−data Draft4Failure
19− = MultipleOf
20−
21− | Maximum
22− | ExclusiveMaximum
23−
24− | Minimum
25− | ExclusiveMinimum
26−
27− | MaxLength
28− | MinLength
29− | Pattern
30−
31− | Items Draft4Failure
32− | AdditionalItemsBool
33− | AdditionalItemsObject Draft4Failure
34−
35− | MaxItems
36− | MinItems
37− | UniqueItems
38− | MaxProperties
39− | MinProperties
40− | Required
41−
42− | Properties Draft4Failure
43− | PatternProperties Draft4Failure
44− | AdditionalPropertiesBool
45− | AdditionalPropertiesObject Draft4Failure
46−
47− | SchemaDependency Draft4Failure
48− | PropertyDependency
49−
50− | Enum
51− | TypeValidator
52− | AllOf Draft4Failure
53− | AnyOf
54− | OneOf
55− | NotValidator
56− | Ref Draft4Failure
57− deriving (Eq, Show, Read)
58−
59−draft4 :: Spec Draft4Failure
60−draft4 = Spec $ H.fromList
61− [ ("$ref" , ValSpec noEm (modifyName Ref ref))
62− , ("multipleOf" , ValSpec noEm (giveName MultipleOf NU.multipleOf))
63− , ("maximum" , ValSpec noEm (modifyName fMax NU.maximumVal))
64− , ("minimum" , ValSpec noEm (modifyName fMin NU.minimumVal))
65− , ("maxLength" , ValSpec noEm (giveName MaxLength maxLength))
66− , ("minLength" , ValSpec noEm (giveName MinLength minLength))
67− , ("pattern" , ValSpec noEm (giveName Pattern pattern))
68− , ("additionalItems" , ValSpec objEmbed neverBuild) -- Handled by items.
69− , ("items" , ValSpec objOrArrayEmbed (modifyName fItems AR.items))
70− , ("maxItems" , ValSpec noEm (giveName MaxItems AR.maxItems))
71− , ("minItems" , ValSpec noEm (giveName MinItems AR.minItems))
72− , ("uniqueItems" , ValSpec noEm (giveName UniqueItems AR.uniqueItems))
73− , ("maxProperties" , ValSpec noEm (giveName MaxProperties OB.maxProperties))
74− , ("minProperties" , ValSpec noEm (giveName MinProperties OB.minProperties))
75− , ("required" , ValSpec noEm (giveName Required OB.required))
76− , ("properties" , ValSpec objMembersEmbed (modifyName fProp OB.properties))
77− , ("patternProperties" , ValSpec objMembersEmbed (modifyName fPatProp OB.patternProperties))
78− , ("additionalProperties", ValSpec objEmbed (modifyName fAddProp OB.additionalProperties))
79− , ("dependencies" , ValSpec objMembersEmbed (modifyName fDeps OB.dependencies))
80− , ("enum" , ValSpec noEm (giveName Enum enum))
81− , ("type" , ValSpec noEm (giveName TypeValidator typeValidator))
82− , ("allOf" , ValSpec arrayEmbed (modifyName AllOf allOf))
83− , ("anyOf" , ValSpec arrayEmbed (giveName AnyOf anyOf))
84− , ("oneOf" , ValSpec arrayEmbed (giveName OneOf oneOf))
85− , ("not" , ValSpec objEmbed (giveName NotValidator notValidator))
86− , ("definitions" , ValSpec objMembersEmbed neverBuild) -- Just contains referenceable schemas.
87− ]
39+-- | Check the validity of a schema and return a function to validate data.
40+checkSchema
41+ :: SchemaCache Schema
42+ -> SchemaContext Schema
43+ -> Either [Failure] (Value -> [Failure])
44+checkSchema sg sc =
45+ case schemaValidity (_scSchema sc) of
46+ [] -> Right (IN.runValidate sg sc)
47+ es -> Left es
48+
49+fetchReferencedSchemas
50+ :: URISchemaMap Schema
51+ -> SchemaContext Schema
52+ -> IO (Either Text (SchemaCache Schema))
53+fetchReferencedSchemas =
54+ FE.fetchReferencedSchemas IN.embedded _schemaId _schemaRef
55+
56+-- | In normal situations just use 'checkSchema', which is a combination of
57+-- 'schemaValidity' and 'runValidate'.
58+schemaValidity :: Schema -> [Failure]
59+schemaValidity = IN.runValidate cache (SchemaContext Nothing d4) . toJSON
8860 where
89− fMax NU.Maximum = Maximum
90− fMax NU.ExclusiveMaximum = ExclusiveMaximum
91−
92− fMin NU.Minimum = Minimum
93− fMin NU.ExclusiveMinimum = ExclusiveMinimum
94−
95− fItems (AR.Items err) = Items err
96− fItems AR.AdditionalItemsBool = AdditionalItemsBool
97− fItems (AR.AdditionalItemsObject err) = AdditionalItemsObject err
98−
99− fProp (OB.Properties err) = Properties err
100− fProp (OB.PropPattern err) = PatternProperties err
101− fProp (OB.PropAdditional OB.AdditionalPropertiesBool) = AdditionalPropertiesBool
102− fProp (OB.PropAdditional (OB.AdditionalPropertiesObject err)) = AdditionalPropertiesObject err
103−
104− fPatProp (OB.PatternProperties err) = PatternProperties err
105− fPatProp (OB.PatternAdditional OB.AdditionalPropertiesBool) = AdditionalPropertiesBool
106− fPatProp (OB.PatternAdditional (OB.AdditionalPropertiesObject err)) = AdditionalPropertiesObject err
107−
108− fAddProp OB.AdditionalPropertiesBool = AdditionalPropertiesBool
109− fAddProp (OB.AdditionalPropertiesObject err) = AdditionalItemsObject err
110−
111− fDeps (OB.SchemaDependency err) = SchemaDependency err
112− fDeps OB.PropertyDependency = PropertyDependency
113−
114−-- | Check if a 'RawSchema' is valid Draft 4 schema.
115−--
116−-- This is just a convenience function built by preloading 'validate'
117−-- with the spec schema that describes valid Draft 4 schemas.
118−--
119−-- NOTE: It's not actually required to run 'isValidSchema' on
120−-- prospective draft 4 schemas at all. However, it's a good way to
121−-- catch unintentional mistakes in schema documents.
122−isValidSchema :: RawSchema -> [ValidationFailure Draft4Failure]
123−isValidSchema r =
124− case decode . LBS.fromStrict $ $(embedFile "draft4.json") of
125− Nothing -> error "Schema decode failed (this should never happen)"
126− Just s ->
127− let a = RawSchema Nothing s
128− in validate (compile draft4 (SchemaGraph a mempty) a) $ Object (_rsData r)
129−
130−-- | Check that a 'RawSchema' conforms to the JSON Schema Draft 4
131−-- master schema document. Compile it if it does.
132−--
133−-- This is just a convenience function built by combining
134−-- 'isValidSchema' and 'compile'.
135−--
136−-- NOTE: It's not actually required to run 'isValidSchema' on
137−-- prospective draft 4 schemas at all.
138−compileDraft4 :: SchemaGraph -> RawSchema -> Either [ValidationFailure Draft4Failure] (Schema Draft4Failure)
139−compileDraft4 g r =
140− case isValidSchema r of
141− [] -> Right (compile draft4 g r)
142− errs -> Left errs
61+ d4 :: Schema
62+ d4 = fromMaybe (error "Schema decode failed (this should never happen)")
63+ . decode . LBS.fromStrict $ $(embedFile "draft4.json")
64+
65+ -- @fst . baseAndFragment@ is necessary to remove the trailing "#",
66+ -- otherwise cache lookups to resolve internal references will fail.
67+ cache :: SchemaCache Schema
68+ cache = SchemaCache d4 $ case _schemaId d4 >>= fst . baseAndFragment of
69+ Nothing -> mempty
70+ Just uri -> H.singleton uri d4
src/Data/JsonSchema/Draft4/Any.hsdeleted−115
@@ -1,115 +0,0 @@
1−
2−module Data.JsonSchema.Draft4.Any where
3−
4−import Control.Monad
5−import qualified Data.HashMap.Strict as H
6−import Data.Maybe
7−import Data.Scientific
8−import qualified Data.Vector as V
9−
10−import Data.JsonSchema.Core
11−import Data.JsonSchema.Helpers
12−import Data.JsonSchema.Reference
13−import Import
14−
15−-- For GHCs before 7.10:
16−import Prelude hiding (any)
17−
18−-- | http://json-schema.org/latest/json-schema-validation.html#anchor76
19−--
20−-- > The value of this keyword MUST be an array.
21−-- > This array MUST have at least one element.
22−-- > Elements in the array MUST be unique.
23−-- >
24−-- > Elements in the array MAY be of any type, including null.
25−--
26−-- NOTE: We actually respect this, and don't build the validator
27−-- if any of the elements aren't unique.
28−enum :: ValidatorConstructor err [FailureInfo]
29−enum _ _ _ val@(Array vs) = do
30− when (V.null vs || not (allUniqueValues vs)) Nothing
31− Just $ \x ->
32− if V.elem x vs
33− then mempty
34− else pure (FailureInfo val x)
35−enum _ _ _ _ = Nothing
36−
37−typeValidator :: ValidatorConstructor err [FailureInfo]
38−typeValidator _ _ _ (String val) = Just $ \x -> isJsonType x (pure val)
39−typeValidator _ _ _ (Array vs) = do
40− ts <- traverse toTxt vs
41− unless (allUnique ts) Nothing
42− Just (`isJsonType` ts)
43−typeValidator _ _ _ _ = Nothing
44−
45−isJsonType :: Value -> Vector Text -> [FailureInfo]
46−isJsonType x xs =
47− case x of
48− (Null) -> f "null" xs
49− (Array _) -> f "array" xs
50− (Bool _) -> f "boolean" xs
51− (Object _) -> f "object" xs
52− (String _) -> f "string" xs
53− (Number y) ->
54− case toBoundedInteger y :: Maybe Int of
55− Nothing -> f "number" xs
56− Just _ -> if V.elem "integer" xs
57− then mempty
58− else f "number" xs
59− where
60− f :: Text -> Vector Text -> [FailureInfo]
61− f t ts = if V.elem t ts
62− then mempty
63− else pure $ FailureInfo (Array (String <$> xs)) x
64−
65−allOf :: ValidatorConstructor err [ValidationFailure err]
66−allOf spec g s (Array vs) = do
67− os <- traverse toObj vs
68− let subSchemas = compile spec g . RawSchema (_rsURI s) <$> V.toList os
69− Just $ \x -> join $ flip validate x <$> subSchemas
70−allOf _ _ _ _ = Nothing
71−
72−anyOf :: ValidatorConstructor err [FailureInfo]
73−anyOf spec g s val@(Array vs) = do
74− os <- traverse toObj vs
75− let subSchemas = compile spec g . RawSchema (_rsURI s) <$> os
76− Just $ \x ->
77− if any null (flip validate x <$> subSchemas)
78− then mempty
79− else pure (FailureInfo val x)
80−anyOf _ _ _ _ = Nothing
81−
82−oneOf :: ValidatorConstructor err [FailureInfo]
83−oneOf spec g s val@(Array vs) = do
84− os <- traverse toObj $ V.toList vs
85− let subSchemas = compile spec g . RawSchema (_rsURI s) <$> os
86− Just $ \x ->
87− if (length . filter null $ flip validate x <$> subSchemas) == 1
88− then mempty
89− else pure (FailureInfo val x)
90−oneOf _ _ _ _ = Nothing
91−
92−notValidator :: ValidatorConstructor err [FailureInfo]
93−notValidator spec g s val@(Object o) = do
94− let subSchema = compile spec g $ RawSchema (_rsURI s) o
95− Just $ \x ->
96− case validate subSchema x of
97− [] -> pure (FailureInfo val x)
98− _ -> mempty
99−notValidator _ _ _ _ = Nothing
100−
101−-- JSON Reference Draft Document:
102−--
103−-- http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03
104−ref :: ValidatorConstructor err [ValidationFailure err]
105−ref spec g s (String val) = do
106− let (mUri, mFragment) = resolveReference (_rsURI s) val
107− r <- RawSchema mUri <$> getReference mUri
108− let o = resolveFragment mFragment (_rsData r)
109− return . validate . compile spec g $ RawSchema (_rsURI r) o
110− where
111− getReference :: Maybe Text -> Maybe (HashMap Text Value)
112− getReference Nothing = Just . _rsData . _startingSchema $ g
113− getReference (Just t) = H.lookup t (_cachedSchemas g)
114−
115−ref _ _ _ _ = Nothing
src/Data/JsonSchema/Draft4/Arrays.hsdeleted−100
@@ -1,100 +0,0 @@
1−
2−module Data.JsonSchema.Draft4.Arrays where
3−
4−import Control.Monad
5−import qualified Data.HashMap.Strict as H
6−import qualified Data.Vector as V
7−
8−import Data.JsonSchema.Core
9−import Data.JsonSchema.Helpers
10−import Import
11−
12−data ItemsFailure err
13− = Items err
14− | AdditionalItemsBool
15− | AdditionalItemsObject err
16−
17−data AdditionalItemsFailure err
18− = AdditionalBool
19− | AdditionalObject err
20−
21−-- | A combination of items and additionalItems.
22−items :: ValidatorConstructor err [ValidationFailure (ItemsFailure err)]
23−items spec g s (Object o) =
24− let subSchema = compile spec g (RawSchema (_rsURI s) o)
25− in Just $ \x ->
26− case x of
27− Array ys -> V.toList ys >>= fmap (modifyFailureName Items) . validate subSchema
28− _ -> mempty
29−items spec g s (Array vs) = do
30− os <- traverse toObj vs
31− let subSchemas = compile spec g . RawSchema (_rsURI s) <$> V.toList os
32− mAdditionalItems = additionalItems spec g s =<< H.lookup "additionalItems" (_rsData s)
33− Just $ \x ->
34− case x of
35− Array ys ->
36− let extras = V.drop (V.length os) ys
37− itemFailures = join $ fmap (modifyFailureName Items) <$> zipWith validate subSchemas (V.toList ys)
38− additionalItemFailures = runMaybeVal mAdditionalItems (Array extras)
39− in itemFailures <> fmap (modifyFailureName f) additionalItemFailures
40− _ -> mempty
41− where
42− f :: AdditionalItemsFailure err -> ItemsFailure err
43− f AdditionalBool = AdditionalItemsBool
44− f (AdditionalObject err) = AdditionalItemsObject err
45−items _ _ _ _ = Nothing
46−
47−-- | Not included directly in the 'draft4' spec hashmap because it always
48−-- validates data unless 'items' is also present. This is because 'items'
49−-- defaults to {}.
50−additionalItems :: ValidatorConstructor err [ValidationFailure (AdditionalItemsFailure err)]
51−additionalItems _ _ _ val@(Bool v) =
52− Just $ \x ->
53− case x of
54− Array ys ->
55− if not v && V.length ys > 0
56− then pure $ ValidationFailure AdditionalBool (FailureInfo val x)
57− else mempty
58− _ -> mempty
59−additionalItems spec g s (Object o) =
60− let subSchema = compile spec g (RawSchema (_rsURI s) o)
61− in Just $ \x ->
62− case x of
63− Array ys -> V.toList ys >>= fmap (modifyFailureName AdditionalObject) . validate subSchema
64− _ -> mempty
65−additionalItems _ _ _ _ = Nothing
66−
67−maxItems :: ValidatorConstructor err [FailureInfo]
68−maxItems _ _ _ val = do
69− n <- fromJSONInt val
70− greaterThanZero n
71− Just $ \x ->
72− case x of
73− Array ys ->
74− if V.length ys > n
75− then pure (FailureInfo val x)
76− else mempty
77− _ -> mempty
78−
79−minItems :: ValidatorConstructor err [FailureInfo]
80−minItems _ _ _ val = do
81− n <- fromJSONInt val
82− greaterThanZero n
83− Just $ \x ->
84− case x of
85− Array ys ->
86− if V.length ys < n
87− then pure (FailureInfo val x)
88− else mempty
89− _ -> mempty
90−
91−uniqueItems :: ValidatorConstructor err [FailureInfo]
92−uniqueItems _ _ _ val@(Bool v) = do
93− unless v Nothing
94− Just $ \x ->
95− case x of
96− (Array ys) -> if allUniqueValues ys
97− then mempty
98− else pure (FailureInfo val x)
99− _ -> mempty
100−uniqueItems _ _ _ _ = Nothing
src/Data/JsonSchema/Draft4/Failure.hsnew file+68
@@ -0,0 +1,68 @@
1+
2+module Data.JsonSchema.Draft4.Failure where
3+
4+import qualified Data.Aeson.Pointer as P
5+
6+import qualified Data.Validator.Failure as FR
7+import Import
8+
9+-- | A version of 'FR.Failure' specialized for JSON Schema Draft 4.
10+data Failure = Failure
11+ -- NOTE: We use a data type here instead of a newtype to provide a cleaner
12+ -- API for those importing only 'Data.JsonSchema.Draft4' (which should be
13+ -- the vast majority of users). Downsides: slower and hacky. I'd appreciate
14+ -- feedback on this.
15+ { _failureValidatorsCalled :: !ValidatorChain
16+ , _failureFinalValidator :: !Value
17+ , _failureOffendingData :: !P.Pointer
18+ } deriving (Eq, Show)
19+
20+specializeForDraft4 :: FR.Failure ValidatorChain -> Failure
21+specializeForDraft4 (FR.Failure a b c) = Failure a b c
22+
23+data ValidatorChain
24+ = MultipleOf
25+ | Maximum
26+ | ExclusiveMaximum
27+ | Minimum
28+ | ExclusiveMinimum
29+
30+ | MaxLength
31+ | MinLength
32+ | PatternValidator
33+
34+ | MaxItems
35+ | MinItems
36+ | UniqueItems
37+ | Items ValidatorChain
38+ | AdditionalItemsBool
39+ | AdditionalItemsObject ValidatorChain
40+
41+ | MaxProperties
42+ | MinProperties
43+ | Required
44+ | SchemaDependency ValidatorChain
45+ | PropertyDependency
46+ | Properties ValidatorChain
47+ | PatternProperties ValidatorChain
48+ | AdditionalPropertiesBool
49+ | AdditionalPropertiesObject ValidatorChain
50+
51+ | RefResolution
52+ -- ^ Indicates a reference that failed to resolve.
53+ --
54+ -- NOTE: The language agnostic test suite doesn't specify if this should
55+ -- cause a validation error or should allow data to pass. We choose to
56+ -- return a validation error.
57+ --
58+ -- Also note that ideally we would enforce in the type system that any
59+ -- failing references be dealt with before valididation. Then this could
60+ -- be removed entirely.
61+ | Ref ValidatorChain
62+ | Enum
63+ | TypeValidator
64+ | AllOf ValidatorChain
65+ | AnyOf
66+ | OneOf
67+ | NotValidator
68+ deriving (Eq, Show)
src/Data/JsonSchema/Draft4/Internal.hsnew file+280
@@ -0,0 +1,280 @@
1+
2+module Data.JsonSchema.Draft4.Internal where
3+
4+import Data.Aeson
5+import qualified Data.HashMap.Strict as H
6+import qualified Data.List.NonEmpty as N
7+import Data.Maybe (catMaybes, fromMaybe, isJust,
8+ maybeToList)
9+import Data.Scientific
10+
11+import Data.JsonSchema.Draft4.Failure
12+import Data.JsonSchema.Draft4.Schema
13+import Data.JsonSchema.Fetch (SchemaCache(..),
14+ SchemaContext(..))
15+import qualified Data.Validator.Draft4.Any as AN
16+import qualified Data.Validator.Draft4.Array as AR
17+import qualified Data.Validator.Draft4.Number as NU
18+import qualified Data.Validator.Draft4.Object as OB
19+import qualified Data.Validator.Draft4.String as ST
20+import Data.Validator.Failure (modFailure, setFailure)
21+import qualified Data.Validator.Failure as FR
22+import Data.Validator.Reference (newResolutionScope)
23+import Import
24+
25+-- For GHCs before 7.10:
26+import Prelude hiding (concat)
27+
28+--------------------------------------------------
29+-- * Embedded Schemas
30+--------------------------------------------------
31+
32+-- | Return a schema's immediate subschemas.
33+--
34+-- Pass this to 'fetchReferencedSchemas' so that function can find all the
35+-- subschemas in a document. This allows 'fetchReferencedSchemas' to process
36+-- only "$ref"s and "id"s that are actual schema keywords. For example,
37+-- within a "properties" validator object an "id" key doesn't actually change
38+-- any scope, but instead serves a validator-specific function.
39+embedded :: Schema -> [Schema]
40+embedded schema = concat
41+ [ f _schemaItems
42+ (\x -> case x of
43+ AR.ItemsObject s -> pure s
44+ AR.ItemsArray ss -> ss
45+ )
46+ , f _schemaAdditionalItems
47+ (\x -> case x of
48+ AR.AdditionalObject s -> pure s
49+ _ -> mempty
50+ )
51+ , f _schemaDependencies (catMaybes . fmap checkDependency . H.elems)
52+ , f _schemaProperties H.elems
53+ , f _schemaPatternProperties H.elems
54+ , f _schemaAdditionalProperties
55+ (\x -> case x of
56+ OB.AdditionalPropertiesObject s -> pure s
57+ _ -> mempty
58+ )
59+ , f _schemaAllOf N.toList
60+ , f _schemaAnyOf N.toList
61+ , f _schemaOneOf N.toList
62+ , f _schemaNot pure
63+ , f _schemaDefinitions H.elems
64+ ]
65+ where
66+ f :: (Schema -> Maybe a) -> (a -> [Schema]) -> [Schema]
67+ f field nextLevelEmbedded = maybe mempty nextLevelEmbedded (field schema)
68+
69+ checkDependency :: OB.Dependency Schema -> Maybe Schema
70+ checkDependency (OB.PropertyDependency _) = Nothing
71+ checkDependency (OB.SchemaDependency s) = Just s
72+
73+--------------------------------------------------
74+-- * Validation (Exported from 'Data.JsonSchema.Draft4')
75+--------------------------------------------------
76+
77+-- | In normal situations just use 'checkSchema', which is a combination of
78+-- 'schemaValidity' and 'runValidate'.
79+runValidate
80+ :: SchemaCache Schema
81+ -> SchemaContext Schema
82+ -> Value
83+ -> [Failure]
84+runValidate = (fmap.fmap.fmap.fmap) specializeForDraft4 validateAny
85+
86+--------------------------------------------------
87+-- * Validation (Main internal functions)
88+--------------------------------------------------
89+
90+validateAny
91+ :: SchemaCache Schema
92+ -> SchemaContext Schema
93+ -> Value
94+ -> [FR.Failure ValidatorChain]
95+validateAny cache sc x = concat
96+ [ f _schemaEnum (setFailure Enum) (fmap maybeToList . AN.enumVal)
97+ , f _schemaType (setFailure TypeValidator) (fmap maybeToList . AN.typeVal)
98+ , f _schemaAllOf (modFailure AllOf) (AN.allOf recurse)
99+ , f _schemaAnyOf (setFailure AnyOf) (fmap maybeToList . AN.anyOf recurse)
100+ , f _schemaOneOf (setFailure OneOf) (fmap maybeToList . AN.oneOf recurse)
101+ , f _schemaNot (setFailure NotValidator) (fmap maybeToList . AN.notVal recurse)
102+ , refFailures
103+ ] <> specificValidators
104+ where
105+ specificValidators :: [FR.Failure ValidatorChain]
106+ specificValidators =
107+ case x of
108+ Number y -> validateNumber (_scSchema sc) y
109+ String y -> validateString (_scSchema sc) y
110+ Array y -> validateArray cache sc y
111+ Object y -> validateObject cache sc y
112+ _ -> mempty
113+
114+ f = runSingle (_scSchema sc) x
115+
116+ recurse = descendNextLevel cache sc
117+
118+ -- Since the results of the 'AN.ref' validator are fairly complicated [1]
119+ -- it's simpler not to use our 'f' helper function for it.
120+ --
121+ -- [1] A list of errors wrapped in a 'Maybe' where 'Nothing' represents
122+ -- if resolving the reference itself failed.
123+ refFailures :: [FR.Failure ValidatorChain]
124+ refFailures =
125+ case _schemaRef (_scSchema sc) of
126+ Nothing -> mempty
127+ Just reference ->
128+ maybe [FR.Failure RefResolution (toJSON reference) mempty]
129+ (fmap (modFailure Ref))
130+ $ AN.ref scope
131+ getReference
132+ (\a b -> validateAny cache (SchemaContext a b))
133+ reference
134+ x
135+ where
136+ scope :: Maybe Text
137+ scope = newResolutionScope (_scURI sc) (_schemaId (_scSchema sc))
138+
139+ getReference :: Maybe Text -> Maybe Schema
140+ getReference Nothing = Just (_startingSchema cache)
141+ getReference (Just t) = H.lookup t (_cachedSchemas cache)
142+
143+validateString
144+ :: Schema
145+ -> Text
146+ -> [FR.Failure ValidatorChain]
147+validateString schema x = concat
148+ [ f _schemaMaxLength (setFailure MaxLength) (fmap maybeToList . ST.maxLength)
149+ , f _schemaMinLength (setFailure MinLength) (fmap maybeToList . ST.minLength)
150+ , f _schemaPattern (setFailure PatternValidator) (fmap maybeToList . ST.patternVal)
151+ ]
152+ where
153+ f = runSingle schema x
154+
155+validateNumber
156+ :: Schema
157+ -> Scientific
158+ -> [FR.Failure ValidatorChain]
159+validateNumber schema x = concat
160+ [ f _schemaMultipleOf (setFailure MultipleOf) (fmap maybeToList . NU.multipleOf)
161+ , f _schemaMaximum
162+ (modFailure fMax)
163+ ( fmap maybeToList
164+ . NU.maximumVal (fromMaybe False (_schemaExclusiveMaximum schema))
165+ )
166+ , f _schemaMinimum
167+ (modFailure fMin)
168+ ( fmap maybeToList
169+ . NU.minimumVal (fromMaybe False (_schemaExclusiveMinimum schema))
170+ )
171+ ]
172+ where
173+ f = runSingle schema x
174+
175+ fMax NU.Maximum = Maximum
176+ fMax NU.ExclusiveMaximum = ExclusiveMaximum
177+
178+ fMin NU.Minimum = Minimum
179+ fMin NU.ExclusiveMinimum = ExclusiveMinimum
180+
181+validateArray
182+ :: SchemaCache Schema
183+ -> SchemaContext Schema
184+ -> Vector Value
185+ -> [FR.Failure ValidatorChain]
186+validateArray cache (SchemaContext mUri schema) x = concat
187+ [ f _schemaMaxItems (setFailure MaxItems) (fmap maybeToList . AR.maxItems)
188+ , f _schemaMinItems (setFailure MinItems) (fmap maybeToList . AR.minItems)
189+ , f _schemaUniqueItems (setFailure UniqueItems) (fmap maybeToList . AR.uniqueItems)
190+ , f _schemaItems
191+ (modFailure fItems)
192+ (AR.items recurse (_schemaAdditionalItems schema))
193+ ]
194+ where
195+ f = runSingle schema x
196+
197+ recurse = descendNextLevel cache (SchemaContext mUri schema)
198+
199+ fItems (AR.Items err) = Items err
200+ fItems AR.AdditionalItemsBoolFailure = AdditionalItemsBool
201+ fItems (AR.AdditionalItemsObjectFailure err) = AdditionalItemsObject err
202+
203+validateObject
204+ :: SchemaCache Schema
205+ -> SchemaContext Schema
206+ -> HashMap Text Value
207+ -> [FR.Failure ValidatorChain]
208+validateObject cache (SchemaContext mUri schema) x = concat
209+ [ f _schemaMaxProperties (setFailure MaxProperties) (fmap maybeToList . OB.maxProperties)
210+ , f _schemaMinProperties (setFailure MinProperties) (fmap maybeToList . OB.minProperties)
211+ , f _schemaRequired (setFailure Required) (fmap maybeToList . OB.required)
212+ , f _schemaDependencies (modFailure fDeps) (OB.dependencies recurse)
213+
214+ , f _schemaProperties
215+ (modFailure fProp)
216+ (OB.properties recurse
217+ (_schemaPatternProperties schema)
218+ (_schemaAdditionalProperties schema))
219+
220+ , f _schemaPatternProperties
221+ (modFailure fPatProp)
222+ (case _schemaProperties schema of
223+ Just _ -> const (const mempty)
224+ Nothing -> OB.patternProperties recurse (_schemaAdditionalProperties schema))
225+
226+ , f _schemaAdditionalProperties
227+ (modFailure fAddProp)
228+ (if isJust (_schemaProperties schema) || isJust (_schemaPatternProperties schema)
229+ then const (const mempty)
230+ else OB.additionalProperties recurse)
231+ ]
232+ where
233+ f = runSingle schema x
234+
235+ recurse = descendNextLevel cache (SchemaContext mUri schema)
236+
237+ fDeps (OB.SchemaDependencyFailure err) = SchemaDependency err
238+ fDeps OB.PropertyDependencyFailure = PropertyDependency
239+
240+ fProp (OB.PropertiesFailure err) = Properties err
241+ fProp (OB.PropPatternFailure err) = PatternProperties err
242+ fProp (OB.PropAdditionalFailure a) =
243+ case a of
244+ OB.APBoolFailure -> AdditionalPropertiesBool
245+ OB.APObjectFailure err -> AdditionalPropertiesObject err
246+
247+ fPatProp (OB.PPFailure err) = PatternProperties err
248+ fPatProp (OB.PPAdditionalPropertiesFailure a) =
249+ case a of
250+ OB.APBoolFailure -> AdditionalPropertiesBool
251+ OB.APObjectFailure err -> AdditionalPropertiesObject err
252+
253+ fAddProp OB.APBoolFailure = AdditionalPropertiesBool
254+ fAddProp (OB.APObjectFailure err) = AdditionalItemsObject err
255+
256+--------------------------------------------------
257+-- * Validation (Internal utils)
258+--------------------------------------------------
259+
260+descendNextLevel
261+ :: SchemaCache Schema
262+ -> SchemaContext Schema
263+ -> Schema
264+ -> Value
265+ -> [FR.Failure ValidatorChain]
266+descendNextLevel cache (SchemaContext mUri schema) =
267+ validateAny cache . SchemaContext scope
268+ where
269+ scope :: Maybe Text
270+ scope = newResolutionScope mUri (_schemaId schema)
271+
272+runSingle
273+ :: Schema
274+ -> dta
275+ -> (Schema -> Maybe val)
276+ -> (err -> FR.Failure ValidatorChain)
277+ -> (val -> dta -> [err])
278+ -> [FR.Failure ValidatorChain]
279+runSingle schema dta field modifyError validate =
280+ maybe mempty (\val -> modifyError <$> validate val dta) (field schema)
src/Data/JsonSchema/Draft4/Numbers.hsdeleted−61
@@ -1,61 +0,0 @@
1−
2−module Data.JsonSchema.Draft4.Numbers where
3−
4−import Data.Fixed (mod')
5−import qualified Data.HashMap.Strict as H
6−import Data.Scientific
7−
8−import Data.JsonSchema.Core
9−import Data.JsonSchema.Helpers
10−import Import
11−
12−data MaximumFailure = Maximum | ExclusiveMaximum
13−data MinimumFailure = Minimum | ExclusiveMinimum
14−
15−multipleOf :: ValidatorConstructor err [FailureInfo]
16−multipleOf _ _ _ val@(Number n) = do
17− greaterThanZero n
18− Just $ \x ->
19− case x of
20− Number y ->
21− if y `mod'` n /= 0
22− then pure (FailureInfo val x)
23− else mempty
24− _ -> mempty
25−multipleOf _ _ _ _ = Nothing
26−
27−maximumVal :: ValidatorConstructor err [ValidationFailure MaximumFailure]
28−maximumVal _ _ s val@(Number n) =
29− Just $ \x ->
30− case x of
31− Number y ->
32− let (greater, err) = checkExclusive
33− in if y `greater` n
34− then pure $ ValidationFailure err (FailureInfo val x)
35− else mempty
36− _ -> mempty
37− where
38− checkExclusive :: (Scientific -> Scientific -> Bool, MaximumFailure)
39− checkExclusive =
40− case H.lookup "exclusiveMaximum" (_rsData s) of
41− Just (Bool a) -> if a then ((>=), ExclusiveMaximum) else ((>), Maximum)
42− _ -> ((>), Maximum)
43−maximumVal _ _ _ _ = Nothing
44−
45−minimumVal :: ValidatorConstructor err [ValidationFailure MinimumFailure]
46−minimumVal _ _ s val@(Number n) =
47− Just $ \x ->
48− case x of
49− Number y ->
50− let (lesser, err) = checkExclusive
51− in if y `lesser` n
52− then pure $ ValidationFailure err (FailureInfo val x)
53− else mempty
54− _ -> mempty
55− where
56− checkExclusive :: (Scientific -> Scientific -> Bool, MinimumFailure)
57− checkExclusive =
58− case H.lookup "exclusiveMinimum" (_rsData s) of
59− Just (Bool a) -> if a then ((<=), ExclusiveMinimum) else ((<), Minimum)
60− _ -> ((<), Minimum)
61−minimumVal _ _ _ _ = Nothing
src/Data/JsonSchema/Draft4/Objects.hsdeleted−118
@@ -1,118 +0,0 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
2−
3−module Data.JsonSchema.Draft4.Objects
4− ( module Data.JsonSchema.Draft4.Objects
5− , module Data.JsonSchema.Draft4.Objects.Properties
6− ) where
7−
8−import Control.Monad
9−import Data.Aeson
10−import Data.Hashable
11−import qualified Data.HashMap.Strict as H
12−import qualified Data.Vector as V
13−
14−import Data.JsonSchema.Core
15−import Data.JsonSchema.Draft4.Objects.Properties
16−import Data.JsonSchema.Helpers
17−import Import
18−
19−data DependencyFailure err = SchemaDependency err | PropertyDependency
20−
21−maxProperties :: ValidatorConstructor err [FailureInfo]
22−maxProperties _ _ _ val = do
23− n <- fromJSONInt val
24− greaterThanZero n
25− Just $ \x ->
26− case x of
27− Object o ->
28− if H.size o > n
29− then pure (FailureInfo val x)
30− else mempty
31− _ -> mempty
32−
33−minProperties :: ValidatorConstructor err [FailureInfo]
34−minProperties _ _ _ val = do
35− n <- fromJSONInt val
36− greaterThanZero n
37− Just $ \x ->
38− case x of
39− Object o ->
40− if H.size o < n
41− then pure (FailureInfo val x)
42− else mempty
43− _ -> mempty
44−
45−required :: ValidatorConstructor err [FailureInfo]
46−required _ _ _ val@(Array vs) = do
47− when (V.length vs == 0) Nothing
48− ts <- traverse toTxt vs
49− let a = vectorToMapSet ts
50− when (H.size a /= V.length ts) Nothing
51− Just $ \x ->
52− case x of
53− Object o ->
54− if H.size (H.difference a o) > 0
55− then pure (FailureInfo val x)
56− else mempty
57− _ -> mempty
58− where
59− vectorToMapSet :: (Eq a, Hashable a) => Vector a -> HashMap a Bool
60− vectorToMapSet vec = H.fromList . V.toList $ (\x -> (x, True)) <$> vec -- TODO: use a fold.
61−required _ _ _ _ = Nothing
62−
63−-- http://json-schema.org/latest/json-schema-validation.html#anchor70
64−--
65−-- > This keyword's value MUST be an object.
66−-- > Each value of this object MUST be either an object or an array.
67−-- >
68−-- > If the value is an object, it MUST be a valid JSON Schema.
69−-- > This is called a schema dependency.
70−-- >
71−-- > If the value is an array, it MUST have at least one element.
72−-- > Each element MUST be a string, and elements in the array MUST be unique.
73−-- > This is called a property dependency.
74−dependencies :: ValidatorConstructor err [ValidationFailure (DependencyFailure err)]
75−dependencies spec g s val@(Object o) = do
76− let vs = H.toList o
77− schemaDeps = vs >>= toSchemaDep spec g
78− propDeps = vs >>= toPropDep
79− when (length schemaDeps + length propDeps /= length vs) Nothing
80− Just $ \x ->
81− case x of
82− Object y ->
83− let schemaFailures = join $ valSD y <$> schemaDeps
84− propertyFailures = join $ valPD y <$> propDeps
85− in schemaFailures <> propertyFailures
86− _ -> mempty
87− where
88− toSchemaDep :: Spec a -> SchemaGraph -> (Text, Value) -> [(Text, Schema a)]
89− toSchemaDep spc gr (t, Object ob) = pure (t, compile spc gr $ RawSchema (_rsURI s) ob)
90− toSchemaDep _ _ _ = mempty
91−
92− toPropDep :: (Text, Value) -> [(Text, Vector Text)]
93− toPropDep (t, Array a) =
94− if V.length a <= 0
95− then mempty
96− else case traverse toTxt a of
97− Nothing -> mempty
98− Just ts ->
99− if allUnique ts
100− then pure (t, ts)
101− else mempty
102− toPropDep _ = mempty
103−
104− valSD :: HashMap Text Value -> (Text, Schema err) -> [ValidationFailure (DependencyFailure err)]
105− valSD d (k, subSchema) =
106− case H.lookup k d of
107− Nothing -> mempty
108− Just _ -> modifyFailureName SchemaDependency <$> validate subSchema (Object d)
109−
110− valPD :: HashMap Text Value -> (Text, Vector Text) -> [ValidationFailure (DependencyFailure err)]
111− valPD d (k, ks) =
112− case H.lookup k d of
113− Nothing -> mempty
114− Just _ ->
115− case traverse (flip H.lookup d) ks of
116− Nothing -> pure $ ValidationFailure PropertyDependency (FailureInfo val (Object d))
117− Just _ -> mempty
118−dependencies _ _ _ _ = Nothing
src/Data/JsonSchema/Draft4/Objects/Properties.hsdeleted−145
@@ -1,145 +0,0 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
2−
3−module Data.JsonSchema.Draft4.Objects.Properties where
4−
5−import Control.Monad
6−import Data.Aeson
7−import qualified Data.HashMap.Strict as H
8−import Data.Maybe
9−import qualified Data.Text as T
10−import Text.RegexPR
11−
12−import Data.JsonSchema.Core
13−import Data.JsonSchema.Helpers
14−import Import
15−
16−data PropertiesFailure err
17− = Properties err
18− | PropPattern err
19− | PropAdditional (AdditionalPropertiesFailure err)
20−
21−data PatternPropertiesFailure err
22− = PatternProperties err
23− | PatternAdditional (AdditionalPropertiesFailure err)
24−
25−data AdditionalPropertiesFailure err
26− = AdditionalPropertiesBool
27− | AdditionalPropertiesObject err
28−
29−-- | In order of what's tried: properties, patternProperties, additionalProperties
30−properties :: forall err. ValidatorConstructor err [ValidationFailure (PropertiesFailure err)]
31−properties spec g s val = do
32− let mProps = propertiesUnmatched val
33− mPatProp = patternUnmatched spec g s =<< H.lookup "patternProperties" (_rsData s)
34− mAddProp = runAdditionalProperties spec g s =<< H.lookup "additionalProperties" (_rsData s)
35− when (isNothing mProps && isNothing mPatProp && isNothing mAddProp) Nothing
36− Just $ \x ->
37− case x of
38− Object y ->
39− let (propFailures, remaining) = runMaybeVal' mProps (Object y)
40− patternFailures = fst $ runMaybeVal' mPatProp (Object y)
41− remaining' = snd $ runMaybeVal' mPatProp remaining
42− additionalFailures = runMaybeVal mAddProp remaining'
43− in fmap (modifyFailureName Properties) propFailures
44− <> fmap (modifyFailureName PropPattern) patternFailures
45− <> fmap (modifyFailureName PropAdditional) additionalFailures
46− _ -> mempty
47− where
48− propertiesUnmatched :: Value -> Maybe (Value -> ([ValidationFailure err], Value))
49− propertiesUnmatched (Object o) = do
50− os <- traverse toObj o
51− let matchedSchemas = compile spec g . RawSchema (_rsURI s) <$> os
52− Just (\x ->
53− case x of
54− Object y ->
55− let rawFailures = H.intersectionWith validate matchedSchemas y
56− failures = join (H.elems rawFailures)
57− leftovers = Object (H.difference y matchedSchemas)
58− in (failures, leftovers)
59− z -> (mempty, z))
60− propertiesUnmatched _ = Nothing
61−
62−patternProperties :: ValidatorConstructor err [ValidationFailure (PatternPropertiesFailure err)]
63−patternProperties spec g s val = do
64− when (H.member "properties" (_rsData s)) Nothing
65− let mPatternProps = patternUnmatched spec g s val
66− let mAdditionalProps = runAdditionalProperties spec g s =<< H.lookup "additionalProperties" (_rsData s)
67− when (isNothing mPatternProps && isNothing mAdditionalProps) Nothing
68− Just $ \x ->
69− case x of
70− Object y ->
71− let (ppFailures, remaining') = runMaybeVal' mPatternProps (Object y)
72− addFailures = runMaybeVal mAdditionalProps remaining'
73− in fmap (modifyFailureName PatternProperties) ppFailures <> fmap (modifyFailureName PatternAdditional) addFailures
74− _ -> mempty
75−
76−patternUnmatched
77− :: Spec err
78− -> SchemaGraph
79− -> RawSchema
80− -> Value
81− -> Maybe (Value -> ([ValidationFailure err], Value))
82−patternUnmatched spec g s (Object val) = do
83− os <- traverse toObj val
84− let subSchemas = compile spec g . RawSchema (_rsURI s) <$> os
85− Just (\x ->
86− case x of
87− Object y -> let ms = H.foldlWithKey' (matches subSchemas) mempty y
88− in (H.foldl' runVals mempty ms, Object (leftovers ms))
89− _ -> (mempty, x))
90− where
91− matches
92− :: HashMap Text (Schema a)
93− -> HashMap Text (Value, [Schema a])
94− -> Text
95− -> Value
96− -> HashMap Text (Value, [Schema a])
97− matches subSchemas acc k v = H.insert k (v, H.foldlWithKey' (match k) mempty subSchemas) acc
98−
99− match
100− :: Text
101− -> [Schema a]
102− -> Text
103− -> Schema a
104− -> [Schema a]
105− match k acc r subSchema =
106− case matchRegexPR (T.unpack r) (T.unpack k) of
107− Nothing -> acc
108− Just _ -> pure subSchema <> acc
109−
110− runVals
111− :: [ValidationFailure err]
112− -> (Value, [Schema err])
113− -> [ValidationFailure err]
114− runVals acc (v,subSchema) = (subSchema >>= flip validate v) <> acc
115−
116− leftovers :: HashMap Text (Value, [Schema a]) -> HashMap Text Value
117− leftovers possiblyMatched = fst <$> H.filter (null . snd) possiblyMatched
118−patternUnmatched _ _ _ _ = Nothing
119−
120−additionalProperties :: ValidatorConstructor err [ValidationFailure (AdditionalPropertiesFailure err)]
121−additionalProperties spec g s val = do
122− when (H.member "properties" (_rsData s)) Nothing
123− when (H.member "patternProperties" (_rsData s)) Nothing
124− runAdditionalProperties spec g s val
125−
126−-- | An additionalProperties validator than never disables itself.
127−--
128−-- Not meant to be used standalone, but useful inside of the properties
129−-- and patternProperties validators.
130−runAdditionalProperties :: ValidatorConstructor err [ValidationFailure (AdditionalPropertiesFailure err)]
131−runAdditionalProperties _ _ _ val@(Bool v) =
132− Just $ \x ->
133− case x of
134− Object y ->
135− if not v && H.size y > 0
136− then pure $ ValidationFailure AdditionalPropertiesBool (FailureInfo val x)
137− else mempty
138− _ -> mempty
139−runAdditionalProperties spec g s (Object o) =
140− let sub = compile spec g (RawSchema (_rsURI s) o)
141− in Just $ \x ->
142− case x of
143− Object y -> H.elems y >>= fmap (modifyFailureName AdditionalPropertiesObject) . validate sub
144− _ -> mempty
145−runAdditionalProperties _ _ _ _ = Nothing
src/Data/JsonSchema/Draft4/Schema.hsnew file+334
@@ -0,0 +1,334 @@
1+
2+module Data.JsonSchema.Draft4.Schema where
3+
4+import qualified Data.HashMap.Strict as H
5+import Data.List.NonEmpty (NonEmpty)
6+import Data.Maybe (fromJust, isJust)
7+import Data.Scientific
8+
9+import qualified Data.Validator.Draft4.Any as AN
10+import qualified Data.Validator.Draft4.Array as AR
11+import qualified Data.Validator.Draft4.Object as OB
12+import Data.Validator.Utils
13+import Import
14+
15+data Schema = Schema
16+ { _schemaVersion :: Maybe Text
17+ , _schemaId :: Maybe Text
18+ , _schemaRef :: Maybe Text
19+ , _schemaDefinitions :: Maybe (HashMap Text Schema)
20+ -- ^ A standardized location for embedding schemas
21+ -- to be referenced from elsewhere in the document.
22+ , _schemaOther :: HashMap Text Value
23+ -- ^ Since the JSON document this Schema was built from could
24+ -- contain schemas anywhere (not just in "definitions" or any
25+ -- of the other official keys) we save any leftover key/value
26+ -- pairs not covered by them here.
27+
28+ , _schemaMultipleOf :: Maybe Scientific
29+ , _schemaMaximum :: Maybe Scientific
30+ , _schemaExclusiveMaximum :: Maybe Bool
31+ , _schemaMinimum :: Maybe Scientific
32+ , _schemaExclusiveMinimum :: Maybe Bool
33+
34+ , _schemaMaxLength :: Maybe Int
35+ , _schemaMinLength :: Maybe Int
36+ , _schemaPattern :: Maybe Text
37+
38+ , _schemaMaxItems :: Maybe Int
39+ , _schemaMinItems :: Maybe Int
40+ , _schemaUniqueItems :: Maybe Bool
41+ , _schemaItems :: Maybe (AR.Items Schema)
42+ -- Note that '_schemaAdditionalItems' is left out of 'runValidate'
43+ -- because its functionality is handled by '_schemaItems'. It always
44+ -- validates data unless 'Items' is present.
45+ , _schemaAdditionalItems :: Maybe (AR.AdditionalItems Schema)
46+
47+ , _schemaMaxProperties :: Maybe Int
48+ , _schemaMinProperties :: Maybe Int
49+ , _schemaRequired :: Maybe OB.Required
50+ , _schemaDependencies :: Maybe (HashMap Text (OB.Dependency Schema))
51+ , _schemaProperties :: Maybe (HashMap Text Schema)
52+ , _schemaPatternProperties :: Maybe (HashMap Text Schema)
53+ , _schemaAdditionalProperties :: Maybe (OB.AdditionalProperties Schema)
54+
55+ , _schemaEnum :: Maybe AN.EnumVal
56+ , _schemaType :: Maybe AN.TypeVal
57+ , _schemaAllOf :: Maybe (NonEmpty Schema)
58+ , _schemaAnyOf :: Maybe (NonEmpty Schema)
59+ , _schemaOneOf :: Maybe (NonEmpty Schema)
60+ , _schemaNot :: Maybe Schema
61+ } deriving (Eq, Show)
62+
63+emptySchema :: Schema
64+emptySchema = Schema
65+ { _schemaVersion = Nothing
66+ , _schemaId = Nothing
67+ , _schemaRef = Nothing
68+ , _schemaDefinitions = Nothing
69+ , _schemaOther = mempty
70+
71+ , _schemaMultipleOf = Nothing
72+ , _schemaMaximum = Nothing
73+ , _schemaExclusiveMaximum = Nothing
74+ , _schemaMinimum = Nothing
75+ , _schemaExclusiveMinimum = Nothing
76+
77+ , _schemaMaxLength = Nothing
78+ , _schemaMinLength = Nothing
79+ , _schemaPattern = Nothing
80+
81+ , _schemaMaxItems = Nothing
82+ , _schemaMinItems = Nothing
83+ , _schemaUniqueItems = Nothing
84+ , _schemaItems = Nothing
85+ , _schemaAdditionalItems = Nothing
86+
87+ , _schemaMaxProperties = Nothing
88+ , _schemaMinProperties = Nothing
89+ , _schemaRequired = Nothing
90+ , _schemaDependencies = Nothing
91+ , _schemaProperties = Nothing
92+ , _schemaPatternProperties = Nothing
93+ , _schemaAdditionalProperties = Nothing
94+
95+ , _schemaEnum = Nothing
96+ , _schemaType = Nothing
97+ , _schemaAllOf = Nothing
98+ , _schemaAnyOf = Nothing
99+ , _schemaOneOf = Nothing
100+ , _schemaNot = Nothing
101+ }
102+
103+instance FromJSON Schema where
104+ parseJSON = withObject "Schema" $ \o -> do
105+ a <- o .:? "$schema"
106+ b <- o .:? "id"
107+ c <- o .:? "$ref"
108+ d <- o .:? "definitions"
109+ e <- parseJSON (Object (H.difference o internalSchemaHashMap))
110+
111+ f <- o .:? "multipleOf"
112+ g <- o .:? "maximum"
113+ h <- o .:? "exclusiveMaximum"
114+ i <- o .:? "minimum"
115+ j <- o .:? "exclusiveMinimum"
116+
117+ k <- o .:? "maxLength"
118+ l <- o .:? "minLength"
119+ m <- o .:? "pattern"
120+
121+ n <- o .:? "maxItems"
122+ o' <- o .:? "minItems"
123+ p <- o .:? "uniqueItems"
124+ q <- o .:? "items"
125+ r <- o .:? "additionalItems"
126+
127+ s <- o .:? "maxProperties"
128+ t <- o .:? "minProperties"
129+ u <- o .:? "required"
130+ v <- o .:? "dependencies"
131+ w <- o .:? "properties"
132+ x <- o .:? "patternProperties"
133+ y <- o .:? "additionalProperties"
134+
135+ z <- o .:? "enum"
136+ a2 <- o .:? "type"
137+ b2 <- fmap _unNonEmpty' <$> o .:? "allOf"
138+ c2 <- fmap _unNonEmpty' <$> o .:? "anyOf"
139+ d2 <- fmap _unNonEmpty' <$> o .:? "oneOf"
140+ e2 <- o .:? "not"
141+ pure Schema
142+ { _schemaVersion = a
143+ , _schemaId = b
144+ , _schemaRef = c
145+ , _schemaDefinitions = d
146+ , _schemaOther = e
147+
148+ , _schemaMultipleOf = f
149+ , _schemaMaximum = g
150+ , _schemaExclusiveMaximum = h
151+ , _schemaMinimum = i
152+ , _schemaExclusiveMinimum = j
153+
154+ , _schemaMaxLength = k
155+ , _schemaMinLength = l
156+ , _schemaPattern = m
157+
158+ , _schemaMaxItems = n
159+ , _schemaMinItems = o'
160+ , _schemaUniqueItems = p
161+ , _schemaItems = q
162+ , _schemaAdditionalItems = r
163+
164+ , _schemaMaxProperties = s
165+ , _schemaMinProperties = t
166+ , _schemaRequired = u
167+ , _schemaDependencies = v
168+ , _schemaProperties = w
169+ , _schemaPatternProperties = x
170+ , _schemaAdditionalProperties = y
171+
172+ , _schemaEnum = z
173+ , _schemaType = a2
174+ , _schemaAllOf = b2
175+ , _schemaAnyOf = c2
176+ , _schemaOneOf = d2
177+ , _schemaNot = e2
178+ }
179+
180+instance ToJSON Schema where
181+ -- | The way we resolve JSON Pointers to embedded schemas is by
182+ -- serializing the containing schema to a value and then resolving the
183+ -- pointer against it. This means that FromJSON and ToJSON must be
184+ -- isomorphic.
185+ --
186+ -- This influences the design choices in the library. E.g. right now
187+ -- there are two false values for "exclusiveMaximum" -- Nothing and
188+ -- Just False. We could have condensed them down by using () instead
189+ -- of Bool for "exclusiveMaximum". This would have made writing schemas
190+ -- in haskell easier, but we could no longer round trip through/from
191+ -- JSON without losing information.
192+ toJSON s = Object $ H.union (mapMaybe ($ s) internalSchemaHashMap) (toJSON <$> _schemaOther s)
193+ where
194+ -- 'mapMaybe' is provided by unordered-containers after unordered-container-2.6.0.0,
195+ -- but until that is a little older (and has time to get into Stackage etc.)
196+ -- we use our own implementation.
197+ mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2
198+ mapMaybe f = fmap fromJust . H.filter isJust . fmap f
199+
200+-- | Internal. Separate from ToJSON because it's also used
201+-- by FromJSON to determine what keys aren't official schema
202+-- keys and therefor should be included in _schemaOther.
203+internalSchemaHashMap :: HashMap Text (Schema -> Maybe Value)
204+internalSchemaHashMap = H.fromList
205+ [ ("$schema" , f _schemaVersion)
206+ , ("id" , f _schemaId)
207+ , ("$ref" , f _schemaRef)
208+ , ("definitions" , f _schemaDefinitions)
209+
210+ , ("multipleOf" , f _schemaMultipleOf)
211+ , ("maximum" , f _schemaMaximum)
212+ , ("exclusiveMaximum" , f _schemaExclusiveMaximum)
213+ , ("minimum" , f _schemaMinimum)
214+ , ("exclusiveMinimum" , f _schemaExclusiveMinimum)
215+
216+ , ("maxLength" , f _schemaMaxLength)
217+ , ("minLength" , f _schemaMinLength)
218+ , ("pattern" , f _schemaPattern)
219+
220+ , ("maxItems" , f _schemaMaxItems)
221+ , ("minItems" , f _schemaMinItems)
222+ , ("uniqueItems" , f _schemaUniqueItems)
223+ , ("items" , f _schemaItems)
224+ , ("additionalItems" , f _schemaAdditionalItems)
225+
226+ , ("maxProperties" , f _schemaMaxProperties)
227+ , ("minProperties" , f _schemaMinProperties)
228+ , ("required" , f _schemaRequired)
229+ , ("dependencies" , f _schemaDependencies)
230+ , ("properties" , f _schemaProperties)
231+ , ("patternProperties" , f _schemaPatternProperties)
232+ , ("additionalProperties", f _schemaAdditionalProperties)
233+
234+ , ("enum" , f _schemaEnum)
235+ , ("type" , f _schemaType)
236+ , ("allOf" , f (fmap NonEmpty' . _schemaAllOf))
237+ , ("anyOf" , f (fmap NonEmpty' . _schemaAnyOf))
238+ , ("oneOf" , f (fmap NonEmpty' . _schemaOneOf))
239+ , ("not" , f _schemaNot)
240+ ]
241+ where
242+ f :: ToJSON a => (Schema -> Maybe a) -> Schema -> Maybe Value
243+ f = (fmap.fmap) toJSON
244+
245+instance Arbitrary Schema where
246+ arbitrary = sized f
247+ where
248+ maybeGen :: Gen a -> Gen (Maybe a)
249+ maybeGen a = oneof [pure Nothing, Just <$> a]
250+
251+ maybeRecurse :: Int -> Gen a -> Gen (Maybe a)
252+ maybeRecurse n a
253+ | n < 1 = pure Nothing
254+ | otherwise = maybeGen $ resize (n `div` 10) a
255+
256+ f :: Int -> Gen Schema
257+ f n = do
258+ a <- maybeGen arbitraryText
259+ b <- maybeGen arbitraryText
260+ c <- maybeGen arbitraryText
261+ -- NOTE: The next two fields are empty to generate cleaner schemas,
262+ -- but note that this means we don't test e.g. the invertability
263+ -- of these fields.
264+ d <- pure Nothing -- _schemaDefinitions
265+ e <- pure mempty -- _otherPairs
266+
267+ f' <- maybeGen arbitraryPositiveScientific
268+ g <- maybeGen arbitraryScientific
269+ h <- arbitrary
270+ i <- maybeGen arbitraryScientific
271+ j <- arbitrary
272+
273+ k <- maybeGen (getPositive <$> arbitrary)
274+ l <- maybeGen (getPositive <$> arbitrary)
275+ m <- maybeGen arbitraryText
276+
277+ n' <- maybeGen (getPositive <$> arbitrary)
278+ o <- maybeGen (getPositive <$> arbitrary)
279+ p <- arbitrary
280+ q <- maybeRecurse n arbitrary
281+ r <- maybeRecurse n arbitrary
282+
283+ s <- maybeGen (getPositive <$> arbitrary)
284+ t <- maybeGen (getPositive <$> arbitrary)
285+ u <- arbitrary
286+ v <- maybeRecurse n arbitraryHashMap
287+ w <- maybeRecurse n arbitraryHashMap
288+ x <- maybeRecurse n arbitraryHashMap
289+ y <- maybeRecurse n arbitrary
290+
291+ z <- arbitrary
292+ a2 <- arbitrary
293+ b2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)
294+ c2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)
295+ d2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)
296+ e2 <- maybeRecurse n arbitrary
297+ pure Schema
298+ { _schemaVersion = a
299+ , _schemaId = b
300+ , _schemaRef = c
301+ , _schemaDefinitions = d
302+ , _schemaOther = e
303+
304+ , _schemaMultipleOf = f'
305+ , _schemaMaximum = g
306+ , _schemaExclusiveMaximum = h
307+ , _schemaMinimum = i
308+ , _schemaExclusiveMinimum = j
309+
310+ , _schemaMaxLength = k
311+ , _schemaMinLength = l
312+ , _schemaPattern = m
313+
314+ , _schemaMaxItems = n'
315+ , _schemaMinItems = o
316+ , _schemaUniqueItems = p
317+ , _schemaItems = q
318+ , _schemaAdditionalItems = r
319+
320+ , _schemaMaxProperties = s
321+ , _schemaMinProperties = t
322+ , _schemaRequired = u
323+ , _schemaDependencies = v
324+ , _schemaProperties = w
325+ , _schemaPatternProperties = x
326+ , _schemaAdditionalProperties = y
327+
328+ , _schemaEnum = z
329+ , _schemaType = a2
330+ , _schemaAllOf = b2
331+ , _schemaAnyOf = c2
332+ , _schemaOneOf = d2
333+ , _schemaNot = e2
334+ }
src/Data/JsonSchema/Draft4/Strings.hsdeleted−44
@@ -1,44 +0,0 @@
1−
2−module Data.JsonSchema.Draft4.Strings where
3−
4−import qualified Data.Text as T
5−import Text.RegexPR
6−
7−import Data.JsonSchema.Core
8−import Data.JsonSchema.Helpers
9−import Import
10−
11−maxLength :: ValidatorConstructor err [FailureInfo]
12−maxLength _ _ _ val = do
13− n <- fromJSONInt val
14− greaterThanZero n
15− Just $ \x ->
16− case x of
17− String y ->
18− if T.length y > n
19− then pure (FailureInfo val x)
20− else mempty
21− _ -> mempty
22−
23−minLength :: ValidatorConstructor err [FailureInfo]
24−minLength _ _ _ val = do
25− n <- fromJSONInt val
26− greaterThanZero n
27− Just $ \x ->
28− case x of
29− String y ->
30− if T.length y < n
31− then pure (FailureInfo val x)
32− else mempty
33− _ -> mempty
34−
35−pattern :: ValidatorConstructor err [FailureInfo]
36−pattern _ _ _ val@(String t) =
37− Just $ \x ->
38− case x of
39− String y ->
40− case matchRegexPR (T.unpack t) (T.unpack y) of
41− Nothing -> pure (FailureInfo val x)
42− Just _ -> mempty
43− _ -> mempty
44−pattern _ _ _ _ = Nothing
src/Data/JsonSchema/Fetch.hsnew file+133
@@ -0,0 +1,133 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+
3+module Data.JsonSchema.Fetch where
4+
5+import Control.Exception (SomeException(..), catch)
6+import qualified Data.ByteString.Lazy as LBS
7+import qualified Data.HashMap.Strict as H
8+import qualified Data.Text as T
9+import Network.HTTP.Client
10+
11+import Data.Validator.Reference (isRemoteReference,
12+ newResolutionScope,
13+ resolveReference)
14+import Import
15+
16+-- For GHCs before 7.10:
17+import Prelude hiding (concat, sequence)
18+
19+data SchemaContext schema = SchemaContext
20+ { _scURI :: !(Maybe Text)
21+ -- ^ Must not include a URI fragment, e.g. use
22+ -- "http://example.com/foo" not "http://example.com/foo#bar".
23+ --
24+ -- This is the URI identifying the document containing the schema.
25+ -- It's different than the schema's "id" field, which controls scope
26+ -- when resolving references contained in the schema.
27+
28+ -- TODO: Make the no URI fragment requirement unnecessary.
29+
30+ , _scSchema :: !schema
31+ } deriving (Eq, Show)
32+
33+-- | Keys are URIs (without URI fragments).
34+type URISchemaMap schema = HashMap Text schema
35+
36+data SchemaCache schema = SchemaCache
37+ { _startingSchema :: !schema
38+ -- ^ Used to resolve relative references.
39+ , _cachedSchemas :: !(URISchemaMap schema)
40+ } deriving (Eq, Show)
41+
42+-- | Take a schema. Retrieve every document either it or its subschemas
43+-- include via the "$ref" keyword. Load a 'SchemaCache' out with them.
44+fetchReferencedSchemas
45+ :: forall schema. FromJSON schema
46+ => (schema -> [schema])
47+ -> (schema -> Maybe Text)
48+ -> (schema -> Maybe Text)
49+ -> URISchemaMap schema
50+ -> SchemaContext schema
51+ -> IO (Either Text (SchemaCache schema))
52+fetchReferencedSchemas embedded getId getRef cache sc = do
53+ manager <- newManager defaultManagerSettings
54+ catch (Right <$> f manager) handler
55+ where
56+ f manager = fetchReferencedSchemas' embedded getId getRef
57+ (simpleGET manager) cache sc
58+
59+ handler :: SomeException -> IO (Either Text (SchemaCache schema))
60+ handler e = pure . Left . T.pack . show $ e
61+
62+-- | Based on 'Network.Http.Conduit.simpleHttp' from http-conduit.
63+simpleGET :: Manager -> Text -> IO LBS.ByteString
64+simpleGET man url = do
65+ req <- parseUrl (T.unpack url)
66+ responseBody <$> httpLbs req { requestHeaders = ("Connection", "close")
67+ : requestHeaders req
68+ } man
69+
70+-- | A version of 'fetchReferencedSchema's where the function to fetch
71+-- schemas is provided by the user. This allows restrictions to be added,
72+-- e.g. rejecting non-local URIs.
73+fetchReferencedSchemas'
74+ :: forall schema. FromJSON schema
75+ => (schema -> [schema])
76+ -> (schema -> Maybe Text)
77+ -> (schema -> Maybe Text)
78+ -> (Text -> IO LBS.ByteString)
79+ -> URISchemaMap schema
80+ -> SchemaContext schema
81+ -> IO (SchemaCache schema)
82+fetchReferencedSchemas' embedded getId getRef fetchRef cache sc = do
83+ let startingCache = case _scURI sc of
84+ Nothing -> cache
85+ Just uri -> H.insert uri (_scSchema sc) cache
86+ SchemaCache (_scSchema sc) <$> foldlM fetchRecursively
87+ startingCache
88+ (includeSubschemas embedded getId sc)
89+ where
90+ fetchRecursively
91+ :: URISchemaMap schema
92+ -> SchemaContext schema
93+ -> IO (URISchemaMap schema)
94+ fetchRecursively g (SchemaContext mUri schema) = do
95+ -- Resolving the new scope is necessary here because of situations
96+ -- like this:
97+ --
98+ -- {
99+ -- "id": "http://localhost:1234/",
100+ -- "items": {
101+ -- "id": "folder/",
102+ -- "items": {"$ref": "folderInteger.json"}
103+ -- }
104+ -- }
105+ let scope = newResolutionScope mUri (getId schema)
106+ case resolveReference scope <$> getRef schema of
107+ Just (Just uri,_) ->
108+ if not (isRemoteReference uri) || H.member uri g
109+ then pure g
110+ else do
111+ bts <- fetchRef uri
112+ case eitherDecode bts of
113+ Left e -> ioError (userError e)
114+ Right schm -> _cachedSchemas <$>
115+ fetchReferencedSchemas' embedded getId getRef fetchRef
116+ g (SchemaContext (Just uri) schm)
117+ _ -> pure g
118+
119+-- | Return the schema passed in as an argument, as well as every
120+-- subschema contained within it.
121+includeSubschemas
122+ :: forall schema.
123+ (schema -> [schema])
124+ -> (schema -> Maybe Text)
125+ -> SchemaContext schema
126+ -> [SchemaContext schema]
127+includeSubschemas embedded getId (SchemaContext mUri schema) =
128+ SchemaContext mUri schema
129+ : (includeSubschemas embedded getId =<< subSchemas)
130+ where
131+ subSchemas :: [SchemaContext schema]
132+ subSchemas = SchemaContext (newResolutionScope mUri (getId schema))
133+ <$> embedded schema
src/Data/JsonSchema/Helpers.hsdeleted−160
@@ -1,160 +0,0 @@
1−
2−module Data.JsonSchema.Helpers where
3−
4−import Control.Exception
5−import qualified Data.ByteString.Lazy as LBS
6−import qualified Data.HashMap.Strict as H
7−import Data.Scientific
8−import qualified Data.Set as S
9−import qualified Data.Text as T
10−import qualified Data.Vector as V
11−import Network.HTTP.Client
12−
13−import Data.JsonSchema.Core
14−import Import
15−
16−--------------------------------------------------
17−-- * Embedded schemas finders
18−--------------------------------------------------
19−
20−noEm :: EmbeddedSchemas
21−noEm _ _ = mempty
22−
23−objEmbed :: EmbeddedSchemas
24−objEmbed t (Object o) = pure (RawSchema t o)
25−objEmbed _ _ = mempty
26−
27−arrayEmbed :: EmbeddedSchemas
28−arrayEmbed t (Array vs) = objEmbed t =<< V.toList vs
29−arrayEmbed _ _ = mempty
30−
31−objOrArrayEmbed :: EmbeddedSchemas
32−objOrArrayEmbed t v@(Object _) = objEmbed t v
33−objOrArrayEmbed t v@(Array _) = arrayEmbed t v
34−objOrArrayEmbed _ _ = mempty
35−
36−objMembersEmbed :: EmbeddedSchemas
37−objMembersEmbed t (Object o) = objEmbed t =<< H.elems o
38−objMembersEmbed _ _ = mempty
39−
40−--------------------------------------------------
41−-- * Modify Validators for use in Specs
42−--------------------------------------------------
43−
44−giveName
45− :: forall err. err
46− -> ValidatorConstructor err [FailureInfo]
47− -> ValidatorConstructor err [ValidationFailure err]
48−giveName err f spec g rs v = (fmap.fmap) (ValidationFailure err) <$> f spec g rs v
49−
50−modifyName
51− :: forall valErr schemaErr. (valErr -> schemaErr)
52− -> ValidatorConstructor schemaErr [ValidationFailure valErr]
53− -> ValidatorConstructor schemaErr [ValidationFailure schemaErr]
54−modifyName failureHandler f spec g rs v = (fmap.fmap) modErr <$> f spec g rs v
55− where
56− modErr :: ValidationFailure valErr -> ValidationFailure schemaErr
57− modErr (ValidationFailure a b) = ValidationFailure (failureHandler a) b
58−
59−-- | It's important to know if an object's a validator (even if it will never run,
60−-- like the definitions validator) because parts of it might be referenced by other
61−-- validators. If one of those referenced parts is itself a valid reference we
62−-- need to have fetched the correct value for it. So validators that won't run are
63−-- different than non-validator objects, because even if a non-validator object has
64−-- a $ref" keyword it's not a valid reference and shouldn't be fetched.
65−neverBuild :: ValidatorConstructor err [ValidationFailure err]
66−neverBuild _ _ _ _ = Nothing
67−
68−--------------------------------------------------
69−-- * Utils
70−--------------------------------------------------
71−
72−-- | Export the fetch function used by fetchReferencedSchemas
73−defaultFetch :: Text -> IO (Either Text LBS.ByteString)
74−defaultFetch url = do
75− eResp <- catch (Right <$> simpleHttp') handler
76− case eResp of
77− Left e -> return $ Left e
78− Right b -> return $ Right b
79−
80− where
81− handler :: SomeException -> IO (Either Text LBS.ByteString)
82− handler e = return . Left . T.pack . show $ e
83−
84− -- Modeled on Network.Http.Conduit.simpleHttp from http-conduit.
85− -- simpleHttp also sets "Connection: close"
86− simpleHttp' :: IO LBS.ByteString
87− simpleHttp' = do
88− man <- newManager defaultManagerSettings
89− req <- parseUrl (T.unpack url)
90− responseBody <$> httpLbs req { requestHeaders = ("Connection", "close") : requestHeaders req } man
91−
92−modifyFailureName :: (a -> b) -> ValidationFailure a -> ValidationFailure b
93−modifyFailureName f (ValidationFailure a b) = ValidationFailure (f a) b
94−
95−eitherToMaybe :: Either a b -> Maybe b
96−eitherToMaybe (Left _) = Nothing
97−eitherToMaybe (Right a) = Just a
98−
99−runMaybeVal :: Maybe (Value -> [a]) -> Value -> [a]
100−runMaybeVal Nothing _ = mempty
101−runMaybeVal (Just val) x = val x
102−
103−runMaybeVal'
104− :: Maybe (Value -> ([a], Value))
105− -> Value
106− -> ([a], Value)
107−runMaybeVal' Nothing x = (mempty, x)
108−runMaybeVal' (Just val) x = val x
109−
110−toObj :: Value -> Maybe (HashMap Text Value)
111−toObj (Object a) = Just a
112−toObj _ = Nothing
113−
114−fromJSONInt :: Value -> Maybe Int
115−fromJSONInt (Number n) = toBoundedInteger n
116−fromJSONInt _ = Nothing
117−
118−toTxt :: Value -> Maybe Text
119−toTxt (String t) = Just t
120−toTxt _ = Nothing
121−
122−greaterThanZero :: (Num a, Ord a) => a -> Maybe ()
123−greaterThanZero n = if n <= 0 then Nothing else Just ()
124−
125−tshow :: Show a => a -> Text
126−tshow = T.pack . show
127−
128−allUnique :: (Ord a) => Vector a -> Bool
129−allUnique xs = S.size (S.fromList (V.toList xs)) == V.length xs
130−
131−-- | This needs benchmarking, but it can't be as bad as using O(n^2) nub.
132−-- (We can't use our allUnique function directly on Values because they're
133−-- not an instance of Ord).
134−allUniqueValues :: Vector Value -> Bool
135−allUniqueValues = allUnique . fmap OrdValue
136−
137−newtype OrdValue = OrdValue Value deriving Eq
138−
139−instance Ord OrdValue where
140− (OrdValue Null) `compare` (OrdValue Null) = EQ
141− (OrdValue Null) `compare` _ = LT
142− _ `compare` (OrdValue Null) = GT
143−
144− (OrdValue (Bool x)) `compare` (OrdValue (Bool y)) = x `compare` y
145− (OrdValue (Bool _)) `compare` _ = LT
146− _ `compare` (OrdValue (Bool _)) = GT
147−
148− (OrdValue (Number x)) `compare` (OrdValue (Number y)) = x `compare` y
149− (OrdValue (Number _)) `compare` _ = LT
150− _ `compare` (OrdValue (Number _)) = GT
151−
152− (OrdValue (String x)) `compare` (OrdValue (String y)) = x `compare` y
153− (OrdValue (String _)) `compare` _ = LT
154− _ `compare` (OrdValue (String _)) = GT
155−
156− (OrdValue (Array xs)) `compare` (OrdValue (Array ys)) = (OrdValue <$> xs) `compare` (OrdValue <$> ys)
157− (OrdValue (Array _)) `compare` _ = LT
158− _ `compare` (OrdValue (Array _)) = GT
159−
160− (OrdValue (Object x)) `compare` (OrdValue (Object y)) = H.toList (OrdValue <$> x) `compare` H.toList (OrdValue <$> y)
src/Data/Validator/Draft4.hsnew file+8
@@ -0,0 +1,8 @@
1+
2+module Data.Validator.Draft4 (module Export) where
3+
4+import Data.Validator.Draft4.Any as Export
5+import Data.Validator.Draft4.Array as Export
6+import Data.Validator.Draft4.Number as Export
7+import Data.Validator.Draft4.Object as Export
8+import Data.Validator.Draft4.String as Export
src/Data/Validator/Draft4/Any.hsnew file+179
@@ -0,0 +1,179 @@
1+
2+module Data.Validator.Draft4.Any where
3+
4+import Control.Monad
5+import Data.Aeson.Types (Parser)
6+import Data.List.NonEmpty (NonEmpty)
7+import qualified Data.List.NonEmpty as N
8+import Data.Maybe
9+import Data.Scientific
10+import Data.Set (Set)
11+import qualified Data.Set as S
12+
13+import Data.Validator.Failure
14+import Data.Validator.Utils
15+import Data.Validator.Reference
16+import Import
17+
18+-- For GHCs before 7.10:
19+import Prelude hiding (any)
20+
21+--------------------------------------------------
22+-- * $ref
23+--------------------------------------------------
24+
25+-- | Will return 'Nothing' if the reference can't be resolved.
26+ref
27+ :: forall err schema. (FromJSON schema, ToJSON schema, Show schema)
28+ => Maybe Text
29+ -> (Maybe Text -> Maybe schema)
30+ -> (Maybe Text -> schema -> Value -> [Failure err])
31+ -> Text
32+ -> Value
33+ -> Maybe [Failure err]
34+ref scope getRef f reference x = do
35+ let (mUri, mFragment) = resolveReference scope reference
36+ schema <- getRef mUri
37+ s <- resolveFragment mFragment schema
38+ Just (f mUri s x)
39+
40+--------------------------------------------------
41+-- * enum
42+--------------------------------------------------
43+
44+-- | From the spec:
45+-- <http://json-schema.org/latest/json-schema-validation.html#anchor76>
46+--
47+-- > The value of this keyword MUST be an array.
48+-- > This array MUST have at least one element.
49+-- > Elements in the array MUST be unique.
50+--
51+-- NOTE: We don't enforce the uniqueness constraint in the haskell code,
52+-- but we do in the 'FromJSON' instance.
53+newtype EnumVal
54+ = EnumVal { _unEnumVal :: NonEmpty Value }
55+ -- Given a choice, we'd prefer to enforce uniqueness through the type
56+ -- system over having at least one element. To use a 'Set' though we'd
57+ -- have to use 'OrdValue' here (there's no 'Ord' instance for plain Values)
58+ -- and we'd rather not make users mess with 'OrdValue'.
59+ deriving (Eq, Show)
60+
61+instance FromJSON EnumVal where
62+ parseJSON v = checkUnique . _unNonEmpty' =<< parseJSON v
63+ where
64+ checkUnique :: NonEmpty Value -> Parser EnumVal
65+ checkUnique a
66+ | allUniqueValues' a = pure (EnumVal a)
67+ | otherwise = fail "All elements of the Enum validator must be unique."
68+
69+instance ToJSON EnumVal where
70+ toJSON = toJSON . NonEmpty' . _unEnumVal
71+
72+instance Arbitrary EnumVal where
73+ arbitrary = do
74+ xs <- traverse (const arbitraryValue) =<< (arbitrary :: Gen [()])
75+ case N.nonEmpty (toUnique xs) of
76+ Nothing -> EnumVal . pure <$> arbitraryValue
77+ Just ne -> pure (EnumVal ne)
78+ where
79+ toUnique :: [Value] -> [Value]
80+ toUnique = fmap _unOrdValue . S.toList . S.fromList . fmap OrdValue
81+
82+enumVal :: EnumVal -> Value -> Maybe (Failure ())
83+enumVal (EnumVal vs) x
84+ | null vs = Nothing
85+ | not (allUniqueValues' vs) = Nothing
86+ | x `elem` vs = Nothing
87+ | otherwise =
88+ Just $ Failure () (toJSON (NonEmpty' vs)) mempty
89+
90+--------------------------------------------------
91+-- * type
92+--------------------------------------------------
93+
94+data TypeVal
95+ = TypeValString Text
96+ | TypeValArray (Set Text)
97+ deriving (Eq, Show)
98+
99+instance FromJSON TypeVal where
100+ parseJSON v = fmap TypeValString (parseJSON v)
101+ <|> fmap TypeValArray (parseJSON v)
102+
103+instance ToJSON TypeVal where
104+ toJSON (TypeValString t) = toJSON t
105+ toJSON (TypeValArray ts) = toJSON ts
106+
107+instance Arbitrary TypeVal where
108+ arbitrary = oneof [ TypeValString <$> arbitraryText
109+ , TypeValArray <$> arbitrarySetOfText
110+ ]
111+
112+typeVal :: TypeVal -> Value -> Maybe (Failure ())
113+typeVal (TypeValString t) x = isJsonType x (S.singleton t)
114+typeVal (TypeValArray ts) x = isJsonType x ts
115+
116+isJsonType :: Value -> Set Text -> Maybe (Failure ())
117+isJsonType x ts
118+ | S.null (S.intersection okTypes ts) = Just (Failure () (toJSON ts) mempty)
119+ | otherwise = Nothing
120+ where
121+ okTypes :: Set Text
122+ okTypes =
123+ case x of
124+ Null -> S.singleton "null"
125+ (Array _) -> S.singleton "array"
126+ (Bool _) -> S.singleton "boolean"
127+ (Object _) -> S.singleton "object"
128+ (String _) -> S.singleton "string"
129+ (Number y) ->
130+ case toBoundedInteger y :: Maybe Int of
131+ Nothing -> S.singleton "number"
132+ Just _ -> S.fromList ["number", "integer"]
133+
134+--------------------------------------------------
135+-- * other
136+--------------------------------------------------
137+
138+allOf
139+ :: (schema -> Value -> [Failure err])
140+ -> NonEmpty schema
141+ -> Value
142+ -> [Failure err]
143+allOf f subSchemas x = N.toList subSchemas >>= flip f x
144+
145+anyOf
146+ :: ToJSON schema
147+ => (schema -> Value -> [Failure err])
148+ -> NonEmpty schema
149+ -> Value
150+ -> Maybe (Failure ())
151+anyOf f subSchemas x
152+ | any null (flip f x <$> subSchemas) = Nothing
153+ | otherwise = Just $ Failure () (toJSON (NonEmpty' subSchemas)) mempty
154+
155+oneOf
156+ :: forall err schema. ToJSON schema
157+ => (schema -> Value -> [Failure err])
158+ -> NonEmpty schema
159+ -> Value
160+ -> Maybe (Failure ())
161+oneOf f subSchemas x
162+ | length successes == 1 = Nothing
163+ | otherwise = Just $ Failure ()
164+ (toJSON (NonEmpty' subSchemas))
165+ mempty
166+ where
167+ successes :: [[Failure err]]
168+ successes = filter null $ flip f x <$> N.toList subSchemas
169+
170+notVal
171+ :: ToJSON schema
172+ => (schema -> Value -> [Failure err])
173+ -> schema
174+ -> Value
175+ -> Maybe (Failure ())
176+notVal f schema x =
177+ case f schema x of
178+ [] -> Just (Failure () (toJSON schema) mempty)
179+ _ -> Nothing
src/Data/Validator/Draft4/Array.hsnew file+168
@@ -0,0 +1,168 @@
1+
2+module Data.Validator.Draft4.Array where
3+
4+import Control.Monad
5+import qualified Data.Aeson.Pointer as P
6+import qualified Data.Text as T
7+import qualified Data.Vector as V
8+import Text.Read (readMaybe)
9+
10+import Data.Validator.Failure
11+import Data.Validator.Utils (allUniqueValues)
12+import Import
13+
14+-- | The spec requires "maxItems" to be non-negative.
15+maxItems :: Int -> Vector Value -> Maybe (Failure ())
16+maxItems n xs
17+ | n < 0 = Nothing
18+ | V.length xs > n = Just (Failure () (toJSON n) mempty)
19+ | otherwise = Nothing
20+
21+-- | The spec requires "minItems" to be non-negative.
22+minItems :: Int -> Vector Value -> Maybe (Failure ())
23+minItems n xs
24+ | n < 0 = Nothing
25+ | V.length xs < n = Just (Failure () (toJSON n) mempty)
26+ | otherwise = Nothing
27+
28+uniqueItems :: Bool -> Vector Value -> Maybe (Failure ())
29+uniqueItems True xs
30+ | allUniqueValues xs = Nothing
31+ | otherwise = Just (Failure () (Bool True) mempty)
32+uniqueItems False _ = Nothing
33+
34+--------------------------------------------------
35+-- * items
36+--------------------------------------------------
37+
38+data ItemsFailure err
39+ = Items err
40+ | AdditionalItemsBoolFailure
41+ | AdditionalItemsObjectFailure err
42+ deriving (Eq, Show)
43+
44+data Items schema
45+ = ItemsObject schema
46+ | ItemsArray [schema]
47+ deriving (Eq, Show)
48+
49+instance FromJSON schema => FromJSON (Items schema) where
50+ parseJSON v = fmap ItemsObject (parseJSON v)
51+ <|> fmap ItemsArray (parseJSON v)
52+
53+instance ToJSON schema => ToJSON (Items schema) where
54+ toJSON (ItemsObject hm) = toJSON hm
55+ toJSON (ItemsArray schemas) = toJSON schemas
56+
57+instance Arbitrary schema => Arbitrary (Items schema) where
58+ arbitrary = oneof [ ItemsObject <$> arbitrary
59+ , ItemsArray <$> arbitrary
60+ ]
61+
62+items
63+ :: forall err schema.
64+ (schema -> Value -> [Failure err])
65+ -> Maybe (AdditionalItems schema)
66+ -> Items schema
67+ -> Vector Value
68+ -> [Failure (ItemsFailure err)]
69+items f _ (ItemsObject subSchema) xs = zip [0..] (V.toList xs) >>= g
70+ where
71+ g :: (Int, Value) -> [Failure (ItemsFailure err)]
72+ g (index,x) = modFailure Items
73+ . addToPath (P.Token (T.pack (show index)))
74+ <$> f subSchema x
75+
76+items f mAdditional (ItemsArray subSchemas) xs = itemFailures
77+ <> additionalItemFailures
78+ where
79+ indexedValues :: [(Int, Value)]
80+ indexedValues = zip [0..] (V.toList xs)
81+
82+ itemFailures :: [Failure (ItemsFailure err)]
83+ itemFailures = join (zipWith g subSchemas indexedValues)
84+ where
85+ g :: schema -> (Int, Value) -> [Failure (ItemsFailure err)]
86+ g schema (index,x) = modFailure Items
87+ . addToPath (P.Token (T.pack (show index)))
88+ <$> f schema x
89+
90+ additionalItemFailures :: [Failure (ItemsFailure err)]
91+ additionalItemFailures =
92+ case mAdditional of
93+ Nothing -> mempty
94+ Just adi -> modFailure correctName
95+ . correctIndexes
96+ <$> additionalItems f adi extras
97+ where
98+ -- It's not great that we convert back to Vector again.
99+ extras :: Vector Value
100+ extras =
101+ V.fromList . fmap snd . drop (length subSchemas) $ indexedValues
102+
103+ -- Since 'additionalItems' only sees part of the array, but starts
104+ -- indexing from zero, we need to modify the paths it reports to
105+ -- represent invalid data so they actually represent the correct
106+ -- offsets.
107+ correctIndexes
108+ :: Failure (AdditionalItemsFailure err)
109+ -> Failure (AdditionalItemsFailure err)
110+ correctIndexes (Failure a b c) = Failure a b (fixIndex c)
111+ where
112+ fixIndex :: P.Pointer -> P.Pointer
113+ fixIndex (P.Pointer (tok:toks)) =
114+ case readMaybe . T.unpack . P._unToken $ tok of
115+ Nothing -> P.Pointer $ tok:toks
116+ Just n -> P.Pointer $
117+ (P.Token . T.pack . show $ n + length subSchemas):toks
118+ fixIndex (P.Pointer []) = P.Pointer []
119+
120+ correctName :: AdditionalItemsFailure err -> ItemsFailure err
121+ correctName AdditionalBoolFailure = AdditionalItemsBoolFailure
122+ correctName (AdditionalObjectFailure err) =
123+ AdditionalItemsObjectFailure err
124+
125+--------------------------------------------------
126+-- * additionalItems
127+--------------------------------------------------
128+
129+data AdditionalItemsFailure err
130+ = AdditionalBoolFailure
131+ | AdditionalObjectFailure err
132+ deriving (Eq, Show)
133+
134+data AdditionalItems schema
135+ = AdditionalBool Bool
136+ | AdditionalObject schema
137+ deriving (Eq, Show)
138+
139+instance FromJSON schema => FromJSON (AdditionalItems schema) where
140+ parseJSON v = fmap AdditionalBool (parseJSON v)
141+ <|> fmap AdditionalObject (parseJSON v)
142+
143+instance ToJSON schema => ToJSON (AdditionalItems schema) where
144+ toJSON (AdditionalBool b) = toJSON b
145+ toJSON (AdditionalObject hm) = toJSON hm
146+
147+instance Arbitrary schema => Arbitrary (AdditionalItems schema) where
148+ arbitrary = oneof [ AdditionalBool <$> arbitrary
149+ , AdditionalObject <$> arbitrary
150+ ]
151+
152+additionalItems
153+ :: forall err schema.
154+ (schema -> Value -> [Failure err])
155+ -> AdditionalItems schema
156+ -> Vector Value
157+ -> [Failure (AdditionalItemsFailure err)]
158+additionalItems _ (AdditionalBool b) xs
159+ | b = mempty
160+ | V.length xs > 0 = pure (Failure AdditionalBoolFailure (Bool b) mempty)
161+ | otherwise = mempty
162+additionalItems f (AdditionalObject subSchema) xs =
163+ zip [0..] (V.toList xs) >>= g
164+ where
165+ g :: (Int, Value) -> [Failure (AdditionalItemsFailure err)]
166+ g (index,x) = modFailure AdditionalObjectFailure
167+ . addToPath (P.Token (T.pack (show index)))
168+ <$> f subSchema x
src/Data/Validator/Draft4/Number.hsnew file+51
@@ -0,0 +1,51 @@
1+
2+module Data.Validator.Draft4.Number where
3+
4+import Data.Fixed (mod')
5+import Data.Scientific
6+
7+import Data.Validator.Failure
8+import Import
9+
10+-- | The spec requires "multipleOf" to be positive.
11+multipleOf :: Scientific -> Scientific -> Maybe (Failure ())
12+multipleOf n x
13+ | n <= 0 = Nothing
14+ | x `mod'` n /= 0 = Just (Failure () (toJSON n) mempty)
15+ | otherwise = Nothing
16+
17+data MaximumFailure
18+ = Maximum
19+ | ExclusiveMaximum
20+ deriving (Eq, Show)
21+
22+maximumVal
23+ :: Bool
24+ -> Scientific
25+ -> Scientific
26+ -> Maybe (Failure MaximumFailure)
27+maximumVal exclusiveMaximum n x
28+ | x `greaterThan` n = Just (Failure err (toJSON n) mempty)
29+ | otherwise = Nothing
30+ where
31+ (greaterThan, err) = if exclusiveMaximum
32+ then ((>=), ExclusiveMaximum)
33+ else ((>), Maximum)
34+
35+data MinimumFailure
36+ = Minimum
37+ | ExclusiveMinimum
38+ deriving (Eq, Show)
39+
40+minimumVal
41+ :: Bool
42+ -> Scientific
43+ -> Scientific
44+ -> Maybe (Failure MinimumFailure)
45+minimumVal exclusiveMinimum n x
46+ | x `lessThan` n = Just (Failure err (toJSON n) mempty)
47+ | otherwise = Nothing
48+ where
49+ (lessThan, err) = if exclusiveMinimum
50+ then ((<=), ExclusiveMinimum)
51+ else ((<), Minimum)
src/Data/Validator/Draft4/Object.hsnew file+147
@@ -0,0 +1,147 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+
4+module Data.Validator.Draft4.Object
5+ ( module Data.Validator.Draft4.Object
6+ , module Data.Validator.Draft4.Object.Properties
7+ ) where
8+
9+import Data.Aeson.Types (Parser)
10+import qualified Data.HashMap.Strict as H
11+import Data.Set (Set)
12+import qualified Data.Set as S
13+import qualified Data.Text as T
14+
15+import Data.Validator.Draft4.Object.Properties
16+import Data.Validator.Failure
17+import Data.Validator.Utils
18+import Import
19+
20+-- For GHCs before 7.10:
21+import Prelude hiding (all, concat,
22+ foldl)
23+
24+-- | The spec requires "maxProperties" to be non-negative.
25+maxProperties :: Int -> HashMap Text Value -> Maybe (Failure ())
26+maxProperties n x
27+ | n < 0 = Nothing
28+ | H.size x > n = Just (Failure () (toJSON n) mempty)
29+ | otherwise = Nothing
30+
31+-- | The spec requires "minProperties" to be non-negative.
32+minProperties :: Int -> HashMap Text Value -> Maybe (Failure ())
33+minProperties n x
34+ | n < 0 = Nothing
35+ | H.size x < n = Just (Failure () (toJSON n) mempty)
36+ | otherwise = Nothing
37+
38+--------------------------------------------------
39+-- * required
40+--------------------------------------------------
41+
42+-- | From the spec:
43+--
44+-- > The value of this keyword MUST be an array.
45+-- > This array MUST have at least one element.
46+-- > Elements of this array MUST be strings, and MUST be unique.
47+--
48+-- We don't enfore that 'Required' has at least one element in the
49+-- haskell code, but we do in the 'FromJSON' instance.
50+newtype Required
51+ = Required { _unRequired :: Set Text }
52+ deriving (Eq, Show, ToJSON)
53+
54+instance FromJSON Required where
55+ parseJSON v = checkUnique =<< checkSize =<< parseJSON v
56+ where
57+ checkSize :: [Text] -> Parser [Text]
58+ checkSize a
59+ | null a = fail "Required validator must not be empty."
60+ | otherwise = pure a
61+
62+ checkUnique :: [Text] -> Parser Required
63+ checkUnique a =
64+ let b = S.fromList a
65+ -- NOTE: Can use length instead of S.size in GHC 7.10 or later.
66+ in if length a == S.size b
67+ then pure (Required b)
68+ else fail "All elements of the Required validator must be unique."
69+
70+instance Arbitrary Required where
71+ arbitrary = do
72+ x <- arbitraryText -- Guarantee at least one element.
73+ xs <- (fmap.fmap) T.pack arbitrary
74+ pure . Required . S.fromList $ x:xs
75+
76+required :: Required -> HashMap Text Value -> Maybe (Failure ())
77+required (Required ts) x
78+ -- NOTE: When we no longer need to support GHCs before 7.10
79+ -- we can use null from Prelude throughout the library
80+ -- instead of specialized versions.
81+ | S.null ts = Nothing
82+ | H.null (H.difference hm x) = Nothing
83+ | otherwise = Just (Failure () (toJSON ts) mempty)
84+ where
85+ hm :: HashMap Text Bool
86+ hm = foldl (\b a -> H.insert a True b) mempty ts
87+
88+--------------------------------------------------
89+-- * dependencies
90+--------------------------------------------------
91+
92+data DependencyFailure err
93+ = SchemaDependencyFailure err
94+ | PropertyDependencyFailure
95+ deriving (Eq, Show)
96+
97+data Dependency schema
98+ = SchemaDependency schema
99+ | PropertyDependency (Set Text)
100+ deriving (Eq, Show)
101+
102+instance FromJSON schema => FromJSON (Dependency schema) where
103+ parseJSON v = fmap SchemaDependency (parseJSON v)
104+ <|> fmap PropertyDependency (parseJSON v)
105+
106+instance ToJSON schema => ToJSON (Dependency schema) where
107+ toJSON (SchemaDependency schema) = toJSON schema
108+ toJSON (PropertyDependency ts) = toJSON ts
109+
110+instance Arbitrary schema => Arbitrary (Dependency schema) where
111+ arbitrary = oneof [ SchemaDependency <$> arbitrary
112+ , PropertyDependency <$> arbitrarySetOfText
113+ ]
114+
115+-- | From the spec:
116+-- <http://json-schema.org/latest/json-schema-validation.html#anchor70>
117+--
118+-- > This keyword's value MUST be an object.
119+-- > Each value of this object MUST be either an object or an array.
120+-- >
121+-- > If the value is an object, it MUST be a valid JSON Schema.
122+-- > This is called a schema dependency.
123+-- >
124+-- > If the value is an array, it MUST have at least one element.
125+-- > Each element MUST be a string, and elements in the array MUST be unique.
126+-- > This is called a property dependency.
127+dependencies
128+ :: forall err schema. (schema -> Value -> [Failure err])
129+ -> HashMap Text (Dependency schema)
130+ -> HashMap Text Value
131+ -> [Failure (DependencyFailure err)]
132+dependencies f hm x = concat . fmap (uncurry g) . H.toList $ hm
133+ where
134+ g :: Text -> Dependency schema -> [Failure (DependencyFailure err)]
135+ g k (SchemaDependency schema)
136+ | H.member k x =
137+ modFailure SchemaDependencyFailure <$> f schema (Object x)
138+ | otherwise = mempty
139+ g k (PropertyDependency ts)
140+ | H.member k x && not allPresent =
141+ pure $ Failure PropertyDependencyFailure
142+ (toJSON (H.singleton k ts))
143+ mempty
144+ | otherwise = mempty
145+ where
146+ allPresent :: Bool
147+ allPresent = all (`H.member` x) ts
src/Data/Validator/Draft4/Object/Properties.hsnew file+187
@@ -0,0 +1,187 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+
3+module Data.Validator.Draft4.Object.Properties where
4+
5+import Control.Monad
6+import Data.Aeson
7+import qualified Data.Aeson.Pointer as P
8+import qualified Data.HashMap.Strict as H
9+import qualified Data.Text as T
10+import Text.RegexPR
11+
12+import Data.Validator.Failure
13+import Import
14+
15+newtype Remaining = Remaining { _unRemaining :: HashMap Text Value }
16+
17+--------------------------------------------------
18+-- * properties
19+--------------------------------------------------
20+
21+data PropertiesFailure err
22+ = PropertiesFailure err
23+ | PropPatternFailure err
24+ | PropAdditionalFailure (AdditionalPropertiesFailure err)
25+ deriving (Eq, Show)
26+
27+-- | In order of what's tried: "properties", "patternProperties",
28+-- "additionalProperties".
29+properties
30+ :: forall err schema.
31+ (schema -> Value -> [Failure err])
32+ -> Maybe (HashMap Text schema)
33+ -> Maybe (AdditionalProperties schema)
34+ -> HashMap Text schema
35+ -> HashMap Text Value
36+ -> [Failure (PropertiesFailure err)]
37+properties f mPat mAdd propertiesHm x =
38+ fmap (modFailure PropertiesFailure) propFailures
39+ <> fmap (modFailure PropPatternFailure) patternFailures
40+ <> fmap (modFailure PropAdditionalFailure) additionalFailures
41+ where
42+ propertiesAndUnmatched :: ([Failure err], Remaining)
43+ propertiesAndUnmatched = ( failures
44+ , Remaining (H.difference x propertiesHm)
45+ )
46+ where
47+ failures :: [Failure err]
48+ failures = H.toList (H.intersectionWith f propertiesHm x)
49+ >>= (\(k,vs) -> fmap (addToPath (P.Token k)) vs)
50+
51+ (propFailures, remaining1) = propertiesAndUnmatched
52+
53+ mPatProp :: Maybe (HashMap Text Value -> ([Failure err], Remaining))
54+ mPatProp = patternAndUnmatched f <$> mPat
55+
56+ patternFailures :: [Failure err]
57+ patternFailures = case mPatProp of
58+ Nothing -> mempty
59+ Just val -> fst (val x)
60+
61+ remaining2 :: Remaining
62+ remaining2 = case mPatProp of
63+ Nothing -> remaining1
64+ Just val -> snd . val . _unRemaining $ remaining1
65+
66+ additionalFailures :: [Failure (AdditionalPropertiesFailure err)]
67+ additionalFailures = case additionalProperties f <$> mAdd of
68+ Nothing -> mempty
69+ Just val -> val (_unRemaining remaining2)
70+
71+--------------------------------------------------
72+-- * patternProperties
73+--------------------------------------------------
74+
75+data PatternPropertiesFailure err
76+ = PPFailure err
77+ | PPAdditionalPropertiesFailure (AdditionalPropertiesFailure err)
78+ deriving (Eq, Show)
79+
80+patternProperties
81+ :: forall err schema.
82+ (schema -> Value -> [Failure err])
83+ -> Maybe (AdditionalProperties schema)
84+ -> HashMap Text schema
85+ -> HashMap Text Value
86+ -> [Failure (PatternPropertiesFailure err)]
87+patternProperties f mAdd patternPropertiesHm x =
88+ fmap (modFailure PPFailure) ppFailures
89+ <> fmap (modFailure PPAdditionalPropertiesFailure) addFailures
90+ where
91+ patternProps :: ([Failure err], Remaining)
92+ patternProps = patternAndUnmatched f patternPropertiesHm x
93+
94+ (ppFailures, remaining) = patternProps
95+
96+ addFailures :: [Failure (AdditionalPropertiesFailure err)]
97+ addFailures = case additionalProperties f <$> mAdd of
98+ Nothing -> mempty
99+ Just val -> val (_unRemaining remaining)
100+
101+patternAndUnmatched
102+ :: forall err schema.
103+ (schema -> Value -> [Failure err])
104+ -> HashMap Text schema
105+ -> HashMap Text Value
106+ -> ([Failure err], Remaining)
107+patternAndUnmatched f patPropertiesHm x =
108+ (H.foldlWithKey' runVals mempty perhapsMatches, remaining)
109+ where
110+ perhapsMatches :: HashMap Text (Value, [schema])
111+ perhapsMatches = H.foldlWithKey' (matchingSchemas patPropertiesHm) mempty x
112+ where
113+ matchingSchemas
114+ :: HashMap Text schema
115+ -> HashMap Text (Value, [schema])
116+ -> Text
117+ -> Value
118+ -> HashMap Text (Value, [schema])
119+ matchingSchemas subSchemas acc k v =
120+ H.insert k (v, H.foldlWithKey' (checkKey k) mempty subSchemas) acc
121+
122+ checkKey
123+ :: Text
124+ -> [schema]
125+ -> Text
126+ -> schema
127+ -> [schema]
128+ checkKey k acc r subSchema =
129+ case matchRegexPR (T.unpack r) (T.unpack k) of
130+ Nothing -> acc
131+ Just _ -> pure subSchema <> acc
132+
133+ runVals
134+ :: [Failure err]
135+ -> Text
136+ -> (Value, [schema])
137+ -> [Failure err]
138+ runVals acc k (v,subSchemas) =
139+ (subSchemas >>= (\schema -> addToPath (P.Token k) <$> f schema v))
140+ <> acc
141+
142+ remaining :: Remaining
143+ remaining = Remaining . fmap fst . H.filter (null . snd) $ perhapsMatches
144+
145+--------------------------------------------------
146+-- * additionalProperties
147+--------------------------------------------------
148+
149+data AdditionalPropertiesFailure err
150+ = APBoolFailure
151+ | APObjectFailure err
152+ deriving (Eq, Show)
153+
154+data AdditionalProperties schema
155+ = AdditionalPropertiesBool Bool
156+ | AdditionalPropertiesObject schema
157+ deriving (Eq, Show)
158+
159+instance FromJSON schema => FromJSON (AdditionalProperties schema) where
160+ parseJSON v = fmap AdditionalPropertiesBool (parseJSON v)
161+ <|> fmap AdditionalPropertiesObject (parseJSON v)
162+
163+instance ToJSON schema => ToJSON (AdditionalProperties schema) where
164+ toJSON (AdditionalPropertiesBool b) = toJSON b
165+ toJSON (AdditionalPropertiesObject hm) = toJSON hm
166+
167+instance Arbitrary schema => Arbitrary (AdditionalProperties schema) where
168+ arbitrary = oneof [ AdditionalPropertiesBool <$> arbitrary
169+ , AdditionalPropertiesObject <$> arbitrary
170+ ]
171+
172+additionalProperties
173+ :: forall err schema.
174+ (schema -> Value -> [Failure err])
175+ -> AdditionalProperties schema
176+ -> HashMap Text Value
177+ -> [Failure (AdditionalPropertiesFailure err)]
178+additionalProperties _ (AdditionalPropertiesBool False) x
179+ | H.size x > 0 = pure $ Failure APBoolFailure (Bool False) mempty
180+ | otherwise = mempty
181+additionalProperties _ (AdditionalPropertiesBool True) _ = mempty
182+additionalProperties f (AdditionalPropertiesObject schema) x = H.toList x >>= g
183+ where
184+ g :: (Text, Value) -> [Failure (AdditionalPropertiesFailure err)]
185+ g (k,v) = modFailure APObjectFailure
186+ . addToPath (P.Token k)
187+ <$> f schema v
src/Data/Validator/Draft4/String.hsnew file+29
@@ -0,0 +1,29 @@
1+
2+module Data.Validator.Draft4.String where
3+
4+import Data.Aeson
5+import qualified Data.Text as T
6+import Text.RegexPR
7+
8+import Data.Validator.Failure
9+import Import
10+
11+-- | The spec requires "maxLength" to be non-negative.
12+maxLength :: Int -> Text -> Maybe (Failure ())
13+maxLength n x
14+ | n <= 0 = Nothing
15+ | T.length x > n = Just (Failure () (toJSON n) mempty)
16+ | otherwise = Nothing
17+
18+-- | The spec requires "minLength" to be non-negative.
19+minLength :: Int -> Text -> Maybe (Failure ())
20+minLength n x
21+ | n <= 0 = Nothing
22+ | T.length x < n = Just (Failure () (toJSON n) mempty)
23+ | otherwise = Nothing
24+
25+patternVal :: Text -> Text -> Maybe (Failure ())
26+patternVal t x =
27+ case matchRegexPR (T.unpack t) (T.unpack x) of
28+ Nothing -> Just (Failure () (toJSON t) mempty)
29+ Just _ -> Nothing
src/Data/Validator/Failure.hsnew file+42
@@ -0,0 +1,42 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+
3+module Data.Validator.Failure where
4+
5+import qualified Data.Aeson.Pointer as P
6+
7+import Import
8+
9+-- For GHCs before 7.10:
10+import Prelude hiding (concat, sequence)
11+
12+-- | Validators shouldn't know more about the schema they're going to
13+-- be used with than necessary. If a validator throws errors using the
14+-- error sum type of a particular schema, then it can't be used with
15+-- other schemas later that have different error sum types (at least not
16+-- without writing partial functions).
17+--
18+-- Thus validators that can only fail in one way return 'FailureInfo's.
19+-- Validators that can fail in multiple ways return 'ValidationFailure's
20+-- along with an custom error sum type for that particular validator.
21+--
22+-- It's the job of a schema's validate function to unify the errors produced
23+-- by the validators it uses into a single error sum type for that schema.
24+-- The schema's validate function will return a 'ValidationFailure' with
25+-- that sum type as its type argument.
26+data Failure err = Failure
27+ { _failureValidatorsCalled :: !err
28+ , _failureFinalValidator :: !Value
29+ , _failureOffendingData :: !P.Pointer
30+ } deriving (Eq, Show)
31+
32+setFailure :: b -> Failure a -> Failure b
33+setFailure e (Failure _ a b) = Failure e a b
34+
35+modFailure :: (a -> b) -> Failure a -> Failure b
36+modFailure f v@(Failure a _ _) = v { _failureValidatorsCalled = f a }
37+
38+addToPath :: P.Token -> Failure a -> Failure a
39+addToPath tok v@(Failure _ _ a) = v { _failureOffendingData = addToken a }
40+ where
41+ addToken :: P.Pointer -> P.Pointer
42+ addToken (P.Pointer ts) = P.Pointer (ts <> pure tok)
src/Data/JsonSchema/Reference.hs → src/Data/Validator/Reference.hsrenamed+19−17
@@ -1,8 +1,7 @@
11
2−module Data.JsonSchema.Reference where
2+module Data.Validator.Reference where
33
4−import qualified Data.HashMap.Strict as H
5−import Data.JsonPointer
4+import qualified Data.Aeson.Pointer as P
65import qualified Data.Text as T
76import Data.Text.Encoding
87import Network.HTTP.Types.URI
@@ -12,11 +11,11 @@ import Import
1211type URIBase = Maybe Text
1312type URIBaseAndFragment = (Maybe Text, Maybe Text)
1413
15−newResolutionScope :: URIBase -> HashMap Text Value -> URIBase
16−newResolutionScope mScope o =
17− case H.lookup "id" o of
18− Just (String t) -> fst . baseAndFragment $ resolveScopeAgainst mScope t
19− _ -> mScope
14+newResolutionScope :: URIBase -> Maybe Text -> URIBase
15+newResolutionScope mScope idKeyword =
16+ case idKeyword of
17+ Just t -> fst . baseAndFragment $ resolveScopeAgainst mScope t
18+ _ -> mScope
2019
2120resolveReference :: URIBase -> Text -> URIBaseAndFragment
2221resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t
@@ -24,16 +23,19 @@ resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t
2423isRemoteReference :: Text -> Bool
2524isRemoteReference uri = "://" `T.isInfixOf` uri
2625
27−resolveFragment :: Maybe Text -> HashMap Text Value -> HashMap Text Value
28−resolveFragment Nothing hm = hm
29−resolveFragment (Just pointer) hm =
26+resolveFragment
27+ :: (FromJSON schema, ToJSON schema, Show schema)
28+ => Maybe Text
29+ -> schema
30+ -> Maybe schema
31+resolveFragment Nothing schema = Just schema
32+resolveFragment (Just pointer) schema = do
3033 let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer
31− in case jsonPointer urlDecoded of
32− Left _ -> hm
33− Right p ->
34− case resolvePointer p (Object hm) of
35− Right (Object hm') -> hm'
36− _ -> hm
34+ p <- either (const Nothing) Just (P.unescape urlDecoded)
35+ x <- either (const Nothing) Just (P.resolve p (toJSON schema))
36+ case fromJSON x of
37+ Error _ -> Nothing
38+ Success schema' -> Just schema'
3739
3840--------------------------------------------------
3941-- * Internal
src/Data/Validator/Utils.hsnew file+122
@@ -0,0 +1,122 @@
1+
2+module Data.Validator.Utils where
3+
4+import Control.Arrow
5+import qualified Data.HashMap.Strict as H
6+import Data.List.NonEmpty (NonEmpty)
7+import qualified Data.List.NonEmpty as N
8+import Data.Scientific (Scientific, fromFloatDigits)
9+import Data.Set (Set)
10+import qualified Data.Set as S
11+import qualified Data.Text as T
12+import qualified Data.Vector as V
13+
14+import Import
15+
16+--------------------------------------------------
17+-- * QuickCheck
18+--------------------------------------------------
19+
20+arbitraryText :: Gen Text
21+arbitraryText = T.pack <$> arbitrary
22+
23+arbitraryScientific :: Gen Scientific
24+arbitraryScientific = (fromFloatDigits :: Double -> Scientific) <$> arbitrary
25+
26+arbitraryPositiveScientific :: Gen Scientific
27+arbitraryPositiveScientific = (fromFloatDigits :: Double -> Scientific)
28+ . getPositive
29+ <$> arbitrary
30+
31+arbitraryValue :: Gen Value
32+arbitraryValue = sized f
33+ where
34+ f :: Int -> Gen Value
35+ f n | n <= 1 = oneof nonRecursive
36+ | otherwise = oneof $
37+ fmap (Array . V.fromList) (traverse (const (f (n `div` 10)))
38+ =<< (arbitrary :: Gen [()]))
39+ : fmap (Object . H.fromList) (traverse (const (g (n `div` 10)))
40+ =<< (arbitrary :: Gen [()]))
41+ : nonRecursive
42+
43+ g :: Int -> Gen (Text, Value)
44+ g n = (,) <$> arbitraryText <*> f n
45+
46+ nonRecursive :: [Gen Value]
47+ nonRecursive =
48+ [ pure Null
49+ , Bool <$> arbitrary
50+ , String <$> arbitraryText
51+ , Number <$> arbitraryScientific
52+ ]
53+
54+arbitraryHashMap :: Arbitrary a => Gen (HashMap Text a)
55+arbitraryHashMap = H.fromList . fmap (first T.pack) <$> arbitrary
56+
57+arbitrarySetOfText :: Gen (Set Text)
58+arbitrarySetOfText = S.fromList . fmap T.pack <$> arbitrary
59+
60+newtype NonEmpty' a = NonEmpty' { _unNonEmpty' :: NonEmpty a }
61+
62+instance FromJSON a => FromJSON (NonEmpty' a) where
63+ parseJSON v = do
64+ xs <- parseJSON v
65+ case N.nonEmpty xs of
66+ Nothing -> fail "Must have at least one item."
67+ Just ne -> pure (NonEmpty' ne)
68+
69+instance ToJSON a => ToJSON (NonEmpty' a) where
70+ toJSON = toJSON . N.toList . _unNonEmpty'
71+
72+instance Arbitrary a => Arbitrary (NonEmpty' a) where
73+ arbitrary = do
74+ xs <- arbitrary
75+ case N.nonEmpty xs of
76+ Nothing -> NonEmpty' . pure <$> arbitrary
77+ Just ne -> pure (NonEmpty' ne)
78+
79+--------------------------------------------------
80+-- * allUniqueValues
81+--------------------------------------------------
82+
83+allUniqueValues :: Vector Value -> Bool
84+allUniqueValues = allUnique . fmap OrdValue . V.toList
85+
86+-- NOTE: When we no longer support GHC 7.8 we can generalize
87+-- allUnique to work on any Foldable and remove this function.
88+allUniqueValues' :: NonEmpty Value -> Bool
89+allUniqueValues' = allUnique . fmap OrdValue . N.toList
90+
91+allUnique :: (Ord a) => [a] -> Bool
92+allUnique xs = S.size (S.fromList xs) == length xs
93+
94+-- | OrdValue's Ord instance needs benchmarking, but it allows us to
95+-- use our 'allUnique' function instead of O(n^2) nub, so it's probably
96+-- worth it.
97+newtype OrdValue = OrdValue { _unOrdValue :: Value } deriving Eq
98+
99+instance Ord OrdValue where
100+ (OrdValue Null) `compare` (OrdValue Null) = EQ
101+ (OrdValue Null) `compare` _ = LT
102+ _ `compare` (OrdValue Null) = GT
103+
104+ (OrdValue (Bool x)) `compare` (OrdValue (Bool y)) = x `compare` y
105+ (OrdValue (Bool _)) `compare` _ = LT
106+ _ `compare` (OrdValue (Bool _)) = GT
107+
108+ (OrdValue (Number x)) `compare` (OrdValue (Number y)) = x `compare` y
109+ (OrdValue (Number _)) `compare` _ = LT
110+ _ `compare` (OrdValue (Number _)) = GT
111+
112+ (OrdValue (String x)) `compare` (OrdValue (String y)) = x `compare` y
113+ (OrdValue (String _)) `compare` _ = LT
114+ _ `compare` (OrdValue (String _)) = GT
115+
116+ (OrdValue (Array xs)) `compare` (OrdValue (Array ys)) =
117+ (OrdValue <$> xs) `compare` (OrdValue <$> ys)
118+ (OrdValue (Array _)) `compare` _ = LT
119+ _ `compare` (OrdValue (Array _)) = GT
120+
121+ (OrdValue (Object x)) `compare` (OrdValue (Object y)) =
122+ H.toList (OrdValue <$> x) `compare` H.toList (OrdValue <$> y)
src/Import.hs+1
@@ -9,3 +9,4 @@ import Data.Monoid as Export
99import Data.Text as Export (Text)
1010import Data.Traversable as Export
1111import Data.Vector as Export (Vector)
12+import Test.QuickCheck as Export hiding (Failure, Result, Success)
tests/Local.hs+67−9
@@ -1,18 +1,76 @@
1+
12module Main where
23
34import Control.Applicative
4−import Data.List (isSuffixOf)
5−import Lib
6−import System.Directory (getDirectoryContents)
7−import Test.Framework
5+import Control.Monad (unless)
6+import Data.Aeson
7+import qualified Data.Aeson.Pointer as P
8+import Data.List (isSuffixOf)
9+import Data.Monoid
10+import System.Directory (getDirectoryContents)
11+import Test.Tasty (TestTree, defaultMain, testGroup)
12+import qualified Test.Tasty.HUnit as HU
13+import Test.Tasty.QuickCheck (testProperty)
14+
15+import Data.JsonSchema.Draft4 (Failure(..), Schema(..),
16+ SchemaCache(..), SchemaContext(..),
17+ emptySchema, runValidate)
18+import qualified Data.Validator.Draft4 as VA
19+import Shared (isLocal, readSchemaTests, toTest)
20+
21+dir :: String
22+dir = "JSON-Schema-Test-Suite/tests/draft4"
823
924main :: IO ()
1025main = do
11− filenames <- filter isLocal . filter (".json" `isSuffixOf`)
12− <$> getDirectoryContents dir
26+ filenames <- filter isLocal . filter (".json" `isSuffixOf`) <$> getDirectoryContents dir
1327 ts <- readSchemaTests dir filenames
14− defaultMain (toTest <$> ts)
28+ defaultMain . testGroup "Tests not requiring an HTTP server" $
29+ testProperty "Invert schemas through JSON without change" invertSchema
30+ : testGroup "Make paths to invalid data correctly" correctPaths
31+ : fmap toTest ts
1532
33+invertSchema :: Schema -> Bool
34+invertSchema a = Just a == decode (encode a)
35+
36+correctPaths :: [TestTree]
37+correctPaths =
38+ [ HU.testCase "Items object" itemsObject
39+ , HU.testCase "Items array" itemsArray
40+ ]
41+
42+itemsObject :: IO ()
43+itemsObject = HU.assertEqual "Path to invalid data"
44+ (P.Pointer [P.Token "0"])
45+ (_failureOffendingData failure)
1646 where
17− dir :: String
18− dir = "JSON-Schema-Test-Suite/tests/draft4"
47+ [failure] = runValidate (SchemaCache schema mempty) sc (toJSON [[True, True]])
48+
49+ schema :: Schema
50+ schema = emptySchema
51+ { _schemaItems = Just (VA.ItemsObject (emptySchema { _schemaUniqueItems = Just True }))
52+ }
53+
54+ sc :: SchemaContext Schema
55+ sc = SchemaContext
56+ { _scURI = Nothing
57+ , _scSchema = schema
58+ }
59+
60+itemsArray :: IO ()
61+itemsArray = HU.assertEqual "Path to invalid data"
62+ (P.Pointer [P.Token "0"])
63+ (_failureOffendingData failure)
64+ where
65+ [failure] = runValidate (SchemaCache schema mempty) sc (toJSON [[True, True]])
66+
67+ schema :: Schema
68+ schema = emptySchema
69+ { _schemaItems = Just (VA.ItemsArray [emptySchema { _schemaUniqueItems = Just True }])
70+ }
71+
72+ sc :: SchemaContext Schema
73+ sc = SchemaContext
74+ { _scURI = Nothing
75+ , _scSchema = schema
76+ }
tests/Remote.hs+13−10
@@ -3,21 +3,24 @@ module Main where
33import Control.Applicative
44import Control.Concurrent.Async (withAsync)
55import Data.List (isSuffixOf)
6−import Lib
76import Network.Wai.Application.Static (defaultFileServerSettings,
87 staticApp)
98import Network.Wai.Handler.Warp (run)
109import System.Directory (getDirectoryContents)
11−import Test.Framework
10+import Test.Tasty (defaultMain, testGroup)
11+
12+import Shared (isLocal, readSchemaTests,
13+ toTest)
14+
15+dir :: String
16+dir = "JSON-Schema-Test-Suite/tests/draft4"
1217
1318main :: IO ()
14−main =
15− withAsync (run 1234 $ staticApp $ defaultFileServerSettings "JSON-Schema-Test-Suite/remotes") $ \_ -> do
16− filenames <- filter (not . isLocal) . filter (".json" `isSuffixOf`)
19+main = withAsync serve $ \_ -> do
20+ filenames <- filter (not . isLocal) . filter (".json" `isSuffixOf`)
1721 <$> getDirectoryContents dir
18− ts <- readSchemaTests dir filenames
19− defaultMain (toTest <$> ts)
22+ ts <- readSchemaTests dir filenames
23+ defaultMain . testGroup "Tests that run an HTTP server" $ toTest <$> ts
2024
21− where
22− dir :: String
23− dir = "JSON-Schema-Test-Suite/tests/draft4"
25+serve :: IO ()
26+serve = run 1234 . staticApp . defaultFileServerSettings $ "JSON-Schema-Test-Suite/remotes"
tests/Lib.hs → tests/Shared.hsrenamed+32−46
@@ -1,22 +1,22 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−{-# OPTIONS_GHC -fno-warn-orphans #-}
1+{-# LANGUAGE DeriveGeneric #-}
32
4−module Lib where
3+module Shared where
54
65import Control.Applicative
76import Control.Monad
87import Data.Aeson
98import Data.Aeson.TH
10−import qualified Data.ByteString.Lazy as LBS
11−import Data.Char (toLower)
12−import Data.JsonSchema
9+import qualified Data.ByteString.Lazy as LBS
10+import Data.Char (toLower)
1311import Data.Monoid
14−import Data.Text (Text)
15−import qualified Data.Text as T
16−import System.FilePath ((</>))
17−import Test.Framework (Test)
18−import Test.Framework.Providers.HUnit (testCase)
19−import Test.HUnit hiding (Test)
12+import Data.Text (Text)
13+import qualified Data.Text as T
14+import GHC.Generics
15+import System.FilePath ((</>))
16+import Test.Tasty (TestTree)
17+import qualified Test.Tasty.HUnit as HU
18+
19+import qualified Data.JsonSchema.Draft4 as D4
2020
2121isLocal :: String -> Bool
2222isLocal file = (file /= "definitions.json")
@@ -25,7 +25,7 @@ isLocal file = (file /= "definitions.json")
2525
2626data SchemaTest = SchemaTest
2727 { _stDescription :: Text
28− , _stSchema :: RawSchema
28+ , _stSchema :: D4.Schema
2929 , _stCases :: [SchemaTestCase]
3030 }
3131
@@ -33,16 +33,16 @@ data SchemaTestCase = SchemaTestCase
3333 { _scDescription :: Text
3434 , _scData :: Value
3535 , _scValid :: Bool
36− }
37−
38−instance FromJSON RawSchema where
39− parseJSON = withObject "Schema" $ return . RawSchema Nothing
36+ } deriving Generic
4037
4138instance FromJSON SchemaTest where
4239 parseJSON = withObject "SchemaTest" $ \o -> SchemaTest
4340 <$> o .: "description"
4441 <*> o .: "schema"
45− <*> o .: "tests" -- I wish this were "cases"
42+ <*> o .: "tests" -- Perhaps "cases" would have been a more descriptive key.
43+
44+instance FromJSON SchemaTestCase where
45+ parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = fmap toLower . drop 3 }
4646
4747readSchemaTests :: String -> [String] -> IO [SchemaTest]
4848readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles
@@ -54,7 +54,7 @@ readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles
5454 jsonBS <- LBS.readFile fullPath
5555 case eitherDecode jsonBS of
5656 Left e -> fail $ "couldn't parse file '" <> fullPath <> "': " <> e
57− Right schemaTests -> return $ prependFileName name <$> schemaTests
57+ Right schemaTests -> pure $ prependFileName name <$> schemaTests
5858
5959 prependFileName :: String -> SchemaTest -> SchemaTest
6060 prependFileName fileName s = s
@@ -64,50 +64,36 @@ readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles
6464 concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
6565 concatMapM f xs = liftM concat (mapM f xs)
6666
67−toTest :: SchemaTest -> Test
67+toTest :: SchemaTest -> TestTree
6868toTest st =
69− testCase (T.unpack $ _stDescription st) $ do
70− sanityCheckTest (_stSchema st)
69+ HU.testCase (T.unpack (_stDescription st)) $ do
7170 forM_ (_stCases st) $ \sc -> do
72− g <- assertRight =<< fetchReferencedSchemas draft4 mempty (_stSchema st)
73− let res = validate (compile draft4 g $ _stSchema st) (_scData sc)
71+ g <- assertRight =<< D4.fetchReferencedSchemas mempty (D4.SchemaContext Nothing (_stSchema st))
72+ validate <- assertRight . D4.checkSchema g $ D4.SchemaContext Nothing (_stSchema st)
73+ let res = validate (_scData sc)
7474 if _scValid sc
7575 then assertValid sc res
7676 else assertInvalid sc res
77− where
78− sanityCheckTest :: RawSchema -> IO ()
79− sanityCheckTest rs =
80− case isValidSchema rs of
81− [] -> return ()
82− errs -> error $ unlines
83− [ "One of the test cases has a problem! "
84− , "Description: " <> T.unpack (_stDescription st)
85− , "Validation failures: " <> show errs
86− ]
8777
88−assertValid :: SchemaTestCase -> [ValidationFailure Draft4Failure] -> Assertion
89−assertValid _ [] = return ()
78+assertValid :: SchemaTestCase -> [D4.Failure] -> HU.Assertion
79+assertValid _ [] = pure ()
9080assertValid sc errs =
91− assertFailure $ unlines
81+ HU.assertFailure $ unlines
9282 [ " Failed to validate data"
9383 , " Description: " <> T.unpack (_scDescription sc)
9484 , " Data: " <> show (_scData sc)
9585 , " Validation failures: " <> show errs
9686 ]
9787
98−assertInvalid :: SchemaTestCase -> [ValidationFailure Draft4Failure] -> Assertion
88+assertInvalid :: SchemaTestCase -> [D4.Failure] -> HU.Assertion
9989assertInvalid sc [] =
100− assertFailure $ unlines
90+ HU.assertFailure $ unlines
10191 [ " Validated invalid data"
10292 , " Description: " <> T.unpack (_scDescription sc)
10393 , " Data: " <> show (_scData sc)
10494 ]
105−assertInvalid _ _ = return ()
95+assertInvalid _ _ = pure ()
10696
10797assertRight :: (Show a) => Either a b -> IO b
108−assertRight a =
109− case a of
110− Left e -> assertFailure (show e) >> fail "assertRight failed"
111− Right b -> return b
112−
113−$(deriveFromJSON defaultOptions { fieldLabelModifier = map toLower . drop 3 } ''SchemaTestCase)
98+assertRight (Left e) = HU.assertFailure (show e) >> fail "assertRight failed"
99+assertRight (Right b) = pure b