json-schema 0.6.1.1 → 0.7.0.0
raw patch · 9 files changed
+515/−94 lines, 9 filesdep +aeson-utilsdep +mtldep +scientificdep −HUnitdep ~aesondep ~basedep ~generic-aeson
Dependencies added: aeson-utils, mtl, scientific
Dependencies removed: HUnit
Dependency ranges changed: aeson, base, generic-aeson
Files
- CHANGELOG.md +10/−0
- json-schema.cabal +15/−8
- src/Data/JSON/Schema/Combinators.hs +5/−0
- src/Data/JSON/Schema/Generic.hs +37/−24
- src/Data/JSON/Schema/Types.hs +3/−4
- src/Data/JSON/Schema/Validate.hs +149/−0
- tests/Main.hs +186/−58
- tests/Test/Util.hs +55/−0
- tests/Test/Validate.hs +55/−0
CHANGELOG.md view
@@ -1,5 +1,15 @@ # Changelog +## 0.7.0.0++* Removed the `Null` constructor from `Schema`, use `Data.JSON.Schema.Combinators.nullable` instead.++* Added the `Validation` module that can be used to validate a json+ object against a schema and to get descriptive error messages.++* Updates for `Maybe` fixes in `generic-aeson 0.2.0.0` including more+ thorough test cases.+ #### 0.6.1.1 * Bugfix: Remove underscores from fields and constructors in generated schemas to match generic-aeson.
json-schema.cabal view
@@ -1,5 +1,5 @@ name: json-schema-version: 0.6.1.1+version: 0.7.0.0 synopsis: Types and type classes for defining JSON schemas. description: Types and type classes for defining JSON schemas. license: BSD3@@ -27,12 +27,15 @@ Data.JSON.Schema.Combinators Data.JSON.Schema.Generic Data.JSON.Schema.Types+ Data.JSON.Schema.Validate build-depends: base == 4.*- , aeson >= 0.6 && < 0.9+ , aeson >= 0.7 && < 0.9 , containers >= 0.3 && < 0.6- , generic-aeson >= 0.1.1.1 && < 0.2+ , generic-aeson == 0.2.* , generic-deriving == 1.6.*+ , mtl >= 2.1 && < 2.3+ , scientific == 0.3.* , tagged >= 0.2 && < 0.8 , text >= 0.10 && < 1.2 , time >= 1.2 && < 1.5@@ -44,16 +47,20 @@ hs-source-dirs: tests main-is: Main.hs type: exitcode-stdio-1.0+ other-modules:+ Test.Util+ Test.Validate build-depends: base- , HUnit >= 1.2 && < 1.3- , aeson+ , aeson >= 0.7 && < 0.9+ , aeson-utils == 0.2.* , attoparsec >= 0.10 && < 0.13 , bytestring >= 0.10 && < 0.12- , generic-aeson >= 0.1.1.1 && < 0.2+ , generic-aeson == 0.2.* , json-schema , tagged >= 0.2 && < 0.8- , tasty == 0.8.*- , tasty-hunit == 0.8.*+ , tasty >= 0.8 && < 0.10+ , tasty-hunit >= 0.8 && < 0.10 , tasty-th == 0.1.* , text >= 0.10 && < 1.2+ , vector == 0.10.*
src/Data/JSON/Schema/Combinators.hs view
@@ -14,6 +14,7 @@ , enum , unbounded , unboundedLength+ , nullable ) where import Data.JSON.Schema.Types@@ -77,3 +78,7 @@ -- | A choice between constant values. enum :: [Aeson.Value] -> Schema enum = Choice . map Constant++-- | The provided schema or null.+nullable :: Schema -> Schema+nullable = (<|> Constant Aeson.Null)
src/Data/JSON/Schema/Generic.hs view
@@ -11,7 +11,10 @@ -- | Generic derivation of schemas. The schemas generated match the -- JSON generated by type 'generic-aeson' package. See that package -- for documentation on the format and examples of it.-module Data.JSON.Schema.Generic (gSchema) where+module Data.JSON.Schema.Generic+ ( gSchema+ , gSchemaWithSettings+ ) where import Control.Applicative hiding (empty, (<|>)) import Data.JSON.Schema.Combinators@@ -27,10 +30,13 @@ -- | Derive a JSON schema for types with an instance of 'Generic'. gSchema :: (Generic a, GJSONSCHEMA (Rep a), ConNames (Rep a), GIsEnum (Rep a)) => Proxy a -> Schema-gSchema p = gSchema' (isEnum p) ((map T.pack . conNames . pv) p) (fmap from p)+gSchema = gSchemaWithSettings defaultSettings +gSchemaWithSettings :: (Generic a, GJSONSCHEMA (Rep a), ConNames (Rep a), GIsEnum (Rep a)) => Settings -> Proxy a -> Schema+gSchemaWithSettings set p = gSchema' set (isEnum p) ((map T.pack . conNames . pv) p) (fmap from p)+ class GJSONSCHEMA f where- gSchema' :: Bool -> [Text] -> Proxy (f a) -> Schema+ gSchema' :: Settings -> Bool -> [Text] -> Proxy (f a) -> Schema -- Recursive positions disabled for now, it causes infintite data structures. This is a problem to be solved! {-@@ -39,18 +45,18 @@ -} instance JSONSchema c => GJSONSCHEMA (K1 i c) where- gSchema' _ _ = schema . fmap unK1+ gSchema' _ _ _ = schema . fmap unK1 instance GJSONSCHEMA (K1 i String) where- gSchema' _ _ _ = Value unboundedLength+ gSchema' _ _ _ _ = Value unboundedLength instance GJSONSCHEMA U1 where- gSchema' _ _ _ = empty+ gSchema' _ _ _ _ = empty instance (GJSONSCHEMA f, GJSONSCHEMA g) => GJSONSCHEMA (f :+: g) where- gSchema' enm names p =- gSchema' enm names (gL <$> p)- <|> gSchema' enm names (gR <$> p)+ gSchema' set enm names p =+ gSchema' set enm names (gL <$> p)+ <|> gSchema' set enm names (gR <$> p) where gL :: (f :+: g) r -> f r gL _ = undefined@@ -58,36 +64,43 @@ gR _ = undefined instance (GJSONSCHEMA f, GJSONSCHEMA g) => GJSONSCHEMA (f :*: g) where- gSchema' enm names p = gSchema' enm names (gFst <$> p) `merge` gSchema' enm names (gSnd <$> p)+ gSchema' set enm names p = gSchema' set enm names (gFst <$> p) `merge` gSchema' set enm names (gSnd <$> p) instance (Constructor c, GJSONSCHEMA f) => GJSONSCHEMA (M1 C c f) where- gSchema' True _ = toConstant . conNameT . pv- gSchema' enm names = wrap . gSchema' enm names . fmap unM1+ gSchema' set True _ = toConstant set . conNameT set . pv+ gSchema' set enm names = wrap . gSchema' set enm names . fmap unM1 where wrap = if multipleCons names- then field (conNameT (undefined :: M1 C c f p)) True+ then field (conNameT set (undefined :: M1 C c f p)) True else id instance GJSONSCHEMA f => GJSONSCHEMA (M1 D c f) where- gSchema' True names p | multipleCons names = const (Choice . fmap toConstant $ names) $ p- gSchema' enm names p = gSchema' enm names . fmap unM1 $ p+ gSchema' set True names p | multipleCons names = const (Choice . fmap (toConstant set) $ names) $ p+ gSchema' set enm names p = gSchema' set enm names . fmap unM1 $ p instance (Selector c, JSONSchema a) => GJSONSCHEMA (M1 S c (K1 i (Maybe a))) where- gSchema' _ _ = field (selNameT (undefined :: M1 S c f p)) False . schema . fmap (fromJust . unK1 . unM1)+ gSchema' set _ _ =+ case selNameT set (undefined :: M1 S c f p) of+ Nothing -> nullable . maybeElemSchema -- C (Maybe a) => [a] or [null]+ Just n -> field n False . maybeElemSchema -- C { f :: Maybe a } => { f : a } or {}+ where+ maybeElemSchema :: Proxy (M1 S c (K1 i (Maybe a)) p) -> Schema+ maybeElemSchema = s+ where s = schema . fmap (fromJust . unK1 . unM1) --- TODO This instance does not correspond to the generic-aeson representation for Maybe instance Selector c => GJSONSCHEMA (M1 S c (K1 i (Maybe String))) where- gSchema' _ _ _ = field (selNameT (undefined :: M1 S c f p)) False $ Value unboundedLength+ gSchema' set _ _ _ =+ case selNameT set (undefined :: M1 S c f p) of+ Nothing -> nullable value+ Just n -> field n False value instance (Selector c, GJSONSCHEMA f) => GJSONSCHEMA (M1 S c f) where- gSchema' enm names = wrap . gSchema' enm names . fmap unM1+ gSchema' set enm names = wrap . gSchema' set enm names . fmap unM1 where- wrap = case selNameT (undefined :: M1 S c f p) of- "" -> id- s -> field s True+ wrap = maybe id (\s -> field s True) $ selNameT set (undefined :: M1 S c f p) -toConstant :: Text -> Schema-toConstant = Constant . Aeson.String . formatLabel+toConstant :: Settings -> Text -> Schema+toConstant set = Constant . Aeson.String . formatLabel set gFst :: (f :*: g) r -> f r gFst (f :*: _) = f
src/Data/JSON/Schema/Types.hs view
@@ -49,8 +49,7 @@ -- indicates no bound. | Constant Aeson.Value -- ^ A Value that never changes. Can be -- combined with Choice to create enumerables.- | Null -- ^ Only null is allowed.- | Any -- ^ Anything value is allowed.+ | Any -- ^ Any value is allowed. deriving (Eq, Show) -- | A type for bounds on number domains. Use Nothing when no lower or upper bound makes sense@@ -79,7 +78,7 @@ schema :: Proxy a -> Schema instance JSONSchema () where- schema _ = Null+ schema _ = Constant Aeson.Null instance JSONSchema Int where schema _ = Number unbounded@@ -100,7 +99,7 @@ schema _ = Value unboundedLength instance JSONSchema a => JSONSchema (Maybe a) where- schema p = Choice [Object [Field "Just" True $ schema $ fmap fromJust p], Object [Field "Nothing" True Null]]+ schema p = Choice [Object [Field "Just" True $ schema $ fmap fromJust p], Object [Field "Nothing" True (Constant Aeson.Null)]] instance JSONSchema a => JSONSchema [a] where schema = Array unboundedLength False . schema . fmap head
+ src/Data/JSON/Schema/Validate.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE+ GeneralizedNewtypeDeriving+ , ScopedTypeVariables+ #-}+module Data.JSON.Schema.Validate+ ( isValid+ , validate+ , ValidationError (..)+ , ErrorType (..)+ ) where++import Control.Applicative+import Control.Monad.RWS.Strict+import Data.Aeson (Value)+import Data.HashMap.Strict (HashMap)+import Data.Scientific+import Data.Text (Text)+import Data.Vector (Vector)+import qualified Data.Aeson as A+import qualified Data.HashMap.Strict as H+import qualified Data.Text as T+import qualified Data.Vector as V++import Data.JSON.Schema (Schema)+import qualified Data.JSON.Schema as S++-- | Validates a value against a schema returning errors.+validate :: Schema -> Value -> Vector ValidationError+validate s v = (\(_,_,errs) -> errs) $ runRWS (unM $ validate' s v) V.empty ()++-- | Predicate version of 'validate'.+isValid :: Schema -> Value -> Bool+isValid s v = V.null $ validate s v++data ValidationError = ValidationError+ { path :: Vector Text -- ^ The Path to the property where the error occured, empty if the error is on the top level.+ , errorType :: ErrorType+ } deriving (Eq, Show)++data ErrorType+ = Mismatch Schema Value -- ^ General type error.+ | BoundError S.Bound Scientific -- ^ Number out of bounds.+ | LengthBoundError S.LengthBound Int -- ^ String or Array out of bounds.+ | TupleLength Int Int -- ^ Expected and actual tuple length.+ | MissingRequiredField Text -- ^ A required field is missing.+ | ChoiceError (Vector (Vector ValidationError)) Value -- ^ All choices failed, contains the error of each branch.+ | NonUniqueArray (HashMap Value Int) -- ^ The elements in the array that are duplicated with the number of occurences (at least 2).+ deriving (Eq, Show)++newtype M a = M { unM :: RWS (Vector Text) (Vector ValidationError) () a }+ deriving+ ( Functor+ , Applicative+ , Monad+ , MonadWriter (Vector ValidationError)+ , MonadReader (Vector Text)+ )++ok :: M ()+ok = return ()++err :: ErrorType -> M ()+err e = do+ pth <- ask+ tell . V.singleton . ValidationError pth $ e++cond :: ErrorType -> Bool -> M ()+cond e p = if p then ok else err e++nestPath :: Text -> M a -> M a+nestPath p m = local (`V.snoc` p) $ m++validate' :: Schema -> Value -> M ()+validate' sch val = case (sch, val) of+ ( S.Any , _ ) -> ok+ ( S.Boolean , A.Bool{} ) -> ok+ ( S.Constant x, _ ) -> cond (Mismatch sch val) (x == val)+ ( S.Number b, A.Number n ) ->+ do inLower b n+ inUpper b n+ ( S.Tuple xs, A.Array vs ) ->+ do let vlen = V.length vs+ let xlen = length xs+ cond (TupleLength xlen vlen) (xlen == vlen)+ sequence_ $ zipWith3+ (\i s -> nestPath (T.pack (show i)) . validate' s)+ [(0::Int)..] xs (V.toList vs)+ ( S.Map x, A.Object h ) ->+ do let kvs = H.toList h+ mapM_ (\(k,v) -> nestPath k $ validate' x v) kvs+ ( S.Object fs, A.Object h ) -> mapM_ (`validateField` h) fs+ ( S.Choice s, _ ) ->+ do let errs = map (`validate` val) s+ if any V.null errs+ then ok+ else err $ ChoiceError (V.fromList errs) val+ ( S.Value b, A.String w ) ->+ do inLowerLength b (T.length w)+ inUpperLength b (T.length w)+ ( S.Array b u s, A.Array vs) ->+ do inLowerLength b (V.length vs)+ inUpperLength b (V.length vs)+ if u then unique vs else ok+ sequence_ $ zipWith+ (\i -> nestPath (T.pack (show i)) . validate' s)+ [(0::Int)..] (V.toList vs)+ ( S.Boolean {}, _ ) -> err $ Mismatch sch val+ ( S.Number {}, _ ) -> err $ Mismatch sch val+ ( S.Tuple {}, _ ) -> err $ Mismatch sch val+ ( S.Object {}, _ ) -> err $ Mismatch sch val+ ( S.Map {}, _ ) -> err $ Mismatch sch val+ ( S.Value {}, _ ) -> err $ Mismatch sch val+ ( S.Array {}, _ ) -> err $ Mismatch sch val++validateField :: S.Field -> A.Object -> M ()+validateField f o = maybe req (nestPath (S.key f) . validate' (S.content f)) $ H.lookup (S.key f) o+ where+ req | not (S.required f) = ok+ | otherwise = err $ MissingRequiredField (S.key f)++unique :: Vector Value -> M ()+unique vs = do+ let dups = H.filter (>= 2) . V.foldl' (\h v -> H.insertWith (+) v 1 h) H.empty $ vs+ unless (H.null dups) $+ err (NonUniqueArray dups)++inLower :: S.Bound -> Scientific -> M ()+inLower b v =+ if (maybe True ((<= v) . fromIntegral) . S.lower $ b)+ then ok+ else err (BoundError b v)++inUpper :: S.Bound -> Scientific -> M ()+inUpper b v =+ if (maybe True ((>= v) . fromIntegral) . S.upper $ b)+ then ok+ else err (BoundError b v)++inLowerLength :: S.LengthBound -> Int -> M ()+inLowerLength b v =+ if (maybe True (<= v) . S.lowerLength $ b)+ then ok+ else err (LengthBoundError b v)++inUpperLength :: S.LengthBound -> Int -> M ()+inUpperLength b v =+ if (maybe True (>= v) . S.upperLength $ b)+ then ok+ else err (LengthBoundError b v)
tests/Main.hs view
@@ -2,16 +2,13 @@ {-# LANGUAGE DeriveGeneric , OverloadedStrings+ , ScopedTypeVariables , TemplateHaskell , TypeFamilies #-} module Main (main) where import Data.Aeson hiding (Result)-import Data.Aeson.Parser-import Data.Attoparsec.Lazy-import Data.ByteString.Lazy (ByteString)-import Data.List (intersperse) import Data.Proxy import GHC.Generics (Generic) import Generics.Generic.Aeson@@ -20,8 +17,11 @@ import Test.Tasty.TH import qualified Data.Aeson.Types as A +import Data.JSON.Schema+import Data.JSON.Schema.Combinators+import Test.Util import qualified Data.JSON.Schema as S-import Data.JSON.Schema (JSONSchema (..), gSchema, Field (..))+import qualified Test.Validate as Validate data SingleCons = SingleCons deriving (Generic, Show, Eq) instance ToJSON SingleCons where toJSON = gtoJson@@ -29,190 +29,318 @@ instance JSONSchema SingleCons where schema = gSchema case_constructorWithoutFields = do- eq (unsafeParse "\"singleCons\"", Right SingleCons)- (toJSON SingleCons , encDec SingleCons)+ bidir "\"singleCons\"" SingleCons eq (S.Constant (A.String "singleCons")) (schema (Proxy :: Proxy SingleCons))+ valid SingleCons -data Record = Record { field :: Int } deriving (Generic, Show, Eq)+data Record = Record { recordField :: Int } deriving (Generic, Show, Eq) instance ToJSON Record where toJSON = gtoJson instance FromJSON Record where parseJSON = gparseJson instance JSONSchema Record where schema = gSchema case_record = do- eq (unsafeParse "{\"field\":1}" , Right (Record { field = 1 }))- (toJSON Record { field = 1 }, encDec Record { field = 1 })- eq (S.Object [S.Field {S.key = "field", S.required = True, S.content = S.Number S.unbounded}])+ bidir "{\"recordField\":1}" Record { recordField = 1 }+ eq (S.Object [S.Field {S.key = "recordField", S.required = True, S.content = S.Number S.unbounded}]) (schema (Proxy :: Proxy Record))+ valid Record { recordField = 1 } data RecordTwoFields = D { d1 :: Int, d2 :: String } deriving (Generic, Show, Eq) instance ToJSON RecordTwoFields where toJSON = gtoJson instance FromJSON RecordTwoFields where parseJSON = gparseJson instance JSONSchema RecordTwoFields where schema = gSchema case_recordWithFields = do- eq (unsafeParse "{\"d1\":1,\"d2\":\"aap\"}" , Right (D {d1 = 1, d2 = "aap"}))- (toJSON D { d1 = 1, d2 = "aap" }, encDec D { d1 = 1, d2 = "aap" })+ bidir "{\"d1\":1,\"d2\":\"aap\"}"D {d1 = 1, d2 = "aap"} eq (S.Object [Field {key = "d1", required = True, content = S.Number S.unbounded}, Field {key = "d2", required = True, content = S.Value S.unboundedLength }]) (schema (Proxy :: Proxy RecordTwoFields))+ valid D { d1 = 1, d2 = "aap"} data E = E Int deriving (Generic, Show, Eq) instance ToJSON E where toJSON = gtoJson instance FromJSON E where parseJSON = gparseJson instance JSONSchema E where schema = gSchema case_constructorOneField = do- eq (unsafeParse "1" , Right (E 1))- (toJSON (E 1) , encDec (E 1))+ bidir "1" (E 1) eq (S.Number S.unbounded) (schema (Proxy :: Proxy E))+ valid $ E 1 data F = F Int String deriving (Generic, Show, Eq) instance ToJSON F where toJSON = gtoJson instance FromJSON F where parseJSON = gparseJson instance JSONSchema F where schema = gSchema case_constructorWithFields = do- eq (unsafeParse "[1,\"aap\"]",Right (F 1 "aap"))- (toJSON (F 1 "aap"), encDec (F 1 "aap"))+ bidir "[1,\"aap\"]" (F 1 "aap") eq (S.Tuple [S.Number S.unbounded, S.Value S.unboundedLength]) (schema (Proxy :: Proxy F))+ valid $ F 1 "aap" data G = G1 Int | G2 String deriving (Generic, Show, Eq) instance ToJSON G where toJSON = gtoJson instance FromJSON G where parseJSON = gparseJson instance JSONSchema G where schema = gSchema case_sumConstructorsWithField = do- eq (unsafeParse "{\"g1\":1}",unsafeParse "{\"g2\":\"aap\"}",Right (G1 1),Right (G2 "aap"))- (toJSON (G1 1), toJSON (G2 "aap"), encDec (G1 1), encDec (G2 "aap"))+ bidir "{\"g1\":1}" (G1 1)+ bidir "{\"g2\":\"aap\"}" (G2 "aap") eq (S.Choice [S.Object [Field {key = "g1", required = True, content = S.Number S.unbounded}],S.Object [Field {key = "g2", required = True, content = S.Value S.unboundedLength }]]) (schema (Proxy :: Proxy G))+ valid $ G1 1+ valid $ G2 "aap" data H = H1 { h1 :: Int } | H2 { h2 :: String } deriving (Generic, Show, Eq) instance ToJSON H where toJSON = gtoJson instance FromJSON H where parseJSON = gparseJson instance JSONSchema H where schema = gSchema case_sumRecord = do- eq (unsafeParse "{\"h1\":{\"h1\":1}}",unsafeParse "{\"h2\":{\"h2\":\"aap\"}}",Right (H1 {h1 = 1}),Right (H2 {h2 = "aap"}))- (toJSON (H1 1), toJSON (H2 "aap"), encDec (H1 1), encDec (H2 "aap"))+ bidir "{\"h1\":{\"h1\":1}}" H1 { h1 = 1 }+ bidir "{\"h2\":{\"h2\":\"aap\"}}" H2 { h2 = "aap" } eq (S.Choice [S.Object [Field {key = "h1", required = True, content = S.Object [Field {key = "h1", required = True, content = S.Number S.unbounded}]}],S.Object [Field {key = "h2", required = True, content = S.Object [Field {key = "h2", required = True, content = S.Value S.unboundedLength}]}]]) (schema (Proxy :: Proxy H))+ valid $ H1 1+ valid $ H2 "aap" data J = J1 { j1 :: Int, j2 :: String } | J2 deriving (Generic, Show, Eq) instance ToJSON J where toJSON = gtoJson instance FromJSON J where parseJSON = gparseJson instance JSONSchema J where schema = gSchema case_sumRecordConstructorWithoutFields = do- eq (unsafeParse "{\"j1\":{\"j1\":1,\"j2\":\"aap\"}}",unsafeParse "{\"j2\":{}}",Right (J1 {j1 = 1, j2 = "aap"}),Right J2)- (toJSON (J1 1 "aap"), toJSON J2, encDec (J1 1 "aap"), encDec J2)+ bidir "{\"j1\":{\"j1\":1,\"j2\":\"aap\"}}" J1 {j1 = 1, j2 = "aap"}+ bidir "{\"j2\":{}}" J2 eq (S.Choice [S.Object [Field {key = "j1", required = True, content = S.Object [Field {key = "j1", required = True, content = S.Number S.unbounded},Field {key = "j2", required = True, content = S.Value S.unboundedLength }]}],S.Object [Field {key = "j2", required = True, content = S.Object []}]]) (schema (Proxy :: Proxy J))+ valid $ J1 1 "aap"+ valid $ J2 data L = L1 | L2 Int String deriving (Generic, Show, Eq) instance ToJSON L where toJSON = gtoJson instance FromJSON L where parseJSON = gparseJson instance JSONSchema L where schema = gSchema case_sumConstructorWithoutFieldsConstructorWithFields = do- eq (unsafeParse "{\"l1\":{}}",unsafeParse "{\"l2\":[1,\"aap\"]}",Right L1,Right (L2 1 "aap"))- (toJSON L1, toJSON (L2 1 "aap"), encDec L1, encDec (L2 1 "aap"))+ bidir "{\"l1\":{}}" L1+ bidir "{\"l2\":[1,\"aap\"]}" (L2 1 "aap") eq (S.Choice [S.Object [Field {key = "l1", required = True, content = S.Object []}],S.Object [Field {key = "l2", required = True, content = S.Tuple [S.Number S.unbounded, S.Value S.unboundedLength]}]]) (schema (Proxy :: Proxy L))+ valid L1+ valid (L2 1 "aap") data M = M1 | M2 Int M deriving (Generic, Show, Eq) instance ToJSON M where toJSON = gtoJson instance FromJSON M where parseJSON = gparseJson instance JSONSchema M where schema = gSchema case_sumConstructorWithoutFieldsConstructorWithRecursiveField = do- eq (unsafeParse "{\"m1\":{}}",unsafeParse "{\"m2\":[1,{\"m1\":{}}]}",unsafeParse "{\"m2\":[1,{\"m2\":[2,{\"m1\":{}}]}]}",Right M1,Right (M2 1 M1),Right (M2 1 (M2 2 M1)))- (toJSON M1, toJSON (M2 1 M1), toJSON (M2 1 (M2 2 M1)), encDec M1, encDec (M2 1 M1), encDec (M2 1 (M2 2 M1)))--- TODO Recursion--- eq (S.Any)--- (schema (Proxy :: Proxy x))+ let a = M1+ let b = M2 1 M1+ let c = M2 1 (M2 2 M1)+ bidir "{\"m1\":{}}" a+ bidir "{\"m2\":[1,{\"m1\":{}}]}" b+ bidir "{\"m2\":[1,{\"m2\":[2,{\"m1\":{}}]}]}" c+ -- Infinite schema, so we just validate+ valid a+ valid b+ valid c data N = N1 | N2 { n1 :: Int, n2 :: N } deriving (Generic, Show, Eq) instance ToJSON N where toJSON = gtoJson instance FromJSON N where parseJSON = gparseJson instance JSONSchema N where schema = gSchema case_sum_constructorWithoutFields_record = do- eq (unsafeParse "{\"n1\":{}}",unsafeParse "{\"n2\":{\"n2\":{\"n1\":{}},\"n1\":1}}",unsafeParse "{\"n2\":{\"n1\":1,\"n2\":{\"n2\":{\"n1\":2,\"n2\":{\"n1\":{}}}}}}",Right N1,Right (N2 {n1 = 1, n2 = N1}),Right (N2 {n1 = 1, n2 = N2 {n1 = 2, n2 = N1}}))- (toJSON N1, toJSON (N2 1 N1), toJSON (N2 1 (N2 2 N1)), encDec N1, encDec (N2 1 N1), encDec (N2 1 (N2 2 N1)))- -- TODO Recursive types produce infinite schemas- -- schema (Proxy :: Proxy N) @=? schema (Proxy :: Proxy N)+ bidir "{\"n1\":{}}" N1+ bidir "{\"n2\":{\"n2\":{\"n1\":{}},\"n1\":1}}" N2 { n1 = 1, n2 = N1 }+ bidir "{\"n2\":{\"n1\":1,\"n2\":{\"n2\":{\"n1\":2,\"n2\":{\"n1\":{}}}}}}" N2 { n1 = 1, n2 = N2 { n1 = 2, n2 = N1 } }+ -- Infinite schema, so we just validate+ valid $ N1+ valid $ N2 1 (N2 2 N1)+ valid $ N2 1 N1 data O = O { o :: [Int] } deriving (Generic, Show, Eq) instance ToJSON O where toJSON = gtoJson instance FromJSON O where parseJSON = gparseJson instance JSONSchema O where schema = gSchema case_recordListField = do- eq (unsafeParse "{\"o\":[1,2,3]}",Right (O {o = [1,2,3]}))- (toJSON (O [1,2,3]), encDec (O [1,2,3]))+ bidir "{\"o\":[1,2,3]}" O {o = [1,2,3]} eq (S.Object [Field {key = "o", required = True, content = S.Array S.unboundedLength False (S.Number S.unbounded)}]) (schema (Proxy :: Proxy O))+ valid $ O [1,2,3] data P = P [Int] deriving (Generic, Show, Eq) instance ToJSON P where toJSON = gtoJson instance FromJSON P where parseJSON = gparseJson instance JSONSchema P where schema = gSchema case_constructorListField = do- eq (unsafeParse "[1,2,3]",Right (P [1,2,3]))- (toJSON (P [1,2,3]), encDec (P [1,2,3]))+ bidir "[1,2,3]" (P [1,2,3]) eq (S.Array S.unboundedLength False (S.Number S.unbounded)) (schema (Proxy :: Proxy P))+ valid $ P [1,2,3] data Q = Q Int Int Int deriving (Generic, Show, Eq) instance ToJSON Q where toJSON = gtoJson instance FromJSON Q where parseJSON = gparseJson instance JSONSchema Q where schema = gSchema case_ConstructorSameTypedFields = do- eq (unsafeParse "[1,2,3]",Right (Q 1 2 3))- (toJSON (Q 1 2 3), encDec (Q 1 2 3))+ bidir "[1,2,3]" (Q 1 2 3) eq (S.Tuple [S.Number S.unbounded, S.Number S.unbounded, S.Number S.unbounded]) (schema (Proxy :: Proxy Q))+ valid $ Q 1 2 3 data T = T { r1 :: Maybe Int } deriving (Generic, Show, Eq) instance ToJSON T where toJSON = gtoJson instance FromJSON T where parseJSON = gparseJson instance JSONSchema T where schema = gSchema case_RecordMaybeField = do- eq (unsafeParse "{}", unsafeParse "{\"r1\":1}",Right (T {r1 = Nothing}),Right (T {r1 = Just 1}))- (toJSON (T Nothing), toJSON (T (Just 1)), encDec (T Nothing), encDec (T (Just 1)))+ bidir "{}" T { r1 = Nothing }+ bidir "{\"r1\":1}" T { r1 = Just 1 } eq (S.Object [Field {key = "r1", required = False, content = S.Number S.unbounded}]) (schema (Proxy :: Proxy T))+ valid $ T Nothing+ valid $ T (Just 1) data V = V1 | V2 | V3 deriving (Generic, Show, Eq) instance ToJSON V where toJSON = gtoJson instance FromJSON V where parseJSON = gparseJson instance JSONSchema V where schema = gSchema case_constructorsWithoutFields = do- eq (unsafeParse "\"v1\"",unsafeParse "\"v2\"",Right V1,Right V2)- (toJSON V1, toJSON V2, encDec V1, encDec V2)+ bidir "\"v1\"" V1+ bidir "\"v2\"" V2 eq (S.Choice [S.Constant (A.String "v1"), S.Constant (A.String "v2"), S.Constant (A.String "v3")]) (schema (Proxy :: Proxy V))+ valid V1+ valid V2 data W = W { underscore1_ :: Int, _underscore2 :: Int } deriving (Generic, Show, Eq) instance ToJSON W where toJSON = gtoJson instance FromJSON W where parseJSON = gparseJson instance JSONSchema W where schema = gSchema case_recordWithUnderscoredFields = do- eq (unsafeParse "{\"underscore1\":1,\"underscore2\":2}",Right (W {underscore1_ = 1, _underscore2 = 2}))- (toJSON (W 1 2), encDec (W 1 2))+ bidir "{\"underscore1\":1,\"underscore2\":2}" W {underscore1_ = 1, _underscore2 = 2} eq (S.Object [Field {key = "underscore1", required = True, content = S.Number S.unbounded},Field {key = "underscore2", required = True, content = S.Number S.unbounded}]) (schema (Proxy :: Proxy W))+ valid $ W 1 2 --- Helpers+data Strip = Strip { stripA :: Int, strip_B :: Int, stripC_ :: Int, strip :: Int } deriving (Generic, Show, Eq)+stripSettings :: Settings+stripSettings = defaultSettings { stripPrefix = Just "strip" }+instance ToJSON Strip where toJSON = gtoJsonWithSettings stripSettings+instance FromJSON Strip where parseJSON = gparseJsonWithSettings stripSettings+instance JSONSchema Strip where schema = gSchemaWithSettings stripSettings+case_strip = do+ bidir "{\"a\":1,\"b\":2,\"c\":3,\"strip\":4}" Strip { stripA = 1, strip_B = 2, stripC_ = 3, strip = 4 }+ eq (S.Object [ Field { key = "a" , required = True, content = S.Number S.unbounded }+ , Field { key = "b" , required = True, content = S.Number S.unbounded }+ , Field { key = "c" , required = True, content = S.Number S.unbounded }+ , Field { key = "strip", required = True, content = S.Number S.unbounded }+ ])+ (schema (Proxy :: Proxy Strip))+ valid (Strip 1 2 3 4) -encDec :: (FromJSON a, ToJSON a) => a -> Either String a-encDec a = case (parse value . encode) a of- Done _ r -> case fromJSON r of A.Success v -> Right v; Error s -> Left $ "fromJSON r=" ++ show r ++ ", s=" ++ s- Fail _ ss e -> Left . concat $ intersperse "," (ss ++ [e])+data Stat = StatA | StatB (Maybe Prog)+ deriving (Eq, Generic, Show)+data Prog = Prog { aff :: Int }+ deriving (Eq, Generic, Show)+instance ToJSON Prog where toJSON = gtoJson+instance FromJSON Prog where parseJSON = gparseJson+instance JSONSchema Prog where schema = gSchema+instance ToJSON Stat where toJSON = gtoJson+instance FromJSON Stat where parseJSON = gparseJson+instance JSONSchema Stat where schema = gSchema+case_stat = do+ let a = StatB (Just Prog { aff = 1 })+ bidir "{\"statB\":{\"aff\":1}}" a+ valid a -unsafeParse :: ByteString -> Value-unsafeParse = fromResult . parse value+ let b = StatB Nothing+ bidir "{\"statB\":null}" b+ eq (field "statA" True empty <|> field "statB" True (nullable $ field "aff" True number))+ (schema (Proxy :: Proxy Stat))+ valid b -fromResult (Done _ r) = r-fromResult _ = error "Boo"+-- https://github.com/silkapp/generic-aeson/issues/2+data X = X (Maybe Int) Int deriving (Eq, Generic, Show)+instance ToJSON X where toJSON = gtoJson+instance FromJSON X where parseJSON = gparseJson+instance JSONSchema X where schema = gSchema+case_constructorWithMaybeField = do+ let a = X (Just 1) 2+ bidir "[1,2]" a+ valid a -eq :: (Show a, Eq a) => a -> a -> Assertion-eq = (@=?)+ let b = X Nothing 2+ bidir "[null,2]" b+ valid b + eq (Left "when expecting a Int, encountered Boolean instead" :: Either String X)+ (eitherDecode "[true,2]")++ eq (Tuple [nullable number, number])+ (schema (Proxy :: Proxy X))++data X1 = X1 { x1a :: Maybe Int, x1b :: Int } deriving (Eq, Generic, Show)+instance ToJSON X1 where toJSON = gtoJson+instance FromJSON X1 where parseJSON = gparseJson+instance JSONSchema X1 where schema = gSchema+case_recordWithMaybeField = do+ let a = X1 { x1a = Just 1, x1b = 2 }+ bidir "{\"x1a\" : 1, \"x1b\" : 2}}" a+ valid a++ let b = X1 Nothing 2+ bidir "{ \"x1b\" : 2 }" b+ eq (Nothing :: Maybe X1)+ (decode "{\"x1a\":true,\"x1b\":2}")+ valid b++ eq (S.Object [Field "x1a" False number, Field "x1b" True number])+ (schema (Proxy :: Proxy X1))++ -- Regression test+ eq (Nothing :: Maybe X1)+ (decode "[true,2]")++-- https://github.com/silkapp/generic-aeson/issues/3+data X2 = X2 { x2 :: Maybe Int }+ deriving (Eq, Generic, Show)+instance ToJSON X2 where toJSON = gtoJson+instance FromJSON X2 where parseJSON = gparseJson+instance JSONSchema X2 where schema = gSchema+case_recordWithOnlyOneMaybeField = do+ eq (Nothing :: Maybe X2)+ (decode "[{\"x2\":1}]")+ bidir "{\"x2\":1}" X2 { x2 = Just 1 }+ valid $ X2 (Just 1)++data MaybeStringCon = MaybeStringCon (Maybe String)+ deriving (Eq, Generic, Show)+instance ToJSON MaybeStringCon where toJSON = gtoJson+instance FromJSON MaybeStringCon where parseJSON = gparseJson+instance JSONSchema MaybeStringCon where schema = gSchema+data MaybeString = MaybeString { ms :: Maybe String }+ deriving (Eq, Generic, Show)+instance ToJSON MaybeString where toJSON = gtoJson+instance FromJSON MaybeString where parseJSON = gparseJson+instance JSONSchema MaybeString where schema = gSchema+case_maybeString = do+ let a = MaybeStringCon (Just "x")+ bidir "\"x\"" a++ eq (nullable value)+ (schema (Proxy :: Proxy MaybeStringCon))++ valid a++ let b = MaybeString { ms = Just "x" }+ bidir "{\"ms\":\"x\"}" b++ valid b++ let c = MaybeString Nothing+ bidir "{}" c++ valid c++ eq (field "ms" False value)+ (schema (Proxy :: Proxy MaybeString))+ tests :: TestTree tests = $testGroupGenerator main :: IO ()-main = defaultMain $ testGroup "generic-aeson" [tests]+main = do+ defaultMain $ testGroup "generic-aeson" [tests, Validate.tests]
+ tests/Test/Util.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE+ OverloadedStrings+ , ScopedTypeVariables+ , TemplateHaskell+ , TypeFamilies+ #-}+module Test.Util where++import Data.Aeson hiding (Result)+import Data.Aeson.Parser ()+import Data.Aeson.Utils (eitherDecodeV)+import Data.Attoparsec.Lazy+import Data.ByteString.Lazy (ByteString)+import Data.ByteString.Lazy.Char8 (unpack)+import Data.List (intersperse)+import Data.Proxy+import Test.Tasty.HUnit+import qualified Data.Aeson.Parser as A+import qualified Data.Aeson.Types as A+import qualified Data.Vector as V++import Data.JSON.Schema+import Data.JSON.Schema.Validate++-- | Serializes a value to an aeson Value and validates that against the type's schema+valid :: forall a . (Show a, ToJSON a, FromJSON a, JSONSchema a) => a -> Assertion+valid v = do+ case eitherDecodeV (encode v) of+ Left err -> error err+ Right r -> case V.toList $ validate sch r of+ [] -> assertBool "x" True+ errs -> assertFailure ("schema validation for " ++ show v ++ " value: " ++ show r ++ " schema: " ++ show sch ++ " errors: " ++ show errs)+ where+ sch = schema (Proxy :: Proxy a)++encDec :: (FromJSON a, ToJSON a) => a -> Either String a+encDec a = case (parse A.value . encode) a of+ Done _ r -> case fromJSON r of A.Success v -> Right v; Error s -> Left $ "fromJSON r=" ++ show r ++ ", s=" ++ s+ Fail _ ss e -> Left . concat $ intersperse "," (ss ++ [e])++unsafeParse :: ByteString -> Value+unsafeParse b = fromResult . parse A.value $ b+ where+ fromResult (Done _ r) = r+ fromResult _ = error $ "unsafeParse failed on: " ++ unpack b++eq :: (Show a, Eq a) => a -> a -> Assertion+eq = (@=?)++bidir :: (FromJSON a, ToJSON a, Show a, Eq a) => ByteString -> a -> IO ()+bidir s d = do+ eq (unsafeParse s)+ (toJSON d)+ eq (Right d)+ (encDec d)
+ tests/Test/Validate.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS -fno-warn-missing-signatures #-}+{-# LANGUAGE+ OverloadedStrings+ , TemplateHaskell+ #-}+module Test.Validate (tests) where++import Data.ByteString.Lazy+import Data.Vector as V++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.TH++import Data.JSON.Schema+import Data.JSON.Schema.Combinators+import Data.JSON.Schema.Validate+import Test.Util++tests :: TestTree+tests = $testGroupGenerator++case_valid = do+ check [] number "1"+ check [] value "\"x\""+ check [] (field "p" True number) "{\"p\" : 1}"+ check [] (nullable value) "\"x\""+ check [] (nullable value) "null"++case_lengthBound = do+ check [err (v []) (LengthBoundError (LengthBound (Just 0) (Just 1)) 3)]+ (Value (LengthBound (Just 0) (Just 1)))+ "\"xyz\""++case_requiredProp = do+ check [err (v []) (MissingRequiredField "a")]+ (field "a" True number)+ "{}"+ check [err (v []) (MissingRequiredField "a")]+ (field "a" True (field "b" True number))+ "{}"+ check [err (v ["a"]) (MissingRequiredField "b")]+ (field "a" True (field "b" True number))+ "{\"a\":{}}"+ check [err (v ["a","b"]) (MissingRequiredField "c")]+ (field "a" True (field "b" True (field "c" True number)))+ "{\"a\":{\"b\":{}}}"++check :: [ValidationError] -> Schema -> ByteString -> Assertion+check errs s val = v errs @=? validate s (unsafeParse val)++err = ValidationError++v :: [a] -> Vector a+v = V.fromList