src/Literate/Web/Live/Common.hs

   1 {-# LANGUAGE QuasiQuotes #-}
   2 {-# LANGUAGE RecordWildCards #-}
   3 {-# LANGUAGE TemplateHaskell #-}
   4
   5 module Literate.Web.Live.Common where
   6
   7 import Control.Arrow ((>>>))
   8 import Data.ByteString qualified as BS
   9 import Data.ByteString.Lazy qualified as BSL
  10 import Data.FileEmbed
  11 import Data.Function (($))
  12 import Data.Functor ((<&>))
  13 import Data.Semigroup (Semigroup (..))
  14 import Data.Text (Text)
  15 import Data.Text qualified as Text
  16 import Data.Text.Encoding qualified as Text
  17 import Data.Text.Lazy qualified as TextL
  18 import Data.Text.Lazy.Encoding qualified as TextL
  19 import System.IO qualified as Sys
  20
  21 import Literate.Web qualified as Web
  22 import Text.Show (Show)
  23
  24 {-
  25 renderCatchingErrors ::
  26   forall r m.
  27   ( MonadLoggerIO m
  28   , MonadUnliftIO m
  29   , EmaStaticSite r
  30   ) =>
  31   RouteModel r ->
  32   r ->
  33   m (Asset BSL.ByteString)
  34 renderCatchingErrors m r =
  35   catch (siteOutput (fromPrism_ $ routePrism m) m r) $ \(err :: SomeException) -> do
  36     -- Log the error first.
  37     logErrorNS "App" $ show @Text err
  38     pure
  39       $ AssetGenerated Html
  40         . mkHtmlErrorMsg
  41       $ show @Text err
  42
  43 -- Decode an URL path into a route
  44 --
  45 -- This function is used only in live server. If the route is not
  46 -- isomoprhic, this returns a Left, with the mismatched encoding.
  47 decodeUrlRoute ::
  48   forall r.
  49   (Eq r, Show r, IsRoute r) =>
  50   RouteModel r ->
  51   Text ->
  52   Either (BadRouteEncoding r) (Maybe r)
  53 decodeUrlRoute m (urlToFilePath -> s) = do
  54   case checkRoutePrismGivenFilePath routePrism m s of
  55     Left (r, log) -> Left $ BadRouteEncoding s r log
  56     Right mr -> Right mr
  57 -}
  58
  59 -- | A basic error response for displaying in the browser
  60 liveErrorHtmlResponse :: Text -> BSL.ByteString
  61 liveErrorHtmlResponse err = mkHtmlErrorMsg err <> BSL.fromStrict wsClientHtml
  62
  63 urlToFilePath :: Text -> Sys.FilePath
  64 urlToFilePath =
  65   Text.splitOn "/"
  66     >>> (<&> (Web.textToPathSegment >>> Web.pathSegmentToText))
  67     >>> Text.intercalate "/"
  68     >>> Text.unpack
  69
  70 mkHtmlErrorMsg :: Text -> BSL.ByteString
  71 mkHtmlErrorMsg s = TextL.encodeUtf8 $ TextL.replace "MESSAGE" (TextL.fromStrict s) $ TextL.fromStrict $ Text.decodeUtf8 $ emaErrorHtml
  72
  73 emaErrorHtml :: BS.ByteString
  74 emaErrorHtml = $(embedFile "www/live-error.html")
  75
  76 decodeRouteNothingMsg :: Text
  77 decodeRouteNothingMsg = "Literate.Web.Live: 404 (route decoding returned Nothing)"
  78
  79 data BadRouteEncoding r = BadRouteEncoding
  80   { _bre_urlFilePath :: Sys.FilePath
  81   , _bre_decodedRoute :: r
  82   , _bre_checkLog :: [(Sys.FilePath, Text)]
  83   }
  84   deriving stock (Show)
  85
  86 wsClientHtml :: BS.ByteString
  87 wsClientHtml = $(embedFile "www/live-indicator.html")
  88
  89 {-
  90 badRouteEncodingMsg :: (Show r) => BadRouteEncoding r -> Text
  91 badRouteEncodingMsg BadRouteEncoding {..} =
  92   toText $
  93     "A route Prism' is unlawful.\n\nThe URL '"
  94       <> toText _bre_urlFilePath
  95       <> "' decodes to route '"
  96       <> show _bre_decodedRoute
  97       <> "', but it is not isomporphic on any of the allowed candidates: \n\n"
  98       <> Text.intercalate
  99         "\n\n"
 100         ( _bre_checkLog <&> \(candidate, log) ->
 101             "## Candidate '" <> toText candidate <> "':\n" <> log
 102         )
 103       <> " \n\nYou should make the relevant routePrism lawful to fix this issue."
 104 -}