@@ -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+|]