bit-badger/myWebLog
1
0
Fork 0
Code Issues 6 Pull Requests Packages Projects Releases 11 Activity

WIP on htmx 4 integration (#60)

Browse Source
This commit is contained in:
Daniel J. Summers
2026-07-11 21:33:07 -04:00
parent 32372a3f9f
commit d31b508359
7 changed files with 72 additions and 68 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/MyWebLog/Handlers/Helpers.fs
+17 -9
View File
@@ -107,7 +107,7 @@ let isHtmx (ctx: HttpContext) =
ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh
/// Convert messages to headers (used for htmx responses)
let messagesToHeaders (messages: UserMessage array) : HttpHandler =
let messagesToHeaders (messages: UserMessage array) pushUrl : HttpHandler =
seq {
yield!
messages
@@ -116,7 +116,10 @@ let messagesToHeaders (messages: UserMessage array) : HttpHandler =
| Some detail -> $"{m.Level}|||{m.Message}|||{detail}"
| None -> $"{m.Level}|||{m.Message}"
|> setHttpHeader "X-Message")
withHxNoPushUrl
match pushUrl with
| Some true -> withHxPushUrl "true"
| Some false -> withHxNoPushUrl
| None -> ()
}
|> Seq.reduce (>=>)
@@ -155,7 +158,7 @@ module Error =
{ UserMessage.Error with
Message = $"You are not authorized to access the URL {ctx.Request.Path.Value}" }
|]
(messagesToHeaders messages >=> setStatusCode 401) earlyReturn ctx
(messagesToHeaders messages (Some false) >=> setStatusCode 401) earlyReturn ctx
else setStatusCode 401 earlyReturn ctx
/// Handle 404s
@@ -165,14 +168,14 @@ module Error =
let messages = [|
{ UserMessage.Error with Message = $"The URL {ctx.Request.Path.Value} was not found" }
|]
RequestErrors.notFound (messagesToHeaders messages) earlyReturn ctx
RequestErrors.notFound (messagesToHeaders messages (Some false)) earlyReturn ctx
else RequestErrors.NOT_FOUND "Not found" earlyReturn ctx)
let server message : HttpHandler =
handleContext (fun ctx ->
if isHtmx ctx then
let messages = [| { UserMessage.Error with Message = message } |]
ServerErrors.internalError (messagesToHeaders messages) earlyReturn ctx
ServerErrors.internalError (messagesToHeaders messages (Some false)) earlyReturn ctx
else ServerErrors.INTERNAL_ERROR message earlyReturn ctx)
@@ -212,8 +215,8 @@ let bareForTheme themeId template next ctx viewCtx = task {
match! Template.Cache.get themeId "layout-bare" ctx.Data with
| Ok layoutTemplate ->
return!
(messagesToHeaders completeCtx.Messages >=> htmlString (Template.render layoutTemplate completeCtx ctx.Data))
next ctx
(messagesToHeaders completeCtx.Messages (Some false)
>=> htmlString (Template.render layoutTemplate completeCtx ctx.Data)) next ctx
| Error message -> return! Error.server message next ctx
| Error message -> return! Error.server message next ctx
}
@@ -228,7 +231,12 @@ let adminPage pageTitle next ctx (content: AppViewContext -> XmlNode list) = tas
let! messages = getCurrentMessages ctx
let appCtx = generateViewContext messages (viewCtxForPage pageTitle) ctx
let layout = if isHtmx ctx then Layout.partial else Layout.full
return! htmlString (layout content appCtx |> RenderView.AsString.htmlDocument) next ctx
let returnFunc html =
if isHtmx ctx && messages.Length > 0 then
messagesToHeaders messages None >=> htmlString html
else
htmlString html
return! (layout content appCtx |> RenderView.AsString.htmlDocument |> returnFunc) next ctx
}
/// Display a bare page for an admin endpoint
@@ -236,7 +244,7 @@ let adminBarePage pageTitle next ctx (content: AppViewContext -> XmlNode list) =
let! messages = getCurrentMessages ctx
let appCtx = generateViewContext messages (viewCtxForPage pageTitle) ctx
return!
( messagesToHeaders appCtx.Messages
( messagesToHeaders appCtx.Messages (Some false)
>=> htmlString (Layout.bare content appCtx |> RenderView.AsString.htmlDocument)) next ctx
}
src/MyWebLog/Views/Admin.fs
+10 -8
View File
@@ -45,7 +45,8 @@ let dashboard (themes: Theme list) app = [
article [] [
fieldset [ _class "container mb-3 pb-0" ] [
legend [] [ raw "Themes" ]
span [ _hxGet (relUrl app "admin/theme/list"); _hxTrigger HxTrigger.Load; _hxSwap HxSwap.OuterHtml ] []
span [ _hxGet (relUrl app "admin/theme/list"); _hxTrigger HxTrigger.Load; _hxSwap HxSwap.OuterHtml
_hxTarget "this" ] []
]
fieldset [ _class "container mb-3 pb-0" ] [
legend [] [ raw "Caches" ]
@@ -65,8 +66,8 @@ let dashboard (themes: Theme list) app = [
raw "These caches include the page list and categories for each web log"
]
let webLogUrl = $"{cacheBaseUrl}web-log/"
form [ _method "post"; _class "container g-0"; _hxNoBoost; _hxTarget "body"
_hxSwap $"{HxSwap.InnerHtml} show:window:top" ] [
form [ _method "post"; _class "container g-0"; hxInherited (_hxTarget "body")
hxInherited (_hxSwap $"{HxSwap.InnerHtml} show:top showTarget:window") ] [
antiCsrf app
button [ _type "submit"; _class "btn btn-sm btn-primary mb-2"
_hxPost $"{webLogUrl}all/refresh" ] [
@@ -86,8 +87,8 @@ let dashboard (themes: Theme list) app = [
raw "The theme template cache is filled on demand as pages are displayed; "
raw "refreshing a theme with no cached templates will still refresh its asset cache"
]
form [ _method "post"; _class "container g-0"; _hxNoBoost; _hxTarget "body"
_hxSwap $"{HxSwap.InnerHtml} show:window:top" ] [
form [ _method "post"; _class "container g-0"
hxInherited (_hxSwap $"{HxSwap.InnerHtml} show:top showTarget:window") ] [
antiCsrf app
button [ _type "submit"; _class "btn btn-sm btn-primary mb-2"
_hxPost $"{themeCacheUrl}all/refresh" ] [
@@ -111,8 +112,9 @@ let themeList (model: DisplayTheme list) app =
let themeCol = "col-12 col-md-6"
let slugCol = "d-none d-md-block col-md-3"
let tmplCol = "d-none d-md-block col-md-3"
let newUrl = relUrl app "admin/theme/new"
div [ _id "theme_panel" ] [
a [ _href (relUrl app "admin/theme/new"); _class "btn btn-primary btn-sm mb-3"; _hxTarget "#theme_new" ] [
a [ _href newUrl; _hxGet newUrl; _class "btn btn-primary btn-sm mb-3"; _hxTarget "#theme_new" ] [
raw "Upload a New Theme"
]
div [ _class "container g-0" ] [
@@ -124,7 +126,7 @@ let themeList (model: DisplayTheme list) app =
]
div [ _class "row mwl-table-detail"; _id "theme_new" ] []
form [ _method "post"; _id "themeList"; _class "container g-0"; _hxTarget "#theme_panel"
_hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [
_hxSwap $"{HxSwap.OuterHtml} show:top showTarget:window" ] [
antiCsrf app
for theme in model do
let url = relUrl app $"admin/theme/{theme.Id}"
@@ -161,7 +163,7 @@ let themeUpload app =
div [ _class "col" ] [
h5 [ _class "mt-2" ] [ raw app.PageTitle ]
form [ _action (relUrl app "admin/theme/new"); _method "post"; _class "container"
_enctype "multipart/form-data"; _hxNoBoost ] [
_enctype "multipart/form-data" ] [
antiCsrf app
div [ _class "row " ] [
div [ _class "col-12 col-sm-6 pb-3" ] [
src/MyWebLog/Views/Helpers.fs
+10 -12
View File
@@ -203,18 +203,18 @@ module Layout =
/// Create a navigation link
let private navLink app name url =
let extraPath = app.WebLog.ExtraPath
let path = if extraPath = "" then "" else $"{extraPath[1..]}/"
let active = if app.CurrentPage.StartsWith $"{path}{url}" then " active" else ""
li [ _class "nav-item" ] [
a [ _class $"nav-link{active}"; _href (relUrl app url) ] [ txt name ]
]
let path = if extraPath = "" then "" else $"{extraPath[1..]}/"
let active = if app.CurrentPage.StartsWith $"{path}{url}" then " active" else ""
let linkUrl = relUrl app url
li [ _class "nav-item" ] [ a [ _class $"nav-link{active}"; _href linkUrl; _hxBoost ] [ txt name ] ]
/// Create a page view for the given content
let private pageView (content: AppViewContext -> XmlNode list) app = [
header [] [
nav [ _class "navbar navbar-dark bg-dark navbar-expand-md justify-content-start px-2 position-fixed top-0 w-100" ] [
nav [ _class "navbar navbar-dark bg-dark navbar-expand-md justify-content-start px-2 position-fixed top-0 w-100"
hxInherited (_hxTarget "body") ] [
div [ _class "container-fluid" ] [
a [ _class "navbar-brand"; _href (relUrl app ""); _hxNoBoost ] [ txt app.WebLog.Name ]
a [ _class "navbar-brand"; _href (relUrl app "") ] [ txt app.WebLog.Name ]
button [ _type "button"; _class "navbar-toggler"; _data "bs-toggle" "collapse"
_data "bs-target" "#navbarText"; _ariaControls "navbarText"; _ariaExpanded "false"
_ariaLabel "Toggle navigation" ] [
@@ -244,9 +244,7 @@ module Layout =
]
if app.IsLoggedOn then
li [ _class "nav-item" ] [
a [ _class "nav-link"; _hxPost (relUrl app "user/log-off"); _hxNoBoost ] [
raw "Log Off"
]
a [ _class "nav-link"; _hxPost (relUrl app "user/log-off") ] [ raw "Log Off" ]
]
else
navLink app "Log On" "user/log-on"
@@ -313,7 +311,7 @@ module Layout =
_integrity "sha384-1BmE4kWBq78iYhFldvKuhfTAU6auU8tT94WrHftjDbrCEXSU1oBoqyl2QvZ6jIW3"
_crossorigin "anonymous" ]
link [ _rel "stylesheet"; _href (relUrl app "themes/admin/admin.css") ]
body [ _hxBoost; _hxIndicator "#loadOverlay" ] [
body [ hxInherited (_hxIndicator "#loadOverlay"); hxInherited (_hxTarget "body") ] [
yield! pageView content app
script [ _src "https://cdn.jsdelivr.net/npm/bootstrap@5.1.3/dist/js/bootstrap.bundle.min.js"
_integrity "sha384-ka7Sk0Gln4gmtz2MlQnikT1wXgYsOg+OMhuP+IlRH9sENBO0LRn5q+8nbTov4+1p"
@@ -362,7 +360,7 @@ let commonEdit (model: EditCommonModel) app = [
]
]
div [ _class "mb-2" ] [
label [ _for "text" ] [ raw "Text" ]; raw "     "
raw "Text"; raw "     "
div [ _class "btn-group btn-group-sm"; _roleGroup; _ariaLabel "Text format button group" ] [
input [ _type "radio"; _name (nameof model.Source); _id "source_html"; _class "btn-check"
_value "HTML"; if model.Source = "HTML" then _checked ]
src/MyWebLog/Views/Page.fs
+9 -13
View File
@@ -7,9 +7,10 @@ open MyWebLog.ViewModels
/// The form to edit pages
let pageEdit (model: EditPageModel) templates app = [
let url = relUrl app "admin/page/save"
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
form [ _action (relUrl app "admin/page/save"); _method "post"; _hxPushUrl "true"; _class "container" ] [
form [ _action url; _method "post"; _hxPost url; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name (nameof model.Id); _value model.Id ]
div [ _class "row mb-3" ] [
@@ -30,7 +31,9 @@ let pageEdit (model: EditPageModel) templates app = [
let pageList (pages: DisplayPage list) pageNbr hasNext app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [ _class "container mb-3" ] [
a [ _href (relUrl app "admin/page/new/edit"); _class "btn btn-primary btn-sm mb-3" ] [ raw "Create a New Page" ]
a [ _href (relUrl app "admin/page/new/edit"); _hxBoost; _class "btn btn-primary btn-sm mb-3" ] [
raw "Create a New Page"
]
if pages.Length = 0 then
p [ _class "text-muted fst-italic text-center" ] [ raw "This web log has no pages" ]
else
@@ -58,7 +61,7 @@ let pageList (pages: DisplayPage list) pageNbr hasNext app = [
a [ _href (relUrl app pageLink); _target "_blank" ] [ raw "View Page" ]
if app.IsEditor || (app.IsAuthor && app.UserId.Value = WebLogUserId pg.AuthorId) then
span [ _class "text-muted" ] [ raw " • " ]
a [ _href $"{adminUrl}/edit" ] [ raw "Edit" ]
a [ _href $"{adminUrl}/edit"; _hxBoost ] [ raw "Edit" ]
if app.IsWebLogAdmin then
span [ _class "text-muted" ] [ raw " • " ]
a [ _href adminUrl; _hxDelete adminUrl; _hxTarget "body"; _class "text-danger"
@@ -79,23 +82,16 @@ let pageList (pages: DisplayPage list) pageNbr hasNext app = [
]
]
if pageNbr > 1 || hasNext then
let aAttrs link = [ _href (relUrl app link); _hxBoost; _class "btn btn-secondary" ]
div [ _class "d-flex justify-content-evenly mb-3" ] [
div [] [
if pageNbr > 1 then
let prevPage = if pageNbr = 2 then "" else $"/page/{pageNbr - 1}"
p [] [
a [ _class "btn btn-secondary"; _href (relUrl app $"admin/pages{prevPage}") ] [
raw "« Previous"
]
]
p [] [ a (aAttrs $"admin/pages{prevPage}") [ raw "« Previous" ] ]
]
div [ _class "text-right" ] [
if hasNext then
p [] [
a [ _class "btn btn-secondary"; _href (relUrl app $"admin/pages/page/{pageNbr + 1}") ] [
raw "Next »"
]
]
p [] [ a (aAttrs $"admin/pages/page/{pageNbr + 1}") [ raw "Next »" ] ]
]
]
]
src/MyWebLog/Views/Post.fs
+17 -19
View File
@@ -102,7 +102,8 @@ let chapterEdit (model: EditChapterModel) app = [
/// Display a list of chapters
let chapterList withNew (model: ManageChaptersModel) app =
div [ _id "chapter_list"; _class "container mb-3"; _hxTarget "this"; _hxSwap HxSwap.OuterHtml ] [
div [ _id "chapter_list"; _class "container mb-3"; hxInherited (_hxTarget "this")
hxInherited (_hxSwap HxSwap.OuterHtml) ] [
div [ _class "row mwl-table-heading" ] [
div [ _class "col-3 col-md-2" ] [ raw "Start" ]
div [ _class "col-3 col-md-6 col-lg-8" ] [ raw "Title" ]
@@ -123,7 +124,7 @@ let chapterList withNew (model: ManageChaptersModel) app =
else
let chapterUrl = relUrl app $"admin/post/{model.Id}/chapter/{idx}"
a [ _href chapterUrl; _hxGet chapterUrl; _hxTarget $"#chapter{idx}"
_hxSwap $"{HxSwap.InnerHtml} show:#chapter{idx}:top" ] [
_hxSwap $"{HxSwap.InnerHtml} show:top showTarget:#chapter{idx}" ] [
raw "Edit"
]
span [ _class "text-muted" ] [ raw " • " ]
@@ -138,12 +139,13 @@ let chapterList withNew (model: ManageChaptersModel) app =
div [ _class "row pb-3"; _id "chapter-1" ] [
let newLink = relUrl app $"admin/post/{model.Id}/chapter/-1"
if withNew then
span [ _hxGet newLink; _hxTarget "#chapter-1"; _hxTrigger "load"; _hxSwap "show:#chapter-1:top" ] []
span [ _hxGet newLink; _hxTarget "#chapter-1"; _hxTrigger "load"
_hxSwap "show:top showTarget:#chapter-1" ] []
else
div [ _class "row pb-3 mwl-table-detail" ] [
div [ _class "col-12" ] [
a [ _class "btn btn-primary"; _href newLink; _hxGet newLink; _hxTarget "#chapter-1"
_hxSwap "show:#chapter-1:top" ] [
_hxSwap "show:top showTarget:#chapter-1" ] [
raw "Add a New Chapter"
]
]
@@ -154,12 +156,13 @@ let chapterList withNew (model: ManageChaptersModel) app =
/// Manage Chapters page
let chapters withNew (model: ManageChaptersModel) app = [
let backUrl = relUrl app $"admin/post/{model.Id}/edit"
h2 [ _class "my-3" ] [ txt app.PageTitle ]
article [] [
p [ _style "line-height:1.2rem;" ] [
strong [] [ txt model.Title ]; br []
small [ _class "text-muted" ] [
a [ _href (relUrl app $"admin/post/{model.Id}/edit") ] [
a [ _href backUrl; _hxGet backUrl; _hxPushUrl "true" ] [
raw "« Back to Edit Post"
]
]
@@ -176,9 +179,11 @@ let list (model: PostDisplay) app = [
let tagCol = "col-lg-3 col-xl-4 col-xxl-5 d-none d-lg-inline-block"
h2 [ _class "my-3" ] [ txt app.PageTitle ]
article [] [
a [ _href (relUrl app "admin/post/new/edit"); _class "btn btn-primary btn-sm mb-3" ] [ raw "Write a New Post" ]
a [ _href (relUrl app "admin/post/new/edit"); _hxBoost; _class "btn btn-primary btn-sm mb-3" ] [
raw "Write a New Post"
]
if model.Posts.Length > 0 then
form [ _method "post"; _class "container mb-3"; _hxTarget "body" ] [
form [ _method "post"; _class "container mb-3" ] [
antiCsrf app
div [ _class "row mwl-table-heading" ] [
div [ _class dateCol ] [
@@ -219,7 +224,7 @@ let list (model: PostDisplay) app = [
a [ _href (relUrl app post.Permalink); _target "_blank" ] [ raw "View Post" ]
if app.IsEditor || (app.IsAuthor && app.UserId.Value = WebLogUserId post.AuthorId) then
span [ _class "text-muted" ] [ raw " • " ]
a [ _href $"{postUrl}/edit" ] [ raw "Edit" ]
a [ _href $"{postUrl}/edit"; _hxBoost ] [ raw "Edit" ]
if app.IsWebLogAdmin then
span [ _class "text-muted" ] [ raw " • " ]
a [ _href postUrl; _hxDelete postUrl; _class "text-danger"
@@ -252,22 +257,15 @@ let list (model: PostDisplay) app = [
]
]
if Option.isSome model.NewerLink || Option.isSome model.OlderLink then
let aAttrs link = [ _href link; _hxBoost; _class "btn btn-secondary" ]
div [ _class "d-flex justify-content-evenly mb-3" ] [
div [] [
if Option.isSome model.NewerLink then
p [] [
a [ _href model.NewerLink.Value; _class "btn btn-secondary"; ] [
raw "« Newer Posts"
]
]
p [] [ a (aAttrs model.NewerLink.Value) [ raw "« Newer Posts" ] ]
]
div [ _class "text-right" ] [
if Option.isSome model.OlderLink then
p [] [
a [ _href model.OlderLink.Value; _class "btn btn-secondary" ] [
raw "Older Posts »"
]
]
p [] [ a (aAttrs model.OlderLink.Value) [ raw "Older Posts »" ] ]
]
]
else
@@ -278,7 +276,7 @@ let list (model: PostDisplay) app = [
let postEdit (model: EditPostModel) templates (ratings: MetaItem list) app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
form [ _action (relUrl app "admin/post/save"); _method "post"; _hxPushUrl "true"; _class "container" ] [
form [ _action (relUrl app "admin/post/save"); _method "post"; _hxBoost; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name (nameof model.Id); _value model.Id ]
div [ _class "row mb-3" ] [
src/MyWebLog/Views/User.fs
+6 -5
View File
@@ -138,8 +138,8 @@ let userList (model: WebLogUser list) app =
if app.IsAdministrator || (app.IsWebLogAdmin && not (user.AccessLevel = Administrator)) then
let userUrl = relUrl app $"admin/settings/user/{user.Id}"
small [] [
a [ _href $"{userUrl}/edit"; _hxTarget $"#user_{user.Id}"
_hxSwap $"{HxSwap.InnerHtml} show:#user_{user.Id}:top" ] [
a [ _href $"{userUrl}/edit"; _hxBoost; _hxTarget $"#user_{user.Id}"
_hxSwap $"{HxSwap.InnerHtml} show:top showTarget:#user_{user.Id}" ] [
raw "Edit"
]
if app.UserId.Value <> user.Id then
@@ -168,7 +168,7 @@ let userList (model: WebLogUser list) app =
]
]
div [ _id "user_panel" ] [
a [ _href (relUrl app "admin/settings/user/new/edit"); _class "btn btn-primary btn-sm mb-3"
a [ _href (relUrl app "admin/settings/user/new/edit"); _hxBoost; _class "btn btn-primary btn-sm mb-3"
_hxTarget "#user_new" ] [
raw "Add a New User"
]
@@ -187,7 +187,8 @@ let userList (model: WebLogUser list) app =
div [ _class "row mwl-table-detail"; _id "user_new" ] []
]
List.map userDetail model
|> div [ _class "container g-0"; _hxTarget "#user_panel"; _hxSwap $"{HxSwap.OuterHtml} show:window:top" ]
|> div [ _class "container g-0"; hxInherited (_hxTarget "#user_panel")
hxInherited (_hxSwap $"{HxSwap.OuterHtml} show:top showTarget:window") ]
]
]
|> List.singleton
@@ -197,7 +198,7 @@ let userList (model: WebLogUser list) app =
let myInfo (model: EditMyInfoModel) (user: WebLogUser) app = [
h2 [ _class "my-3" ] [ txt app.PageTitle ]
article [] [
form [ _action (relUrl app "admin/my-info"); _method "post" ] [
form [ _action (relUrl app "admin/my-info"); _method "post"; _hxBoost ] [
antiCsrf app
div [ _class "d-flex flex-row flex-wrap justify-content-around" ] [
div [ _class "text-center mb-3 lh-sm" ] [
src/MyWebLog/Views/WebLog.fs
+3 -2
View File
@@ -814,7 +814,8 @@ let webLogSettings
]
fieldset [ _id "users"; _class "container mb-3 pb-0" ] [
legend [] [ raw "Users" ]
span [ _hxGet (relUrl app "admin/settings/users"); _hxTrigger HxTrigger.Load; _hxSwap HxSwap.OuterHtml ] []
span [ _hxGet (relUrl app "admin/settings/users"); _hxTarget "this"; _hxTrigger HxTrigger.Load
_hxSwap HxSwap.OuterHtml ] []
]
fieldset [ _id "rss-settings"; _class "container mb-3 pb-0" ] [
legend [] [ raw "RSS Settings" ]
@@ -891,7 +892,7 @@ let webLogSettings
_hxTarget "#tag_new" ] [
raw "Add a New Tag Mapping"
]
span [ _hxGet (relUrl app "admin/settings/tag-mappings"); _hxTrigger HxTrigger.Load
span [ _hxGet (relUrl app "admin/settings/tag-mappings"); _hxTarget "this"; _hxTrigger HxTrigger.Load
_hxSwap HxSwap.OuterHtml ] []
]
]