module Mensam.Server.Server.Err404 where

import Mensam.Server.Application.Configured.Class
import Mensam.Server.Configuration
import Mensam.Server.Configuration.BaseUrl

import Control.Monad.Logger.CallStack
import Data.ByteString.Builder
import Network.HTTP.Types.Status
import Network.Wai
import Network.Wai.Trans
import Text.Blaze.Html.Renderer.Utf8
import Text.Blaze.Html5 qualified as H
import Text.Blaze.Html5.Attributes as HA

application404 ::
  (MonadConfigured m, MonadLogger m) =>
  ApplicationT m
application404 :: forall (m :: * -> *).
(MonadConfigured m, MonadLogger m) =>
ApplicationT m
application404 Request
_req Response -> m ResponseReceived
rsp = do
  Html
html404' <- m Html
forall (m :: * -> *). MonadConfigured m => m Html
html404
  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Serve generic 404 page."
  Response -> m ResponseReceived
rsp (Response -> m ResponseReceived)
-> (Builder -> Response) -> Builder -> m ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> ResponseHeaders -> Builder -> Response
responseBuilder Status
status404 [(,) HeaderName
"Content-Type" ByteString
"text/html"] (Builder -> m ResponseReceived) -> Builder -> m ResponseReceived
forall a b. (a -> b) -> a -> b
$
    ByteString -> Builder
lazyByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$
      Html -> ByteString
renderHtml Html
html404'

html404 ::
  MonadConfigured m =>
  m H.Html
html404 :: forall (m :: * -> *). MonadConfigured m => m Html
html404 = 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
  Maybe Text
maybeRevision <- Configuration -> Maybe Text
configRevision (Configuration -> Maybe Text) -> m Configuration -> m (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Configuration
forall (m :: * -> *). MonadConfigured m => m Configuration
configuration
  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
H.docTypeHtml (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.lang AttributeValue
"en" (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
H.meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.charset AttributeValue
"UTF-8"
      Html
H.meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.name AttributeValue
"description" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
content AttributeValue
"Mensam did not find, what you were looking for."
      Html
H.meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.name AttributeValue
"viewport" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
content AttributeValue
"width=500"
      Html -> Html
H.title Html
"Mensam 404"
      Html
H.link
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.rel AttributeValue
"icon"
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.type_ AttributeValue
"image/png"
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.sizes AttributeValue
"32x32"
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.href (Text -> AttributeValue
H.textValue (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Text
displayBaseUrl BaseUrl
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/favicon.png")
      Html
H.link
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.rel AttributeValue
"icon"
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.type_ AttributeValue
"image/png"
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.sizes AttributeValue
"192x192"
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.href (Text -> AttributeValue
H.textValue (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Text
displayBaseUrl BaseUrl
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/favicon-192x192.png")
      Html
H.link
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.rel AttributeValue
"icon"
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.type_ AttributeValue
"image/png"
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.sizes AttributeValue
"512x512"
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.href (Text -> AttributeValue
H.textValue (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Text
displayBaseUrl BaseUrl
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/favicon-512x512.png")
      Html
H.link
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.rel AttributeValue
"apple-touch-icon"
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.type_ AttributeValue
"image/png"
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.sizes AttributeValue
"512x512"
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.href (Text -> AttributeValue
H.textValue (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Text
displayBaseUrl BaseUrl
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/favicon-512x512.png")
      Html
H.link
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.rel AttributeValue
"stylesheet"
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.type_ AttributeValue
"text/css"
        Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.href (Text -> AttributeValue
H.textValue (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Text
displayBaseUrl BaseUrl
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/stylesheet.css")
    Html -> Html
H.body (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.h1 Html
"404"
      Html -> Html
H.h2 Html
"You got lost?"
      Html -> Html
H.p (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Try starting " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> (Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.href (Text -> AttributeValue
H.textValue (BaseUrl -> Text
displayBaseUrl BaseUrl
baseUrl)) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"here") Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
"."
      case Maybe Text
maybeRevision of
        Maybe Text
Nothing -> () -> Html
forall a. a -> MarkupM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Text
revision ->
          Html -> Html
H.p (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
            Html
"This happened on revision "
            Html -> Html
H.code (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.text Text
revision
            Html
"."