WIP on theme admin page (#20)

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<Theme list>
     
     /// Find a theme by its ID

src/MyWebLog.Data/RethinkDbData.fs

@@ -96,6 +96,10 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
         let keyPrefix = $"^{ThemeId.toString themeId}/"
         fun (row : Ast.ReqlExpr) -> 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<string list> { withTable table; indexList; result; withRetryOnce conn }
@@ -711,7 +715,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
                 member _.All () = rethink<Theme list> {
                     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<R
                 member _.FindByIdWithoutText themeId = rethink<Theme> {
                     withTable Table.Theme
                     get themeId
-                    merge (fun row ->
+                    merge withoutTemplateText
-                        {|  Templates = row[nameof Theme.empty.Templates].Without [| nameof ThemeTemplate.empty.Text |]
-                        |})
                     resultOption; withRetryOptionDefault conn
                 }
                 

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 =
+    let toThemeTemplate includeText rdr : ThemeTemplate =
-        {   Name = getString "name"     rdr
+        {   Name = getString "name" rdr
-            Text = getString "template" rdr
+            Text = if includeText then getString "template" rdr else ""
         }
     
     /// Create an uploaded file from the current row in the given data reader

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
     }

src/MyWebLog.Domain/ViewModels.fs

@@ -176,6 +176,40 @@ with
 
 open System.IO
 
+/// Information about a theme used for display
+[<NoComparison; NoEquality>]
+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
 [<NoComparison; NoEquality>]
 type DisplayUpload =

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 get (themeId : ThemeId) (templateName : string) (data : IData) = backgroundTask {
-        let templatePath = $"{themeId}/{templateName}"
+        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

src/MyWebLog/DotLiquidBespoke.fs

@@ -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<DashboardModel>;    typeof<DisplayCategory>;       typeof<DisplayCustomFeed>;    typeof<DisplayPage>
-      typeof<DisplayRevision>;       typeof<DisplayUpload>;        typeof<DisplayUser>;       typeof<EditCategoryModel>
+      typeof<DisplayRevision>;   typeof<DisplayTheme>;          typeof<DisplayUpload>;        typeof<DisplayUser>
-      typeof<EditCustomFeedModel>;   typeof<EditMyInfoModel>;      typeof<EditPageModel>;     typeof<EditPostModel>
+      typeof<EditCategoryModel>; typeof<EditCustomFeedModel>;   typeof<EditMyInfoModel>;      typeof<EditPageModel>
-      typeof<EditRssModel>;          typeof<EditTagMapModel>;      typeof<EditUserModel>;     typeof<LogOnModel>
+      typeof<EditPostModel>;     typeof<EditRssModel>;          typeof<EditTagMapModel>;      typeof<EditUserModel>
-      typeof<ManagePermalinksModel>; typeof<ManageRevisionsModel>; typeof<PostDisplay>;       typeof<PostListItem>
+      typeof<LogOnModel>;        typeof<ManagePermalinksModel>; typeof<ManageRevisionsModel>; typeof<PostDisplay>
-      typeof<SettingsModel>;         typeof<UserMessage>
+      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>

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"

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 {

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

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

src/admin-theme/_layout.liquid

@@ -7,23 +7,26 @@
         <span class="navbar-toggler-icon"></span>
       </button>
       <div class="collapse navbar-collapse" id="navbarText">
-        {% if is_logged_on -%}
+        {%- if is_logged_on %}
           <ul class="navbar-nav">
             {{ "admin/dashboard" | nav_link: "Dashboard" }}
-            {% if is_author %}
+            {%- if is_author %}
               {{ "admin/pages" | nav_link: "Pages" }}
               {{ "admin/posts" | nav_link: "Posts" }}
               {{ "admin/uploads" | nav_link: "Uploads" }}
-            {% endif %}
+            {%- endif %}
-            {% if is_web_log_admin %}
+            {%- if is_web_log_admin %}
               {{ "admin/categories" | nav_link: "Categories" }}
               {{ "admin/users" | nav_link: "Users" }}
               {{ "admin/settings" | nav_link: "Settings" }}
-            {% endif %}
+            {%- endif %}
+            {%- if is_administrator %}
+              {{ "admin/themes" | nav_link: "Themes" }}
+            {%- endif %}
           </ul>
         {%- endif %}
         <ul class="navbar-nav flex-grow-1 justify-content-end">
-          {% if is_logged_on -%}
+          {%- if is_logged_on %}
             {{ "admin/user/my-info" | nav_link: "My Info" }}
             <li class="nav-item">
               <a class="nav-link" href="{{ "user/log-off" | relative_link }}" hx-boost="false">Log Off</a>

src/admin-theme/_theme-list-columns.liquid

@@ -0,0 +1,3 @@
+{%- assign theme_col = "col-12 col-md-6" -%}
+{%- assign slug_col  = "d-none d-md-block col-md-3" -%}
+{%- assign tmpl_col  = "d-none d-md-block col-md-3" -%}

src/admin-theme/theme-list-body.liquid

@@ -0,0 +1,34 @@
+<form method="post" id="themeList" class="container" hx-target="this" hx-swap="outerHTML show:window:top">
+  <input type="hidden" name="{{ csrf.form_field_name }}" value="{{ csrf.request_token }}">
+  <div class="row mwl-table-detail" id="theme_new"></div>
+  {% include_template "_theme-list-columns" %}
+  {% for theme in themes -%}
+    <div class="row mwl-table-detail" id="theme_{{ theme.id }}">
+      <div class="{{ theme_col }} no-wrap">
+        {{ theme.name }}
+        {%- if theme.is_in_use %}
+          <span class="badge bg-primary ms-2">IN USE</span>
+        {%- endif %}
+        {%- unless theme.is_on_disk %}
+          <span class="badge bg-warning text-dark ms-2">NOT ON DISK</span>
+        {%- endunless %}<br>
+        <small>
+          <span class="text-muted">v{{ theme.version }}</span>
+          {% unless theme.is_in_use or theme.id == "default" %}
+            <span class="text-muted"> &bull; </span>
+            {%- assign theme_del_link = "admin/" | append: theme.id | append: "/delete" | relative_link -%}
+            <a href="{{ theme_del_link }}" hx-post="{{ theme_del_link }}" class="text-danger"
+               hx-confirm="Are you sure you want to delete the theme &ldquo;{{ theme.name }}&rdquo;? This action cannot be undone.">
+              Delete
+            </a>
+          {% endunless %}
+          <span class="d-md-none text-muted">
+            <br>Slug: {{ theme.id }} &bull; {{ theme.template_count }} Templates
+          </span>
+        </small>
+      </div>
+      <div class="{{ slug_col }}">{{ theme.id }}</div>
+      <div class="{{ tmpl_col }}">{{ theme.template_count }}</div>
+    </div>
+  {%- endfor %}
+</form>

src/admin-theme/theme-list.liquid

@@ -0,0 +1,16 @@
+<h2 class="my-3">{{ page_title }}</h2>
+<article>
+  <a href="{{ "admin/theme/upload" | relative_link }}" class="btn btn-primary btn-sm mb-3"
+     hx-target="#theme_new">
+    Upload a New Theme
+  </a>
+  <div class="container">
+    {% include_template "_theme-list-columns" %}
+    <div class="row mwl-table-heading">
+      <div class="{{ theme_col }}">Theme</div>
+      <div class="{{ slug_col }} d-none d-md-inline-block">Slug</div>
+      <div class="{{ tmpl_col }} d-none d-md-inline-block">Templates</div>
+    </div>
+  </div>
+  {{ theme_list }}
+</article>