src/Literate/Web/Live/HTTP.hs

   1 {-# OPTIONS_GHC -Wno-type-defaults #-}
   2
   3 module Literate.Web.Live.HTTP where
   4
   5 -- import Network.Wai.Middleware.Static qualified as Static
   6 import Control.Concurrent.STM (STM)
   7 import Control.Concurrent.STM qualified as STM
   8 import Data.ByteString.Lazy qualified as BSL
   9 import Data.Function (($))
  10 import Data.Map.Strict qualified as Map
  11 import Data.Maybe (Maybe (..), fromMaybe)
  12 import Data.Semigroup (Semigroup (..))
  13 import Data.Text qualified as Text
  14 import Literate.Web qualified as Web
  15 import Network.HTTP.Media qualified as Media
  16 import Network.HTTP.Types qualified as H
  17 import Network.Wai qualified as Wai
  18 import System.IO (IO)
  19 import System.IO qualified as Sys
  20
  21 import Literate.Web.Live.Asset
  22 import Literate.Web.Live.Common
  23 import Literate.Web.Types.MIME (MediaType)
  24
  25 httpApp ::
  26   STM model ->
  27   (model -> IO (Map.Map Web.OutputPath (MediaType, IO BSL.ByteString))) ->
  28   -- The shim to include in every HTML response
  29   Maybe BSL.ByteString ->
  30   Wai.Application
  31 httpApp modelSTM siteMap mShim req res = do
  32   let shim = fromMaybe "" mShim
  33   let path = Text.intercalate "/" $ Wai.pathInfo req
  34   model <- STM.atomically modelSTM
  35   site <- siteMap model
  36   Sys.hPrint Sys.stderr (["httpApp", "GET"] :: [Text.Text], ("path", path, decodeOutputPath path))
  37   case Map.lookup (decodeOutputPath path) site of
  38     Nothing -> do
  39       let s = liveErrorHtmlResponse decodeRouteNothingMsg <> shim
  40       res $ Wai.responseLBS H.status404 [(H.hContentType, "text/html")] s
  41     Just (contentType, contentIO) -> do
  42       content <- contentIO
  43       res $ Wai.responseLBS H.status200 [(H.hContentType, Media.renderHeader contentType)] content
  44
  45 {-
  46 case mr of
  47   Left err -> do
  48     logErrorNS "App" $ badRouteEncodingMsg err
  49     let s = liveErrorHtmlResponse (badRouteEncodingMsg err) <> shim
  50     liftIO $ res $ Wai.responseLBS H.status500 [(H.hContentType, "text/html")] s
  51   Right Nothing -> do
  52     let s = liveErrorHtmlResponse decodeRouteNothingMsg <> shim
  53     liftIO $ res $ Wai.responseLBS H.status404 [(H.hContentType, "text/html")] s
  54   Right (Just r) -> do
  55     renderCatchingErrors val r >>= \case
  56       AssetStatic staticPath -> do
  57         let mimeType = Static.getMimeType staticPath
  58         liftIO $ res $ Wai.responseFile H.status200 [(H.hContentType, mimeType)] staticPath Nothing
  59       AssetGenerated Html html -> do
  60         let s = html <> toLazy wsClientHtml <> shim
  61         liftIO $ res $ Wai.responseLBS H.status200 [(H.hContentType, "text/html")] s
  62       AssetGenerated Other s -> do
  63         let mimeType = Static.getMimeType $ review (fromPrism_ $ routePrism val) r
  64         liftIO $ res $ Wai.responseLBS H.status200 [(H.hContentType, mimeType)] s
  65 -}