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