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 =
  [Server m] -> Server m
forall a. Monoid a => [a] -> a
mconcat
    [ Server m
server
    , SwaggerConfig m -> m OpenApi -> Server m
forall (m :: * -> *).
MonadIO m =>
SwaggerConfig m -> m OpenApi -> Server m
swagger SwaggerConfig m
config (OpenApi -> m OpenApi
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OpenApi
openApi)
    ]
  where
    openApi :: OpenApi
openApi = Server m -> 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 (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ OpenApi -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty (OpenApi -> ByteString) -> OpenApi -> ByteString
forall a b. (a -> b) -> a -> b
$ Server m -> OpenApi
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 (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ OpenApi -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty (OpenApi -> ByteString) -> OpenApi -> ByteString
forall a b. (a -> b) -> a -> b
$ Server m -> OpenApi
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 =
  (Info -> Identity Info) -> OpenApi -> Identity OpenApi
forall s a. HasInfo s a => Lens' s a
Lens' OpenApi Info
OA.info
    ((Info -> Identity Info) -> OpenApi -> Identity OpenApi)
-> Info -> OpenApi -> OpenApi
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ( Info
forall a. Monoid a => a
mempty
          Info -> (Info -> Info) -> Info
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> Info -> Identity Info
forall s a. HasTitle s a => Lens' s a
Lens' Info Text
OA.title ((Text -> Identity Text) -> Info -> Identity Info)
-> Text -> Info -> Info
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DefaultInfo
appInfo.title
          Info -> (Info -> Info) -> Info
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Info -> Identity Info
forall s a. HasDescription s a => Lens' s a
Lens' Info (Maybe Text)
OA.description ((Maybe Text -> Identity (Maybe Text)) -> Info -> Identity Info)
-> Text -> Info -> Info
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ DefaultInfo
appInfo.description
          Info -> (Info -> Info) -> Info
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> Info -> Identity Info
forall s a. HasVersion s a => Lens' s a
Lens' Info Text
OA.version ((Text -> Identity Text) -> Info -> Identity Info)
-> Text -> Info -> Info
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 = OpenApi -> m OpenApi
forall a. a -> m a
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 =
  [Server m] -> Server m
forall a. Monoid a => [a] -> a
mconcat
    [ SwaggerConfig m
config.swaggerFile Path
-> Get m (Resp Json Value)
-> Server (MonadOf (Get m (Resp Json Value)))
forall a. ToServer a => Path -> a -> Server (MonadOf a)
/. Get m (Resp Json Value)
getSchema
    , SwaggerConfig m
config.staticDir
        Path -> Server m -> Server (MonadOf (Server m))
forall a. ToServer a => Path -> a -> Server (MonadOf a)
/. [Server m] -> Server m
forall a. Monoid a => [a] -> a
mconcat
          [ Path
"index.html" Path
-> Get m (Resp Html Html)
-> Server (MonadOf (Get m (Resp Html Html)))
forall a. ToServer a => Path -> a -> Server (MonadOf a)
/. Get m (Resp Html Html)
getIndex
          , [(FilePath, ByteString)] -> Server m
forall (m :: * -> *).
MonadIO m =>
[(FilePath, ByteString)] -> Server m
staticFiles [(FilePath, ByteString)]
swaggerFiles
          , Get m (Resp Html Html) -> Server (MonadOf (Get m (Resp Html Html)))
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 = m (Resp Json Value) -> Get m (Resp Json Value)
forall {k} {k1} (method :: k) (m :: k1 -> *) (a :: k1).
m a -> Send method m a
Send (m (Resp Json Value) -> Get m (Resp Json Value))
-> m (Resp Json Value) -> Get m (Resp Json Value)
forall a b. (a -> b) -> a -> b
$ Value -> Resp Json Value
RespBody (Resp Json Value) -> Resp Json Value
forall a. IsResp a => RespBody a -> a
ok (Value -> Resp Json Value)
-> (OpenApi -> Value) -> OpenApi -> Resp Json Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpenApi -> Value
forall a. ToJSON a => a -> Value
Json.toJSON (OpenApi -> Resp Json Value) -> m OpenApi -> m (Resp Json Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SwaggerConfig m
config.mapSchema (OpenApi -> m OpenApi) -> m OpenApi -> m OpenApi
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 = m (Resp Html Html) -> Get m (Resp Html Html)
forall {k} {k1} (method :: k) (m :: k1 -> *) (a :: k1).
m a -> Send method m a
Send (m (Resp Html Html) -> Get m (Resp Html Html))
-> m (Resp Html Html) -> Get m (Resp Html Html)
forall a b. (a -> b) -> a -> b
$ do
      Resp Html Html -> m (Resp Html Html)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resp Html Html -> m (Resp Html Html))
-> Resp Html Html -> m (Resp Html Html)
forall a b. (a -> b) -> a -> b
$
        RespBody (Resp Html Html) -> Resp Html Html
forall a. IsResp a => RespBody a -> a
ok (RespBody (Resp Html Html) -> Resp Html Html)
-> RespBody (Resp Html Html) -> Resp Html Html
forall a b. (a -> b) -> a -> b
$
          Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToMarkup (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$
            HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"MIG_SWAGGER_UI_SCHEMA" (Path -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece SwaggerConfig m
config.swaggerFile) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
              HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"MIG_SWAGGER_UI_DIR" (Path -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece SwaggerConfig m
config.staticDir) (Text -> Text) -> Text -> Text
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")