1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
|
{-# 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))
|
