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

WIP on theme admin page (#20)

Browse Source
This commit is contained in:
Daniel J. Summers
2022-07-22 21:19:19 -04:00
parent 4514c4864d
commit 81fe03b8f3
15 changed files with 162 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
src/MyWebLog/Caches.fs
View File

@@ -85,6 +85,10 @@ module WebLogCache =
let! webLogs = data.WebLog.All ()
_cache <- webLogs
}
/// Is the given theme in use by any web logs?
let isThemeInUse themeId =
_cache |> List.exists (fun wl -> wl.ThemeId = themeId)
/// A cache of page information needed to display the page list in templates
@@ -147,12 +151,12 @@ module TemplateCache =
let private hasInclude = Regex ("""{% include_template \"(.*)\" %}""", RegexOptions.None, TimeSpan.FromSeconds 2)
/// Get a template for the given theme and template name
let get (themeId : string) (templateName : string) (data : IData) = backgroundTask {
let templatePath = $"{themeId}/{templateName}"
let get (themeId : ThemeId) (templateName : string) (data : IData) = backgroundTask {
let templatePath = $"{ThemeId.toString themeId}/{templateName}"
match _cache.ContainsKey templatePath with
| true -> ()
| false ->
match! data.Theme.FindById (ThemeId themeId) with
match! data.Theme.FindById themeId with
| Some theme ->
let mutable text = (theme.Templates |> List.find (fun t -> t.Name = templateName)).Text
while hasInclude.IsMatch text do

12
src/MyWebLog/DotLiquidBespoke.fs
View File

@@ -227,12 +227,12 @@ let register () =
typeof<CustomFeed>; typeof<Episode>; typeof<Episode option>; typeof<MetaItem>; typeof<Page>
typeof<RssOptions>; typeof<TagMap>; typeof<UploadDestination>; typeof<WebLog>
// View models
typeof<DashboardModel>; typeof<DisplayCategory>; typeof<DisplayCustomFeed>; typeof<DisplayPage>
typeof<DisplayRevision>; typeof<DisplayUpload>; typeof<DisplayUser>; typeof<EditCategoryModel>
typeof<EditCustomFeedModel>; typeof<EditMyInfoModel>; typeof<EditPageModel>; typeof<EditPostModel>
typeof<EditRssModel>; typeof<EditTagMapModel>; typeof<EditUserModel>; typeof<LogOnModel>
typeof<ManagePermalinksModel>; typeof<ManageRevisionsModel>; typeof<PostDisplay>; typeof<PostListItem>
typeof<SettingsModel>; typeof<UserMessage>
typeof<DashboardModel>; typeof<DisplayCategory>; typeof<DisplayCustomFeed>; typeof<DisplayPage>
typeof<DisplayRevision>; typeof<DisplayTheme>; typeof<DisplayUpload>; typeof<DisplayUser>
typeof<EditCategoryModel>; typeof<EditCustomFeedModel>; typeof<EditMyInfoModel>; typeof<EditPageModel>
typeof<EditPostModel>; typeof<EditRssModel>; typeof<EditTagMapModel>; typeof<EditUserModel>
typeof<LogOnModel>; typeof<ManagePermalinksModel>; typeof<ManageRevisionsModel>; typeof<PostDisplay>
typeof<PostListItem>; typeof<SettingsModel>; typeof<UserMessage>
// Framework types
typeof<AntiforgeryTokenSet>; typeof<DateTime option>; typeof<int option>; typeof<KeyValuePair>
typeof<MetaItem list>; typeof<string list>; typeof<string option>; typeof<TagMap list>

17
src/MyWebLog/Handlers/Admin.fs
View File

@@ -34,7 +34,7 @@ let dashboard : HttpHandler = requireAccess Author >=> fun next ctx -> task {
// GET /admin/categories
let listCategories : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! catListTemplate = TemplateCache.get "admin" "category-list-body" ctx.Data
let! catListTemplate = TemplateCache.get adminTheme "category-list-body" ctx.Data
let! hash =
hashForPage "Categories"
|> withAntiCsrf ctx
@@ -122,7 +122,7 @@ let private tagMappingHash (ctx : HttpContext) = task {
// GET /admin/settings/tag-mappings
let tagMappings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! hash = tagMappingHash ctx
let! listTemplate = TemplateCache.get "admin" "tag-mapping-list-body" ctx.Data
let! listTemplate = TemplateCache.get adminTheme "tag-mapping-list-body" ctx.Data
return!
addToHash "tag_mapping_list" (listTemplate.Render hash) hash
|> adminView "tag-mapping-list" next ctx
@@ -181,6 +181,19 @@ open System.IO.Compression
open System.Text.RegularExpressions
open MyWebLog.Data
// GET /admin/themes
let listThemes : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
let! themes = ctx.Data.Theme.All ()
let! bodyTemplate = TemplateCache.get adminTheme "theme-list-body" ctx.Data
let hash =
hashForPage "Theme Administration"
|> withAntiCsrf ctx
|> addToHash "themes" (themes |> List.map (DisplayTheme.fromTheme WebLogCache.isThemeInUse) |> Array.ofList)
return!
addToHash "theme_list" (bodyTemplate.Render hash) hash
|> adminView "theme-list" next ctx
}
// GET /admin/theme/update
let themeUpdatePage : HttpHandler = requireAccess Administrator >=> fun next ctx ->
hashForPage "Upload Theme"

18
src/MyWebLog/Handlers/Helpers.fs
View File

@@ -221,16 +221,16 @@ let isHtmx (ctx : HttpContext) =
/// 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
let (ThemeId theme) = themeId
// 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
// Render view content...
let! contentTemplate = TemplateCache.get theme template ctx.Data
let! contentTemplate = TemplateCache.get themeId template ctx.Data
let _ = addToHash ViewContext.Content (contentTemplate.Render hash) hash
// ...then render that content with its layout
let! layoutTemplate = TemplateCache.get theme (if isHtmx ctx then "layout-partial" else "layout") ctx.Data
let! layoutTemplate = TemplateCache.get themeId (if isHtmx ctx then "layout-partial" else "layout") ctx.Data
return! htmlString (layoutTemplate.Render hash) next ctx
}
@@ -252,14 +252,13 @@ let messagesToHeaders (messages : UserMessage array) : HttpHandler =
/// 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
let (ThemeId theme) = themeId
if not (hash.ContainsKey ViewContext.Content) then
let! contentTemplate = TemplateCache.get theme template ctx.Data
let! contentTemplate = TemplateCache.get themeId template ctx.Data
addToHash ViewContext.Content (contentTemplate.Render hash) hash |> ignore
// Bare templates are rendered with layout-bare
let! layoutTemplate = TemplateCache.get theme "layout-bare" ctx.Data
let! layoutTemplate = TemplateCache.get themeId "layout-bare" ctx.Data
return!
(messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage[])
>=> htmlString (layoutTemplate.Render hash))
@@ -272,13 +271,16 @@ let themedView template next ctx hash = task {
return! viewForTheme (hash[ViewContext.WebLog] :?> WebLog).ThemeId template next ctx hash
}
/// The ID for the admin theme
let adminTheme = ThemeId "admin"
/// Display a view for the admin theme
let adminView template =
viewForTheme (ThemeId "admin") template
viewForTheme adminTheme template
/// Display a bare view for the admin theme
let adminBareView template =
bareForTheme (ThemeId "admin") template
bareForTheme adminTheme template
/// Redirect after doing some action; commits session and issues a temporary redirect
let redirectToGet url : HttpHandler = fun _ ctx -> task {

5
src/MyWebLog/Handlers/Routes.fs
View File

@@ -140,7 +140,10 @@ let router : HttpHandler = choose [
routef "/%s/edit" Admin.editMapping
])
])
route "/theme/update" >=> Admin.themeUpdatePage
subRoute "/theme" (choose [
route "s" >=> Admin.listThemes
route "/update" >=> Admin.themeUpdatePage
])
subRoute "/upload" (choose [
route "s" >=> Upload.list
route "/new" >=> Upload.showNew

2
src/MyWebLog/Handlers/User.fs
View File

@@ -90,7 +90,7 @@ let private goAway : HttpHandler = RequestErrors.BAD_REQUEST "really?"
// GET /admin/users
let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! hash = userListHash ctx
let! tmpl = TemplateCache.get "admin" "user-list-body" ctx.Data
let! tmpl = TemplateCache.get adminTheme "user-list-body" ctx.Data
return!
addToHash "user_list" (tmpl.Render hash) hash
|> adminView "user-list" next ctx