From e17e5b79f0a05f32dfae1a51264094ddfbef61fe Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 23 Aug 2026 15:26:18 -0400 Subject: [PATCH] Add person add/edit/delete in settings (#17) --- .../Postgres/PostgresPersonData.fs | 1 - src/MyWebLog.Domain/ViewModels.fs | 35 ++++++ src/MyWebLog.Tests/Data/PersonDataTests.fs | 1 - src/MyWebLog/Handlers/Admin.fs | 69 ++++++++++++ src/MyWebLog/Handlers/Helpers.fs | 4 - src/MyWebLog/Handlers/Post.fs | 6 +- src/MyWebLog/Handlers/Routes.fs | 8 +- src/MyWebLog/Maintenance.fs | 2 + src/MyWebLog/Views/Helpers.fs | 4 + src/MyWebLog/Views/WebLog.fs | 102 ++++++++++++++++++ 10 files changed, 222 insertions(+), 10 deletions(-) diff --git a/src/MyWebLog.Data/Postgres/PostgresPersonData.fs b/src/MyWebLog.Data/Postgres/PostgresPersonData.fs index 1e9fd90..83c1eea 100644 --- a/src/MyWebLog.Data/Postgres/PostgresPersonData.fs +++ b/src/MyWebLog.Data/Postgres/PostgresPersonData.fs @@ -5,7 +5,6 @@ open BitBadger.Documents.Postgres open Microsoft.Extensions.Logging open MyWebLog open MyWebLog.Data -open NodaTime open Npgsql.FSharp /// PostgreSQL myWebLog person data implementation diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 8f4ea05..0282e19 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -776,6 +776,41 @@ type EditPageModel() = | _ -> revision :: page.Revisions } +/// View model to edit a person +type EditPersonModel() = + + /// The ID of the person being edited + member val Id = "" with get, set + + /// The name of the person + member val Name = "" with get, set + + /// A URL for this person's profile + member val ProfileUrl = "" with get, set + + /// A URL to the image for this person + member val ImageUrl = "" with get, set + + /// Create an edit model from a person + /// The person for whom the edit model is created + static member FromPerson(person: Person) = + let model = EditPersonModel() + model.Id <- string person.Id + model.Name <- person.Name + model.ProfileUrl <- defaultArg person.Url "" + model.ImageUrl <- defaultArg person.ImageUrl "" + model + + /// Update a person with values from this model + /// The person to be updated + /// A person with their values updated + member this.UpdatePerson(person: Person) = + { person with + Name = this.Name + Url = noneIfBlank this.ProfileUrl + ImageUrl = noneIfBlank this.ImageUrl } + + /// View model to edit a post type EditPostModel() = inherit EditCommonModel() diff --git a/src/MyWebLog.Tests/Data/PersonDataTests.fs b/src/MyWebLog.Tests/Data/PersonDataTests.fs index ad8c37c..8ceb678 100644 --- a/src/MyWebLog.Tests/Data/PersonDataTests.fs +++ b/src/MyWebLog.Tests/Data/PersonDataTests.fs @@ -1,7 +1,6 @@ /// Integration tests for implementations module PersonDataTests -open System open Expecto open MyWebLog open MyWebLog.Data diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index b86dca5..45f9aa9 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -181,6 +181,75 @@ module Category = } +/// ~~~ PERSON ~~~ +module Person = + + // GET /admin/settings/people + let all : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + let! ppl = ctx.Data.Person.FindByWebLog ctx.WebLog.Id + return! adminBarePage "People" next ctx (Views.WebLog.personList ppl) + } + + // GET /admin/settings/person/[id]/edit + let edit psnId : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + let! result = task { + match psnId with + | "new" -> return Some ("Add a New Person", { Person.Empty with Id = PersonId "new" }) + | _ -> + match! ctx.Data.Person.FindById (PersonId psnId) ctx.WebLog.Id with + | Some it -> return Some ("Edit Person", it) + | None -> return None + } + match result with + | Some (title, psn) -> + return! Views.WebLog.personEdit (EditPersonModel.FromPerson psn) + |> adminBarePage title next ctx + | None -> return! Error.notFound next ctx + } + + // POST /admin/settings/person/save + let save : HttpHandler = + requireAccess WebLogAdmin + >=> validateCsrf + >=> fun next ctx -> task { + let data = ctx.Data + let! model = ctx.BindFormAsync() + let isNew = model.Id = "new" + let person = + if isNew then someTask { Person.Empty with Id = PersonId.Create(); WebLogId = ctx.WebLog.Id } + else data.Person.FindById (PersonId model.Id) ctx.WebLog.Id + match! person with + | Some psn -> + let updatedPsn = model.UpdatePerson psn + do! (if isNew then data.Person.Add else data.Person.Update) updatedPsn + do! CategoryCache.update ctx + do! addMessage ctx { UserMessage.Success with Message = "Person saved successfully" } + return! all next ctx + | None -> return! Error.notFound next ctx + } + + // DELETE /admin/settings/person/{id} + let delete personId : HttpHandler = + requireAccess WebLogAdmin + >=> fun next ctx -> task { + let data = ctx.Data + match! data.Person.FindById (PersonId personId) ctx.WebLog.Id with + | Some psn -> + match! data.Person.Delete psn.Id psn.WebLogId with + | true -> + do! addMessage ctx { UserMessage.Success with Message = $"Person {psn.Name} deleted successfully" } + return! all next ctx + | false -> + do! addMessage ctx { UserMessage.Error with Message = $"User {psn.Name} was not deleted" } + return! all next ctx + | None -> return! Error.notFound next ctx + } + + /// ~~~ REDIRECT RULES ~~~ module RedirectRules = diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index d4f3235..fcb7955 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -275,10 +275,6 @@ open System.Threading.Tasks /// Create a Task with a Some result for the given object let someTask<'T> (it: 'T) = Task.FromResult(Some it) -/// Create an absolute URL from a string that may already be an absolute URL -let absoluteUrl (url: string) (ctx: HttpContext) = - if url.StartsWith "http" then url else ctx.WebLog.AbsoluteUrl(Permalink url) - open MyWebLog.Data diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 866e916..196ca1b 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -222,8 +222,8 @@ let chapters (post: Post) : HttpHandler = fun next ctx -> let dic = Dictionary() dic["startTime"] <- Math.Round(it.StartTime.TotalSeconds, 2) it.Title |> Option.iter (fun ttl -> dic["title"] <- ttl) - it.ImageUrl |> Option.iter (fun img -> dic["img"] <- absoluteUrl img ctx) - it.Url |> Option.iter (fun url -> dic["url"] <- absoluteUrl url ctx) + it.ImageUrl |> Option.iter (fun img -> dic["img"] <- absoluteUrl img ctx.WebLog) + it.Url |> Option.iter (fun url -> dic["url"] <- absoluteUrl url ctx.WebLog) it.IsHidden |> Option.iter (fun toc -> dic["toc"] <- not toc) it.EndTime |> Option.iter (fun ent -> dic["endTime"] <- Math.Round(ent.TotalSeconds, 2)) it.Location |> Option.iter (fun loc -> @@ -237,7 +237,7 @@ let chapters (post: Post) : HttpHandler = fun next ctx -> let jsonFile = Dictionary() jsonFile["version"] <- "1.2.0" jsonFile["title"] <- post.Title - jsonFile["fileName"] <- absoluteUrl ep.Media ctx + jsonFile["fileName"] <- absoluteUrl ep.Media ctx.WebLog if defaultArg ep.ChapterWaypoints false then jsonFile["waypoints"] <- true jsonFile["chapters"] <- chapterData (setContentType JSON_CHAPTERS >=> json jsonFile) next ctx diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index acadacd..914b90c 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -165,6 +165,10 @@ let endpoints = [ route "" Admin.RedirectRules.all routef "/%i" Admin.RedirectRules.edit ] + subRoute "/pe" [ + route "ople" Admin.Person.all + routef "rson/%s/edit" Admin.Person.edit + ] subRoute "/tag-mapping" [ route "s" Admin.TagMapping.all routef "/%s/edit" Admin.TagMapping.edit @@ -202,7 +206,8 @@ let endpoints = [ routef "/%s/revision/%s/restore" Post.restoreRevision ] subRoute "/settings" [ - route "" Admin.WebLog.saveSettings + route "" Admin.WebLog.saveSettings + route "/person/save" Admin.Person.save subRoute "/rss" [ route "" Feed.saveSettings route "/save" Feed.saveCustomFeed @@ -235,6 +240,7 @@ let endpoints = [ routef "/%s/revisions" Post.purgeRevisions ] subRoute "/settings" [ + routef "/person/%s" Admin.Person.delete routef "/redirect-rules/%i" Admin.RedirectRules.delete routef "/rss/%s" Feed.deleteCustomFeed routef "/tag-mapping/%s" Admin.TagMapping.delete diff --git a/src/MyWebLog/Maintenance.fs b/src/MyWebLog/Maintenance.fs index 109dd2c..b2db3d2 100644 --- a/src/MyWebLog/Maintenance.fs +++ b/src/MyWebLog/Maintenance.fs @@ -321,6 +321,8 @@ module Backup = } let private doRestore archive newUrlBase isInteractive (data: IData) = task { + // COMPAT: v2.x archives do not have a People entry + let archive = if (box >> isNull) archive.People then { archive with People = [] } else archive let! restore = task { match! data.WebLog.FindById archive.WebLog.Id with | Some webLog when defaultArg newUrlBase webLog.UrlBase = webLog.UrlBase -> diff --git a/src/MyWebLog/Views/Helpers.fs b/src/MyWebLog/Views/Helpers.fs index da2f041..9e7de56 100644 --- a/src/MyWebLog/Views/Helpers.fs +++ b/src/MyWebLog/Views/Helpers.fs @@ -17,6 +17,10 @@ open NodaTime.Text let relUrl app = Permalink >> app.WebLog.RelativeUrl +/// Create an absolute URL from a string that may already be an absolute URL +let absoluteUrl (url: string) (webLog: WebLog) = + if url.StartsWith "http" then url else webLog.AbsoluteUrl(Permalink url) + /// Create a hidden input with the anti-Cross Site Request Forgery (CSRF) token /// The app view context for the current view /// A hidden input with the CSRF token value diff --git a/src/MyWebLog/Views/WebLog.fs b/src/MyWebLog/Views/WebLog.fs index e7a3110..fdb0ffe 100644 --- a/src/MyWebLog/Views/WebLog.fs +++ b/src/MyWebLog/Views/WebLog.fs @@ -399,6 +399,103 @@ let feedEdit (model: EditCustomFeedModel) (ratings: MetaItem list) (mediums: Met ] +/// Edit form for a person +let personEdit (model: EditPersonModel) (app: AppViewContext) = [ + h5 [ _class "my-3" ] [ txt app.PageTitle ] + form [ _hxPost (relUrl app "admin/settings/person/save"); _method "post"; _hxBoost; _class "container" + hxInherited (_hxTarget "#person_panel"); _hxSwap $"{HxSwap.OuterHtml} show:top showTarget:top" ] [ + antiCsrf app + input [ _type "hidden"; _name "Id"; _value model.Id ] + div [ _class "row mb-3" ] [ + div [ _class "col-12 col-sm-8 offset-sm-2 col-lg-4 offset-lg-0 mb-3" ] [ + textField [ _autofocus; _required ] (nameof model.Name) "Name" model.Name [] + ] + div [ _class "col-12 col-lg-4 mb-3" ] [ + textField [] (nameof model.ProfileUrl) "Profile URL" model.ProfileUrl [ + span [ _class "form-text fst-italic" ] [ + raw "relative URL will be served from this web log" + ] + ] + ] + div [ _class "col-12 col-lg-4 mb-3" ] [ + textField [] (nameof model.ImageUrl) "Image URL" model.ImageUrl [ + span [ _class "form-text fst-italic" ] [ + raw "relative URL will be served from this web log" + ] + ] + ] + ] + div [ _class "row mb-3" ] [ + div [ _class "col text-center" ] [ + saveButton; raw "   " + a [ _href (relUrl app "admin/settings/people"); _hxBoost; _class "btn btn-sm btn-secondary ms-3" ] [ + raw "Cancel" + ] + ] + ] + ] +] + + +/// A list of people for this web log +let personList (ppl: Person list) app = + let personDetail (psn: Person) = + let url = relUrl app $"admin/settings/person/{psn.Id}" + div [ _class "row mwl-table-detail"; _id $"person_{psn.Id}" ] [ + div [ _class "col-12 col-md-4 no-wrap" ] [ + txt psn.Name; br [] + small [] [ + a [ _href $"{url}/edit"; _hxBoost; _hxTarget $"#person_{psn.Id}" + _hxSwap $"{HxSwap.InnerHtml} show:top showTarget:#person_{psn.Id}" ] [ + raw "Edit" + ]; actionSpacer + a [ _href url; _hxDelete url; _hxPushUrl "false"; _class "text-danger" + _hxConfirm $"Are you sure you want to delete the person “{psn.Name}”? This action cannot be undone." ] [ + raw "Delete" + ] + ] + ] + div [ _class "col-12 col-md-8" ] [ + if psn.Url.IsSome then + a [ _href (absoluteUrl psn.Url.Value app.WebLog); _target "_blank" ] [ txt psn.Url.Value ] + else + raw "N/A" + if psn.ImageUrl.IsSome then + br [] + small [ _class "text-muted" ] [ + raw "Image: " + a [ _href (absoluteUrl psn.ImageUrl.Value app.WebLog); _target "_blank" ] [ + txt psn.ImageUrl.Value + ] + ] + ] + ] + div [ _id "person_panel" ] [ + a [ _href (relUrl app "admin/settings/person/new/edit"); _hxBoost; _hxTarget "#person_new" + _class "btn btn-primary btn-sm mb-3" ] [ + raw "Add a New Person" + ] + if List.isEmpty ppl then + div [ _id "person_new" ] [ + p [ _class "text-muted text-center fst-italic" ] [ raw "This web log has no people defined" ] + ] + else + div [ _class "container g-0" ] [ + div [ _class "row mwl-table-heading" ] [ + div [ _class "col-12 col-md-4" ] [ raw "Name" ] + div [ _class "col-12 col-md-8" ] [ raw "URLs" ] + ] + ] + div [ _id "personList" ] [ + div [ _class "row mwl-table-detail"; _id "person_new" ] [] + List.map personDetail ppl + |> div [ _class "container g-0"; hxInherited (_hxTarget "#person_panel") + hxInherited (_hxSwap $"{HxSwap.OuterHtml} show:top showTarget:body") ] + ] + ] + |> List.singleton + + /// Redirect Rule edit form let redirectEdit (model: EditRedirectRuleModel) app = [ let url = relUrl app $"admin/settings/redirect-rules/{model.RuleId}" @@ -822,6 +919,11 @@ let webLogSettings span [ _hxGet (relUrl app "admin/settings/users"); _hxTarget "this"; _hxTrigger HxTrigger.Load _hxSwap HxSwap.OuterHtml ] [] ] + fieldset [ _id "people"; _class "container mb-3 pb-0" ] [ + legend [] [ raw "People" ] + span [ _hxGet (relUrl app "admin/settings/people"); _hxTarget "this"; _hxTrigger HxTrigger.Load + _hxSwap HxSwap.OuterHtml ] [] + ] fieldset [ _id "rss-settings"; _class "container mb-3 pb-0" ] [ legend [] [ raw "RSS Settings" ] form [ _action (relUrl app "admin/settings/rss"); _method "post"; _hxBoost; _class "container g-0" ] [