{-# 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.Aeson                     (ToJSON (..), Value)
import Data.ByteString                (ByteString)
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\/...
-- @
--
-- This type does not actually force served type to be @Swagger@ from @swagger2@ package,
-- it could be arbitrary @aeson@ 'Value'.
type SwaggerSchemaUI (dir :: Symbol) (schema :: Symbol) =
    SwaggerSchemaUI' dir (schema :> Get '[JSON] Value)

-- | 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 Value, ToJSON a)
    => T.Text -> [(FilePath, ByteString)]
    -> a -> ServerT (SwaggerSchemaUI' dir api) m
swaggerSchemaUIServerImpl :: Text
-> [(String, ByteString)]
-> a
-> ServerT (SwaggerSchemaUI' dir api) m
swaggerSchemaUIServerImpl Text
indexTemplate [(String, ByteString)]
files a
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
$ Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ a -> Value
forall a. ToJSON a => a -> Value
toJSON a
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