bit-badger/myWebLog
1
0
Fork 0
Code Issues 2 Pull Requests Packages Projects Releases 11 Activity

WIP: conversion to Fluid (#47)

Browse Source
This commit is contained in:
Daniel J. Summers
2024-08-24 20:47:23 -04:00
parent cc3e41ddc5
commit d047035173
14 changed files with 553 additions and 393 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/MyWebLog/Handlers/Helpers.fs
+59 -196
View File
@@ -19,112 +19,9 @@ type ISession with
| item -> Some (JsonSerializer.Deserialize<'T> item)
/// Keys used in the myWebLog-standard DotLiquid hash
module ViewContext =
/// The anti cross-site request forgery (CSRF) token set to use for form submissions
[<Literal>]
let AntiCsrfTokens = "csrf"
/// The unified application view context
[<Literal>]
let AppViewContext = "app"
/// The categories for this web log
[<Literal>]
let Categories = "categories"
/// The main content of the view
[<Literal>]
let Content = "content"
/// The current page URL
[<Literal>]
let CurrentPage = "current_page"
/// The generator string for the current version of myWebLog
[<Literal>]
let Generator = "generator"
/// The HTML to load htmx from the unpkg CDN
[<Literal>]
let HtmxScript = "htmx_script"
/// Whether the current user has Administrator privileges
[<Literal>]
let IsAdministrator = "is_administrator"
/// Whether the current user has Author (or above) privileges
[<Literal>]
let IsAuthor = "is_author"
/// Whether the current view is displaying a category archive page
[<Literal>]
let IsCategory = "is_category"
/// Whether the current view is displaying the first page of a category archive
[<Literal>]
let IsCategoryHome = "is_category_home"
/// Whether the current user has Editor (or above) privileges
[<Literal>]
let IsEditor = "is_editor"
/// Whether the current view is the home page for the web log
[<Literal>]
let IsHome = "is_home"
/// Whether there is a user logged on
[<Literal>]
let IsLoggedOn = "is_logged_on"
/// Whether the current view is displaying a page
[<Literal>]
let IsPage = "is_page"
/// Whether the current view is displaying a post
[<Literal>]
let IsPost = "is_post"
/// Whether the current view is a tag archive page
[<Literal>]
let IsTag = "is_tag"
/// Whether the current view is the first page of a tag archive
[<Literal>]
let IsTagHome = "is_tag_home"
/// Whether the current user has Web Log Admin (or above) privileges
[<Literal>]
let IsWebLogAdmin = "is_web_log_admin"
/// Messages to be displayed to the user
[<Literal>]
let Messages = "messages"
/// The view model / form for the page
[<Literal>]
let Model = "model"
/// The listed pages for the web log
[<Literal>]
let PageList = "page_list"
/// The title of the page being displayed
[<Literal>]
let PageTitle = "page_title"
/// The slug for category or tag archive pages
[<Literal>]
let Slug = "slug"
/// The ID of the current user
[<Literal>]
let UserId = "user_id"
/// The current web log
[<Literal>]
let WebLog = "web_log"
/// Messages to be displayed to the user
[<Literal>]
let MESSAGES = "messages"
/// The HTTP item key for loading the session
@@ -147,36 +44,25 @@ open MyWebLog.ViewModels
/// Add a message to the user's session
let addMessage (ctx: HttpContext) message = task {
do! loadSession ctx
let msg = match ctx.Session.TryGet<UserMessage list> ViewContext.Messages with Some it -> it | None -> []
ctx.Session.Set(ViewContext.Messages, message :: msg)
let msg = match ctx.Session.TryGet<UserMessage list> MESSAGES with Some it -> it | None -> []
ctx.Session.Set(MESSAGES, message :: msg)
}
/// Get any messages from the user's session, removing them in the process
let messages (ctx: HttpContext) = task {
do! loadSession ctx
match ctx.Session.TryGet<UserMessage list> ViewContext.Messages with
match ctx.Session.TryGet<UserMessage list> MESSAGES with
| Some msg ->
ctx.Session.Remove ViewContext.Messages
ctx.Session.Remove MESSAGES
return msg |> (List.rev >> Array.ofList)
| None -> return [||]
}
open MyWebLog
open DotLiquid
/// Shorthand for creating a DotLiquid hash from an anonymous object
let makeHash (values: obj) =
Hash.FromAnonymousObject values
/// Create a hash with the page title filled
let hashForPage (title: string) =
makeHash {| page_title = title |}
/// Add a key to the hash, returning the modified hash
// (note that the hash itself is mutated; this is only used to make it pipeable)
let addToHash key (value: obj) (hash: Hash) =
if hash.ContainsKey key then hash[key] <- value else hash.Add(key, value)
hash
/// Create a view context with the page title filled
let viewCtxForPage title =
{ AppViewContext.Empty with PageTitle = title }
open System.Security.Claims
open Giraffe
@@ -194,54 +80,31 @@ let private getCurrentMessages ctx = task {
}
/// Generate the view context for a response
let private generateViewContext pageTitle messages includeCsrf (ctx: HttpContext) =
{ WebLog = ctx.WebLog
UserId = ctx.User.Claims
|> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.NameIdentifier)
|> Option.map (fun claim -> WebLogUserId claim.Value)
PageTitle = pageTitle
Csrf = if includeCsrf then Some ctx.CsrfTokenSet else None
PageList = PageListCache.get ctx
Categories = CategoryCache.get ctx
CurrentPage = ctx.Request.Path.Value[1..]
Messages = messages
Generator = ctx.Generator
HtmxScript = htmxScript
IsAuthor = ctx.HasAccessLevel Author
IsEditor = ctx.HasAccessLevel Editor
IsWebLogAdmin = ctx.HasAccessLevel WebLogAdmin
IsAdministrator = ctx.HasAccessLevel Administrator }
let private generateViewContext messages viewCtx (ctx: HttpContext) =
{ viewCtx with
WebLog = ctx.WebLog
UserId = ctx.User.Claims
|> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.NameIdentifier)
|> Option.map (fun claim -> WebLogUserId claim.Value)
Csrf = Some ctx.CsrfTokenSet
PageList = PageListCache.get ctx
Categories = CategoryCache.get ctx
CurrentPage = ctx.Request.Path.Value[1..]
Messages = messages
Generator = ctx.Generator
HtmxScript = htmxScript
IsAuthor = ctx.HasAccessLevel Author
IsEditor = ctx.HasAccessLevel Editor
IsWebLogAdmin = ctx.HasAccessLevel WebLogAdmin
IsAdministrator = ctx.HasAccessLevel Administrator }
/// Populate the DotLiquid hash with standard information
let addViewContext ctx (hash: Hash) = task {
/// Update the view context with standard information (if it has not been done yet) or updated messages
let updateViewContext ctx viewCtx = task {
let! messages = getCurrentMessages ctx
if hash.ContainsKey ViewContext.AppViewContext then
let oldApp = hash[ViewContext.AppViewContext] :?> AppViewContext
let newApp = { oldApp with Messages = Array.concat [ oldApp.Messages; messages ] }
return
hash
|> addToHash ViewContext.AppViewContext newApp
|> addToHash ViewContext.Messages newApp.Messages
if viewCtx.Generator = "" then
return generateViewContext messages viewCtx ctx
else
let app =
generateViewContext (string hash[ViewContext.PageTitle]) messages
(hash.ContainsKey ViewContext.AntiCsrfTokens) ctx
return
hash
|> addToHash ViewContext.UserId (app.UserId |> Option.map string |> Option.defaultValue "")
|> addToHash ViewContext.WebLog app.WebLog
|> addToHash ViewContext.PageList app.PageList
|> addToHash ViewContext.Categories app.Categories
|> addToHash ViewContext.CurrentPage app.CurrentPage
|> addToHash ViewContext.Messages app.Messages
|> addToHash ViewContext.Generator app.Generator
|> addToHash ViewContext.HtmxScript app.HtmxScript
|> addToHash ViewContext.IsLoggedOn app.IsLoggedOn
|> addToHash ViewContext.IsAuthor app.IsAuthor
|> addToHash ViewContext.IsEditor app.IsEditor
|> addToHash ViewContext.IsWebLogAdmin app.IsWebLogAdmin
|> addToHash ViewContext.IsAdministrator app.IsAdministrator
return { viewCtx with Messages = Array.concat [ viewCtx.Messages; messages ] }
}
/// Is the request from htmx?
@@ -311,65 +174,65 @@ module Error =
else ServerErrors.INTERNAL_ERROR message earlyReturn ctx)
/// Render a view for the specified theme, using the specified template, layout, and hash
let viewForTheme themeId template next ctx (hash: Hash) = task {
let! hash = addViewContext ctx hash
/// Render a view for the specified theme, using the specified template, layout, and context
let viewForTheme themeId template next ctx (viewCtx: AppViewContext) = task {
let! updated = updateViewContext ctx viewCtx
// NOTE: DotLiquid does not support {% render %} or {% include %} in its templates, so we will do a 2-pass render;
// the net effect is a "layout" capability similar to Razor or Pug
// NOTE: Although Fluid's view engine support implements layouts and sections, it also relies on the filesystem.
// As we are loading templates from memory or a database, we do a 2-pass render; the first for the content,
// the second for the overall page.
// Render view content...
match! TemplateCache.get themeId template ctx.Data with
match! Template.Cache.get themeId template ctx.Data with
| Ok contentTemplate ->
let _ = addToHash ViewContext.Content (contentTemplate.Render hash) hash
let forLayout = { updated with Content = Template.render contentTemplate updated }
// ...then render that content with its layout
match! TemplateCache.get themeId (if isHtmx ctx then "layout-partial" else "layout") ctx.Data with
| Ok layoutTemplate -> return! htmlString (layoutTemplate.Render hash) next ctx
match! Template.Cache.get themeId (if isHtmx ctx then "layout-partial" else "layout") ctx.Data with
| Ok layoutTemplate -> return! htmlString (Template.render layoutTemplate forLayout) next ctx
| Error message -> return! Error.server message next ctx
| Error message -> return! Error.server message next ctx
}
/// Render a bare view for the specified theme, using the specified template and hash
let bareForTheme themeId template next ctx (hash: Hash) = task {
let! hash = addViewContext ctx hash
/// Render a bare view for the specified theme, using the specified template and context
let bareForTheme themeId template next ctx viewCtx = task {
let! updated = updateViewContext ctx viewCtx
let withContent = task {
if hash.ContainsKey ViewContext.Content then return Ok hash
if updated.Content = "" then
match! Template.Cache.get themeId template ctx.Data with
| Ok contentTemplate -> return Ok { updated with Content = Template.render contentTemplate updated }
| Error message -> return Error message
else
match! TemplateCache.get themeId template ctx.Data with
| Ok contentTemplate -> return Ok(addToHash ViewContext.Content (contentTemplate.Render hash) hash)
| Error message -> return Error message
return Ok viewCtx
}
match! withContent with
| Ok completeHash ->
| Ok completeCtx ->
// Bare templates are rendered with layout-bare
match! TemplateCache.get themeId "layout-bare" ctx.Data with
match! Template.Cache.get themeId "layout-bare" ctx.Data with
| Ok layoutTemplate ->
return!
(messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage array)
>=> htmlString (layoutTemplate.Render completeHash))
(messagesToHeaders completeCtx.Messages >=> htmlString (Template.render layoutTemplate completeCtx))
next ctx
| Error message -> return! Error.server message next ctx
| Error message -> return! Error.server message next ctx
}
/// Return a view for the web log's default theme
let themedView template next ctx hash = task {
let! hash = addViewContext ctx hash
return! viewForTheme (hash[ViewContext.WebLog] :?> WebLog).ThemeId template next ctx hash
let themedView template next (ctx: HttpContext) viewCtx = task {
return! viewForTheme ctx.WebLog.ThemeId template next ctx viewCtx
}
/// Display a page for an admin endpoint
let adminPage pageTitle includeCsrf next ctx (content: AppViewContext -> XmlNode list) = task {
let adminPage pageTitle next ctx (content: AppViewContext -> XmlNode list) = task {
let! messages = getCurrentMessages ctx
let appCtx = generateViewContext pageTitle messages includeCsrf ctx
let appCtx = generateViewContext messages (viewCtxForPage pageTitle) ctx
let layout = if isHtmx ctx then Layout.partial else Layout.full
return! htmlString (layout content appCtx |> RenderView.AsString.htmlDocument) next ctx
}
/// Display a bare page for an admin endpoint
let adminBarePage pageTitle includeCsrf next ctx (content: AppViewContext -> XmlNode list) = task {
let adminBarePage pageTitle next ctx (content: AppViewContext -> XmlNode list) = task {
let! messages = getCurrentMessages ctx
let appCtx = generateViewContext pageTitle messages includeCsrf ctx
let appCtx = generateViewContext messages (viewCtxForPage pageTitle) ctx
return!
( messagesToHeaders appCtx.Messages
>=> htmlString (Layout.bare content appCtx |> RenderView.AsString.htmlDocument)) next ctx