diff --git a/src/Directory.Packages.props b/src/Directory.Packages.props index 632ceeb..c585bd5 100644 --- a/src/Directory.Packages.props +++ b/src/Directory.Packages.props @@ -11,8 +11,8 @@ - - + + diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 915b835..ea4a2c7 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -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) = 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() - 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 diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index d6c9039..d48cb28 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -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} « 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} « Posts" + return! + { viewCtx with + PageTitle = defaultArg title viewCtx.PageTitle + IsHome = pageNbr = 1 && ctx.WebLog.DefaultPage = "posts" } + |> themedView "index" next ctx } // GET /page/{pageNbr}/ diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 82d7089..190e426 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -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 +] diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index df3bac0..e1152ae 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -47,7 +47,7 @@ let doLogOn : HttpHandler = 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 + 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 = diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index a72dafd..74163bb 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -20,6 +20,9 @@ type WebLogMiddleware(next: RequestDelegate, log: ILogger) = 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() } diff --git a/src/MyWebLog/Template.fs b/src/MyWebLog/Template.fs index 8f5aae9..e522a5d 100644 --- a/src/MyWebLog/Template.fs +++ b/src/MyWebLog/Template.fs @@ -174,6 +174,7 @@ let options () = it +open Giraffe.Htmx.Common /// Fluid parser customized with myWebLog filters and tags 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" s |> writer.WriteLine if assetExists "script.js" webLog then diff --git a/src/MyWebLog/Views/Helpers.fs b/src/MyWebLog/Views/Helpers.fs index e30d1db..6808c92 100644 --- a/src/MyWebLog/Views/Helpers.fs +++ b/src/MyWebLog/Views/Helpers.fs @@ -2,6 +2,7 @@ [] 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 /// The round-trip instant pattern let roundTrip = InstantPattern.CreateWithInvariantCulture "uuuu'-'MM'-'dd'T'HH':'mm':'ss'.'fffffff"