module Mensam.Server.Server.Route.Frontend where

import Mensam.API.Route.Frontend
import Mensam.Server.Application.Configured.Class
import Mensam.Server.Configuration
import Mensam.Server.Configuration.BaseUrl

import Control.Monad.Logger.CallStack
import Data.Aeson.Text qualified as A
import Data.Foldable
import Data.List qualified as L
import Data.List.NonEmpty qualified as NE
import Data.Maybe qualified as M
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Numeric.Natural
import Servant
import Text.Blaze qualified as B
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as H.A

handler ::
  (MonadConfigured m, MonadLogger m) =>
  ServerT API m
handler :: forall (m :: * -> *).
(MonadConfigured m, MonadLogger m) =>
ServerT API m
handler [Text]
segments = do
  BaseUrl
baseUrl <- Configuration -> BaseUrl
configBaseUrl (Configuration -> BaseUrl) -> m Configuration -> m BaseUrl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Configuration
forall (m :: * -> *). MonadConfigured m => m Configuration
configuration
  [FontConfig]
fontConfigs <- Configuration -> [FontConfig]
configFonts (Configuration -> [FontConfig])
-> m Configuration -> m [FontConfig]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Configuration
forall (m :: * -> *). MonadConfigured m => m Configuration
configuration
  let depth :: Maybe Natural
depth =
        case [Text]
segments of
          [] -> Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
0
          [Text]
_ -> Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Natural -> Maybe Natural) -> Natural -> Maybe Natural
forall a b. (a -> b) -> a -> b
$ Int -> Natural
forall a. Enum a => Int -> a
toEnum (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
segments Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Serve frontend."
  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Frontend will be using path: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([Text] -> String
forall a. Show a => a -> String
show [Text]
segments)
  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
docTypeHtml (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.head (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html
meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
charset AttributeValue
"UTF-8"
        Html
meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
name AttributeValue
"application-name" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
content AttributeValue
"Mensam"
        Html
meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
name AttributeValue
"color-scheme" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
content AttributeValue
"dark"
        Html
meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
name AttributeValue
"mobile-web-app-capable" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
content AttributeValue
"yes"
        Html
meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
name AttributeValue
"theme-color" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
content AttributeValue
"#282a2e"
        Html
meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
name AttributeValue
"viewport" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
content AttributeValue
"width=device-width, height=device-height, initial-scale=1"
        Html -> Html
H.title Html
"Mensam"
        Html
link
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
rel AttributeValue
"icon"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ AttributeValue
"image/png"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
sizes AttributeValue
"32x32"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! BaseUrl -> Maybe Natural -> AttributeValue -> Attribute
hrefWithDepth BaseUrl
baseUrl Maybe Natural
depth AttributeValue
"static/favicon.png"
        Html
link
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
rel AttributeValue
"icon"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ AttributeValue
"image/png"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
sizes AttributeValue
"192x192"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! BaseUrl -> Maybe Natural -> AttributeValue -> Attribute
hrefWithDepth BaseUrl
baseUrl Maybe Natural
depth AttributeValue
"static/favicon-192x192.png"
        Html
link
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
rel AttributeValue
"icon"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ AttributeValue
"image/png"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
sizes AttributeValue
"512x512"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! BaseUrl -> Maybe Natural -> AttributeValue -> Attribute
hrefWithDepth BaseUrl
baseUrl Maybe Natural
depth AttributeValue
"static/favicon-512x512.png"
        Html
meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
name AttributeValue
"apple-mobile-web-app-capable" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
content AttributeValue
"yes"
        Html
meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
name AttributeValue
"apple-mobile-web-app-status-bar-style" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
content AttributeValue
"black"
        Html
link
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
rel AttributeValue
"apple-touch-icon"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ AttributeValue
"image/png"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
sizes AttributeValue
"512x512"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! BaseUrl -> Maybe Natural -> AttributeValue -> Attribute
hrefWithDepth BaseUrl
baseUrl Maybe Natural
depth AttributeValue
"static/favicon-512x512.png"
        Html
link
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
rel AttributeValue
"stylesheet"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ AttributeValue
"text/css"
          Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! BaseUrl -> Maybe Natural -> AttributeValue -> Attribute
hrefWithDepth BaseUrl
baseUrl Maybe Natural
depth AttributeValue
"static/fonts.css"
        [Html] -> Html
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([Html] -> Html) -> [Html] -> Html
forall a b. (a -> b) -> a -> b
$ (FontConfig -> Maybe Html) -> [FontConfig] -> [Html]
forall a b. (a -> Maybe b) -> [a] -> [b]
M.mapMaybe (BaseUrl -> Maybe Natural -> FontConfig -> Maybe Html
fontPreloadLinkMaybe BaseUrl
baseUrl Maybe Natural
depth) [FontConfig]
fontConfigs
        Html -> Html
script (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
src (BaseUrl -> Maybe Natural -> AttributeValue -> AttributeValue
withDepth BaseUrl
baseUrl Maybe Natural
depth AttributeValue
"static/frontend.js") (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
""
      Html -> Html
body (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
H.A.id AttributeValue
"mensam-frontend" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
""
        Html -> Html
script (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
          [Html] -> Html
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
            [ Html
"\
              \var storageName = 'mensam-frontend-storage';\
              \var storageUnsafe = localStorage.getItem(storageName);\
              \\
              \var flags = \
              \  { \"storage\": storageUnsafe ? JSON.parse(storageUnsafe) : null\
              \  , \"time\": \
              \    { \"now\": Date.now()\
              \    , \"zone\": Intl.DateTimeFormat().resolvedOptions().timeZone\
              \    }\
              \  , \"base-url\": \
              \"
            , Text -> Html
preEscapedText (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Text
forall a. ToJSON a => a -> Text
A.encodeToLazyText BaseUrl
baseUrl
            , Html
"\
              \  };\
              \\
              \var app = Elm.Main.init(\
              \  { \"node\": document.getElementById('mensam-frontend')\
              \  , \"flags\": flags\
              \  }\
              \);\
              \\
              \app.ports.setStorageJson.subscribe(function(state) {\
              \  localStorage.setItem(storageName, JSON.stringify(state));\
              \});\
              \\
              \app.ports.copyTextToClipboard.subscribe(function(content) {\
              \  navigator.clipboard.writeText(content);\
              \});\
              \"
            ]

hrefWithDepth ::
  BaseUrl ->
  -- | depth
  Maybe Natural ->
  AttributeValue ->
  Attribute
hrefWithDepth :: BaseUrl -> Maybe Natural -> AttributeValue -> Attribute
hrefWithDepth BaseUrl
baseUrl Maybe Natural
depth AttributeValue
ref = AttributeValue -> Attribute
href (AttributeValue -> Attribute) -> AttributeValue -> Attribute
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Maybe Natural -> AttributeValue -> AttributeValue
withDepth BaseUrl
baseUrl Maybe Natural
depth AttributeValue
ref

withDepth ::
  BaseUrl ->
  -- | depth
  Maybe Natural ->
  AttributeValue ->
  AttributeValue
withDepth :: BaseUrl -> Maybe Natural -> AttributeValue -> AttributeValue
withDepth BaseUrl
baseUrl Maybe Natural
Nothing AttributeValue
ref = Text -> AttributeValue
textValue (BaseUrl -> Text
displayBaseUrl BaseUrl
baseUrl) AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
ref
withDepth BaseUrl
_ (Just Natural
0) AttributeValue
ref = AttributeValue
"./" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
ref
withDepth BaseUrl
_ (Just Natural
1) AttributeValue
ref = AttributeValue
"../" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
ref
withDepth BaseUrl
baseUrl (Just Natural
n) AttributeValue
ref = BaseUrl -> Maybe Natural -> AttributeValue -> AttributeValue
withDepth BaseUrl
baseUrl (Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Natural -> Maybe Natural) -> Natural -> Maybe Natural
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
forall a. Enum a => a -> a
pred Natural
n) (AttributeValue -> AttributeValue)
-> AttributeValue -> AttributeValue
forall a b. (a -> b) -> a -> b
$ AttributeValue
"../" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
ref

fontPreloadLinkMaybe ::
  BaseUrl ->
  -- | depth
  Maybe Natural ->
  FontConfig ->
  Maybe Html
fontPreloadLinkMaybe :: BaseUrl -> Maybe Natural -> FontConfig -> Maybe Html
fontPreloadLinkMaybe BaseUrl
baseUrl Maybe Natural
depth FontConfig
fontConfig =
  if FontConfig -> Bool
fontPreload FontConfig
fontConfig
    then Html -> Maybe Html
forall a. a -> Maybe a
Just (Html -> Maybe Html) -> Html -> Maybe Html
forall a b. (a -> b) -> a -> b
$ Html
link Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
rel AttributeValue
"preload" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href (BaseUrl -> Maybe Natural -> NonEmpty Text -> AttributeValue
fontUrl BaseUrl
baseUrl Maybe Natural
depth (NonEmpty Text -> AttributeValue)
-> NonEmpty Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FontConfig -> NonEmpty Text
fontPathPieces FontConfig
fontConfig) Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! Tag -> AttributeValue -> Attribute
B.customAttribute Tag
"as" AttributeValue
"font" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ AttributeValue
"font/woff2" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! Tag -> AttributeValue -> Attribute
B.customAttribute Tag
"crossorigin" AttributeValue
"anonymous"
    else Maybe Html
forall a. Maybe a
Nothing

fontUrl ::
  BaseUrl ->
  -- | depth
  Maybe Natural ->
  NE.NonEmpty T.Text ->
  AttributeValue
fontUrl :: BaseUrl -> Maybe Natural -> NonEmpty Text -> AttributeValue
fontUrl BaseUrl
baseUrl Maybe Natural
depth NonEmpty Text
pathPieces = BaseUrl -> Maybe Natural -> AttributeValue -> AttributeValue
withDepth BaseUrl
baseUrl Maybe Natural
depth AttributeValue
fontPathSerialized
 where
  fontPathSerialized :: AttributeValue
fontPathSerialized =
    case Text -> AttributeValue
B.textValue (Text -> AttributeValue)
-> NonEmpty Text -> NonEmpty AttributeValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Text
pathPieces of
      AttributeValue
x NE.:| [AttributeValue]
xs -> [AttributeValue] -> AttributeValue
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([AttributeValue] -> AttributeValue)
-> [AttributeValue] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ AttributeValue -> [AttributeValue] -> [AttributeValue]
forall a. a -> [a] -> [a]
L.intersperse AttributeValue
"/" (AttributeValue
x AttributeValue -> [AttributeValue] -> [AttributeValue]
forall a. a -> [a] -> [a]
: [AttributeValue]
xs)