git.iko.soy/typeable/openapi3
on 340f666 help sign in
typeable/openapi3/test/Data/Swagger/SchemaSpec.hs
602 lines 17 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 Data.Aeson
11import Data.Aeson.QQ
12import Data.Char
13import qualified Data.HashMap.Strict as HashMap
14import Data.Proxy
15import Data.Set (Set)
16import qualified Data.Set as 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 Set.fromList (HashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names)
38 where
39 defs = execDeclare (declareNamedSchema proxy) mempty
41checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec
42checkInlinedSchema proxy js = toInlinedSchema proxy <=> js
44checkInlinedSchemas :: ToSchema a => [String] -> Proxy a -> Value -> Spec
45checkInlinedSchemas names proxy js = inlineSchemas (map Text.pack names) defs s <=> js
46 where
47 (defs, s) = runDeclare (declareSchema proxy) mempty
49checkInlinedRecSchema :: ToSchema a => Proxy a -> Value -> Spec
50checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs s <=> js
51 where
52 (defs, s) = runDeclare (declareSchema proxy) mempty
54spec :: Spec
55spec = do
56 describe "Generic ToSchema" $ do
57 context "Unit" $ checkToSchema (Proxy :: Proxy Unit) unitSchemaJSON
58 context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
59 context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
60 context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON
61 context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
62 context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
63 context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
64 context "UserGroup (set newtype)" $ checkToSchema (Proxy :: Proxy UserGroup) userGroupSchemaJSON
65 context "Unary records" $ do
66 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
67 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
68 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
69 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
70 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
71 context "Sum types" $ do
72 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
73 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
74 context "Light (sum with unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Light) lightSchemaJSON
75 context "Schema name" $ do
76 context "String" $ checkSchemaName Nothing (Proxy :: Proxy String)
77 context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))
78 context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person)
79 context "Shade" $ checkSchemaName (Just "Shade") (Proxy :: Proxy Shade)
80 describe "Generic Definitions" $ do
81 context "Unit" $ checkDefs (Proxy :: Proxy Unit) []
82 context "Paint" $ checkDefs (Proxy :: Proxy Paint) ["Color"]
83 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
84 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
85 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
86 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
87 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
88 describe "Inlining Schemas" $ do
89 context "Paint" $ checkInlinedSchema (Proxy :: Proxy Paint) paintInlinedSchemaJSON
90 context "Character" $ checkInlinedSchema (Proxy :: Proxy Character) characterInlinedSchemaJSON
91 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
92 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
93 context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
95main :: IO ()
96main = hspec spec
98-- ========================================================================
99-- Person (simple record with optional fields)
100-- ========================================================================
101data Person = Person
102 { name :: String
103 , phone :: Integer
104 , email :: Maybe String
105 } deriving (Generic)
107instance ToSchema Person
109personSchemaJSON :: Value
110personSchemaJSON = [aesonQQ|
112 "type": "object",
113 "properties":
114 {
115 "name": { "type": "string" },
116 "phone": { "type": "integer" },
117 "email": { "type": "string" }
118 },
119 "required": ["name", "phone"]
121|]
123-- ========================================================================
124-- ISPair (non-record product data type)
125-- ========================================================================
126data ISPair = ISPair Integer String
127 deriving (Generic)
129instance ToSchema ISPair
131ispairSchemaJSON :: Value
132ispairSchemaJSON = [aesonQQ|
134 "type": "array",
135 "items":
136 [
137 { "type": "integer" },
138 { "type": "string" }
139 ]
141|]
143-- ========================================================================
144-- Point (record data type with custom fieldLabelModifier)
145-- ========================================================================
146data Point = Point
147 { pointX :: Double
148 , pointY :: Double
149 } deriving (Generic)
151instance ToSchema Point where
152 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
153 { fieldLabelModifier = map toLower . drop (length "point") }
155pointSchemaJSON :: Value
156pointSchemaJSON = [aesonQQ|
158 "type": "object",
159 "properties":
160 {
161 "x": { "type": "number", "format": "double" },
162 "y": { "type": "number", "format": "double" }
163 },
164 "required": ["x", "y"]
166|]
169-- ========================================================================
170-- Color (enum)
171-- ========================================================================
172data Color
173 = Red
174 | Green
175 | Blue
176 deriving (Generic)
177instance ToSchema Color
179colorSchemaJSON :: Value
180colorSchemaJSON = [aesonQQ|
182 "type": "string",
183 "enum": ["Red", "Green", "Blue"]
185|]
187-- ========================================================================
188-- Shade (paramSchemaToNamedSchema)
189-- ========================================================================
191data Shade = Dim | Bright deriving (Generic)
192instance ToParamSchema Shade
194instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
196shadeSchemaJSON :: Value
197shadeSchemaJSON = [aesonQQ|
199 "type": "string",
200 "enum": ["Dim", "Bright"]
202|]
204-- ========================================================================
205-- Paint (record with bounded enum property)
206-- ========================================================================
208newtype Paint = Paint { color :: Color }
209 deriving (Generic)
210instance ToSchema Paint
212paintSchemaJSON :: Value
213paintSchemaJSON = [aesonQQ|
215 "type": "object",
216 "properties":
217 {
218 "color":
219 {
220 "$ref": "#/definitions/Color"
221 }
222 },
223 "required": ["color"]
225|]
227paintInlinedSchemaJSON :: Value
228paintInlinedSchemaJSON = [aesonQQ|
230 "type": "object",
231 "properties":
232 {
233 "color":
234 {
235 "type": "string",
236 "enum": ["Red", "Green", "Blue"]
237 }
238 },
239 "required": ["color"]
241|]
243-- ========================================================================
244-- Email (newtype with unwrapUnaryRecords set to True)
245-- ========================================================================
247newtype Email = Email { getEmail :: String }
248 deriving (Generic)
250instance ToSchema Email where
251 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
252 { unwrapUnaryRecords = True }
254emailSchemaJSON :: Value
255emailSchemaJSON = [aesonQQ|
257 "type": "string"
259|]
261-- ========================================================================
262-- UserId (non-record newtype)
263-- ========================================================================
265newtype UserId = UserId Integer
266 deriving (Eq, Ord, Generic)
267instance ToSchema UserId
269userIdSchemaJSON :: Value
270userIdSchemaJSON = [aesonQQ|
272 "type": "integer"
274|]
276-- ========================================================================
277-- UserGroup (set newtype)
278-- ========================================================================
280newtype UserGroup = UserGroup (Set UserId)
281 deriving (Generic)
282instance ToSchema UserGroup
284userGroupSchemaJSON :: Value
285userGroupSchemaJSON = [aesonQQ|
287 "type": "array",
288 "items": { "$ref": "#/definitions/UserId" },
289 "uniqueItems": true
291|]
293-- ========================================================================
294-- Player (record newtype)
295-- ========================================================================
297newtype Player = Player
298 { position :: Point
299 } deriving (Generic)
300instance ToSchema Player
302playerSchemaJSON :: Value
303playerSchemaJSON = [aesonQQ|
305 "type": "object",
306 "properties":
307 {
308 "position":
309 {
310 "$ref": "#/definitions/Point"
311 }
312 },
313 "required": ["position"]
315|]
317-- ========================================================================
318-- MyRoseTree (custom datatypeNameModifier)
319-- ========================================================================
321data MyRoseTree = MyRoseTree
322 { root :: String
323 , trees :: [MyRoseTree]
324 } deriving (Generic)
326instance ToSchema MyRoseTree where
327 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
328 { datatypeNameModifier = drop (length "My") }
330myRoseTreeSchemaJSON :: Value
331myRoseTreeSchemaJSON = [aesonQQ|
333 "type": "object",
334 "properties":
335 {
336 "root": { "type": "string" },
337 "trees":
338 {
339 "type": "array",
340 "items":
341 {
342 "$ref": "#/definitions/RoseTree"
343 }
344 }
345 },
346 "required": ["root", "trees"]
348|]
350-- ========================================================================
351-- Inlined (newtype for inlining schemas)
352-- ========================================================================
354newtype Inlined a = Inlined { getInlined :: a }
356instance ToSchema a => ToSchema (Inlined a) where
357 declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
358 where
359 unname (NamedSchema _ s) = NamedSchema Nothing s
361newtype Players = Players [Inlined Player]
362 deriving (Generic)
363instance ToSchema Players
365playersSchemaJSON :: Value
366playersSchemaJSON = [aesonQQ|
368 "type": "array",
369 "items":
370 {
371 "type": "object",
372 "properties":
373 {
374 "position":
375 {
376 "$ref": "#/definitions/Point"
377 }
378 },
379 "required": ["position"]
380 }
382|]
384-- ========================================================================
385-- Status (sum type with unary constructors)
386-- ========================================================================
388data Status
389 = StatusOk String
390 | StatusError String
391 deriving (Generic)
393instance ToSchema Status where
394 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
395 { constructorTagModifier = map toLower . drop (length "Status") }
397statusSchemaJSON :: Value
398statusSchemaJSON = [aesonQQ|
400 "type": "object",
401 "properties":
402 {
403 "ok": { "type": "string" },
404 "error": { "type": "string" }
405 },
406 "maxProperties": 1,
407 "minProperties": 1
409|]
411-- ========================================================================
412-- Unit type
413-- ========================================================================
415data Unit = Unit deriving (Generic)
416instance ToSchema Unit
418unitSchemaJSON :: Value
419unitSchemaJSON = [aesonQQ|
421 "type": "string",
422 "enum": ["Unit"]
424|]
427-- ========================================================================
428-- Character (sum type with ref and record in alternative)
429-- ========================================================================
431data Character
432 = PC Player
433 | NPC { npcName :: String, npcPosition :: Point }
434 deriving (Generic)
435instance ToSchema Character
437characterSchemaJSON :: Value
438characterSchemaJSON = [aesonQQ|
440 "type": "object",
441 "properties":
442 {
443 "PC": { "$ref": "#/definitions/Player" },
444 "NPC":
445 {
446 "type": "object",
447 "properties":
448 {
449 "npcName": { "type": "string" },
450 "npcPosition": { "$ref": "#/definitions/Point" }
451 },
452 "required": ["npcName", "npcPosition"]
453 }
454 },
455 "maxProperties": 1,
456 "minProperties": 1
458|]
460characterInlinedSchemaJSON :: Value
461characterInlinedSchemaJSON = [aesonQQ|
463 "type": "object",
464 "properties":
465 {
466 "PC":
467 {
468 "type": "object",
469 "properties":
470 {
471 "position":
472 {
473 "type": "object",
474 "properties":
475 {
476 "x": { "type": "number", "format": "double" },
477 "y": { "type": "number", "format": "double" }
478 },
479 "required": ["x", "y"]
480 }
481 },
482 "required": ["position"]
483 },
484 "NPC":
485 {
486 "type": "object",
487 "properties":
488 {
489 "npcName": { "type": "string" },
490 "npcPosition":
491 {
492 "type": "object",
493 "properties":
494 {
495 "x": { "type": "number", "format": "double" },
496 "y": { "type": "number", "format": "double" }
497 },
498 "required": ["x", "y"]
499 }
500 },
501 "required": ["npcName", "npcPosition"]
502 }
503 },
504 "maxProperties": 1,
505 "minProperties": 1
507|]
509characterInlinedPlayerSchemaJSON :: Value
510characterInlinedPlayerSchemaJSON = [aesonQQ|
512 "type": "object",
513 "properties":
514 {
515 "PC":
516 {
517 "type": "object",
518 "properties":
519 {
520 "position":
521 {
522 "$ref": "#/definitions/Point"
523 }
524 },
525 "required": ["position"]
526 },
527 "NPC":
528 {
529 "type": "object",
530 "properties":
531 {
532 "npcName": { "type": "string" },
533 "npcPosition": { "$ref": "#/definitions/Point" }
534 },
535 "required": ["npcName", "npcPosition"]
536 }
537 },
538 "maxProperties": 1,
539 "minProperties": 1
541|]
543-- ========================================================================
544-- Light (sum type with unwrapUnaryRecords)
545-- ========================================================================
547data Light
548 = NoLight
549 | LightFreq Double
550 | LightColor Color
551 | LightWaveLength { waveLength :: Double }
552 deriving (Generic)
554instance ToSchema Light where
555 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
556 { unwrapUnaryRecords = True }
558lightSchemaJSON :: Value
559lightSchemaJSON = [aesonQQ|
561 "type": "object",
562 "properties":
563 {
564 "NoLight": { "type": "array", "items": [] },
565 "LightFreq": { "type": "number", "format": "double" },
566 "LightColor": { "$ref": "#/definitions/Color" },
567 "LightWaveLength": { "type": "number", "format": "double" }
568 },
569 "maxProperties": 1,
570 "minProperties": 1
572|]
574lightInlinedSchemaJSON :: Value
575lightInlinedSchemaJSON = [aesonQQ|
577 "type": "object",
578 "properties":
579 {
580 "NoLight": { "type": "array", "items": [] },
581 "LightFreq": { "type": "number", "format": "double" },
582 "LightColor":
583 {
584 "type": "string",
585 "enum": ["Red", "Green", "Blue"]
586 },
587 "LightWaveLength": { "type": "number", "format": "double" }
588 },
589 "maxProperties": 1,
590 "minProperties": 1
592|]
594-- ========================================================================
595-- ResourceId (series of newtypes)
596-- ========================================================================
598newtype Id = Id String deriving (Generic)
599instance ToSchema Id
601newtype ResourceId = ResourceId Id deriving (Generic)
602instance ToSchema ResourceId