Html.hs

{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module WikiMusic.SSR.View.Html () where

import Data.Map qualified as Map
import Data.Text qualified as T
import Free.AlaCarte
import Optics
import Relude
import Text.Blaze.Html
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
import WikiMusic.SSR.Free.View
import WikiMusic.SSR.Language
import WikiMusic.SSR.Model.Api
import WikiMusic.SSR.Model.Env
import WikiMusic.SSR.View.ArtistHtml
import WikiMusic.SSR.View.Components.Forms
import WikiMusic.SSR.View.Components.Meta
import WikiMusic.SSR.View.Components.PageTop
import WikiMusic.SSR.View.GenreHtml
import WikiMusic.SSR.View.SongHtml
import Prelude qualified

instance Exec View where
  execAlgebra (ArtistListPage env mode sortOrder l palette r next) =
    next =<< artistListPage' env mode sortOrder l palette r
  execAlgebra (ArtistDetailPage env mode language palette r next) =
    next =<< artistDetailPage' env mode language palette (Prelude.head . Map.elems $ r ^. #artists)
  execAlgebra (ArtistCreatePage env mode language palette next) =
    next =<< artistCreatePage' env mode language palette
  execAlgebra (GenreListPage env mode sortOrder l palette r next) =
    next =<< genreListPage' env mode sortOrder l palette r
  execAlgebra (GenreDetailPage env mode language palette r next) =
    next =<< genreDetailPage' env mode language palette (Prelude.head . Map.elems $ r ^. #genres)
  execAlgebra (GenreCreatePage env mode language palette next) =
    next =<< genreCreatePage' env mode language palette
  execAlgebra (SongListPage env mode sortOrder language palette r next) =
    next =<< songListPage' env mode sortOrder language palette r
  execAlgebra (SongDetailPage env mode language palette songAsciiSize r next) =
    next =<< songDetailPage' env mode language palette songAsciiSize (Prelude.head . Map.elems $ r ^. #songs)
  execAlgebra (SongCreatePage env mode language palette next) =
    next =<< songCreatePage' env mode language palette
  execAlgebra (ErrorPage env mode language palette message next) =
    next =<< errorPage' env mode language palette message
  execAlgebra (LoginPage env mode language palette next) =
    next =<< loginPage' env mode language palette

errorPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> Text -> m Html
errorPage' env mode language palette message = do
  sharedHead <- mkSharedHead env mode palette (dictionary ^. #titles % #errorOccurred |##| language)
  pure $ H.html $ do
    sharedHead
    body $ section $ do
      sharedPageTop (Just $ dictionary ^. #titles % #errorOccurred |##| language) mode language palette
      h3 . text $ messageCauses
      H.pre ! class_ "font-size-small" $ text message
  where
    messageCauses :: Text
    messageCauses = T.intercalate " - " causeStrings
    causeStrings = catMaybes [Just "Error", if T.isInfixOf "504" message then Just "Gateway Timeout" else Nothing]

loginPage' :: (MonadIO m) => Env -> UiMode -> Language -> Palette -> m Html
loginPage' env mode language palette = do
  sharedHead <- mkSharedHead env mode palette (dictionary ^. #titles % #login |##| language)
  pure $ H.html $ do
    sharedHead
    body $ section $ do
      sharedPageTop (Just $ dictionary ^. #titles % #login |##| language) mode language palette
      section $ postForm "/login" $ do
        requiredEmailInput "email" (dictionary ^. #forms % #email |##| language)
        requiredPasswordInput "password" (dictionary ^. #forms % #password |##| language)
        submitButton language