module Mig.Swagger (
SwaggerConfig (..),
withSwagger,
swagger,
Default (..),
DefaultInfo (..),
addDefaultInfo,
writeOpenApi,
printOpenApi,
) where
import Control.Lens ((&), (.~), (?~))
import Control.Monad.IO.Class (MonadIO)
import Data.Aeson qualified as Json
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy.Char8 qualified as BL
import Data.Default
import Data.OpenApi (OpenApi)
import Data.OpenApi qualified as OA
import Data.Text (Text)
import Data.Text qualified as Text
import FileEmbedLzma
import Mig.Core
import Text.Blaze (ToMarkup (..))
import Text.Blaze.Html (Html)
import Web.HttpApiData
withSwagger :: (MonadIO m) => SwaggerConfig m -> Server m -> Server m
withSwagger :: forall (m :: * -> *).
MonadIO m =>
SwaggerConfig m -> Server m -> Server m
withSwagger SwaggerConfig m
config Server m
server =
forall a. Monoid a => [a] -> a
mconcat
[ Server m
server
, forall (m :: * -> *).
MonadIO m =>
SwaggerConfig m -> m OpenApi -> Server m
swagger SwaggerConfig m
config (forall (f :: * -> *) a. Applicative f => a -> f a
pure OpenApi
openApi)
]
where
openApi :: OpenApi
openApi = forall (m :: * -> *). Server m -> OpenApi
toOpenApi Server m
server
printOpenApi :: Server m -> IO ()
printOpenApi :: forall (m :: * -> *). Server m -> IO ()
printOpenApi Server m
server = ByteString -> IO ()
BL.putStrLn forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encodePretty forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Server m -> OpenApi
toOpenApi Server m
server
writeOpenApi :: FilePath -> Server m -> IO ()
writeOpenApi :: forall (m :: * -> *). FilePath -> Server m -> IO ()
writeOpenApi FilePath
file Server m
server = FilePath -> ByteString -> IO ()
BL.writeFile FilePath
file forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encodePretty forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Server m -> OpenApi
toOpenApi Server m
server
data DefaultInfo = DefaultInfo
{ DefaultInfo -> Text
title :: Text
, DefaultInfo -> Text
description :: Text
, DefaultInfo -> Text
version :: Text
}
addDefaultInfo :: DefaultInfo -> OpenApi -> OpenApi
addDefaultInfo :: DefaultInfo -> OpenApi -> OpenApi
addDefaultInfo DefaultInfo
appInfo =
forall s a. HasInfo s a => Lens' s a
OA.info
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ( forall a. Monoid a => a
mempty
forall a b. a -> (a -> b) -> b
& forall s a. HasTitle s a => Lens' s a
OA.title forall s t a b. ASetter s t a b -> b -> s -> t
.~ DefaultInfo
appInfo.title
forall a b. a -> (a -> b) -> b
& forall s a. HasDescription s a => Lens' s a
OA.description forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ DefaultInfo
appInfo.description
forall a b. a -> (a -> b) -> b
& forall s a. HasVersion s a => Lens' s a
OA.version forall s t a b. ASetter s t a b -> b -> s -> t
.~ DefaultInfo
appInfo.version
)
instance Default DefaultInfo where
def :: DefaultInfo
def = Text -> Text -> Text -> DefaultInfo
DefaultInfo Text
"" Text
"" Text
""
data SwaggerConfig m = SwaggerConfig
{ forall (m :: * -> *). SwaggerConfig m -> Path
staticDir :: Path
, forall (m :: * -> *). SwaggerConfig m -> Path
swaggerFile :: Path
, forall (m :: * -> *). SwaggerConfig m -> OpenApi -> m OpenApi
mapSchema :: OpenApi -> m OpenApi
}
instance (Applicative m) => Default (SwaggerConfig m) where
def :: SwaggerConfig m
def =
SwaggerConfig
{ staticDir :: Path
staticDir = Path
"swagger-ui"
, swaggerFile :: Path
swaggerFile = Path
"swagger.json"
, mapSchema :: OpenApi -> m OpenApi
mapSchema = forall (f :: * -> *) a. Applicative f => a -> f a
pure
}
swagger :: forall m. (MonadIO m) => SwaggerConfig m -> m OpenApi -> Server m
swagger :: forall (m :: * -> *).
MonadIO m =>
SwaggerConfig m -> m OpenApi -> Server m
swagger SwaggerConfig m
config m OpenApi
getOpenApi =
forall a. Monoid a => [a] -> a
mconcat
[ SwaggerConfig m
config.swaggerFile forall a. ToServer a => Path -> a -> Server (MonadOf a)
/. Get m (Resp Json Value)
getSchema
, SwaggerConfig m
config.staticDir
forall a. ToServer a => Path -> a -> Server (MonadOf a)
/. forall a. Monoid a => [a] -> a
mconcat
[ Path
"index.html" forall a. ToServer a => Path -> a -> Server (MonadOf a)
/. Get m (Resp Html Html)
getIndex
, forall (m :: * -> *).
MonadIO m =>
[(FilePath, ByteString)] -> Server m
staticFiles [(FilePath, ByteString)]
swaggerFiles
, forall a. ToServer a => a -> Server (MonadOf a)
toServer Get m (Resp Html Html)
getIndex
]
]
where
getSchema :: Get m (Resp Json Json.Value)
getSchema :: Get m (Resp Json Value)
getSchema = forall {k} {k1} (method :: k) (m :: k1 -> *) (a :: k1).
m a -> Send method m a
Send forall a b. (a -> b) -> a -> b
$ forall a. IsResp a => RespBody a -> a
ok forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
Json.toJSON forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SwaggerConfig m
config.mapSchema forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m OpenApi
getOpenApi)
getIndex :: Get m (Resp Html Html)
getIndex :: Get m (Resp Html Html)
getIndex = forall {k} {k1} (method :: k) (m :: k1 -> *) (a :: k1).
m a -> Send method m a
Send forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall a. IsResp a => RespBody a -> a
ok forall a b. (a -> b) -> a -> b
$
forall a. ToMarkup a => a -> Html
preEscapedToMarkup forall a b. (a -> b) -> a -> b
$
Text -> Text -> Text -> Text
Text.replace Text
"MIG_SWAGGER_UI_SCHEMA" (forall a. ToHttpApiData a => a -> Text
toUrlPiece SwaggerConfig m
config.swaggerFile) forall a b. (a -> b) -> a -> b
$
Text -> Text -> Text -> Text
Text.replace Text
"MIG_SWAGGER_UI_DIR" (forall a. ToHttpApiData a => a -> Text
toUrlPiece SwaggerConfig m
config.staticDir) forall a b. (a -> b) -> a -> b
$
Text
indexTemplate
swaggerFiles :: [(FilePath, ByteString)]
swaggerFiles :: [(FilePath, ByteString)]
swaggerFiles = $(embedRecursiveDir "swagger-ui-dist-5.0.0")
indexTemplate :: Text
indexTemplate :: Text
indexTemplate = $(embedText "index.html.tmpl")