diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/schematic.cabal b/schematic.cabal --- a/schematic.cabal +++ b/schematic.cabal @@ -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 diff --git a/src/Data/Schematic/DSL.hs b/src/Data/Schematic/DSL.hs --- a/src/Data/Schematic/DSL.hs +++ b/src/Data/Schematic/DSL.hs @@ -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 diff --git a/src/Data/Schematic/JsonSchema.hs b/src/Data/Schematic/JsonSchema.hs --- a/src/Data/Schematic/JsonSchema.hs +++ b/src/Data/Schematic/JsonSchema.hs @@ -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 diff --git a/src/Data/Schematic/Migration.hs b/src/Data/Schematic/Migration.hs --- a/src/Data/Schematic/Migration.hs +++ b/src/Data/Schematic/Migration.hs @@ -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 diff --git a/src/Data/Schematic/Schema.hs b/src/Data/Schematic/Schema.hs --- a/src/Data/Schematic/Schema.hs +++ b/src/Data/Schematic/Schema.hs @@ -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 diff --git a/src/Data/Schematic/Schema.hs-boot b/src/Data/Schematic/Schema.hs-boot --- a/src/Data/Schematic/Schema.hs-boot +++ b/src/Data/Schematic/Schema.hs-boot @@ -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] diff --git a/src/Data/Schematic/Validation.hs b/src/Data/Schematic/Validation.hs --- a/src/Data/Schematic/Validation.hs +++ b/src/Data/Schematic/Validation.hs @@ -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 diff --git a/test/JsonSchemaSpec.hs b/test/JsonSchemaSpec.hs --- a/test/JsonSchemaSpec.hs +++ b/test/JsonSchemaSpec.hs @@ -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 ()