{-# LANGUAGE NoPolyKinds #-}
module Yam.Swagger(
SwaggerConfig(..)
, serveWithContextAndSwagger
, baseInfo
, SwaggerTag
) where
import Control.Lens hiding (Context)
import Data.Reflection
import Data.Swagger
import Data.Version (showVersion)
import GHC.TypeLits
import Salak
import Servant
import Servant.Client
import Servant.Swagger
import Servant.Swagger.UI
import Yam.Prelude
data SwaggerConfig = SwaggerConfig
{ urlDir :: String
, urlSchema :: String
, enabled :: Bool
} deriving (Eq, Show)
instance FromProp SwaggerConfig where
fromProp = SwaggerConfig
<$> "dir" .?= "swagger-ui"
<*> "schema" .?= "swagger-ui.json"
<*> "enabled" .?= True
serveWithContextAndSwagger
:: forall api context. (HasSwagger api, HasServer api context)
=> SwaggerConfig
-> (Swagger -> Swagger)
-> Proxy api
-> Context context
-> ServerT api Handler
-> Application
serveWithContextAndSwagger SwaggerConfig{..} g5 proxy cxt api =
if enabled
then reifySymbol urlDir $ \pd -> reifySymbol urlSchema $ \ps ->
serveWithContext (go proxy pd ps) cxt (swaggerSchemaUIServer (g5 $ toSwagger proxy) :<|> api)
else serveWithContext proxy cxt api
where
go :: forall dir schema. Proxy api -> Proxy dir -> Proxy schema -> Proxy (SwaggerSchemaUI dir schema :<|> api)
go _ _ _ = Proxy
baseInfo
:: String
-> Text
-> Version
-> Int
-> Swagger
-> Swagger
baseInfo hostName n v p s = s
& info . title .~ n
& info . version .~ pack (showVersion v)
& host ?~ Host hostName (Just $ fromIntegral p)
data SwaggerTag (name :: Symbol) (desp :: Symbol)
instance HasServer api ctx
=> HasServer (SwaggerTag name desp :> api) ctx where
type ServerT (SwaggerTag name desp :> api) m = ServerT api m
route _ = route (Proxy @api)
hoistServerWithContext _ = hoistServerWithContext (Proxy @api)
instance HasClient m api
=> HasClient m (SwaggerTag name desp :> api) where
type Client m (SwaggerTag name desp :> api) = Client m api
clientWithRoute _ _ = clientWithRoute (Proxy @m) (Proxy @api)
hoistClientMonad pm _ = hoistClientMonad pm (Proxy @api)
instance (HasSwagger api, KnownSymbol name, KnownSymbol desp)
=> HasSwagger (SwaggerTag name desp :> api) where
toSwagger _ = toSwagger (Proxy @api) & applyTags [tag]
where
tag = Tag (go (Proxy @name)) (g2 $ go (Proxy @desp)) Nothing
go :: forall a. KnownSymbol a => Proxy a -> Text
go = pack . symbolVal
g2 "" = Nothing
g2 a = Just a