module Data.Swagger.Internal.Schema where
import Control.Lens
import Data.Data.Lens (template)
import Control.Monad
import Control.Monad.Writer
import Data.Aeson
import Data.Char
import Data.Data (Data)
import Data.Foldable (traverse_)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import "unordered-containers" Data.HashSet (HashSet)
import Data.Int
import Data.IntSet (IntSet)
import Data.IntMap (IntMap)
import Data.Map (Map)
import Data.Monoid
import Data.Proxy
import Data.Scientific (Scientific)
import Data.Set (Set)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Time
import Data.Word
import GHC.Generics
import Data.Swagger.Declare
import Data.Swagger.Internal
import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
import Data.Swagger.Lens
import Data.Swagger.SchemaOptions
type NamedSchema = (Maybe T.Text, Schema)
type Definitions = HashMap T.Text Schema
unnamed :: Schema -> NamedSchema
unnamed schema = (Nothing, schema)
named :: T.Text -> Schema -> NamedSchema
named name schema = (Just name, schema)
plain :: Schema -> Declare Definitions NamedSchema
plain = pure . unnamed
unname :: NamedSchema -> NamedSchema
unname (_, schema) = (Nothing, schema)
rename :: Maybe T.Text -> NamedSchema -> NamedSchema
rename name (_, schema) = (name, schema)
class ToSchema a where
declareNamedSchema :: proxy a -> Declare Definitions NamedSchema
default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare Definitions NamedSchema
declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
declareSchema :: ToSchema a => proxy a -> Declare Definitions Schema
declareSchema = fmap snd . declareNamedSchema
toNamedSchema :: ToSchema a => proxy a -> NamedSchema
toNamedSchema = undeclare . declareNamedSchema
schemaName :: ToSchema a => proxy a -> Maybe T.Text
schemaName = fst . toNamedSchema
toSchema :: ToSchema a => proxy a -> Schema
toSchema = snd . toNamedSchema
toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
toSchemaRef = undeclare . declareSchemaRef
declareSchemaRef :: ToSchema a => proxy a -> Declare Definitions (Referenced Schema)
declareSchemaRef proxy = do
case toNamedSchema proxy of
(Just name, schema) -> do
known <- looks (HashMap.member name)
when (not known) $ do
declare [(name, schema)]
void $ declareNamedSchema proxy
return $ Ref (Reference name)
_ -> Inline <$> declareSchema proxy
inlineSchemasWhen :: Data s => (T.Text -> Bool) -> Definitions -> s -> s
inlineSchemasWhen p defs = template %~ deref
where
deref r@(Ref (Reference name))
| p name =
case HashMap.lookup name defs of
Just schema -> Inline (inlineSchemasWhen p defs schema)
Nothing -> r
| otherwise = r
deref (Inline schema) = Inline (inlineSchemasWhen p defs schema)
inlineSchemas :: Data s => [T.Text] -> Definitions -> s -> s
inlineSchemas names = inlineSchemasWhen (`elem` names)
inlineAllSchemas :: Data s => Definitions -> s -> s
inlineAllSchemas = inlineSchemasWhen (const True)
toInlinedSchema :: ToSchema a => proxy a -> Schema
toInlinedSchema proxy = inlineAllSchemas defs schema
where
(defs, schema) = runDeclare (declareSchema proxy) mempty
inlineNonRecursiveSchemas :: Data s => Definitions -> s -> s
inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
where
nonRecursive name =
case HashMap.lookup name defs of
Just schema -> name `notElem` execDeclare (usedNames schema) mempty
Nothing -> False
usedNames schema = traverse_ schemaRefNames (schema ^.. template)
schemaRefNames :: Referenced Schema -> Declare [T.Text] ()
schemaRefNames ref = case ref of
Ref (Reference name) -> do
seen <- looks (name `elem`)
when (not seen) $ do
declare [name]
traverse_ usedNames (HashMap.lookup name defs)
Inline subschema -> usedNames subschema
class GToSchema (f :: * -> *) where
gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare Definitions NamedSchema
instance ToSchema a => ToSchema [a] where
declareNamedSchema _ = do
ref <- declareSchemaRef (Proxy :: Proxy a)
return $ unnamed $ mempty
& schemaType .~ SwaggerArray
& schemaItems ?~ SwaggerItemsObject ref
instance ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Int32 where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Int64 where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Word where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Word8 where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Char where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema a => ToSchema (Maybe a) where
declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
instance ToSchema ()
instance (ToSchema a, ToSchema b) => ToSchema (a, b)
instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
timeSchema :: T.Text -> Schema
timeSchema format = mempty
& schemaType .~ SwaggerString
& schemaFormat ?~ format
instance ToSchema Day where
declareNamedSchema _ = pure $ named "Day" (timeSchema "date")
instance ToSchema LocalTime where
declareNamedSchema _ = pure $ named "LocalTime" (timeSchema "yyyy-mm-ddThh:MM:ss")
instance ToSchema ZonedTime where
declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
instance ToSchema NominalDiffTime where
declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)
instance ToSchema UTCTime where
declareNamedSchema _ = pure $ named "UTCTime" (timeSchema "yyyy-mm-ddThh:MM:ssZ")
instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
instance ToSchema a => ToSchema (IntMap a) where
declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
instance ToSchema a => ToSchema (Map String a) where
declareNamedSchema _ = do
schema <- declareSchema (Proxy :: Proxy a)
return $ unnamed $ mempty
& schemaType .~ SwaggerObject
& schemaAdditionalProperties ?~ schema
instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
instance ToSchema a => ToSchema (Map TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
instance ToSchema a => ToSchema (HashMap String a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
instance ToSchema a => ToSchema (HashMap T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
instance ToSchema a => ToSchema (Set a) where
declareNamedSchema _ = do
schema <- declareSchema (Proxy :: Proxy [a])
return $ unnamed $ schema
& schemaUniqueItems ?~ True
instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema a => ToSchema (Sum a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
instance ToSchema a => ToSchema (Product a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
toSchemaBoundedIntegral _ = mempty
& schemaType .~ SwaggerInteger
& schemaMinimum ?~ fromInteger (toInteger (minBound :: a))
& schemaMaximum ?~ fromInteger (toInteger (maxBound :: a))
genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
( Bounded a, Integral a
, Generic a, Rep a ~ D1 d f, Datatype d)
=> SchemaOptions -> proxy a -> NamedSchema
genericToNamedSchemaBoundedIntegral opts proxy
= (gdatatypeSchemaName opts (Proxy :: Proxy d), toSchemaBoundedIntegral proxy)
genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare Definitions Schema
genericDeclareSchema opts proxy = snd <$> genericDeclareNamedSchema opts proxy
genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare Definitions NamedSchema
genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
gdatatypeSchemaName opts _ = case name of
(c:_) | isAlpha c && isUpper c -> Just (T.pack name)
_ -> Nothing
where
name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
paramSchemaToNamedSchema :: forall a d f proxy.
(ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
=> SchemaOptions -> proxy a -> NamedSchema
paramSchemaToNamedSchema opts proxy = (gdatatypeSchemaName opts (Proxy :: Proxy d), paramSchemaToSchema proxy)
paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
paramSchemaToSchema _ = mempty & schemaParamSchema .~ toParamSchema (Proxy :: Proxy a)
nullarySchema :: Schema
nullarySchema = mempty
& schemaType .~ SwaggerArray
& schemaEnum ?~ [ toJSON () ]
gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare Definitions Schema
gdeclareSchema opts proxy = snd <$> gdeclareNamedSchema opts proxy mempty
instance GToSchema U1 where
gdeclareNamedSchema _ _ _ = plain nullarySchema
instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
gdeclareNamedSchema opts _ schema = do
(_, gschema) <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema
gdeclareNamedSchema opts (Proxy :: Proxy f) gschema
instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s
where
name = gdatatypeSchemaName opts (Proxy :: Proxy d)
instance GToSchema f => GToSchema (C1 c f) where
gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f)
instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
gdeclareNamedSchema opts _ s
| unwrapUnaryRecords opts = fieldSchema
| otherwise = do
(_, schema) <- recordSchema
case schema ^. schemaItems of
Just (SwaggerItemsArray [_]) -> fieldSchema
_ -> pure (unnamed schema)
where
recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare Definitions (Referenced Schema)
gdeclareSchemaRef opts proxy = do
case gtoNamedSchema opts proxy of
(Just name, schema) -> do
known <- looks (HashMap.member name)
when (not known) $ do
declare [(name, schema)]
void $ gdeclareNamedSchema opts proxy mempty
return $ Ref (Reference name)
_ -> Inline <$> gdeclareSchema opts proxy
appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema)
appendItem x Nothing = Just (SwaggerItemsArray [x])
appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (x:xs))
appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
SchemaOptions -> proxy s f -> Bool -> Schema -> Declare Definitions Schema
withFieldSchema opts _ isRequiredField schema = do
ref <- gdeclareSchemaRef opts (Proxy :: Proxy f)
return $
if T.null fname
then schema
& schemaType .~ SwaggerArray
& schemaItems %~ appendItem ref
else schema
& schemaType .~ SwaggerObject
& schemaProperties . at fname ?~ ref
& if isRequiredField
then schemaRequired %~ (fname :)
else id
where
fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
instance (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
instance (Selector s, GToSchema f) => GToSchema (S1 s f) where
gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
instance ToSchema c => GToSchema (K1 i (Maybe c)) where
gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
instance ToSchema c => GToSchema (K1 i c) where
gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
gdeclareNamedSchema opts _ s
| allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
| otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
where
declareSumSchema = gsumToSchema opts (Proxy :: Proxy (f :+: g)) s
(sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
toStringTag schema = mempty
& schemaType .~ SwaggerString
& schemaEnum ?~ map toJSON (schema ^.. schemaProperties.ifolded.asIndex)
type AllNullary = All
class GSumToSchema f where
gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare Definitions) Schema
instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <=< gsumToSchema opts (Proxy :: Proxy g)
gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
SchemaOptions -> proxy (C1 c f) -> Schema -> Declare Definitions Schema
gsumConToSchema opts _ schema = do
ref <- gdeclareSchemaRef opts (Proxy :: Proxy (C1 c f))
return $ schema
& schemaType .~ SwaggerObject
& schemaProperties . at tag ?~ ref
& schemaMaxProperties ?~ 1
& schemaMinProperties ?~ 1
where
tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
instance (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
gsumToSchema opts proxy schema = do
tell (All False)
lift $ gsumConToSchema opts proxy schema
instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
gsumToSchema opts proxy schema = do
tell (All False)
lift $ gsumConToSchema opts proxy schema
instance Constructor c => GSumToSchema (C1 c U1) where
gsumToSchema opts proxy = lift . gsumConToSchema opts proxy
data Proxy2 a b = Proxy2
data Proxy3 a b c = Proxy3