diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +2.2 +--- + +* Treat unknown properties as validation errors in `validateToJSON`; +* Add `validateJSON` and `validateJSONWithPatternChecker` to validate JSON `Value` against `Schema` without classes; +* Add more `Schema` helpers: + * `genericNameSchema` — to give a custom schema `Generic`-based name; + * `genericDeclareNamedSchemaNewtype` — to derive `NamedSchema` for `newtype`s; + * `declareSchemaBoundedEnumKeyMapping` — to derive more specific `Schema` for maps with `Bounded` `Enum` keys; +* Add a few tests with invalid `Schema`. + 2.1.6 ----- diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -588,8 +588,63 @@ , Generic a, Rep a ~ D1 d f, Datatype d) => SchemaOptions -> proxy a -> NamedSchema genericToNamedSchemaBoundedIntegral opts proxy - = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy) + = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy) +-- | Declare a named schema for a @newtype@ wrapper. +genericDeclareNamedSchemaNewtype :: forall proxy a d c s i inner. + (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner)))) + => SchemaOptions -- ^ How to derive the name. + -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type. + -> proxy a + -> Declare (Definitions Schema) NamedSchema +genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner) + +-- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys. +-- This makes a much more useful schema when there aren't many options for key values. +-- +-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic) +-- >>> instance ToJSON ButtonState +-- >>> instance ToSchema ButtonState +-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show) +-- >>> type ImageUrl = T.Text +-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl)) +-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}" +-- +-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'. +-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used. +declareSchemaBoundedEnumKeyMapping :: forall map key value proxy. + (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value) + => proxy (map key value) -> Declare (Definitions Schema) Schema +declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of + ToJSONKeyText keyToText _ -> objectSchema keyToText + ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)]) + where + objectSchema keyToText = do + valueRef <- declareSchemaRef (Proxy :: Proxy value) + let allKeys = [minBound..maxBound :: key] + mkPair k = (keyToText k, valueRef) + return $ mempty + & type_ .~ SwaggerObject + & properties .~ InsOrdHashMap.fromList (map mkPair allKeys) + +-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys. +-- This makes a much more useful schema when there aren't many options for key values. +-- +-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic) +-- >>> instance ToJSON ButtonState +-- >>> instance ToSchema ButtonState +-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show) +-- >>> type ImageUrl = T.Text +-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl)) +-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}" +-- +-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'. +-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used. +toSchemaBoundedEnumKeyMapping :: forall map key value proxy. + (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value) + => proxy (map key value) -> Schema +toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping + -- | A configurable generic @'Schema'@ creator. genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema @@ -618,6 +673,12 @@ SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty +-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'. +genericNameSchema :: forall a d f proxy. + (Generic a, Rep a ~ D1 d f, Datatype d) + => SchemaOptions -> proxy a -> Schema -> NamedSchema +genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) + gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text gdatatypeSchemaName opts _ = case name of (c:_) | isAlpha c && isUpper c -> Just (T.pack name) @@ -629,7 +690,7 @@ paramSchemaToNamedSchema :: forall a d f proxy. (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) => SchemaOptions -> proxy a -> NamedSchema -paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy) +paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy) -- | Lift a plain @'ParamSchema'@ into a model @'Schema'@. paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema @@ -797,3 +858,4 @@ -- $setup -- >>> import Data.Swagger -- >>> import Data.Aeson (encode) +-- >>> import Data.Aeson.Types (toJSONKeyText) diff --git a/src/Data/Swagger/Internal/Schema/Validation.hs b/src/Data/Swagger/Internal/Schema/Validation.hs --- a/src/Data/Swagger/Internal/Schema/Validation.hs +++ b/src/Data/Swagger/Internal/Schema/Validation.hs @@ -57,15 +57,29 @@ -- This can be used with QuickCheck to ensure those instances are coherent. -- -- For validation without patterns see @'validateToJSON'@. -validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => - (Pattern -> Text -> Bool) -> a -> [ValidationError] -validateToJSONWithPatternChecker checker x = +validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError] +validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON + where + (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty + +-- | Validate JSON @'Value'@ against Swagger @'Schema'@. +-- +-- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == [] +-- +-- /NOTE:/ @'validateJSON'@ does not perform string pattern validation. +-- See @'validateJSONWithPatternChecker'@. +validateJSON :: Definitions Schema -> Schema -> Value -> [ValidationError] +validateJSON = validateJSONWithPatternChecker (\_pattern _str -> True) + +-- | Validate JSON @'Value'@ agains Swagger @'ToSchema'@ for a given value and pattern checker. +-- +-- For validation without patterns see @'validateJSON'@. +validateJSONWithPatternChecker :: (Pattern -> Text -> Bool) -> Definitions Schema -> Schema -> Value -> [ValidationError] +validateJSONWithPatternChecker checker defs sch js = case runValidation (validateWithSchema js) cfg sch of Failed xs -> xs Passed _ -> mempty where - (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty - js = toJSON x cfg = defaultConfig { configPatternChecker = checker , configDefinitions = defs } @@ -158,12 +172,18 @@ -- | Validate schema's property given a lens into that property -- and property checker. -check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s () -check l g = withSchema $ \sch -> +checkMissing :: Validation s () -> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s () +checkMissing missing l g = withSchema $ \sch -> case sch ^. l of - Nothing -> valid + Nothing -> missing Just x -> g x +-- | Validate schema's property given a lens into that property +-- and property checker. +-- If property is missing in schema, consider it valid. +check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s () +check = checkMissing valid + -- | Validate same value with different schema. sub :: t -> Validation t a -> Validation s a sub = lmap . const @@ -292,8 +312,12 @@ Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property _ -> case InsOrdHashMap.lookup k (sch ^. properties) of - Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v + Nothing -> checkMissing (unknownProperty k) additionalProperties $ \s -> validateWithSchemaRef s v Just s -> validateWithSchemaRef s v + + unknownProperty :: Text -> Validation s a + unknownProperty name = invalid $ + "property " <> show name <> " is found in JSON value, but it is not mentioned in Swagger schema" validateEnum :: Value -> Validation (ParamSchema t) () validateEnum value = do diff --git a/src/Data/Swagger/Schema.hs b/src/Data/Swagger/Schema.hs --- a/src/Data/Swagger/Schema.hs +++ b/src/Data/Swagger/Schema.hs @@ -17,8 +17,18 @@ -- * Generic schema encoding genericDeclareNamedSchema, genericDeclareSchema, + genericDeclareNamedSchemaNewtype, + genericNameSchema, + + -- ** 'Bounded' 'Integral' genericToNamedSchemaBoundedIntegral, toSchemaBoundedIntegral, + + -- ** 'Bounded' 'Enum' key mappings + declareSchemaBoundedEnumKeyMapping, + toSchemaBoundedEnumKeyMapping, + + -- ** Reusing 'ToParamSchema' paramSchemaToNamedSchema, paramSchemaToSchema, diff --git a/src/Data/Swagger/Schema/Validation.hs b/src/Data/Swagger/Schema/Validation.hs --- a/src/Data/Swagger/Schema/Validation.hs +++ b/src/Data/Swagger/Schema/Validation.hs @@ -15,9 +15,16 @@ -- $maybe -- * JSON validation + + ValidationError, + + -- ** Using 'ToJSON' and 'ToSchema' validateToJSON, validateToJSONWithPatternChecker, - ValidationError, + + -- ** Using 'Value' and 'Schema' + validateJSON, + validateJSONWithPatternChecker, ) where import Data.Swagger.Internal.Schema.Validation diff --git a/swagger2.cabal b/swagger2.cabal --- a/swagger2.cabal +++ b/swagger2.cabal @@ -1,5 +1,5 @@ name: swagger2 -version: 2.1.6 +version: 2.2 synopsis: Swagger 2.0 data model description: This library is inteded to be used for decoding and encoding Swagger 2.0 API diff --git a/test/Data/Swagger/Schema/ValidationSpec.hs b/test/Data/Swagger/Schema/ValidationSpec.hs --- a/test/Data/Swagger/Schema/ValidationSpec.hs +++ b/test/Data/Swagger/Schema/ValidationSpec.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Swagger.Schema.ValidationSpec where @@ -15,6 +17,7 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Map (Map) +import Data.Monoid (mempty) import Data.Proxy import Data.Time import qualified Data.Text as T @@ -24,6 +27,7 @@ import GHC.Generics import Data.Swagger +import Data.Swagger.Declare import Test.Hspec import Test.Hspec.QuickCheck @@ -32,6 +36,11 @@ shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool shouldValidate _ x = validateToJSON x == [] +shouldNotValidate :: forall a. ToSchema a => (a -> Value) -> a -> Bool +shouldNotValidate f = not . null . validateJSON defs sch . f + where + (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty + spec :: Spec spec = do describe "Validation" $ do @@ -77,7 +86,15 @@ prop "Paint" $ shouldValidate (Proxy :: Proxy Paint) prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree) prop "Light" $ shouldValidate (Proxy :: Proxy Light) + prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages) + describe "invalid cases" $ do + prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON + prop "invalidColorToJSON" $ shouldNotValidate invalidColorToJSON + prop "invalidPaintToJSON" $ shouldNotValidate invalidPaintToJSON + prop "invalidLightToJSON" $ shouldNotValidate invalidLightToJSON + prop "invalidButtonImagesToJSON" $ shouldNotValidate invalidButtonImagesToJSON + main :: IO () main = hspec spec @@ -96,6 +113,13 @@ instance Arbitrary Person where arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary +invalidPersonToJSON :: Person -> Value +invalidPersonToJSON Person{..} = object + [ T.pack "personName" .= toJSON name + , T.pack "personPhone" .= toJSON phone + , T.pack "personEmail" .= toJSON email + ] + -- ======================================================================== -- Color (enum) -- ======================================================================== @@ -107,6 +131,11 @@ instance Arbitrary Color where arbitrary = arbitraryBoundedEnum +invalidColorToJSON :: Color -> Value +invalidColorToJSON Red = toJSON "red" +invalidColorToJSON Green = toJSON "green" +invalidColorToJSON Blue = toJSON "blue" + -- ======================================================================== -- Paint (record with bounded enum property) -- ======================================================================== @@ -120,6 +149,9 @@ instance Arbitrary Paint where arbitrary = Paint <$> arbitrary +invalidPaintToJSON :: Paint -> Value +invalidPaintToJSON = toJSON . color + -- ======================================================================== -- MyRoseTree (custom datatypeNameModifier) -- ======================================================================== @@ -161,6 +193,41 @@ , LightColor <$> arbitrary ] +invalidLightToJSON :: Light -> Value +invalidLightToJSON = genericToJSON defaultOptions + +-- ======================================================================== +-- ButtonImages (bounded enum key mapping) +-- ======================================================================== + +data ButtonState = Neutral | Focus | Active | Hover | Disabled + deriving (Show, Eq, Ord, Bounded, Enum, Generic) + +instance ToJSON ButtonState +instance ToSchema ButtonState +instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show) + +instance Arbitrary ButtonState where + arbitrary = arbitraryBoundedEnum + +type ImageUrl = T.Text + +newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl } + deriving (Show, Generic) + +instance ToJSON ButtonImages where + toJSON = toJSON . getButtonImages + +instance ToSchema ButtonImages where + declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions + declareSchemaBoundedEnumKeyMapping + +invalidButtonImagesToJSON :: ButtonImages -> Value +invalidButtonImagesToJSON = genericToJSON defaultOptions + +instance Arbitrary ButtonImages where + arbitrary = ButtonImages <$> arbitrary + -- Arbitrary instances for common types instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where @@ -193,4 +260,3 @@ instance Arbitrary UTCTime where arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400)) - diff --git a/test/Data/Swagger/SchemaSpec.hs b/test/Data/Swagger/SchemaSpec.hs --- a/test/Data/Swagger/SchemaSpec.hs +++ b/test/Data/Swagger/SchemaSpec.hs @@ -8,12 +8,14 @@ import Prelude.Compat import Control.Lens ((^.)) -import Data.Aeson (Value) +import Data.Aeson (Value, ToJSON(..), ToJSONKey(..)) +import Data.Aeson.Types (toJSONKeyText) import Data.Aeson.QQ import Data.Char import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Proxy import Data.Set (Set) +import Data.Map (Map) import qualified Data.Text as Text import GHC.Generics @@ -101,6 +103,8 @@ context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON + describe "Bounded Enum key mapping" $ do + context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON main :: IO () main = hspec spec @@ -647,3 +651,42 @@ newtype ResourceId = ResourceId Id deriving (Generic) instance ToSchema ResourceId + +-- ======================================================================== +-- ButtonImages (bounded enum key mapping) +-- ======================================================================== + +data ButtonState = Neutral | Focus | Active | Hover | Disabled + deriving (Show, Bounded, Enum, Generic) + +instance ToJSON ButtonState +instance ToSchema ButtonState +instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show) + +type ImageUrl = Text.Text + +newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl } + deriving (Generic) + +instance ToJSON ButtonImages where + toJSON = toJSON . getButtonImages + +instance ToSchema ButtonImages where + declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions + declareSchemaBoundedEnumKeyMapping + +buttonImagesSchemaJSON :: Value +buttonImagesSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "Neutral": { "type": "string" }, + "Focus": { "type": "string" }, + "Active": { "type": "string" }, + "Hover": { "type": "string" }, + "Disabled": { "type": "string" } + } +} +|] +