{-# LANGUAGE RecordWildCards #-}

module Emanote.View.Common (
  commonSplices,
  renderModelTemplate,
  routeBreadcrumbs,
  generatedCssFile,

  -- * Render context
  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
  }

{- | Create the context in which Heist templates (notably `pandoc.tpl`) will be
 rendered.
-}
mkTemplateRenderCtx ::
  -- | Current model.
  Model ->
  -- | Current route.
  R.LMLRoute ->
  -- | Associated metadata.
  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
      -- TODO: We should be using withInlineCtx, so as to make the wikilink
      -- render in note title.
      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
  -- Heist helpers
  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
  -- Add tailwind css shim
  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
            -- Twind shim doesn't reliably work in dev server mode. Let's just use the
            -- tailwind CDN.
            Html
cachedTailwindCdn
          else do
            Html
H.link
              -- TODO: Use ?md5 to prevent stale browser caching of CSS.
              -- TODO: This should go through Ema route encoder!
              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
  -- <head>'s <title> cannot contain HTML
  Text
"ema:titleFull" forall k v. k -> v -> MapSyntax k v
##
    Title -> Splice Identity
Tit.titleSpliceNoHtml Title
routeTitleFull
  -- `ema:homeUrl` is normally `""`; but if Emanote is being served from an URL
  -- prefix, it would be "/foo/" (with a slash at the end). This allows you to
  -- just concatanate homeUrl with a relative URL path (no slash in between), to
  -- get the full URL. The reason there is no slash in between is to account for
  -- the usual case of homeUrl being an empty string.
  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
      ( -- HACK
        -- Also: more-head.tpl is the one place where this is hardcoded.
        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
            -- Deal with a silly Firefox bug https://github.com/srid/emanote/issues/340
            --
            -- Firefox deduces an incorrect <base> after doing morphdom
            -- patching, unless the <base> is absolute (i.e., starts with a '/').
            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
      )
  -- For those cases the user really wants to hardcode the URL
  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
    -- A hack to force the browser not to cache the CSS, because we are not md5
    -- hashing the CSS yet (because the CSS is generated *after* the HTML files
    -- are generated.)
    -- For a proper way to do this, see: https://github.com/srid/ema/issues/20
    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 -- When staticaly generating, we must fail asap on template errors.
            forall a t. (HasCallStack, IsText t) => t -> a
error
   in -- Until Ema's error handling improves ...
      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
          -- Hardcode to 'Md, and resolve using resolveLmlRoute latter.
          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)