diff --git a/src/MyWebLog.Data/Interfaces.fs b/src/MyWebLog.Data/Interfaces.fs index 60e861a..91d58f3 100644 --- a/src/MyWebLog.Data/Interfaces.fs +++ b/src/MyWebLog.Data/Interfaces.fs @@ -167,7 +167,7 @@ type ITagMapData = /// Functions to manipulate themes type IThemeData = - /// Retrieve all themes (except "admin") + /// Retrieve all themes (except "admin") (excluding the text of templates) abstract member All : unit -> Task /// Find a theme by its ID diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index a239d7b..0e529f6 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -96,6 +96,10 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger row[nameof ThemeAsset.empty.Id].Match keyPrefix :> obj + /// Function to exclude template text from themes + let withoutTemplateText (row : Ast.ReqlExpr) : obj = + {| Templates = row[nameof Theme.empty.Templates].Without [| nameof ThemeTemplate.empty.Text |] |} + /// Ensure field indexes exist, as well as special indexes for selected tables let ensureIndexes table fields = backgroundTask { let! indexes = rethink { withTable table; indexList; result; withRetryOnce conn } @@ -711,7 +715,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.Theme filter (fun row -> row[nameof Theme.empty.Id].Ne "admin" :> obj) - without [ nameof Theme.empty.Templates ] + merge withoutTemplateText orderBy (nameof Theme.empty.Id) result; withRetryDefault conn } @@ -725,9 +729,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { withTable Table.Theme get themeId - merge (fun row -> - {| Templates = row[nameof Theme.empty.Templates].Without [| nameof ThemeTemplate.empty.Text |] - |}) + merge withoutTemplateText resultOption; withRetryOptionDefault conn } diff --git a/src/MyWebLog.Data/SQLite/Helpers.fs b/src/MyWebLog.Data/SQLite/Helpers.fs index 05c25b2..88955d6 100644 --- a/src/MyWebLog.Data/SQLite/Helpers.fs +++ b/src/MyWebLog.Data/SQLite/Helpers.fs @@ -242,9 +242,9 @@ module Map = } /// Create a theme template from the current row in the given data reader - let toThemeTemplate rdr : ThemeTemplate = - { Name = getString "name" rdr - Text = getString "template" rdr + let toThemeTemplate includeText rdr : ThemeTemplate = + { Name = getString "name" rdr + Text = if includeText then getString "template" rdr else "" } /// Create an uploaded file from the current row in the given data reader diff --git a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs index f7d6a56..0674aa4 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteThemeData.fs @@ -8,12 +8,22 @@ open MyWebLog.Data /// SQLite myWebLog theme data implementation type SQLiteThemeData (conn : SqliteConnection) = - /// Retrieve all themes (except 'admin'; excludes templates) + /// Retrieve all themes (except 'admin'; excludes template text) let all () = backgroundTask { use cmd = conn.CreateCommand () cmd.CommandText <- "SELECT * FROM theme WHERE id <> 'admin' ORDER BY id" use! rdr = cmd.ExecuteReaderAsync () - return toList Map.toTheme rdr + let themes = toList Map.toTheme rdr + do! rdr.CloseAsync () + cmd.CommandText <- "SELECT name, theme_id FROM theme_template WHERE theme_id <> 'admin' ORDER BY name" + use! rdr = cmd.ExecuteReaderAsync () + let mutable templates = [] + while rdr.Read () do + templates <- (ThemeId (Map.getString "theme_id" rdr), Map.toThemeTemplate false rdr) :: templates + return + themes + |> List.map (fun t -> + { t with Templates = templates |> List.filter (fun tt -> fst tt = t.Id) |> List.map snd }) } /// Find a theme by its ID @@ -28,7 +38,7 @@ type SQLiteThemeData (conn : SqliteConnection) = templateCmd.CommandText <- "SELECT * FROM theme_template WHERE theme_id = @id" templateCmd.Parameters.Add cmd.Parameters["@id"] |> ignore use! templateRdr = templateCmd.ExecuteReaderAsync () - return Some { theme with Templates = toList Map.toThemeTemplate templateRdr } + return Some { theme with Templates = toList (Map.toThemeTemplate true) templateRdr } else return None } diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index c6cb8cb..f7c61eb 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -176,6 +176,40 @@ with open System.IO +/// Information about a theme used for display +[] +type DisplayTheme = + { /// The ID / path slug of the theme + Id : string + + /// The name of the theme + Name : string + + /// The version of the theme + Version : string + + /// How many templates are contained in the theme + TemplateCount : int + + /// Whether the theme is in use by any web logs + IsInUse : bool + + /// Whether the theme .zip file exists on the filesystem + IsOnDisk : bool + } +with + + /// Create a display theme from a theme + static member fromTheme inUseFunc (theme : Theme) = + { Id = ThemeId.toString theme.Id + Name = theme.Name + Version = theme.Version + TemplateCount = List.length theme.Templates + IsInUse = inUseFunc theme.Id + IsOnDisk = File.Exists $"{ThemeId.toString theme.Id}-theme.zip" + } + + /// Information about an uploaded file used for display [] type DisplayUpload = diff --git a/src/MyWebLog/Caches.fs b/src/MyWebLog/Caches.fs index e48706d..ce7b49a 100644 --- a/src/MyWebLog/Caches.fs +++ b/src/MyWebLog/Caches.fs @@ -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 diff --git a/src/MyWebLog/DotLiquidBespoke.fs b/src/MyWebLog/DotLiquidBespoke.fs index d693b04..6fba67f 100644 --- a/src/MyWebLog/DotLiquidBespoke.fs +++ b/src/MyWebLog/DotLiquidBespoke.fs @@ -227,12 +227,12 @@ let register () = typeof; typeof; typeof; typeof; typeof typeof; typeof; typeof; typeof // View models - typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof - typeof; typeof + typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof + typeof; typeof; typeof // Framework types typeof; typeof; typeof; typeof typeof; typeof; typeof; typeof diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index b27d551..b63384e 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -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" diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index 0e2a32e..05ee4d1 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -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 { diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index f8a307b..0dbe5f9 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -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 diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index 9b193b5..ffa8b13 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -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 diff --git a/src/admin-theme/_layout.liquid b/src/admin-theme/_layout.liquid index cc6f527..82cf089 100644 --- a/src/admin-theme/_layout.liquid +++ b/src/admin-theme/_layout.liquid @@ -7,23 +7,26 @@