From 8631a7621701aef73efa8ff20de3a37bc3da3528 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 22 May 2022 18:24:09 -0400 Subject: [PATCH] Use most specific URL base match - Add extensions for web log and data connection - Add forwarded header middleware --- src/MyWebLog/Caches.fs | 55 +++++++++--------- src/MyWebLog/Handlers/Admin.fs | 95 +++++++++++++++----------------- src/MyWebLog/Handlers/Error.fs | 4 +- src/MyWebLog/Handlers/Helpers.fs | 46 ++++++++++------ src/MyWebLog/Handlers/Post.fs | 70 ++++++++++++----------- src/MyWebLog/Handlers/Routes.fs | 6 +- src/MyWebLog/Handlers/User.fs | 16 +++--- src/MyWebLog/Program.fs | 12 ++-- src/MyWebLog/appsettings.json | 7 ++- 9 files changed, 167 insertions(+), 144 deletions(-) diff --git a/src/MyWebLog/Caches.fs b/src/MyWebLog/Caches.fs index e85850b..5e81eef 100644 --- a/src/MyWebLog/Caches.fs +++ b/src/MyWebLog/Caches.fs @@ -2,16 +2,22 @@ open Microsoft.AspNetCore.Http -/// Helper functions for caches -module Cache = +/// Extension properties on HTTP context for web log +[] +module Extensions = - /// Create the cache key for the web log for the current request - let makeKey (ctx : HttpContext) = (ctx.Items["webLog"] :?> WebLog).urlBase - + open Microsoft.Extensions.DependencyInjection + open RethinkDb.Driver.Net + + type HttpContext with + /// The web log for the current request + member this.WebLog = this.Items["webLog"] :?> WebLog + + /// The RethinkDB data connection + member this.Conn = this.RequestServices.GetRequiredService () + open System.Collections.Concurrent -open Microsoft.Extensions.DependencyInjection -open RethinkDb.Driver.Net /// /// In-memory cache of web log details @@ -27,15 +33,13 @@ module WebLogCache = /// The cache of web log details let mutable private _cache : WebLog list = [] - /// Does a host exist in the cache? - let exists ctx = + /// Try to get the web log for the current request (longest matching URL base wins) + let tryGet ctx = let path = fullPath ctx - _cache |> List.exists (fun wl -> path.StartsWith wl.urlBase) - - /// Get the web log for the current request - let get ctx = - let path = fullPath ctx - _cache |> List.find (fun wl -> path.StartsWith wl.urlBase) + _cache + |> List.filter (fun wl -> path.StartsWith wl.urlBase) + |> List.sortByDescending (fun wl -> wl.urlBase.Length) + |> List.tryHead /// Cache the web log for a particular host let set webLog = @@ -57,17 +61,16 @@ module PageListCache = let private _cache = ConcurrentDictionary () /// Are there pages cached for this web log? - let exists ctx = _cache.ContainsKey (Cache.makeKey ctx) + let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.urlBase /// Get the pages for the web log for this request - let get ctx = _cache[Cache.makeKey ctx] + let get (ctx : HttpContext) = _cache[ctx.WebLog.urlBase] /// Update the pages for the current web log let update (ctx : HttpContext) = backgroundTask { - let webLog = ctx.Items["webLog"] :?> WebLog - let conn = ctx.RequestServices.GetRequiredService () - let! pages = Data.Page.findListed webLog.id conn - _cache[Cache.makeKey ctx] <- pages |> List.map (DisplayPage.fromPage webLog) |> Array.ofList + let webLog = ctx.WebLog + let! pages = Data.Page.findListed webLog.id ctx.Conn + _cache[webLog.urlBase] <- pages |> List.map (DisplayPage.fromPage webLog) |> Array.ofList } @@ -80,17 +83,15 @@ module CategoryCache = let private _cache = ConcurrentDictionary () /// Are there categories cached for this web log? - let exists ctx = _cache.ContainsKey (Cache.makeKey ctx) + let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.urlBase /// Get the categories for the web log for this request - let get ctx = _cache[Cache.makeKey ctx] + let get (ctx : HttpContext) = _cache[ctx.WebLog.urlBase] /// Update the cache with fresh data let update (ctx : HttpContext) = backgroundTask { - let webLog = ctx.Items["webLog"] :?> WebLog - let conn = ctx.RequestServices.GetRequiredService () - let! cats = Data.Category.findAllForView webLog.id conn - _cache[Cache.makeKey ctx] <- cats + let! cats = Data.Category.findAllForView ctx.WebLog.id ctx.Conn + _cache[ctx.WebLog.urlBase] <- cats } diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index 4940fe1..7d42077 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -1,8 +1,6 @@ /// Handlers to manipulate admin functions module MyWebLog.Handlers.Admin -// TODO: remove requireUser, as this is applied in the router - open System.Collections.Generic open System.IO @@ -22,10 +20,10 @@ open MyWebLog.ViewModels open RethinkDb.Driver.Net // GET /admin -let dashboard : HttpHandler = requireUser >=> fun next ctx -> task { - let webLog = webLog ctx - let conn = conn ctx - let getCount (f : WebLogId -> IConnection -> Task) = f webLog.id conn +let dashboard : HttpHandler = fun next ctx -> task { + let webLogId = ctx.WebLog.id + let conn = ctx.Conn + let getCount (f : WebLogId -> IConnection -> Task) = f webLogId conn let! posts = Data.Post.countByStatus Published |> getCount let! drafts = Data.Post.countByStatus Draft |> getCount let! pages = Data.Page.countAll |> getCount @@ -50,7 +48,7 @@ let dashboard : HttpHandler = requireUser >=> fun next ctx -> task { // -- CATEGORIES -- // GET /admin/categories -let listCategories : HttpHandler = requireUser >=> fun next ctx -> task { +let listCategories : HttpHandler = fun next ctx -> task { return! Hash.FromAnonymousObject {| categories = CategoryCache.get ctx @@ -61,14 +59,12 @@ let listCategories : HttpHandler = requireUser >=> fun next ctx -> task { } // GET /admin/category/{id}/edit -let editCategory catId : HttpHandler = requireUser >=> fun next ctx -> task { - let webLog = webLog ctx - let conn = conn ctx +let editCategory catId : HttpHandler = fun next ctx -> task { let! result = task { match catId with | "new" -> return Some ("Add a New Category", { Category.empty with id = CategoryId "new" }) | _ -> - match! Data.Category.findById (CategoryId catId) webLog.id conn with + match! Data.Category.findById (CategoryId catId) ctx.WebLog.id ctx.Conn with | Some cat -> return Some ("Edit Category", cat) | None -> return None } @@ -86,10 +82,10 @@ let editCategory catId : HttpHandler = requireUser >=> fun next ctx -> task { } // POST /admin/category/save -let saveCategory : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { +let saveCategory : HttpHandler = fun next ctx -> task { + let webLog = ctx.WebLog + let conn = ctx.Conn let! model = ctx.BindFormAsync () - let webLog = webLog ctx - let conn = conn ctx let! category = task { match model.categoryId with | "new" -> return Some { Category.empty with id = CategoryId.create (); webLogId = webLog.id } @@ -114,10 +110,9 @@ let saveCategory : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx - } // POST /admin/category/{id}/delete -let deleteCategory catId : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { - let webLog = webLog ctx - let conn = conn ctx - match! Data.Category.delete (CategoryId catId) webLog.id conn with +let deleteCategory catId : HttpHandler = fun next ctx -> task { + let webLog = ctx.WebLog + match! Data.Category.delete (CategoryId catId) webLog.id ctx.Conn with | true -> do! CategoryCache.update ctx do! addMessage ctx { UserMessage.success with message = "Category deleted successfully" } @@ -129,9 +124,9 @@ let deleteCategory catId : HttpHandler = requireUser >=> validateCsrf >=> fun ne // GET /admin/pages // GET /admin/pages/page/{pageNbr} -let listPages pageNbr : HttpHandler = requireUser >=> fun next ctx -> task { - let webLog = webLog ctx - let! pages = Data.Page.findPageOfPages webLog.id pageNbr (conn ctx) +let listPages pageNbr : HttpHandler = fun next ctx -> task { + let webLog = ctx.WebLog + let! pages = Data.Page.findPageOfPages webLog.id pageNbr ctx.Conn return! Hash.FromAnonymousObject {| pages = pages |> List.map (DisplayPage.fromPageMinimal webLog) @@ -141,12 +136,12 @@ let listPages pageNbr : HttpHandler = requireUser >=> fun next ctx -> task { } // GET /admin/page/{id}/edit -let editPage pgId : HttpHandler = requireUser >=> fun next ctx -> task { +let editPage pgId : HttpHandler = fun next ctx -> task { let! result = task { match pgId with | "new" -> return Some ("Add a New Page", { Page.empty with id = PageId "new" }) | _ -> - match! Data.Page.findByFullId (PageId pgId) (webLog ctx).id (conn ctx) with + match! Data.Page.findByFullId (PageId pgId) ctx.WebLog.id ctx.Conn with | Some page -> return Some ("Edit Page", page) | None -> return None } @@ -167,8 +162,8 @@ let editPage pgId : HttpHandler = requireUser >=> fun next ctx -> task { } // GET /admin/page/{id}/permalinks -let editPagePermalinks pgId : HttpHandler = requireUser >=> fun next ctx -> task { - match! Data.Page.findByFullId (PageId pgId) (webLog ctx).id (conn ctx) with +let editPagePermalinks pgId : HttpHandler = fun next ctx -> task { + match! Data.Page.findByFullId (PageId pgId) ctx.WebLog.id ctx.Conn with | Some pg -> return! Hash.FromAnonymousObject {| @@ -181,11 +176,11 @@ let editPagePermalinks pgId : HttpHandler = requireUser >=> fun next ctx -> task } // POST /admin/page/permalinks -let savePagePermalinks : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { - let webLog = webLog ctx +let savePagePermalinks : HttpHandler = fun next ctx -> task { + let webLog = ctx.WebLog let! model = ctx.BindFormAsync () let links = model.prior |> Array.map Permalink |> List.ofArray - match! Data.Page.updatePriorPermalinks (PageId model.id) webLog.id links (conn ctx) with + match! Data.Page.updatePriorPermalinks (PageId model.id) webLog.id links ctx.Conn with | true -> do! addMessage ctx { UserMessage.success with message = "Page permalinks saved successfully" } return! redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/page/{model.id}/permalinks")) next ctx @@ -193,9 +188,9 @@ let savePagePermalinks : HttpHandler = requireUser >=> validateCsrf >=> fun next } // POST /admin/page/{id}/delete -let deletePage pgId : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { - let webLog = webLog ctx - match! Data.Page.delete (PageId pgId) webLog.id (conn ctx) with +let deletePage pgId : HttpHandler = fun next ctx -> task { + let webLog = ctx.WebLog + match! Data.Page.delete (PageId pgId) webLog.id ctx.Conn with | true -> do! addMessage ctx { UserMessage.success with message = "Page deleted successfully" } | false -> do! addMessage ctx { UserMessage.error with message = "Page not found; nothing deleted" } return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/pages")) next ctx @@ -206,10 +201,10 @@ open System #nowarn "3511" // POST /admin/page/save -let savePage : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { +let savePage : HttpHandler = fun next ctx -> task { let! model = ctx.BindFormAsync () - let webLog = webLog ctx - let conn = conn ctx + let webLog = ctx.WebLog + let conn = ctx.Conn let now = DateTime.UtcNow let! pg = task { match model.pageId with @@ -261,9 +256,9 @@ let savePage : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> ta // -- WEB LOG SETTINGS -- // GET /admin/settings -let settings : HttpHandler = requireUser >=> fun next ctx -> task { - let webLog = webLog ctx - let! allPages = Data.Page.findAll webLog.id (conn ctx) +let settings : HttpHandler = fun next ctx -> task { + let webLog = ctx.WebLog + let! allPages = Data.Page.findAll webLog.id ctx.Conn return! Hash.FromAnonymousObject {| csrf = csrfToken ctx @@ -284,9 +279,9 @@ let settings : HttpHandler = requireUser >=> fun next ctx -> task { } // POST /admin/settings -let saveSettings : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { - let webLog = webLog ctx - let conn = conn ctx +let saveSettings : HttpHandler = fun next ctx -> task { + let webLog = ctx.WebLog + let conn = ctx.Conn let! model = ctx.BindFormAsync () match! Data.WebLog.findById webLog.id conn with | Some webLog -> @@ -312,8 +307,8 @@ let saveSettings : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx - // -- TAG MAPPINGS -- // GET /admin/tag-mappings -let tagMappings : HttpHandler = requireUser >=> fun next ctx -> task { - let! mappings = Data.TagMap.findByWebLogId (webLog ctx).id (conn ctx) +let tagMappings : HttpHandler = fun next ctx -> task { + let! mappings = Data.TagMap.findByWebLogId ctx.WebLog.id ctx.Conn return! Hash.FromAnonymousObject {| csrf = csrfToken ctx @@ -325,13 +320,13 @@ let tagMappings : HttpHandler = requireUser >=> fun next ctx -> task { } // GET /admin/tag-mapping/{id}/edit -let editMapping tagMapId : HttpHandler = requireUser >=> fun next ctx -> task { +let editMapping tagMapId : HttpHandler = fun next ctx -> task { let isNew = tagMapId = "new" let tagMap = if isNew then Task.FromResult (Some { TagMap.empty with id = TagMapId "new" }) else - Data.TagMap.findById (TagMapId tagMapId) (webLog ctx).id (conn ctx) + Data.TagMap.findById (TagMapId tagMapId) ctx.WebLog.id ctx.Conn match! tagMap with | Some tm -> return! @@ -345,9 +340,9 @@ let editMapping tagMapId : HttpHandler = requireUser >=> fun next ctx -> task { } // POST /admin/tag-mapping/save -let saveMapping : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { - let webLog = webLog ctx - let conn = conn ctx +let saveMapping : HttpHandler = fun next ctx -> task { + let webLog = ctx.WebLog + let conn = ctx.Conn let! model = ctx.BindFormAsync () let tagMap = if model.id = "new" then @@ -365,9 +360,9 @@ let saveMapping : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> } // POST /admin/tag-mapping/{id}/delete -let deleteMapping tagMapId : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { - let webLog = webLog ctx - match! Data.TagMap.delete (TagMapId tagMapId) webLog.id (conn ctx) with +let deleteMapping tagMapId : HttpHandler = fun next ctx -> task { + let webLog = ctx.WebLog + match! Data.TagMap.delete (TagMapId tagMapId) webLog.id ctx.Conn 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! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/tag-mappings")) next ctx diff --git a/src/MyWebLog/Handlers/Error.fs b/src/MyWebLog/Handlers/Error.fs index dfb00ee..0f7157c 100644 --- a/src/MyWebLog/Handlers/Error.fs +++ b/src/MyWebLog/Handlers/Error.fs @@ -9,10 +9,10 @@ open MyWebLog /// Handle unauthorized actions, redirecting to log on for GETs, otherwise returning a 401 Not Authorized response let notAuthorized : HttpHandler = fun next ctx -> task { - let webLog = ctx.Items["webLog"] :?> WebLog if ctx.Request.Method = "GET" then let returnUrl = WebUtility.UrlEncode ctx.Request.Path - return! redirectTo false (WebLog.relativeUrl webLog (Permalink $"user/log-on?returnUrl={returnUrl}")) next ctx + return! + redirectTo false (WebLog.relativeUrl ctx.WebLog (Permalink $"user/log-on?returnUrl={returnUrl}")) next ctx else return! (setStatusCode 401 >=> fun _ _ -> Task.FromResult None) next ctx } diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index eb9644e..33e2445 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -64,20 +64,18 @@ let generator (ctx : HttpContext) = | Some gen -> gen | None -> let cfg = ctx.RequestServices.GetRequiredService () - generatorString <- Option.ofObj cfg["Generator"] - defaultArg generatorString "generator not configured" + generatorString <- + match Option.ofObj cfg["Generator"] with + | Some gen -> Some gen + | None -> Some "generator not configured" + generatorString.Value open MyWebLog - -/// Get the web log for the request from the context (established by middleware) -let webLog (ctx : HttpContext) = - ctx.Items["webLog"] :?> WebLog - open DotLiquid /// Either get the web log from the hash, or get it from the cache and add it to the hash -let private deriveWebLogFromHash (hash : Hash) ctx = - if hash.ContainsKey "web_log" then () else hash.Add ("web_log", webLog ctx) +let private deriveWebLogFromHash (hash : Hash) (ctx : HttpContext) = + if hash.ContainsKey "web_log" then () else hash.Add ("web_log", ctx.WebLog) hash["web_log"] :?> WebLog open Giraffe @@ -125,11 +123,6 @@ open System.Security.Claims let userId (ctx : HttpContext) = WebLogUserId (ctx.User.Claims |> Seq.find (fun c -> c.Type = ClaimTypes.NameIdentifier)).Value -open RethinkDb.Driver.Net - -/// Get the RethinkDB connection -let conn (ctx : HttpContext) = ctx.RequestServices.GetRequiredService () - open Microsoft.AspNetCore.Antiforgery /// Get the Anti-CSRF service @@ -153,11 +146,11 @@ open System.Collections.Generic open System.IO /// Get the templates available for the current web log's theme (in a key/value pair list) -let templatesForTheme ctx (typ : string) = +let templatesForTheme (ctx : HttpContext) (typ : string) = seq { KeyValuePair.Create ("", $"- Default (single-{typ}) -") yield! - Path.Combine ("themes", (webLog ctx).themePath) + Path.Combine ("themes", ctx.WebLog.themePath) |> Directory.EnumerateFiles |> Seq.filter (fun it -> it.EndsWith $"{typ}.liquid") |> Seq.map (fun it -> @@ -167,3 +160,24 @@ let templatesForTheme ctx (typ : string) = } |> Array.ofSeq +open Microsoft.Extensions.Logging + +/// Log level for debugging +let mutable private debugEnabled : bool option = None + +/// Is debug enabled for handlers? +let private isDebugEnabled (ctx : HttpContext) = + match debugEnabled with + | Some flag -> flag + | None -> + let fac = ctx.RequestServices.GetRequiredService () + let log = fac.CreateLogger "MyWebLog.Handlers" + debugEnabled <- Some (log.IsEnabled LogLevel.Debug) + debugEnabled.Value + +/// Log a debug message +let debug name ctx (msg : unit -> string) = + if isDebugEnabled ctx then + let fac = ctx.RequestServices.GetRequiredService () + let log = fac.CreateLogger $"MyWebLog.Handlers.{name}" + log.LogDebug (msg ()) diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 2978b74..a066abc 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -2,6 +2,7 @@ module MyWebLog.Handlers.Post open System +open Microsoft.AspNetCore.Http /// Parse a slug and page number from an "everything else" URL let private parseSlugAndPage (slugAndPage : string seq) = @@ -98,8 +99,8 @@ open Giraffe // GET /page/{pageNbr} let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task { - let webLog = webLog ctx - let conn = conn ctx + let webLog = ctx.WebLog + let conn = ctx.Conn let! posts = Data.Post.findPageOfPublishedPosts webLog.id pageNbr webLog.postsPerPage conn let! hash = preparePostList webLog posts PostList "" pageNbr webLog.postsPerPage ctx conn let title = @@ -115,8 +116,8 @@ let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task { // GET /category/{slug}/ // GET /category/{slug}/page/{pageNbr} let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task { - let webLog = webLog ctx - let conn = conn ctx + let webLog = ctx.WebLog + let conn = ctx.Conn match parseSlugAndPage slugAndPage with | Some pageNbr, slug -> let allCats = CategoryCache.get ctx @@ -145,8 +146,8 @@ open System.Web // GET /tag/{tag}/ // GET /tag/{tag}/page/{pageNbr} let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task { - let webLog = webLog ctx - let conn = conn ctx + let webLog = ctx.WebLog + let conn = ctx.Conn match parseSlugAndPage slugAndPage with | Some pageNbr, rawTag -> let urlTag = HttpUtility.UrlDecode rawTag @@ -178,11 +179,11 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task { // GET / let home : HttpHandler = fun next ctx -> task { - let webLog = webLog ctx + let webLog = ctx.WebLog match webLog.defaultPage with | "posts" -> return! pageOfPosts 1 next ctx | pageId -> - match! Data.Page.findById (PageId pageId) webLog.id (conn ctx) with + match! Data.Page.findById (PageId pageId) webLog.id ctx.Conn with | Some page -> return! Hash.FromAnonymousObject {| @@ -203,8 +204,8 @@ open System.Xml // GET /feed.xml // (Routing handled by catch-all handler for future configurability) let generateFeed : HttpHandler = fun next ctx -> backgroundTask { - let conn = conn ctx - let webLog = webLog ctx + let webLog = ctx.WebLog + let conn = ctx.Conn // TODO: hard-coded number of items let! posts = Data.Post.findPageOfPublishedPosts webLog.id 1 10 conn let! authors = getAuthors webLog posts conn @@ -274,13 +275,16 @@ let generateFeed : HttpHandler = fun next ctx -> backgroundTask { } /// Sequence where the first returned value is the proper handler for the link -let private deriveAction ctx : HttpHandler seq = - let webLog = webLog ctx - let conn = conn ctx - let _, extra = WebLog.hostAndPath webLog - let textLink = if extra = "" then ctx.Request.Path.Value else ctx.Request.Path.Value.Substring extra.Length - let await it = (Async.AwaitTask >> Async.RunSynchronously) it +let private deriveAction (ctx : HttpContext) : HttpHandler seq = + let webLog = ctx.WebLog + let conn = ctx.Conn + let textLink = + let _, extra = WebLog.hostAndPath webLog + let url = string ctx.Request.Path + if extra = "" then url else url.Substring extra.Length + let await it = (Async.AwaitTask >> Async.RunSynchronously) it seq { + debug "Post" ctx (fun () -> $"Considering URL {textLink}") // Home page directory without the directory slash if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.empty) let permalink = Permalink (textLink.Substring 1) @@ -329,9 +333,9 @@ let catchAll : HttpHandler = fun next ctx -> task { // GET /admin/posts // GET /admin/posts/page/{pageNbr} -let all pageNbr : HttpHandler = requireUser >=> fun next ctx -> task { - let webLog = webLog ctx - let conn = conn ctx +let all pageNbr : HttpHandler = fun next ctx -> task { + let webLog = ctx.WebLog + let conn = ctx.Conn let! posts = Data.Post.findPageOfPosts webLog.id pageNbr 25 conn let! hash = preparePostList webLog posts AdminList "" pageNbr 25 ctx conn hash.Add ("page_title", "Posts") @@ -339,9 +343,9 @@ let all pageNbr : HttpHandler = requireUser >=> fun next ctx -> task { } // GET /admin/post/{id}/edit -let edit postId : HttpHandler = requireUser >=> fun next ctx -> task { - let webLog = webLog ctx - let conn = conn ctx +let edit postId : HttpHandler = fun next ctx -> task { + let webLog = ctx.WebLog + let conn = ctx.Conn let! result = task { match postId with | "new" -> return Some ("Write a New Post", { Post.empty with id = PostId "new" }) @@ -365,8 +369,8 @@ let edit postId : HttpHandler = requireUser >=> fun next ctx -> task { } // GET /admin/post/{id}/permalinks -let editPermalinks postId : HttpHandler = requireUser >=> fun next ctx -> task { - match! Data.Post.findByFullId (PostId postId) (webLog ctx).id (conn ctx) with +let editPermalinks postId : HttpHandler = fun next ctx -> task { + match! Data.Post.findByFullId (PostId postId) ctx.WebLog.id ctx.Conn with | Some post -> return! Hash.FromAnonymousObject {| @@ -379,11 +383,11 @@ let editPermalinks postId : HttpHandler = requireUser >=> fun next ctx -> task { } // POST /admin/post/permalinks -let savePermalinks : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { - let webLog = webLog ctx +let savePermalinks : HttpHandler = fun next ctx -> task { + let webLog = ctx.WebLog let! model = ctx.BindFormAsync () let links = model.prior |> Array.map Permalink |> List.ofArray - match! Data.Post.updatePriorPermalinks (PostId model.id) webLog.id links (conn ctx) with + match! Data.Post.updatePriorPermalinks (PostId model.id) webLog.id links ctx.Conn with | true -> do! addMessage ctx { UserMessage.success with message = "Post permalinks saved successfully" } return! redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/post/{model.id}/permalinks")) next ctx @@ -391,9 +395,9 @@ let savePermalinks : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx } // POST /admin/post/{id}/delete -let delete postId : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { - let webLog = webLog ctx - match! Data.Post.delete (PostId postId) webLog.id (conn ctx) with +let delete postId : HttpHandler = fun next ctx -> task { + let webLog = ctx.WebLog + match! Data.Post.delete (PostId postId) webLog.id ctx.Conn 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 (WebLog.relativeUrl webLog (Permalink "admin/posts")) next ctx @@ -402,10 +406,10 @@ let delete postId : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx #nowarn "3511" // POST /admin/post/save -let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { +let save : HttpHandler = fun next ctx -> task { let! model = ctx.BindFormAsync () - let webLog = webLog ctx - let conn = conn ctx + let webLog = ctx.WebLog + let conn = ctx.Conn let now = DateTime.UtcNow let! pst = task { match model.postId with diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 6694986..4f0fbda 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -34,7 +34,7 @@ let router : HttpHandler = choose [ ]) route "/user/edit" >=> User.edit ] - POST >=> choose [ + POST >=> validateCsrf >=> choose [ subRoute "/category" (choose [ route "/save" >=> Admin.saveCategory routef "/%s/delete" Admin.deleteCategory @@ -65,7 +65,7 @@ let router : HttpHandler = choose [ route "/log-on" >=> User.logOn None route "/log-off" >=> User.logOff ] - POST >=> choose [ + POST >=> validateCsrf >=> choose [ route "/log-on" >=> User.doLogOn ] ]) @@ -79,7 +79,7 @@ let routerWithPath extraPath : HttpHandler = /// Handler to apply Giraffe routing with a possible sub-route let handleRoute : HttpHandler = fun next ctx -> task { - let _, extraPath = WebLog.hostAndPath (webLog ctx) + let _, extraPath = WebLog.hostAndPath ctx.WebLog return! (if extraPath = "" then router else routerWithPath extraPath) next ctx } diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index 9e7f9c6..c0c7939 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -39,10 +39,10 @@ open Microsoft.AspNetCore.Authentication.Cookies open MyWebLog // POST /user/log-on -let doLogOn : HttpHandler = validateCsrf >=> fun next ctx -> task { +let doLogOn : HttpHandler = fun next ctx -> task { let! model = ctx.BindFormAsync () - let webLog = webLog ctx - match! Data.WebLogUser.findByEmail model.emailAddress webLog.id (conn ctx) with + let webLog = ctx.WebLog + match! Data.WebLogUser.findByEmail model.emailAddress webLog.id ctx.Conn with | Some user when user.passwordHash = hashedPassword model.password user.userName user.salt -> let claims = seq { Claim (ClaimTypes.NameIdentifier, WebLogUserId.toString user.id) @@ -66,7 +66,7 @@ let doLogOn : HttpHandler = validateCsrf >=> fun next ctx -> task { let logOff : HttpHandler = fun next ctx -> task { do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme do! addMessage ctx { UserMessage.info with message = "Log off successful" } - return! redirectToGet (WebLog.relativeUrl (webLog ctx) Permalink.empty) next ctx + return! redirectToGet (WebLog.relativeUrl ctx.WebLog Permalink.empty) next ctx } /// Display the user edit page, with information possibly filled in @@ -77,8 +77,8 @@ let private showEdit (hash : Hash) : HttpHandler = fun next ctx -> task { } // GET /admin/user/edit -let edit : HttpHandler = requireUser >=> fun next ctx -> task { - match! Data.WebLogUser.findById (userId ctx) (conn ctx) with +let edit : HttpHandler = fun next ctx -> task { + match! Data.WebLogUser.findById (userId ctx) ctx.Conn with | Some user -> return! showEdit (Hash.FromAnonymousObject {| model = EditUserModel.fromUser user |}) next ctx | None -> return! Error.notFound next ctx } @@ -87,7 +87,7 @@ let edit : HttpHandler = requireUser >=> fun next ctx -> task { let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { let! model = ctx.BindFormAsync () if model.newPassword = model.newPasswordConfirm then - let conn = conn ctx + let conn = ctx.Conn match! Data.WebLogUser.findById (userId ctx) conn with | Some user -> let pw, salt = @@ -107,7 +107,7 @@ let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { do! Data.WebLogUser.update user conn 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 (WebLog.relativeUrl (webLog ctx) (Permalink "admin/user/edit")) next ctx + return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/user/edit")) next ctx | None -> return! Error.notFound next ctx else do! addMessage ctx { UserMessage.error with message = "Passwords did not match; no updates made" } diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index 8291e78..dde6415 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -5,13 +5,13 @@ open MyWebLog type WebLogMiddleware (next : RequestDelegate) = member this.InvokeAsync (ctx : HttpContext) = task { - if WebLogCache.exists ctx then - ctx.Items["webLog"] <- WebLogCache.get ctx + match WebLogCache.tryGet ctx with + | Some webLog -> + ctx.Items["webLog"] <- webLog if PageListCache.exists ctx then () else do! PageListCache.update ctx if CategoryCache.exists ctx then () else do! CategoryCache.update ctx return! next.Invoke ctx - else - ctx.Response.StatusCode <- 404 + | None -> ctx.Response.StatusCode <- 404 } @@ -151,6 +151,7 @@ open Giraffe.EndpointRouting open Microsoft.AspNetCore.Antiforgery open Microsoft.AspNetCore.Authentication.Cookies open Microsoft.AspNetCore.Builder +open Microsoft.AspNetCore.HttpOverrides open Microsoft.Extensions.Configuration open Microsoft.Extensions.Logging open MyWebLog.ViewModels @@ -161,6 +162,8 @@ open RethinkDb.Driver.FSharp let main args = let builder = WebApplication.CreateBuilder(args) + let _ = builder.Services.Configure(fun (opts : ForwardedHeadersOptions) -> + opts.ForwardedHeaders <- ForwardedHeaders.XForwardedFor ||| ForwardedHeaders.XForwardedProto) let _ = builder.Services .AddAuthentication(CookieAuthenticationDefaults.AuthenticationScheme) @@ -227,6 +230,7 @@ let main args = | Some it when it = "import-permalinks" -> NewWebLog.importPermalinks args app.Services |> Async.AwaitTask |> Async.RunSynchronously | _ -> + let _ = app.UseForwardedHeaders () let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict)) let _ = app.UseMiddleware () let _ = app.UseAuthentication () diff --git a/src/MyWebLog/appsettings.json b/src/MyWebLog/appsettings.json index 4cb4a6e..f7733ab 100644 --- a/src/MyWebLog/appsettings.json +++ b/src/MyWebLog/appsettings.json @@ -3,5 +3,10 @@ "hostname": "data02.bitbadger.solutions", "database": "myWebLog_dev" }, - "Generator": "myWebLog 2.0-alpha08" + "Generator": "myWebLog 2.0-alpha10", + "Logging": { + "LogLevel": { + "MyWebLog.Handlers": "Debug" + } + } }