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
  -- artists
  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 (ArtistEditPage env mode language palette artist next) =
    next =<< artistEditPage' env mode language palette artist
  -- genres
  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 (GenreEditPage env mode language palette genre next) =
    next =<< genreEditPage' env mode language palette genre
  -- songs
  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 (SongEditPage env mode language palette song next) =
    next =<< songEditPage' env mode language palette song
  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 ((^. #titles % #errorOccurred) |##| language)
  pure $ H.html $ do
    sharedHead
    body $ section $ do
      sharedPageTop (Just $ (^. #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 ((^. #titles % #login) |##| language)
  pure $ H.html $ do
    sharedHead
    body $ section $ do
      sharedPageTop (Just $ (^. #titles % #login) |##| language) mode language palette
      section $ postForm "/login" $ do
        requiredEmailInput "email" ((^. #forms % #email) |##| language)
        requiredPasswordInput "password" ((^. #forms % #password) |##| language)
        submitButton language