{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}
-----------------------------------------------------------------------------
--
-- Provides 'SwaggerUI' and corresponding 'swaggerUIServer' to embed
-- <http://swagger.io/swagger-ui/ swagger ui> into the application.
--
-- All of UI files are embedded into the binary.
--
-- /An example:/
--
-- @
-- -- | Actual API.
-- type BasicAPI = Get '[PlainText, JSON] Text
--     :\<|> "cat" :> Capture ":name" CatName :> Get '[JSON] Cat
--
-- -- | API type with bells and whistles, i.e. schema file and swagger-ui.
-- type API = 'SwaggerSchemaUI' "swagger-ui" "swagger.json"
--     :\<|> BasicAPI
--
-- -- | Servant server for an API
-- server :: Server API
-- server = 'swaggerSchemaUIServer' swaggerDoc
--     :\<|> (pure "Hello World" :\<|> catEndpoint)
--   where
--     catEndpoint name = pure $ Cat name False
-- @

module Servant.Swagger.UI.Core (
    -- * Swagger UI API
    SwaggerSchemaUI,
    SwaggerSchemaUI',

    -- * Implementation details
    SwaggerUiHtml(..),
    swaggerSchemaUIServerImpl,
    swaggerSchemaUIServerImpl',
    Handler,
    ) where

import Data.ByteString                (ByteString)
import Data.Swagger                   (Swagger)
import GHC.TypeLits                   (KnownSymbol, Symbol, symbolVal)
import Network.Wai.Application.Static (embeddedSettings, staticApp)
import Servant
import Servant.HTML.Blaze             (HTML)
import Text.Blaze                     (ToMarkup (..))

import qualified Data.Text as T

-- | Swagger schema + ui api.
--
-- @SwaggerSchemaUI "swagger-ui" "swagger.json"@ will result into following hierarchy:
--
-- @
-- \/swagger.json
-- \/swagger-ui
-- \/swagger-ui\/index.html
-- \/swagger-ui\/...
-- @
--
type SwaggerSchemaUI (dir :: Symbol) (schema :: Symbol) =
    SwaggerSchemaUI' dir (schema :> Get '[JSON] Swagger)

-- | Use 'SwaggerSchemaUI'' when you need even more control over
-- where @swagger.json@ is served (e.g. subdirectory).
type SwaggerSchemaUI' (dir :: Symbol) (api :: *) =
    api
    :<|> dir :>
        ( Get '[HTML] (SwaggerUiHtml dir api)
        :<|> "index.html" :> Get '[HTML] (SwaggerUiHtml dir api)
        :<|> Raw
        )

-- | Index file for swagger ui.
--
-- It's configured by the location of swagger schema and directory it lives under.
--
-- Implementation detail: the @index.html@ is prepopulated with parameters
-- to find schema file automatically.
data SwaggerUiHtml (dir :: Symbol) (api :: *) = SwaggerUiHtml T.Text

instance (KnownSymbol dir, HasLink api, Link ~ MkLink api Link, IsElem api api)
    => ToMarkup (SwaggerUiHtml dir api)
  where
    toMarkup :: SwaggerUiHtml dir api -> Markup
toMarkup (SwaggerUiHtml Text
template) = Text -> Markup
forall a. ToMarkup a => a -> Markup
preEscapedToMarkup
        (Text -> Markup) -> Text -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
T.replace Text
"SERVANT_SWAGGER_UI_SCHEMA" Text
schema
        (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
T.replace Text
"SERVANT_SWAGGER_UI_DIR" Text
dir
        (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
template
      where
        schema :: Text
schema = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ URI -> String
uriPath (URI -> String) -> (Link -> URI) -> Link -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Link -> URI
linkURI (Link -> String) -> Link -> String
forall a b. (a -> b) -> a -> b
$ Proxy api -> Proxy api -> MkLink api Link
forall endpoint api.
(IsElem endpoint api, HasLink endpoint) =>
Proxy api -> Proxy endpoint -> MkLink endpoint Link
safeLink Proxy api
proxyApi Proxy api
proxyApi
        dir :: Text
dir    = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy dir -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy dir
forall k (t :: k). Proxy t
Proxy :: Proxy dir)
        proxyApi :: Proxy api
proxyApi = Proxy api
forall k (t :: k). Proxy t
Proxy :: Proxy api

swaggerSchemaUIServerImpl
    :: (Monad m, ServerT api m ~ m Swagger)
    => T.Text -> [(FilePath, ByteString)]
    -> Swagger -> ServerT (SwaggerSchemaUI' dir api) m
swaggerSchemaUIServerImpl :: Text
-> [(String, ByteString)]
-> Swagger
-> ServerT (SwaggerSchemaUI' dir api) m
swaggerSchemaUIServerImpl Text
indexTemplate [(String, ByteString)]
files Swagger
swagger
  = Text
-> [(String, ByteString)]
-> ServerT api m
-> ServerT (SwaggerSchemaUI' dir api) m
forall (m :: * -> *) api (dir :: Symbol).
Monad m =>
Text
-> [(String, ByteString)]
-> ServerT api m
-> ServerT (SwaggerSchemaUI' dir api) m
swaggerSchemaUIServerImpl' Text
indexTemplate [(String, ByteString)]
files (ServerT api m -> ServerT (SwaggerSchemaUI' dir api) m)
-> ServerT api m -> ServerT (SwaggerSchemaUI' dir api) m
forall a b. (a -> b) -> a -> b
$ Swagger -> m Swagger
forall (m :: * -> *) a. Monad m => a -> m a
return Swagger
swagger

-- | Use a custom server to serve the Swagger spec source.
swaggerSchemaUIServerImpl'
    :: Monad m
    => T.Text
    -> [(FilePath, ByteString)]
    -> ServerT api m
    -> ServerT (SwaggerSchemaUI' dir api) m
swaggerSchemaUIServerImpl' :: Text
-> [(String, ByteString)]
-> ServerT api m
-> ServerT (SwaggerSchemaUI' dir api) m
swaggerSchemaUIServerImpl' Text
indexTemplate [(String, ByteString)]
files ServerT api m
server
       = ServerT api m
server
    ServerT api m
-> (m (SwaggerUiHtml dir api)
    :<|> (m (SwaggerUiHtml dir api) :<|> Tagged m Application))
-> ServerT api m
   :<|> (m (SwaggerUiHtml dir api)
         :<|> (m (SwaggerUiHtml dir api) :<|> Tagged m Application))
forall a b. a -> b -> a :<|> b
:<|> SwaggerUiHtml dir api -> m (SwaggerUiHtml dir api)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> SwaggerUiHtml dir api
forall (dir :: Symbol) api. Text -> SwaggerUiHtml dir api
SwaggerUiHtml Text
indexTemplate)
    m (SwaggerUiHtml dir api)
-> (m (SwaggerUiHtml dir api) :<|> Tagged m Application)
-> m (SwaggerUiHtml dir api)
   :<|> (m (SwaggerUiHtml dir api) :<|> Tagged m Application)
forall a b. a -> b -> a :<|> b
:<|> SwaggerUiHtml dir api -> m (SwaggerUiHtml dir api)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> SwaggerUiHtml dir api
forall (dir :: Symbol) api. Text -> SwaggerUiHtml dir api
SwaggerUiHtml Text
indexTemplate)
    m (SwaggerUiHtml dir api)
-> Tagged m Application
-> m (SwaggerUiHtml dir api) :<|> Tagged m Application
forall a b. a -> b -> a :<|> b
:<|> Tagged m Application
rest
  where
    rest :: Tagged m Application
rest = Application -> Tagged m Application
forall k (s :: k) b. b -> Tagged s b
Tagged (Application -> Tagged m Application)
-> Application -> Tagged m Application
forall a b. (a -> b) -> a -> b
$ StaticSettings -> Application
staticApp (StaticSettings -> Application) -> StaticSettings -> Application
forall a b. (a -> b) -> a -> b
$ [(String, ByteString)] -> StaticSettings
embeddedSettings [(String, ByteString)]
files