#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#else
#define OVERLAPPABLE_
#endif
module Servant.Swagger.Internal where
import Control.Lens
import Data.Aeson
import Data.Monoid
import Data.Proxy
import qualified Data.Swagger as Swagger
import Data.Swagger hiding (Header)
import Data.Swagger.Declare
import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.TypeLits
import Network.HTTP.Media (MediaType)
import Servant.API
import Servant.Swagger.Internal.TypeLevel.API
class HasSwagger api where
toSwagger :: Proxy api -> Swagger
instance HasSwagger Raw where
toSwagger _ = mempty & paths . at "/" ?~ mempty
subOperations :: (IsSubAPI sub api, HasSwagger sub) =>
Proxy sub
-> Proxy api
-> Traversal' Swagger Operation
subOperations sub _ = operationsOf (toSwagger sub)
mkEndpoint :: forall a cs hs proxy method status.
(ToSchema a, AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
=> FilePath
-> proxy (Verb method status cs (Headers hs a))
-> Swagger
mkEndpoint path proxy
= mkEndpointWithSchemaRef (Just ref) path proxy
& definitions .~ defs
where
(defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
mkEndpointNoContent :: forall nocontent cs hs proxy method status.
(AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
=> FilePath
-> proxy (Verb method status cs (Headers hs nocontent))
-> Swagger
mkEndpointNoContent path proxy
= mkEndpointWithSchemaRef Nothing path proxy
mkEndpointWithSchemaRef :: forall cs hs proxy method status a.
(AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
=> Maybe (Referenced Schema)
-> FilePath
-> proxy (Verb method status cs (Headers hs a))
-> Swagger
mkEndpointWithSchemaRef mref path _ = mempty
& paths.at path ?~
(mempty & method ?~ (mempty
& produces ?~ MimeList contentTypes
& at code ?~ Inline (mempty
& schema .~ mref
& headers .~ responseHeaders)))
where
method = swaggerMethod (Proxy :: Proxy method)
code = fromIntegral (natVal (Proxy :: Proxy status))
contentTypes = allContentType (Proxy :: Proxy cs)
responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs)
addParam :: Param -> Swagger -> Swagger
addParam param = allOperations.parameters %~ (Inline param :)
addConsumes :: [MediaType] -> Swagger -> Swagger
addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))
markdownCode :: Text -> Text
markdownCode s = "`" <> s <> "`"
addDefaultResponse404 :: ParamName -> Swagger -> Swagger
addDefaultResponse404 pname = setResponseWith (\old _new -> alter404 old) 404 (return response404)
where
sname = markdownCode pname
description404 = sname <> " not found"
alter404 = description %~ ((sname <> " or ") <>)
response404 = mempty & description .~ description404
addDefaultResponse400 :: ParamName -> Swagger -> Swagger
addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400)
where
sname = markdownCode pname
description400 = "Invalid " <> sname
alter400 = description %~ (<> (" or " <> sname))
response400 = mempty & description .~ description400
class SwaggerMethod method where
swaggerMethod :: proxy method -> Lens' PathItem (Maybe Operation)
instance SwaggerMethod 'GET where swaggerMethod _ = get
instance SwaggerMethod 'PUT where swaggerMethod _ = put
instance SwaggerMethod 'POST where swaggerMethod _ = post
instance SwaggerMethod 'DELETE where swaggerMethod _ = delete
instance SwaggerMethod 'OPTIONS where swaggerMethod _ = options
instance SwaggerMethod 'HEAD where swaggerMethod _ = head_
instance SwaggerMethod 'PATCH where swaggerMethod _ = patch
instance OVERLAPPABLE_ (ToSchema a, AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs a) where
toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a)))
instance OVERLAPPABLE_ (ToSchema a, AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)
=> HasSwagger (Verb method status cs (Headers hs a)) where
toSwagger = mkEndpoint "/"
instance (AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs NoContent) where
toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] NoContent)))
instance (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)
=> HasSwagger (Verb method status cs (Headers hs NoContent)) where
toSwagger = mkEndpointNoContent "/"
instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where
toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b)
instance (HasSwagger sub) => HasSwagger (Vault :> sub) where
toSwagger _ = toSwagger (Proxy :: Proxy sub)
instance (HasSwagger sub) => HasSwagger (IsSecure :> sub) where
toSwagger _ = toSwagger (Proxy :: Proxy sub)
instance (HasSwagger sub) => HasSwagger (RemoteHost :> sub) where
toSwagger _ = toSwagger (Proxy :: Proxy sub)
instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where
toSwagger _ = toSwagger (Proxy :: Proxy sub)
instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where
toSwagger _ = toSwagger (Proxy :: Proxy sub)
instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where
toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))
where
piece = symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (Capture sym a :> sub) where
toSwagger _ = toSwagger (Proxy :: Proxy sub)
& addParam param
& prependPath capture
& addDefaultResponse404 tname
where
pname = symbolVal (Proxy :: Proxy sym)
tname = Text.pack pname
capture = "{" <> pname <> "}"
param = mempty
& name .~ tname
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamPath
& paramSchema .~ toParamSchema (Proxy :: Proxy a))
#if MIN_VERSION_servant(0,8,1)
instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (CaptureAll sym a :> sub) where
toSwagger _ = toSwagger (Proxy :: Proxy (Capture sym a :> sub))
#endif
instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (QueryParam sym a :> sub) where
toSwagger _ = toSwagger (Proxy :: Proxy sub)
& addParam param
& addDefaultResponse400 tname
where
tname = Text.pack (symbolVal (Proxy :: Proxy sym))
param = mempty
& name .~ tname
& schema .~ ParamOther (mempty
& in_ .~ ParamQuery
& paramSchema .~ toParamSchema (Proxy :: Proxy a))
instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (QueryParams sym a :> sub) where
toSwagger _ = toSwagger (Proxy :: Proxy sub)
& addParam param
& addDefaultResponse400 tname
where
tname = Text.pack (symbolVal (Proxy :: Proxy sym))
param = mempty
& name .~ tname
& schema .~ ParamOther (mempty
& in_ .~ ParamQuery
& paramSchema .~ (mempty
& type_ .~ SwaggerArray
& items ?~ SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a))))
instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub) where
toSwagger _ = toSwagger (Proxy :: Proxy sub)
& addParam param
& addDefaultResponse400 tname
where
tname = Text.pack (symbolVal (Proxy :: Proxy sym))
param = mempty
& name .~ tname
& schema .~ ParamOther (mempty
& in_ .~ ParamQuery
& allowEmptyValue ?~ True
& paramSchema .~ (toParamSchema (Proxy :: Proxy Bool)
& default_ ?~ toJSON False))
instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (Header sym a :> sub) where
toSwagger _ = toSwagger (Proxy :: Proxy sub)
& addParam param
& addDefaultResponse400 tname
where
tname = Text.pack (symbolVal (Proxy :: Proxy sym))
param = mempty
& name .~ tname
& schema .~ ParamOther (mempty
& in_ .~ ParamHeader
& paramSchema .~ toParamSchema (Proxy :: Proxy a))
instance (ToSchema a, AllAccept cs, HasSwagger sub) => HasSwagger (ReqBody cs a :> sub) where
toSwagger _ = toSwagger (Proxy :: Proxy sub)
& addParam param
& addConsumes (allContentType (Proxy :: Proxy cs))
& addDefaultResponse400 tname
& definitions %~ (<> defs)
where
tname = "body"
(defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
param = mempty
& name .~ tname
& required ?~ True
& schema .~ ParamBody ref
class AllAccept cs where
allContentType :: Proxy cs -> [MediaType]
instance AllAccept '[] where
allContentType _ = []
instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where
allContentType _ = contentType (Proxy :: Proxy c) : allContentType (Proxy :: Proxy cs)
class ToResponseHeader h where
toResponseHeader :: Proxy h -> (HeaderName, Swagger.Header)
instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where
toResponseHeader _ = (hname, Swagger.Header Nothing hschema)
where
hname = Text.pack (symbolVal (Proxy :: Proxy sym))
hschema = toParamSchema (Proxy :: Proxy a)
class AllToResponseHeader hs where
toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName Swagger.Header
instance AllToResponseHeader '[] where
toAllResponseHeaders _ = mempty
instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where
toAllResponseHeaders _ = InsOrdHashMap.insert hname header hdrs
where
(hname, header) = toResponseHeader (Proxy :: Proxy h)
hdrs = toAllResponseHeaders (Proxy :: Proxy hs)
instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where
toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs)