diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 0b4f28a..0c6d83a 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -12,30 +12,34 @@ open NodaTime module Dashboard = // GET /admin/dashboard - let user : HttpHandler = requireAccess Author >=> fun next ctx -> task { - let getCount (f: WebLogId -> Task) = f ctx.WebLog.Id - let data = ctx.Data - let! posts = getCount (data.Post.CountByStatus Published) - let! drafts = getCount (data.Post.CountByStatus Draft) - let! pages = getCount data.Page.CountAll - let! listed = getCount data.Page.CountListed - let! cats = getCount data.Category.CountAll - let! topCats = getCount data.Category.CountTopLevel - let model = - { Posts = posts - Drafts = drafts - Pages = pages - ListedPages = listed - Categories = cats - TopLevelCategories = topCats } - return! adminPage "Dashboard" next ctx (Views.WebLog.dashboard model) - } + let user : HttpHandler = + requireAccess Author + >=> fun next ctx -> task { + let getCount (f: WebLogId -> Task) = f ctx.WebLog.Id + let data = ctx.Data + let! posts = getCount (data.Post.CountByStatus Published) + let! drafts = getCount (data.Post.CountByStatus Draft) + let! pages = getCount data.Page.CountAll + let! listed = getCount data.Page.CountListed + let! cats = getCount data.Category.CountAll + let! topCats = getCount data.Category.CountTopLevel + let model = + { Posts = posts + Drafts = drafts + Pages = pages + ListedPages = listed + Categories = cats + TopLevelCategories = topCats } + return! adminPage "Dashboard" next ctx (Views.WebLog.dashboard model) + } // GET /admin/administration - let admin : HttpHandler = requireAccess Administrator >=> fun next ctx -> task { - let! themes = ctx.Data.Theme.All() - return! adminPage "myWebLog Administration" next ctx (Views.Admin.dashboard themes) - } + let admin : HttpHandler = + requireAccess Administrator + >=> fun next ctx -> task { + let! themes = ctx.Data.Theme.All() + return! adminPage "myWebLog Administration" next ctx (Views.Admin.dashboard themes) + } /// Redirect the user to the admin dashboard let toAdminDashboard : HttpHandler = redirectToGet "admin/administration" @@ -45,49 +49,56 @@ let toAdminDashboard : HttpHandler = redirectToGet "admin/administration" module Cache = // POST /admin/cache/web-log/{id}/refresh - let refreshWebLog webLogId : HttpHandler = requireAccess Administrator >=> validateCsrf >=> fun next ctx -> task { - let data = ctx.Data - if webLogId = "all" then - do! WebLogCache.fill data - for webLog in WebLogCache.all () do - do! PageListCache.refresh webLog data - do! CategoryCache.refresh webLog.Id data - do! addMessage ctx - { UserMessage.Success with Message = "Successfully refresh web log cache for all web logs" } - else - match! data.WebLog.FindById(WebLogId webLogId) with - | Some webLog -> - WebLogCache.set webLog - do! PageListCache.refresh webLog data - do! CategoryCache.refresh webLog.Id data + let refreshWebLog webLogId : HttpHandler = + requireAccess Administrator + >=> validateCsrf + >=> fun next ctx -> task { + let data = ctx.Data + if webLogId = "all" then + do! WebLogCache.fill data + for webLog in WebLogCache.all () do + do! PageListCache.refresh webLog data + do! CategoryCache.refresh webLog.Id data do! addMessage ctx - { UserMessage.Success with Message = $"Successfully refreshed web log cache for {webLog.Name}" } - | None -> - do! addMessage ctx { UserMessage.Error with Message = $"No web log exists with ID {webLogId}" } - return! toAdminDashboard next ctx - } + { UserMessage.Success with Message = "Successfully refresh web log cache for all web logs" } + else + match! data.WebLog.FindById(WebLogId webLogId) with + | Some webLog -> + WebLogCache.set webLog + do! PageListCache.refresh webLog data + do! CategoryCache.refresh webLog.Id data + do! addMessage ctx + { UserMessage.Success with + Message = $"Successfully refreshed web log cache for {webLog.Name}" } + | None -> + do! addMessage ctx { UserMessage.Error with Message = $"No web log exists with ID {webLogId}" } + return! toAdminDashboard next ctx + } // POST /admin/cache/theme/{id}/refresh - let refreshTheme themeId : HttpHandler = requireAccess Administrator >=> validateCsrf >=> fun next ctx -> task { - let data = ctx.Data - if themeId = "all" then - Template.Cache.empty () - do! ThemeAssetCache.fill data - do! addMessage ctx - { UserMessage.Success with - Message = "Successfully cleared template cache and refreshed theme asset cache" } - else - match! data.Theme.FindById(ThemeId themeId) with - | Some theme -> - Template.Cache.invalidateTheme theme.Id - do! ThemeAssetCache.refreshTheme theme.Id data + let refreshTheme themeId : HttpHandler = + requireAccess Administrator + >=> validateCsrf + >=> fun next ctx -> task { + let data = ctx.Data + if themeId = "all" then + Template.Cache.empty () + do! ThemeAssetCache.fill data do! addMessage ctx { UserMessage.Success with - Message = $"Successfully cleared template cache and refreshed theme asset cache for {theme.Name}" } - | None -> - do! addMessage ctx { UserMessage.Error with Message = $"No theme exists with ID {themeId}" } - return! toAdminDashboard next ctx - } + Message = "Successfully cleared template cache and refreshed theme asset cache" } + else + match! data.Theme.FindById(ThemeId themeId) with + | Some theme -> + Template.Cache.invalidateTheme theme.Id + do! ThemeAssetCache.refreshTheme theme.Id data + do! addMessage ctx + { UserMessage.Success with + Message = $"Successfully cleared template cache and refreshed theme asset cache for {theme.Name}" } + | None -> + do! addMessage ctx { UserMessage.Error with Message = $"No theme exists with ID {themeId}" } + return! toAdminDashboard next ctx + } /// ~~~ CATEGORIES ~~~ @@ -96,68 +107,78 @@ module Category = open MyWebLog.Data // GET /admin/categories - let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> - let response = fun next ctx -> - adminPage "Categories" next ctx (Views.WebLog.categoryList (ctx.Request.Query.ContainsKey "new")) - (withHxPushUrl (ctx.WebLog.RelativeUrl (Permalink "admin/categories")) >=> response) next ctx + let all : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> + let response = fun next ctx -> + adminPage "Categories" next ctx (Views.WebLog.categoryList (ctx.Request.Query.ContainsKey "new")) + (withHxPushUrl (ctx.WebLog.RelativeUrl (Permalink "admin/categories")) >=> response) next ctx // GET /admin/category/{id}/edit - let edit catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { - let! result = task { - match catId with - | "new" -> return Some ("Add a New Category", { Category.Empty with Id = CategoryId "new" }) - | _ -> - match! ctx.Data.Category.FindById (CategoryId catId) ctx.WebLog.Id with - | Some cat -> return Some ("Edit Category", cat) - | None -> return None + let edit catId : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + let! result = task { + match catId with + | "new" -> return Some ("Add a New Category", { Category.Empty with Id = CategoryId "new" }) + | _ -> + match! ctx.Data.Category.FindById (CategoryId catId) ctx.WebLog.Id with + | Some cat -> return Some ("Edit Category", cat) + | None -> return None + } + match result with + | Some (title, cat) -> + return! + Views.WebLog.categoryEdit (EditCategoryModel.FromCategory cat) + |> adminBarePage title next ctx + | None -> return! Error.notFound next ctx } - match result with - | Some (title, cat) -> - return! - Views.WebLog.categoryEdit (EditCategoryModel.FromCategory cat) - |> adminBarePage title next ctx - | None -> return! Error.notFound next ctx - } // POST /admin/category/save - let save : HttpHandler = requireAccess WebLogAdmin >=> validateCsrf >=> fun next ctx -> task { - let data = ctx.Data - let! model = ctx.BindFormAsync() - let category = - if model.IsNew then someTask { Category.Empty with Id = CategoryId.Create(); WebLogId = ctx.WebLog.Id } - else data.Category.FindById (CategoryId model.CategoryId) ctx.WebLog.Id - match! category with - | Some cat -> - let updatedCat = - { cat with - Name = model.Name - Slug = model.Slug - Description = if model.Description = "" then None else Some model.Description - ParentId = if model.ParentId = "" then None else Some (CategoryId model.ParentId) } - do! (if model.IsNew then data.Category.Add else data.Category.Update) updatedCat - do! CategoryCache.update ctx - do! addMessage ctx { UserMessage.Success with Message = "Category saved successfully" } - return! all next ctx - | None -> return! Error.notFound next ctx - } + let save : HttpHandler = + requireAccess WebLogAdmin + >=> validateCsrf + >=> fun next ctx -> task { + let data = ctx.Data + let! model = ctx.BindFormAsync() + let category = + if model.IsNew then someTask { Category.Empty with Id = CategoryId.Create(); WebLogId = ctx.WebLog.Id } + else data.Category.FindById (CategoryId model.CategoryId) ctx.WebLog.Id + match! category with + | Some cat -> + let updatedCat = + { cat with + Name = model.Name + Slug = model.Slug + Description = if model.Description = "" then None else Some model.Description + ParentId = if model.ParentId = "" then None else Some (CategoryId model.ParentId) } + do! (if model.IsNew then data.Category.Add else data.Category.Update) updatedCat + do! CategoryCache.update ctx + do! addMessage ctx { UserMessage.Success with Message = "Category saved successfully" } + return! all next ctx + | None -> return! Error.notFound next ctx + } // DELETE /admin/category/{id} - let delete catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { - let! result = ctx.Data.Category.Delete (CategoryId catId) ctx.WebLog.Id - match result with - | CategoryDeleted - | ReassignedChildCategories -> - do! CategoryCache.update ctx - let detail = - match result with - | ReassignedChildCategories -> - Some "(Its child categories were reassigned to its parent category)" - | _ -> None - do! addMessage ctx { UserMessage.Success with Message = "Category deleted successfully"; Detail = detail } - | CategoryNotFound -> - do! addMessage ctx { UserMessage.Error with Message = "Category not found; cannot delete" } - return! all next ctx - } + let delete catId : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + let! result = ctx.Data.Category.Delete (CategoryId catId) ctx.WebLog.Id + match result with + | CategoryDeleted + | ReassignedChildCategories -> + do! CategoryCache.update ctx + let detail = + match result with + | ReassignedChildCategories -> + Some "(Its child categories were reassigned to its parent category)" + | _ -> None + do! addMessage + ctx { UserMessage.Success with Message = "Category deleted successfully"; Detail = detail } + | CategoryNotFound -> + do! addMessage ctx { UserMessage.Error with Message = "Category not found; cannot delete" } + return! all next ctx + } /// ~~~ REDIRECT RULES ~~~ @@ -166,24 +187,28 @@ module RedirectRules = open Microsoft.AspNetCore.Http // GET /admin/settings/redirect-rules - let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> - adminPage "Redirect Rules" next ctx (Views.WebLog.redirectList ctx.WebLog.RedirectRules) + let all : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> + adminPage "Redirect Rules" next ctx (Views.WebLog.redirectList ctx.WebLog.RedirectRules) // GET /admin/settings/redirect-rules/[index] - let edit idx : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> - let titleAndView = - if idx = -1 then - Some ("Add", Views.WebLog.redirectEdit (EditRedirectRuleModel.FromRule -1 RedirectRule.Empty)) - else - let rules = ctx.WebLog.RedirectRules - if rules.Length < idx || idx < 0 then - None + let edit idx : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> + let titleAndView = + if idx = -1 then + Some ("Add", Views.WebLog.redirectEdit (EditRedirectRuleModel.FromRule -1 RedirectRule.Empty)) else - Some - ("Edit", (Views.WebLog.redirectEdit (EditRedirectRuleModel.FromRule idx (List.item idx rules)))) - match titleAndView with - | Some (title, view) -> adminBarePage $"{title} Redirect Rule" next ctx view - | None -> Error.notFound next ctx + let rules = ctx.WebLog.RedirectRules + if rules.Length < idx || idx < 0 then + None + else + Some ("Edit", + Views.WebLog.redirectEdit (EditRedirectRuleModel.FromRule idx (List.item idx rules))) + match titleAndView with + | Some (title, view) -> adminBarePage $"{title} Redirect Rule" next ctx view + | None -> Error.notFound next ctx /// Update the web log's redirect rules in the database, the request web log, and the web log cache let private updateRedirectRules (ctx: HttpContext) webLog = backgroundTask { @@ -193,99 +218,119 @@ module RedirectRules = } // POST /admin/settings/redirect-rules/[index] - let save idx : HttpHandler = requireAccess WebLogAdmin >=> validateCsrf >=> fun next ctx -> task { - let! model = ctx.BindFormAsync() - let rule = model.ToRule() - let rules = - ctx.WebLog.RedirectRules - |> match idx with - | -1 when model.InsertAtTop -> List.insertAt 0 rule - | -1 -> List.insertAt ctx.WebLog.RedirectRules.Length rule - | _ -> List.removeAt idx >> List.insertAt idx rule - do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = rules } - do! addMessage ctx { UserMessage.Success with Message = "Redirect rule saved successfully" } - return! all next ctx - } + let save idx : HttpHandler = + requireAccess WebLogAdmin + >=> validateCsrf + >=> fun next ctx -> task { + let! model = ctx.BindFormAsync() + let rule = model.ToRule() + let rules = + ctx.WebLog.RedirectRules + |> match idx with + | -1 when model.InsertAtTop -> List.insertAt 0 rule + | -1 -> List.insertAt ctx.WebLog.RedirectRules.Length rule + | _ -> List.removeAt idx >> List.insertAt idx rule + do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = rules } + do! addMessage ctx { UserMessage.Success with Message = "Redirect rule saved successfully" } + return! all next ctx + } // POST /admin/settings/redirect-rules/[index]/up - let moveUp idx : HttpHandler = requireAccess WebLogAdmin >=> validateCsrf >=> fun next ctx -> task { - if idx < 1 || idx >= ctx.WebLog.RedirectRules.Length then - return! Error.notFound next ctx - else - let toMove = List.item idx ctx.WebLog.RedirectRules - let newRules = ctx.WebLog.RedirectRules |> List.removeAt idx |> List.insertAt (idx - 1) toMove - do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = newRules } - return! all next ctx - } + let moveUp idx : HttpHandler = + requireAccess WebLogAdmin + >=> validateCsrf + >=> fun next ctx -> task { + if idx < 1 || idx >= ctx.WebLog.RedirectRules.Length then + return! Error.notFound next ctx + else + let toMove = List.item idx ctx.WebLog.RedirectRules + let newRules = ctx.WebLog.RedirectRules |> List.removeAt idx |> List.insertAt (idx - 1) toMove + do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = newRules } + return! all next ctx + } // POST /admin/settings/redirect-rules/[index]/down - let moveDown idx : HttpHandler = requireAccess WebLogAdmin >=> validateCsrf >=> fun next ctx -> task { - if idx < 0 || idx >= ctx.WebLog.RedirectRules.Length - 1 then - return! Error.notFound next ctx - else - let toMove = List.item idx ctx.WebLog.RedirectRules - let newRules = ctx.WebLog.RedirectRules |> List.removeAt idx |> List.insertAt (idx + 1) toMove - do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = newRules } - return! all next ctx - } + let moveDown idx : HttpHandler = + requireAccess WebLogAdmin + >=> validateCsrf + >=> fun next ctx -> task { + if idx < 0 || idx >= ctx.WebLog.RedirectRules.Length - 1 then + return! Error.notFound next ctx + else + let toMove = List.item idx ctx.WebLog.RedirectRules + let newRules = ctx.WebLog.RedirectRules |> List.removeAt idx |> List.insertAt (idx + 1) toMove + do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = newRules } + return! all next ctx + } // DELETE /admin/settings/redirect-rules/[index] - let delete idx : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { - if idx < 0 || idx >= ctx.WebLog.RedirectRules.Length then - return! Error.notFound next ctx - else - let rules = ctx.WebLog.RedirectRules |> List.removeAt idx - do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = rules } - do! addMessage ctx { UserMessage.Success with Message = "Redirect rule deleted successfully" } - return! all next ctx - } + let delete idx : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + if idx < 0 || idx >= ctx.WebLog.RedirectRules.Length then + return! Error.notFound next ctx + else + let rules = ctx.WebLog.RedirectRules |> List.removeAt idx + do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = rules } + do! addMessage ctx { UserMessage.Success with Message = "Redirect rule deleted successfully" } + return! all next ctx + } /// ~~~ TAG MAPPINGS ~~~ module TagMapping = // GET /admin/settings/tag-mappings - let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { - let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id - return! adminBarePage "Tag Mapping List" next ctx (Views.WebLog.tagMapList mappings) - } + let all : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id + return! adminBarePage "Tag Mapping List" next ctx (Views.WebLog.tagMapList mappings) + } // GET /admin/settings/tag-mapping/{id}/edit - let edit tagMapId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { - let isNew = tagMapId = "new" - let tagMap = - if isNew then someTask { TagMap.Empty with Id = TagMapId "new" } - else ctx.Data.TagMap.FindById (TagMapId tagMapId) ctx.WebLog.Id - match! tagMap with - | Some tm -> - return! - Views.WebLog.tagMapEdit (EditTagMapModel.FromMapping tm) - |> adminBarePage (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag") next ctx - | None -> return! Error.notFound next ctx - } + let edit tagMapId : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + let isNew = tagMapId = "new" + let tagMap = + if isNew then someTask { TagMap.Empty with Id = TagMapId "new" } + else ctx.Data.TagMap.FindById (TagMapId tagMapId) ctx.WebLog.Id + match! tagMap with + | Some tm -> + return! + Views.WebLog.tagMapEdit (EditTagMapModel.FromMapping tm) + |> adminBarePage (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag") next ctx + | None -> return! Error.notFound next ctx + } // POST /admin/settings/tag-mapping/save - let save : HttpHandler = requireAccess WebLogAdmin >=> validateCsrf >=> fun next ctx -> task { - let data = ctx.Data - let! model = ctx.BindFormAsync() - let tagMap = - if model.IsNew then someTask { TagMap.Empty with Id = TagMapId.Create(); WebLogId = ctx.WebLog.Id } - else data.TagMap.FindById (TagMapId model.Id) ctx.WebLog.Id - match! tagMap with - | Some tm -> - do! data.TagMap.Save { tm with Tag = model.Tag.ToLower(); UrlValue = model.UrlValue.ToLower() } - do! addMessage ctx { UserMessage.Success with Message = "Tag mapping saved successfully" } - return! all next ctx - | None -> return! Error.notFound next ctx - } + let save : HttpHandler = + requireAccess WebLogAdmin + >=> validateCsrf + >=> fun next ctx -> task { + let data = ctx.Data + let! model = ctx.BindFormAsync() + let tagMap = + if model.IsNew then someTask { TagMap.Empty with Id = TagMapId.Create(); WebLogId = ctx.WebLog.Id } + else data.TagMap.FindById (TagMapId model.Id) ctx.WebLog.Id + match! tagMap with + | Some tm -> + do! data.TagMap.Save { tm with Tag = model.Tag.ToLower(); UrlValue = model.UrlValue.ToLower() } + do! addMessage ctx { UserMessage.Success with Message = "Tag mapping saved successfully" } + return! all next ctx + | None -> return! Error.notFound next ctx + } // DELETE /admin/settings/tag-mapping/{id} - let delete tagMapId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { - match! ctx.Data.TagMap.Delete (TagMapId tagMapId) ctx.WebLog.Id with - | true -> do! addMessage ctx { UserMessage.Success with Message = "Tag mapping deleted successfully" } - | false -> do! addMessage ctx { UserMessage.Error with Message = "Tag mapping not found; nothing deleted" } - return! all next ctx - } + let delete tagMapId : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + match! ctx.Data.TagMap.Delete (TagMapId tagMapId) ctx.WebLog.Id with + | true -> do! addMessage ctx { UserMessage.Success with Message = "Tag mapping deleted successfully" } + | false -> do! addMessage ctx { UserMessage.Error with Message = "Tag mapping not found; nothing deleted" } + return! all next ctx + } /// ~~~ THEMES ~~~ @@ -298,16 +343,19 @@ module Theme = open MyWebLog.Data // GET /admin/theme/list - let all : HttpHandler = requireAccess Administrator >=> fun next ctx -> task { - let! themes = ctx.Data.Theme.All () - return! - Views.Admin.themeList (List.map (DisplayTheme.FromTheme WebLogCache.isThemeInUse) themes) - |> adminBarePage "Themes" next ctx - } + let all : HttpHandler = + requireAccess Administrator + >=> fun next ctx -> task { + let! themes = ctx.Data.Theme.All () + return! + Views.Admin.themeList (List.map (DisplayTheme.FromTheme WebLogCache.isThemeInUse) themes) + |> adminBarePage "Themes" next ctx + } // GET /admin/theme/new - let add : HttpHandler = requireAccess Administrator >=> fun next ctx -> - adminBarePage "Upload a Theme File" next ctx Views.Admin.themeUpload + let add : HttpHandler = + requireAccess Administrator + >=> fun next ctx -> adminBarePage "Upload a Theme File" next ctx Views.Admin.themeUpload /// Update the name and version for a theme based on the version.txt file, if present let private updateNameAndVersion (theme: Theme) (zip: ZipArchive) = backgroundTask { @@ -383,67 +431,73 @@ module Theme = } // POST /admin/theme/new - let save : HttpHandler = requireAccess Administrator >=> validateCsrf >=> fun next ctx -> task { - if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then - let themeFile = Seq.head ctx.Request.Form.Files - match deriveIdFromFileName themeFile.FileName with - | Ok themeId when themeId <> ThemeId "admin" -> - let data = ctx.Data - let! exists = data.Theme.Exists themeId - let isNew = not exists - let! model = ctx.BindFormAsync() - if isNew || model.DoOverwrite then - // Load the theme to the database - use stream = new MemoryStream() - do! themeFile.CopyToAsync stream - let! _ = loadFromZip themeId stream data - do! ThemeAssetCache.refreshTheme themeId data - Template.Cache.invalidateTheme themeId - // Ensure the themes directory exists - let themeDir = Path.Combine(".", "themes") - if not (Directory.Exists themeDir) then Directory.CreateDirectory themeDir |> ignore - // Save the .zip file - use file = new FileStream(Path.Combine(".", "themes", $"{themeId}-theme.zip"), FileMode.Create) - do! themeFile.CopyToAsync file - do! addMessage ctx - { UserMessage.Success with - Message = $"""Theme {if isNew then "add" else "updat"}ed successfully""" } + let save : HttpHandler = + requireAccess Administrator + >=> validateCsrf + >=> fun next ctx -> task { + if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then + let themeFile = Seq.head ctx.Request.Form.Files + match deriveIdFromFileName themeFile.FileName with + | Ok themeId when themeId <> ThemeId "admin" -> + let data = ctx.Data + let! exists = data.Theme.Exists themeId + let isNew = not exists + let! model = ctx.BindFormAsync() + if isNew || model.DoOverwrite then + // Load the theme to the database + use stream = new MemoryStream() + do! themeFile.CopyToAsync stream + let! _ = loadFromZip themeId stream data + do! ThemeAssetCache.refreshTheme themeId data + Template.Cache.invalidateTheme themeId + // Ensure the themes directory exists + let themeDir = Path.Combine(".", "themes") + if not (Directory.Exists themeDir) then Directory.CreateDirectory themeDir |> ignore + // Save the .zip file + use file = new FileStream(Path.Combine(".", "themes", $"{themeId}-theme.zip"), FileMode.Create) + do! themeFile.CopyToAsync file + do! addMessage 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! toAdminDashboard next ctx + | Ok _ -> + do! addMessage ctx { UserMessage.Error with Message = "You may not replace the admin theme" } return! toAdminDashboard next ctx - else - do! addMessage ctx - { UserMessage.Error with - Message = "Theme exists and overwriting was not requested; nothing saved" } + | Error message -> + do! addMessage ctx { UserMessage.Error with Message = message } return! toAdminDashboard next ctx - | Ok _ -> - do! addMessage ctx { UserMessage.Error with Message = "You may not replace the admin theme" } - return! toAdminDashboard next ctx - | Error message -> - do! addMessage ctx { UserMessage.Error with Message = message } - return! toAdminDashboard next ctx - else return! RequestErrors.BAD_REQUEST "Bad request" next ctx - } + else return! RequestErrors.BAD_REQUEST "Bad request" next ctx + } // POST /admin/theme/{id}/delete - let delete themeId : HttpHandler = requireAccess Administrator >=> validateCsrf >=> fun next ctx -> task { - let data = ctx.Data - match themeId with - | "admin" | "default" -> - do! addMessage ctx { UserMessage.Error with Message = $"You may not delete the {themeId} theme" } - return! all next ctx - | it when WebLogCache.isThemeInUse (ThemeId it) -> - do! addMessage ctx - { UserMessage.Error with - Message = $"You may not delete the {themeId} theme, as it is currently in use" } - return! all next ctx - | _ -> - match! data.Theme.Delete (ThemeId themeId) with - | true -> - let zippedTheme = Path.Combine(".", "themes", $"{themeId}-theme.zip") - if File.Exists zippedTheme then File.Delete zippedTheme - do! addMessage ctx { UserMessage.Success with Message = $"Theme ID {themeId} deleted successfully" } + let delete themeId : HttpHandler = + requireAccess Administrator + >=> validateCsrf + >=> fun next ctx -> task { + let data = ctx.Data + match themeId with + | "admin" | "default" -> + do! addMessage ctx { UserMessage.Error with Message = $"You may not delete the {themeId} theme" } return! all next ctx - | false -> return! Error.notFound next ctx - } + | it when WebLogCache.isThemeInUse (ThemeId it) -> + do! addMessage ctx + { UserMessage.Error with + Message = $"You may not delete the {themeId} theme, as it is currently in use" } + return! all next ctx + | _ -> + match! data.Theme.Delete (ThemeId themeId) with + | true -> + let zippedTheme = Path.Combine(".", "themes", $"{themeId}-theme.zip") + if File.Exists zippedTheme then File.Delete zippedTheme + do! addMessage ctx { UserMessage.Success with Message = $"Theme ID {themeId} deleted successfully" } + return! all next ctx + | false -> return! Error.notFound next ctx + } /// ~~~ WEB LOG SETTINGS ~~~ @@ -452,41 +506,50 @@ module WebLog = open System.IO // GET /admin/settings - let settings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { - let data = ctx.Data - let! allPages = data.Page.All ctx.WebLog.Id - let pages = - allPages - |> List.sortBy _.Title.ToLower() - |> List.append [ { Page.Empty with Id = PageId "posts"; Title = "- First Page of Posts -" } ] - let! themes = data.Theme.All() - let uploads = [ Database; Disk ] - return! - Views.WebLog.webLogSettings - (SettingsModel.FromWebLog ctx.WebLog) themes pages uploads (EditRssModel.FromRssOptions ctx.WebLog.Rss) - |> adminPage "Web Log Settings" next ctx - } + let settings : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + let data = ctx.Data + let! allPages = data.Page.All ctx.WebLog.Id + let pages = + allPages + |> List.sortBy _.Title.ToLower() + |> List.append [ { Page.Empty with Id = PageId "posts"; Title = "- First Page of Posts -" } ] + let! themes = data.Theme.All() + let uploads = [ Database; Disk ] + return! + Views.WebLog.webLogSettings + (SettingsModel.FromWebLog ctx.WebLog) + themes + pages + uploads + (EditRssModel.FromRssOptions ctx.WebLog.Rss) + |> adminPage "Web Log Settings" next ctx + } // POST /admin/settings - let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> validateCsrf >=> fun next ctx -> task { - let data = ctx.Data - let! model = ctx.BindFormAsync() - match! data.WebLog.FindById ctx.WebLog.Id with - | Some webLog -> - let oldSlug = webLog.Slug - let webLog = model.Update webLog - do! data.WebLog.UpdateSettings webLog + let saveSettings : HttpHandler = + requireAccess WebLogAdmin + >=> validateCsrf + >=> fun next ctx -> task { + let data = ctx.Data + let! model = ctx.BindFormAsync() + match! data.WebLog.FindById ctx.WebLog.Id with + | Some webLog -> + let oldSlug = webLog.Slug + let webLog = model.Update webLog + do! data.WebLog.UpdateSettings webLog - // Update cache - WebLogCache.set webLog + // Update cache + WebLogCache.set webLog - if oldSlug <> webLog.Slug then - // Rename disk directory if it exists - let uploadRoot = Path.Combine("wwwroot", "upload") - let oldDir = Path.Combine(uploadRoot, oldSlug) - if Directory.Exists oldDir then Directory.Move(oldDir, Path.Combine(uploadRoot, webLog.Slug)) + if oldSlug <> webLog.Slug then + // Rename disk directory if it exists + let uploadRoot = Path.Combine("wwwroot", "upload") + let oldDir = Path.Combine(uploadRoot, oldSlug) + if Directory.Exists oldDir then Directory.Move(oldDir, Path.Combine(uploadRoot, webLog.Slug)) - do! addMessage ctx { UserMessage.Success with Message = "Web log settings saved successfully" } - return! redirectToGet "admin/settings" next ctx - | None -> return! Error.notFound next ctx - } + do! addMessage ctx { UserMessage.Success with Message = "Web log settings saved successfully" } + return! redirectToGet "admin/settings" next ctx + | None -> return! Error.notFound next ctx + } diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs index 6c6365b..aa08e52 100644 --- a/src/MyWebLog/Handlers/Feed.fs +++ b/src/MyWebLog/Handlers/Feed.fs @@ -416,87 +416,97 @@ let generate (feedType: FeedType) postCount : HttpHandler = fun next ctx -> back // ~~ FEED ADMINISTRATION ~~ // POST /admin/settings/rss -let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> validateCsrf >=> fun next ctx -> task { - let data = ctx.Data - let! model = ctx.BindFormAsync() - match! data.WebLog.FindById ctx.WebLog.Id with - | Some webLog -> - let webLog = { webLog with Rss = model.UpdateOptions webLog.Rss } - do! data.WebLog.UpdateRssOptions webLog - WebLogCache.set webLog - do! addMessage ctx { UserMessage.Success with Message = "RSS settings updated successfully" } - return! redirectToGet "admin/settings#rss-settings" next ctx - | None -> return! Error.notFound next ctx -} +let saveSettings : HttpHandler = + requireAccess WebLogAdmin + >=> validateCsrf + >=> fun next ctx -> task { + let data = ctx.Data + let! model = ctx.BindFormAsync() + match! data.WebLog.FindById ctx.WebLog.Id with + | Some webLog -> + let webLog = { webLog with Rss = model.UpdateOptions webLog.Rss } + do! data.WebLog.UpdateRssOptions webLog + WebLogCache.set webLog + do! addMessage ctx { UserMessage.Success with Message = "RSS settings updated successfully" } + return! redirectToGet "admin/settings#rss-settings" next ctx + | None -> return! Error.notFound next ctx + } // GET /admin/settings/rss/{id}/edit -let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> - let customFeed = - match feedId with - | "new" -> Some { CustomFeed.Empty with Id = CustomFeedId "new" } - | _ -> ctx.WebLog.Rss.CustomFeeds |> List.tryFind (fun f -> f.Id = CustomFeedId feedId) - match customFeed with - | Some f -> - let ratings = [ - { Name = string Yes; Value = "Yes" } - { Name = string No; Value = "No" } - { Name = string Clean; Value = "Clean" } - ] - let mediums = [ - { Name = ""; Value = "– Unspecified –" } - { Name = string Podcast; Value = "Podcast" } - { Name = string Music; Value = "Music" } - { Name = string Video; Value = "Video" } - { Name = string Film; Value = "Film" } - { Name = string Audiobook; Value = "Audiobook" } - { Name = string Newsletter; Value = "Newsletter" } - { Name = string Blog; Value = "Blog" } - ] - Views.WebLog.feedEdit (EditCustomFeedModel.FromFeed f) ratings mediums - |> adminPage $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed""" next ctx - | None -> Error.notFound next ctx +let editCustomFeed feedId : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> + let customFeed = + match feedId with + | "new" -> Some { CustomFeed.Empty with Id = CustomFeedId "new" } + | _ -> ctx.WebLog.Rss.CustomFeeds |> List.tryFind (fun f -> f.Id = CustomFeedId feedId) + match customFeed with + | Some f -> + let ratings = [ + { Name = string Yes; Value = "Yes" } + { Name = string No; Value = "No" } + { Name = string Clean; Value = "Clean" } + ] + let mediums = [ + { Name = ""; Value = "– Unspecified –" } + { Name = string Podcast; Value = "Podcast" } + { Name = string Music; Value = "Music" } + { Name = string Video; Value = "Video" } + { Name = string Film; Value = "Film" } + { Name = string Audiobook; Value = "Audiobook" } + { Name = string Newsletter; Value = "Newsletter" } + { Name = string Blog; Value = "Blog" } + ] + Views.WebLog.feedEdit (EditCustomFeedModel.FromFeed f) ratings mediums + |> adminPage $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed""" next ctx + | None -> Error.notFound next ctx // POST /admin/settings/rss/save -let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> validateCsrf >=> fun next ctx -> task { - let data = ctx.Data - match! data.WebLog.FindById ctx.WebLog.Id with - | Some webLog -> - let! model = ctx.BindFormAsync() - let theFeed = - match model.Id with - | "new" -> Some { CustomFeed.Empty with Id = CustomFeedId.Create() } - | _ -> webLog.Rss.CustomFeeds |> List.tryFind (fun it -> string it.Id = model.Id) - match theFeed with - | Some feed -> - let feeds = model.UpdateFeed feed :: (webLog.Rss.CustomFeeds |> List.filter (fun it -> it.Id <> feed.Id)) - let webLog = { webLog with Rss.CustomFeeds = feeds } - do! data.WebLog.UpdateRssOptions webLog - WebLogCache.set webLog - do! addMessage ctx - { UserMessage.Success with - Message = $"""Successfully {if model.Id = "new" then "add" else "sav"}ed custom feed""" } - return! redirectToGet $"admin/settings/rss/{feed.Id}/edit" next ctx +let saveCustomFeed : HttpHandler = + requireAccess WebLogAdmin + >=> validateCsrf + >=> fun next ctx -> task { + let data = ctx.Data + match! data.WebLog.FindById ctx.WebLog.Id with + | Some webLog -> + let! model = ctx.BindFormAsync() + let theFeed = + match model.Id with + | "new" -> Some { CustomFeed.Empty with Id = CustomFeedId.Create() } + | _ -> webLog.Rss.CustomFeeds |> List.tryFind (fun it -> string it.Id = model.Id) + match theFeed with + | Some feed -> + let feeds = model.UpdateFeed feed :: (webLog.Rss.CustomFeeds |> List.filter (fun f -> f.Id <> feed.Id)) + let webLog = { webLog with Rss.CustomFeeds = feeds } + do! data.WebLog.UpdateRssOptions webLog + WebLogCache.set webLog + do! addMessage ctx + { UserMessage.Success with + Message = $"""Successfully {if model.Id = "new" then "add" else "sav"}ed custom feed""" } + return! redirectToGet $"admin/settings/rss/{feed.Id}/edit" next ctx + | None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx - | None -> return! Error.notFound next ctx -} + } // DELETE /admin/settings/rss/{id} -let deleteCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { - let data = ctx.Data - match! data.WebLog.FindById ctx.WebLog.Id with - | Some webLog -> - let customId = CustomFeedId feedId - if webLog.Rss.CustomFeeds |> List.exists (fun f -> f.Id = customId) then - let webLog = - { webLog with - Rss = - { webLog.Rss with - CustomFeeds = webLog.Rss.CustomFeeds |> List.filter (fun f -> f.Id <> customId) } } - do! data.WebLog.UpdateRssOptions webLog - WebLogCache.set webLog - do! addMessage ctx { UserMessage.Success with Message = "Custom feed deleted successfully" } - else - do! addMessage ctx { UserMessage.Warning with Message = "Custom feed not found; no action taken" } - return! redirectToGet "admin/settings#rss-settings" next ctx - | None -> return! Error.notFound next ctx -} +let deleteCustomFeed feedId : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + let data = ctx.Data + match! data.WebLog.FindById ctx.WebLog.Id with + | Some webLog -> + let customId = CustomFeedId feedId + if webLog.Rss.CustomFeeds |> List.exists (fun f -> f.Id = customId) then + let webLog = + { webLog with + Rss = + { webLog.Rss with + CustomFeeds = webLog.Rss.CustomFeeds |> List.filter (fun f -> f.Id <> customId) } } + do! data.WebLog.UpdateRssOptions webLog + WebLogCache.set webLog + do! addMessage ctx { UserMessage.Success with Message = "Custom feed deleted successfully" } + else + do! addMessage ctx { UserMessage.Warning with Message = "Custom feed not found; no action taken" } + return! redirectToGet "admin/settings#rss-settings" next ctx + | None -> return! Error.notFound next ctx + } diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs index fa95a1d..39c8794 100644 --- a/src/MyWebLog/Handlers/Page.fs +++ b/src/MyWebLog/Handlers/Page.fs @@ -7,98 +7,113 @@ open MyWebLog.ViewModels // GET /admin/pages // 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 - let displayPages = - pages - |> Seq.ofList - |> Seq.truncate 25 - |> Seq.map (DisplayPage.FromPageMinimal ctx.WebLog) - |> List.ofSeq - return! - Views.Page.pageList displayPages pageNbr (pages.Length > 25) - |> adminPage "Pages" next ctx -} +let all pageNbr : HttpHandler = + requireAccess Author + >=> fun next ctx -> task { + let! pages = ctx.Data.Page.FindPageOfPages ctx.WebLog.Id pageNbr + let displayPages = + pages + |> Seq.ofList + |> Seq.truncate 25 + |> Seq.map (DisplayPage.FromPageMinimal ctx.WebLog) + |> List.ofSeq + return! + Views.Page.pageList displayPages pageNbr (pages.Length > 25) + |> adminPage "Pages" next ctx + } // GET /admin/page/{id}/edit -let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task { - let! result = task { - match pgId with - | "new" -> return Some ("Add a New Page", { Page.Empty with Id = PageId "new"; AuthorId = ctx.UserId }) - | _ -> - match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with - | Some page -> return Some ("Edit Page", page) - | None -> return None +let edit pgId : HttpHandler = + requireAccess Author + >=> fun next ctx -> task { + let! result = task { + match pgId with + | "new" -> return Some ("Add a New Page", { Page.Empty with Id = PageId "new"; AuthorId = ctx.UserId }) + | _ -> + match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with + | Some page -> return Some ("Edit Page", page) + | None -> return None + } + match result with + | Some (title, page) when canEdit page.AuthorId ctx -> + let model = EditPageModel.FromPage page + let! templates = templatesForTheme ctx "page" + return! adminPage title next ctx (Views.Page.pageEdit model templates) + | Some _ -> return! Error.notAuthorized next ctx + | None -> return! Error.notFound next ctx } - match result with - | Some (title, page) when canEdit page.AuthorId ctx -> - let model = EditPageModel.FromPage page - let! templates = templatesForTheme ctx "page" - return! adminPage title next ctx (Views.Page.pageEdit model templates) - | Some _ -> return! Error.notAuthorized next ctx - | None -> return! Error.notFound next ctx -} // DELETE /admin/page/{id} -let delete pgId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { - match! ctx.Data.Page.Delete (PageId pgId) ctx.WebLog.Id with - | true -> - do! PageListCache.update ctx - do! addMessage ctx { UserMessage.Success with Message = "Page deleted successfully" } - | false -> do! addMessage ctx { UserMessage.Error with Message = "Page not found; nothing deleted" } - return! all 1 next ctx -} +let delete pgId : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + match! ctx.Data.Page.Delete (PageId pgId) ctx.WebLog.Id with + | true -> + do! PageListCache.update ctx + do! addMessage ctx { UserMessage.Success with Message = "Page deleted successfully" } + | false -> do! addMessage ctx { UserMessage.Error with Message = "Page not found; nothing deleted" } + return! all 1 next ctx + } // GET /admin/page/{id}/permalinks -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! - ManagePermalinksModel.FromPage pg - |> Views.Helpers.managePermalinks - |> adminPage "Manage Prior Permalinks" next ctx - | Some _ -> return! Error.notAuthorized next ctx - | None -> return! Error.notFound next ctx -} +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! + ManagePermalinksModel.FromPage pg + |> Views.Helpers.managePermalinks + |> adminPage "Manage Prior Permalinks" next ctx + | Some _ -> return! Error.notAuthorized next ctx + | None -> return! Error.notFound next ctx + } // POST /admin/page/permalinks -let savePermalinks : HttpHandler = requireAccess Author >=> validateCsrf >=> fun next ctx -> task { - let! model = ctx.BindFormAsync() - let pageId = PageId model.Id - match! ctx.Data.Page.FindById pageId ctx.WebLog.Id with - | Some pg when canEdit pg.AuthorId ctx -> - let links = model.Prior |> Array.map Permalink |> List.ofArray - match! ctx.Data.Page.UpdatePriorPermalinks pageId ctx.WebLog.Id links with - | true -> - do! addMessage ctx { UserMessage.Success with Message = "Page permalinks saved successfully" } - return! redirectToGet $"admin/page/{model.Id}/permalinks" next ctx - | false -> return! Error.notFound next ctx - | Some _ -> return! Error.notAuthorized next ctx - | None -> return! Error.notFound next ctx -} +let savePermalinks : HttpHandler = + requireAccess Author + >=> validateCsrf + >=> fun next ctx -> task { + let! model = ctx.BindFormAsync() + let pageId = PageId model.Id + match! ctx.Data.Page.FindById pageId ctx.WebLog.Id with + | Some pg when canEdit pg.AuthorId ctx -> + let links = model.Prior |> Array.map Permalink |> List.ofArray + match! ctx.Data.Page.UpdatePriorPermalinks pageId ctx.WebLog.Id links with + | true -> + do! addMessage ctx { UserMessage.Success with Message = "Page permalinks saved successfully" } + return! redirectToGet $"admin/page/{model.Id}/permalinks" next ctx + | false -> return! Error.notFound next ctx + | Some _ -> return! Error.notAuthorized next ctx + | None -> return! Error.notFound next ctx + } // GET /admin/page/{id}/revisions -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! - ManageRevisionsModel.FromPage pg - |> Views.Helpers.manageRevisions - |> adminPage "Manage Page Revisions" next ctx - | Some _ -> return! Error.notAuthorized next ctx - | None -> return! Error.notFound next ctx -} +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! + ManageRevisionsModel.FromPage pg + |> Views.Helpers.manageRevisions + |> adminPage "Manage Page Revisions" next ctx + | Some _ -> return! Error.notAuthorized next ctx + | None -> return! Error.notFound next ctx + } // DELETE /admin/page/{id}/revisions -let purgeRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task { - let data = ctx.Data - match! data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with - | Some pg -> - do! data.Page.Update { pg with Revisions = [ List.head pg.Revisions ] } - do! addMessage ctx { UserMessage.Success with Message = "Prior revisions purged successfully" } - return! editRevisions pgId next ctx - | None -> return! Error.notFound next ctx -} +let purgeRevisions pgId : HttpHandler = + requireAccess Author + >=> fun next ctx -> task { + let data = ctx.Data + match! data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with + | Some pg -> + do! data.Page.Update { pg with Revisions = [ List.head pg.Revisions ] } + do! addMessage ctx { UserMessage.Success with Message = "Prior revisions purged successfully" } + return! editRevisions pgId next ctx + | None -> return! Error.notFound next ctx + } open Microsoft.AspNetCore.Http @@ -112,63 +127,73 @@ let private findPageRevision pgId revDate (ctx: HttpContext) = task { } // GET /admin/page/{id}/revision/{revision-date}/preview -let previewRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task { - match! findPageRevision pgId revDate ctx with - | Some pg, Some rev when canEdit pg.AuthorId ctx -> - return! adminBarePage "" next ctx (Views.Helpers.commonPreview rev) - | Some _, Some _ -> return! Error.notAuthorized next ctx - | None, _ | _, None -> return! Error.notFound next ctx -} +let previewRevision (pgId, revDate) : HttpHandler = + requireAccess Author + >=> fun next ctx -> task { + match! findPageRevision pgId revDate ctx with + | Some pg, Some rev when canEdit pg.AuthorId ctx -> + return! adminBarePage "" next ctx (Views.Helpers.commonPreview rev) + | Some _, Some _ -> return! Error.notAuthorized next ctx + | None, _ | _, None -> return! Error.notFound next ctx + } // POST /admin/page/{id}/revision/{revision-date}/restore -let restoreRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> validateCsrf >=> fun next ctx -> task { - match! findPageRevision pgId revDate ctx with - | Some pg, Some rev when canEdit pg.AuthorId ctx -> - do! ctx.Data.Page.Update - { pg with - Revisions = { rev with AsOf = Noda.now () } - :: (pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) } - do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" } - return! redirectToGet $"admin/page/{pgId}/revisions" next ctx - | Some _, Some _ -> return! Error.notAuthorized next ctx - | None, _ - | _, None -> return! Error.notFound next ctx -} +let restoreRevision (pgId, revDate) : HttpHandler = + requireAccess Author + >=> validateCsrf + >=> fun next ctx -> task { + match! findPageRevision pgId revDate ctx with + | Some pg, Some rev when canEdit pg.AuthorId ctx -> + do! ctx.Data.Page.Update + { pg with + Revisions = { rev with AsOf = Noda.now () } + :: (pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) } + do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" } + return! redirectToGet $"admin/page/{pgId}/revisions" next ctx + | Some _, Some _ -> return! Error.notAuthorized next ctx + | None, _ + | _, None -> return! Error.notFound next ctx + } // DELETE /admin/page/{id}/revision/{revision-date} -let deleteRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task { - match! findPageRevision pgId revDate ctx with - | Some pg, Some rev when canEdit pg.AuthorId ctx -> - do! ctx.Data.Page.Update { pg with Revisions = pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) } - do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" } - return! adminBarePage "" next ctx (fun _ -> []) - | Some _, Some _ -> return! Error.notAuthorized next ctx - | None, _ - | _, None -> return! Error.notFound next ctx -} +let deleteRevision (pgId, revDate) : HttpHandler = + requireAccess Author + >=> fun next ctx -> task { + match! findPageRevision pgId revDate ctx with + | Some pg, Some rev when canEdit pg.AuthorId ctx -> + do! ctx.Data.Page.Update { pg with Revisions = pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) } + do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" } + return! adminBarePage "" next ctx (fun _ -> []) + | Some _, Some _ -> return! Error.notAuthorized next ctx + | None, _ + | _, None -> return! Error.notFound next ctx + } // POST /admin/page/save -let save : HttpHandler = requireAccess Author >=> validateCsrf >=> fun next ctx -> task { - let! model = ctx.BindFormAsync() - let data = ctx.Data - let now = Noda.now () - let tryPage = - if model.IsNew then - { Page.Empty with - Id = PageId.Create() - WebLogId = ctx.WebLog.Id - AuthorId = ctx.UserId - PublishedOn = now - } |> someTask - else data.Page.FindFullById (PageId model.Id) ctx.WebLog.Id - match! tryPage with - | Some page when canEdit page.AuthorId ctx -> - let updateList = page.IsInPageList <> model.IsShownInPageList - let updatedPage = model.UpdatePage page now - do! (if model.IsNew then data.Page.Add else data.Page.Update) updatedPage - if updateList then do! PageListCache.update ctx - do! addMessage ctx { UserMessage.Success with Message = "Page saved successfully" } - return! redirectToGet $"admin/page/{page.Id}/edit" next ctx - | Some _ -> return! Error.notAuthorized next ctx - | None -> return! Error.notFound next ctx -} +let save : HttpHandler = + requireAccess Author + >=> validateCsrf + >=> fun next ctx -> task { + let! model = ctx.BindFormAsync() + let data = ctx.Data + let now = Noda.now () + let tryPage = + if model.IsNew then + { Page.Empty with + Id = PageId.Create() + WebLogId = ctx.WebLog.Id + AuthorId = ctx.UserId + PublishedOn = now + } |> someTask + else data.Page.FindFullById (PageId model.Id) ctx.WebLog.Id + match! tryPage with + | Some page when canEdit page.AuthorId ctx -> + let updateList = page.IsInPageList <> model.IsShownInPageList + let updatedPage = model.UpdatePage page now + do! (if model.IsNew then data.Page.Add else data.Page.Update) updatedPage + if updateList then do! PageListCache.update ctx + do! addMessage ctx { UserMessage.Success with Message = "Page saved successfully" } + return! redirectToGet $"admin/page/{page.Id}/edit" 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 8ac3908..bb6efba 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -97,6 +97,7 @@ let preparePostList webLog posts listType (url: string) pageNbr perPage (data: I open Giraffe // GET /page/{pageNbr}[/] +// (also served with pageNbr = 1 when default page is recent posts) let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task { if pageNbr <> 1 && ctx.Request.Path.Value.EndsWith "/" then return! redirectTo true (ctx.WebLog.RelativeUrl(Permalink $"page/{pageNbr}")) next ctx @@ -117,10 +118,6 @@ let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task { |> themedView "index" next ctx } -// GET /page/{pageNbr}/ -let redirectToPageOfPosts (pageNbr: int) : HttpHandler = fun next ctx -> - redirectTo true (ctx.WebLog.RelativeUrl(Permalink $"page/{pageNbr}")) next ctx - // GET /category/{slug}/ // GET /category/{slug}/page/{pageNbr} let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task { @@ -255,99 +252,114 @@ let chapters (post: Post) : HttpHandler = fun next ctx -> // GET /admin/posts // GET /admin/posts/page/{pageNbr} -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! viewCtx = preparePostList ctx.WebLog posts AdminList "" pageNbr 25 data - return! adminPage "Posts" next ctx (Post.list viewCtx.Posts) -} +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! viewCtx = preparePostList ctx.WebLog posts AdminList "" pageNbr 25 data + return! adminPage "Posts" next ctx (Post.list viewCtx.Posts) + } // GET /admin/post/{id}/edit -let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { - let data = ctx.Data - let! result = task { - match postId with - | "new" -> return Some ("Write a New Post", { Post.Empty with Id = PostId "new" }) - | _ -> - match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with - | Some post -> return Some ("Edit Post", post) - | None -> return None +let edit postId : HttpHandler = + requireAccess Author + >=> fun next ctx -> task { + let data = ctx.Data + let! result = task { + match postId with + | "new" -> return Some ("Write a New Post", { Post.Empty with Id = PostId "new" }) + | _ -> + match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with + | Some post -> return Some ("Edit Post", post) + | None -> return None + } + match result with + | Some (title, post) when canEdit post.AuthorId ctx -> + let! templates = templatesForTheme ctx "post" + let model = EditPostModel.FromPost ctx.WebLog post + let ratings = [ + { Name = ""; Value = "– Default –" } + { Name = string Yes; Value = "Yes" } + { Name = string No; Value = "No" } + { Name = string Clean; Value = "Clean" } + ] + return! adminPage title next ctx (Post.postEdit model templates ratings) + | Some _ -> return! Error.notAuthorized next ctx + | None -> return! Error.notFound next ctx } - match result with - | Some (title, post) when canEdit post.AuthorId ctx -> - let! templates = templatesForTheme ctx "post" - let model = EditPostModel.FromPost ctx.WebLog post - let ratings = [ - { Name = ""; Value = "– Default –" } - { Name = string Yes; Value = "Yes" } - { Name = string No; Value = "No" } - { Name = string Clean; Value = "Clean" } - ] - return! adminPage title next ctx (Post.postEdit model templates ratings) - | Some _ -> return! Error.notAuthorized next ctx - | None -> return! Error.notFound next ctx -} // DELETE /admin/post/{id} -let delete postId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { - match! ctx.Data.Post.Delete (PostId postId) ctx.WebLog.Id with - | true -> do! addMessage ctx { UserMessage.Success with Message = "Post deleted successfully" } - | false -> do! addMessage ctx { UserMessage.Error with Message = "Post not found; nothing deleted" } - //return! redirectToGet "admin/posts" next ctx - return! all 1 next ctx -} +let delete postId : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + match! ctx.Data.Post.Delete (PostId postId) ctx.WebLog.Id with + | true -> do! addMessage ctx { UserMessage.Success with Message = "Post deleted successfully" } + | false -> do! addMessage ctx { UserMessage.Error with Message = "Post not found; nothing deleted" } + //return! redirectToGet "admin/posts" next ctx + return! all 1 next ctx + } // GET /admin/post/{id}/permalinks -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! - ManagePermalinksModel.FromPost post - |> managePermalinks - |> adminPage "Manage Prior Permalinks" next ctx - | Some _ -> return! Error.notAuthorized next ctx - | None -> return! Error.notFound 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! + ManagePermalinksModel.FromPost post + |> managePermalinks + |> adminPage "Manage Prior Permalinks" next ctx + | Some _ -> return! Error.notAuthorized next ctx + | None -> return! Error.notFound next ctx + } // POST /admin/post/permalinks -let savePermalinks : HttpHandler = requireAccess Author >=> validateCsrf >=> fun next ctx -> task { - let! model = ctx.BindFormAsync() - let postId = PostId model.Id - match! ctx.Data.Post.FindById postId ctx.WebLog.Id with - | Some post when canEdit post.AuthorId ctx -> - let links = model.Prior |> Array.map Permalink |> List.ofArray - match! ctx.Data.Post.UpdatePriorPermalinks postId ctx.WebLog.Id links with - | true -> - do! addMessage ctx { UserMessage.Success with Message = "Post permalinks saved successfully" } - return! redirectToGet $"admin/post/{model.Id}/permalinks" next ctx - | false -> return! Error.notFound next ctx - | Some _ -> return! Error.notAuthorized next ctx - | None -> return! Error.notFound next ctx -} +let savePermalinks : HttpHandler = + requireAccess Author + >=> validateCsrf + >=> fun next ctx -> task { + let! model = ctx.BindFormAsync() + let postId = PostId model.Id + match! ctx.Data.Post.FindById postId ctx.WebLog.Id with + | Some post when canEdit post.AuthorId ctx -> + let links = model.Prior |> Array.map Permalink |> List.ofArray + match! ctx.Data.Post.UpdatePriorPermalinks postId ctx.WebLog.Id links with + | true -> + do! addMessage ctx { UserMessage.Success with Message = "Post permalinks saved successfully" } + return! redirectToGet $"admin/post/{model.Id}/permalinks" next ctx + | false -> return! Error.notFound next ctx + | Some _ -> return! Error.notAuthorized next ctx + | None -> return! Error.notFound next ctx + } // GET /admin/post/{id}/revisions -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! - ManageRevisionsModel.FromPost post - |> manageRevisions - |> adminPage "Manage Post Revisions" next ctx - | Some _ -> return! Error.notAuthorized next ctx - | None -> return! Error.notFound next ctx -} +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! + ManageRevisionsModel.FromPost post + |> manageRevisions + |> adminPage "Manage Post Revisions" next ctx + | Some _ -> return! Error.notAuthorized next ctx + | None -> return! Error.notFound next ctx + } // DELETE /admin/post/{id}/revisions -let purgeRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { - let data = ctx.Data - match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with - | Some post when canEdit post.AuthorId ctx -> - do! data.Post.Update { post with Revisions = [ List.head post.Revisions ] } - do! addMessage ctx { UserMessage.Success with Message = "Prior revisions purged successfully" } - return! editRevisions postId next ctx - | Some _ -> return! Error.notAuthorized next ctx - | None -> return! Error.notFound next ctx -} +let purgeRevisions postId : HttpHandler = + requireAccess Author + >=> fun next ctx -> task { + let data = ctx.Data + match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with + | Some post when canEdit post.AuthorId ctx -> + do! data.Post.Update { post with Revisions = [ List.head post.Revisions ] } + do! addMessage ctx { UserMessage.Success with Message = "Prior revisions purged successfully" } + return! editRevisions postId next ctx + | Some _ -> return! Error.notAuthorized next ctx + | None -> return! Error.notFound next ctx + } open Microsoft.AspNetCore.Http @@ -361,165 +373,184 @@ let private findPostRevision postId revDate (ctx: HttpContext) = task { } // GET /admin/post/{id}/revision/{revision-date}/preview -let previewRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task { - match! findPostRevision postId revDate ctx with - | Some post, Some rev when canEdit post.AuthorId ctx -> - return! adminBarePage "" next ctx (commonPreview rev) - | Some _, Some _ -> return! Error.notAuthorized next ctx - | None, _ | _, None -> return! Error.notFound next ctx -} +let previewRevision (postId, revDate) : HttpHandler = + requireAccess Author + >=> fun next ctx -> task { + match! findPostRevision postId revDate ctx with + | Some post, Some rev when canEdit post.AuthorId ctx -> + return! adminBarePage "" next ctx (commonPreview rev) + | Some _, Some _ -> return! Error.notAuthorized next ctx + | None, _ | _, None -> return! Error.notFound next ctx + } // POST /admin/post/{id}/revision/{revision-date}/restore -let restoreRevision (postId, revDate) : HttpHandler = requireAccess Author >=> validateCsrf >=> fun next ctx -> task { - match! findPostRevision postId revDate ctx with - | Some post, Some rev when canEdit post.AuthorId ctx -> - do! ctx.Data.Post.Update - { post with - Revisions = { rev with AsOf = Noda.now () } - :: (post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) } - do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" } - return! redirectToGet $"admin/post/{postId}/revisions" next ctx - | Some _, Some _ -> return! Error.notAuthorized next ctx - | None, _ - | _, None -> return! Error.notFound next ctx -} +let restoreRevision (postId, revDate) : HttpHandler = + requireAccess Author + >=> validateCsrf + >=> fun next ctx -> task { + match! findPostRevision postId revDate ctx with + | Some post, Some rev when canEdit post.AuthorId ctx -> + do! ctx.Data.Post.Update + { post with + Revisions = { rev with AsOf = Noda.now () } + :: (post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) } + do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" } + return! redirectToGet $"admin/post/{postId}/revisions" next ctx + | Some _, Some _ -> return! Error.notAuthorized next ctx + | None, _ + | _, None -> return! Error.notFound next ctx + } // DELETE /admin/post/{id}/revision/{revision-date} -let deleteRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task { - match! findPostRevision postId revDate ctx with - | Some post, Some rev when canEdit post.AuthorId ctx -> - do! ctx.Data.Post.Update { post with Revisions = post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) } - do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" } - return! adminBarePage "" next ctx (fun _ -> []) - | Some _, Some _ -> return! Error.notAuthorized next ctx - | None, _ - | _, None -> return! Error.notFound next ctx -} +let deleteRevision (postId, revDate) : HttpHandler = + requireAccess Author + >=> fun next ctx -> task { + match! findPostRevision postId revDate ctx with + | Some post, Some rev when canEdit post.AuthorId ctx -> + do! ctx.Data.Post.Update { post with Revisions = post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) } + do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" } + return! adminBarePage "" next ctx (fun _ -> []) + | Some _, Some _ -> return! Error.notAuthorized next ctx + | None, _ + | _, None -> return! Error.notFound next ctx + } // GET /admin/post/{id}/chapters -let manageChapters postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { - match! ctx.Data.Post.FindById (PostId postId) ctx.WebLog.Id with - | Some post - when Option.isSome post.Episode - && Option.isSome post.Episode.Value.Chapters - && canEdit post.AuthorId ctx -> - return! - Post.chapters false (ManageChaptersModel.Create post) - |> adminPage "Manage Chapters" next ctx - | Some _ | None -> return! Error.notFound next ctx -} +let manageChapters postId : HttpHandler = + requireAccess Author + >=> fun next ctx -> task { + match! ctx.Data.Post.FindById (PostId postId) ctx.WebLog.Id with + | Some post + when Option.isSome post.Episode + && Option.isSome post.Episode.Value.Chapters + && canEdit post.AuthorId ctx -> + return! + Post.chapters false (ManageChaptersModel.Create post) + |> adminPage "Manage Chapters" next ctx + | Some _ | None -> return! Error.notFound next ctx + } // GET /admin/post/{id}/chapter/{idx} -let editChapter (postId, index) : HttpHandler = requireAccess Author >=> fun next ctx -> task { - match! ctx.Data.Post.FindById (PostId postId) ctx.WebLog.Id with - | Some post - when Option.isSome post.Episode - && Option.isSome post.Episode.Value.Chapters - && canEdit post.AuthorId ctx -> - let chapter = - if index = -1 then Some Chapter.Empty - else - let chapters = post.Episode.Value.Chapters.Value - if index < List.length chapters then Some chapters[index] else None - match chapter with - | Some chap -> - return! - Post.chapterEdit (EditChapterModel.FromChapter post.Id index chap) - |> adminBarePage (if index = -1 then "Add a Chapter" else "Edit Chapter") next ctx - | None -> return! Error.notFound next ctx - | Some _ | None -> return! Error.notFound next ctx -} +let editChapter (postId, index) : HttpHandler = + requireAccess Author + >=> fun next ctx -> task { + match! ctx.Data.Post.FindById (PostId postId) ctx.WebLog.Id with + | Some post + when Option.isSome post.Episode + && Option.isSome post.Episode.Value.Chapters + && canEdit post.AuthorId ctx -> + let chapter = + if index = -1 then Some Chapter.Empty + else + let chapters = post.Episode.Value.Chapters.Value + if index < List.length chapters then Some chapters[index] else None + match chapter with + | Some chap -> + return! + Post.chapterEdit (EditChapterModel.FromChapter post.Id index chap) + |> adminBarePage (if index = -1 then "Add a Chapter" else "Edit Chapter") next ctx + | None -> return! Error.notFound next ctx + | Some _ | None -> return! Error.notFound next ctx + } // POST /admin/post/{id}/chapter/{idx} -let saveChapter (postId, index) : HttpHandler = requireAccess Author >=> validateCsrf >=> fun next ctx -> task { - let data = ctx.Data - match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with - | Some post - when Option.isSome post.Episode - && Option.isSome post.Episode.Value.Chapters - && canEdit post.AuthorId ctx -> - let! form = ctx.BindFormAsync() - let chapters = post.Episode.Value.Chapters.Value - if index >= -1 && index < List.length chapters then - try - let chapter = form.ToChapter() - let existing = if index = -1 then chapters else List.removeAt index chapters - let updatedPost = - { post with - Episode = Some - { post.Episode.Value with - Chapters = Some (chapter :: existing |> List.sortBy _.StartTime) } } - do! data.Post.Update updatedPost - do! addMessage ctx { UserMessage.Success with Message = "Chapter saved successfully" } - return! - Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost) - |> adminBarePage "Manage Chapters" next ctx - with - | ex -> return! Error.server ex.Message next ctx - else return! Error.notFound next ctx - | Some _ | None -> return! Error.notFound next ctx -} +let saveChapter (postId, index) : HttpHandler = + requireAccess Author + >=> validateCsrf + >=> fun next ctx -> task { + let data = ctx.Data + match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with + | Some post + when Option.isSome post.Episode + && Option.isSome post.Episode.Value.Chapters + && canEdit post.AuthorId ctx -> + let! form = ctx.BindFormAsync() + let chapters = post.Episode.Value.Chapters.Value + if index >= -1 && index < List.length chapters then + try + let chapter = form.ToChapter() + let existing = if index = -1 then chapters else List.removeAt index chapters + let updatedPost = + { post with + Episode = Some + { post.Episode.Value with + Chapters = Some (chapter :: existing |> List.sortBy _.StartTime) } } + do! data.Post.Update updatedPost + do! addMessage ctx { UserMessage.Success with Message = "Chapter saved successfully" } + return! + Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost) + |> adminBarePage "Manage Chapters" next ctx + with + | ex -> return! Error.server ex.Message next ctx + else return! Error.notFound next ctx + | Some _ | None -> return! Error.notFound next ctx + } // DELETE /admin/post/{id}/chapter/{idx} -let deleteChapter (postId, index) : HttpHandler = requireAccess Author >=> fun next ctx -> task { - let data = ctx.Data - match! data.Post.FindById (PostId postId) ctx.WebLog.Id with - | Some post - when Option.isSome post.Episode - && Option.isSome post.Episode.Value.Chapters - && canEdit post.AuthorId ctx -> - let chapters = post.Episode.Value.Chapters.Value - if index >= 0 && index < List.length chapters then - let updatedPost = - { post with - Episode = Some { post.Episode.Value with Chapters = Some (List.removeAt index chapters) } } - do! data.Post.Update updatedPost - do! addMessage ctx { UserMessage.Success with Message = "Chapter deleted successfully" } - return! - Post.chapterList false (ManageChaptersModel.Create updatedPost) - |> adminPage "Manage Chapters" next ctx - else return! Error.notFound next ctx - | Some _ | None -> return! Error.notFound next ctx -} +let deleteChapter (postId, index) : HttpHandler = + requireAccess Author + >=> fun next ctx -> task { + let data = ctx.Data + match! data.Post.FindById (PostId postId) ctx.WebLog.Id with + | Some post + when Option.isSome post.Episode + && Option.isSome post.Episode.Value.Chapters + && canEdit post.AuthorId ctx -> + let chapters = post.Episode.Value.Chapters.Value + if index >= 0 && index < List.length chapters then + let updatedPost = + { post with + Episode = Some { post.Episode.Value with Chapters = Some (List.removeAt index chapters) } } + do! data.Post.Update updatedPost + do! addMessage ctx { UserMessage.Success with Message = "Chapter deleted successfully" } + return! + Post.chapterList false (ManageChaptersModel.Create updatedPost) + |> adminPage "Manage Chapters" next ctx + else return! Error.notFound next ctx + | Some _ | None -> return! Error.notFound next ctx + } // POST /admin/post/save -let save : HttpHandler = requireAccess Author >=> validateCsrf >=> fun next ctx -> task { - let! model = ctx.BindFormAsync() - let data = ctx.Data - let tryPost = - if model.IsNew then - { Post.Empty with - Id = PostId.Create() - WebLogId = ctx.WebLog.Id - AuthorId = ctx.UserId } - |> someTask - else data.Post.FindFullById (PostId model.Id) ctx.WebLog.Id - match! tryPost with - | Some post when canEdit post.AuthorId ctx -> - let priorCats = post.CategoryIds - let updatedPost = - model.UpdatePost post (Noda.now ()) - |> function - | post -> - if model.SetPublished then - let dt = parseToUtc (model.PubOverride.Value.ToString "o") - if model.SetUpdated then - { post with - PublishedOn = Some dt - UpdatedOn = dt - Revisions = [ { (List.head post.Revisions) with AsOf = dt } ] } - else { post with PublishedOn = Some dt } - else post - do! (if model.IsNew then data.Post.Add else data.Post.Update) updatedPost - // If the post was published or its categories changed, refresh the category cache - if model.DoPublish - || not (priorCats - |> List.append updatedPost.CategoryIds - |> List.distinct - |> List.length = List.length priorCats) then - do! CategoryCache.update ctx - do! addMessage ctx { UserMessage.Success with Message = "Post saved successfully" } - return! redirectToGet $"admin/post/{post.Id}/edit" next ctx - | Some _ -> return! Error.notAuthorized next ctx - | None -> return! Error.notFound next ctx -} +let save : HttpHandler = + requireAccess Author + >=> validateCsrf + >=> fun next ctx -> task { + let! model = ctx.BindFormAsync() + let data = ctx.Data + let tryPost = + if model.IsNew then + { Post.Empty with + Id = PostId.Create() + WebLogId = ctx.WebLog.Id + AuthorId = ctx.UserId } + |> someTask + else data.Post.FindFullById (PostId model.Id) ctx.WebLog.Id + match! tryPost with + | Some post when canEdit post.AuthorId ctx -> + let priorCats = post.CategoryIds + let updatedPost = + model.UpdatePost post (Noda.now ()) + |> function + | post -> + if model.SetPublished then + let dt = parseToUtc (model.PubOverride.Value.ToString "o") + if model.SetUpdated then + { post with + PublishedOn = Some dt + UpdatedOn = dt + Revisions = [ { (List.head post.Revisions) with AsOf = dt } ] } + else { post with PublishedOn = Some dt } + else post + do! (if model.IsNew then data.Post.Add else data.Post.Update) updatedPost + // If the post was published or its categories changed, refresh the category cache + if model.DoPublish + || not (priorCats + |> List.append updatedPost.CategoryIds + |> List.distinct + |> List.length = List.length priorCats) then + do! CategoryCache.update ctx + do! addMessage ctx { UserMessage.Success with Message = "Post saved successfully" } + return! redirectToGet $"admin/post/{post.Id}/edit" next ctx + | Some _ -> return! Error.notAuthorized next ctx + | None -> return! Error.notFound next ctx + } diff --git a/src/MyWebLog/Handlers/Upload.fs b/src/MyWebLog/Handlers/Upload.fs index d5c39e6..6c4fc62 100644 --- a/src/MyWebLog/Handlers/Upload.fs +++ b/src/MyWebLog/Handlers/Upload.fs @@ -90,86 +90,95 @@ open MyWebLog.ViewModels let makeSlug it = (Regex """\s+""").Replace((Regex "[^A-z0-9 -]").Replace(it, ""), "-").ToLowerInvariant() // GET /admin/uploads -let list : HttpHandler = requireAccess Author >=> fun next ctx -> task { - let webLog = ctx.WebLog - let! dbUploads = ctx.Data.Upload.FindByWebLog webLog.Id - let diskUploads = - let path = Path.Combine(uploadDir, webLog.Slug) - try - Directory.EnumerateFiles(path, "*", SearchOption.AllDirectories) - |> Seq.map (fun file -> - let name = Path.GetFileName file - let create = - match File.GetCreationTime(Path.Combine(path, file)) with - | dt when dt > DateTime.UnixEpoch -> Some dt - | _ -> None - { DisplayUpload.Id = "" - Name = name - Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace(slash, '/') - UpdatedOn = create - Source = string Disk }) - with - | :? DirectoryNotFoundException -> [] // This is fine - | ex -> - warn "Upload" ctx $"Encountered {ex.GetType().Name} listing uploads for {path}:\n{ex.Message}" - [] - return! - dbUploads - |> Seq.ofList - |> Seq.map (DisplayUpload.FromUpload webLog Database) - |> Seq.append diskUploads - |> Seq.sortByDescending (fun file -> file.UpdatedOn, file.Path) - |> Views.WebLog.uploadList - |> adminPage "Uploaded Files" next ctx -} +let list : HttpHandler = + requireAccess Author + >=> fun next ctx -> task { + let webLog = ctx.WebLog + let! dbUploads = ctx.Data.Upload.FindByWebLog webLog.Id + let diskUploads = + let path = Path.Combine(uploadDir, webLog.Slug) + try + Directory.EnumerateFiles(path, "*", SearchOption.AllDirectories) + |> Seq.map (fun file -> + let name = Path.GetFileName file + let create = + match File.GetCreationTime(Path.Combine(path, file)) with + | dt when dt > DateTime.UnixEpoch -> Some dt + | _ -> None + { DisplayUpload.Id = "" + Name = name + Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace(slash, '/') + UpdatedOn = create + Source = string Disk }) + with + | :? DirectoryNotFoundException -> [] // This is fine + | ex -> + warn "Upload" ctx $"Encountered {ex.GetType().Name} listing uploads for {path}:\n{ex.Message}" + [] + return! + dbUploads + |> Seq.ofList + |> Seq.map (DisplayUpload.FromUpload webLog Database) + |> Seq.append diskUploads + |> Seq.sortByDescending (fun file -> file.UpdatedOn, file.Path) + |> Views.WebLog.uploadList + |> adminPage "Uploaded Files" next ctx + } // GET /admin/upload/new -let showNew : HttpHandler = requireAccess Author >=> fun next ctx -> - adminPage "Upload a File" next ctx Views.WebLog.uploadNew +let showNew : HttpHandler = + requireAccess Author + >=> fun next ctx -> adminPage "Upload a File" next ctx Views.WebLog.uploadNew // POST /admin/upload/save -let save : HttpHandler = requireAccess Author >=> validateCsrf >=> fun next ctx -> task { - if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then - let upload = Seq.head ctx.Request.Form.Files - let fileName = String.Concat (makeSlug (Path.GetFileNameWithoutExtension upload.FileName), - Path.GetExtension(upload.FileName).ToLowerInvariant()) - let now = Noda.now () - let localNow = ctx.WebLog.LocalTime now - let year = localNow.ToString "yyyy" - let month = localNow.ToString "MM" - let! form = ctx.BindFormAsync() +let save : HttpHandler = + requireAccess Author + >=> validateCsrf + >=> fun next ctx -> task { + if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then + let upload = Seq.head ctx.Request.Form.Files + let fileName = String.Concat (makeSlug (Path.GetFileNameWithoutExtension upload.FileName), + Path.GetExtension(upload.FileName).ToLowerInvariant()) + let now = Noda.now () + let localNow = ctx.WebLog.LocalTime now + let year = localNow.ToString "yyyy" + let month = localNow.ToString "MM" + let! form = ctx.BindFormAsync() - match UploadDestination.Parse form.Destination with - | Database -> - use stream = new MemoryStream() - do! upload.CopyToAsync stream - let file = - { Id = UploadId.Create() - WebLogId = ctx.WebLog.Id - Path = Permalink $"{year}/{month}/{fileName}" - UpdatedOn = now - Data = stream.ToArray() } - do! ctx.Data.Upload.Add file - | Disk -> - let fullPath = Path.Combine(uploadDir, ctx.WebLog.Slug, year, month) - let _ = Directory.CreateDirectory fullPath - use stream = new FileStream(Path.Combine(fullPath, fileName), FileMode.Create) - do! upload.CopyToAsync stream + match UploadDestination.Parse form.Destination with + | Database -> + use stream = new MemoryStream() + do! upload.CopyToAsync stream + let file = + { Id = UploadId.Create() + WebLogId = ctx.WebLog.Id + Path = Permalink $"{year}/{month}/{fileName}" + UpdatedOn = now + Data = stream.ToArray() } + do! ctx.Data.Upload.Add file + | Disk -> + let fullPath = Path.Combine(uploadDir, ctx.WebLog.Slug, year, month) + let _ = Directory.CreateDirectory fullPath + use stream = new FileStream(Path.Combine(fullPath, fileName), FileMode.Create) + do! upload.CopyToAsync stream - do! addMessage ctx { UserMessage.Success with Message = $"File uploaded to {form.Destination} successfully" } - return! redirectToGet "admin/uploads" next ctx - else - return! RequestErrors.BAD_REQUEST "Bad request; no file present" next ctx -} + do! addMessage + ctx { UserMessage.Success with Message = $"File uploaded to {form.Destination} successfully" } + return! redirectToGet "admin/uploads" next ctx + else + return! RequestErrors.BAD_REQUEST "Bad request; no file present" next ctx + } // DELETE /admin/upload/{id} -let deleteFromDb upId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { - match! ctx.Data.Upload.Delete (UploadId upId) ctx.WebLog.Id with - | Ok fileName -> - do! addMessage ctx { UserMessage.Success with Message = $"{fileName} deleted successfully" } - return! list next ctx - | Error _ -> return! Error.notFound next ctx -} +let deleteFromDb upId : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + match! ctx.Data.Upload.Delete (UploadId upId) ctx.WebLog.Id with + | Ok fileName -> + do! addMessage ctx { UserMessage.Success with Message = $"{fileName} deleted successfully" } + return! list next ctx + | Error _ -> return! Error.notFound next ctx + } /// Remove a directory tree if it is empty let removeEmptyDirectories (webLog: WebLog) (filePath: string) = @@ -183,13 +192,15 @@ let removeEmptyDirectories (webLog: WebLog) (filePath: string) = else finished <- true // DELETE /admin/upload/disk/{**path} -let deleteFromDisk urlParts : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { - let filePath = urlParts |> Seq.skip 1 |> Seq.head - let path = Path.Combine(uploadDir, ctx.WebLog.Slug, filePath) - if File.Exists path then - File.Delete path - removeEmptyDirectories ctx.WebLog filePath - do! addMessage ctx { UserMessage.Success with Message = $"{filePath} deleted successfully" } - return! list next ctx - else return! Error.notFound next ctx -} +let deleteFromDisk urlParts : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + let filePath = urlParts |> Seq.skip 1 |> Seq.head + let path = Path.Combine(uploadDir, ctx.WebLog.Slug, filePath) + if File.Exists path then + File.Delete path + removeEmptyDirectories ctx.WebLog filePath + do! addMessage ctx { UserMessage.Success with Message = $"{filePath} deleted successfully" } + return! list next ctx + else return! Error.notFound next ctx + } diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index 3a4026e..ebcc4f6 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -43,38 +43,40 @@ open Microsoft.AspNetCore.Authentication open Microsoft.AspNetCore.Authentication.Cookies // POST /user/log-on -let doLogOn : HttpHandler = validateCsrf >=> fun next ctx -> task { - let! model = ctx.BindFormAsync() - let data = ctx.Data - let! tryUser = data.WebLogUser.FindByEmail (model.EmailAddress.ToLowerInvariant()) ctx.WebLog.Id - match! verifyPassword tryUser model.Password ctx with - | Ok _ -> - let user = tryUser.Value - let claims = seq { - Claim(ClaimTypes.NameIdentifier, string user.Id) - Claim(ClaimTypes.Name, $"{user.FirstName} {user.LastName}") - Claim(ClaimTypes.GivenName, user.PreferredName) - Claim(ClaimTypes.Role, string user.AccessLevel) - } - let identity = ClaimsIdentity(claims, CookieAuthenticationDefaults.AuthenticationScheme) +let doLogOn : HttpHandler = + validateCsrf + >=> fun next ctx -> task { + let! model = ctx.BindFormAsync() + let data = ctx.Data + let! tryUser = data.WebLogUser.FindByEmail (model.EmailAddress.ToLowerInvariant()) ctx.WebLog.Id + match! verifyPassword tryUser model.Password ctx with + | Ok _ -> + let user = tryUser.Value + let claims = seq { + Claim(ClaimTypes.NameIdentifier, string user.Id) + Claim(ClaimTypes.Name, $"{user.FirstName} {user.LastName}") + Claim(ClaimTypes.GivenName, user.PreferredName) + Claim(ClaimTypes.Role, string user.AccessLevel) + } + let identity = ClaimsIdentity(claims, CookieAuthenticationDefaults.AuthenticationScheme) - do! ctx.SignInAsync(identity.AuthenticationType, ClaimsPrincipal identity, - AuthenticationProperties(IssuedUtc = DateTimeOffset.UtcNow)) - do! data.WebLogUser.SetLastSeen user.Id user.WebLogId - do! addMessage ctx - { UserMessage.Success with - Message = "Log on successful" - Detail = Some $"Welcome to {ctx.WebLog.Name}!" } - return! - match model.ReturnTo with - | Some url -> redirectTo false url next ctx // TODO: change to redirectToGet? - | None -> redirectToGet "admin/dashboard" next ctx - | Error msg -> - do! addMessage ctx { UserMessage.Error with Message = msg } - return! logOn model.ReturnTo next ctx -} + do! ctx.SignInAsync(identity.AuthenticationType, ClaimsPrincipal identity, + AuthenticationProperties(IssuedUtc = DateTimeOffset.UtcNow)) + do! data.WebLogUser.SetLastSeen user.Id user.WebLogId + do! addMessage ctx + { UserMessage.Success with + Message = "Log on successful" + Detail = Some $"Welcome to {ctx.WebLog.Name}!" } + return! + match model.ReturnTo with + | Some url -> redirectTo false url next ctx // TODO: change to redirectToGet? + | None -> redirectToGet "admin/dashboard" next ctx + | Error msg -> + do! addMessage ctx { UserMessage.Error with Message = msg } + return! logOn model.ReturnTo next ctx + } -// GET /user/log-off +// POST /user/log-off let logOff : HttpHandler = fun next ctx -> task { do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme do! addMessage ctx { UserMessage.Info with Message = "Log off successful" } @@ -89,118 +91,131 @@ open Giraffe.Htmx let private goAway : HttpHandler = RequestErrors.BAD_REQUEST "really?" // GET /admin/settings/users -let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { - let! users = ctx.Data.WebLogUser.FindByWebLog ctx.WebLog.Id - return! adminBarePage "User Administration" next ctx (Views.User.userList users) -} +let all : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + let! users = ctx.Data.WebLogUser.FindByWebLog ctx.WebLog.Id + return! adminBarePage "User Administration" next ctx (Views.User.userList users) + } /// Show the edit user page let private showEdit (model: EditUserModel) : HttpHandler = fun next ctx -> adminBarePage (if model.IsNew then "Add a New User" else "Edit User") next ctx (Views.User.edit model) // GET /admin/settings/user/{id}/edit -let edit usrId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { - let isNew = usrId = "new" - let userId = WebLogUserId usrId - let tryUser = - 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 (EditUserModel.FromUser user) next ctx - | None -> return! Error.notFound next ctx -} +let edit usrId : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + let isNew = usrId = "new" + let userId = WebLogUserId usrId + let tryUser = + 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 (EditUserModel.FromUser user) next ctx + | None -> return! Error.notFound next ctx + } // DELETE /admin/settings/user/{id} -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 {user.DisplayName} deleted successfully" } - return! all next ctx - | Error msg -> - do! addMessage ctx - { UserMessage.Error with - Message = $"User {user.DisplayName} was not deleted" - Detail = Some msg } - return! all next ctx - | None -> return! Error.notFound next ctx -} +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 {user.DisplayName} deleted successfully" } + return! all next ctx + | Error msg -> + do! addMessage ctx + { UserMessage.Error with + Message = $"User {user.DisplayName} was not deleted" + Detail = Some msg } + return! all next ctx + | None -> return! Error.notFound next ctx + } // GET /admin/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! - Views.User.myInfo (EditMyInfoModel.FromUser user) user - |> adminPage "Edit Your Information" next ctx - | None -> return! Error.notFound next ctx -} +let myInfo : HttpHandler = + requireAccess Author + >=> fun next ctx -> task { + match! ctx.Data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with + | Some user -> + return! + Views.User.myInfo (EditMyInfoModel.FromUser user) user + |> adminPage "Edit Your Information" next ctx + | None -> return! Error.notFound next ctx + } // POST /admin/my-info -let saveMyInfo : HttpHandler = requireAccess Author >=> validateCsrf >=> fun next ctx -> task { - let! model = ctx.BindFormAsync() - let data = ctx.Data - match! data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with - | Some user when model.NewPassword = model.NewPasswordConfirm -> - let pw = if model.NewPassword = "" then user.PasswordHash else createPasswordHash user model.NewPassword - let user = - { user with - FirstName = model.FirstName - LastName = model.LastName - PreferredName = model.PreferredName - PasswordHash = pw } - do! data.WebLogUser.Update user - let pwMsg = if model.NewPassword = "" then "" else " and updated your password" - do! addMessage ctx { UserMessage.Success with Message = $"Saved your information{pwMsg} successfully" } - return! redirectToGet "admin/my-info" next ctx - | Some user -> - do! addMessage ctx { UserMessage.Error with Message = "Passwords did not match; no updates made" } - return! - Views.User.myInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user - |> adminPage "Edit Your Information" next ctx - | None -> return! Error.notFound next ctx -} +let saveMyInfo : HttpHandler = + requireAccess Author + >=> validateCsrf + >=> fun next ctx -> task { + let! model = ctx.BindFormAsync() + let data = ctx.Data + match! data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with + | Some user when model.NewPassword = model.NewPasswordConfirm -> + let pw = if model.NewPassword = "" then user.PasswordHash else createPasswordHash user model.NewPassword + let user = + { user with + FirstName = model.FirstName + LastName = model.LastName + PreferredName = model.PreferredName + PasswordHash = pw } + do! data.WebLogUser.Update user + let pwMsg = if model.NewPassword = "" then "" else " and updated your password" + do! addMessage ctx { UserMessage.Success with Message = $"Saved your information{pwMsg} successfully" } + return! redirectToGet "admin/my-info" next ctx + | Some user -> + do! addMessage ctx { UserMessage.Error with Message = "Passwords did not match; no updates made" } + return! + Views.User.myInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user + |> adminPage "Edit Your Information" next ctx + | None -> return! Error.notFound next ctx + } // User save is not statically compilable; not sure why, but we'll revisit it at some point #nowarn "3511" // POST /admin/settings/user/save -let save : HttpHandler = requireAccess WebLogAdmin >=> validateCsrf >=> fun next ctx -> task { - let! model = ctx.BindFormAsync() - let data = ctx.Data - let tryUser = - if model.IsNew then - { WebLogUser.Empty with - Id = WebLogUserId.Create() - WebLogId = ctx.WebLog.Id - CreatedOn = Noda.now () } - |> someTask - else data.WebLogUser.FindById (WebLogUserId model.Id) ctx.WebLog.Id - match! tryUser with - | Some user when model.Password = model.PasswordConfirm -> - let updatedUser = model.UpdateUser user - if updatedUser.AccessLevel = Administrator && not (ctx.HasAccessLevel Administrator) then - return! goAway next ctx - else - let toUpdate = - if model.Password = "" then updatedUser - else { updatedUser with PasswordHash = createPasswordHash updatedUser model.Password } - do! (if model.IsNew then data.WebLogUser.Add else data.WebLogUser.Update) toUpdate - do! addMessage ctx - { UserMessage.Success with - Message = $"""{if model.IsNew then "Add" else "Updat"}ed user successfully""" } - return! all next ctx - | Some _ -> - do! addMessage ctx { UserMessage.Error with Message = "The passwords did not match; nothing saved" } - return! - (withHxRetarget $"#user_{model.Id}" >=> showEdit { model with Password = ""; PasswordConfirm = "" }) - next ctx - | None -> return! Error.notFound next ctx -} +let save : HttpHandler = + requireAccess WebLogAdmin + >=> validateCsrf + >=> fun next ctx -> task { + let! model = ctx.BindFormAsync() + let data = ctx.Data + let tryUser = + if model.IsNew then + { WebLogUser.Empty with + Id = WebLogUserId.Create() + WebLogId = ctx.WebLog.Id + CreatedOn = Noda.now () } + |> someTask + else data.WebLogUser.FindById (WebLogUserId model.Id) ctx.WebLog.Id + match! tryUser with + | Some user when model.Password = model.PasswordConfirm -> + let updatedUser = model.UpdateUser user + if updatedUser.AccessLevel = Administrator && not (ctx.HasAccessLevel Administrator) then + return! goAway next ctx + else + let toUpdate = + if model.Password = "" then updatedUser + else { updatedUser with PasswordHash = createPasswordHash updatedUser model.Password } + do! (if model.IsNew then data.WebLogUser.Add else data.WebLogUser.Update) toUpdate + do! addMessage ctx + { UserMessage.Success with + Message = $"""{if model.IsNew then "Add" else "Updat"}ed user successfully""" } + return! all next ctx + | Some _ -> + do! addMessage ctx { UserMessage.Error with Message = "The passwords did not match; nothing saved" } + return! + (withHxRetarget $"#user_{model.Id}" >=> showEdit { model with Password = ""; PasswordConfirm = "" }) + next ctx + | None -> return! Error.notFound next ctx + }