diff --git a/src/MyWebLog.Data/Interfaces.fs b/src/MyWebLog.Data/Interfaces.fs index 9cd8bfa..60e861a 100644 --- a/src/MyWebLog.Data/Interfaces.fs +++ b/src/MyWebLog.Data/Interfaces.fs @@ -255,6 +255,9 @@ type IWebLogUserData = /// Add a web log user abstract member Add : WebLogUser -> Task + /// Delete a web log user + abstract member Delete : WebLogUserId -> WebLogId -> Task> + /// Find a web log user by their e-mail address abstract member FindByEmail : email : string -> WebLogId -> Task diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs index 01c7dc2..a239d7b 100644 --- a/src/MyWebLog.Data/RethinkDbData.fs +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -955,6 +955,44 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger { + withTable Table.WebLogUser + get userId + resultOption; withRetryOptionDefault + } + |> verifyWebLog webLogId (fun u -> u.WebLogId) <| conn + + member this.Delete userId webLogId = backgroundTask { + match! this.FindById userId webLogId with + | Some _ -> + let! pageCount = rethink { + withTable Table.Page + getAll [ webLogId ] (nameof Page.empty.WebLogId) + filter (nameof Page.empty.AuthorId) userId + count + result; withRetryDefault conn + } + let! postCount = rethink { + withTable Table.Post + getAll [ webLogId ] (nameof Post.empty.WebLogId) + filter (nameof Post.empty.AuthorId) userId + count + result; withRetryDefault conn + } + if pageCount + postCount > 0 then + return Result.Error "User has pages or posts; cannot delete" + else + do! rethink { + withTable Table.WebLogUser + get userId + delete + write; withRetryDefault; ignoreResult conn + } + return Ok true + | None -> return Result.Error "User does not exist" + } + member _.FindByEmail email webLogId = rethink { withTable Table.WebLogUser @@ -964,17 +1002,10 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger tryFirst <| conn - member _.FindById userId webLogId = - rethink { - withTable Table.WebLogUser - get userId - resultOption; withRetryOptionDefault - } - |> verifyWebLog webLogId (fun u -> u.WebLogId) <| conn - member _.FindByWebLog webLogId = rethink { withTable Table.WebLogUser getAll [ webLogId ] (nameof WebLogUser.empty.WebLogId) + orderByFunc (fun row -> row[nameof WebLogUser.empty.PreferredName].Downcase ()) result; withRetryDefault conn } diff --git a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs index 57c4c68..334dc6a 100644 --- a/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs +++ b/src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs @@ -43,6 +43,34 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = do! write cmd } + /// Find a user by their ID for the given web log + let findById userId webLogId = backgroundTask { + use cmd = conn.CreateCommand () + cmd.CommandText <- "SELECT * FROM web_log_user WHERE id = @id" + cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString userId) |> ignore + use! rdr = cmd.ExecuteReaderAsync () + return Helpers.verifyWebLog webLogId (fun u -> u.WebLogId) Map.toWebLogUser rdr + } + + /// Delete a user if they have no posts or pages + let delete userId webLogId = backgroundTask { + match! findById userId webLogId with + | Some _ -> + use cmd = conn.CreateCommand () + cmd.CommandText <- "SELECT COUNT(id) FROM page WHERE author_id = @userId" + cmd.Parameters.AddWithValue ("@userId", WebLogUserId.toString userId) |> ignore + let! pageCount = count cmd + cmd.CommandText <- "SELECT COUNT(id) FROM post WHERE author_id = @userId" + let! postCount = count cmd + if pageCount + postCount > 0 then + return Error "User has pages or posts; cannot delete" + else + cmd.CommandText <- "DELETE FROM web_log_user WHERE id = @userId" + let! _ = cmd.ExecuteNonQueryAsync () + return Ok true + | None -> return Error "User does not exist" + } + /// Find a user by their e-mail address for the given web log let findByEmail (email : string) webLogId = backgroundTask { use cmd = conn.CreateCommand () @@ -53,19 +81,10 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = return if rdr.Read () then Some (Map.toWebLogUser rdr) else None } - /// Find a user by their ID for the given web log - let findById userId webLogId = backgroundTask { - use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT * FROM web_log_user WHERE id = @id" - cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString userId) |> ignore - use! rdr = cmd.ExecuteReaderAsync () - return Helpers.verifyWebLog webLogId (fun u -> u.WebLogId) Map.toWebLogUser rdr - } - /// Get all users for the given web log let findByWebLog webLogId = backgroundTask { use cmd = conn.CreateCommand () - cmd.CommandText <- "SELECT * FROM web_log_user WHERE web_log_id = @webLogId" + cmd.CommandText <- "SELECT * FROM web_log_user WHERE web_log_id = @webLogId ORDER BY LOWER(preferred_name)" addWebLogId cmd webLogId use! rdr = cmd.ExecuteReaderAsync () return toList Map.toWebLogUser rdr @@ -133,6 +152,7 @@ type SQLiteWebLogUserData (conn : SqliteConnection) = interface IWebLogUserData with member _.Add user = add user + member _.Delete userId webLogId = delete userId webLogId member _.FindByEmail email webLogId = findByEmail email webLogId member _.FindById userId webLogId = findById userId webLogId member _.FindByWebLog webLogId = findByWebLog webLogId diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index dfcb555..e5167ce 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -18,17 +18,16 @@ let dashboard : HttpHandler = requireAccess Author >=> fun next ctx -> task { let topCats = getCount data.Category.CountTopLevel let! _ = Task.WhenAll (posts, drafts, pages, listed, cats, topCats) return! - {| page_title = "Dashboard" - model = - { Posts = posts.Result - Drafts = drafts.Result - Pages = pages.Result - ListedPages = listed.Result - Categories = cats.Result - TopLevelCategories = topCats.Result - } - |} - |> makeHash |> adminView "dashboard" next ctx + hashForPage "Dashboard" + |> addToHash ViewContext.Model { + Posts = posts.Result + Drafts = drafts.Result + Pages = pages.Result + ListedPages = listed.Result + Categories = cats.Result + TopLevelCategories = topCats.Result + } + |> adminView "dashboard" next ctx } // -- CATEGORIES -- @@ -36,12 +35,10 @@ 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 hash = makeHash {| - page_title = "Categories" - csrf = ctx.CsrfTokenSet - web_log = ctx.WebLog - categories = CategoryCache.get ctx - |} + let! hash = + hashForPage "Categories" + |> withAntiCsrf ctx + |> addViewContext ctx return! addToHash "category_list" (catListTemplate.Render hash) hash |> adminView "category-list" next ctx @@ -49,10 +46,9 @@ let listCategories : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> // GET /admin/categories/bare let listCategoriesBare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> - {| categories = CategoryCache.get ctx - csrf = ctx.CsrfTokenSet - |} - |> makeHash |> adminBareView "category-list-body" next ctx + hashForPage "Categories" + |> withAntiCsrf ctx + |> adminBareView "category-list-body" next ctx // GET /admin/category/{id}/edit @@ -67,13 +63,11 @@ let editCategory catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ct } match result with | Some (title, cat) -> - return! {| - page_title = title - csrf = ctx.CsrfTokenSet - model = EditCategoryModel.fromCategory cat - categories = CategoryCache.get ctx - |} - |> makeHash |> adminBareView "category-edit" next ctx + return! + hashForPage title + |> withAntiCsrf ctx + |> addToHash ViewContext.Model (EditCategoryModel.fromCategory cat) + |> adminBareView "category-edit" next ctx | None -> return! Error.notFound next ctx } @@ -117,12 +111,12 @@ open Microsoft.AspNetCore.Http /// Get the hash necessary to render the tag mapping list let private tagMappingHash (ctx : HttpContext) = task { let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id - return makeHash {| - csrf = ctx.CsrfTokenSet - web_log = ctx.WebLog - mappings = mappings - mapping_ids = mappings |> List.map (fun it -> { Name = it.Tag; Value = TagMapId.toString it.Id }) - |} + return! + hashForPage "Tag Mappings" + |> withAntiCsrf ctx + |> addToHash "mappings" mappings + |> addToHash "mapping_ids" (mappings |> List.map (fun it -> { Name = it.Tag; Value = TagMapId.toString it.Id })) + |> addViewContext ctx } // GET /admin/settings/tag-mappings @@ -131,7 +125,6 @@ let tagMappings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> ta let! listTemplate = TemplateCache.get "admin" "tag-mapping-list-body" ctx.Data return! addToHash "tag_mapping_list" (listTemplate.Render hash) hash - |> addToHash "page_title" "Tag Mappings" |> adminView "tag-mapping-list" next ctx } @@ -149,12 +142,11 @@ let editMapping tagMapId : HttpHandler = requireAccess WebLogAdmin >=> fun next else ctx.Data.TagMap.FindById (TagMapId tagMapId) ctx.WebLog.Id match! tagMap with | Some tm -> - return! {| - page_title = if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag" - csrf = ctx.CsrfTokenSet - model = EditTagMapModel.fromMapping tm - |} - |> makeHash |> adminBareView "tag-mapping-edit" next ctx + return! + hashForPage (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag") + |> withAntiCsrf ctx + |> addToHash ViewContext.Model (EditTagMapModel.fromMapping tm) + |> adminBareView "tag-mapping-edit" next ctx | None -> return! Error.notFound next ctx } @@ -191,10 +183,9 @@ open MyWebLog.Data // GET /admin/theme/update let themeUpdatePage : HttpHandler = requireAccess Administrator >=> fun next ctx -> - {| page_title = "Upload Theme" - csrf = ctx.CsrfTokenSet - |} - |> makeHash |> adminView "upload-theme" next ctx + hashForPage "Upload Theme" + |> withAntiCsrf ctx + |> adminView "upload-theme" 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 { @@ -244,9 +235,9 @@ let private updateAssets themeId (zip : ZipArchive) (data : IData) = backgroundT use stream = new MemoryStream () do! asset.Open().CopyToAsync stream do! data.ThemeAsset.Save - { Id = ThemeAssetId (themeId, assetName) - UpdatedOn = asset.LastWriteTime.DateTime - Data = stream.ToArray () + { Id = ThemeAssetId (themeId, assetName) + UpdatedOn = asset.LastWriteTime.DateTime + Data = stream.ToArray () } } @@ -303,28 +294,28 @@ let settings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task let data = ctx.Data let! allPages = data.Page.All ctx.WebLog.Id let! themes = data.Theme.All () - return! {| - page_title = "Web Log Settings" - csrf = ctx.CsrfTokenSet - model = SettingsModel.fromWebLog ctx.WebLog - pages = seq - { KeyValuePair.Create ("posts", "- First Page of Posts -") + return! + hashForPage "Web Log Settings" + |> withAntiCsrf ctx + |> addToHash ViewContext.Model (SettingsModel.fromWebLog ctx.WebLog) + |> addToHash "pages" ( + seq { + KeyValuePair.Create ("posts", "- First Page of Posts -") yield! allPages |> List.sortBy (fun p -> p.Title.ToLower ()) |> List.map (fun p -> KeyValuePair.Create (PageId.toString p.Id, p.Title)) } - |> Array.ofSeq - themes = + |> Array.ofSeq) + |> addToHash "themes" ( themes - |> Seq.ofList - |> Seq.map (fun it -> KeyValuePair.Create (ThemeId.toString it.Id, $"{it.Name} (v{it.Version})")) - |> Array.ofSeq - upload_values = [| + |> Seq.ofList + |> Seq.map (fun it -> KeyValuePair.Create (ThemeId.toString it.Id, $"{it.Name} (v{it.Version})")) + |> Array.ofSeq) + |> addToHash "upload_values" [| KeyValuePair.Create (UploadDestination.toString Database, "Database") KeyValuePair.Create (UploadDestination.toString Disk, "Disk") |] - |} - |> makeHash |> adminView "settings" next ctx + |> adminView "settings" next ctx } // POST /admin/settings diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs index e6bdecf..ef40a44 100644 --- a/src/MyWebLog/Handlers/Feed.fs +++ b/src/MyWebLog/Handlers/Feed.fs @@ -416,16 +416,14 @@ let generate (feedType : FeedType) postCount : HttpHandler = fun next ctx -> bac // GET /admin/settings/rss let editSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> - let feeds = + hashForPage "RSS Settings" + |> withAntiCsrf ctx + |> addToHash ViewContext.Model (EditRssModel.fromRssOptions ctx.WebLog.Rss) + |> addToHash "custom_feeds" ( ctx.WebLog.Rss.CustomFeeds |> List.map (DisplayCustomFeed.fromFeed (CategoryCache.get ctx)) - |> Array.ofList - {| page_title = "RSS Settings" - csrf = ctx.CsrfTokenSet - model = EditRssModel.fromRssOptions ctx.WebLog.Rss - custom_feeds = feeds - |} - |> makeHash |> adminView "rss-settings" next ctx + |> Array.ofList) + |> adminView "rss-settings" next ctx // POST /admin/settings/rss let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { @@ -449,22 +447,20 @@ let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next | _ -> ctx.WebLog.Rss.CustomFeeds |> List.tryFind (fun f -> f.Id = CustomFeedId feedId) match customFeed with | Some f -> - {| page_title = $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed""" - csrf = ctx.CsrfTokenSet - model = EditCustomFeedModel.fromFeed f - categories = CategoryCache.get ctx - medium_values = [| - KeyValuePair.Create ("", "– Unspecified –") - KeyValuePair.Create (PodcastMedium.toString Podcast, "Podcast") - KeyValuePair.Create (PodcastMedium.toString Music, "Music") - KeyValuePair.Create (PodcastMedium.toString Video, "Video") - KeyValuePair.Create (PodcastMedium.toString Film, "Film") - KeyValuePair.Create (PodcastMedium.toString Audiobook, "Audiobook") - KeyValuePair.Create (PodcastMedium.toString Newsletter, "Newsletter") - KeyValuePair.Create (PodcastMedium.toString Blog, "Blog") - |] - |} - |> makeHash |> adminView "custom-feed-edit" next ctx + hashForPage $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed""" + |> withAntiCsrf ctx + |> addToHash ViewContext.Model (EditCustomFeedModel.fromFeed f) + |> addToHash "medium_values" [| + KeyValuePair.Create ("", "– Unspecified –") + KeyValuePair.Create (PodcastMedium.toString Podcast, "Podcast") + KeyValuePair.Create (PodcastMedium.toString Music, "Music") + KeyValuePair.Create (PodcastMedium.toString Video, "Video") + KeyValuePair.Create (PodcastMedium.toString Film, "Film") + KeyValuePair.Create (PodcastMedium.toString Audiobook, "Audiobook") + KeyValuePair.Create (PodcastMedium.toString Newsletter, "Newsletter") + KeyValuePair.Create (PodcastMedium.toString Blog, "Blog") + |] + |> adminView "custom-feed-edit" 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 8a7cfbf..0e2a32e 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -12,12 +12,117 @@ type ISession with this.SetString (key, JsonSerializer.Serialize item) /// Get an item from the session - member this.Get<'T> key = + member this.TryGet<'T> key = match this.GetString key with | null -> None | 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 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" + + + /// The HTTP item key for loading the session let private sessionLoadedKey = "session-loaded" @@ -38,34 +143,41 @@ 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.Get "messages" with Some it -> it | None -> [] - ctx.Session.Set ("messages", message :: msg) + let msg = match ctx.Session.TryGet ViewContext.Messages with Some it -> it | None -> [] + ctx.Session.Set (ViewContext.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.Get "messages" with + match ctx.Session.TryGet ViewContext.Messages with | Some msg -> - ctx.Session.Remove "messages" + ctx.Session.Remove ViewContext.Messages return msg |> (List.rev >> Array.ofList) | None -> return [||] } -open System.Collections.Generic 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 +/// Add anti-CSRF tokens to the given hash +let withAntiCsrf (ctx : HttpContext) = + addToHash ViewContext.AntiCsrfTokens ctx.CsrfTokenSet + open System.Security.Claims open Giraffe open Giraffe.Htmx @@ -75,27 +187,31 @@ open Giraffe.ViewEngine let private htmxScript = RenderView.AsString.htmlNode Htmx.Script.minified /// Populate the DotLiquid hash with standard information -let private populateHash hash ctx = task { +let addViewContext ctx (hash : Hash) = task { let! messages = messages ctx do! commitSession ctx - - ctx.User.Claims - |> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.NameIdentifier) - |> Option.map (fun claim -> claim.Value) - |> Option.iter (fun userId -> addToHash "user_id" userId hash |> ignore) - return - addToHash "web_log" ctx.WebLog hash - |> addToHash "page_list" (PageListCache.get ctx) - |> addToHash "current_page" ctx.Request.Path.Value[1..] - |> addToHash "messages" messages - |> addToHash "generator" ctx.Generator - |> addToHash "htmx_script" htmxScript - |> addToHash "is_logged_on" ctx.User.Identity.IsAuthenticated - |> addToHash "is_author" (ctx.HasAccessLevel Author) - |> addToHash "is_editor" (ctx.HasAccessLevel Editor) - |> addToHash "is_web_log_admin" (ctx.HasAccessLevel WebLogAdmin) - |> addToHash "is_administrator" (ctx.HasAccessLevel Administrator) + if hash.ContainsKey ViewContext.HtmxScript && hash.ContainsKey ViewContext.Messages then + // We have already populated everything; just update messages + hash[ViewContext.Messages] <- Array.concat [ hash[ViewContext.Messages] :?> UserMessage[]; messages ] + hash + else + ctx.User.Claims + |> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.NameIdentifier) + |> Option.map (fun claim -> addToHash ViewContext.UserId claim.Value hash) + |> Option.defaultValue hash + |> addToHash ViewContext.WebLog ctx.WebLog + |> addToHash ViewContext.PageList (PageListCache.get ctx) + |> addToHash ViewContext.Categories (CategoryCache.get ctx) + |> addToHash ViewContext.CurrentPage ctx.Request.Path.Value[1..] + |> addToHash ViewContext.Messages messages + |> addToHash ViewContext.Generator ctx.Generator + |> addToHash ViewContext.HtmxScript htmxScript + |> addToHash ViewContext.IsLoggedOn ctx.User.Identity.IsAuthenticated + |> addToHash ViewContext.IsAuthor (ctx.HasAccessLevel Author) + |> addToHash ViewContext.IsEditor (ctx.HasAccessLevel Editor) + |> addToHash ViewContext.IsWebLogAdmin (ctx.HasAccessLevel WebLogAdmin) + |> addToHash ViewContext.IsAdministrator (ctx.HasAccessLevel Administrator) } /// Is the request from htmx? @@ -104,16 +220,14 @@ 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 { - if not (hash.ContainsKey "htmx_script") then - let! _ = populateHash hash ctx - () + 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 _ = addToHash "content" (contentTemplate.Render hash) hash + 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 @@ -137,24 +251,25 @@ 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 = populateHash hash ctx + let! hash = addViewContext ctx hash let (ThemeId theme) = themeId - if not (hash.ContainsKey "content") then + if not (hash.ContainsKey ViewContext.Content) then let! contentTemplate = TemplateCache.get theme template ctx.Data - addToHash "content" (contentTemplate.Render hash) hash |> ignore + addToHash ViewContext.Content (contentTemplate.Render hash) hash |> ignore // Bare templates are rendered with layout-bare let! layoutTemplate = TemplateCache.get theme "layout-bare" ctx.Data - return! - (messagesToHeaders (hash["messages"] :?> UserMessage[]) >=> htmlString (layoutTemplate.Render hash)) next ctx + (messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage[]) + >=> htmlString (layoutTemplate.Render hash)) + next ctx } /// Return a view for the web log's default theme let themedView template next ctx hash = task { - let! hash = populateHash hash ctx - return! viewForTheme (hash["web_log"] :?> WebLog).ThemeId template next ctx hash + let! hash = addViewContext ctx hash + return! viewForTheme (hash[ViewContext.WebLog] :?> WebLog).ThemeId template next ctx hash } /// Display a view for the admin theme @@ -171,7 +286,7 @@ let redirectToGet url : HttpHandler = fun _ ctx -> task { return! redirectTo false (WebLog.relativeUrl ctx.WebLog (Permalink url)) earlyReturn ctx } -/// Validate the cross-site request forgery token in the current request +/// Validate the anti cross-site request forgery token in the current request let validateCsrf : HttpHandler = fun next ctx -> task { match! ctx.AntiForgery.IsRequestValidAsync ctx with | true -> return! next ctx diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs index 4f97852..99778fe 100644 --- a/src/MyWebLog/Handlers/Page.fs +++ b/src/MyWebLog/Handlers/Page.fs @@ -9,15 +9,14 @@ open MyWebLog.ViewModels // GET /admin/pages/page/{pageNbr} let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task { let! pages = ctx.Data.Page.FindPageOfPages ctx.WebLog.Id pageNbr - return! {| - page_title = "Pages" - csrf = ctx.CsrfTokenSet - pages = pages |> List.map (DisplayPage.fromPageMinimal ctx.WebLog) - page_nbr = pageNbr - prev_page = if pageNbr = 2 then "" else $"/page/{pageNbr - 1}" - next_page = $"/page/{pageNbr + 1}" - |} - |> makeHash |> adminView "page-list" next ctx + return! + hashForPage "Pages" + |> withAntiCsrf ctx + |> addToHash "pages" (pages |> List.map (DisplayPage.fromPageMinimal ctx.WebLog)) + |> addToHash "page_nbr" pageNbr + |> addToHash "prev_page" (if pageNbr = 2 then "" else $"/page/{pageNbr - 1}") + |> addToHash "next_page" $"/page/{pageNbr + 1}" + |> adminView "page-list" next ctx } // GET /admin/page/{id}/edit @@ -34,15 +33,15 @@ 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! {| - page_title = title - csrf = ctx.CsrfTokenSet - model = model - metadata = Array.zip model.MetaNames model.MetaValues - |> Array.mapi (fun idx (name, value) -> [| string idx; name; value |]) - templates = templates - |} - |> makeHash |> adminView "page-edit" next ctx + return! + hashForPage title + |> withAntiCsrf ctx + |> addToHash ViewContext.Model model + |> addToHash "metadata" ( + Array.zip model.MetaNames model.MetaValues + |> Array.mapi (fun idx (name, value) -> [| string idx; name; value |])) + |> addToHash "templates" templates + |> adminView "page-edit" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } @@ -61,12 +60,11 @@ let delete pgId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> ta let editPermalinks pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task { match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with | Some pg when canEdit pg.AuthorId ctx -> - return! {| - page_title = "Manage Prior Permalinks" - csrf = ctx.CsrfTokenSet - model = ManagePermalinksModel.fromPage pg - |} - |> makeHash |> adminView "permalinks" next ctx + return! + hashForPage "Manage Prior Permalinks" + |> withAntiCsrf ctx + |> addToHash ViewContext.Model (ManagePermalinksModel.fromPage pg) + |> adminView "permalinks" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } @@ -91,12 +89,11 @@ let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task let editRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task { match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with | Some pg when canEdit pg.AuthorId ctx -> - return! {| - page_title = "Manage Page Revisions" - csrf = ctx.CsrfTokenSet - model = ManageRevisionsModel.fromPage ctx.WebLog pg - |} - |> makeHash |> adminView "revisions" next ctx + return! + hashForPage "Manage Page Revisions" + |> withAntiCsrf ctx + |> addToHash ViewContext.Model (ManageRevisionsModel.fromPage ctx.WebLog pg) + |> adminView "revisions" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index e5a7c4e..a7ed5f2 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -39,7 +39,7 @@ open MyWebLog.Data open MyWebLog.ViewModels /// Convert a list of posts into items ready to be displayed -let preparePostList webLog posts listType (url : string) pageNbr perPage ctx (data : IData) = task { +let preparePostList webLog posts listType (url : string) pageNbr perPage (data : IData) = task { let! authors = getAuthors webLog posts data let! tagMappings = getTagMappings webLog posts data let relUrl it = Some <| WebLog.relativeUrl webLog (Permalink it) @@ -85,12 +85,11 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage ctx (da OlderLink = olderLink OlderName = olderPost |> Option.map (fun p -> p.Title) } - return makeHash {| - model = model - categories = CategoryCache.get ctx - tag_mappings = tagMappings - is_post = match listType with SinglePost -> true | _ -> false - |} + return + makeHash {||} + |> addToHash ViewContext.Model model + |> addToHash "tag_mappings" tagMappings + |> addToHash ViewContext.IsPost (match listType with SinglePost -> true | _ -> false) } open Giraffe @@ -100,15 +99,18 @@ 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 ctx data + let! hash = 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" - match title with Some ttl -> hash.Add ("page_title", ttl) | None -> () - if pageNbr = 1 && ctx.WebLog.DefaultPage = "posts" then hash.Add ("is_home", true) - return! themedView "index" next ctx hash + 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 + |> themedView "index" next ctx } // GET /page/{pageNbr}/ @@ -131,14 +133,14 @@ 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 ctx data + let! hash = preparePostList webLog posts CategoryList cat.Slug pageNbr webLog.PostsPerPage data let pgTitle = if pageNbr = 1 then "" else $""" (Page {pageNbr})""" return! - addToHash "page_title" $"{cat.Name}: Category Archive{pgTitle}" hash - |> addToHash "subtitle" (defaultArg cat.Description "") - |> addToHash "is_category" true - |> addToHash "is_category_home" (pageNbr = 1) - |> addToHash "slug" slug + 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 |> themedView "index" next ctx | _ -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx @@ -166,13 +168,13 @@ 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 ctx data + let! hash = preparePostList webLog posts TagList rawTag pageNbr webLog.PostsPerPage data let pgTitle = if pageNbr = 1 then "" else $""" (Page {pageNbr})""" return! - addToHash "page_title" $"Posts Tagged “{tag}”{pgTitle}" hash - |> addToHash "is_tag" true - |> addToHash "is_tag_home" (pageNbr = 1) - |> addToHash "slug" rawTag + addToHash ViewContext.PageTitle $"Posts Tagged “{tag}”{pgTitle}" hash + |> addToHash ViewContext.IsTag true + |> addToHash ViewContext.IsTagHome (pageNbr = 1) + |> addToHash ViewContext.Slug rawTag |> themedView "index" next ctx // Other systems use hyphens for spaces; redirect if this is an old tag link | _ -> @@ -196,13 +198,11 @@ let home : HttpHandler = fun next ctx -> task { | pageId -> match! ctx.Data.Page.FindById (PageId pageId) webLog.Id with | Some page -> - return! {| - page_title = page.Title - page = DisplayPage.fromPage webLog page - categories = CategoryCache.get ctx - is_home = true - |} - |> makeHash |> themedView (defaultArg page.Template "single-page") next ctx + return! + hashForPage page.Title + |> addToHash "page" (DisplayPage.fromPage webLog page) + |> addToHash ViewContext.IsHome true + |> themedView (defaultArg page.Template "single-page") next ctx | None -> return! Error.notFound next ctx } @@ -211,10 +211,10 @@ let home : HttpHandler = fun next ctx -> task { 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 ctx data + let! hash = preparePostList ctx.WebLog posts AdminList "" pageNbr 25 data return! - addToHash "page_title" "Posts" hash - |> addToHash "csrf" ctx.CsrfTokenSet + addToHash ViewContext.PageTitle "Posts" hash + |> withAntiCsrf ctx |> adminView "post-list" next ctx } @@ -231,25 +231,23 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { } match result with | Some (title, post) when canEdit post.AuthorId ctx -> - let! cats = data.Category.FindAllForView ctx.WebLog.Id let! templates = templatesForTheme ctx "post" let model = EditPostModel.fromPost ctx.WebLog post - return! {| - page_title = title - csrf = ctx.CsrfTokenSet - model = model - metadata = Array.zip model.MetaNames model.MetaValues - |> Array.mapi (fun idx (name, value) -> [| string idx; name; value |]) - templates = templates - categories = cats - explicit_values = [| + return! + hashForPage title + |> withAntiCsrf ctx + |> addToHash ViewContext.Model model + |> addToHash "metadata" ( + Array.zip model.MetaNames model.MetaValues + |> Array.mapi (fun idx (name, value) -> [| string idx; name; value |])) + |> addToHash "templates" templates + |> addToHash "explicit_values" [| KeyValuePair.Create ("", "– Default –") KeyValuePair.Create (ExplicitRating.toString Yes, "Yes") KeyValuePair.Create (ExplicitRating.toString No, "No") KeyValuePair.Create (ExplicitRating.toString Clean, "Clean") |] - |} - |> makeHash |> adminView "post-edit" next ctx + |> adminView "post-edit" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } @@ -266,12 +264,11 @@ let delete postId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> let editPermalinks postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with | Some post when canEdit post.AuthorId ctx -> - return! {| - page_title = "Manage Prior Permalinks" - csrf = ctx.CsrfTokenSet - model = ManagePermalinksModel.fromPost post - |} - |> makeHash |> adminView "permalinks" next ctx + return! + hashForPage "Manage Prior Permalinks" + |> withAntiCsrf ctx + |> addToHash ViewContext.Model (ManagePermalinksModel.fromPost post) + |> adminView "permalinks" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } @@ -296,12 +293,11 @@ let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task let editRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with | Some post when canEdit post.AuthorId ctx -> - return! {| - page_title = "Manage Post Revisions" - csrf = ctx.CsrfTokenSet - model = ManageRevisionsModel.fromPost ctx.WebLog post - |} - |> makeHash |> adminView "revisions" next ctx + return! + hashForPage "Manage Post Revisions" + |> withAntiCsrf ctx + |> addToHash ViewContext.Model (ManageRevisionsModel.fromPost ctx.WebLog post) + |> adminView "revisions" next ctx | Some _ -> return! Error.notAuthorized next ctx | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 4a57ac8..f8a307b 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -29,9 +29,9 @@ module CatchAll = match data.Post.FindByPermalink permalink webLog.Id |> await with | Some post -> debug (fun () -> "Found post by permalink") - let hash = Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 ctx data |> await + let hash = Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 data |> await yield fun next ctx -> - addToHash "page_title" post.Title hash + addToHash ViewContext.PageTitle post.Title hash |> themedView (defaultArg post.Template "single-post") next ctx | None -> () // Current page @@ -39,13 +39,10 @@ module CatchAll = | Some page -> debug (fun () -> "Found page by permalink") yield fun next ctx -> - {| - page_title = page.Title - page = DisplayPage.fromPage webLog page - categories = CategoryCache.get ctx - is_page = true - |} - |> makeHash |> themedView (defaultArg page.Template "single-page") next ctx + hashForPage page.Title + |> addToHash "page" (DisplayPage.fromPage webLog page) + |> addToHash ViewContext.IsPage true + |> themedView (defaultArg page.Template "single-page") next ctx | None -> () // RSS feed match Feed.deriveFeedType ctx textLink with @@ -195,8 +192,9 @@ let router : HttpHandler = choose [ routef "/%s/delete" Upload.deleteFromDb ]) subRoute "/user" (choose [ - route "/my-info" >=> User.saveMyInfo - route "/save" >=> User.save + route "/my-info" >=> User.saveMyInfo + route "/save" >=> User.save + routef "/%s/delete" User.delete ]) ] ]) diff --git a/src/MyWebLog/Handlers/Upload.fs b/src/MyWebLog/Handlers/Upload.fs index 8931e93..91c53d8 100644 --- a/src/MyWebLog/Handlers/Upload.fs +++ b/src/MyWebLog/Handlers/Upload.fs @@ -118,22 +118,19 @@ let list : HttpHandler = requireAccess Author >=> fun next ctx -> task { |> List.map (DisplayUpload.fromUpload webLog Database) |> List.append diskUploads |> List.sortByDescending (fun file -> file.UpdatedOn, file.Path) - - return! {| - page_title = "Uploaded Files" - csrf = ctx.CsrfTokenSet - files = allFiles - |} - |> makeHash |> adminView "upload-list" next ctx + return! + hashForPage "Uploaded Files" + |> withAntiCsrf ctx + |> addToHash "files" allFiles + |> adminView "upload-list" next ctx } // GET /admin/upload/new let showNew : HttpHandler = requireAccess Author >=> fun next ctx -> - {| page_title = "Upload a File" - csrf = ctx.CsrfTokenSet - destination = UploadDestination.toString ctx.WebLog.Uploads - |} - |> makeHash |> adminView "upload-new" next ctx + hashForPage "Upload a File" + |> withAntiCsrf ctx + |> addToHash "destination" (UploadDestination.toString ctx.WebLog.Uploads) + |> adminView "upload-new" next ctx /// Redirect to the upload list diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index 1353669..828fab5 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -23,11 +23,10 @@ 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 - {| page_title = "Log On" - csrf = ctx.CsrfTokenSet - model = { LogOnModel.empty with ReturnTo = returnTo } - |} - |> makeHash |> adminView "log-on" next ctx + hashForPage "Log On" + |> withAntiCsrf ctx + |> addToHash ViewContext.Model { LogOnModel.empty with ReturnTo = returnTo } + |> adminView "log-on" next ctx open System.Security.Claims @@ -72,21 +71,22 @@ let logOff : HttpHandler = fun next ctx -> task { // ~~ ADMINISTRATION ~~ open System.Collections.Generic -open DotLiquid open Giraffe.Htmx open Microsoft.AspNetCore.Http /// Create the hash needed to display the user list let private userListHash (ctx : HttpContext) = task { let! users = ctx.Data.WebLogUser.FindByWebLog ctx.WebLog.Id - return makeHash {| - page_title = "User Administration" - csrf = ctx.CsrfTokenSet - web_log = ctx.WebLog - users = users |> List.map (DisplayUser.fromUser ctx.WebLog) |> Array.ofList - |} + return! + hashForPage "User Administration" + |> withAntiCsrf ctx + |> addToHash "users" (users |> List.map (DisplayUser.fromUser ctx.WebLog) |> Array.ofList) + |> addViewContext ctx } - + +/// Got no time for URL/form manipulators... +let private goAway : HttpHandler = RequestErrors.BAD_REQUEST "really?" + // GET /admin/users let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let! hash = userListHash ctx @@ -103,16 +103,17 @@ let bare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { } /// Show the edit user page -let private showEdit (hash : Hash) : HttpHandler = fun next ctx -> - addToHash "page_title" (if (hash["model"] :?> EditUserModel).IsNew then "Add a New User" else "Edit User") hash - |> addToHash "csrf" ctx.CsrfTokenSet - |> addToHash "access_levels" - [| KeyValuePair.Create (AccessLevel.toString Author, "Author") - KeyValuePair.Create (AccessLevel.toString Editor, "Editor") - KeyValuePair.Create (AccessLevel.toString WebLogAdmin, "Web Log Admin") - if ctx.HasAccessLevel Administrator then - KeyValuePair.Create (AccessLevel.toString Administrator, "Administrator") - |] +let private showEdit (model : EditUserModel) : HttpHandler = fun next ctx -> + hashForPage (if model.IsNew then "Add a New User" else "Edit User") + |> withAntiCsrf ctx + |> addToHash ViewContext.Model model + |> addToHash "access_levels" [| + KeyValuePair.Create (AccessLevel.toString Author, "Author") + KeyValuePair.Create (AccessLevel.toString Editor, "Editor") + KeyValuePair.Create (AccessLevel.toString WebLogAdmin, "Web Log Admin") + if ctx.HasAccessLevel Administrator then + KeyValuePair.Create (AccessLevel.toString Administrator, "Administrator") + |] |> adminBareView "user-edit" next ctx // GET /admin/user/{id}/edit @@ -123,7 +124,7 @@ let edit usrId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> tas if isNew then someTask { WebLogUser.empty with Id = userId } else ctx.Data.WebLogUser.FindById userId ctx.WebLog.Id match! tryUser with - | Some user -> return! showEdit (makeHash {| model = EditUserModel.fromUser user |}) next ctx + | Some user -> return! showEdit (EditUserModel.fromUser user) next ctx | None -> return! Error.notFound next ctx } @@ -143,7 +144,7 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { | Some user when model.Password = model.PasswordConfirm -> let updatedUser = model.UpdateUser user if updatedUser.AccessLevel = Administrator && not (ctx.HasAccessLevel Administrator) then - return! RequestErrors.BAD_REQUEST "really?" next ctx + return! goAway next ctx else let updatedUser = if model.Password = "" then updatedUser @@ -159,26 +160,51 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { | Some _ -> do! addMessage ctx { UserMessage.error with Message = "The passwords did not match; nothing saved" } return! - (withHxRetarget $"#user_{model.Id}" - >=> showEdit (makeHash {| model = { model with Password = ""; PasswordConfirm = "" } |})) + (withHxRetarget $"#user_{model.Id}" >=> showEdit { model with Password = ""; PasswordConfirm = "" }) next ctx | None -> return! Error.notFound next ctx } +// POST /admin/user/{id}/delete +let delete userId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { + let data = ctx.Data + match! data.WebLogUser.FindById (WebLogUserId userId) ctx.WebLog.Id with + | Some user -> + if user.AccessLevel = Administrator && not (ctx.HasAccessLevel Administrator) then + return! goAway next ctx + else + match! data.WebLogUser.Delete user.Id user.WebLogId with + | Ok _ -> + do! addMessage ctx + { UserMessage.success with + Message = $"User {WebLogUser.displayName user} deleted successfully" + } + return! bare next ctx + | Error msg -> + do! addMessage ctx + { UserMessage.error with + Message = $"User {WebLogUser.displayName user} was not deleted" + Detail = Some msg + } + return! bare next ctx + | None -> return! Error.notFound next ctx +} + /// Display the user "my info" page, with information possibly filled in -let private showMyInfo (user : WebLogUser) (hash : Hash) : HttpHandler = fun next ctx -> - addToHash "page_title" "Edit Your Information" hash - |> addToHash "csrf" ctx.CsrfTokenSet - |> addToHash "access_level" (AccessLevel.toString user.AccessLevel) - |> addToHash "created_on" (WebLog.localTime ctx.WebLog user.CreatedOn) - |> addToHash "last_seen_on" (WebLog.localTime ctx.WebLog (defaultArg user.LastSeenOn DateTime.UnixEpoch)) +let private showMyInfo (model : EditMyInfoModel) (user : WebLogUser) : HttpHandler = fun next ctx -> + hashForPage "Edit Your Information" + |> withAntiCsrf ctx + |> addToHash ViewContext.Model model + |> addToHash "access_level" (AccessLevel.toString user.AccessLevel) + |> addToHash "created_on" (WebLog.localTime ctx.WebLog user.CreatedOn) + |> addToHash "last_seen_on" (WebLog.localTime ctx.WebLog (defaultArg user.LastSeenOn DateTime.UnixEpoch)) |> adminView "my-info" next ctx // GET /admin/user/my-info let myInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { match! ctx.Data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with - | Some user -> return! showMyInfo user (makeHash {| model = EditMyInfoModel.fromUser user |}) next ctx + | Some user -> return! showMyInfo (EditMyInfoModel.fromUser user) user next ctx | None -> return! Error.notFound next ctx } @@ -208,7 +234,6 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { return! redirectToGet "admin/user/my-info" next ctx | Some user -> do! addMessage ctx { UserMessage.error with Message = "Passwords did not match; no updates made" } - return! showMyInfo user (makeHash {| model = { model with NewPassword = ""; NewPasswordConfirm = "" } |}) - next ctx + return! showMyInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user next ctx | None -> return! Error.notFound next ctx } diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index e81eafd..d60d9f4 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -46,7 +46,7 @@ module DataImplementation = let createSQLite connStr = let log = sp.GetRequiredService> () let conn = new SqliteConnection (connStr) - log.LogInformation $"Using SQL database {conn.DataSource}" + log.LogInformation $"Using SQLite database {conn.DataSource}" await (SQLiteData.setUpConnection conn) SQLiteData (conn, log) @@ -62,6 +62,26 @@ module DataImplementation = upcast createSQLite "Data Source=./myweblog.db;Cache=Shared" +open System.Threading.Tasks + +/// Show a list of valid command-line interface commands +let showHelp () = + printfn " " + printfn "COMMAND WHAT IT DOES" + printfn "----------- ------------------------------------------------------" + printfn "backup Create a JSON file backup of a web log" + printfn "do-restore Restore a JSON file backup (overwrite data silently)" + printfn "help Display this information" + printfn "import-links Import prior permalinks" + printfn "init Initializes a new web log" + printfn "load-theme Load a theme" + printfn "restore Restore a JSON file backup (prompt before overwriting)" + printfn "upgrade-user Upgrade a WebLogAdmin user to a full Administrator" + printfn " " + printfn "For more information on a particular command, run it with no options." + Task.FromResult () + + open Giraffe open Giraffe.EndpointRouting open Microsoft.AspNetCore.Authentication.Cookies @@ -138,7 +158,11 @@ let rec main args = | Some it when it = "restore" -> Maintenance.Backup.restoreFromBackup args app.Services | Some it when it = "do-restore" -> Maintenance.Backup.restoreFromBackup args app.Services | Some it when it = "upgrade-user" -> Maintenance.upgradeUser args app.Services - | _ -> + | Some it when it = "help" -> showHelp () + | Some it -> + printfn $"""Unrecognized command "{it}" - valid commands are:""" + showHelp () + | None -> let _ = app.UseForwardedHeaders () let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict)) let _ = app.UseMiddleware () @@ -148,7 +172,7 @@ let rec main args = let _ = app.UseSession () let _ = app.UseGiraffe Handlers.Routes.endpoint - System.Threading.Tasks.Task.FromResult (app.Run ()) + Task.FromResult (app.Run ()) |> Async.AwaitTask |> Async.RunSynchronously 0 // Exit code diff --git a/src/admin-theme/user-list-body.liquid b/src/admin-theme/user-list-body.liquid index 40da7a5..5ea9ae6 100644 --- a/src/admin-theme/user-list-body.liquid +++ b/src/admin-theme/user-list-body.liquid @@ -19,19 +19,23 @@ {%- elsif user.access_level == "Author" %} AUTHOR {%- endif %}
- - {%- assign user_url_base = "admin/user/" | append: user.id -%} - - Edit - - • - {%- assign user_del_link = user_url_base | append: "/delete" | relative_link -%} - - Delete - - + {%- unless is_administrator == false and user.access_level == "Administrator" %} + + {%- assign user_url_base = "admin/user/" | append: user.id -%} + + Edit + + {% unless user_id == user.id %} + • + {%- assign user_del_link = user_url_base | append: "/delete" | relative_link -%} + + Delete + + {% endunless %} + + {%- endunless %}