schematic 0.5.0.0 → 0.5.1.0
raw patch · 9 files changed
+229/−33 lines, 9 filesdep ~aesondep ~base
Dependency ranges changed: aeson, base
Files
- ChangeLog.md +7/−0
- schematic.cabal +4/−4
- src/Data/Schematic/DSL.hs +11/−2
- src/Data/Schematic/JsonSchema.hs +21/−9
- src/Data/Schematic/Migration.hs +10/−2
- src/Data/Schematic/Schema.hs +69/−3
- src/Data/Schematic/Schema.hs-boot +8/−0
- src/Data/Schematic/Validation.hs +41/−13
- test/JsonSchemaSpec.hs +58/−0
ChangeLog.md view
@@ -1,5 +1,12 @@ # Revision history for schematic +## 0.5.1.0 -- 2021-01-15++Fix the generation of json schema for numbers.+Add array constraints.+Fix the generation of text and number constraints.+Remove jsonpath from the error message.+ ## 0.5.0.0 -- 2019-02-20 GHC 8.6, json generation by schema definition, validation bug fixes, better
schematic.cabal view
@@ -1,5 +1,5 @@ name: schematic-version: 0.5.0.0+version: 0.5.1.0 synopsis: JSON-biased spec and validation tool description: JSON-biased spec and validation tool. Makes possible to have a schema as a haskell type and derive json instances, validation actions, JSON generation for property-test generically. Built-in lens support. license: BSD3@@ -65,9 +65,9 @@ , TypeOperators , TypeSynonymInstances , UndecidableInstances- build-depends: base >=4.11 && <4.12+ build-depends: base >=4.11 && <5 , bytestring- , aeson >= 1+ , aeson >= 1 && < 1.4.3.0 , containers , hjsonschema , mtl@@ -95,7 +95,7 @@ default-language: Haskell2010 build-depends: HUnit , aeson >= 1- , base >=4.11 && <4.12+ , base >=4.11 && <4.13 , bytestring , containers , hjsonschema
src/Data/Schematic/DSL.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-} module Data.Schematic.DSL where @@ -17,11 +18,19 @@ import Data.Vinyl.Functor +#if MIN_VERSION_base(4,12,0) type Constructor a- = forall fields b. (fields ~ FieldsOf a, FSubset fields b (FImage fields b))+ = forall fields b+ . (fields ~ FieldsOf a, FSubset fields b (FImage fields b), RMap fields) => Rec (Tagged fields :. FieldRepr) b -> JsonRepr ('SchemaObject fields)-+#else+type Constructor a+ = forall fields b+ . (fields ~ FieldsOf a, FSubset fields b (FImage fields b))+ => Rec (Tagged fields :. FieldRepr) b+ -> JsonRepr ('SchemaObject fields)+#endif withRepr :: Constructor a withRepr = ReprObject . rmap (unTagged . getCompose) . fcast
src/Data/Schematic/JsonSchema.hs view
@@ -30,13 +30,13 @@ textConstraint (DTEq n) = modify $ \s -> s { _schemaMinLength = pure $ fromIntegral n , _schemaMaxLength = pure $ fromIntegral n }-textConstraint (DTLt n) = modify $ \s -> s- { _schemaMaxLength = pure . fromIntegral $ n + 1 } textConstraint (DTLe n) = modify $ \s -> s { _schemaMaxLength = pure . fromIntegral $ n }-textConstraint (DTGt n) =+textConstraint (DTLt n) = let n' = if n == 0 then 0 else n - 1- in modify $ \s -> s { _schemaMinLength = pure . fromIntegral $ n' }+ in modify $ \s -> s { _schemaMaxLength = pure . fromIntegral $ n' }+textConstraint (DTGt n) = modify $ \s -> s+ { _schemaMinLength = pure . fromIntegral $ n + 1 } textConstraint (DTGe n) = modify $ \s -> s { _schemaMinLength = pure . fromIntegral $ n } textConstraint (DTRegex r) = modify $ \s -> s { _schemaPattern = pure r }@@ -48,18 +48,30 @@ numberConstraint (DNLe n) = modify $ \s -> s { _schemaMaximum = pure . fromIntegral $ n } numberConstraint (DNLt n) = modify $ \s -> s- { _schemaMaximum = pure . fromIntegral $ n + 1 }+ { _schemaMaximum = pure . fromIntegral $ n+ , _schemaExclusiveMaximum = pure True } numberConstraint (DNGt n) = modify $ \s -> s+ { _schemaMinimum = pure . fromIntegral $ n+ , _schemaExclusiveMinimum = pure True }+numberConstraint (DNGe n) = modify $ \s -> s { _schemaMinimum = pure . fromIntegral $ n }-numberConstraint (DNGe n) =- let n' = if n == 0 then 0 else n - 1- in modify $ \s -> s { _schemaMinimum = pure . fromIntegral $ n' } numberConstraint (DNEq n) = modify $ \s -> s { _schemaMinimum = pure $ fromIntegral n , _schemaMaximum = pure $ fromIntegral n } arrayConstraint :: DemotedArrayConstraint -> State D4.Schema ()-arrayConstraint (DAEq _) = pure ()+arrayConstraint (DALe n) = modify $ \s -> s+ { _schemaMaxItems = pure . fromIntegral $ n }+arrayConstraint (DALt n) =+ let n' = if n == 0 then 0 else n - 1+ in modify $ \s -> s { _schemaMaxItems = pure . fromIntegral $ n' }+arrayConstraint (DAGt n) = modify $ \s -> s+ { _schemaMinItems = pure . fromIntegral $ n + 1 }+arrayConstraint (DAGe n) = modify $ \s -> s+ { _schemaMinItems = pure . fromIntegral $ n }+arrayConstraint (DAEq n) = modify $ \s -> s+ { _schemaMinItems = pure $ fromIntegral n+ , _schemaMaxItems = pure $ fromIntegral n } toJsonSchema :: forall proxy schema
src/Data/Schematic/Migration.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-} module Data.Schematic.Migration where @@ -8,7 +9,7 @@ import Data.Schematic.Lens import Data.Schematic.Path import Data.Schematic.Schema-import Data.Singletons.Prelude hiding (All, (:.))+import Data.Singletons.Prelude hiding ((:.), All) import Data.Singletons.TypeLits import Data.Tagged import Data.Vinyl@@ -156,10 +157,17 @@ infixr 7 :&& +#if MIN_VERSION_base(4,12,0) migrateObject+ :: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m, RMap fh, RMap fs)+ => (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs))+ -> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))+#else+migrateObject :: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m) => (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs)) -> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))+#endif migrateObject f = Tagged $ \(ReprObject r) -> do res <- f $ rmap (Compose . Tagged) r pure $ withRepr @('SchemaObject fs) res
src/Data/Schematic/Schema.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fprint-explicit-kinds #-} module Data.Schematic.Schema where@@ -12,8 +13,8 @@ import Data.HashMap.Strict as H import Data.Kind import Data.Maybe-import Data.Schematic.Instances () import Data.Schematic.Generator+import Data.Schematic.Instances () import Data.Scientific import Data.Singletons.Prelude.List hiding (All, Union) import Data.Singletons.TH@@ -179,27 +180,63 @@ data ArrayConstraint = AEq Nat+ | AGt Nat+ | AGe Nat+ | ALt Nat+ | ALe Nat deriving (Generic) data DemotedArrayConstraint = DAEq Integer+ | DAGt Integer+ | DAGe Integer+ | DALt Integer+ | DALe Integer deriving (Generic, Eq, Show) data instance Sing (ac :: ArrayConstraint) where SAEq :: Sing n -> Sing ('AEq n)+ SAGt :: Sing n -> Sing ('AGt n)+ SAGe :: Sing n -> Sing ('AGe n)+ SALt :: Sing n -> Sing ('ALt n)+ SALe :: Sing n -> Sing ('ALe n) instance KnownNat n => SingI ('AEq n) where sing = SAEq sing+instance KnownNat n => SingI ('AGt n) where sing = SAGt sing+instance KnownNat n => SingI ('AGe n) where sing = SAGe sing+instance KnownNat n => SingI ('ALt n) where sing = SALt sing+instance KnownNat n => SingI ('ALe n) where sing = SALe sing instance Eq (Sing ('AEq n)) where _ == _ = True+instance Eq (Sing ('AGt n)) where _ == _ = True+instance Eq (Sing ('AGe n)) where _ == _ = True+instance Eq (Sing ('ALt n)) where _ == _ = True+instance Eq (Sing ('ALe n)) where _ == _ = True instance SingKind ArrayConstraint where type Demote ArrayConstraint = DemotedArrayConstraint fromSing = \case SAEq n -> withKnownNat n (DAEq . fromIntegral $ natVal n)+ SAGt n -> withKnownNat n (DAGt . fromIntegral $ natVal n)+ SAGe n -> withKnownNat n (DAGe . fromIntegral $ natVal n)+ SALt n -> withKnownNat n (DALt . fromIntegral $ natVal n)+ SALe n -> withKnownNat n (DALe . fromIntegral $ natVal n) toSing = \case DAEq n -> case someNatVal n of Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAEq (SNat :: Sing n)) Nothing -> error "Negative singleton nat"+ DAGt n -> case someNatVal n of+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAGt (SNat :: Sing n))+ Nothing -> error "Negative singleton nat"+ DAGe n -> case someNatVal n of+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAGe (SNat :: Sing n))+ Nothing -> error "Negative singleton nat"+ DALt n -> case someNatVal n of+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SALt (SNat :: Sing n))+ Nothing -> error "Negative singleton nat"+ DALe n -> case someNatVal n of+ Just (SomeNat (_ :: Proxy n)) -> SomeSing (SALe (SNat :: Sing n))+ Nothing -> error "Negative singleton nat" data Schema = SchemaText [TextConstraint]@@ -368,17 +405,32 @@ instance Show (JsonRepr ('SchemaNumber cs)) where show (ReprNumber n) = "ReprNumber " P.++ show n +instance Show (JsonRepr 'SchemaBoolean) where+ show (ReprBoolean n) = "ReprBoolean " P.++ show n+ instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull" instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where show (ReprArray v) = "ReprArray " P.++ show v +#if MIN_VERSION_base(4,12,0)+instance+ ( V.RecAll FieldRepr fs Show, RMap fs, ReifyConstraint Show FieldRepr fs+ , RecordToList fs )+ => Show (JsonRepr ('SchemaObject fs)) where+ show (ReprObject fs) = "ReprObject " P.++ show fs+#else instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where show (ReprObject fs) = "ReprObject " P.++ show fs+#endif instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where show (ReprOptional s) = "ReprOptional " P.++ show s +instance Show (Union JsonRepr (h ': tl))+ => Show (JsonRepr ('SchemaUnion (h ': tl))) where+ show (ReprUnion s) = "ReprUnion " P.++ show s+ instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where ReprObject a == ReprObject b = a == b @@ -388,6 +440,9 @@ instance Eq (JsonRepr ('SchemaNumber cs)) where ReprNumber a == ReprNumber b = a == b +instance Eq (JsonRepr 'SchemaBoolean) where+ ReprBoolean a == ReprBoolean b = a == b+ instance Eq (JsonRepr 'SchemaNull) where ReprNull == ReprNull = True @@ -397,6 +452,10 @@ instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where ReprOptional a == ReprOptional b = a == b +instance Eq (Union JsonRepr (h ': tl))+ => Eq (JsonRepr ('SchemaUnion (h ': tl))) where+ ReprUnion a == ReprUnion b = a == b+ instance Ord (Rec FieldRepr fs) => Ord (JsonRepr ('SchemaObject fs)) where ReprObject a `compare` ReprObject b = a `compare` b @@ -406,6 +465,9 @@ instance Ord (JsonRepr ('SchemaNumber cs)) where ReprNumber a `compare` ReprNumber b = a `compare` b +instance Ord (JsonRepr 'SchemaBoolean) where+ ReprBoolean a `compare` ReprBoolean b = a `compare` b+ instance Ord (JsonRepr 'SchemaNull) where compare _ _ = EQ @@ -414,6 +476,10 @@ instance Ord (JsonRepr s) => Ord (JsonRepr ('SchemaOptional s)) where ReprOptional a `compare` ReprOptional b = a `compare` b++instance Ord (Union JsonRepr (h ': tl))+ => Ord (JsonRepr ('SchemaUnion (h ': tl))) where+ ReprUnion a `compare` ReprUnion b = a `compare` b instance IsList (JsonRepr ('SchemaArray cs s)) where type Item (JsonRepr ('SchemaArray cs s)) = JsonRepr s
src/Data/Schematic/Schema.hs-boot view
@@ -46,9 +46,17 @@ data ArrayConstraint = AEq Nat+ | AGt Nat+ | AGe Nat+ | ALt Nat+ | ALe Nat data DemotedArrayConstraint = DAEq Integer+ | DAGt Integer+ | DAGe Integer+ | DALt Integer+ | DALe Integer data Schema = SchemaText [TextConstraint]
src/Data/Schematic/Validation.hs view
@@ -58,42 +58,42 @@ let nlen = withKnownNat n $ natVal n predicate = nlen == (fromIntegral $ T.length t)- errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)+ errMsg = "length should be == " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn STLt n -> do let nlen = withKnownNat n $ natVal n predicate = nlen > (fromIntegral $ T.length t)- errMsg = "length of " <> path <> " should be < " <> T.pack (show nlen)+ errMsg = "length should be < " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn STLe n -> do let nlen = withKnownNat n $ natVal n predicate = nlen >= (fromIntegral $ T.length t)- errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)+ errMsg = "length should be <= " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn STGt n -> do let nlen = withKnownNat n $ natVal n predicate = nlen < (fromIntegral $ T.length t)- errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)+ errMsg = "length should be > " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn STGe n -> do let nlen = withKnownNat n $ natVal n predicate = nlen <= (fromIntegral $ T.length t)- errMsg = "length of " <> path <> " should be >= " <> T.pack (show nlen)+ errMsg = "length should be >= " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn STRegex r -> do let regex = withKnownSymbol r $ fromSing r predicate = matchTest (makeRegex (T.unpack regex) :: Regex) (T.unpack t)- errMsg = path <> " must match " <> regex+ errMsg = "must match " <> regex warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn STEnum ss -> do@@ -101,7 +101,7 @@ matching :: Sing (s :: [Symbol]) -> Bool matching SNil = False matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs- errMsg = path <> " must be one of " <> T.pack (show (fromSing ss))+ errMsg = "must be one of " <> T.pack (show (fromSing ss)) warn = vWarning $ mmSingleton path (pure errMsg) unless (matching ss) warn @@ -115,35 +115,35 @@ let nlen = withKnownNat n $ natVal n predicate = fromIntegral nlen == num- errMsg = path <> " should be == " <> T.pack (show nlen)+ errMsg = "should be == " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn SNGt n -> do let nlen = withKnownNat n $ natVal n predicate = num > fromIntegral nlen- errMsg = path <> " should be > " <> T.pack (show nlen)+ errMsg = "should be > " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn SNGe n -> do let nlen = withKnownNat n $ natVal n predicate = num >= fromIntegral nlen- errMsg = path <> " should be >= " <> T.pack (show nlen)+ errMsg = "should be >= " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn SNLt n -> do let nlen = withKnownNat n $ natVal n predicate = num < fromIntegral nlen- errMsg = path <> " should be < " <> T.pack (show nlen)+ errMsg = "should be < " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn SNLe n -> do let nlen = withKnownNat n $ natVal n predicate = num <= fromIntegral nlen- errMsg = path <> " should be <= " <> T.pack (show nlen)+ errMsg = "should be <= " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn @@ -157,7 +157,35 @@ let nlen = withKnownNat n $ natVal n predicate = nlen == fromIntegral (V.length v)- errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)+ errMsg = "length should be == " <> T.pack (show nlen)+ warn = vWarning $ mmSingleton path (pure errMsg)+ unless predicate warn+ SAGt n -> do+ let+ nlen = withKnownNat n $ natVal n+ predicate = fromIntegral (V.length v) > nlen+ errMsg = "length should be > " <> T.pack (show nlen)+ warn = vWarning $ mmSingleton path (pure errMsg)+ unless predicate warn+ SAGe n -> do+ let+ nlen = withKnownNat n $ natVal n+ predicate = fromIntegral (V.length v) >= nlen+ errMsg = "length should be >= " <> T.pack (show nlen)+ warn = vWarning $ mmSingleton path (pure errMsg)+ unless predicate warn+ SALt n -> do+ let+ nlen = withKnownNat n $ natVal n+ predicate = fromIntegral (V.length v) < nlen+ errMsg = "length should be < " <> T.pack (show nlen)+ warn = vWarning $ mmSingleton path (pure errMsg)+ unless predicate warn+ SALe n -> do+ let+ nlen = withKnownNat n $ natVal n+ predicate = fromIntegral (V.length v) <= nlen+ errMsg = "length should be <= " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn
test/JsonSchemaSpec.hs view
@@ -10,6 +10,7 @@ import Data.Aeson as J import Data.Maybe import Data.Proxy+import Data.ByteString.Lazy as B import Data.Schematic import Data.Vinyl import JSONSchema.Draft4 as D4@@ -31,12 +32,69 @@ :& field @"bar" (pure (ReprText "foo")) :& RNil +type SchemaArrayExample = 'SchemaObject+ '[ '("a1", 'SchemaArray '[ 'AGt 1 ] ('SchemaNumber '[]))+ , '("a2", 'SchemaArray '[ 'AGe 1 ] ('SchemaNumber '[]))+ , '("a3", 'SchemaArray '[ 'ALt 1 ] ('SchemaNumber '[]))+ , '("a4", 'SchemaArray '[ 'ALe 1 ] ('SchemaNumber '[]))+ ]++type SchemaNumberExample = 'SchemaObject+ '[ '("n1", 'SchemaNumber '[ 'NGt 1 ])+ , '("n2", 'SchemaNumber '[ 'NGe 1 ])+ , '("n3", 'SchemaNumber '[ 'NLt 1 ])+ , '("n4", 'SchemaNumber '[ 'NLe 1 ])+ ]++type SchemaTextExample = 'SchemaObject+ '[ '("t1", 'SchemaText '[ 'TGt 1 ])+ , '("t2", 'SchemaText '[ 'TGe 1 ])+ , '("t3", 'SchemaText '[ 'TLt 1 ])+ , '("t4", 'SchemaText '[ 'TLe 1 ])+ ]+ spec :: Spec spec = do it "validates simple schema" $ do let schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaExample)) Nothing fetchHTTPAndValidate schema (toJSON exampleData) >>= \case Left _ -> fail "failed to validate test example"+ Right _ -> pure ()+ it "validates schema with arrays" $ do+ let+ schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaArrayExample)) Nothing+ obj = withRepr @SchemaArrayExample $+ field @"a1" [ReprNumber 13, ReprNumber 13]+ :& field @"a2" [ReprNumber 13]+ :& field @"a3" []+ :& field @"a4" [ReprNumber 13]+ :& RNil+ fetchHTTPAndValidate schema (toJSON obj) >>= \case+ Left e -> fail "failed to validate test example"+ Right _ -> pure ()+ it "validates schema with numbers" $ do+ let+ schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaNumberExample)) Nothing+ obj = withRepr @SchemaNumberExample $+ field @"n1" 1.1+ :& field @"n2" 1+ :& field @"n3" 0.9+ :& field @"n4" 1.0+ :& RNil+ fetchHTTPAndValidate schema (toJSON obj) >>= \case+ Left e -> fail "failed to validate test example"+ Right _ -> pure ()+ it "validates schema with strings" $ do+ let+ schema = D4.SchemaWithURI (fromJust $ toJsonSchema (Proxy @SchemaTextExample)) Nothing+ obj = withRepr @SchemaTextExample $+ field @"t1" "11"+ :& field @"t2" "1"+ :& field @"t3" ""+ :& field @"t4" "1"+ :& RNil+ fetchHTTPAndValidate schema (toJSON obj) >>= \case+ Left e -> fail "failed to validate test example" Right _ -> pure () main :: IO ()