@@ -0,0 +1,652 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE QuasiQuotes #-}
4+
5+module Data.Swagger.CommonTestTypes where
6+
7+ import Prelude ()
8+ import Prelude.Compat
9+
10+ import Data.Aeson (Value, ToJSON(..), ToJSONKey(..))
11+ import Data.Aeson.Types (toJSONKeyText)
12+ import Data.Aeson.QQ
13+ import Data.Char
14+ import Data.Proxy
15+ import Data.Set (Set)
16+ import Data.Map (Map)
17+ import qualified Data.Text as Text
18+ import GHC.Generics
19+
20+ import Data.Swagger
21+ import Data.Swagger.Declare
22+ import Data.Swagger.Internal (SwaggerKind(..))
23+
24+ -- ========================================================================
25+ -- Unit type
26+ -- ========================================================================
27+
28+ data Unit = Unit deriving (Generic)
29+ instance ToParamSchema Unit
30+ instance ToSchema Unit
31+
32+ unitSchemaJSON :: Value
33+ unitSchemaJSON = [aesonQQ|
34+ {
35+ "type": "string",
36+ "enum": ["Unit"]
37+ }
38+ |]
39+
40+ -- ========================================================================
41+ -- Color (enum)
42+ -- ========================================================================
43+ data Color
44+ = Red
45+ | Green
46+ | Blue
47+ deriving (Generic)
48+ instance ToParamSchema Color
49+ instance ToSchema Color
50+
51+ colorSchemaJSON :: Value
52+ colorSchemaJSON = [aesonQQ|
53+ {
54+ "type": "string",
55+ "enum": ["Red", "Green", "Blue"]
56+ }
57+ |]
58+
59+ -- ========================================================================
60+ -- Shade (paramSchemaToNamedSchema)
61+ -- ========================================================================
62+
63+ data Shade = Dim | Bright deriving (Generic)
64+ instance ToParamSchema Shade
65+
66+ instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
67+
68+ shadeSchemaJSON :: Value
69+ shadeSchemaJSON = [aesonQQ|
70+ {
71+ "type": "string",
72+ "enum": ["Dim", "Bright"]
73+ }
74+ |]
75+
76+ -- ========================================================================
77+ -- Paint (record with bounded enum property)
78+ -- ========================================================================
79+
80+ newtype Paint = Paint { color :: Color }
81+ deriving (Generic)
82+ instance ToSchema Paint
83+
84+ paintSchemaJSON :: Value
85+ paintSchemaJSON = [aesonQQ|
86+ {
87+ "type": "object",
88+ "properties":
89+ {
90+ "color":
91+ {
92+ "$ref": "#/definitions/Color"
93+ }
94+ },
95+ "required": ["color"]
96+ }
97+ |]
98+
99+ paintInlinedSchemaJSON :: Value
100+ paintInlinedSchemaJSON = [aesonQQ|
101+ {
102+ "type": "object",
103+ "properties":
104+ {
105+ "color":
106+ {
107+ "type": "string",
108+ "enum": ["Red", "Green", "Blue"]
109+ }
110+ },
111+ "required": ["color"]
112+ }
113+ |]
114+
115+ -- ========================================================================
116+ -- Status (constructorTagModifier)
117+ -- ========================================================================
118+
119+ data Status
120+ = StatusOk
121+ | StatusError
122+ deriving (Generic)
123+
124+ instance ToParamSchema Status where
125+ toParamSchema = genericToParamSchema defaultSchemaOptions
126+ { constructorTagModifier = map toLower . drop (length "Status") }
127+ instance ToSchema Status where
128+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
129+ { constructorTagModifier = map toLower . drop (length "Status") }
130+
131+ statusSchemaJSON :: Value
132+ statusSchemaJSON = [aesonQQ|
133+ {
134+ "type": "string",
135+ "enum": ["ok", "error"]
136+ }
137+ |]
138+
139+ -- ========================================================================
140+ -- Email (newtype with unwrapUnaryRecords set to True)
141+ -- ========================================================================
142+
143+ newtype Email = Email { getEmail :: String }
144+ deriving (Generic)
145+ instance ToParamSchema Email
146+ instance ToSchema Email where
147+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
148+ { unwrapUnaryRecords = True }
149+
150+ emailSchemaJSON :: Value
151+ emailSchemaJSON = [aesonQQ|
152+ {
153+ "type": "string"
154+ }
155+ |]
156+
157+ -- ========================================================================
158+ -- UserId (non-record newtype)
159+ -- ========================================================================
160+
161+ newtype UserId = UserId Integer
162+ deriving (Eq, Ord, Generic)
163+ instance ToParamSchema UserId
164+ instance ToSchema UserId
165+
166+ userIdSchemaJSON :: Value
167+ userIdSchemaJSON = [aesonQQ|
168+ {
169+ "type": "integer"
170+ }
171+ |]
172+
173+ -- ========================================================================
174+ -- UserGroup (set newtype)
175+ -- ========================================================================
176+
177+ newtype UserGroup = UserGroup (Set UserId)
178+ deriving (Generic)
179+ instance ToSchema UserGroup
180+
181+ userGroupSchemaJSON :: Value
182+ userGroupSchemaJSON = [aesonQQ|
183+ {
184+ "type": "array",
185+ "items": { "$ref": "#/definitions/UserId" },
186+ "uniqueItems": true
187+ }
188+ |]
189+
190+ -- ========================================================================
191+ -- Person (simple record with optional fields)
192+ -- ========================================================================
193+ data Person = Person
194+ { name :: String
195+ , phone :: Integer
196+ , email :: Maybe String
197+ } deriving (Generic)
198+
199+ instance ToSchema Person
200+
201+ personSchemaJSON :: Value
202+ personSchemaJSON = [aesonQQ|
203+ {
204+ "type": "object",
205+ "properties":
206+ {
207+ "name": { "type": "string" },
208+ "phone": { "type": "integer" },
209+ "email": { "type": "string" }
210+ },
211+ "required": ["name", "phone"]
212+ }
213+ |]
214+
215+ -- ========================================================================
216+ -- Player (record newtype)
217+ -- ========================================================================
218+
219+ newtype Player = Player
220+ { position :: Point
221+ } deriving (Generic)
222+ instance ToSchema Player
223+
224+ playerSchemaJSON :: Value
225+ playerSchemaJSON = [aesonQQ|
226+ {
227+ "type": "object",
228+ "properties":
229+ {
230+ "position":
231+ {
232+ "$ref": "#/definitions/Point"
233+ }
234+ },
235+ "required": ["position"]
236+ }
237+ |]
238+
239+ newtype Players = Players [Inlined Player]
240+ deriving (Generic)
241+ instance ToSchema Players
242+
243+ playersSchemaJSON :: Value
244+ playersSchemaJSON = [aesonQQ|
245+ {
246+ "type": "array",
247+ "items":
248+ {
249+ "type": "object",
250+ "properties":
251+ {
252+ "position":
253+ {
254+ "$ref": "#/definitions/Point"
255+ }
256+ },
257+ "required": ["position"]
258+ }
259+ }
260+ |]
261+
262+ -- ========================================================================
263+ -- Character (sum type with ref and record in alternative)
264+ -- ========================================================================
265+
266+ data Character
267+ = PC Player
268+ | NPC { npcName :: String, npcPosition :: Point }
269+ deriving (Generic)
270+ instance ToSchema Character
271+
272+ characterSchemaJSON :: Value
273+ characterSchemaJSON = [aesonQQ|
274+ {
275+ "type": "object",
276+ "properties":
277+ {
278+ "PC": { "$ref": "#/definitions/Player" },
279+ "NPC":
280+ {
281+ "type": "object",
282+ "properties":
283+ {
284+ "npcName": { "type": "string" },
285+ "npcPosition": { "$ref": "#/definitions/Point" }
286+ },
287+ "required": ["npcName", "npcPosition"]
288+ }
289+ },
290+ "maxProperties": 1,
291+ "minProperties": 1
292+ }
293+ |]
294+
295+ characterInlinedSchemaJSON :: Value
296+ characterInlinedSchemaJSON = [aesonQQ|
297+ {
298+ "type": "object",
299+ "properties":
300+ {
301+ "PC":
302+ {
303+ "type": "object",
304+ "properties":
305+ {
306+ "position":
307+ {
308+ "type": "object",
309+ "properties":
310+ {
311+ "x": { "type": "number", "format": "double" },
312+ "y": { "type": "number", "format": "double" }
313+ },
314+ "required": ["x", "y"]
315+ }
316+ },
317+ "required": ["position"]
318+ },
319+ "NPC":
320+ {
321+ "type": "object",
322+ "properties":
323+ {
324+ "npcName": { "type": "string" },
325+ "npcPosition":
326+ {
327+ "type": "object",
328+ "properties":
329+ {
330+ "x": { "type": "number", "format": "double" },
331+ "y": { "type": "number", "format": "double" }
332+ },
333+ "required": ["x", "y"]
334+ }
335+ },
336+ "required": ["npcName", "npcPosition"]
337+ }
338+ },
339+ "maxProperties": 1,
340+ "minProperties": 1
341+ }
342+ |]
343+
344+ characterInlinedPlayerSchemaJSON :: Value
345+ characterInlinedPlayerSchemaJSON = [aesonQQ|
346+ {
347+ "type": "object",
348+ "properties":
349+ {
350+ "PC":
351+ {
352+ "type": "object",
353+ "properties":
354+ {
355+ "position":
356+ {
357+ "$ref": "#/definitions/Point"
358+ }
359+ },
360+ "required": ["position"]
361+ },
362+ "NPC":
363+ {
364+ "type": "object",
365+ "properties":
366+ {
367+ "npcName": { "type": "string" },
368+ "npcPosition": { "$ref": "#/definitions/Point" }
369+ },
370+ "required": ["npcName", "npcPosition"]
371+ }
372+ },
373+ "maxProperties": 1,
374+ "minProperties": 1
375+ }
376+ |]
377+
378+ -- ========================================================================
379+ -- ISPair (non-record product data type)
380+ -- ========================================================================
381+ data ISPair = ISPair Integer String
382+ deriving (Generic)
383+
384+ instance ToSchema ISPair
385+
386+ ispairSchemaJSON :: Value
387+ ispairSchemaJSON = [aesonQQ|
388+ {
389+ "type": "array",
390+ "items":
391+ [
392+ { "type": "integer" },
393+ { "type": "string" }
394+ ],
395+ "minItems": 2,
396+ "maxItems": 2
397+ }
398+ |]
399+
400+ -- ========================================================================
401+ -- Point (record data type with custom fieldLabelModifier)
402+ -- ========================================================================
403+
404+ data Point = Point
405+ { pointX :: Double
406+ , pointY :: Double
407+ } deriving (Generic)
408+
409+ instance ToSchema Point where
410+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
411+ { fieldLabelModifier = map toLower . drop (length "point") }
412+
413+ pointSchemaJSON :: Value
414+ pointSchemaJSON = [aesonQQ|
415+ {
416+ "type": "object",
417+ "properties":
418+ {
419+ "x": { "type": "number", "format": "double" },
420+ "y": { "type": "number", "format": "double" }
421+ },
422+ "required": ["x", "y"]
423+ }
424+ |]
425+
426+ -- ========================================================================
427+ -- Point (record data type with multiple fields)
428+ -- ========================================================================
429+
430+ data Point5 = Point5
431+ { point5X :: Double
432+ , point5Y :: Double
433+ , point5Z :: Double
434+ , point5U :: Double
435+ , point5V :: Double -- 5 dimensional!
436+ } deriving (Generic)
437+
438+ instance ToSchema Point5 where
439+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
440+ { fieldLabelModifier = map toLower . drop (length "point5") }
441+
442+ point5SchemaJSON :: Value
443+ point5SchemaJSON = [aesonQQ|
444+ {
445+ "type": "object",
446+ "properties":
447+ {
448+ "x": { "type": "number", "format": "double" },
449+ "y": { "type": "number", "format": "double" },
450+ "z": { "type": "number", "format": "double" },
451+ "u": { "type": "number", "format": "double" },
452+ "v": { "type": "number", "format": "double" }
453+ },
454+ "required": ["x", "y", "z", "u", "v"]
455+ }
456+ |]
457+
458+ point5Properties :: [String]
459+ point5Properties = ["x", "y", "z", "u", "v"]
460+
461+ -- ========================================================================
462+ -- MyRoseTree (custom datatypeNameModifier)
463+ -- ========================================================================
464+
465+ data MyRoseTree = MyRoseTree
466+ { root :: String
467+ , trees :: [MyRoseTree]
468+ } deriving (Generic)
469+
470+ instance ToSchema MyRoseTree where
471+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
472+ { datatypeNameModifier = drop (length "My") }
473+
474+ myRoseTreeSchemaJSON :: Value
475+ myRoseTreeSchemaJSON = [aesonQQ|
476+ {
477+ "type": "object",
478+ "properties":
479+ {
480+ "root": { "type": "string" },
481+ "trees":
482+ {
483+ "type": "array",
484+ "items":
485+ {
486+ "$ref": "#/definitions/RoseTree"
487+ }
488+ }
489+ },
490+ "required": ["root", "trees"]
491+ }
492+ |]
493+
494+ data MyRoseTree' = MyRoseTree'
495+ { root' :: String
496+ , trees' :: [MyRoseTree']
497+ } deriving (Generic)
498+
499+ instance ToSchema MyRoseTree' where
500+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
501+ { datatypeNameModifier = map toLower }
502+
503+ myRoseTreeSchemaJSON' :: Value
504+ myRoseTreeSchemaJSON' = [aesonQQ|
505+ {
506+ "type": "object",
507+ "properties":
508+ {
509+ "root'": { "type": "string" },
510+ "trees'":
511+ {
512+ "type": "array",
513+ "items":
514+ {
515+ "$ref": "#/definitions/myrosetree'"
516+ }
517+ }
518+ },
519+ "required": ["root'", "trees'"]
520+ }
521+ |]
522+
523+ -- ========================================================================
524+ -- Inlined (newtype for inlining schemas)
525+ -- ========================================================================
526+
527+ newtype Inlined a = Inlined { getInlined :: a }
528+
529+ instance ToSchema a => ToSchema (Inlined a) where
530+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
531+ where
532+ unname (NamedSchema _ s) = NamedSchema Nothing s
533+
534+ -- ========================================================================
535+ -- Light (sum type with unwrapUnaryRecords)
536+ -- ========================================================================
537+
538+ data Light
539+ = NoLight
540+ | LightFreq Double
541+ | LightColor Color
542+ | LightWaveLength { waveLength :: Double }
543+ deriving (Generic)
544+
545+ instance ToSchema Light where
546+ declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
547+ { unwrapUnaryRecords = True }
548+
549+ lightSchemaJSON :: Value
550+ lightSchemaJSON = [aesonQQ|
551+ {
552+ "type": "object",
553+ "properties":
554+ {
555+ "NoLight": { "type": "array", "items": [] },
556+ "LightFreq": { "type": "number", "format": "double" },
557+ "LightColor": { "$ref": "#/definitions/Color" },
558+ "LightWaveLength": { "type": "number", "format": "double" }
559+ },
560+ "maxProperties": 1,
561+ "minProperties": 1
562+ }
563+ |]
564+
565+ lightInlinedSchemaJSON :: Value
566+ lightInlinedSchemaJSON = [aesonQQ|
567+ {
568+ "type": "object",
569+ "properties":
570+ {
571+ "NoLight": { "type": "array", "items": [] },
572+ "LightFreq": { "type": "number", "format": "double" },
573+ "LightColor":
574+ {
575+ "type": "string",
576+ "enum": ["Red", "Green", "Blue"]
577+ },
578+ "LightWaveLength": { "type": "number", "format": "double" }
579+ },
580+ "maxProperties": 1,
581+ "minProperties": 1
582+ }
583+ |]
584+
585+ -- ========================================================================
586+ -- ResourceId (series of newtypes)
587+ -- ========================================================================
588+
589+ newtype Id = Id String deriving (Generic)
590+ instance ToSchema Id
591+
592+ newtype ResourceId = ResourceId Id deriving (Generic)
593+ instance ToSchema ResourceId
594+
595+ -- ========================================================================
596+ -- ButtonImages (bounded enum key mapping)
597+ -- ========================================================================
598+
599+ data ButtonState = Neutral | Focus | Active | Hover | Disabled
600+ deriving (Show, Bounded, Enum, Generic)
601+
602+ instance ToJSON ButtonState
603+ instance ToSchema ButtonState
604+ instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)
605+
606+ type ImageUrl = Text.Text
607+
608+ newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
609+ deriving (Generic)
610+
611+ instance ToJSON ButtonImages where
612+ toJSON = toJSON . getButtonImages
613+
614+ instance ToSchema ButtonImages where
615+ declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
616+ declareSchemaBoundedEnumKeyMapping
617+
618+ buttonImagesSchemaJSON :: Value
619+ buttonImagesSchemaJSON = [aesonQQ|
620+ {
621+ "type": "object",
622+ "properties":
623+ {
624+ "Neutral": { "type": "string" },
625+ "Focus": { "type": "string" },
626+ "Active": { "type": "string" },
627+ "Hover": { "type": "string" },
628+ "Disabled": { "type": "string" }
629+ }
630+ }
631+ |]
632+
633+ -- ========================================================================
634+ -- SingleMaybeField (single field data with optional field)
635+ -- ========================================================================
636+
637+ data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String }
638+ deriving (Show, Generic)
639+
640+ instance ToJSON SingleMaybeField
641+ instance ToSchema SingleMaybeField
642+
643+ singleMaybeFieldSchemaJSON :: Value
644+ singleMaybeFieldSchemaJSON = [aesonQQ|
645+ {
646+ "type": "object",
647+ "properties":
648+ {
649+ "singleMaybeField": { "type": "string" }
650+ }
651+ }
652+ |]