summaryrefslogtreecommitdiff
path: root/source/Render/Html/Context.hs
diff options
context:
space:
mode:
Diffstat (limited to 'source/Render/Html/Context.hs')
-rw-r--r--source/Render/Html/Context.hs171
1 files changed, 0 insertions, 171 deletions
diff --git a/source/Render/Html/Context.hs b/source/Render/Html/Context.hs
deleted file mode 100644
index 151edd5..0000000
--- a/source/Render/Html/Context.hs
+++ /dev/null
@@ -1,171 +0,0 @@
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
--- | Browser-facing routing authority for one rendered HTML page.
-module Render.Html.Context
- ( HtmlRenderEnvironment
- , htmlRenderEnvironment
- , HtmlRenderContext
- , HtmlRenderContextError(..)
- , htmlRenderContext
- , htmlRenderContextFromEnvironment
- , htmlCurrentSource
- , htmlCurrentPageUrl
- , htmlCurrentPageLabel
- , htmlRouteNamespaces
- , htmlSourceUrl
- , htmlSourceLabel
- , htmlSourcePageHref
- , htmlSourceFragmentHref
- , htmlSupportScriptHref
- ) where
-
-import Base
-import Felix.Source
-import Render.Html.Layout
-
-import Control.Exception (Exception)
-import Data.Map.Strict qualified as Map
-import Data.Text qualified as Text
-
-
-data HtmlRenderContextError
- = HtmlCurrentSourceNotRouted !ResolvedSource
- | HtmlReferencedSourceNotRouted !ResolvedSource
- deriving stock (Show, Eq)
-
-instance Exception HtmlRenderContextError
-
-data HtmlRenderContext = HtmlRenderContext
- { contextCurrentSource :: !ResolvedSource
- , contextCurrentPageUrl :: !UrlPath
- , contextEnvironment :: !HtmlRenderEnvironment
- }
- deriving stock (Show, Eq)
-
-data HtmlRenderEnvironment = HtmlRenderEnvironment
- { environmentSourceUrls :: !(Map ResolvedSource UrlPath)
- , environmentRouteNamespaces :: !(Map SourceMountId UrlPath)
- , environmentSupportScriptUrl :: !UrlPath
- }
- deriving stock (Show, Eq)
-
-htmlRenderEnvironment :: HtmlLayout -> HtmlRenderEnvironment
-htmlRenderEnvironment layout =
- HtmlRenderEnvironment
- { environmentSourceUrls =
- Map.fromList
- [ (source, routeUrlPath route)
- | (source, route) <- htmlPageRoutes layout
- ]
- , environmentRouteNamespaces =
- htmlMountUrlPrefixes layout
- , environmentSupportScriptUrl =
- routeUrlPath (htmlSupportScriptRoute layout)
- }
-
-htmlRenderContext
- :: HtmlLayout
- -> ResolvedSource
- -> Either HtmlRenderContextError HtmlRenderContext
-htmlRenderContext layout =
- htmlRenderContextFromEnvironment
- (htmlRenderEnvironment layout)
-
-htmlRenderContextFromEnvironment
- :: HtmlRenderEnvironment
- -> ResolvedSource
- -> Either HtmlRenderContextError HtmlRenderContext
-htmlRenderContextFromEnvironment environment currentSource = do
- currentPageUrl <-
- maybe
- (Left (HtmlCurrentSourceNotRouted currentSource))
- Right
- (Map.lookup
- currentSource
- (environmentSourceUrls environment))
- Right
- HtmlRenderContext
- { contextCurrentSource = currentSource
- , contextCurrentPageUrl = currentPageUrl
- , contextEnvironment = environment
- }
-
-htmlCurrentSource :: HtmlRenderContext -> ResolvedSource
-htmlCurrentSource =
- contextCurrentSource
-
-htmlCurrentPageUrl :: HtmlRenderContext -> UrlPath
-htmlCurrentPageUrl =
- contextCurrentPageUrl
-
-htmlCurrentPageLabel :: HtmlRenderContext -> Text
-htmlCurrentPageLabel context =
- resolvedSourceLabel (contextCurrentSource context)
-
-htmlRouteNamespaces
- :: HtmlRenderContext
- -> Map SourceMountId UrlPath
-htmlRouteNamespaces =
- environmentRouteNamespaces . contextEnvironment
-
-htmlSourceUrl
- :: HtmlRenderContext
- -> ResolvedSource
- -> Either HtmlRenderContextError UrlPath
-htmlSourceUrl HtmlRenderContext{contextEnvironment} source =
- maybe
- (Left (HtmlReferencedSourceNotRouted source))
- Right
- (Map.lookup source (environmentSourceUrls contextEnvironment))
-
-htmlSourceLabel
- :: HtmlRenderContext
- -> ResolvedSource
- -> Either HtmlRenderContextError Text
-htmlSourceLabel context source = do
- _url <- htmlSourceUrl context source
- Right (resolvedSourceLabel source)
-
-htmlSourcePageHref
- :: HtmlRenderContext
- -> ResolvedSource
- -> Either HtmlRenderContextError Text
-htmlSourcePageHref context source =
- renderRelativeUrlPath
- (contextCurrentPageUrl context)
- <$> htmlSourceUrl context source
-
-htmlSourceFragmentHref
- :: HtmlRenderContext
- -> ResolvedSource
- -> Text
- -> Either HtmlRenderContextError Text
-htmlSourceFragmentHref context source fragment = do
- target <- htmlSourceUrl context source
- let encodedFragment =
- renderUrlFragment fragment
- Right
- (if target == contextCurrentPageUrl context
- then encodedFragment
- else
- renderRelativeUrlPath
- (contextCurrentPageUrl context)
- target
- <> encodedFragment)
-
-htmlSupportScriptHref :: HtmlRenderContext -> Text
-htmlSupportScriptHref context =
- renderRelativeUrlPath
- (contextCurrentPageUrl context)
- (environmentSupportScriptUrl
- (contextEnvironment context))
-
-resolvedSourceLabel :: ResolvedSource -> Text
-resolvedSourceLabel source =
- sourceMountIdText (resolvedSourceMount source)
- <> ":"
- <> Text.pack
- (safeRelativePathFilePath
- (resolvedSourceRelativePath source))