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.Types qualified as H
  16 import Network.Wai qualified as Wai
  17 import System.IO (IO)
  18 import System.IO qualified as Sys
  19
  20 import Literate.Web.Live.Asset
  21 import Literate.Web.Live.Common
  22
  23 httpApp ::
  24   STM model ->
  25   (model -> IO (Map.Map Web.OutputPath (IO BSL.ByteString))) ->
  26   -- The shim to include in every HTML response
  27   Maybe BSL.ByteString ->
  28   Wai.Application
  29 httpApp modelSTM siteMap mShim req res = do
  30   let shim = fromMaybe "" mShim
  31   let path = Text.intercalate "/" $ Wai.pathInfo req
  32   model <- STM.atomically modelSTM
  33   site <- siteMap model
  34   Sys.hPrint Sys.stderr (["httpApp", "GET"] :: [Text.Text], ("path", path, decodeOutputPath path))
  35   case Map.lookup (decodeOutputPath path) site of
  36     Nothing -> do
  37       let s = liveErrorHtmlResponse decodeRouteNothingMsg <> shim
  38       res $ Wai.responseLBS H.status404 [(H.hContentType, "text/html")] s
  39     Just contentIO -> do
  40       content <- contentIO
  41       res $ Wai.responseLBS H.status200 [(H.hContentType, "text/html")] content
  42
  43 {-
  44 case mr of
  45   Left err -> do
  46     logErrorNS "App" $ badRouteEncodingMsg err
  47     let s = liveErrorHtmlResponse (badRouteEncodingMsg err) <> shim
  48     liftIO $ res $ Wai.responseLBS H.status500 [(H.hContentType, "text/html")] s
  49   Right Nothing -> do
  50     let s = liveErrorHtmlResponse decodeRouteNothingMsg <> shim
  51     liftIO $ res $ Wai.responseLBS H.status404 [(H.hContentType, "text/html")] s
  52   Right (Just r) -> do
  53     renderCatchingErrors val r >>= \case
  54       AssetStatic staticPath -> do
  55         let mimeType = Static.getMimeType staticPath
  56         liftIO $ res $ Wai.responseFile H.status200 [(H.hContentType, mimeType)] staticPath Nothing
  57       AssetGenerated Html html -> do
  58         let s = html <> toLazy wsClientHtml <> shim
  59         liftIO $ res $ Wai.responseLBS H.status200 [(H.hContentType, "text/html")] s
  60       AssetGenerated Other s -> do
  61         let mimeType = Static.getMimeType $ review (fromPrism_ $ routePrism val) r
  62         liftIO $ res $ Wai.responseLBS H.status200 [(H.hContentType, mimeType)] s
  63 -}