module Mensam.Server.Server.Route.OpenApi where

import Mensam.API.Route qualified as Route
import Mensam.API.Route.Api qualified as Route.Api
import Mensam.API.Route.Api.OpenApi qualified as Route.Api.OpenApi
import Mensam.API.Route.OpenApi
import Mensam.API.Route.OpenApi qualified as Route.OpenApi
import Mensam.Server.Application.Configured.Class

import Data.List qualified as L
import Data.Text qualified as T
import Servant.Links
import Servant.Server.Generic
import Text.Blaze.Html qualified as Blaze
import Text.Blaze.Html5 qualified as Blaze
import Text.Blaze.Html5.Attributes qualified as Blaze.Attributes
import Text.Blaze.Internal qualified as Blaze.Internal

handler ::
  MonadConfigured m =>
  Routes (AsServerT m)
handler :: forall (m :: * -> *). MonadConfigured m => Routes (AsServerT m)
handler =
  Routes
    { routeRender :: AsServerT m
:- (Summary "View API documentation"
    :> (Description
          "View the OpenAPI documentation in a human-readabable format.\n"
        :> Get '[HTML] Html))
routeRender = m Html
AsServerT m
:- (Summary "View API documentation"
    :> (Description
          "View the OpenAPI documentation in a human-readabable format.\n"
        :> Get '[HTML] Html))
forall (m :: * -> *). MonadConfigured m => m Html
render
    }

render ::
  MonadConfigured m =>
  m Blaze.Html
render :: forall (m :: * -> *). MonadConfigured m => m Html
render = do
  Html -> m Html
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> m Html) -> Html -> m Html
forall a b. (a -> b) -> a -> b
$
    Html -> Html
Blaze.docTypeHtml (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
Blaze.head (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
Blaze.title (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ forall a. ToMarkup a => a -> Html
Blaze.toMarkup @T.Text Text
"Mensam API"
        Html
Blaze.link
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.rel AttributeValue
"icon"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.type_ AttributeValue
"image/png"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.sizes AttributeValue
"32x32"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.href AttributeValue
"static/favicon.png"
        Html
Blaze.link
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.rel AttributeValue
"icon"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.type_ AttributeValue
"image/png"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.sizes AttributeValue
"192x192"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.href AttributeValue
"static/favicon-192x192.png"
        Html
Blaze.link
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.rel AttributeValue
"icon"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.type_ AttributeValue
"image/png"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.sizes AttributeValue
"512x512"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.href AttributeValue
"static/favicon-512x512.png"
        Html
Blaze.link
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.rel AttributeValue
"apple-touch-icon"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.type_ AttributeValue
"image/png"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.sizes AttributeValue
"512x512"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.href AttributeValue
"static/favicon-512x512.png"

        --  needed for adaptive design
        Html
Blaze.meta
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.charset AttributeValue
"utf-8"
        Html
Blaze.meta
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.name AttributeValue
"viewport"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.content AttributeValue
"width=device-width, initial-scale=1"
        Html
Blaze.link
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.rel AttributeValue
"stylesheet"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.type_ AttributeValue
"text/css"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.href AttributeValue
"static/redoc.css"

        -- Redoc doesn't change outer page styles
        Html -> Html
Blaze.style
          Html
"body {\n\
          \  margin: 0;\n\
          \  padding: 0;\n\
          \}"

      Html -> Html
Blaze.body (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        let
          redoc :: Html -> Html
redoc = Tag -> Html -> Html
Blaze.Internal.customParent (Tag -> Html -> Html) -> Tag -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Tag
Blaze.textTag Text
"redoc"
          specUrl :: AttributeValue -> Attribute
specUrl = Tag -> AttributeValue -> Attribute
Blaze.customAttribute Tag
"spec-url"
          linkCurrent :: AsLink Link
:- (Summary "View API documentation"
    :> (Description
          "View the OpenAPI documentation in a human-readabable format.\n"
        :> Get '[HTML] Html))
linkCurrent = Routes (AsLink Link)
-> AsLink Link
   :- (Summary "View API documentation"
       :> (Description
             "View the OpenAPI documentation in a human-readabable format.\n"
           :> Get '[HTML] Html))
forall route.
Routes route
-> route
   :- (Summary "View API documentation"
       :> (Description
             "View the OpenAPI documentation in a human-readabable format.\n"
           :> Get '[HTML] Html))
Route.OpenApi.routeRender (Routes (AsLink Link)
 -> AsLink Link
    :- (Summary "View API documentation"
        :> (Description
              "View the OpenAPI documentation in a human-readabable format.\n"
            :> Get '[HTML] Html)))
-> (Routes (AsLink Link) -> Routes (AsLink Link))
-> Routes (AsLink Link)
-> AsLink Link
   :- (Summary "View API documentation"
       :> (Description
             "View the OpenAPI documentation in a human-readabable format.\n"
           :> Get '[HTML] Html))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Routes (AsLink Link)
-> AsLink Link :- ("openapi" :> NamedRoutes Routes)
Routes (AsLink Link) -> Routes (AsLink Link)
forall route.
Routes route -> route :- ("openapi" :> NamedRoutes Routes)
Route.routeOpenApi (Routes (AsLink Link)
 -> AsLink Link
    :- (Summary "View API documentation"
        :> (Description
              "View the OpenAPI documentation in a human-readabable format.\n"
            :> Get '[HTML] Html)))
-> Routes (AsLink Link)
-> AsLink Link
   :- (Summary "View API documentation"
       :> (Description
             "View the OpenAPI documentation in a human-readabable format.\n"
           :> Get '[HTML] Html))
forall a b. (a -> b) -> a -> b
$ Routes (AsLink Link)
forall (routes :: * -> *).
(HasLink (ToServantApi routes),
 GenericServant routes (AsLink Link),
 ToServant routes (AsLink Link)
 ~ MkLink (ToServantApi routes) Link) =>
routes (AsLink Link)
allFieldLinks
          linkOpenApiJson :: AsLink Link
:- (Summary "OpenAPI"
    :> (Description
          "This OpenAPI specification is automatically generated from a servant API.\n"
        :> ("openapi" :> Get '[JSON] OpenApi)))
linkOpenApiJson = Routes (AsLink Link)
-> AsLink Link
   :- (Summary "OpenAPI"
       :> (Description
             "This OpenAPI specification is automatically generated from a servant API.\n"
           :> ("openapi" :> Get '[JSON] OpenApi)))
forall route.
Routes route
-> route
   :- (Summary "OpenAPI"
       :> (Description
             "This OpenAPI specification is automatically generated from a servant API.\n"
           :> ("openapi" :> Get '[JSON] OpenApi)))
Route.Api.OpenApi.routeJson (Routes (AsLink Link)
 -> AsLink Link
    :- (Summary "OpenAPI"
        :> (Description
              "This OpenAPI specification is automatically generated from a servant API.\n"
            :> ("openapi" :> Get '[JSON] OpenApi))))
-> (Routes (AsLink Link) -> Routes (AsLink Link))
-> Routes (AsLink Link)
-> AsLink Link
   :- (Summary "OpenAPI"
       :> (Description
             "This OpenAPI specification is automatically generated from a servant API.\n"
           :> ("openapi" :> Get '[JSON] OpenApi)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Routes (AsLink Link) -> AsLink Link :- NamedRoutes Routes
Routes (AsLink Link) -> Routes (AsLink Link)
forall route. Routes route -> route :- NamedRoutes Routes
Route.Api.routeOpenApi (Routes (AsLink Link) -> Routes (AsLink Link))
-> (Routes (AsLink Link) -> Routes (AsLink Link))
-> Routes (AsLink Link)
-> Routes (AsLink Link)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Routes (AsLink Link)
-> AsLink Link :- ("api" :> NamedRoutes Routes)
Routes (AsLink Link) -> Routes (AsLink Link)
forall route.
Routes route -> route :- ("api" :> NamedRoutes Routes)
Route.routeApi (Routes (AsLink Link)
 -> AsLink Link
    :- (Summary "OpenAPI"
        :> (Description
              "This OpenAPI specification is automatically generated from a servant API.\n"
            :> ("openapi" :> Get '[JSON] OpenApi))))
-> Routes (AsLink Link)
-> AsLink Link
   :- (Summary "OpenAPI"
       :> (Description
             "This OpenAPI specification is automatically generated from a servant API.\n"
           :> ("openapi" :> Get '[JSON] OpenApi)))
forall a b. (a -> b) -> a -> b
$ Routes (AsLink Link)
forall (routes :: * -> *).
(HasLink (ToServantApi routes),
 GenericServant routes (AsLink Link),
 ToServant routes (AsLink Link)
 ~ MkLink (ToServantApi routes) Link) =>
routes (AsLink Link)
allFieldLinks
        Html -> Html
redoc (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
specUrl ([Char] -> AttributeValue
Blaze.stringValue ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Link -> Link -> [Char]
relativePath Link
linkCurrent Link
linkOpenApiJson) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
""
        Html -> Html
Blaze.script (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
Blaze.! AttributeValue -> Attribute
Blaze.Attributes.src AttributeValue
"static/redoc.standalone.js" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
""

-- | Assuming that links don't have trailing slashes.
relativePath :: Link -> Link -> String
relativePath :: Link -> Link -> [Char]
relativePath Link
origin Link
destination = [Char]
goBack [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
goForward
 where
  goBack :: String
  goBack :: [Char]
goBack = case Link -> [[Char]]
linkSegments Link
origin of
    [] -> [Char]
"."
    [[Char]
_] -> [Char]
"."
    [Char]
_ : [[Char]]
baseSegments -> [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
L.intercalate [Char]
"/" ([Char]
".." [Char] -> [[Char]] -> [[Char]]
forall a b. a -> [b] -> [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [[Char]]
baseSegments)
  goForward :: String
  goForward :: [Char]
goForward = URI -> [Char]
forall a. Show a => a -> [Char]
show (URI -> [Char]) -> URI -> [Char]
forall a b. (a -> b) -> a -> b
$ Link -> URI
linkURI Link
destination