packages feed

swagger2 2.1.6 → 2.2

raw patch · 8 files changed

+238/−15 lines, 8 filesdep ~aesondep ~bytestringdep ~containers

Dependency ranges changed: aeson, bytestring, containers, hashable, http-media, lens, mtl, network, scientific, template-haskell, text, time, transformers, transformers-compat, unordered-containers, vector

Files

CHANGELOG.md view
@@ -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 -----
src/Data/Swagger/Internal/Schema.hs view
@@ -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)
src/Data/Swagger/Internal/Schema/Validation.hs view
@@ -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
src/Data/Swagger/Schema.hs view
@@ -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,
src/Data/Swagger/Schema/Validation.hs view
@@ -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
swagger2.cabal view
@@ -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
test/Data/Swagger/Schema/ValidationSpec.hs view
@@ -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))-
test/Data/Swagger/SchemaSpec.hs view
@@ -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" }+    }+}+|]+