{-# LANGUAGE NoPolyKinds #-} module Yam.Web.Swagger( SwaggerConfig(..) , mkServeWithSwagger , YamSettings(..) , defaultYamSettings ) where import Control.Lens hiding (Context) import Data.Aeson import Data.Aeson.Types (typeMismatch) import Data.Default import Data.Maybe import Data.Reflection import Data.Swagger import Data.Text (Text) import Data.Vault.Lazy import GHC.TypeLits import Network.Wai import Servant import Servant.Swagger import Servant.Swagger.UI import Yam.Web.Internal import Yam.Web.Middleware data SwaggerUIType = Classic | Jensoleg deriving Show data SwaggerConfig = SwaggerConfig { uiType :: SwaggerUIType , uiPath :: String , apiPath :: String , enabled :: Bool , apiTitle :: Text , apiVersion :: Text , contractName :: Maybe Text , contractEmail :: Maybe Text } deriving Show instance FromJSON SwaggerUIType where parseJSON v = go <$> parseJSON v where go :: Text -> SwaggerUIType go "default" = Classic go _ = Jensoleg instance FromJSON SwaggerConfig where parseJSON (Object v) = SwaggerConfig <$> v .:? "ui-type" .!= Classic <*> v .:? "ui-path" .!= "swagger-ui.html" <*> v .:? "api-path" .!= "swagger.json" <*> v .:? "enabled" .!= True <*> v .:? "api-title" .!= "" <*> v .:? "api-version" .!= "1.0.0" <*> v .:? "contract-name" <*> v .:? "contract-email" parseJSON invalid = typeMismatch "SwaggerConfig" invalid instance Default SwaggerConfig where def = fromJust $ decode "{}" swagger :: (HasSwagger api) => SwaggerConfig -> Proxy (SwaggerSchemaUI dir schema :<|> api) -> Proxy api -> Server api -> Server (SwaggerSchemaUI dir schema :<|> api) swagger conf _ proxy api = go (uiType conf) (f conf $ toSwagger proxy) :<|> api where go Jensoleg = jensolegSwaggerSchemaUIServer go _ = swaggerSchemaUIServer f SwaggerConfig{..} s = s & info.title .~ apiTitle & info.version .~ apiVersion & info.contact ?~ Contact contractName Nothing contractEmail mkServeWithSwagger' :: (HasSwagger api, API api) => Vault -> [Middleware] -> SwaggerConfig -> Proxy api -> ServerT api App -> Application mkServeWithSwagger' vault middlewares conf proxy server = if enabled conf then reifyGroup conf $ \p -> mkServe' (\(p0,s0) -> (p,swagger conf p p0 s0)) vault middlewares proxy server else mkServe' id vault middlewares proxy server reifyGroup :: SwaggerConfig -> (forall d s. (KnownSymbol d ,KnownSymbol s)=> Proxy (SwaggerSchemaUI d s :<|> api) -> r) -> r reifyGroup SwaggerConfig{..} f = reifySymbol uiPath $ \pd -> reifySymbol apiPath $ \ps -> f $ group pd ps group :: Proxy dir -> Proxy schema -> Proxy (SwaggerSchemaUI dir schema :<|> api) group _ _ = Proxy data YamSettings = YamSettings { vault :: Vault , middlewares :: [Middleware] , swaggers :: SwaggerConfig } defaultYamSettings :: IO YamSettings defaultYamSettings = do lm <- stdLoggerMiddleware return $ YamSettings empty [lm] def mkServeWithSwagger :: (HasSwagger api, API api) => YamSettings -> Proxy api -> ServerT api App -> Application mkServeWithSwagger YamSettings{..} = mkServeWithSwagger' vault middlewares swaggers