From d04703517300bb73e610ea15ed4c045f777f588a Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 24 Aug 2024 20:47:23 -0400 Subject: [PATCH] WIP: conversion to Fluid (#47) --- src/MyWebLog/Caches.fs | 64 ------- src/MyWebLog/Handlers/Admin.fs | 28 +-- src/MyWebLog/Handlers/Feed.fs | 2 +- src/MyWebLog/Handlers/Helpers.fs | 255 +++++++--------------------- src/MyWebLog/Handlers/Page.fs | 12 +- src/MyWebLog/Handlers/Post.fs | 96 +++++------ src/MyWebLog/Handlers/Routes.fs | 11 +- src/MyWebLog/Handlers/Upload.fs | 4 +- src/MyWebLog/Handlers/User.fs | 10 +- src/MyWebLog/MyWebLog.fsproj | 3 + src/MyWebLog/Template.fs | 282 +++++++++++++++++++++++++++++++ src/MyWebLog/ViewContext.fs | 126 ++++++++++++++ src/MyWebLog/Views/Admin.fs | 2 +- src/MyWebLog/Views/Helpers.fs | 51 ------ 14 files changed, 553 insertions(+), 393 deletions(-) create mode 100644 src/MyWebLog/Template.fs create mode 100644 src/MyWebLog/ViewContext.fs diff --git a/src/MyWebLog/Caches.fs b/src/MyWebLog/Caches.fs index c459920..0c141de 100644 --- a/src/MyWebLog/Caches.fs +++ b/src/MyWebLog/Caches.fs @@ -180,70 +180,6 @@ module CategoryCache = } -/// Cache for parsed templates -module TemplateCache = - - open System - open System.Text.RegularExpressions - open DotLiquid - - /// Cache of parsed templates - let private _cache = ConcurrentDictionary () - - /// Custom include parameter pattern - let private hasInclude = Regex("""{% include_template \"(.*)\" %}""", RegexOptions.None, TimeSpan.FromSeconds 2) - - /// Get a template for the given theme and template name - let get (themeId: ThemeId) (templateName: string) (data: IData) = backgroundTask { - let templatePath = $"{themeId}/{templateName}" - match _cache.ContainsKey templatePath with - | true -> return Ok _cache[templatePath] - | false -> - match! data.Theme.FindById themeId with - | Some theme -> - match theme.Templates |> List.tryFind (fun t -> t.Name = templateName) with - | Some template -> - let mutable text = template.Text - let mutable childNotFound = "" - while hasInclude.IsMatch text do - let child = hasInclude.Match text - let childText = - match theme.Templates |> List.tryFind (fun t -> t.Name = child.Groups[1].Value) with - | Some childTemplate -> childTemplate.Text - | None -> - childNotFound <- - if childNotFound = "" then child.Groups[1].Value - else $"{childNotFound}; {child.Groups[1].Value}" - "" - text <- text.Replace(child.Value, childText) - if childNotFound <> "" then - let s = if childNotFound.IndexOf ";" >= 0 then "s" else "" - return Error $"Could not find the child template{s} {childNotFound} required by {templateName}" - else - _cache[templatePath] <- Template.Parse(text, SyntaxCompatibility.DotLiquid22) - return Ok _cache[templatePath] - | None -> - return Error $"Theme ID {themeId} does not have a template named {templateName}" - | None -> return Error $"Theme ID {themeId} does not exist" - } - - /// Get all theme/template names currently cached - let allNames () = - _cache.Keys |> Seq.sort |> Seq.toList - - /// Invalidate all template cache entries for the given theme ID - let invalidateTheme (themeId: ThemeId) = - let keyPrefix = string themeId - _cache.Keys - |> Seq.filter _.StartsWith(keyPrefix) - |> List.ofSeq - |> List.iter (fun key -> match _cache.TryRemove key with _, _ -> ()) - - /// Remove all entries from the template cache - let empty () = - _cache.Clear() - - /// A cache of asset names by themes module ThemeAssetCache = diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 38cfcf3..915b835 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -28,13 +28,13 @@ module Dashboard = ListedPages = listed Categories = cats TopLevelCategories = topCats } - return! adminPage "Dashboard" false next ctx (Views.WebLog.dashboard model) + return! adminPage "Dashboard" next ctx (Views.WebLog.dashboard model) } // GET /admin/administration let admin : HttpHandler = requireAccess Administrator >=> fun next ctx -> task { let! themes = ctx.Data.Theme.All() - return! adminPage "myWebLog Administration" true next ctx (Views.Admin.dashboard themes) + return! adminPage "myWebLog Administration" next ctx (Views.Admin.dashboard themes) } /// Redirect the user to the admin dashboard @@ -71,7 +71,7 @@ module Cache = let refreshTheme themeId : HttpHandler = requireAccess Administrator >=> fun next ctx -> task { let data = ctx.Data if themeId = "all" then - TemplateCache.empty () + Template.Cache.empty () do! ThemeAssetCache.fill data do! addMessage ctx { UserMessage.Success with @@ -79,7 +79,7 @@ module Cache = else match! data.Theme.FindById(ThemeId themeId) with | Some theme -> - TemplateCache.invalidateTheme theme.Id + Template.Cache.invalidateTheme theme.Id do! ThemeAssetCache.refreshTheme theme.Id data do! addMessage ctx { UserMessage.Success with @@ -98,7 +98,7 @@ module Category = // GET /admin/categories let all : HttpHandler = fun next ctx -> let response = fun next ctx -> - adminPage "Categories" true next ctx (Views.WebLog.categoryList (ctx.Request.Query.ContainsKey "new")) + adminPage "Categories" next ctx (Views.WebLog.categoryList (ctx.Request.Query.ContainsKey "new")) (withHxPushUrl (ctx.WebLog.RelativeUrl (Permalink "admin/categories")) >=> response) next ctx // GET /admin/category/{id}/edit @@ -115,7 +115,7 @@ module Category = | Some (title, cat) -> return! Views.WebLog.categoryEdit (EditCategoryModel.FromCategory cat) - |> adminBarePage title true next ctx + |> adminBarePage title next ctx | None -> return! Error.notFound next ctx } @@ -167,7 +167,7 @@ module RedirectRules = // GET /admin/settings/redirect-rules let all : HttpHandler = fun next ctx -> - adminPage "Redirect Rules" true next ctx (Views.WebLog.redirectList ctx.WebLog.RedirectRules) + adminPage "Redirect Rules" next ctx (Views.WebLog.redirectList ctx.WebLog.RedirectRules) // GET /admin/settings/redirect-rules/[index] let edit idx : HttpHandler = fun next ctx -> @@ -182,7 +182,7 @@ module RedirectRules = Some ("Edit", (Views.WebLog.redirectEdit (EditRedirectRuleModel.FromRule idx (List.item idx rules)))) match titleAndView with - | Some (title, view) -> adminBarePage $"{title} Redirect Rule" true next ctx view + | Some (title, view) -> adminBarePage $"{title} Redirect Rule" next ctx view | None -> Error.notFound next ctx /// Update the web log's redirect rules in the database, the request web log, and the web log cache @@ -247,7 +247,7 @@ module TagMapping = // GET /admin/settings/tag-mappings let all : HttpHandler = fun next ctx -> task { let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id - return! adminBarePage "Tag Mapping List" true next ctx (Views.WebLog.tagMapList mappings) + return! adminBarePage "Tag Mapping List" next ctx (Views.WebLog.tagMapList mappings) } // GET /admin/settings/tag-mapping/{id}/edit @@ -260,7 +260,7 @@ module TagMapping = | Some tm -> return! Views.WebLog.tagMapEdit (EditTagMapModel.FromMapping tm) - |> adminBarePage (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag") true next ctx + |> adminBarePage (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag") next ctx | None -> return! Error.notFound next ctx } @@ -302,12 +302,12 @@ module Theme = let! themes = ctx.Data.Theme.All () return! Views.Admin.themeList (List.map (DisplayTheme.FromTheme WebLogCache.isThemeInUse) themes) - |> adminBarePage "Themes" true next ctx + |> adminBarePage "Themes" next ctx } // GET /admin/theme/new let add : HttpHandler = requireAccess Administrator >=> fun next ctx -> - adminBarePage "Upload a Theme File" true next ctx Views.Admin.themeUpload + adminBarePage "Upload a Theme File" next ctx Views.Admin.themeUpload /// Update the name and version for a theme based on the version.txt file, if present let private updateNameAndVersion (theme: Theme) (zip: ZipArchive) = backgroundTask { @@ -398,7 +398,7 @@ module Theme = do! themeFile.CopyToAsync stream let! _ = loadFromZip themeId stream data do! ThemeAssetCache.refreshTheme themeId data - TemplateCache.invalidateTheme themeId + Template.Cache.invalidateTheme themeId // Ensure the themes directory exists let themeDir = Path.Combine(".", "themes") if not (Directory.Exists themeDir) then Directory.CreateDirectory themeDir |> ignore @@ -464,7 +464,7 @@ module WebLog = return! Views.WebLog.webLogSettings (SettingsModel.FromWebLog ctx.WebLog) themes pages uploads (EditRssModel.FromRssOptions ctx.WebLog.Rss) - |> adminPage "Web Log Settings" true next ctx + |> adminPage "Web Log Settings" next ctx } // POST /admin/settings diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs index 25f055f..55df0ab 100644 --- a/src/MyWebLog/Handlers/Feed.fs +++ b/src/MyWebLog/Handlers/Feed.fs @@ -453,7 +453,7 @@ let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next { Name = string Blog; Value = "Blog" } ] Views.WebLog.feedEdit (EditCustomFeedModel.FromFeed f) ratings mediums - |> adminPage $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed""" true next ctx + |> adminPage $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed""" next ctx | None -> Error.notFound next ctx // POST /admin/settings/rss/save diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index 1a26bea..158648f 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -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 - [] - let AntiCsrfTokens = "csrf" - - /// The unified application view context - [] - let AppViewContext = "app" - - /// The categories for this web log - [] - let Categories = "categories" - - /// The main content of the view - [] - let Content = "content" - - /// The current page URL - [] - let CurrentPage = "current_page" - - /// The generator string for the current version of myWebLog - [] - let Generator = "generator" - - /// The HTML to load htmx from the unpkg CDN - [] - let HtmxScript = "htmx_script" - - /// Whether the current user has Administrator privileges - [] - let IsAdministrator = "is_administrator" - - /// Whether the current user has Author (or above) privileges - [] - let IsAuthor = "is_author" - - /// Whether the current view is displaying a category archive page - [] - let IsCategory = "is_category" - - /// Whether the current view is displaying the first page of a category archive - [] - let IsCategoryHome = "is_category_home" - - /// Whether the current user has Editor (or above) privileges - [] - let IsEditor = "is_editor" - - /// Whether the current view is the home page for the web log - [] - let IsHome = "is_home" - - /// Whether there is a user logged on - [] - let IsLoggedOn = "is_logged_on" - - /// Whether the current view is displaying a page - [] - let IsPage = "is_page" - - /// Whether the current view is displaying a post - [] - let IsPost = "is_post" - - /// Whether the current view is a tag archive page - [] - let IsTag = "is_tag" - - /// Whether the current view is the first page of a tag archive - [] - let IsTagHome = "is_tag_home" - - /// Whether the current user has Web Log Admin (or above) privileges - [] - let IsWebLogAdmin = "is_web_log_admin" - - /// Messages to be displayed to the user - [] - let Messages = "messages" - - /// The view model / form for the page - [] - let Model = "model" - - /// The listed pages for the web log - [] - let PageList = "page_list" - - /// The title of the page being displayed - [] - let PageTitle = "page_title" - - /// The slug for category or tag archive pages - [] - let Slug = "slug" - - /// The ID of the current user - [] - let UserId = "user_id" - - /// The current web log - [] - let WebLog = "web_log" +/// Messages to be displayed to the user +[] +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 ViewContext.Messages with Some it -> it | None -> [] - ctx.Session.Set(ViewContext.Messages, message :: msg) + let msg = match ctx.Session.TryGet 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 ViewContext.Messages with + match ctx.Session.TryGet 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 diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs index f616375..0e47a95 100644 --- a/src/MyWebLog/Handlers/Page.fs +++ b/src/MyWebLog/Handlers/Page.fs @@ -17,7 +17,7 @@ let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task { |> List.ofSeq return! Views.Page.pageList displayPages pageNbr (pages.Length > 25) - |> adminPage "Pages" true next ctx + |> adminPage "Pages" next ctx } // GET /admin/page/{id}/edit @@ -34,7 +34,7 @@ let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task { | Some (title, page) when canEdit page.AuthorId ctx -> let model = EditPageModel.FromPage page let! templates = templatesForTheme ctx "page" - return! adminPage title true next ctx (Views.Page.pageEdit model templates) + return! adminPage title next ctx (Views.Page.pageEdit model templates) | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } @@ -56,7 +56,7 @@ let editPermalinks pgId : HttpHandler = requireAccess Author >=> fun next ctx -> return! ManagePermalinksModel.FromPage pg |> Views.Helpers.managePermalinks - |> adminPage "Manage Prior Permalinks" true next ctx + |> adminPage "Manage Prior Permalinks" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } @@ -84,7 +84,7 @@ let editRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx -> return! ManageRevisionsModel.FromPage pg |> Views.Helpers.manageRevisions - |> adminPage "Manage Page Revisions" true next ctx + |> adminPage "Manage Page Revisions" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } @@ -115,7 +115,7 @@ let private findPageRevision pgId revDate (ctx: HttpContext) = task { let previewRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task { match! findPageRevision pgId revDate ctx with | Some pg, Some rev when canEdit pg.AuthorId ctx -> - return! adminBarePage "" false next ctx (Views.Helpers.commonPreview rev) + return! adminBarePage "" next ctx (Views.Helpers.commonPreview rev) | Some _, Some _ -> return! Error.notAuthorized next ctx | None, _ | _, None -> return! Error.notFound next ctx } @@ -141,7 +141,7 @@ let deleteRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun | Some pg, Some rev when canEdit pg.AuthorId ctx -> do! ctx.Data.Page.Update { pg with Revisions = pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) } do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" } - return! adminBarePage "" false next ctx (fun _ -> []) + return! adminBarePage "" next ctx (fun _ -> []) | Some _, Some _ -> return! Error.notAuthorized next ctx | None, _ | _, None -> return! Error.notFound next ctx diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index b1ae54a..9d5fb44 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -4,6 +4,7 @@ module MyWebLog.Handlers.Post open System open System.Collections.Generic open MyWebLog +open MyWebLog.Views /// Parse a slug and page number from an "everything else" URL let private parseSlugAndPage webLog (slugAndPage: string seq) = @@ -87,30 +88,29 @@ let preparePostList webLog posts listType (url: string) pageNbr perPage (data: I OlderName = olderPost |> Option.map _.Title } return - makeHash {||} - |> addToHash ViewContext.Model model - |> addToHash "tag_mappings" tagMappings - |> addToHash ViewContext.IsPost (match listType with SinglePost -> true | _ -> false) + { AppViewContext.Empty with + Payload = model + TagMappings = Array.ofList tagMappings + IsPost = (match listType with SinglePost -> true | _ -> false) } } open Giraffe // GET /page/{pageNbr} let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task { - let count = ctx.WebLog.PostsPerPage - let data = ctx.Data - let! posts = data.Post.FindPageOfPublishedPosts ctx.WebLog.Id pageNbr count - let! hash = preparePostList ctx.WebLog posts PostList "" pageNbr count data - let title = + let count = ctx.WebLog.PostsPerPage + let data = ctx.Data + let! posts = data.Post.FindPageOfPublishedPosts ctx.WebLog.Id pageNbr count + let! viewCtx = preparePostList ctx.WebLog posts PostList "" pageNbr count data + let title = match pageNbr, ctx.WebLog.DefaultPage with | 1, "posts" -> None | _, "posts" -> Some $"Page {pageNbr}" | _, _ -> Some $"Page {pageNbr} « Posts" return! - match title with Some ttl -> addToHash ViewContext.PageTitle ttl hash | None -> hash - |> function - | hash -> - if pageNbr = 1 && ctx.WebLog.DefaultPage = "posts" then addToHash ViewContext.IsHome true hash else hash + { viewCtx with + PageTitle = defaultArg title viewCtx.PageTitle + IsHome = pageNbr = 1 && ctx.WebLog.DefaultPage = "posts" } |> themedView "index" next ctx } @@ -134,14 +134,15 @@ let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task { match! data.Post.FindPageOfCategorizedPosts webLog.Id (getCategoryIds slug ctx) pageNbr webLog.PostsPerPage with | posts when List.length posts > 0 -> - let! hash = preparePostList webLog posts CategoryList cat.Slug pageNbr webLog.PostsPerPage data + let! viewCtx = preparePostList webLog posts CategoryList cat.Slug pageNbr webLog.PostsPerPage data let pgTitle = if pageNbr = 1 then "" else $""" (Page {pageNbr})""" return! - addToHash ViewContext.PageTitle $"{cat.Name}: Category Archive{pgTitle}" hash - |> addToHash "subtitle" (defaultArg cat.Description "") - |> addToHash ViewContext.IsCategory true - |> addToHash ViewContext.IsCategoryHome (pageNbr = 1) - |> addToHash ViewContext.Slug slug + { viewCtx with + PageTitle = $"{cat.Name}: Category Archive{pgTitle}" + Subtitle = cat.Description + IsCategory = true + IsCategoryHome = (pageNbr = 1) + Slug = Some slug } |> themedView "index" next ctx | _ -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx @@ -169,13 +170,14 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task { else match! data.Post.FindPageOfTaggedPosts webLog.Id tag pageNbr webLog.PostsPerPage with | posts when List.length posts > 0 -> - let! hash = preparePostList webLog posts TagList rawTag pageNbr webLog.PostsPerPage data - let pgTitle = if pageNbr = 1 then "" else $""" (Page {pageNbr})""" + let! viewCtx = preparePostList webLog posts TagList rawTag pageNbr webLog.PostsPerPage data + let pgTitle = if pageNbr = 1 then "" else $" (Page {pageNbr})" return! - addToHash ViewContext.PageTitle $"Posts Tagged “{tag}”{pgTitle}" hash - |> addToHash ViewContext.IsTag true - |> addToHash ViewContext.IsTagHome (pageNbr = 1) - |> addToHash ViewContext.Slug rawTag + { viewCtx with + PageTitle = $"Posts Tagged “{tag}”{pgTitle}" + IsTag = true + IsTagHome = (pageNbr = 1) + Slug = Some rawTag } |> themedView "index" next ctx // Other systems use hyphens for spaces; redirect if this is an old tag link | _ -> @@ -200,9 +202,9 @@ let home : HttpHandler = fun next ctx -> task { match! ctx.Data.Page.FindById (PageId pageId) webLog.Id with | Some page -> return! - hashForPage page.Title - |> addToHash "page" (DisplayPage.FromPage webLog page) - |> addToHash ViewContext.IsHome true + { viewCtxForPage page.Title with + Payload = DisplayPage.FromPage webLog page + IsHome = true } |> themedView (defaultArg page.Template "single-page") next ctx | None -> return! Error.notFound next ctx } @@ -251,10 +253,10 @@ let chapters (post: Post) : HttpHandler = fun next ctx -> // GET /admin/posts // GET /admin/posts/page/{pageNbr} let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task { - let data = ctx.Data - let! posts = data.Post.FindPageOfPosts ctx.WebLog.Id pageNbr 25 - let! hash = preparePostList ctx.WebLog posts AdminList "" pageNbr 25 data - return! adminPage "Posts" true next ctx (Views.Post.list (hash[ViewContext.Model] :?> PostDisplay)) + let data = ctx.Data + let! posts = data.Post.FindPageOfPosts ctx.WebLog.Id pageNbr 25 + let! viewCtx = preparePostList ctx.WebLog posts AdminList "" pageNbr 25 data + return! adminPage "Posts" next ctx (Post.list viewCtx.Posts) } // GET /admin/post/{id}/edit @@ -278,7 +280,7 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { { Name = string No; Value = "No" } { Name = string Clean; Value = "Clean" } ] - return! adminPage title true next ctx (Views.Post.postEdit model templates ratings) + return! adminPage title next ctx (Post.postEdit model templates ratings) | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } @@ -298,8 +300,8 @@ let editPermalinks postId : HttpHandler = requireAccess Author >=> fun next ctx | Some post when canEdit post.AuthorId ctx -> return! ManagePermalinksModel.FromPost post - |> Views.Helpers.managePermalinks - |> adminPage "Manage Prior Permalinks" true next ctx + |> managePermalinks + |> adminPage "Manage Prior Permalinks" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } @@ -326,8 +328,8 @@ let editRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx - | Some post when canEdit post.AuthorId ctx -> return! ManageRevisionsModel.FromPost post - |> Views.Helpers.manageRevisions - |> adminPage "Manage Post Revisions" true next ctx + |> manageRevisions + |> adminPage "Manage Post Revisions" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } @@ -359,7 +361,7 @@ let private findPostRevision postId revDate (ctx: HttpContext) = task { let previewRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task { match! findPostRevision postId revDate ctx with | Some post, Some rev when canEdit post.AuthorId ctx -> - return! adminBarePage "" false next ctx (Views.Helpers.commonPreview rev) + return! adminBarePage "" next ctx (commonPreview rev) | Some _, Some _ -> return! Error.notAuthorized next ctx | None, _ | _, None -> return! Error.notFound next ctx } @@ -385,7 +387,7 @@ let deleteRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fu | Some post, Some rev when canEdit post.AuthorId ctx -> do! ctx.Data.Post.Update { post with Revisions = post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) } do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" } - return! adminBarePage "" false next ctx (fun _ -> []) + return! adminBarePage "" next ctx (fun _ -> []) | Some _, Some _ -> return! Error.notAuthorized next ctx | None, _ | _, None -> return! Error.notFound next ctx @@ -399,8 +401,8 @@ let manageChapters postId : HttpHandler = requireAccess Author >=> fun next ctx && Option.isSome post.Episode.Value.Chapters && canEdit post.AuthorId ctx -> return! - Views.Post.chapters false (ManageChaptersModel.Create post) - |> adminPage "Manage Chapters" true next ctx + Post.chapters false (ManageChaptersModel.Create post) + |> adminPage "Manage Chapters" next ctx | Some _ | None -> return! Error.notFound next ctx } @@ -419,8 +421,8 @@ let editChapter (postId, index) : HttpHandler = requireAccess Author >=> fun nex match chapter with | Some chap -> return! - Views.Post.chapterEdit (EditChapterModel.FromChapter post.Id index chap) - |> adminBarePage (if index = -1 then "Add a Chapter" else "Edit Chapter") true next ctx + Post.chapterEdit (EditChapterModel.FromChapter post.Id index chap) + |> adminBarePage (if index = -1 then "Add a Chapter" else "Edit Chapter") next ctx | None -> return! Error.notFound next ctx | Some _ | None -> return! Error.notFound next ctx } @@ -447,8 +449,8 @@ let saveChapter (postId, index) : HttpHandler = requireAccess Author >=> fun nex do! data.Post.Update updatedPost do! addMessage ctx { UserMessage.Success with Message = "Chapter saved successfully" } return! - Views.Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost) - |> adminBarePage "Manage Chapters" true next ctx + Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost) + |> adminBarePage "Manage Chapters" next ctx with | ex -> return! Error.server ex.Message next ctx else return! Error.notFound next ctx @@ -471,8 +473,8 @@ let deleteChapter (postId, index) : HttpHandler = requireAccess Author >=> fun n do! data.Post.Update updatedPost do! addMessage ctx { UserMessage.Success with Message = "Chapter deleted successfully" } return! - Views.Post.chapterList false (ManageChaptersModel.Create updatedPost) - |> adminPage "Manage Chapters" true next ctx + Post.chapterList false (ManageChaptersModel.Create updatedPost) + |> adminPage "Manage Chapters" next ctx else return! Error.notFound next ctx | Some _ | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 733f29b..432fac4 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -34,9 +34,8 @@ module CatchAll = yield Post.chapters post else yield fun next ctx -> - Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 data - |> await - |> addToHash ViewContext.PageTitle post.Title + { await (Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 data) with + PageTitle = post.Title } |> themedView (defaultArg post.Template "single-post") next ctx | None -> () // Current page @@ -44,9 +43,9 @@ module CatchAll = | Some page -> debug (fun () -> "Found page by permalink") yield fun next ctx -> - hashForPage page.Title - |> addToHash "page" (DisplayPage.FromPage webLog page) - |> addToHash ViewContext.IsPage true + { viewCtxForPage page.Title with + Payload = DisplayPage.FromPage webLog page + IsPage = true } |> themedView (defaultArg page.Template "single-page") next ctx | None -> () // RSS feed diff --git a/src/MyWebLog/Handlers/Upload.fs b/src/MyWebLog/Handlers/Upload.fs index c992eda..29a7ce2 100644 --- a/src/MyWebLog/Handlers/Upload.fs +++ b/src/MyWebLog/Handlers/Upload.fs @@ -120,12 +120,12 @@ let list : HttpHandler = requireAccess Author >=> fun next ctx -> task { |> Seq.append diskUploads |> Seq.sortByDescending (fun file -> file.UpdatedOn, file.Path) |> Views.WebLog.uploadList - |> adminPage "Uploaded Files" true next ctx + |> adminPage "Uploaded Files" next ctx } // GET /admin/upload/new let showNew : HttpHandler = requireAccess Author >=> fun next ctx -> - adminPage "Upload a File" true next ctx Views.WebLog.uploadNew + adminPage "Upload a File" next ctx Views.WebLog.uploadNew // POST /admin/upload/save let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index f9a6edb..df3bac0 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -35,7 +35,7 @@ let logOn returnUrl : HttpHandler = fun next ctx -> match returnUrl with | Some _ -> returnUrl | None -> if ctx.Request.Query.ContainsKey "returnUrl" then Some ctx.Request.Query["returnUrl"].[0] else None - adminPage "Log On" true next ctx (Views.User.logOn { LogOnModel.Empty with ReturnTo = returnTo }) + adminPage "Log On" next ctx (Views.User.logOn { LogOnModel.Empty with ReturnTo = returnTo }) open System.Security.Claims @@ -91,12 +91,12 @@ let private goAway : HttpHandler = RequestErrors.BAD_REQUEST "really?" // GET /admin/settings/users let all : HttpHandler = fun next ctx -> task { let! users = ctx.Data.WebLogUser.FindByWebLog ctx.WebLog.Id - return! adminBarePage "User Administration" true next ctx (Views.User.userList users) + return! adminBarePage "User Administration" next ctx (Views.User.userList users) } /// Show the edit user page let private showEdit (model: EditUserModel) : HttpHandler = fun next ctx -> - adminBarePage (if model.IsNew then "Add a New User" else "Edit User") true next ctx (Views.User.edit model) + adminBarePage (if model.IsNew then "Add a New User" else "Edit User") next ctx (Views.User.edit model) // GET /admin/settings/user/{id}/edit let edit usrId : HttpHandler = fun next ctx -> task { @@ -139,7 +139,7 @@ let myInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { | Some user -> return! Views.User.myInfo (EditMyInfoModel.FromUser user) user - |> adminPage "Edit Your Information" true next ctx + |> adminPage "Edit Your Information" next ctx | None -> return! Error.notFound next ctx } @@ -164,7 +164,7 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { do! addMessage ctx { UserMessage.Error with Message = "Passwords did not match; no updates made" } return! Views.User.myInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user - |> adminPage "Edit Your Information" true next ctx + |> adminPage "Edit Your Information" next ctx | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/MyWebLog.fsproj b/src/MyWebLog/MyWebLog.fsproj index 06b4bf1..c51435d 100644 --- a/src/MyWebLog/MyWebLog.fsproj +++ b/src/MyWebLog/MyWebLog.fsproj @@ -9,6 +9,8 @@ + + @@ -31,6 +33,7 @@ + diff --git a/src/MyWebLog/Template.fs b/src/MyWebLog/Template.fs new file mode 100644 index 0000000..b41fe0f --- /dev/null +++ b/src/MyWebLog/Template.fs @@ -0,0 +1,282 @@ +module MyWebLog.Template + +open Fluid +open Fluid.Values +open Giraffe.ViewEngine +open MyWebLog +open MyWebLog.ViewModels + +/// Alias for ValueTask +type VTask<'T> = System.Threading.Tasks.ValueTask<'T> + + +/// Extensions on Fluid's TemplateContext object +type TemplateContext with + + /// Get the model of the context as an AppViewContext instance + member this.App = + this.Model.ToObjectValue() :?> AppViewContext + + +/// Helper functions for filters and tags +[] +module private Helpers = + + /// Does an asset exist for the current theme? + let assetExists fileName (webLog: WebLog) = + ThemeAssetCache.get webLog.ThemeId |> List.exists (fun it -> it = fileName) + + /// Obtain the link from known types + let permalink (item: FluidValue) (linkFunc: Permalink -> string) = + match item.Type with + | FluidValues.String -> Some (item.ToStringValue()) + | FluidValues.Object -> + match item.ToObjectValue() with + | :? DisplayPage as page -> Some page.Permalink + | :? PostListItem as post -> Some post.Permalink + | :? Permalink as link -> Some (string link) + | _ -> None + | _ -> None + |> function + | Some link -> linkFunc (Permalink link) + | None -> $"alert('unknown item type {item.Type}')" + + /// Generate a link for theme asset (image, stylesheet, script, etc.) + let themeAsset (input: FluidValue) (ctx: TemplateContext) = + let app = ctx.App + app.WebLog.RelativeUrl(Permalink $"themes/{app.WebLog.ThemeId}/{input.ToStringValue()}") + + +/// Fluid template options customized with myWebLog filters +let options = + let sValue = StringValue >> VTask + let it = TemplateOptions.Default + it.MemberAccessStrategy.MemberNameStrategy <- MemberNameStrategies.SnakeCase + + // A filter to generate an absolute link + it.Filters.AddFilter("absolute_link", fun input _ ctx -> sValue (permalink input ctx.App.WebLog.AbsoluteUrl)) + + // A filter to generate a link with posts categorized under the given category + it.Filters.AddFilter("category_link", + fun input _ ctx -> + match input.ToObjectValue() with + | :? DisplayCategory as cat -> Some cat.Slug + | :? string as slug -> Some slug + | _ -> None + |> function + | Some slug -> ctx.App.WebLog.RelativeUrl(Permalink $"category/{slug}/") + | None -> $"alert('unknown category object type {input.Type}')" + |> sValue) + + // A filter to generate a link that will edit a page + it.Filters.AddFilter("edit_page_link", + fun input _ ctx -> + match input.ToObjectValue() with + | :? DisplayPage as page -> Some page.Id + | :? string as theId -> Some theId + | _ -> None + |> function + | Some pageId -> ctx.App.WebLog.RelativeUrl(Permalink $"admin/page/{pageId}/edit") + | None -> $"alert('unknown page object type {input.Type}')" + |> sValue) + + // A filter to generate a link that will edit a post + it.Filters.AddFilter("edit_post_link", + fun input _ ctx -> + match input.ToObjectValue() with + | :? PostListItem as post -> Some post.Id + | :? string as theId -> Some theId + | _ -> None + |> function + | Some postId -> ctx.App.WebLog.RelativeUrl(Permalink $"admin/post/{postId}/edit") + | None -> $"alert('unknown post object type {input.Type}')" + |> sValue) + + // A filter to generate nav links, highlighting the active link (starts-with match) + it.Filters.AddFilter("nav_link", + fun input args ctx -> + let app = ctx.App + let extraPath = app.WebLog.ExtraPath + let path = if extraPath = "" then "" else $"{extraPath[1..]}/" + let url = input.ToStringValue() + seq { + "
  • " + args.At(0).ToStringValue() + "" + } + |> String.concat "" + |> sValue) + + // A filter to generate a relative link + it.Filters.AddFilter("relative_link", fun input _ ctx -> sValue (permalink input ctx.App.WebLog.RelativeUrl)) + + // A filter to generate a link with posts tagged with the given tag + it.Filters.AddFilter("tag_link", + fun input _ ctx -> + let tag = input.ToStringValue() + ctx.App.TagMappings + |> Array.tryFind (fun it -> it.Tag = tag) + |> function + | Some tagMap -> tagMap.UrlValue + | None -> tag.Replace(" ", "+") + |> function tagUrl -> ctx.App.WebLog.RelativeUrl(Permalink $"tag/{tagUrl}/") + |> sValue) + + // A filter to generate a link for theme asset (image, stylesheet, script, etc.) + it.Filters.AddFilter("theme_asset", fun input _ ctx -> sValue (themeAsset input ctx)) + + // A filter to retrieve the value of a meta item from a list + // (shorter than `{% assign item = list | where: "Name", [name] | first %}{{ item.value }}`) + it.Filters.AddFilter("value", + fun input args _ -> + let items = input.ToObjectValue() :?> MetaItem list + let name = args.At(0).ToStringValue() + match items |> List.tryFind (fun it -> it.Name = name) with + | Some item -> item.Value + | None -> $"-- {name} not found --" + |> sValue) + + it + + +/// Fluid parser customized with myWebLog filters and tags +let parser = + // spacer + let s = " " + // Required return for tag delegates + let ok () = + VTask Fluid.Ast.Completion.Normal + + let it = FluidParser() + + // Create various items in the page header based on the state of the page being generated + it.RegisterEmptyTag("page_head", + fun writer encoder context -> + let app = context.App + // let getBool name = + // defaultArg (context.Environments[0].[name] |> Option.ofObj |> Option.map Convert.ToBoolean) false + + writer.WriteLine $"""{s}""" + + // Theme assets + if assetExists "style.css" app.WebLog then + themeAsset (StringValue "style.css") context + |> sprintf "%s" s + |> writer.WriteLine + if assetExists "favicon.ico" app.WebLog then + themeAsset (StringValue "favicon.ico") context + |> sprintf "%s" s + |> writer.WriteLine + + // RSS feeds and canonical URLs + let feedLink title url = + let escTitle = System.Web.HttpUtility.HtmlAttributeEncode title + let relUrl = app.WebLog.RelativeUrl(Permalink url) + $"""{s}""" + + if app.WebLog.Rss.IsFeedEnabled && app.IsHome then + writer.WriteLine(feedLink app.WebLog.Name app.WebLog.Rss.FeedName) + writer.WriteLine $"""{s}""" + + if app.WebLog.Rss.IsCategoryEnabled && app.IsCategoryHome then + let slug = context.AmbientValues["slug"] :?> string + writer.WriteLine(feedLink app.WebLog.Name $"category/{slug}/{app.WebLog.Rss.FeedName}") + + if app.WebLog.Rss.IsTagEnabled && app.IsTagHome then + let slug = context.AmbientValues["slug"] :?> string + writer.WriteLine(feedLink app.WebLog.Name $"tag/{slug}/{app.WebLog.Rss.FeedName}") + + if app.IsPost then + let post = (* context.Environments[0].["model"] *) obj() :?> PostDisplay + let url = app.WebLog.AbsoluteUrl(Permalink post.Posts[0].Permalink) + writer.WriteLine $"""{s}""" + + if app.IsPage then + let page = (* context.Environments[0].["page"] *) obj() :?> DisplayPage + let url = app.WebLog.AbsoluteUrl(Permalink page.Permalink) + writer.WriteLine $"""{s}""" + + ok ()) + + // Create various items in the page footer based on the state of the page being generated + it.RegisterEmptyTag("page_foot", + fun writer encoder context -> + let webLog = context.App.WebLog + if webLog.AutoHtmx then + writer.WriteLine $"{s}{RenderView.AsString.htmlNode Htmx.Script.minified}" + if assetExists "script.js" webLog then + themeAsset (StringValue "script.js") context + |> sprintf "%s" s + |> writer.WriteLine + ok ()) + + // Create links for a user to log on or off, and a dashboard link if they are logged off + it.RegisterEmptyTag("user_links", + fun writer encoder ctx -> + let app = ctx.App + let link it = app.WebLog.RelativeUrl(Permalink it) + seq { + """
      """ + match app.IsLoggedOn with + | true -> + $"""
    • Dashboard""" + $"""
    • Log Off""" + | false -> + $"""
    • Log On""" + "
    " + } + |> Seq.iter writer.WriteLine + ok()) + + it + +/// Cache for parsed templates +module Cache = + + open System.Collections.Concurrent + open MyWebLog.Data + + /// Cache of parsed templates + let private _cache = ConcurrentDictionary () + + /// Get a template for the given theme and template name + let get (themeId: ThemeId) (templateName: string) (data: IData) = backgroundTask { + let templatePath = $"{themeId}/{templateName}" + match _cache.ContainsKey templatePath with + | true -> return Ok _cache[templatePath] + | false -> + match! data.Theme.FindById themeId with + | Some theme -> + match theme.Templates |> List.tryFind (fun t -> t.Name = templateName) with + | Some template -> + _cache[templatePath] <- parser.Parse(template.Text) + return Ok _cache[templatePath] + | None -> + return Error $"Theme ID {themeId} does not have a template named {templateName}" + | None -> return Error $"Theme ID {themeId} does not exist" + } + + /// Get all theme/template names currently cached + let allNames () = + _cache.Keys |> Seq.sort |> Seq.toList + + /// Invalidate all template cache entries for the given theme ID + let invalidateTheme (themeId: ThemeId) = + let keyPrefix = string themeId + _cache.Keys + |> Seq.filter _.StartsWith(keyPrefix) + |> List.ofSeq + |> List.iter (fun key -> match _cache.TryRemove key with _, _ -> ()) + + /// Remove all entries from the template cache + let empty () = + _cache.Clear() + + +/// Render a template to a string +let render (template: IFluidTemplate) (viewCtx: AppViewContext) = + template.Render(TemplateContext(viewCtx, options, true)) diff --git a/src/MyWebLog/ViewContext.fs b/src/MyWebLog/ViewContext.fs new file mode 100644 index 0000000..5e80df1 --- /dev/null +++ b/src/MyWebLog/ViewContext.fs @@ -0,0 +1,126 @@ +/// View rendering context for myWebLog +[] +module MyWebLog.ViewContext + +open Microsoft.AspNetCore.Antiforgery +open MyWebLog.ViewModels + +/// The rendering context for this application +[] +type AppViewContext = { + /// The web log for this request + WebLog: WebLog + + /// The ID of the current user + UserId: WebLogUserId option + + /// The title of the page being rendered + PageTitle: string + + /// The subtitle for the page + Subtitle: string option + + /// The anti-Cross Site Request Forgery (CSRF) token set to use when rendering a form + Csrf: AntiforgeryTokenSet option + + /// The page list for the web log + PageList: DisplayPage array + + /// Categories and post counts for the web log + Categories: DisplayCategory array + + /// Tag mappings + TagMappings: TagMap array + + /// The URL of the page being rendered + CurrentPage: string + + /// User messages + Messages: UserMessage array + + /// The generator string for the rendered page + Generator: string + + /// The payload for this page (see other properties that wrap this one) + Payload: obj + + /// The content of a page (wrapped when rendering the layout) + Content: string + + /// A string to load the minified htmx script + HtmxScript: string + + /// Whether the current user is an author + IsAuthor: bool + + /// Whether the current user is an editor (implies author) + IsEditor: bool + + /// Whether the current user is a web log administrator (implies author and editor) + IsWebLogAdmin: bool + + /// Whether the current user is an installation administrator (implies all web log rights) + IsAdministrator: bool + + /// Whether the current page is the home page of the web log + IsHome: bool + + /// Whether the current page is a category archive page + IsCategory: bool + + /// Whether the current page is a category archive home page + IsCategoryHome: bool + + /// Whether the current page is a tag archive page + IsTag: bool + + /// Whether the current page is a tag archive home page + IsTagHome: bool + + /// Whether the current page is a single post + IsPost: bool + + /// Whether the current page is a static page + IsPage: bool + + /// The slug for a category or tag + Slug: string option } +with + + /// Whether there is a user logged on + member this.IsLoggedOn = Option.isSome this.UserId + + member this.Page = + this.Payload :?> DisplayPage + + member this.Posts = + this.Payload :?> PostDisplay + + /// An empty view context + static member Empty = + { WebLog = WebLog.Empty + UserId = None + PageTitle = "" + Subtitle = None + Csrf = None + PageList = [||] + Categories = [||] + TagMappings = [||] + CurrentPage = "" + Messages = [||] + Generator = "" + Payload = obj () + Content = "" + HtmxScript = "" + IsAuthor = false + IsEditor = false + IsWebLogAdmin = false + IsAdministrator = false + IsHome = false + IsCategory = false + IsCategoryHome = false + IsTag = false + IsTagHome = false + IsPost = false + IsPage = false + Slug = None } diff --git a/src/MyWebLog/Views/Admin.fs b/src/MyWebLog/Views/Admin.fs index a3933db..7226f4b 100644 --- a/src/MyWebLog/Views/Admin.fs +++ b/src/MyWebLog/Views/Admin.fs @@ -8,7 +8,7 @@ open MyWebLog.ViewModels /// The administrator dashboard let dashboard (themes: Theme list) app = [ - let templates = TemplateCache.allNames () + let templates = Template.Cache.allNames () let cacheBaseUrl = relUrl app "admin/cache/" let webLogCacheUrl = $"{cacheBaseUrl}web-log/" let themeCacheUrl = $"{cacheBaseUrl}theme/" diff --git a/src/MyWebLog/Views/Helpers.fs b/src/MyWebLog/Views/Helpers.fs index 8907e37..8740b7e 100644 --- a/src/MyWebLog/Views/Helpers.fs +++ b/src/MyWebLog/Views/Helpers.fs @@ -1,7 +1,6 @@ [] module MyWebLog.Views.Helpers -open Microsoft.AspNetCore.Antiforgery open Giraffe.ViewEngine open Giraffe.ViewEngine.Accessibility open Giraffe.ViewEngine.Htmx @@ -10,56 +9,6 @@ open MyWebLog.ViewModels open NodaTime open NodaTime.Text -/// The rendering context for this application -[] -type AppViewContext = { - /// The web log for this request - WebLog: WebLog - - /// The ID of the current user - UserId: WebLogUserId option - - /// The title of the page being rendered - PageTitle: string - - /// The anti-Cross Site Request Forgery (CSRF) token set to use when rendering a form - Csrf: AntiforgeryTokenSet option - - /// The page list for the web log - PageList: DisplayPage array - - /// Categories and post counts for the web log - Categories: DisplayCategory array - - /// The URL of the page being rendered - CurrentPage: string - - /// User messages - Messages: UserMessage array - - /// The generator string for the rendered page - Generator: string - - /// A string to load the minified htmx script - HtmxScript: string - - /// Whether the current user is an author - IsAuthor: bool - - /// Whether the current user is an editor (implies author) - IsEditor: bool - - /// Whether the current user is a web log administrator (implies author and editor) - IsWebLogAdmin: bool - - /// Whether the current user is an installation administrator (implies all web log rights) - IsAdministrator: bool -} with - - /// Whether there is a user logged on - member this.IsLoggedOn = Option.isSome this.UserId - - /// Create a relative URL for the current web log let relUrl app = Permalink >> app.WebLog.RelativeUrl