HTTP.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

module Ema.Server.HTTP where

import Control.Monad.Logger
import Data.LVar (LVar)
import Data.LVar qualified as LVar
import Data.Maybe (fromMaybe)
import Data.Text qualified as T
import Ema.Asset (
  Asset (AssetGenerated, AssetStatic),
  Format (Html, Other),
 )
import Ema.Route.Class (IsRoute (RouteModel, routePrism))
import Ema.Route.Prism (
  fromPrism_,
 )
import Ema.Server.Common
import Ema.Site (EmaStaticSite)
import Network.HTTP.Types qualified as H
import Network.Wai qualified as Wai
import Network.Wai.Middleware.Static qualified as Static
import Optics.Core (review)

httpApp ::
  forall r.
  (Eq r, Show r, IsRoute r, EmaStaticSite r) =>
  (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) ->
  LVar (RouteModel r) ->
  -- The shim to include in every HTML response
  Maybe LByteString ->
  Wai.Application
httpApp logger model mShim req f = flip runLoggingT logger $ do
  let shim = fromMaybe "" mShim
  val <- LVar.get model
  let pathInfo = Wai.pathInfo req
      path = T.intercalate "/" pathInfo
      mr = decodeUrlRoute @r val path
  logInfoNS "ema.http" $ "GET " <> path <> " as " <> show mr
  case mr of
    Left err -> do
      logErrorNS "App" $ badRouteEncodingMsg err
      let s = emaErrorHtmlResponse (badRouteEncodingMsg err) <> shim
      liftIO $ f $ Wai.responseLBS H.status500 [(H.hContentType, "text/html")] s
    Right Nothing -> do
      let s = emaErrorHtmlResponse decodeRouteNothingMsg <> shim
      liftIO $ f $ Wai.responseLBS H.status404 [(H.hContentType, "text/html")] s
    Right (Just r) -> do
      renderCatchingErrors val r >>= \case
        AssetStatic staticPath -> do
          let mimeType = Static.getMimeType staticPath
          liftIO $ f $ Wai.responseFile H.status200 [(H.hContentType, mimeType)] staticPath Nothing
        AssetGenerated Html html -> do
          let s = html <> toLazy wsClientHtml <> shim
          liftIO $ f $ Wai.responseLBS H.status200 [(H.hContentType, "text/html")] s
        AssetGenerated Other s -> do
          let mimeType = Static.getMimeType $ review (fromPrism_ $ routePrism val) r
          liftIO $ f $ Wai.responseLBS H.status200 [(H.hContentType, mimeType)] s