module Mig.Swagger (
  SwaggerConfig (..),
  withSwagger,
  swagger,

  -- * utils
  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

-- | Appends swagger UI to server
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

-- | Prints openapi schema file to stdout
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

-- | Writes openapi schema to file
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

-- | Default info that is often added to OpenApi schema
data DefaultInfo = DefaultInfo
  { DefaultInfo -> Text
title :: Text
  , DefaultInfo -> Text
description :: Text
  , DefaultInfo -> Text
version :: Text
  }

{-| Adds most common used info to OpenApi schema. Use this function
in the @mapSchema@ field of the @SwaggerConfig@.
-}
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
""

-- | Swagger config
data SwaggerConfig m = SwaggerConfig
  { forall (m :: * -> *). SwaggerConfig m -> Path
staticDir :: Path
  -- ^ path to server swagger (default is "/swagger-ui")
  , forall (m :: * -> *). SwaggerConfig m -> Path
swaggerFile :: Path
  -- ^ swagger file name (default is "swaggger.json")
  , forall (m :: * -> *). SwaggerConfig m -> OpenApi -> m OpenApi
mapSchema :: OpenApi -> m OpenApi
  -- ^ apply transformation to OpenApi schema on serving OpenApi schema.
  -- it is useful to add additional info or set current date in the examples
  -- or apply any real-time transformation.
  }

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 server. It serves static files and injects OpenApi schema
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")