@@ -0,0 +1,447 @@
1+{-# LANGUAGE DefaultSignatures #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TupleSections #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE TypeSynonymInstances #-}
12+module Data.Swagger.Schema.Internal where
13+
14+import Control.Lens
15+import Data.Aeson
16+import Data.Char
17+import Data.HashMap.Strict (HashMap)
18+import Data.HashSet (HashSet)
19+import Data.Int
20+import Data.IntSet (IntSet)
21+import Data.IntMap (IntMap)
22+import Data.Map (Map)
23+import Data.Monoid
24+import Data.Proxy
25+import Data.Scientific (Scientific)
26+import Data.Set (Set)
27+import qualified Data.Text as T
28+import qualified Data.Text.Lazy as TL
29+import Data.Time
30+import Data.Word
31+import GHC.Generics
32+
33+import Data.Swagger.Internal
34+import Data.Swagger.Lens
35+
36+-- | A @'Schema'@ with an optional name.
37+-- This name can be used in references.
38+type NamedSchema = (Maybe String, Schema)
39+
40+unnamed :: Schema -> NamedSchema
41+unnamed schema = (Nothing, schema)
42+
43+named :: String -> Schema -> NamedSchema
44+named name schema = (Just name, schema)
45+
46+-- | Convert a type into @'Schema'@.
47+--
48+-- An example type and instance:
49+--
50+-- @
51+-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals
52+-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' as list
53+--
54+-- import Control.Lens
55+--
56+-- data Coord = Coord { x :: Double, y :: Double }
57+--
58+-- instance ToSchema Coord where
59+-- toNamedSchema = (Just \"Coord\", mempty
60+-- & schemaType .~ SchemaObject
61+-- & schemaProperties .~
62+-- [ ("x", toSchemaRef (Proxy :: Proxy Double))
63+-- , ("y", toSchemaRef (Proxy :: Proxy Double))
64+-- ]
65+-- & schemaRequired .~ [ "x", "y" ]
66+-- @
67+--
68+-- Instead of manually writing your @'ToSchema'@ instance you can
69+-- use a default generic implementation of @'toNamedSchema'@.
70+--
71+-- To do that, simply add @deriving 'Generic'@ clause to your datatype
72+-- and declare a @'ToSchema'@ instance for your datatype without
73+-- giving definition for @'toNamedSchema'@.
74+--
75+-- For instance, the previous example can be simplified into this:
76+--
77+-- @
78+-- {-\# LANGUAGE DeriveGeneric \#-}
79+--
80+-- import GHC.Generics (Generic)
81+--
82+-- data Coord = Coord { x :: Double, y :: Double } deriving Generic
83+--
84+-- instance ToSchema Coord
85+-- @
86+class ToSchema a where
87+ -- | Convert a type into an optionally named schema.
88+ toNamedSchema :: proxy a -> NamedSchema
89+ default toNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> NamedSchema
90+ toNamedSchema = genericToNamedSchema defaultSchemaOptions
91+
92+-- | Get type's schema name according to its @'ToSchema'@ instance.
93+schemaName :: ToSchema a => proxy a -> Maybe String
94+schemaName = fst . toNamedSchema
95+
96+-- | Convert a type into a schema.
97+toSchema :: ToSchema a => proxy a -> Schema
98+toSchema = snd . toNamedSchema
99+
100+-- | Convert a type into a referenced schema if possible.
101+-- Only named schemas can be references, nameless schemas are inlined.
102+toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
103+toSchemaRef proxy = case toNamedSchema proxy of
104+ (Just name, _) -> Ref (Reference ("#/definitions/" <> T.pack name))
105+ (_, schema) -> Inline schema
106+
107+class GToSchema (f :: * -> *) where
108+ gtoNamedSchema :: SchemaOptions -> proxy f -> Schema -> NamedSchema
109+
110+gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema -> Schema
111+gtoSchema opts proxy = snd . gtoNamedSchema opts proxy
112+
113+instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
114+ toNamedSchema _ = unnamed $ mempty
115+ & schemaType .~ SchemaArray
116+ & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a))
117+
118+instance {-# OVERLAPPING #-} ToSchema String where
119+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaString
120+
121+instance ToSchema Bool where
122+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaBoolean
123+
124+instance ToSchema Integer where
125+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaInteger
126+
127+instance ToSchema Int where toNamedSchema = unnamed . toSchemaBoundedIntegral
128+instance ToSchema Int8 where toNamedSchema = unnamed . toSchemaBoundedIntegral
129+instance ToSchema Int16 where toNamedSchema = unnamed . toSchemaBoundedIntegral
130+instance ToSchema Int32 where toNamedSchema = unnamed . toSchemaBoundedIntegral
131+instance ToSchema Int64 where toNamedSchema = unnamed . toSchemaBoundedIntegral
132+
133+instance ToSchema Word where toNamedSchema = unnamed . toSchemaBoundedIntegral
134+instance ToSchema Word8 where toNamedSchema = unnamed . toSchemaBoundedIntegral
135+instance ToSchema Word16 where toNamedSchema = unnamed . toSchemaBoundedIntegral
136+instance ToSchema Word32 where toNamedSchema = unnamed . toSchemaBoundedIntegral
137+instance ToSchema Word64 where toNamedSchema = unnamed . toSchemaBoundedIntegral
138+
139+instance ToSchema Char where
140+ toNamedSchema _ = unnamed $ mempty
141+ & schemaType .~ SchemaString
142+ & schemaMaxLength ?~ 1
143+ & schemaMinLength ?~ 1
144+
145+instance ToSchema Scientific where
146+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber
147+
148+instance ToSchema Double where
149+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber
150+
151+instance ToSchema Float where
152+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber
153+
154+instance ToSchema a => ToSchema (Maybe a) where
155+ toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
156+
157+instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
158+
159+instance ToSchema ()
160+instance (ToSchema a, ToSchema b) => ToSchema (a, b)
161+instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
162+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
163+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)
164+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
165+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
166+
167+timeNamedSchema :: String -> String -> NamedSchema
168+timeNamedSchema name format = (Just name, mempty
169+ & schemaType .~ SchemaString
170+ & schemaFormat ?~ T.pack format
171+ & schemaMinLength ?~ toInteger (length format))
172+
173+-- |
174+-- >>> toSchema (Proxy :: Proxy Day) ^. schemaFormat
175+-- Just "yyyy-mm-dd"
176+instance ToSchema Day where
177+ toNamedSchema _ = timeNamedSchema "Day" "yyyy-mm-dd"
178+
179+-- |
180+-- >>> toSchema (Proxy :: Proxy LocalTime) ^. schemaFormat
181+-- Just "yyyy-mm-ddThh:MM:ss"
182+instance ToSchema LocalTime where
183+ toNamedSchema _ = timeNamedSchema "LocalTime" "yyyy-mm-ddThh:MM:ss"
184+
185+-- |
186+-- >>> toSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat
187+-- Just "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
188+instance ToSchema ZonedTime where
189+ toNamedSchema _ = (Just "ZonedTime", mempty
190+ & schemaType .~ SchemaString
191+ & schemaFormat ?~ "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
192+ & schemaMinLength ?~ toInteger (length ("yyyy-mm-ddThh:MM:ssZ" :: String)))
193+
194+instance ToSchema NominalDiffTime where
195+ toNamedSchema _ = toNamedSchema (Proxy :: Proxy Integer)
196+
197+-- |
198+-- >>> toSchema (Proxy :: Proxy UTCTime) ^. schemaFormat
199+-- Just "yyyy-mm-ddThh:MM:ssZ"
200+instance ToSchema UTCTime where
201+ toNamedSchema _ = timeNamedSchema "UTCTime" "yyyy-mm-ddThh:MM:ssZ"
202+
203+instance ToSchema T.Text where
204+ toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy String)
205+
206+instance ToSchema TL.Text where
207+ toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy String)
208+
209+instance ToSchema IntSet where toNamedSchema _ = toNamedSchema (Proxy :: Proxy (Set Int))
210+
211+-- | NOTE: This schema does not account for the uniqueness of keys.
212+instance ToSchema a => ToSchema (IntMap a) where
213+ toNamedSchema _ = toNamedSchema (Proxy :: Proxy [(Int, a)])
214+
215+instance ToSchema a => ToSchema (Map String a) where
216+ toNamedSchema _ = unnamed $ mempty
217+ & schemaType .~ SchemaObject
218+ & schemaAdditionalProperties ?~ toSchema (Proxy :: Proxy a)
219+
220+instance ToSchema a => ToSchema (Map T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
221+instance ToSchema a => ToSchema (Map TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
222+
223+instance ToSchema a => ToSchema (HashMap String a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
224+instance ToSchema a => ToSchema (HashMap T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
225+instance ToSchema a => ToSchema (HashMap TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
226+
227+instance ToSchema a => ToSchema (Set a) where
228+ toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy [a])
229+ & schemaUniqueItems ?~ True
230+
231+instance ToSchema a => ToSchema (HashSet a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Set a))
232+
233+instance ToSchema All where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy Bool)
234+instance ToSchema Any where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy Bool)
235+instance ToSchema a => ToSchema (Sum a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
236+instance ToSchema a => ToSchema (Product a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
237+instance ToSchema a => ToSchema (First a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
238+instance ToSchema a => ToSchema (Last a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
239+instance ToSchema a => ToSchema (Dual a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
240+
241+-- | Options that specify how to encode your type to Swagger schema.
242+data SchemaOptions = SchemaOptions
243+ { -- | Function applied to field labels. Handy for removing common record prefixes for example.
244+ fieldLabelModifier :: String -> String
245+ -- | Function applied to constructor tags which could be handy for lower-casing them for example.
246+ , constructorTagModifier :: String -> String
247+ -- | Function applied to datatype name.
248+ , datatypeNameModifier :: String -> String
249+ -- | If @'True'@ the constructors of a datatype, with all nullary constructors,
250+ -- will be encoded to a string enumeration schema with the constructor tags as possible values.
251+ , allNullaryToStringTag :: Bool
252+ -- | If @'True'@ direct subschemas will be referenced if possible (rather than inlined).
253+ -- Note that this option does not influence nested schemas, e.g. for these types
254+ --
255+ -- @
256+ -- data Object = Object String deriving Generic
257+ -- instance ToSchema Object
258+ --
259+ -- newtype Objects = Objects [Object] deriving Generic
260+ -- instance ToSchema Objects where
261+ -- toNamedSchema = genericToNamedSchema defaultSchemaOptions
262+ -- { useReferences = False }
263+ -- @
264+ --
265+ -- Schema for @Objects@ __will not__ inline @Object@ schema because
266+ -- it is nested in a @[]@ schema.
267+ , useReferences :: Bool
268+ -- | Hide the field name when a record constructor has only one field, like a newtype.
269+ , unwrapUnaryRecords :: Bool
270+ }
271+
272+-- | Default encoding @'SchemaOptions'@.
273+--
274+-- @
275+-- 'SchemaOptions'
276+-- { 'fieldLabelModifier' = id
277+-- , 'constructorTagModifier' = id
278+-- , 'datatypeNameModifier' = id
279+-- , 'allNullaryToStringTag' = True
280+-- , 'useReferences' = True
281+-- , 'unwrapUnaryRecords' = False
282+-- }
283+-- @
284+defaultSchemaOptions :: SchemaOptions
285+defaultSchemaOptions = SchemaOptions
286+ { fieldLabelModifier = id
287+ , constructorTagModifier = id
288+ , datatypeNameModifier = id
289+ , allNullaryToStringTag = True
290+ , useReferences = True
291+ , unwrapUnaryRecords = False
292+ }
293+
294+-- | Default schema for @'Bounded'@, @'Integral'@ types.
295+toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
296+toSchemaBoundedIntegral _ = mempty
297+ & schemaType .~ SchemaInteger
298+ & schemaMinimum ?~ fromInteger (toInteger (minBound :: a))
299+ & schemaMaximum ?~ fromInteger (toInteger (maxBound :: a))
300+
301+-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
302+genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
303+ ( Bounded a, Integral a
304+ , Generic a, Rep a ~ D1 d f, Datatype d)
305+ => SchemaOptions -> proxy a -> NamedSchema
306+genericToNamedSchemaBoundedIntegral opts proxy
307+ = (gdatatypeSchemaName opts (Proxy :: Proxy d), toSchemaBoundedIntegral proxy)
308+
309+-- | A configurable generic @'Schema'@ creator.
310+genericToSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Schema
311+genericToSchema opts = snd . genericToNamedSchema opts
312+
313+-- | A configurable generic @'NamedSchema'@ creator.
314+-- This function applied to @'defaultSchemaOptions'@
315+-- is used as the default for @'toNamedSchema'@
316+-- when the type is an instance of @'Generic'@.
317+genericToNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> NamedSchema
318+genericToNamedSchema opts _ = gtoNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
319+
320+gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe String
321+gdatatypeSchemaName opts _ = case name of
322+ (c:_) | isAlpha c && isUpper c -> Just name
323+ _ -> Nothing
324+ where
325+ name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
326+
327+nullarySchema :: Schema
328+nullarySchema = mempty
329+ & schemaType .~ SchemaArray
330+ & schemaEnum ?~ [ toJSON () ]
331+
332+instance GToSchema U1 where
333+ gtoNamedSchema _ _ _ = unnamed nullarySchema
334+
335+instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
336+ gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f) . gtoSchema opts (Proxy :: Proxy g)
337+
338+instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
339+ gtoNamedSchema opts _ s = (schemaName, gtoSchema opts (Proxy :: Proxy f) s)
340+ where
341+ schemaName = gdatatypeSchemaName opts (Proxy :: Proxy d)
342+
343+instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
344+ gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f)
345+
346+-- | Single field constructor.
347+instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
348+ gtoNamedSchema opts _ s
349+ | unwrapUnaryRecords opts = fieldSchema
350+ | otherwise =
351+ case schema ^. schemaItems of
352+ Just (SchemaItemsArray [_]) -> fieldSchema
353+ _ -> unnamed schema
354+ where
355+ schema = gtoSchema opts (Proxy :: Proxy (S1 s f)) s
356+ fieldSchema = gtoNamedSchema opts (Proxy :: Proxy f) s
357+
358+gtoSchemaRef :: GToSchema f => SchemaOptions -> proxy f -> Referenced Schema
359+gtoSchemaRef opts proxy = case gtoNamedSchema opts proxy mempty of
360+ (Just name, _)
361+ | useReferences opts -> Ref (Reference ("#/definitions/" <> T.pack name))
362+ (_, schema) -> Inline schema
363+
364+appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems
365+appendItem x Nothing = Just (SchemaItemsArray [x])
366+appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs))
367+appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject"
368+
369+withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions -> proxy s f -> Bool -> Schema -> Schema
370+withFieldSchema opts _ isRequiredField schema
371+ | T.null fieldName = schema
372+ & schemaType .~ SchemaArray
373+ & schemaItems %~ appendItem fieldSchemaRef
374+ | otherwise = schema
375+ & schemaType .~ SchemaObject
376+ & schemaProperties . at fieldName ?~ fieldSchemaRef
377+ & if isRequiredField
378+ then schemaRequired %~ (fieldName :)
379+ else id
380+ where
381+ fieldName = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
382+ fieldSchemaRef = gtoSchemaRef opts (Proxy :: Proxy f)
383+
384+-- | Optional record fields.
385+instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
386+ gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
387+
388+-- | Record fields.
389+instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
390+ gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
391+
392+instance ToSchema c => GToSchema (K1 i c) where
393+ gtoNamedSchema _ _ _ = toNamedSchema (Proxy :: Proxy c)
394+
395+instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
396+ gtoNamedSchema opts _ s
397+ | allNullaryToStringTag opts && allNullary = unnamed (toStringTag sumSchema)
398+ | otherwise = unnamed sumSchema
399+ where
400+ (All allNullary, sumSchema) = gsumToSchema opts (Proxy :: Proxy (f :+: g)) s
401+
402+ toStringTag schema = mempty
403+ & schemaType .~ SchemaString
404+ & schemaEnum ?~ map toJSON (schema ^.. schemaProperties.ifolded.asIndex)
405+
406+type AllNullary = All
407+
408+class GSumToSchema f where
409+ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> (AllNullary, Schema)
410+
411+instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
412+ gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <.> gsumToSchema opts (Proxy :: Proxy g)
413+ where
414+ (f <.> g) s = (a <> b, s'')
415+ where
416+ (a, s') = f s
417+ (b, s'') = g s'
418+
419+gsumConToSchema :: forall c f proxy. Constructor c =>
420+ Bool -> Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> (AllNullary, Schema)
421+gsumConToSchema isNullary tagSchemaRef opts _ schema = (All isNullary, schema
422+ & schemaType .~ SchemaObject
423+ & schemaProperties . at tag ?~ tagSchemaRef
424+ & schemaMaxProperties ?~ 1
425+ & schemaMinProperties ?~ 1)
426+ where
427+ tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
428+
429+instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
430+ gsumToSchema opts = gsumConToSchema False tagSchemaRef opts
431+ where
432+ tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c f))
433+
434+instance Constructor c => GSumToSchema (C1 c U1) where
435+ gsumToSchema opts = gsumConToSchema True tagSchemaRef opts
436+ where
437+ tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c U1))
438+
439+instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
440+ gsumToSchema opts = gsumConToSchema False tagSchemaRef opts
441+ where
442+ tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c (S1 s f)))
443+
444+data Proxy2 a b = Proxy2
445+
446+data Proxy3 a b c = Proxy3
447+