git.iko.soy/typeable/hjsonschema
on master help sign in
0.9.0.0. Partial rewrite.
2b9f123Ian Grant Jeffries
.gitignorenew file+1
compare with master
unifiedsplit
@@ -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
4
4
5[Hackage](https://hackage.haskell.org/package/hjsonschema) / [GitHub](https://github.com/seagreen/hjsonschema) / [Travis CI](https://travis-ci.org/seagreen/hjsonschema)
5[Hackage](https://hackage.haskell.org/package/hjsonschema) / [GitHub](https://github.com/seagreen/hjsonschema) / [Travis CI](https://travis-ci.org/seagreen/hjsonschema)
6
6
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.
8
8
9# Example
9# Example
10
10
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).
12
12
13# Tests
13# Tests
14
14
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+
1# 0.8
8# 0.8
2
9
3+ Improve scope updating and resolving.
10+ 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 @@
1name: hjsonschema
1name: hjsonschema
2−version: 0.8.0.1
2+version: 0.9.0.0
3synopsis: JSON Schema library
3synopsis: JSON Schema library
4homepage: https://github.com/seagreen/hjsonschema
4homepage: https://github.com/seagreen/hjsonschema
5license: MIT
5license: MIT
@@ -14,73 +14,80 @@ extra-source-files: changelog.txt
14 draft4.json
14 draft4.json
15 JSON-Schema-Test-Suite/tests/draft4/*.json
15 JSON-Schema-Test-Suite/tests/draft4/*.json
16 README.md
16 README.md
17− tests/Lib.hs
17+ tests/Shared.hs
18
18
19library
19library
20 hs-source-dirs: src
20 hs-source-dirs: src
21− exposed-modules: Data.JsonSchema
21+ exposed-modules: Data.JsonSchema.Draft4
22− , Data.JsonSchema.Draft4.Any
23− , Data.JsonSchema.Draft4.Arrays
22+ , Data.JsonSchema.Draft4.Internal
24− , Data.JsonSchema.Draft4.Numbers
23+ , Data.JsonSchema.Fetch
25− , Data.JsonSchema.Draft4.Objects
26− , Data.JsonSchema.Draft4.Strings
24+ , Data.Validator.Draft4
27− , Data.JsonSchema.Helpers
25+ , Data.Validator.Failure
28− , Data.JsonSchema.Reference
26+ , Data.Validator.Reference
27+ , Data.Validator.Utils
28+
29− other-modules: Data.JsonSchema.Core
29+ other-modules: Data.JsonSchema.Draft4.Failure
30− Data.JsonSchema.Draft4
30+ , Data.JsonSchema.Draft4.Schema
31− , Data.JsonSchema.Draft4.Objects.Properties
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
32 , Import
37 , Import
33 default-language: Haskell2010
38 default-language: Haskell2010
34 default-extensions: ScopedTypeVariables
39 default-extensions: ScopedTypeVariables
35 OverloadedStrings
40 OverloadedStrings
36− other-extensions: TemplateHaskell
37 ghc-options: -Wall
41 ghc-options: -Wall
38− build-depends: aeson >= 0.7 && < 0.11
42+ build-depends: aeson >= 0.7 && < 0.12
39 -- 4.6 doesn't have a Traversable Either instance:
43 -- 4.6 doesn't have a Traversable Either instance:
40− , base >= 4.7 && < 4.9
44+ , base >= 4.7 && < 4.9
41− , bytestring >= 0.10 && < 0.11
45+ , bytestring >= 0.10 && < 0.11
42− , containers >= 0.5 && < 0.6
46+ , containers >= 0.5 && < 0.6
43− , file-embed >= 0.0.8 && < 0.0.10
47+ , file-embed >= 0.0.8 && < 0.0.10
44− , hashable >= 1.2 && < 1.3
45− , hjsonpointer >= 0.2 && < 0.3
48+ , hjsonpointer >= 0.3 && < 0.4
46− , http-client >= 0.4.9 && < 0.5
49+ , http-client >= 0.4.9 && < 0.5
47− , http-types >= 0.8 && < 0.10
50+ , http-types >= 0.8 && < 0.10
48− , mtl >= 2.2.1 && < 2.3
51+ , QuickCheck >= 2.8.1 && < 2.9
49− , regexpr >= 0.5 && < 0.6
52+ , regexpr >= 0.5 && < 0.6
50− , scientific >= 0.3 && < 0.4
53+ , scientific >= 0.3 && < 0.4
51− , transformers >= 0.4.2 && < 0.5
54+ , semigroups >= 0.18.0 && < 0.19
52− , unordered-containers >= 0.2 && < 0.3
55+ , unordered-containers >= 0.2 && < 0.3
53− , text >= 1.2 && < 1.3
56+ , text >= 1.2 && < 1.3
54− , vector >= 0.10 && < 0.12
57+ , vector >= 0.10 && < 0.12
55
58
56test-suite local
59test-suite local
57 type: exitcode-stdio-1.0
60 type: exitcode-stdio-1.0
58 hs-source-dirs: tests
61 hs-source-dirs: tests
59 main-is: Local.hs
62 main-is: Local.hs
63+ other-modules: Shared
60 default-language: Haskell2010
64 default-language: Haskell2010
61− ghc-options: -Wall
65+ ghc-options: -Wall -fno-warn-orphans
62 default-extensions: OverloadedStrings
66 default-extensions: OverloadedStrings
63− other-extensions: TemplateHaskell
64 build-depends: aeson
67 build-depends: aeson
65 , base
68 , base
66 , bytestring
69 , bytestring
70+ , hjsonpointer
67 , hjsonschema
71 , hjsonschema
68 , text
72 , text
73+ , QuickCheck
74+ , unordered-containers
69 , vector
75 , vector
70− , directory >= 1.2 && < 1.3
76+ , directory >= 1.2 && < 1.3
71− , filepath >= 1.3 && < 1.5
77+ , filepath >= 1.3 && < 1.5
72− , HUnit >= 1.2 && < 1.4
78+ , HUnit >= 1.2 && < 1.4
73− , test-framework >= 0.8 && < 0.9
79+ , tasty >= 0.11 && < 0.12
74− , test-framework-hunit >= 0.3 && < 0.4
80+ , tasty-hunit >= 0.9 && < 0.10
81+ , tasty-quickcheck >= 0.8 && < 0.9
75
82
76test-suite remote
83test-suite remote
77 type: exitcode-stdio-1.0
84 type: exitcode-stdio-1.0
78 hs-source-dirs: tests
85 hs-source-dirs: tests
79 main-is: Remote.hs
86 main-is: Remote.hs
87+ other-modules: Shared
80 default-language: Haskell2010
88 default-language: Haskell2010
81− ghc-options: -Wall
89+ ghc-options: -Wall -fno-warn-orphans
82 default-extensions: OverloadedStrings
90 default-extensions: OverloadedStrings
83− other-extensions: TemplateHaskell
84 build-depends: aeson
91 build-depends: aeson
85 , async
92 , async
86 , base
93 , base
@@ -91,17 +98,22 @@ test-suite remote
91 , directory
98 , directory
92 , filepath
99 , filepath
93 , HUnit
100 , HUnit
94− , test-framework
101+ , tasty
95− , test-framework-hunit
102+ , tasty-hunit
96 , wai-app-static
103 , wai-app-static
97 , warp
104 , warp
98
105
99executable example
106executable example
107+ hs-source-dirs: examples
100− main-is: Example.hs
108+ main-is: Main.hs
109+ other-modules: CustomSchema
110+ , PrettyShowFailure
111+ , Standard
101 default-language: Haskell2010
112 default-language: Haskell2010
102 ghc-options: -Wall
113 ghc-options: -Wall
103 build-depends: aeson
114 build-depends: aeson
104 , base
115 , base
116+ , hjsonpointer
105 , hjsonschema
117 , hjsonschema
106 , text
118 , text
107 , unordered-containers
119 , 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 ScopedTypeVariables #-}
1−{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TemplateHaskell #-}
2−
3+
3−module Data.JsonSchema.Draft4 where
4+module Data.JsonSchema.Draft4
4−
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
5−import qualified Data.ByteString.Lazy as LBS
24+import qualified Data.ByteString.Lazy as LBS
6import Data.FileEmbed
25import Data.FileEmbed
7−import qualified Data.HashMap.Strict as H
26+import qualified Data.HashMap.Strict as H
8−
9−import Data.JsonSchema.Core
27+import Data.Maybe (fromMaybe)
28+
10−import Data.JsonSchema.Draft4.Any
29+import Data.JsonSchema.Draft4.Failure
11−import qualified Data.JsonSchema.Draft4.Arrays as AR
30+import qualified Data.JsonSchema.Draft4.Internal as IN
12−import qualified Data.JsonSchema.Draft4.Numbers as NU
31+import Data.JsonSchema.Draft4.Schema
13−import qualified Data.JsonSchema.Draft4.Objects as OB
32+import Data.JsonSchema.Fetch (SchemaCache(..),
14−import Data.JsonSchema.Draft4.Strings
33+ SchemaContext(..),
15−import Data.JsonSchema.Helpers
34+ URISchemaMap)
35+import qualified Data.JsonSchema.Fetch as FE
36+import Data.Validator.Reference (baseAndFragment)
16import Import
37import Import
17
38
18−data Draft4Failure
39+-- | Check the validity of a schema and return a function to validate data.
19− = MultipleOf
40+checkSchema
20−
41+ :: SchemaCache Schema
21− | Maximum
42+ -> SchemaContext Schema
22− | ExclusiveMaximum
43+ -> Either [Failure] (Value -> [Failure])
23−
44+checkSchema sg sc =
24− | Minimum
45+ case schemaValidity (_scSchema sc) of
25− | ExclusiveMinimum
46+ [] -> Right (IN.runValidate sg sc)
26−
47+ es -> Left es
27− | MaxLength
48+
28− | MinLength
49+fetchReferencedSchemas
29− | Pattern
50+ :: URISchemaMap Schema
30−
51+ -> SchemaContext Schema
31− | Items Draft4Failure
52+ -> IO (Either Text (SchemaCache Schema))
32− | AdditionalItemsBool
53+fetchReferencedSchemas =
33− | AdditionalItemsObject Draft4Failure
54+ FE.fetchReferencedSchemas IN.embedded _schemaId _schemaRef
34−
55+
35− | MaxItems
56+-- | In normal situations just use 'checkSchema', which is a combination of
36− | MinItems
57+-- 'schemaValidity' and 'runValidate'.
37− | UniqueItems
58+schemaValidity :: Schema -> [Failure]
38− | MaxProperties
59+schemaValidity = IN.runValidate cache (SchemaContext Nothing d4) . toJSON
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− ]
88 where
60 where
89− fMax NU.Maximum = Maximum
61+ d4 :: Schema
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)"
62+ d4 = fromMaybe (error "Schema decode failed (this should never happen)")
126− Just s ->
63+ . decode . LBS.fromStrict $ $(embedFile "draft4.json")
127− let a = RawSchema Nothing s
64+
128− in validate (compile draft4 (SchemaGraph a mempty) a) $ Object (_rsData r)
65+ -- @fst . baseAndFragment@ is necessary to remove the trailing "#",
129−
66+ -- otherwise cache lookups to resolve internal references will fail.
130−-- | Check that a 'RawSchema' conforms to the JSON Schema Draft 4
67+ cache :: SchemaCache Schema
131−-- master schema document. Compile it if it does.
68+ cache = SchemaCache d4 $ case _schemaId d4 >>= fst . baseAndFragment of
132−--
69+ Nothing -> mempty
133−-- This is just a convenience function built by combining
70+ Just uri -> H.singleton uri d4
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
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 @@
1
1
2−module Data.JsonSchema.Reference where
2+module Data.Validator.Reference where
3
3
4−import qualified Data.HashMap.Strict as H
4+import qualified Data.Aeson.Pointer as P
5−import Data.JsonPointer
6import qualified Data.Text as T
5import qualified Data.Text as T
7import Data.Text.Encoding
6import Data.Text.Encoding
8import Network.HTTP.Types.URI
7import Network.HTTP.Types.URI
@@ -12,11 +11,11 @@ import Import
12type URIBase = Maybe Text
11type URIBase = Maybe Text
13type URIBaseAndFragment = (Maybe Text, Maybe Text)
12type URIBaseAndFragment = (Maybe Text, Maybe Text)
14
13
15−newResolutionScope :: URIBase -> HashMap Text Value -> URIBase
14+newResolutionScope :: URIBase -> Maybe Text -> URIBase
16−newResolutionScope mScope o =
15+newResolutionScope mScope idKeyword =
17− case H.lookup "id" o of
16+ case idKeyword of
18− Just (String t) -> fst . baseAndFragment $ resolveScopeAgainst mScope t
17+ Just t -> fst . baseAndFragment $ resolveScopeAgainst mScope t
19− _ -> mScope
18+ _ -> mScope
20
19
21resolveReference :: URIBase -> Text -> URIBaseAndFragment
20resolveReference :: URIBase -> Text -> URIBaseAndFragment
22resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t
21resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t
@@ -24,16 +23,19 @@ resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t
24isRemoteReference :: Text -> Bool
23isRemoteReference :: Text -> Bool
25isRemoteReference uri = "://" `T.isInfixOf` uri
24isRemoteReference uri = "://" `T.isInfixOf` uri
26
25
27−resolveFragment :: Maybe Text -> HashMap Text Value -> HashMap Text Value
26+resolveFragment
27+ :: (FromJSON schema, ToJSON schema, Show schema)
28+ => Maybe Text
29+ -> schema
30+ -> Maybe schema
28−resolveFragment Nothing hm = hm
31+resolveFragment Nothing schema = Just schema
29−resolveFragment (Just pointer) hm =
32+resolveFragment (Just pointer) schema = do
30 let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer
33 let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer
31− in case jsonPointer urlDecoded of
34+ p <- either (const Nothing) Just (P.unescape urlDecoded)
32− Left _ -> hm
35+ x <- either (const Nothing) Just (P.resolve p (toJSON schema))
33− Right p ->
36+ case fromJSON x of
34− case resolvePointer p (Object hm) of
37+ Error _ -> Nothing
35− Right (Object hm') -> hm'
38+ Success schema' -> Just schema'
36− _ -> hm
37
39
38--------------------------------------------------
40--------------------------------------------------
39-- * Internal
41-- * 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
9import Data.Text as Export (Text)
9import Data.Text as Export (Text)
10import Data.Traversable as Export
10import Data.Traversable as Export
11import Data.Vector as Export (Vector)
11import 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+
1module Main where
2module Main where
2
3
3import Control.Applicative
4import Control.Applicative
5+import Control.Monad (unless)
6+import Data.Aeson
7+import qualified Data.Aeson.Pointer as P
4−import Data.List (isSuffixOf)
8+import Data.List (isSuffixOf)
5−import Lib
9+import Data.Monoid
6−import System.Directory (getDirectoryContents)
10+import System.Directory (getDirectoryContents)
7−import Test.Framework
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"
8
23
9main :: IO ()
24main :: IO ()
10main = do
25main = do
11− filenames <- filter isLocal . filter (".json" `isSuffixOf`)
26+ filenames <- filter isLocal . filter (".json" `isSuffixOf`) <$> getDirectoryContents dir
12− <$> getDirectoryContents dir
13 ts <- readSchemaTests dir filenames
27 ts <- readSchemaTests dir filenames
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
14− defaultMain (toTest <$> ts)
31+ : fmap toTest ts
15
32
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)
16 where
46 where
17− dir :: String
47+ [failure] = runValidate (SchemaCache schema mempty) sc (toJSON [[True, True]])
18− dir = "JSON-Schema-Test-Suite/tests/draft4"
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
3import Control.Applicative
3import Control.Applicative
4import Control.Concurrent.Async (withAsync)
4import Control.Concurrent.Async (withAsync)
5import Data.List (isSuffixOf)
5import Data.List (isSuffixOf)
6−import Lib
7import Network.Wai.Application.Static (defaultFileServerSettings,
6import Network.Wai.Application.Static (defaultFileServerSettings,
8 staticApp)
7 staticApp)
9import Network.Wai.Handler.Warp (run)
8import Network.Wai.Handler.Warp (run)
10import System.Directory (getDirectoryContents)
9import 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"
12
17
13main :: IO ()
18main :: IO ()
14−main =
19+main = withAsync serve $ \_ -> do
15− withAsync (run 1234 $ staticApp $ defaultFileServerSettings "JSON-Schema-Test-Suite/remotes") $ \_ -> do
16− filenames <- filter (not . isLocal) . filter (".json" `isSuffixOf`)
20+ filenames <- filter (not . isLocal) . filter (".json" `isSuffixOf`)
17 <$> getDirectoryContents dir
21 <$> getDirectoryContents dir
18− ts <- readSchemaTests dir filenames
22+ ts <- readSchemaTests dir filenames
19− defaultMain (toTest <$> ts)
23+ defaultMain . testGroup "Tests that run an HTTP server" $ toTest <$> ts
20
24
21− where
25+serve :: IO ()
22− dir :: String
26+serve = run 1234 . staticApp . defaultFileServerSettings $ "JSON-Schema-Test-Suite/remotes"
23− dir = "JSON-Schema-Test-Suite/tests/draft4"
tests/Lib.hs → tests/Shared.hsrenamed+32−46
@@ -1,22 +1,22 @@
1−{-# LANGUAGE TemplateHaskell #-}
1+{-# LANGUAGE DeriveGeneric #-}
2−{-# OPTIONS_GHC -fno-warn-orphans #-}
3
2
4−module Lib where
3+module Shared where
5
4
6import Control.Applicative
5import Control.Applicative
7import Control.Monad
6import Control.Monad
8import Data.Aeson
7import Data.Aeson
9import Data.Aeson.TH
8import Data.Aeson.TH
10−import qualified Data.ByteString.Lazy as LBS
9+import qualified Data.ByteString.Lazy as LBS
11−import Data.Char (toLower)
10+import Data.Char (toLower)
12−import Data.JsonSchema
13import Data.Monoid
11import Data.Monoid
14−import Data.Text (Text)
12+import Data.Text (Text)
15−import qualified Data.Text as T
13+import qualified Data.Text as T
14+import GHC.Generics
16−import System.FilePath ((</>))
15+import System.FilePath ((</>))
17−import Test.Framework (Test)
16+import Test.Tasty (TestTree)
18−import Test.Framework.Providers.HUnit (testCase)
17+import qualified Test.Tasty.HUnit as HU
19−import Test.HUnit hiding (Test)
18+
19+import qualified Data.JsonSchema.Draft4 as D4
20
20
21isLocal :: String -> Bool
21isLocal :: String -> Bool
22isLocal file = (file /= "definitions.json")
22isLocal file = (file /= "definitions.json")
@@ -25,7 +25,7 @@ isLocal file = (file /= "definitions.json")
25
25
26data SchemaTest = SchemaTest
26data SchemaTest = SchemaTest
27 { _stDescription :: Text
27 { _stDescription :: Text
28− , _stSchema :: RawSchema
28+ , _stSchema :: D4.Schema
29 , _stCases :: [SchemaTestCase]
29 , _stCases :: [SchemaTestCase]
30 }
30 }
31
31
@@ -33,16 +33,16 @@ data SchemaTestCase = SchemaTestCase
33 { _scDescription :: Text
33 { _scDescription :: Text
34 , _scData :: Value
34 , _scData :: Value
35 , _scValid :: Bool
35 , _scValid :: Bool
36− }
36+ } deriving Generic
37−
38−instance FromJSON RawSchema where
39− parseJSON = withObject "Schema" $ return . RawSchema Nothing
40
37
41instance FromJSON SchemaTest where
38instance FromJSON SchemaTest where
42 parseJSON = withObject "SchemaTest" $ \o -> SchemaTest
39 parseJSON = withObject "SchemaTest" $ \o -> SchemaTest
43 <$> o .: "description"
40 <$> o .: "description"
44 <*> o .: "schema"
41 <*> 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 }
46
46
47readSchemaTests :: String -> [String] -> IO [SchemaTest]
47readSchemaTests :: String -> [String] -> IO [SchemaTest]
48readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles
48readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles
@@ -54,7 +54,7 @@ readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles
54 jsonBS <- LBS.readFile fullPath
54 jsonBS <- LBS.readFile fullPath
55 case eitherDecode jsonBS of
55 case eitherDecode jsonBS of
56 Left e -> fail $ "couldn't parse file '" <> fullPath <> "': " <> e
56 Left e -> fail $ "couldn't parse file '" <> fullPath <> "': " <> e
57− Right schemaTests -> return $ prependFileName name <$> schemaTests
57+ Right schemaTests -> pure $ prependFileName name <$> schemaTests
58
58
59 prependFileName :: String -> SchemaTest -> SchemaTest
59 prependFileName :: String -> SchemaTest -> SchemaTest
60 prependFileName fileName s = s
60 prependFileName fileName s = s
@@ -64,50 +64,36 @@ readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles
64 concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
64 concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
65 concatMapM f xs = liftM concat (mapM f xs)
65 concatMapM f xs = liftM concat (mapM f xs)
66
66
67−toTest :: SchemaTest -> Test
67+toTest :: SchemaTest -> TestTree
68toTest st =
68toTest st =
69− testCase (T.unpack $ _stDescription st) $ do
69+ HU.testCase (T.unpack (_stDescription st)) $ do
70− sanityCheckTest (_stSchema st)
71 forM_ (_stCases st) $ \sc -> do
70 forM_ (_stCases st) $ \sc -> do
72− g <- assertRight =<< fetchReferencedSchemas draft4 mempty (_stSchema st)
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 (compile draft4 g $ _stSchema st) (_scData sc)
73+ let res = validate (_scData sc)
74 if _scValid sc
74 if _scValid sc
75 then assertValid sc res
75 then assertValid sc res
76 else assertInvalid sc res
76 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− ]
87
77
88−assertValid :: SchemaTestCase -> [ValidationFailure Draft4Failure] -> Assertion
78+assertValid :: SchemaTestCase -> [D4.Failure] -> HU.Assertion
89−assertValid _ [] = return ()
79+assertValid _ [] = pure ()
90assertValid sc errs =
80assertValid sc errs =
91− assertFailure $ unlines
81+ HU.assertFailure $ unlines
92 [ " Failed to validate data"
82 [ " Failed to validate data"
93 , " Description: " <> T.unpack (_scDescription sc)
83 , " Description: " <> T.unpack (_scDescription sc)
94 , " Data: " <> show (_scData sc)
84 , " Data: " <> show (_scData sc)
95 , " Validation failures: " <> show errs
85 , " Validation failures: " <> show errs
96 ]
86 ]
97
87
98−assertInvalid :: SchemaTestCase -> [ValidationFailure Draft4Failure] -> Assertion
88+assertInvalid :: SchemaTestCase -> [D4.Failure] -> HU.Assertion
99assertInvalid sc [] =
89assertInvalid sc [] =
100− assertFailure $ unlines
90+ HU.assertFailure $ unlines
101 [ " Validated invalid data"
91 [ " Validated invalid data"
102 , " Description: " <> T.unpack (_scDescription sc)
92 , " Description: " <> T.unpack (_scDescription sc)
103 , " Data: " <> show (_scData sc)
93 , " Data: " <> show (_scData sc)
104 ]
94 ]
105−assertInvalid _ _ = return ()
95+assertInvalid _ _ = pure ()
106
96
107assertRight :: (Show a) => Either a b -> IO b
97assertRight :: (Show a) => Either a b -> IO b
108−assertRight a =
109− case a of
110− Left e -> assertFailure (show e) >> fail "assertRight failed"
98+assertRight (Left e) = HU.assertFailure (show e) >> fail "assertRight failed"
111− Right b -> return b
99+assertRight (Right b) = pure b
112−
113−$(deriveFromJSON defaultOptions { fieldLabelModifier = map toLower . drop 3 } ''SchemaTestCase)