src/Literate/Web/Live/HTTP.hs

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