{-# LANGUAGE RecordWildCards #-}
module Emanote.View.Common (
commonSplices,
renderModelTemplate,
routeBreadcrumbs,
generatedCssFile,
TemplateRenderCtx (..),
mkTemplateRenderCtx,
defaultRouteMeta,
) where
import Data.Aeson.Types qualified as Aeson
import Data.Map.Syntax ((##))
import Data.Text qualified as T
import Data.Version (showVersion)
import Ema qualified
import Emanote.Model.Meta qualified as Meta
import Emanote.Model.SData qualified as SData
import Emanote.Model.Title qualified as Tit
import Emanote.Model.Type (Model)
import Emanote.Model.Type qualified as M
import Emanote.Pandoc.BuiltinFilters (preparePandoc)
import Emanote.Pandoc.Renderer (EmanotePandocRenderers (..), PandocRenderers (..))
import Emanote.Pandoc.Renderer qualified as Renderer
import Emanote.Route (LMLRoute)
import Emanote.Route qualified as R
import Emanote.Route.SiteRoute.Class qualified as SR
import Emanote.View.LiveServerFiles qualified as LiveServerFiles
import Heist qualified as H
import Heist.Extra.Splices.List qualified as Splices
import Heist.Extra.Splices.Pandoc.Ctx (RenderCtx)
import Heist.Extra.TemplateState qualified as Tmpl
import Heist.Interpreted qualified as HI
import Heist.Splices.Apply qualified as HA
import Heist.Splices.Bind qualified as HB
import Heist.Splices.Json qualified as HJ
import Optics.Operators ((^.))
import Paths_emanote qualified
import Relude
import System.FilePath ((</>))
import Text.Blaze.Html ((!))
import Text.Blaze.Html5 qualified as H
import Text.Blaze.Html5.Attributes qualified as A
import Text.Blaze.Renderer.XmlHtml qualified as RX
data TemplateRenderCtx n = TemplateRenderCtx
{ forall {k} (n :: k).
TemplateRenderCtx @k n
-> (RenderCtx -> Splice Identity) -> Splice Identity
withInlineCtx :: (RenderCtx -> HI.Splice Identity) -> HI.Splice Identity
, forall {k} (n :: k).
TemplateRenderCtx @k n
-> (RenderCtx -> Splice Identity) -> Splice Identity
withBlockCtx :: (RenderCtx -> HI.Splice Identity) -> HI.Splice Identity
, forall {k} (n :: k).
TemplateRenderCtx @k n
-> (RenderCtx -> Splice Identity) -> Splice Identity
withLinkInlineCtx :: (RenderCtx -> HI.Splice Identity) -> HI.Splice Identity
, forall {k} (n :: k).
TemplateRenderCtx @k n -> Title -> Splice Identity
titleSplice :: Tit.Title -> HI.Splice Identity
}
mkTemplateRenderCtx ::
Model ->
R.LMLRoute ->
Aeson.Value ->
TemplateRenderCtx Identity
mkTemplateRenderCtx :: Model
-> LMLRoute -> Value -> TemplateRenderCtx @(Type -> Type) Identity
mkTemplateRenderCtx Model
model LMLRoute
r Value
meta =
let EmanotePandocRenderers {PandocRenderers Model LMLRoute
linkInlineRenderers :: forall a r. EmanotePandocRenderers a r -> PandocRenderers a r
inlineRenderers :: forall a r. EmanotePandocRenderers a r -> PandocRenderers a r
blockRenderers :: forall a r. EmanotePandocRenderers a r -> PandocRenderers a r
linkInlineRenderers :: PandocRenderers Model LMLRoute
inlineRenderers :: PandocRenderers Model LMLRoute
blockRenderers :: PandocRenderers Model LMLRoute
..} = forall (encF :: Type -> Type).
ModelT encF -> EmanotePandocRenderers Model LMLRoute
M._modelPandocRenderers Model
model
withInlineCtx :: (RenderCtx -> Splice Identity) -> Splice Identity
withInlineCtx =
forall (m :: Type -> Type) x.
Monad m =>
PandocRenderers Model LMLRoute
-> (RenderCtx -> HeistT Identity m x) -> HeistT Identity m x
withRenderCtx PandocRenderers Model LMLRoute
inlineRenderers
withLinkInlineCtx :: (RenderCtx -> Splice Identity) -> Splice Identity
withLinkInlineCtx =
forall (m :: Type -> Type) x.
Monad m =>
PandocRenderers Model LMLRoute
-> (RenderCtx -> HeistT Identity m x) -> HeistT Identity m x
withRenderCtx PandocRenderers Model LMLRoute
linkInlineRenderers
withBlockCtx :: (RenderCtx -> Splice Identity) -> Splice Identity
withBlockCtx =
forall (m :: Type -> Type) x.
Monad m =>
PandocRenderers Model LMLRoute
-> (RenderCtx -> HeistT Identity m x) -> HeistT Identity m x
withRenderCtx PandocRenderers Model LMLRoute
blockRenderers
titleSplice :: Title -> Splice Identity
titleSplice Title
titleDoc = (RenderCtx -> Splice Identity) -> Splice Identity
withLinkInlineCtx forall a b. (a -> b) -> a -> b
$ \RenderCtx
ctx ->
forall b.
(Walkable Inline b, (b :: Type) ~ ([Inline] :: Type)) =>
RenderCtx -> (b -> b) -> Title -> Splice Identity
Tit.titleSplice RenderCtx
ctx forall b. Walkable Inline b => b -> b
preparePandoc Title
titleDoc
in TemplateRenderCtx {Title -> Splice Identity
(RenderCtx -> Splice Identity) -> Splice Identity
titleSplice :: Title -> Splice Identity
withBlockCtx :: (RenderCtx -> Splice Identity) -> Splice Identity
withLinkInlineCtx :: (RenderCtx -> Splice Identity) -> Splice Identity
withInlineCtx :: (RenderCtx -> Splice Identity) -> Splice Identity
titleSplice :: Title -> Splice Identity
withLinkInlineCtx :: (RenderCtx -> Splice Identity) -> Splice Identity
withBlockCtx :: (RenderCtx -> Splice Identity) -> Splice Identity
withInlineCtx :: (RenderCtx -> Splice Identity) -> Splice Identity
..}
where
withRenderCtx ::
(Monad m) =>
PandocRenderers Model LMLRoute ->
(RenderCtx -> H.HeistT Identity m x) ->
H.HeistT Identity m x
withRenderCtx :: forall (m :: Type -> Type) x.
Monad m =>
PandocRenderers Model LMLRoute
-> (RenderCtx -> HeistT Identity m x) -> HeistT Identity m x
withRenderCtx PandocRenderers Model LMLRoute
pandocRenderers RenderCtx -> HeistT Identity m x
f =
RenderCtx -> HeistT Identity m x
f
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall model route (m :: Type -> Type).
Monad m =>
PandocRenderers model route
-> Map Text Text -> model -> route -> HeistT Identity m RenderCtx
Renderer.mkRenderCtxWithPandocRenderers
PandocRenderers Model LMLRoute
pandocRenderers
Map Text Text
classRules
Model
model
LMLRoute
r
classRules :: Map Text Text
classRules :: Map Text Text
classRules =
forall a. FromJSON a => a -> NonEmpty Text -> Value -> a
SData.lookupAeson forall a. Monoid a => a
mempty (Text
"pandoc" forall a. a -> [a] -> NonEmpty a
:| [Text
"rewriteClass"]) Value
meta
defaultRouteMeta :: Model -> (LMLRoute, Aeson.Value)
defaultRouteMeta :: Model -> (LMLRoute, Value)
defaultRouteMeta Model
model =
let r :: LMLRoute
r = forall (f :: Type -> Type). ModelT f -> LMLRoute
M.modelIndexRoute Model
model
meta :: Value
meta = forall (f :: Type -> Type). LMLRoute -> ModelT f -> Value
Meta.getEffectiveRouteMeta LMLRoute
r Model
model
in (LMLRoute
r, Value
meta)
generatedCssFile :: FilePath
generatedCssFile :: FilePath
generatedCssFile = FilePath
"tailwind.css"
commonSplices ::
HasCallStack =>
((RenderCtx -> HI.Splice Identity) -> HI.Splice Identity) ->
Model ->
Aeson.Value ->
Tit.Title ->
H.Splices (HI.Splice Identity)
commonSplices :: HasCallStack =>
((RenderCtx -> Splice Identity) -> Splice Identity)
-> Model -> Value -> Title -> Splices (Splice Identity)
commonSplices (RenderCtx -> Splice Identity) -> Splice Identity
withCtx Model
model Value
meta Title
routeTitle = do
let siteTitle :: Title
siteTitle = forall a. IsString a => FilePath -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> FilePath
toString forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => a -> NonEmpty Text -> Value -> a
SData.lookupAeson @Text Text
"Emanote Site" (Text
"page" forall a. a -> [a] -> NonEmpty a
:| [Text
"siteTitle"]) Value
meta
routeTitleFull :: Title
routeTitleFull =
if Title
routeTitle forall a. Eq a => a -> a -> Bool
== Title
siteTitle
then Title
siteTitle
else Title
routeTitle forall a. Semigroup a => a -> a -> a
<> Title
" – " forall a. Semigroup a => a -> a -> a
<> Title
siteTitle
Text
"bind" forall k v. k -> v -> MapSyntax k v
## forall (n :: Type -> Type). Monad n => Splice n
HB.bindImpl
Text
"apply" forall k v. k -> v -> MapSyntax k v
## forall (n :: Type -> Type). Monad n => Splice n
HA.applyImpl
Text
"tailwindCssShim" forall k v. k -> v -> MapSyntax k v
##
do
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [Node]
RX.renderHtmlNodes forall a b. (a -> b) -> a -> b
$
if Model -> Bool
M.inLiveServer Model
model Bool -> Bool -> Bool
|| Bool -> Bool
not (Model
model forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (encF :: Type -> Type). Lens' (ModelT encF) Bool
M.modelCompileTailwind)
then do
Html
cachedTailwindCdn
else do
Html
H.link
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (forall a. ToValue a => a -> AttributeValue
H.toValue forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
cannotBeCached FilePath
generatedCssFile)
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.rel AttributeValue
"stylesheet"
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.type_ AttributeValue
"text/css"
Text
"ema:version" forall k v. k -> v -> MapSyntax k v
##
forall (m :: Type -> Type) (n :: Type -> Type).
Monad m =>
Text -> HeistT n m [Node]
HI.textSplice (forall a. ToText a => a -> Text
toText forall a b. (a -> b) -> a -> b
$ Version -> FilePath
showVersion Version
Paths_emanote.version)
Text
"ema:metadata" forall k v. k -> v -> MapSyntax k v
##
forall a (n :: Type -> Type). (ToJSON a, Monad n) => a -> Splice n
HJ.bindJson Value
meta
Text
"ema:title" forall k v. k -> v -> MapSyntax k v
## (RenderCtx -> Splice Identity) -> Splice Identity
withCtx forall a b. (a -> b) -> a -> b
$ \RenderCtx
ctx ->
forall b.
(Walkable Inline b, (b :: Type) ~ ([Inline] :: Type)) =>
RenderCtx -> (b -> b) -> Title -> Splice Identity
Tit.titleSplice RenderCtx
ctx forall b. Walkable Inline b => b -> b
preparePandoc Title
routeTitle
Text
"ema:titleFull" forall k v. k -> v -> MapSyntax k v
##
Title -> Splice Identity
Tit.titleSpliceNoHtml Title
routeTitleFull
Text
"ema:homeUrl" forall k v. k -> v -> MapSyntax k v
##
( let homeR :: SiteRoute
homeR = LMLRoute -> SiteRoute
SR.lmlSiteRoute (forall (f :: Type -> Type). ModelT f -> LMLRoute
M.modelIndexRoute Model
model)
homeUrl' :: Text
homeUrl' = HasCallStack => Model -> SiteRoute -> Text
SR.siteRouteUrl Model
model SiteRoute
homeR
homeUrl :: Text
homeUrl = if Text
homeUrl' forall a. Eq a => a -> a -> Bool
/= Text
"" then Text
homeUrl' forall a. Semigroup a => a -> a -> a
<> Text
"/" else Text
homeUrl'
in forall (m :: Type -> Type) (n :: Type -> Type).
Monad m =>
Text -> HeistT n m [Node]
HI.textSplice Text
homeUrl
)
Text
"ema:indexUrl" forall k v. k -> v -> MapSyntax k v
##
forall (m :: Type -> Type) (n :: Type -> Type).
Monad m =>
Text -> HeistT n m [Node]
HI.textSplice (HasCallStack => Model -> SiteRoute -> Text
SR.siteRouteUrl Model
model SiteRoute
SR.indexRoute)
Text
"ema:tagIndexUrl" forall k v. k -> v -> MapSyntax k v
##
forall (m :: Type -> Type) (n :: Type -> Type).
Monad m =>
Text -> HeistT n m [Node]
HI.textSplice (HasCallStack => Model -> SiteRoute -> Text
SR.siteRouteUrl Model
model forall a b. (a -> b) -> a -> b
$ [TagNode] -> SiteRoute
SR.tagIndexRoute [])
Text
"ema:taskIndexUrl" forall k v. k -> v -> MapSyntax k v
##
forall (m :: Type -> Type) (n :: Type -> Type).
Monad m =>
Text -> HeistT n m [Node]
HI.textSplice (HasCallStack => Model -> SiteRoute -> Text
SR.siteRouteUrl Model
model SiteRoute
SR.taskIndexRoute)
Text
"ema:emanoteStaticLayerUrl" forall k v. k -> v -> MapSyntax k v
##
forall (m :: Type -> Type) (n :: Type -> Type).
Monad m =>
Text -> HeistT n m [Node]
HI.textSplice
(
let staticFolder :: FilePath
staticFolder = FilePath
"_emanote-static"
itUrl :: Text
itUrl =
HasCallStack => Model -> SiteRoute -> Text
SR.siteRouteUrl Model
model forall a b. (a -> b) -> a -> b
$
StaticFile -> SiteRoute
SR.staticFileSiteRoute forall a b. (a -> b) -> a -> b
$
forall a. a -> Maybe a -> a
fromMaybe (forall a t. (HasCallStack, IsText t) => t -> a
error Text
"no _emanote-static?") forall a b. (a -> b) -> a -> b
$
forall (f :: Type -> Type).
FilePath -> ModelT f -> Maybe StaticFile
M.modelLookupStaticFile (FilePath
staticFolder FilePath -> FilePath -> FilePath
</> FilePath
"inverted-tree.css") Model
model
staticFolderUrl :: Text
staticFolderUrl = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
T.breakOn Text
"/inverted-tree.css" Text
itUrl
patchForFirefoxBug :: FilePath -> Text -> Text
patchForFirefoxBug FilePath
folder Text
url =
if Model -> Bool
M.inLiveServer Model
model Bool -> Bool -> Bool
&& Text
url forall a. Eq a => a -> a -> Bool
== forall a. ToText a => a -> Text
toText FilePath
folder
then Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
url
else Text
url
in FilePath -> Text -> Text
patchForFirefoxBug FilePath
staticFolder Text
staticFolderUrl
)
Text
"ema:urlStrategySuffix" forall k v. k -> v -> MapSyntax k v
##
forall (m :: Type -> Type) (n :: Type -> Type).
Monad m =>
Text -> HeistT n m [Node]
HI.textSplice (Model -> Text
SR.urlStrategySuffix Model
model)
where
cannotBeCached :: FilePath -> FilePath
cannotBeCached FilePath
url = FilePath
url forall a. Semigroup a => a -> a -> a
<> FilePath
"?instanceId=" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show (Model
model forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (encF :: Type -> Type). Lens' (ModelT encF) UUID
M.modelInstanceID)
cachedTailwindCdn :: Html
cachedTailwindCdn = do
let localCdnUrl :: Text
localCdnUrl =
HasCallStack => Model -> SiteRoute -> Text
SR.siteRouteUrl Model
model forall a b. (a -> b) -> a -> b
$
StaticFile -> SiteRoute
SR.staticFileSiteRoute forall a b. (a -> b) -> a -> b
$
Model -> StaticFile
LiveServerFiles.tailwindCssFile Model
model
Html
H.link
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (forall a. ToValue a => a -> AttributeValue
H.toValue Text
localCdnUrl)
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.rel AttributeValue
"stylesheet"
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.type_ AttributeValue
"text/css"
renderModelTemplate :: Model -> Tmpl.TemplateName -> H.Splices (HI.Splice Identity) -> LByteString
renderModelTemplate :: Model -> TemplateName -> Splices (Splice Identity) -> LByteString
renderModelTemplate Model
model TemplateName
templateName =
let handleErr :: Text -> LByteString
handleErr =
if Model -> Bool
M.inLiveServer Model
model
then Text -> LByteString
Ema.emaErrorHtmlResponse
else
forall a t. (HasCallStack, IsText t) => t -> a
error
in
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> LByteString
handleErr forall a. a -> a
id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (HasCallStack =>
TemplateName
-> Splices (Splice Identity)
-> TemplateState
-> Either Text LByteString
Tmpl.renderHeistTemplate TemplateName
templateName) (Model
model forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (encF :: Type -> Type). Lens' (ModelT encF) TemplateState
M.modelHeistTemplate)
routeBreadcrumbs :: TemplateRenderCtx n -> Model -> LMLRoute -> HI.Splice Identity
routeBreadcrumbs :: forall {k} (n :: k).
TemplateRenderCtx @k n -> Model -> LMLRoute -> Splice Identity
routeBreadcrumbs TemplateRenderCtx {Title -> Splice Identity
(RenderCtx -> Splice Identity) -> Splice Identity
titleSplice :: Title -> Splice Identity
withLinkInlineCtx :: (RenderCtx -> Splice Identity) -> Splice Identity
withBlockCtx :: (RenderCtx -> Splice Identity) -> Splice Identity
withInlineCtx :: (RenderCtx -> Splice Identity) -> Splice Identity
titleSplice :: forall {k} (n :: k).
TemplateRenderCtx @k n -> Title -> Splice Identity
withLinkInlineCtx :: forall {k} (n :: k).
TemplateRenderCtx @k n
-> (RenderCtx -> Splice Identity) -> Splice Identity
withBlockCtx :: forall {k} (n :: k).
TemplateRenderCtx @k n
-> (RenderCtx -> Splice Identity) -> Splice Identity
withInlineCtx :: forall {k} (n :: k).
TemplateRenderCtx @k n
-> (RenderCtx -> Splice Identity) -> Splice Identity
..} Model
model LMLRoute
r = do
let breadcrumbs :: [LMLRoute]
breadcrumbs =
LMLRoute
r
forall a b. a -> (a -> b) -> b
& LMLRoute
-> Either
(R @SourceExt ('LMLType 'Md)) (R @SourceExt ('LMLType 'Org))
R.lmlRouteCase
forall a b. a -> (a -> b) -> b
& forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {a} (ext :: FileType a). R @a ext -> NonEmpty (R @a ext)
R.routeInits (forall {a} (ext :: FileType a). R @a ext -> NonEmpty (R @a ext)
R.routeInits forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible @Type a b => a -> b
coerce)
forall a b. a -> (a -> b) -> b
& forall (f :: Type -> Type) a.
IsNonEmpty f a [a] "init" =>
f a -> [a]
init
forall a b. a -> (a -> b) -> b
& forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (lmlType :: LML) (f :: Type -> Type).
ModelT f -> R @SourceExt ('LMLType lmlType) -> LMLRoute
M.resolveLmlRoute Model
model)
forall a.
[a] -> Text -> (a -> Splices (Splice Identity)) -> Splice Identity
Splices.listSplice [LMLRoute]
breadcrumbs Text
"each-crumb" forall a b. (a -> b) -> a -> b
$ \LMLRoute
crumbR -> do
Text
"crumb:url" forall k v. k -> v -> MapSyntax k v
## forall (m :: Type -> Type) (n :: Type -> Type).
Monad m =>
Text -> HeistT n m [Node]
HI.textSplice (HasCallStack => Model -> SiteRoute -> Text
SR.siteRouteUrl Model
model forall a b. (a -> b) -> a -> b
$ LMLRoute -> SiteRoute
SR.lmlSiteRoute LMLRoute
crumbR)
Text
"crumb:title" forall k v. k -> v -> MapSyntax k v
## Title -> Splice Identity
titleSplice (forall (f :: Type -> Type). LMLRoute -> ModelT f -> Title
M.modelLookupTitle LMLRoute
crumbR Model
model)