Upload / delete themes (#20)

- Moved themes to section of installation admin page (will also implement #23 there)

src/MyWebLog.Data/Interfaces.fs

@@ -170,6 +170,12 @@ type IThemeData =
     /// Retrieve all themes (except "admin") (excluding the text of templates)
     abstract member All : unit -> Task<Theme list>
     
+    /// Delete a theme
+    abstract member Delete : ThemeId -> Task<bool>
+    
+    /// Determine if a theme exists
+    abstract member Exists : ThemeId -> Task<bool>
+    
     /// Find a theme by its ID
     abstract member FindById : ThemeId -> Task<Theme option>
     

src/MyWebLog.Data/RethinkDbData.fs

@@ -180,6 +180,14 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
     /// The batch size for restoration methods
     let restoreBatchSize = 100
     
+    /// Delete assets for the given theme ID
+    let deleteAssetsByTheme themeId = rethink {
+        withTable Table.ThemeAsset
+        filter (matchAssetByThemeId themeId)
+        delete
+        write; withRetryDefault; ignoreResult conn
+    }
+
     /// The connection for this instance
     member _.Conn = conn
     
@@ -720,6 +728,16 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
                     result; withRetryDefault conn
                 }
                 
+                member _.Exists themeId = backgroundTask {
+                    let! count = rethink<int> {
+                        withTable Table.Theme
+                        filter (nameof Theme.empty.Id) themeId
+                        count
+                        result; withRetryDefault conn
+                    }
+                    return count > 0
+                }
+                
                 member _.FindById themeId = rethink<Theme> {
                     withTable Table.Theme
                     get themeId
@@ -733,6 +751,20 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
                     resultOption; withRetryOptionDefault conn
                 }
                 
+                member this.Delete themeId = backgroundTask {
+                    match! this.FindByIdWithoutText themeId with
+                    | Some _ ->
+                        do! deleteAssetsByTheme themeId
+                        do! rethink {
+                            withTable Table.Theme
+                            get themeId
+                            delete
+                            write; withRetryDefault; ignoreResult conn
+                        }
+                        return true
+                    | None -> return false
+                }
+                
                 member _.Save theme = rethink {
                     withTable Table.Theme
                     get theme.Id
@@ -750,12 +782,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
                     result; withRetryDefault conn
                 }
                 
-                member _.DeleteByTheme themeId = rethink {
+                member _.DeleteByTheme themeId = deleteAssetsByTheme themeId
-                    withTable Table.ThemeAsset
-                    filter (matchAssetByThemeId themeId)
-                    delete
-                    write; withRetryDefault; ignoreResult conn
-                }
                 
                 member _.FindById assetId = rethink<ThemeAsset> {
                     withTable Table.ThemeAsset

src/MyWebLog.Data/SQLite/SQLiteThemeData.fs

@@ -26,6 +26,15 @@ type SQLiteThemeData (conn : SqliteConnection) =
                 { t with Templates = templates |> List.filter (fun tt -> fst tt = t.Id) |> List.map snd })
     }
     
+    /// Does a given theme exist?
+    let exists themeId = backgroundTask {
+        use cmd = conn.CreateCommand ()
+        cmd.CommandText <- "SELECT COUNT(id) FROM theme WHERE id = @id"
+        cmd.Parameters.AddWithValue ("@id", ThemeId.toString themeId) |> ignore
+        let! count = count cmd
+        return count > 0
+    }
+    
     /// Find a theme by its ID
     let findById themeId = backgroundTask {
         use cmd = conn.CreateCommand ()
@@ -53,6 +62,21 @@ type SQLiteThemeData (conn : SqliteConnection) =
         | None -> return None
     }
     
+    /// Delete a theme by its ID
+    let delete themeId = backgroundTask {
+        match! findByIdWithoutText themeId with
+        | Some _ ->
+            use cmd = conn.CreateCommand ()
+            cmd.CommandText <- """
+                DELETE FROM theme_asset    WHERE theme_id = @id;
+                DELETE FROM theme_template WHERE theme_id = @id;
+                DELETE FROM theme          WHERE id       = @id"""
+            cmd.Parameters.AddWithValue ("@id", ThemeId.toString themeId) |> ignore
+            do! write cmd
+            return true
+        | None -> return false
+    }
+    
     /// Save a theme
     let save (theme : Theme) = backgroundTask {
         use cmd = conn.CreateCommand ()
@@ -112,6 +136,8 @@ type SQLiteThemeData (conn : SqliteConnection) =
     
     interface IThemeData with
         member _.All () = all ()
+        member _.Delete themeId = delete themeId
+        member _.Exists themeId = exists themeId
         member _.FindById themeId = findById themeId
         member _.FindByIdWithoutText themeId = findByIdWithoutText themeId
         member _.Save theme = save theme

src/MyWebLog/Handlers/Admin.fs

@@ -6,7 +6,9 @@ open Giraffe
 open MyWebLog
 open MyWebLog.ViewModels
 
-// GET /admin
+// ~~ DASHBOARDS ~~
+
+// GET /admin/dashboard
 let dashboard : HttpHandler = requireAccess Author >=> fun next ctx -> task {
     let getCount (f : WebLogId -> Task<int>) = f ctx.WebLog.Id
     let data    = ctx.Data
@@ -30,7 +32,24 @@ let dashboard : HttpHandler = requireAccess Author >=> fun next ctx -> task {
         |> adminView "dashboard" next ctx
 }
 
-// -- CATEGORIES --
+// GET /admin/dashboard/administration
+let adminDashboard : 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 "myWebLog Administration"
+        |> withAntiCsrf ctx
+        |> addToHash "themes" (themes |> List.map (DisplayTheme.fromTheme WebLogCache.isThemeInUse) |> Array.ofList)
+        |> addViewContext ctx
+    return!
+        addToHash "theme_list" (bodyTemplate.Render hash) hash
+        |> adminView "admin-dashboard" next ctx
+}
+
+/// Redirect the user to the admin dashboard
+let toAdminDashboard : HttpHandler = redirectToGet "admin/dashboard/administration"
+
+// ~~ CATEGORIES ~~
 
 // GET /admin/categories
 let listCategories : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
@@ -106,7 +125,7 @@ let deleteCategory catId : HttpHandler = requireAccess WebLogAdmin >=> fun next
 
 open Microsoft.AspNetCore.Http
 
-// -- TAG MAPPINGS --
+// ~~ TAG MAPPINGS ~~
 
 /// Get the hash necessary to render the tag mapping list
 let private tagMappingHash (ctx : HttpContext) = task {
@@ -173,7 +192,7 @@ let deleteMapping tagMapId : HttpHandler = requireAccess WebLogAdmin >=> fun nex
     return! tagMappingsBare next ctx
 }
 
-// -- THEMES --
+// ~~ THEMES ~~
 
 open System
 open System.IO
@@ -181,24 +200,21 @@ open System.IO.Compression
 open System.Text.RegularExpressions
 open MyWebLog.Data
 
-// GET /admin/themes
+// GET /admin/theme/list
 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
+    return!
-    let hash =
+        hashForPage "Themes"
-        hashForPage "Theme Administration"
         |> withAntiCsrf ctx
         |> addToHash "themes" (themes |> List.map (DisplayTheme.fromTheme WebLogCache.isThemeInUse) |> Array.ofList)
-    return!
+        |> adminBareView "theme-list-body" next ctx
-        addToHash "theme_list" (bodyTemplate.Render hash) hash
-        |> adminView "theme-list" next ctx
 }
 
 // GET /admin/theme/new
 let addTheme : HttpHandler = requireAccess Administrator >=> fun next ctx ->
     hashForPage "Upload a Theme File"
     |> withAntiCsrf ctx
-    |> adminView "theme-upload" next ctx
+    |> adminBareView "theme-upload" next ctx
 
 /// Update the name and version for a theme based on the version.txt file, if present
 let private updateNameAndVersion (theme : Theme) (zip : ZipArchive) = backgroundTask {
@@ -279,8 +295,8 @@ let saveTheme : HttpHandler = requireAccess Administrator >=> fun next ctx -> ta
         match getThemeIdFromFileName themeFile.FileName with
         | Ok themeId when themeId <> adminTheme ->
             let  data   = ctx.Data
-            let! theme = data.Theme.FindByIdWithoutText themeId
+            let! exists = data.Theme.Exists themeId
-            let  isNew = Option.isNone theme
+            let  isNew  = not exists
             let! model  = ctx.BindFormAsync<UploadThemeModel> ()
             if isNew || model.DoOverwrite then 
                 // Load the theme to the database
@@ -290,26 +306,45 @@ let saveTheme : HttpHandler = requireAccess Administrator >=> fun next ctx -> ta
                 do! ThemeAssetCache.refreshTheme themeId data
                 TemplateCache.invalidateTheme themeId
                 // Save the .zip file
-                use file = new FileStream ($"{themeId}-theme.zip", FileMode.Create)
+                use file = new FileStream ($"{ThemeId.toString themeId}-theme.zip", FileMode.Create)
-                do! stream.CopyToAsync file
+                do! themeFile.CopyToAsync file
-                do! addMessage ctx { UserMessage.success with Message = "Theme updated successfully" }
+                do! addMessage ctx
-                return! redirectToGet "admin/dashboard" next ctx
+                        { UserMessage.success with
+                            Message = $"""Theme {if isNew then "add" else "updat"}ed successfully"""
+                        }
+                return! toAdminDashboard next ctx
             else
                 do! addMessage ctx
                         { UserMessage.error with
                             Message = "Theme exists and overwriting was not requested; nothing saved"
                         }
-                return! redirectToGet "admin/theme/new" next ctx
+                return! toAdminDashboard next ctx
         | Ok _ ->
             do! addMessage ctx { UserMessage.error with Message = "You may not replace the admin theme" }
-            return! redirectToGet "admin/theme/new" next ctx
+            return! toAdminDashboard next ctx
         | Error message ->
             do! addMessage ctx { UserMessage.error with Message = message }
-            return! redirectToGet "admin/theme/update" next ctx
+            return! toAdminDashboard next ctx
     else return! RequestErrors.BAD_REQUEST "Bad request" next ctx
 }
 
-// -- WEB LOG SETTINGS --
+// POST /admin/theme/{id}/delete
+let deleteTheme themeId : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
+    let data = ctx.Data
+    if themeId = "admin" || themeId = "default" then
+        do! addMessage ctx { UserMessage.error with Message = $"You may not delete the {themeId} theme" }
+        return! listThemes next ctx
+    else
+        match! data.Theme.Delete (ThemeId themeId) with
+        | true ->
+            let zippedTheme = $"{themeId}-theme.zip"
+            if File.Exists zippedTheme then File.Delete zippedTheme
+            do! addMessage ctx { UserMessage.success with Message = $"Theme ID {themeId} deleted successfully" }
+            return! listThemes next ctx
+        | false -> return! Error.notFound next ctx
+}
+
+// ~~ WEB LOG SETTINGS ~~
 
 open System.Collections.Generic
 

src/MyWebLog/Handlers/Routes.fs

@@ -112,6 +112,7 @@ let router : HttpHandler = choose [
                 routef "y/%s/edit"     Admin.editCategory
             ])
             route    "/dashboard"                >=> Admin.dashboard
+            route    "/dashboard/administration" >=> Admin.adminDashboard
             subRoute "/page" (choose [
                 route  "s"                       >=> Page.all 1
                 routef "s/page/%i"                   Page.all
@@ -141,7 +142,7 @@ let router : HttpHandler = choose [
                 ])
             ])
             subRoute "/theme" (choose [
-                route "s"    >=> Admin.listThemes
+                route "/list" >=> Admin.listThemes
                 route "/new"  >=> Admin.addTheme
             ])
             subRoute "/upload" (choose [
@@ -188,7 +189,10 @@ let router : HttpHandler = choose [
                     routef "/%s/delete"     Admin.deleteMapping
                 ])
             ])
-            route    "/theme/new" >=> Admin.saveTheme
+            subRoute "/theme" (choose [
+                route  "/new"       >=> Admin.saveTheme
+                routef "/%s/delete"     Admin.deleteTheme
+            ])
             subRoute "/upload" (choose [
                 route   "/save"        >=> Upload.save
                 routexp "/delete/(.*)"     Upload.deleteFromDisk

src/admin-theme/_layout.liquid

@@ -21,7 +21,7 @@
               {{ "admin/settings" | nav_link: "Settings" }}
             {%- endif %}
             {%- if is_administrator %}
-              {{ "admin/themes" | nav_link: "Themes" }}
+              {{ "admin/dashboard/administration" | nav_link: "Admin" }}
             {%- endif %}
           </ul>
         {%- endif %}

src/admin-theme/admin-dashboard.liquid

@@ -0,0 +1,32 @@
+<h2 class="my-3">{{ page_title }}</h2>
+<article>
+  <fieldset class="container pb-3">
+    <legend>Themes</legend>
+    <div class="row">
+      <div class="col">
+        <a href="{{ "admin/theme/new" | 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>
+        <div class="row mwl-table-detail" id="theme_new"></div>
+        {{ theme_list }}
+      </div>
+    </div>
+  </fieldset>
+  <fieldset class="container">
+    <legend>Caches</legend>
+    <div class="row">
+      <div class="col">
+        TODO
+      </div>
+    </div>
+  </fieldset>
+</article>

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

@@ -1,6 +1,5 @@
 <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 }}">
@@ -16,7 +15,7 @@
           <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 -%}
+            {%- assign theme_del_link = "admin/theme/" | 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

src/admin-theme/theme-list.liquid

@@ -1,16 +0,0 @@
-<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>

src/admin-theme/theme-upload.liquid

@@ -1,26 +1,30 @@
-<h2>{{ page_title }}</h2>
+<div class="col">
-<article>
+  <h5>{{ page_title }}</h5>
-  <form action="{{ "admin/theme/new" | relative_link }}"
+  <form action="{{ "admin/theme/new" | relative_link }}" method="post" class="container" enctype="multipart/form-data"
-        method="post" class="container" enctype="multipart/form-data" hx-boost="false">
+        hx-boost="false">
     <input type="hidden" name="{{ csrf.form_field_name }}" value="{{ csrf.request_token }}">
     <div class="row">
-      <div class="col-12 col-sm-6 offset-sm-3 pb-3">
+      <div class="col-12 col-sm-6 pb-3">
         <div class="form-floating">
           <input type="file" id="file" name="file" class="form-control" accept=".zip" placeholder="Theme File" required>
           <label for="file">Theme File</label>
         </div>
       </div>
-      <div class="col-12 col-sm-6 pb-3">
+      <div class="col-12 col-sm-6 pb-3 d-flex justify-content-center align-items-center">
         <div class="form-check form-switch pb-2">
           <input type="checkbox" name="DoOverwrite" id="doOverwrite" class="form-check-input" value="true">
-          <label for="doOverwrite" class="form-check-label">Overwrite an Existing Theme If Required</label>
+          <label for="doOverwrite" class="form-check-label">Overwrite</label>
         </div>
       </div>
     </div>
     <div class="row pb-3">
       <div class="col text-center">
-        <button type="submit" class="btn btn-primary">Upload Theme</button>
+        <button type="submit" class="btn btn-sm btn-primary">Upload Theme</button>
+        <button type="button" class="btn btn-sm btn-secondary ms-3"
+                onclick="document.getElementById('theme_new').innerHTML = ''">
+          Cancel
+        </button>
       </div>
     </div>
   </form>
-</article>
+</div>