e2d1f94 · typeable/swagger2

git.iko.soy/typeable/swagger2

on master help sign in

Merge pull request #126 from GetShopTV/validate-unknown-properties

e2d1f94Nickolay Kudasov9 years ago

src/Data/Swagger/Internal/Schema.hs+64−2

compare with master

unifiedsplit

@@ -588,7 +588,62 @@ genericToNamedSchemaBoundedIntegral :: forall a d f proxy.

588 , Generic a, Rep a ~ D1 d f, Datatype d)

589 => SchemaOptions -> proxy a -> NamedSchema

590genericToNamedSchemaBoundedIntegral opts proxy

591− = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)

591+ = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)

592+

593+-- | Declare a named schema for a @newtype@ wrapper.

594+genericDeclareNamedSchemaNewtype :: forall proxy a d c s i inner.

595+ (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner))))

596+ => SchemaOptions -- ^ How to derive the name.

597+ -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type.

598+ -> proxy a

599+ -> Declare (Definitions Schema) NamedSchema

600+genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)

601+

602+-- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys.

603+-- This makes a much more useful schema when there aren't many options for key values.

604+--

605+-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)

606+-- >>> instance ToJSON ButtonState

607+-- >>> instance ToSchema ButtonState

608+-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)

609+-- >>> type ImageUrl = T.Text

610+-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))

611+-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"

612+--

613+-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.

614+-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.

615+declareSchemaBoundedEnumKeyMapping :: forall map key value proxy.

616+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)

617+ => proxy (map key value) -> Declare (Definitions Schema) Schema

618+declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of

619+ ToJSONKeyText keyToText _ -> objectSchema keyToText

620+ ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])

621+ where

622+ objectSchema keyToText = do

623+ valueRef <- declareSchemaRef (Proxy :: Proxy value)

624+ let allKeys = [minBound..maxBound :: key]

625+ mkPair k = (keyToText k, valueRef)

626+ return $ mempty

627+ & type_ .~ SwaggerObject

628+ & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)

629+

630+-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.

631+-- This makes a much more useful schema when there aren't many options for key values.

632+--

633+-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)

634+-- >>> instance ToJSON ButtonState

635+-- >>> instance ToSchema ButtonState

636+-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)

637+-- >>> type ImageUrl = T.Text

638+-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))

639+-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"

640+--

641+-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.

642+-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.

643+toSchemaBoundedEnumKeyMapping :: forall map key value proxy.

644+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)

645+ => proxy (map key value) -> Schema

646+toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping

592

647

593-- | A configurable generic @'Schema'@ creator.

648-- | A configurable generic @'Schema'@ creator.

594genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>

649genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>

@@ -618,6 +673,12 @@ genericDeclareNamedSchemaUnrestricted :: forall a proxy. (Generic a, GToSchema (

618 SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema

673 SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema

619genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty

674genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty

620

675

676+-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.

677+genericNameSchema :: forall a d f proxy.

678+ (Generic a, Rep a ~ D1 d f, Datatype d)

679+ => SchemaOptions -> proxy a -> Schema -> NamedSchema

680+genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))

681+

621gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text

682gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text

622gdatatypeSchemaName opts _ = case name of

683gdatatypeSchemaName opts _ = case name of

623 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)

684 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)

@@ -629,7 +690,7 @@ gdatatypeSchemaName opts _ = case name of

629paramSchemaToNamedSchema :: forall a d f proxy.

690paramSchemaToNamedSchema :: forall a d f proxy.

630 (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)

691 (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)

631 => SchemaOptions -> proxy a -> NamedSchema

692 => SchemaOptions -> proxy a -> NamedSchema

632−paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)

693+paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)

633

694

634-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.

695-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.

635paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema

696paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema

@@ -797,3 +858,4 @@ data Proxy3 a b c = Proxy3

797-- $setup

858-- $setup

798-- >>> import Data.Swagger

859-- >>> import Data.Swagger

799-- >>> import Data.Aeson (encode)

860-- >>> import Data.Aeson (encode)

861+-- >>> import Data.Aeson.Types (toJSONKeyText)

src/Data/Swagger/Internal/Schema/Validation.hs+33−9

@@ -57,15 +57,29 @@ validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)

57-- This can be used with QuickCheck to ensure those instances are coherent.

58--

59-- For validation without patterns see @'validateToJSON'@.

60−validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) =>

60+validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError]

61− (Pattern -> Text -> Bool) -> a -> [ValidationError]

61+validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON

62−validateToJSONWithPatternChecker checker x =

62+ where

63+ (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

64+

65+-- | Validate JSON @'Value'@ against Swagger @'Schema'@.

66+--

67+-- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []

68+--

69+-- /NOTE:/ @'validateJSON'@ does not perform string pattern validation.

70+-- See @'validateJSONWithPatternChecker'@.

71+validateJSON :: Definitions Schema -> Schema -> Value -> [ValidationError]

72+validateJSON = validateJSONWithPatternChecker (\_pattern _str -> True)

73+

74+-- | Validate JSON @'Value'@ agains Swagger @'ToSchema'@ for a given value and pattern checker.

75+--

76+-- For validation without patterns see @'validateJSON'@.

77+validateJSONWithPatternChecker :: (Pattern -> Text -> Bool) -> Definitions Schema -> Schema -> Value -> [ValidationError]

78+validateJSONWithPatternChecker checker defs sch js =

63 case runValidation (validateWithSchema js) cfg sch of

79 case runValidation (validateWithSchema js) cfg sch of

64 Failed xs -> xs

80 Failed xs -> xs

65 Passed _ -> mempty

81 Passed _ -> mempty

66 where

82 where

67− (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

68− js = toJSON x

69 cfg = defaultConfig

83 cfg = defaultConfig

70 { configPatternChecker = checker

84 { configPatternChecker = checker

71 , configDefinitions = defs }

85 , configDefinitions = defs }

@@ -158,12 +172,18 @@ valid = pure ()

158

172

159-- | Validate schema's property given a lens into that property

173-- | Validate schema's property given a lens into that property

160-- and property checker.

174-- and property checker.

161−check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

175+checkMissing :: Validation s () -> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

162−check l g = withSchema $ \sch ->

176+checkMissing missing l g = withSchema $ \sch ->

163 case sch ^. l of

177 case sch ^. l of

164− Nothing -> valid

178+ Nothing -> missing

165 Just x -> g x

179 Just x -> g x

166

180

181+-- | Validate schema's property given a lens into that property

182+-- and property checker.

183+-- If property is missing in schema, consider it valid.

184+check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

185+check = checkMissing valid

186+

167-- | Validate same value with different schema.

187-- | Validate same value with different schema.

168sub :: t -> Validation t a -> Validation s a

188sub :: t -> Validation t a -> Validation s a

169sub = lmap . const

189sub = lmap . const

@@ -292,9 +312,13 @@ validateObject o = withSchema $ \sch ->

292 Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property

312 Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property

293 _ ->

313 _ ->

294 case InsOrdHashMap.lookup k (sch ^. properties) of

314 case InsOrdHashMap.lookup k (sch ^. properties) of

295− Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v

315+ Nothing -> checkMissing (unknownProperty k) additionalProperties $ \s -> validateWithSchemaRef s v

296 Just s -> validateWithSchemaRef s v

316 Just s -> validateWithSchemaRef s v

297

317

318+ unknownProperty :: Text -> Validation s a

319+ unknownProperty name = invalid $

320+ "property " <> show name <> " is found in JSON value, but it is not mentioned in Swagger schema"

321+

298validateEnum :: Value -> Validation (ParamSchema t) ()

322validateEnum :: Value -> Validation (ParamSchema t) ()

299validateEnum value = do

323validateEnum value = do

300 check enum_ $ \xs ->

324 check enum_ $ \xs ->

src/Data/Swagger/Schema.hs+10

@@ -17,8 +17,18 @@ module Data.Swagger.Schema (

17 -- * Generic schema encoding

18 genericDeclareNamedSchema,

19 genericDeclareSchema,

20+ genericDeclareNamedSchemaNewtype,

21+ genericNameSchema,

22+

23+ -- ** 'Bounded' 'Integral'

20 genericToNamedSchemaBoundedIntegral,

24 genericToNamedSchemaBoundedIntegral,

21 toSchemaBoundedIntegral,

25 toSchemaBoundedIntegral,

26+

27+ -- ** 'Bounded' 'Enum' key mappings

28+ declareSchemaBoundedEnumKeyMapping,

29+ toSchemaBoundedEnumKeyMapping,

30+

31+ -- ** Reusing 'ToParamSchema'

22 paramSchemaToNamedSchema,

32 paramSchemaToNamedSchema,

23 paramSchemaToSchema,

33 paramSchemaToSchema,

src/Data/Swagger/Schema/Validation.hs+8−1

@@ -15,9 +15,16 @@ module Data.Swagger.Schema.Validation (

15 -- $maybe

17 -- * JSON validation

18+

19+ ValidationError,

20+

21+ -- ** Using 'ToJSON' and 'ToSchema'

18 validateToJSON,

22 validateToJSON,

19 validateToJSONWithPatternChecker,

23 validateToJSONWithPatternChecker,

20− ValidationError,

24+

25+ -- ** Using 'Value' and 'Schema'

26+ validateJSON,

27+ validateJSONWithPatternChecker,

21) where

28) where

23import Data.Swagger.Internal.Schema.Validation

30import Data.Swagger.Internal.Schema.Validation

test/Data/Swagger/Schema/ValidationSpec.hs+67−1

@@ -1,6 +1,8 @@

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE PackageImports #-}

4+{-# LANGUAGE RecordWildCards #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

4{-# OPTIONS_GHC -fno-warn-orphans #-}

6{-# OPTIONS_GHC -fno-warn-orphans #-}

5module Data.Swagger.Schema.ValidationSpec where

7module Data.Swagger.Schema.ValidationSpec where

@@ -15,6 +17,7 @@ import qualified "unordered-containers" Data.HashSet as HashSet

15import Data.HashMap.Strict (HashMap)

17import Data.HashMap.Strict (HashMap)

16import qualified Data.HashMap.Strict as HashMap

18import qualified Data.HashMap.Strict as HashMap

17import Data.Map (Map)

19import Data.Map (Map)

20+import Data.Monoid (mempty)

18import Data.Proxy

21import Data.Proxy

19import Data.Time

22import Data.Time

20import qualified Data.Text as T

23import qualified Data.Text as T

@@ -24,6 +27,7 @@ import Data.Word

24import GHC.Generics

27import GHC.Generics

26import Data.Swagger

29import Data.Swagger

30+import Data.Swagger.Declare

28import Test.Hspec

32import Test.Hspec

29import Test.Hspec.QuickCheck

33import Test.Hspec.QuickCheck

@@ -32,6 +36,11 @@ import Test.QuickCheck

32shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool

36shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool

33shouldValidate _ x = validateToJSON x == []

37shouldValidate _ x = validateToJSON x == []

39+shouldNotValidate :: forall a. ToSchema a => (a -> Value) -> a -> Bool

40+shouldNotValidate f = not . null . validateJSON defs sch . f

41+ where

42+ (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

43+

35spec :: Spec

44spec :: Spec

36spec = do

45spec = do

37 describe "Validation" $ do

46 describe "Validation" $ do

@@ -77,6 +86,14 @@ spec = do

77 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)

86 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)

78 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)

87 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)

79 prop "Light" $ shouldValidate (Proxy :: Proxy Light)

88 prop "Light" $ shouldValidate (Proxy :: Proxy Light)

89+ prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)

90+

91+ describe "invalid cases" $ do

92+ prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON

93+ prop "invalidColorToJSON" $ shouldNotValidate invalidColorToJSON

94+ prop "invalidPaintToJSON" $ shouldNotValidate invalidPaintToJSON

95+ prop "invalidLightToJSON" $ shouldNotValidate invalidLightToJSON

96+ prop "invalidButtonImagesToJSON" $ shouldNotValidate invalidButtonImagesToJSON

81main :: IO ()

98main :: IO ()

82main = hspec spec

99main = hspec spec

@@ -96,6 +113,13 @@ instance ToSchema Person

96instance Arbitrary Person where

113instance Arbitrary Person where

97 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary

114 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary

115

116+invalidPersonToJSON :: Person -> Value

117+invalidPersonToJSON Person{..} = object

118+ [ T.pack "personName" .= toJSON name

119+ , T.pack "personPhone" .= toJSON phone

120+ , T.pack "personEmail" .= toJSON email

121+ ]

122+

99-- ========================================================================

123-- ========================================================================

100-- Color (enum)

124-- Color (enum)

101-- ========================================================================

125-- ========================================================================

@@ -107,6 +131,11 @@ instance ToSchema Color

107instance Arbitrary Color where

131instance Arbitrary Color where

108 arbitrary = arbitraryBoundedEnum

132 arbitrary = arbitraryBoundedEnum

109

133

134+invalidColorToJSON :: Color -> Value

135+invalidColorToJSON Red = toJSON "red"

136+invalidColorToJSON Green = toJSON "green"

137+invalidColorToJSON Blue = toJSON "blue"

138+

110-- ========================================================================

139-- ========================================================================

111-- Paint (record with bounded enum property)

140-- Paint (record with bounded enum property)

112-- ========================================================================

141-- ========================================================================

@@ -120,6 +149,9 @@ instance ToSchema Paint

120instance Arbitrary Paint where

149instance Arbitrary Paint where

121 arbitrary = Paint <$> arbitrary

150 arbitrary = Paint <$> arbitrary

122

151

152+invalidPaintToJSON :: Paint -> Value

153+invalidPaintToJSON = toJSON . color

154+

123-- ========================================================================

155-- ========================================================================

124-- MyRoseTree (custom datatypeNameModifier)

156-- MyRoseTree (custom datatypeNameModifier)

125-- ========================================================================

157-- ========================================================================

@@ -161,6 +193,41 @@ instance Arbitrary Light where

161 , LightColor <$> arbitrary

193 , LightColor <$> arbitrary

162 ]

194 ]

163

195

196+invalidLightToJSON :: Light -> Value

197+invalidLightToJSON = genericToJSON defaultOptions

198+

199+-- ========================================================================

200+-- ButtonImages (bounded enum key mapping)

201+-- ========================================================================

202+

203+data ButtonState = Neutral | Focus | Active | Hover | Disabled

204+ deriving (Show, Eq, Ord, Bounded, Enum, Generic)

205+

206+instance ToJSON ButtonState

207+instance ToSchema ButtonState

208+instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)

209+

210+instance Arbitrary ButtonState where

211+ arbitrary = arbitraryBoundedEnum

212+

213+type ImageUrl = T.Text

214+

215+newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }

216+ deriving (Show, Generic)

217+

218+instance ToJSON ButtonImages where

219+ toJSON = toJSON . getButtonImages

220+

221+instance ToSchema ButtonImages where

222+ declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions

223+ declareSchemaBoundedEnumKeyMapping

224+

225+invalidButtonImagesToJSON :: ButtonImages -> Value

226+invalidButtonImagesToJSON = genericToJSON defaultOptions

227+

228+instance Arbitrary ButtonImages where

229+ arbitrary = ButtonImages <$> arbitrary

230+

164-- Arbitrary instances for common types

231-- Arbitrary instances for common types

165

232

166instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where

233instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where

@@ -193,4 +260,3 @@ instance Arbitrary ZonedTime where

193

260

194instance Arbitrary UTCTime where

261instance Arbitrary UTCTime where

195 arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))

262 arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))

196−

test/Data/Swagger/SchemaSpec.hs+44−1

@@ -8,12 +8,14 @@ import Prelude ()

8import Prelude.Compat

10import Control.Lens ((^.))

11−import Data.Aeson (Value)

11+import Data.Aeson (Value, ToJSON(..), ToJSONKey(..))

12+import Data.Aeson.Types (toJSONKeyText)

12import Data.Aeson.QQ

13import Data.Aeson.QQ

13import Data.Char

14import Data.Char

14import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

15import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

15import Data.Proxy

16import Data.Proxy

16import Data.Set (Set)

17import Data.Set (Set)

18+import Data.Map (Map)

17import qualified Data.Text as Text

19import qualified Data.Text as Text

18import GHC.Generics

20import GHC.Generics

@@ -101,6 +103,8 @@ spec = do

101 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON

103 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON

102 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON

104 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON

103 context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON

105 context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON

106+ describe "Bounded Enum key mapping" $ do

107+ context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON

104

108

105main :: IO ()

109main :: IO ()

106main = hspec spec

110main = hspec spec

@@ -647,3 +651,42 @@ instance ToSchema Id

647

651

648newtype ResourceId = ResourceId Id deriving (Generic)

652newtype ResourceId = ResourceId Id deriving (Generic)

649instance ToSchema ResourceId

653instance ToSchema ResourceId

654+

655+-- ========================================================================

656+-- ButtonImages (bounded enum key mapping)

657+-- ========================================================================

658+

659+data ButtonState = Neutral | Focus | Active | Hover | Disabled

660+ deriving (Show, Bounded, Enum, Generic)

661+

662+instance ToJSON ButtonState

663+instance ToSchema ButtonState

664+instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)

665+

666+type ImageUrl = Text.Text

667+

668+newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }

669+ deriving (Generic)

670+

671+instance ToJSON ButtonImages where

672+ toJSON = toJSON . getButtonImages

673+

674+instance ToSchema ButtonImages where

675+ declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions

676+ declareSchemaBoundedEnumKeyMapping

677+

678+buttonImagesSchemaJSON :: Value

679+buttonImagesSchemaJSON = [aesonQQ|

680+{

681+ "type": "object",

682+ "properties":

683+ {

684+ "Neutral": { "type": "string" },

685+ "Focus": { "type": "string" },

686+ "Active": { "type": "string" },

687+ "Hover": { "type": "string" },

688+ "Disabled": { "type": "string" }

689+ }

690+}

691+|]

692+