Treat unknown properties as invalid + some new helpers

src/Data/Swagger/Internal/Schema.hs

@@ -588,7 +588,62 @@ genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
   , 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") =>
@@ -618,6 +673,12 @@ genericDeclareNamedSchemaUnrestricted :: forall a proxy. (Generic a, GToSchema (
   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 @@ gdatatypeSchemaName opts _ = case name of
 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 @@ data Proxy3 a b c = Proxy3
 -- $setup
 -- >>> import Data.Swagger
 -- >>> import Data.Aeson (encode)
+-- >>> import Data.Aeson.Types (toJSONKeyText)

src/Data/Swagger/Internal/Schema/Validation.hs

@@ -57,15 +57,29 @@ validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
 -- 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 @@ valid = pure ()
 
 -- | 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,9 +312,13 @@ validateObject o = withSchema $ \sch ->
           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
   check enum_ $ \xs ->

src/Data/Swagger/Schema.hs

@@ -17,8 +17,18 @@ module Data.Swagger.Schema (
   -- * Generic schema encoding
   genericDeclareNamedSchema,
   genericDeclareSchema,
+  genericDeclareNamedSchemaNewtype,
+  genericNameSchema,
+
+  -- ** 'Bounded' 'Integral'
   genericToNamedSchemaBoundedIntegral,
   toSchemaBoundedIntegral,
+
+  -- ** 'Bounded' 'Enum' key mappings
+  declareSchemaBoundedEnumKeyMapping,
+  toSchemaBoundedEnumKeyMapping,
+
+  -- ** Reusing 'ToParamSchema'
   paramSchemaToNamedSchema,
   paramSchemaToSchema,
 

src/Data/Swagger/Schema/Validation.hs

@@ -15,9 +15,16 @@ module Data.Swagger.Schema.Validation (
   -- $maybe
 
   -- * JSON validation
+
+  ValidationError,
+
+  -- ** Using 'ToJSON' and 'ToSchema'
   validateToJSON,
   validateToJSONWithPatternChecker,
-  ValidationError,
+
+  -- ** Using 'Value' and 'Schema'
+  validateJSON,
+  validateJSONWithPatternChecker,
 ) where
 
 import Data.Swagger.Internal.Schema.Validation

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 qualified "unordered-containers" Data.HashSet as HashSet
 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 Data.Word
 import GHC.Generics
 
 import Data.Swagger
+import Data.Swagger.Declare
 
 import Test.Hspec
 import Test.Hspec.QuickCheck
@@ -32,6 +36,11 @@ import Test.QuickCheck
 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,6 +86,14 @@ spec = do
     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 ToSchema Person
 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 ToSchema Color
 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 ToSchema Paint
 instance Arbitrary Paint where
   arbitrary = Paint <$> arbitrary
 
+invalidPaintToJSON :: Paint -> Value
+invalidPaintToJSON = toJSON . color
+
 -- ========================================================================
 -- MyRoseTree (custom datatypeNameModifier)
 -- ========================================================================
@@ -161,6 +193,41 @@ instance Arbitrary Light where
     , 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 ZonedTime where
 
 instance Arbitrary UTCTime where
   arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))
-