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

WIP on endpoint routing conversion (#59)

Browse Source
This commit is contained in:
Daniel J. Summers
2026-07-01 23:43:48 -04:00
parent cb9ec52a7d
commit be094fb07e
8 changed files with 118 additions and 153 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Directory.Packages.props
+2 -2
View File
@@ -11,8 +11,8 @@
<PackageVersion Include="Fluid.Core" Version="2.31.0" />
<PackageVersion Include="FSharp.Core" Version="10.1.301" />
<PackageVersion Include="Giraffe" Version="8.2.0" />
<PackageVersion Include="Giraffe.Htmx" Version="4.0.0-beta4" />
<PackageVersion Include="Giraffe.ViewEngine.Htmx" Version="4.0.0-beta4" />
<PackageVersion Include="Giraffe.Htmx" Version="4.0.0-beta5" />
<PackageVersion Include="Giraffe.ViewEngine.Htmx" Version="4.0.0-beta5" />
<PackageVersion Include="Markdig" Version="1.3.2" />
<PackageVersion Include="Markdown.ColorCode" Version="3.0.1" />
<PackageVersion Include="Microsoft.Data.Sqlite" Version="10.0.9" />
src/MyWebLog/Handlers/Admin.fs
+20 -20
View File
@@ -10,7 +10,7 @@ open NodaTime
/// ~~~ DASHBOARDS ~~~
module Dashboard =
// GET /admin/dashboard
let user : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let getCount (f: WebLogId -> Task<int>) = f ctx.WebLog.Id
@@ -43,7 +43,7 @@ let toAdminDashboard : HttpHandler = redirectToGet "admin/administration"
/// ~~~ CACHES ~~~
module Cache =
// POST /admin/cache/web-log/{id}/refresh
let refreshWebLog webLogId : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
let data = ctx.Data
@@ -92,17 +92,17 @@ module Cache =
/// ~~~ CATEGORIES ~~~
module Category =
open MyWebLog.Data
// GET /admin/categories
let all : HttpHandler = fun 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 = fun next ctx -> task {
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" })
@@ -166,15 +166,15 @@ module RedirectRules =
open Microsoft.AspNetCore.Http
// GET /admin/settings/redirect-rules
let all : HttpHandler = fun next ctx ->
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 = fun next ctx ->
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
else
let rules = ctx.WebLog.RedirectRules
if rules.Length < idx || idx < 0 then
None
@@ -184,7 +184,7 @@ module RedirectRules =
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 {
do! ctx.Data.WebLog.UpdateRedirectRules webLog
@@ -243,15 +243,15 @@ module RedirectRules =
/// ~~~ TAG MAPPINGS ~~~
module TagMapping =
// GET /admin/settings/tag-mappings
let all : HttpHandler = fun next ctx -> task {
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 = fun next ctx -> task {
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" }
@@ -290,7 +290,7 @@ module TagMapping =
/// ~~~ THEMES ~~~
module Theme =
open System
open System.IO
open System.IO.Compression
@@ -298,7 +298,7 @@ module Theme =
open MyWebLog.Data
// GET /admin/theme/list
let all : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
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)
@@ -378,7 +378,7 @@ module Theme =
let! theme = updateTemplates { theme with Templates = [] } zip
do! data.Theme.Save theme
do! updateAssets themeId zip data
return theme
}
@@ -392,7 +392,7 @@ module Theme =
let! exists = data.Theme.Exists themeId
let isNew = not exists
let! model = ctx.BindFormAsync<UploadThemeModel>()
if isNew || model.DoOverwrite then
if isNew || model.DoOverwrite then
// Load the theme to the database
use stream = new MemoryStream()
do! themeFile.CopyToAsync stream
@@ -448,11 +448,11 @@ module Theme =
/// ~~~ WEB LOG SETTINGS ~~~
module WebLog =
open System.IO
// GET /admin/settings
let settings : HttpHandler = fun next ctx -> task {
let settings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data
let! allPages = data.Page.All ctx.WebLog.Id
let pages =
@@ -479,13 +479,13 @@ module 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))
do! addMessage ctx { UserMessage.Success with Message = "Web log settings saved successfully" }
return! redirectToGet "admin/settings" next ctx
| None -> return! Error.notFound next ctx
src/MyWebLog/Handlers/Post.fs
+18 -15
View File
@@ -96,22 +96,25 @@ let preparePostList webLog posts listType (url: string) pageNbr perPage (data: I
open Giraffe
// GET /page/{pageNbr}
// GET /page/{pageNbr}[/]
let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
let count = ctx.WebLog.PostsPerPage
let data = ctx.Data
let! posts = data.Post.FindPageOfPublishedPosts ctx.WebLog.Id pageNbr count
let! viewCtx = preparePostList ctx.WebLog posts PostList "" pageNbr count data
let title =
match pageNbr, ctx.WebLog.DefaultPage with
| 1, "posts" -> None
| _, "posts" -> Some $"Page {pageNbr}"
| _, _ -> Some $"Page {pageNbr} &laquo; Posts"
return!
{ viewCtx with
PageTitle = defaultArg title viewCtx.PageTitle
IsHome = pageNbr = 1 && ctx.WebLog.DefaultPage = "posts" }
|> themedView "index" next ctx
if ctx.Request.Path.Value.EndsWith "/" then
return! redirectTo true (ctx.WebLog.RelativeUrl(Permalink $"page/{pageNbr}")) next ctx
else
let count = ctx.WebLog.PostsPerPage
let data = ctx.Data
let! posts = data.Post.FindPageOfPublishedPosts ctx.WebLog.Id pageNbr count
let! viewCtx = preparePostList ctx.WebLog posts PostList "" pageNbr count data
let title =
match pageNbr, ctx.WebLog.DefaultPage with
| 1, "posts" -> None
| _, "posts" -> Some $"Page {pageNbr}"
| _, _ -> Some $"Page {pageNbr} &laquo; Posts"
return!
{ viewCtx with
PageTitle = defaultArg title viewCtx.PageTitle
IsHome = pageNbr = 1 && ctx.WebLog.DefaultPage = "posts" }
|> themedView "index" next ctx
}
// GET /page/{pageNbr}/
src/MyWebLog/Handlers/Routes.fs
+65 -106
View File
@@ -1,10 +1,8 @@
/// Routes for this application
module MyWebLog.Handlers.Routes
open System.Reflection
open Giraffe
open Microsoft.AspNetCore.Http
open Microsoft.Extensions.FileProviders
open MyWebLog
/// Module to resolve routes that do not match any other known route (web blog content)
@@ -13,18 +11,12 @@ module CatchAll =
open System.IO
open MyWebLog.ViewModels
/// URLs for the embedded htmx scripts
let htmxUrls = [ "giraffe.htmx.common/htmx.min.js"; "giraffe.htmx.common/htmax.min.js" ]
/// Sequence where the first returned value is the proper handler for the link
let private deriveAction (ctx: HttpContext) : HttpHandler seq =
let webLog = ctx.WebLog
let data = ctx.Data
let debug = debug "Routes.CatchAll" ctx
let textLink =
let extra = webLog.ExtraPath
let url = string ctx.Request.Path
(if extra = "" then url else url[extra.Length..]).ToLowerInvariant()
let textLink = string ctx.Request.Path
let await it = (Async.AwaitTask >> Async.RunSynchronously) it
seq {
// Static file
@@ -41,32 +33,6 @@ module CatchAll =
|> System.DateTimeOffset
|> Some
|> streamFile true staticFileName None
// Embedded htmx library
if htmxUrls |> List.exists textLink.EndsWith then
debug (fun () -> "Embedded htmx script")
let asm = Assembly.Load "Giraffe.Htmx.Common"
asm.GetManifestResourceNames() |> Array.iter (fun it -> debug (fun () -> $"Resource {it}"))
let name = textLink.Split("/") |> Array.last |> sprintf "Giraffe.Htmx.Common/%s"
use fs = asm.GetManifestResourceStream name
if isNull fs then
debug (fun () -> $"No stream found for {name}")
else
debug (fun () -> $"Found {name}")
yield streamData true fs None None
// let files = EmbeddedFileProvider(Assembly.Load "Giraffe.Htmx.Common")
// let cont = files.GetDirectoryContents "."
// if cont.Exists then
// debug (fun () -> "Contents found in file provider, here comes the list")
// debug (fun () -> $"%A{cont}")
// cont |> Seq.iter (fun it -> debug (fun () -> "Path = " + it.PhysicalPath))
// else
// debug (fun () -> "No contents found in file provider")
// let file = files.GetFileInfo (textLink.Replace("giraffe.htmx.common", "Giraffe.Htmx.Common"))
// debug (fun () -> $"File info created; {textLink} exists = {file.Exists}")
// if file.Exists then
// use contents = file.CreateReadStream()
// yield streamData true contents None None
//yield None
// Home page directory without the directory slash
if textLink = "" then yield redirectTo true (webLog.RelativeUrl Permalink.Empty)
let permalink = Permalink textLink[1..]
@@ -149,61 +115,7 @@ module Asset =
/// The primary myWebLog router
let router : HttpHandler = choose [
GET_HEAD >=> choose [
route "/" >=> Post.home
]
subRoute "/admin" (requireUser >=> choose [
GET_HEAD >=> choose [
route "/administration" >=> Admin.Dashboard.admin
subRoute "/categor" (requireAccess WebLogAdmin >=> choose [
route "ies" >=> Admin.Category.all
routef "y/%s/edit" Admin.Category.edit
])
route "/dashboard" >=> Admin.Dashboard.user
route "/my-info" >=> User.myInfo
subRoute "/page" (choose [
route "s" >=> Page.all 1
routef "s/page/%i" Page.all
routef "/%s/edit" Page.edit
routef "/%s/permalinks" Page.editPermalinks
routef "/%s/revision/%s/preview" Page.previewRevision
routef "/%s/revisions" Page.editRevisions
])
subRoute "/post" (choose [
route "s" >=> Post.all 1
routef "s/page/%i" Post.all
routef "/%s/edit" Post.edit
routef "/%s/permalinks" Post.editPermalinks
routef "/%s/revision/%s/preview" Post.previewRevision
routef "/%s/revisions" Post.editRevisions
routef "/%s/chapter/%i" Post.editChapter
routef "/%s/chapters" Post.manageChapters
])
subRoute "/settings" (requireAccess WebLogAdmin >=> choose [
route "" >=> Admin.WebLog.settings
routef "/rss/%s/edit" Feed.editCustomFeed
subRoute "/redirect-rules" (choose [
route "" >=> Admin.RedirectRules.all
routef "/%i" Admin.RedirectRules.edit
])
subRoute "/tag-mapping" (choose [
route "s" >=> Admin.TagMapping.all
routef "/%s/edit" Admin.TagMapping.edit
])
subRoute "/user" (choose [
route "s" >=> User.all
routef "/%s/edit" User.edit
])
])
subRoute "/theme" (choose [
route "/list" >=> Admin.Theme.all
route "/new" >=> Admin.Theme.add
])
subRoute "/upload" (choose [
route "s" >=> Upload.list
route "/new" >=> Upload.showNew
])
]
POST >=> validateCsrf >=> choose [
subRoute "/cache" (choose [
routef "/theme/%s/refresh" Admin.Cache.refreshTheme
@@ -271,16 +183,10 @@ let router : HttpHandler = choose [
]
])
GET_HEAD >=> routexp "/category/(.*)" Post.pageOfCategorizedPosts
GET_HEAD >=> routef "/page/%i" Post.pageOfPosts
GET_HEAD >=> routef "/page/%i/" Post.redirectToPageOfPosts
GET_HEAD >=> routexp "/tag/(.*)" Post.pageOfTaggedPosts
GET_HEAD >=> routexp "/themes/(.*)" Asset.serve
GET_HEAD >=> routexp "/upload/(.*)" Upload.serve
subRoute "/user" (choose [
GET_HEAD >=> choose [
route "/log-on" >=> User.logOn None
route "/log-off" >=> User.logOff
]
POST >=> validateCsrf >=> choose [
route "/log-on" >=> User.doLogOn
]
@@ -289,17 +195,70 @@ let router : HttpHandler = choose [
//Error.notFound
]
/// Wrap a router in a sub-route
let routerWithPath extraPath : HttpHandler =
subRoute extraPath router
/// Handler to apply Giraffe routing with a possible sub-route
let handleRoute : HttpHandler = fun next ctx ->
let extraPath = ctx.WebLog.ExtraPath
(if extraPath = "" then router else routerWithPath extraPath) next ctx
open Giraffe.EndpointRouting
/// Endpoint-routed handler to deal with sub-routes
let endpoint = [ route "{**url}" handleRoute ]
let endpoints = [
GET_HEAD [ route "/" Post.home ]
subRoute "/admin" [
GET_HEAD [
route "/administration" Admin.Dashboard.admin
subRoute "/categor" [
route "ies" Admin.Category.all
routef "y/%s/edit" Admin.Category.edit
]
route "/dashboard" Admin.Dashboard.user
route "/my-info" User.myInfo
subRoute "/page" [
route "s" (Page.all 1)
routef "s/page/%i" Page.all
routef "/%s/edit" Page.edit
routef "/%s/permalinks" Page.editPermalinks
routef "/%s/revision/%s/preview" Page.previewRevision
routef "/%s/revisions" Page.editRevisions
]
subRoute "/post" [
route "s" (Post.all 1)
routef "s/page/%i" Post.all
routef "/%s/edit" Post.edit
routef "/%s/permalinks" Post.editPermalinks
routef "/%s/revision/%s/preview" Post.previewRevision
routef "/%s/revisions" Post.editRevisions
routef "/%s/chapter/%i" Post.editChapter
routef "/%s/chapters" Post.manageChapters
]
subRoute "/settings" [
route "" Admin.WebLog.settings
routef "/rss/%s/edit" Feed.editCustomFeed
subRoute "/redirect-rules" [
route "" Admin.RedirectRules.all
routef "/%i" Admin.RedirectRules.edit
]
subRoute "/tag-mapping" [
route "s" Admin.TagMapping.all
routef "/%s/edit" Admin.TagMapping.edit
]
subRoute "/user" [
route "s" User.all
routef "/%s/edit" User.edit
]
]
subRoute "/theme" [
route "/list" Admin.Theme.all
route "/new" Admin.Theme.add
]
subRoute "/upload" [
route "s" Upload.list
route "/new" Upload.showNew
]
]
]
subRoute "/user" [
GET_HEAD [ route "/log-on" (User.logOn None) ]
POST [
route "/log-off" User.logOff
]
]
GET_HEAD [ routef "/page/%i" Post.pageOfPosts ]
route "{**url}" router
]
src/MyWebLog/Handlers/User.fs
+4 -4
View File
@@ -47,7 +47,7 @@ let doLogOn : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<LogOnModel>()
let data = ctx.Data
let! tryUser = data.WebLogUser.FindByEmail (model.EmailAddress.ToLowerInvariant()) ctx.WebLog.Id
match! verifyPassword tryUser model.Password ctx with
match! verifyPassword tryUser model.Password ctx with
| Ok _ ->
let user = tryUser.Value
let claims = seq {
@@ -89,7 +89,7 @@ open Giraffe.Htmx
let private goAway : HttpHandler = RequestErrors.BAD_REQUEST "really?"
// GET /admin/settings/users
let all : HttpHandler = fun next ctx -> task {
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)
}
@@ -97,9 +97,9 @@ let all : HttpHandler = fun next ctx -> task {
/// 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 = fun next ctx -> task {
let edit usrId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let isNew = usrId = "new"
let userId = WebLogUserId usrId
let tryUser =
src/MyWebLog/Program.fs
+4 -1
View File
@@ -20,6 +20,9 @@ type WebLogMiddleware(next: RequestDelegate, log: ILogger<WebLogMiddleware>) =
ctx.Items["webLog"] <- webLog
if PageListCache.exists ctx then () else do! PageListCache.update ctx
if CategoryCache.exists ctx then () else do! CategoryCache.update ctx
if webLog.ExtraPath <> "" then
ctx.Request.PathBase <- PathString(webLog.ExtraPath)
ctx.Request.Path <- PathString(ctx.Request.Path.Value[webLog.ExtraPath.Length ..])
return! next.Invoke ctx
| None ->
if isDebug then log.LogDebug $"No resolved web log for {path}"
@@ -242,7 +245,7 @@ let main args =
let _ = app.UseStaticFiles()
let _ = app.UseRouting()
let _ = app.UseSession()
let _ = app.UseGiraffe Handlers.Routes.endpoint
let _ = app.UseGiraffe Handlers.Routes.endpoints
app.Run()
}
src/MyWebLog/Template.fs
+2 -1
View File
@@ -174,6 +174,7 @@ let options () =
it
open Giraffe.Htmx.Common
/// <summary>Fluid parser customized with myWebLog filters and tags</summary>
let parser =
@@ -255,7 +256,7 @@ let parser =
fun writer encoder context ->
let webLog = context.App.WebLog
if webLog.AutoHtmx then
context.App.WebLog.RelativeUrl(Permalink "htmx.min.js")
context.App.WebLog.RelativeUrl(Permalink StaticAssetUrl.htmx[1..])
|> sprintf "%s<script src=\"%s\"></script>" s
|> writer.WriteLine
if assetExists "script.js" webLog then
src/MyWebLog/Views/Helpers.fs
+3 -4
View File
@@ -2,6 +2,7 @@
[<AutoOpen>]
module MyWebLog.Views.Helpers
open Giraffe.Htmx
open Giraffe.ViewEngine
open Giraffe.ViewEngine.Accessibility
open Giraffe.ViewEngine.Htmx
@@ -243,7 +244,7 @@ module Layout =
]
if app.IsLoggedOn then
li [ _class "nav-item" ] [
a [ _class "nav-link"; _href (relUrl app "user/log-off"); _hxNoBoost ] [
a [ _class "nav-link"; _hxPost (relUrl app "user/log-off"); _hxNoBoost ] [
raw "Log Off"
]
]
@@ -317,8 +318,7 @@ module Layout =
script [ _src "https://cdn.jsdelivr.net/npm/bootstrap@5.1.3/dist/js/bootstrap.bundle.min.js"
_integrity "sha384-ka7Sk0Gln4gmtz2MlQnikT1wXgYsOg+OMhuP+IlRH9sENBO0LRn5q+8nbTov4+1p"
_crossorigin "anonymous" ] []
//script [ _src (relUrl app "htmx.min.js") ] []
Script.local
script [ _src (relUrl app StaticAssetUrl.htmx[1..]) ] []
script [ _src (relUrl app "themes/admin/admin.js") ] []
]
]
@@ -335,7 +335,6 @@ module Layout =
// ~~ SHARED TEMPLATES BETWEEN POSTS AND PAGES
open Giraffe.Htmx.Common
/// <summary>The round-trip instant pattern</summary>
let roundTrip = InstantPattern.CreateWithInvariantCulture "uuuu'-'MM'-'dd'T'HH':'mm':'ss'.'fffffff"