git.iko.soy/typeable/openapi3
on 047caac help sign in
typeable/openapi3/test/Data/Swagger/SchemaSpec.hs
649 lines 18 kB history raw
1{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE QuasiQuotes #-}
5module Data.Swagger.SchemaSpec where
7import Prelude ()
8import Prelude.Compat
10import Control.Lens ((^.))
11import Data.Aeson (Value)
12import Data.Aeson.QQ
13import Data.Char
14import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
15import Data.Proxy
16import Data.Set (Set)
17import qualified Data.Text as Text
18import GHC.Generics
20import Data.Swagger
21import Data.Swagger.Declare
23import SpecCommon
24import Test.Hspec
26checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
27checkToSchema proxy js = toSchema proxy <=> js
29checkSchemaName :: ToSchema a => Maybe String -> Proxy a -> Spec
30checkSchemaName sname proxy =
31 it ("schema name is " ++ show sname) $
32 schemaName proxy `shouldBe` fmap Text.pack sname
34checkDefs :: ToSchema a => Proxy a -> [String] -> Spec
35checkDefs proxy names =
36 it ("uses these definitions " ++ show names) $
37 InsOrdHashMap.keys defs `shouldBe` map Text.pack names
38 where
39 defs = execDeclare (declareNamedSchema proxy) mempty
41checkProperties :: ToSchema a => Proxy a -> [String] -> Spec
42checkProperties proxy names =
43 it ("has these fields in order " ++ show names) $
44 InsOrdHashMap.keys fields `shouldBe` map Text.pack names
45 where
46 fields = toSchema proxy ^. properties
48checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec
49checkInlinedSchema proxy js = toInlinedSchema proxy <=> js
51checkInlinedSchemas :: ToSchema a => [String] -> Proxy a -> Value -> Spec
52checkInlinedSchemas names proxy js = inlineSchemas (map Text.pack names) defs s <=> js
53 where
54 (defs, s) = runDeclare (declareSchema proxy) mempty
56checkInlinedRecSchema :: ToSchema a => Proxy a -> Value -> Spec
57checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs s <=> js
58 where
59 (defs, s) = runDeclare (declareSchema proxy) mempty
61spec :: Spec
62spec = do
63 describe "Generic ToSchema" $ do
64 context "Unit" $ checkToSchema (Proxy :: Proxy Unit) unitSchemaJSON
65 context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
66 context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
67 context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON
68 context "Point5 (many field record)" $ do
69 checkToSchema (Proxy :: Proxy Point5) point5SchemaJSON
70 checkProperties (Proxy :: Proxy Point5) point5Properties
71 context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
72 context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
73 context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
74 context "UserGroup (set newtype)" $ checkToSchema (Proxy :: Proxy UserGroup) userGroupSchemaJSON
75 context "Unary records" $ do
76 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
77 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
78 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
79 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
80 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
81 context "Sum types" $ do
82 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
83 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
84 context "Light (sum with unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Light) lightSchemaJSON
85 context "Schema name" $ do
86 context "String" $ checkSchemaName Nothing (Proxy :: Proxy String)
87 context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))
88 context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person)
89 context "Shade" $ checkSchemaName (Just "Shade") (Proxy :: Proxy Shade)
90 describe "Generic Definitions" $ do
91 context "Unit" $ checkDefs (Proxy :: Proxy Unit) []
92 context "Paint" $ checkDefs (Proxy :: Proxy Paint) ["Color"]
93 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
94 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
95 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
96 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
97 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
98 describe "Inlining Schemas" $ do
99 context "Paint" $ checkInlinedSchema (Proxy :: Proxy Paint) paintInlinedSchemaJSON
100 context "Character" $ checkInlinedSchema (Proxy :: Proxy Character) characterInlinedSchemaJSON
101 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
102 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
103 context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
105main :: IO ()
106main = hspec spec
108-- ========================================================================
109-- Person (simple record with optional fields)
110-- ========================================================================
111data Person = Person
112 { name :: String
113 , phone :: Integer
114 , email :: Maybe String
115 } deriving (Generic)
117instance ToSchema Person
119personSchemaJSON :: Value
120personSchemaJSON = [aesonQQ|
122 "type": "object",
123 "properties":
124 {
125 "name": { "type": "string" },
126 "phone": { "type": "integer" },
127 "email": { "type": "string" }
128 },
129 "required": ["name", "phone"]
131|]
133-- ========================================================================
134-- ISPair (non-record product data type)
135-- ========================================================================
136data ISPair = ISPair Integer String
137 deriving (Generic)
139instance ToSchema ISPair
141ispairSchemaJSON :: Value
142ispairSchemaJSON = [aesonQQ|
144 "type": "array",
145 "items":
146 [
147 { "type": "integer" },
148 { "type": "string" }
149 ],
150 "minItems": 2,
151 "maxItems": 2
153|]
155-- ========================================================================
156-- Point (record data type with custom fieldLabelModifier)
157-- ========================================================================
159data Point = Point
160 { pointX :: Double
161 , pointY :: Double
162 } deriving (Generic)
164instance ToSchema Point where
165 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
166 { fieldLabelModifier = map toLower . drop (length "point") }
168pointSchemaJSON :: Value
169pointSchemaJSON = [aesonQQ|
171 "type": "object",
172 "properties":
173 {
174 "x": { "type": "number", "format": "double" },
175 "y": { "type": "number", "format": "double" }
176 },
177 "required": ["x", "y"]
179|]
181-- ========================================================================
182-- Point (record data type with multiple fields)
183-- ========================================================================
185data Point5 = Point5
186 { point5X :: Double
187 , point5Y :: Double
188 , point5Z :: Double
189 , point5U :: Double
190 , point5V :: Double -- 5 dimensional!
191 } deriving (Generic)
193instance ToSchema Point5 where
194 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
195 { fieldLabelModifier = map toLower . drop (length "point5") }
197point5SchemaJSON :: Value
198point5SchemaJSON = [aesonQQ|
200 "type": "object",
201 "properties":
202 {
203 "x": { "type": "number", "format": "double" },
204 "y": { "type": "number", "format": "double" },
205 "z": { "type": "number", "format": "double" },
206 "u": { "type": "number", "format": "double" },
207 "v": { "type": "number", "format": "double" }
208 },
209 "required": ["x", "y", "z", "u", "v"]
211|]
213point5Properties :: [String]
214point5Properties = ["x", "y", "z", "u", "v"]
216-- ========================================================================
217-- Color (enum)
218-- ========================================================================
219data Color
220 = Red
221 | Green
222 | Blue
223 deriving (Generic)
224instance ToSchema Color
226colorSchemaJSON :: Value
227colorSchemaJSON = [aesonQQ|
229 "type": "string",
230 "enum": ["Red", "Green", "Blue"]
232|]
234-- ========================================================================
235-- Shade (paramSchemaToNamedSchema)
236-- ========================================================================
238data Shade = Dim | Bright deriving (Generic)
239instance ToParamSchema Shade
241instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
243shadeSchemaJSON :: Value
244shadeSchemaJSON = [aesonQQ|
246 "type": "string",
247 "enum": ["Dim", "Bright"]
249|]
251-- ========================================================================
252-- Paint (record with bounded enum property)
253-- ========================================================================
255newtype Paint = Paint { color :: Color }
256 deriving (Generic)
257instance ToSchema Paint
259paintSchemaJSON :: Value
260paintSchemaJSON = [aesonQQ|
262 "type": "object",
263 "properties":
264 {
265 "color":
266 {
267 "$ref": "#/definitions/Color"
268 }
269 },
270 "required": ["color"]
272|]
274paintInlinedSchemaJSON :: Value
275paintInlinedSchemaJSON = [aesonQQ|
277 "type": "object",
278 "properties":
279 {
280 "color":
281 {
282 "type": "string",
283 "enum": ["Red", "Green", "Blue"]
284 }
285 },
286 "required": ["color"]
288|]
290-- ========================================================================
291-- Email (newtype with unwrapUnaryRecords set to True)
292-- ========================================================================
294newtype Email = Email { getEmail :: String }
295 deriving (Generic)
297instance ToSchema Email where
298 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
299 { unwrapUnaryRecords = True }
301emailSchemaJSON :: Value
302emailSchemaJSON = [aesonQQ|
304 "type": "string"
306|]
308-- ========================================================================
309-- UserId (non-record newtype)
310-- ========================================================================
312newtype UserId = UserId Integer
313 deriving (Eq, Ord, Generic)
314instance ToSchema UserId
316userIdSchemaJSON :: Value
317userIdSchemaJSON = [aesonQQ|
319 "type": "integer"
321|]
323-- ========================================================================
324-- UserGroup (set newtype)
325-- ========================================================================
327newtype UserGroup = UserGroup (Set UserId)
328 deriving (Generic)
329instance ToSchema UserGroup
331userGroupSchemaJSON :: Value
332userGroupSchemaJSON = [aesonQQ|
334 "type": "array",
335 "items": { "$ref": "#/definitions/UserId" },
336 "uniqueItems": true
338|]
340-- ========================================================================
341-- Player (record newtype)
342-- ========================================================================
344newtype Player = Player
345 { position :: Point
346 } deriving (Generic)
347instance ToSchema Player
349playerSchemaJSON :: Value
350playerSchemaJSON = [aesonQQ|
352 "type": "object",
353 "properties":
354 {
355 "position":
356 {
357 "$ref": "#/definitions/Point"
358 }
359 },
360 "required": ["position"]
362|]
364-- ========================================================================
365-- MyRoseTree (custom datatypeNameModifier)
366-- ========================================================================
368data MyRoseTree = MyRoseTree
369 { root :: String
370 , trees :: [MyRoseTree]
371 } deriving (Generic)
373instance ToSchema MyRoseTree where
374 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
375 { datatypeNameModifier = drop (length "My") }
377myRoseTreeSchemaJSON :: Value
378myRoseTreeSchemaJSON = [aesonQQ|
380 "type": "object",
381 "properties":
382 {
383 "root": { "type": "string" },
384 "trees":
385 {
386 "type": "array",
387 "items":
388 {
389 "$ref": "#/definitions/RoseTree"
390 }
391 }
392 },
393 "required": ["root", "trees"]
395|]
397-- ========================================================================
398-- Inlined (newtype for inlining schemas)
399-- ========================================================================
401newtype Inlined a = Inlined { getInlined :: a }
403instance ToSchema a => ToSchema (Inlined a) where
404 declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
405 where
406 unname (NamedSchema _ s) = NamedSchema Nothing s
408newtype Players = Players [Inlined Player]
409 deriving (Generic)
410instance ToSchema Players
412playersSchemaJSON :: Value
413playersSchemaJSON = [aesonQQ|
415 "type": "array",
416 "items":
417 {
418 "type": "object",
419 "properties":
420 {
421 "position":
422 {
423 "$ref": "#/definitions/Point"
424 }
425 },
426 "required": ["position"]
427 }
429|]
431-- ========================================================================
432-- Status (sum type with unary constructors)
433-- ========================================================================
435data Status
436 = StatusOk String
437 | StatusError String
438 deriving (Generic)
440instance ToSchema Status where
441 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
442 { constructorTagModifier = map toLower . drop (length "Status") }
444statusSchemaJSON :: Value
445statusSchemaJSON = [aesonQQ|
447 "type": "object",
448 "properties":
449 {
450 "ok": { "type": "string" },
451 "error": { "type": "string" }
452 },
453 "maxProperties": 1,
454 "minProperties": 1
456|]
458-- ========================================================================
459-- Unit type
460-- ========================================================================
462data Unit = Unit deriving (Generic)
463instance ToSchema Unit
465unitSchemaJSON :: Value
466unitSchemaJSON = [aesonQQ|
468 "type": "string",
469 "enum": ["Unit"]
471|]
474-- ========================================================================
475-- Character (sum type with ref and record in alternative)
476-- ========================================================================
478data Character
479 = PC Player
480 | NPC { npcName :: String, npcPosition :: Point }
481 deriving (Generic)
482instance ToSchema Character
484characterSchemaJSON :: Value
485characterSchemaJSON = [aesonQQ|
487 "type": "object",
488 "properties":
489 {
490 "PC": { "$ref": "#/definitions/Player" },
491 "NPC":
492 {
493 "type": "object",
494 "properties":
495 {
496 "npcName": { "type": "string" },
497 "npcPosition": { "$ref": "#/definitions/Point" }
498 },
499 "required": ["npcName", "npcPosition"]
500 }
501 },
502 "maxProperties": 1,
503 "minProperties": 1
505|]
507characterInlinedSchemaJSON :: Value
508characterInlinedSchemaJSON = [aesonQQ|
510 "type": "object",
511 "properties":
512 {
513 "PC":
514 {
515 "type": "object",
516 "properties":
517 {
518 "position":
519 {
520 "type": "object",
521 "properties":
522 {
523 "x": { "type": "number", "format": "double" },
524 "y": { "type": "number", "format": "double" }
525 },
526 "required": ["x", "y"]
527 }
528 },
529 "required": ["position"]
530 },
531 "NPC":
532 {
533 "type": "object",
534 "properties":
535 {
536 "npcName": { "type": "string" },
537 "npcPosition":
538 {
539 "type": "object",
540 "properties":
541 {
542 "x": { "type": "number", "format": "double" },
543 "y": { "type": "number", "format": "double" }
544 },
545 "required": ["x", "y"]
546 }
547 },
548 "required": ["npcName", "npcPosition"]
549 }
550 },
551 "maxProperties": 1,
552 "minProperties": 1
554|]
556characterInlinedPlayerSchemaJSON :: Value
557characterInlinedPlayerSchemaJSON = [aesonQQ|
559 "type": "object",
560 "properties":
561 {
562 "PC":
563 {
564 "type": "object",
565 "properties":
566 {
567 "position":
568 {
569 "$ref": "#/definitions/Point"
570 }
571 },
572 "required": ["position"]
573 },
574 "NPC":
575 {
576 "type": "object",
577 "properties":
578 {
579 "npcName": { "type": "string" },
580 "npcPosition": { "$ref": "#/definitions/Point" }
581 },
582 "required": ["npcName", "npcPosition"]
583 }
584 },
585 "maxProperties": 1,
586 "minProperties": 1
588|]
590-- ========================================================================
591-- Light (sum type with unwrapUnaryRecords)
592-- ========================================================================
594data Light
595 = NoLight
596 | LightFreq Double
597 | LightColor Color
598 | LightWaveLength { waveLength :: Double }
599 deriving (Generic)
601instance ToSchema Light where
602 declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
603 { unwrapUnaryRecords = True }
605lightSchemaJSON :: Value
606lightSchemaJSON = [aesonQQ|
608 "type": "object",
609 "properties":
610 {
611 "NoLight": { "type": "array", "items": [] },
612 "LightFreq": { "type": "number", "format": "double" },
613 "LightColor": { "$ref": "#/definitions/Color" },
614 "LightWaveLength": { "type": "number", "format": "double" }
615 },
616 "maxProperties": 1,
617 "minProperties": 1
619|]
621lightInlinedSchemaJSON :: Value
622lightInlinedSchemaJSON = [aesonQQ|
624 "type": "object",
625 "properties":
626 {
627 "NoLight": { "type": "array", "items": [] },
628 "LightFreq": { "type": "number", "format": "double" },
629 "LightColor":
630 {
631 "type": "string",
632 "enum": ["Red", "Green", "Blue"]
633 },
634 "LightWaveLength": { "type": "number", "format": "double" }
635 },
636 "maxProperties": 1,
637 "minProperties": 1
639|]
641-- ========================================================================
642-- ResourceId (series of newtypes)
643-- ========================================================================
645newtype Id = Id String deriving (Generic)
646instance ToSchema Id
648newtype ResourceId = ResourceId Id deriving (Generic)
649instance ToSchema ResourceId