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

V2 #1

Merged
danieljsummers merged 102 commits from v2 into main 2022-06-23 00:35:12 +00:00
Conversation 0 Commits 102 Files Changed 125 +167 -144
9 changed files with 167 additions and 144 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files
Showing only changes of commit 8631a76217 - Show all commits

53
src/MyWebLog/Caches.fs
View File

@ -2,16 +2,22 @@
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
/// Helper functions for caches /// Extension properties on HTTP context for web log
module Cache = [<AutoOpen>]
module Extensions =
/// Create the cache key for the web log for the current request open Microsoft.Extensions.DependencyInjection
let makeKey (ctx : HttpContext) = (ctx.Items["webLog"] :?> WebLog).urlBase 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<IConnection> ()
open System.Collections.Concurrent open System.Collections.Concurrent
open Microsoft.Extensions.DependencyInjection
open RethinkDb.Driver.Net
/// <summary> /// <summary>
/// In-memory cache of web log details /// In-memory cache of web log details
@ -27,15 +33,13 @@ module WebLogCache =
/// The cache of web log details /// The cache of web log details
let mutable private _cache : WebLog list = [] let mutable private _cache : WebLog list = []
/// Does a host exist in the cache? /// Try to get the web log for the current request (longest matching URL base wins)
let exists ctx = let tryGet ctx =
let path = fullPath ctx let path = fullPath ctx
_cache |> List.exists (fun wl -> path.StartsWith wl.urlBase) _cache
|> List.filter (fun wl -> path.StartsWith wl.urlBase)
/// Get the web log for the current request |> List.sortByDescending (fun wl -> wl.urlBase.Length)
let get ctx = |> List.tryHead
let path = fullPath ctx
_cache |> List.find (fun wl -> path.StartsWith wl.urlBase)
/// Cache the web log for a particular host /// Cache the web log for a particular host
let set webLog = let set webLog =
@ -57,17 +61,16 @@ module PageListCache =
let private _cache = ConcurrentDictionary<string, DisplayPage[]> () let private _cache = ConcurrentDictionary<string, DisplayPage[]> ()
/// Are there pages cached for this web log? /// 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 /// 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 /// Update the pages for the current web log
let update (ctx : HttpContext) = backgroundTask { let update (ctx : HttpContext) = backgroundTask {
let webLog = ctx.Items["webLog"] :?> WebLog let webLog = ctx.WebLog
let conn = ctx.RequestServices.GetRequiredService<IConnection> () let! pages = Data.Page.findListed webLog.id ctx.Conn
let! pages = Data.Page.findListed webLog.id conn _cache[webLog.urlBase] <- pages |> List.map (DisplayPage.fromPage webLog) |> Array.ofList
_cache[Cache.makeKey ctx] <- pages |> List.map (DisplayPage.fromPage webLog) |> Array.ofList
} }
@ -80,17 +83,15 @@ module CategoryCache =
let private _cache = ConcurrentDictionary<string, DisplayCategory[]> () let private _cache = ConcurrentDictionary<string, DisplayCategory[]> ()
/// Are there categories cached for this web log? /// 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 /// 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 /// Update the cache with fresh data
let update (ctx : HttpContext) = backgroundTask { let update (ctx : HttpContext) = backgroundTask {
let webLog = ctx.Items["webLog"] :?> WebLog let! cats = Data.Category.findAllForView ctx.WebLog.id ctx.Conn
let conn = ctx.RequestServices.GetRequiredService<IConnection> () _cache[ctx.WebLog.urlBase] <- cats
let! cats = Data.Category.findAllForView webLog.id conn
_cache[Cache.makeKey ctx] <- cats
} }

95
src/MyWebLog/Handlers/Admin.fs
View File

@ -1,8 +1,6 @@
/// Handlers to manipulate admin functions /// Handlers to manipulate admin functions
module MyWebLog.Handlers.Admin module MyWebLog.Handlers.Admin
// TODO: remove requireUser, as this is applied in the router
open System.Collections.Generic open System.Collections.Generic
open System.IO open System.IO
@ -22,10 +20,10 @@ open MyWebLog.ViewModels
open RethinkDb.Driver.Net open RethinkDb.Driver.Net
// GET /admin // GET /admin
let dashboard : HttpHandler = requireUser >=> fun next ctx -> task { let dashboard : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLogId = ctx.WebLog.id
let conn = conn ctx let conn = ctx.Conn
let getCount (f : WebLogId -> IConnection -> Task<int>) = f webLog.id conn let getCount (f : WebLogId -> IConnection -> Task<int>) = f webLogId conn
let! posts = Data.Post.countByStatus Published |> getCount let! posts = Data.Post.countByStatus Published |> getCount
let! drafts = Data.Post.countByStatus Draft |> getCount let! drafts = Data.Post.countByStatus Draft |> getCount
let! pages = Data.Page.countAll |> getCount let! pages = Data.Page.countAll |> getCount
@ -50,7 +48,7 @@ let dashboard : HttpHandler = requireUser >=> fun next ctx -> task {
// -- CATEGORIES -- // -- CATEGORIES --
// GET /admin/categories // GET /admin/categories
let listCategories : HttpHandler = requireUser >=> fun next ctx -> task { let listCategories : HttpHandler = fun next ctx -> task {
return! return!
Hash.FromAnonymousObject {| Hash.FromAnonymousObject {|
categories = CategoryCache.get ctx categories = CategoryCache.get ctx
@ -61,14 +59,12 @@ let listCategories : HttpHandler = requireUser >=> fun next ctx -> task {
} }
// GET /admin/category/{id}/edit // GET /admin/category/{id}/edit
let editCategory catId : HttpHandler = requireUser >=> fun next ctx -> task { let editCategory catId : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx
let conn = conn ctx
let! result = task { let! result = task {
match catId with match catId with
| "new" -> return Some ("Add a New Category", { Category.empty with id = CategoryId "new" }) | "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) | Some cat -> return Some ("Edit Category", cat)
| None -> return None | None -> return None
} }
@ -86,10 +82,10 @@ let editCategory catId : HttpHandler = requireUser >=> fun next ctx -> task {
} }
// POST /admin/category/save // 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<EditCategoryModel> () let! model = ctx.BindFormAsync<EditCategoryModel> ()
let webLog = webLog ctx
let conn = conn ctx
let! category = task { let! category = task {
match model.categoryId with match model.categoryId with
| "new" -> return Some { Category.empty with id = CategoryId.create (); webLogId = webLog.id } | "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 // POST /admin/category/{id}/delete
let deleteCategory catId : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { let deleteCategory catId : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
let conn = conn ctx match! Data.Category.delete (CategoryId catId) webLog.id ctx.Conn with
match! Data.Category.delete (CategoryId catId) webLog.id conn with
| true -> | true ->
do! CategoryCache.update ctx do! CategoryCache.update ctx
do! addMessage ctx { UserMessage.success with message = "Category deleted successfully" } 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
// GET /admin/pages/page/{pageNbr} // GET /admin/pages/page/{pageNbr}
let listPages pageNbr : HttpHandler = requireUser >=> fun next ctx -> task { let listPages pageNbr : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
let! pages = Data.Page.findPageOfPages webLog.id pageNbr (conn ctx) let! pages = Data.Page.findPageOfPages webLog.id pageNbr ctx.Conn
return! return!
Hash.FromAnonymousObject Hash.FromAnonymousObject
{| pages = pages |> List.map (DisplayPage.fromPageMinimal webLog) {| 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 // 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 { let! result = task {
match pgId with match pgId with
| "new" -> return Some ("Add a New Page", { Page.empty with id = PageId "new" }) | "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) | Some page -> return Some ("Edit Page", page)
| None -> return None | None -> return None
} }
@ -167,8 +162,8 @@ let editPage pgId : HttpHandler = requireUser >=> fun next ctx -> task {
} }
// GET /admin/page/{id}/permalinks // GET /admin/page/{id}/permalinks
let editPagePermalinks pgId : HttpHandler = requireUser >=> fun next ctx -> task { let editPagePermalinks pgId : HttpHandler = fun next ctx -> task {
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 pg -> | Some pg ->
return! return!
Hash.FromAnonymousObject {| Hash.FromAnonymousObject {|
@ -181,11 +176,11 @@ let editPagePermalinks pgId : HttpHandler = requireUser >=> fun next ctx -> task
} }
// POST /admin/page/permalinks // POST /admin/page/permalinks
let savePagePermalinks : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { let savePagePermalinks : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
let! model = ctx.BindFormAsync<ManagePermalinksModel> () let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
let links = model.prior |> Array.map Permalink |> List.ofArray 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 -> | true ->
do! addMessage ctx { UserMessage.success with message = "Page permalinks saved successfully" } do! addMessage ctx { UserMessage.success with message = "Page permalinks saved successfully" }
return! redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/page/{model.id}/permalinks")) next ctx 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 // POST /admin/page/{id}/delete
let deletePage pgId : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { let deletePage pgId : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
match! Data.Page.delete (PageId pgId) webLog.id (conn ctx) with match! Data.Page.delete (PageId pgId) webLog.id ctx.Conn with
| true -> do! addMessage ctx { UserMessage.success with message = "Page deleted successfully" } | true -> do! addMessage ctx { UserMessage.success with message = "Page deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with message = "Page not found; nothing deleted" } | false -> do! addMessage ctx { UserMessage.error with message = "Page not found; nothing deleted" }
return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/pages")) next ctx return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/pages")) next ctx
@ -206,10 +201,10 @@ open System
#nowarn "3511" #nowarn "3511"
// POST /admin/page/save // POST /admin/page/save
let savePage : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { let savePage : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPageModel> () let! model = ctx.BindFormAsync<EditPageModel> ()
let webLog = webLog ctx let webLog = ctx.WebLog
let conn = conn ctx let conn = ctx.Conn
let now = DateTime.UtcNow let now = DateTime.UtcNow
let! pg = task { let! pg = task {
match model.pageId with match model.pageId with
@ -261,9 +256,9 @@ let savePage : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> ta
// -- WEB LOG SETTINGS -- // -- WEB LOG SETTINGS --
// GET /admin/settings // GET /admin/settings
let settings : HttpHandler = requireUser >=> fun next ctx -> task { let settings : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
let! allPages = Data.Page.findAll webLog.id (conn ctx) let! allPages = Data.Page.findAll webLog.id ctx.Conn
return! return!
Hash.FromAnonymousObject Hash.FromAnonymousObject
{| csrf = csrfToken ctx {| csrf = csrfToken ctx
@ -284,9 +279,9 @@ let settings : HttpHandler = requireUser >=> fun next ctx -> task {
} }
// POST /admin/settings // POST /admin/settings
let saveSettings : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { let saveSettings : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
let conn = conn ctx let conn = ctx.Conn
let! model = ctx.BindFormAsync<SettingsModel> () let! model = ctx.BindFormAsync<SettingsModel> ()
match! Data.WebLog.findById webLog.id conn with match! Data.WebLog.findById webLog.id conn with
| Some webLog -> | Some webLog ->
@ -312,8 +307,8 @@ let saveSettings : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -
// -- TAG MAPPINGS -- // -- TAG MAPPINGS --
// GET /admin/tag-mappings // GET /admin/tag-mappings
let tagMappings : HttpHandler = requireUser >=> fun next ctx -> task { let tagMappings : HttpHandler = fun next ctx -> task {
let! mappings = Data.TagMap.findByWebLogId (webLog ctx).id (conn ctx) let! mappings = Data.TagMap.findByWebLogId ctx.WebLog.id ctx.Conn
return! return!
Hash.FromAnonymousObject Hash.FromAnonymousObject
{| csrf = csrfToken ctx {| csrf = csrfToken ctx
@ -325,13 +320,13 @@ let tagMappings : HttpHandler = requireUser >=> fun next ctx -> task {
} }
// GET /admin/tag-mapping/{id}/edit // 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 isNew = tagMapId = "new"
let tagMap = let tagMap =
if isNew then if isNew then
Task.FromResult (Some { TagMap.empty with id = TagMapId "new" }) Task.FromResult (Some { TagMap.empty with id = TagMapId "new" })
else else
Data.TagMap.findById (TagMapId tagMapId) (webLog ctx).id (conn ctx) Data.TagMap.findById (TagMapId tagMapId) ctx.WebLog.id ctx.Conn
match! tagMap with match! tagMap with
| Some tm -> | Some tm ->
return! return!
@ -345,9 +340,9 @@ let editMapping tagMapId : HttpHandler = requireUser >=> fun next ctx -> task {
} }
// POST /admin/tag-mapping/save // POST /admin/tag-mapping/save
let saveMapping : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { let saveMapping : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
let conn = conn ctx let conn = ctx.Conn
let! model = ctx.BindFormAsync<EditTagMapModel> () let! model = ctx.BindFormAsync<EditTagMapModel> ()
let tagMap = let tagMap =
if model.id = "new" then if model.id = "new" then
@ -365,9 +360,9 @@ let saveMapping : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx ->
} }
// POST /admin/tag-mapping/{id}/delete // POST /admin/tag-mapping/{id}/delete
let deleteMapping tagMapId : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { let deleteMapping tagMapId : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
match! Data.TagMap.delete (TagMapId tagMapId) webLog.id (conn ctx) with match! Data.TagMap.delete (TagMapId tagMapId) webLog.id ctx.Conn with
| true -> do! addMessage ctx { UserMessage.success with message = "Tag mapping deleted successfully" } | 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" } | 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 return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/tag-mappings")) next ctx

4
src/MyWebLog/Handlers/Error.fs
View File

@ -9,10 +9,10 @@ open MyWebLog
/// Handle unauthorized actions, redirecting to log on for GETs, otherwise returning a 401 Not Authorized response /// Handle unauthorized actions, redirecting to log on for GETs, otherwise returning a 401 Not Authorized response
let notAuthorized : HttpHandler = fun next ctx -> task { let notAuthorized : HttpHandler = fun next ctx -> task {
let webLog = ctx.Items["webLog"] :?> WebLog
if ctx.Request.Method = "GET" then if ctx.Request.Method = "GET" then
let returnUrl = WebUtility.UrlEncode ctx.Request.Path 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 else
return! (setStatusCode 401 >=> fun _ _ -> Task.FromResult<HttpContext option> None) next ctx return! (setStatusCode 401 >=> fun _ _ -> Task.FromResult<HttpContext option> None) next ctx
} }

46
src/MyWebLog/Handlers/Helpers.fs
View File

@ -64,20 +64,18 @@ let generator (ctx : HttpContext) =
| Some gen -> gen | Some gen -> gen
| None -> | None ->
let cfg = ctx.RequestServices.GetRequiredService<IConfiguration> () let cfg = ctx.RequestServices.GetRequiredService<IConfiguration> ()
generatorString <- Option.ofObj cfg["Generator"] generatorString <-
defaultArg generatorString "generator not configured" match Option.ofObj cfg["Generator"] with
| Some gen -> Some gen
| None -> Some "generator not configured"
generatorString.Value
open MyWebLog 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 open DotLiquid
/// Either get the web log from the hash, or get it from the cache and add it to the hash /// 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 = let private deriveWebLogFromHash (hash : Hash) (ctx : HttpContext) =
if hash.ContainsKey "web_log" then () else hash.Add ("web_log", webLog ctx) if hash.ContainsKey "web_log" then () else hash.Add ("web_log", ctx.WebLog)
hash["web_log"] :?> WebLog hash["web_log"] :?> WebLog
open Giraffe open Giraffe
@ -125,11 +123,6 @@ open System.Security.Claims
let userId (ctx : HttpContext) = let userId (ctx : HttpContext) =
WebLogUserId (ctx.User.Claims |> Seq.find (fun c -> c.Type = ClaimTypes.NameIdentifier)).Value 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<IConnection> ()
open Microsoft.AspNetCore.Antiforgery open Microsoft.AspNetCore.Antiforgery
/// Get the Anti-CSRF service /// Get the Anti-CSRF service
@ -153,11 +146,11 @@ open System.Collections.Generic
open System.IO open System.IO
/// Get the templates available for the current web log's theme (in a key/value pair list) /// 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 { seq {
KeyValuePair.Create ("", $"- Default (single-{typ}) -") KeyValuePair.Create ("", $"- Default (single-{typ}) -")
yield! yield!
Path.Combine ("themes", (webLog ctx).themePath) Path.Combine ("themes", ctx.WebLog.themePath)
|> Directory.EnumerateFiles |> Directory.EnumerateFiles
|> Seq.filter (fun it -> it.EndsWith $"{typ}.liquid") |> Seq.filter (fun it -> it.EndsWith $"{typ}.liquid")
|> Seq.map (fun it -> |> Seq.map (fun it ->
@ -167,3 +160,24 @@ let templatesForTheme ctx (typ : string) =
} }
|> Array.ofSeq |> 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<ILoggerFactory> ()
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<ILoggerFactory> ()
let log = fac.CreateLogger $"MyWebLog.Handlers.{name}"
log.LogDebug (msg ())

70
src/MyWebLog/Handlers/Post.fs
View File

@ -2,6 +2,7 @@
module MyWebLog.Handlers.Post module MyWebLog.Handlers.Post
open System open System
open Microsoft.AspNetCore.Http
/// Parse a slug and page number from an "everything else" URL /// Parse a slug and page number from an "everything else" URL
let private parseSlugAndPage (slugAndPage : string seq) = let private parseSlugAndPage (slugAndPage : string seq) =
@ -98,8 +99,8 @@ open Giraffe
// GET /page/{pageNbr} // GET /page/{pageNbr}
let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task { let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
let conn = conn ctx let conn = ctx.Conn
let! posts = Data.Post.findPageOfPublishedPosts webLog.id pageNbr webLog.postsPerPage conn let! posts = Data.Post.findPageOfPublishedPosts webLog.id pageNbr webLog.postsPerPage conn
let! hash = preparePostList webLog posts PostList "" pageNbr webLog.postsPerPage ctx conn let! hash = preparePostList webLog posts PostList "" pageNbr webLog.postsPerPage ctx conn
let title = let title =
@ -115,8 +116,8 @@ let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
// GET /category/{slug}/ // GET /category/{slug}/
// GET /category/{slug}/page/{pageNbr} // GET /category/{slug}/page/{pageNbr}
let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task { let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
let conn = conn ctx let conn = ctx.Conn
match parseSlugAndPage slugAndPage with match parseSlugAndPage slugAndPage with
| Some pageNbr, slug -> | Some pageNbr, slug ->
let allCats = CategoryCache.get ctx let allCats = CategoryCache.get ctx
@ -145,8 +146,8 @@ open System.Web
// GET /tag/{tag}/ // GET /tag/{tag}/
// GET /tag/{tag}/page/{pageNbr} // GET /tag/{tag}/page/{pageNbr}
let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task { let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
let conn = conn ctx let conn = ctx.Conn
match parseSlugAndPage slugAndPage with match parseSlugAndPage slugAndPage with
| Some pageNbr, rawTag -> | Some pageNbr, rawTag ->
let urlTag = HttpUtility.UrlDecode rawTag let urlTag = HttpUtility.UrlDecode rawTag
@ -178,11 +179,11 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
// GET / // GET /
let home : HttpHandler = fun next ctx -> task { let home : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
match webLog.defaultPage with match webLog.defaultPage with
| "posts" -> return! pageOfPosts 1 next ctx | "posts" -> return! pageOfPosts 1 next ctx
| pageId -> | 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 -> | Some page ->
return! return!
Hash.FromAnonymousObject {| Hash.FromAnonymousObject {|
@ -203,8 +204,8 @@ open System.Xml
// GET /feed.xml // GET /feed.xml
// (Routing handled by catch-all handler for future configurability) // (Routing handled by catch-all handler for future configurability)
let generateFeed : HttpHandler = fun next ctx -> backgroundTask { let generateFeed : HttpHandler = fun next ctx -> backgroundTask {
let conn = conn ctx let webLog = ctx.WebLog
let webLog = webLog ctx let conn = ctx.Conn
// TODO: hard-coded number of items // TODO: hard-coded number of items
let! posts = Data.Post.findPageOfPublishedPosts webLog.id 1 10 conn let! posts = Data.Post.findPageOfPublishedPosts webLog.id 1 10 conn
let! authors = getAuthors webLog posts 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 /// Sequence where the first returned value is the proper handler for the link
let private deriveAction ctx : HttpHandler seq = let private deriveAction (ctx : HttpContext) : HttpHandler seq =
let webLog = webLog ctx let webLog = ctx.WebLog
let conn = conn ctx let conn = ctx.Conn
let _, extra = WebLog.hostAndPath webLog let textLink =
let textLink = if extra = "" then ctx.Request.Path.Value else ctx.Request.Path.Value.Substring extra.Length let _, extra = WebLog.hostAndPath webLog
let await it = (Async.AwaitTask >> Async.RunSynchronously) it let url = string ctx.Request.Path
if extra = "" then url else url.Substring extra.Length
let await it = (Async.AwaitTask >> Async.RunSynchronously) it
seq { seq {
debug "Post" ctx (fun () -> $"Considering URL {textLink}")
// Home page directory without the directory slash // Home page directory without the directory slash
if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.empty) if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.empty)
let permalink = Permalink (textLink.Substring 1) let permalink = Permalink (textLink.Substring 1)
@ -329,9 +333,9 @@ let catchAll : HttpHandler = fun next ctx -> task {
// GET /admin/posts // GET /admin/posts
// GET /admin/posts/page/{pageNbr} // GET /admin/posts/page/{pageNbr}
let all pageNbr : HttpHandler = requireUser >=> fun next ctx -> task { let all pageNbr : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
let conn = conn ctx let conn = ctx.Conn
let! posts = Data.Post.findPageOfPosts webLog.id pageNbr 25 conn let! posts = Data.Post.findPageOfPosts webLog.id pageNbr 25 conn
let! hash = preparePostList webLog posts AdminList "" pageNbr 25 ctx conn let! hash = preparePostList webLog posts AdminList "" pageNbr 25 ctx conn
hash.Add ("page_title", "Posts") hash.Add ("page_title", "Posts")
@ -339,9 +343,9 @@ let all pageNbr : HttpHandler = requireUser >=> fun next ctx -> task {
} }
// GET /admin/post/{id}/edit // GET /admin/post/{id}/edit
let edit postId : HttpHandler = requireUser >=> fun next ctx -> task { let edit postId : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
let conn = conn ctx let conn = ctx.Conn
let! result = task { let! result = task {
match postId with match postId with
| "new" -> return Some ("Write a New Post", { Post.empty with id = PostId "new" }) | "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 // GET /admin/post/{id}/permalinks
let editPermalinks postId : HttpHandler = requireUser >=> fun next ctx -> task { let editPermalinks postId : HttpHandler = fun next ctx -> task {
match! Data.Post.findByFullId (PostId postId) (webLog ctx).id (conn ctx) with match! Data.Post.findByFullId (PostId postId) ctx.WebLog.id ctx.Conn with
| Some post -> | Some post ->
return! return!
Hash.FromAnonymousObject {| Hash.FromAnonymousObject {|
@ -379,11 +383,11 @@ let editPermalinks postId : HttpHandler = requireUser >=> fun next ctx -> task {
} }
// POST /admin/post/permalinks // POST /admin/post/permalinks
let savePermalinks : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { let savePermalinks : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
let! model = ctx.BindFormAsync<ManagePermalinksModel> () let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
let links = model.prior |> Array.map Permalink |> List.ofArray 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 -> | true ->
do! addMessage ctx { UserMessage.success with message = "Post permalinks saved successfully" } do! addMessage ctx { UserMessage.success with message = "Post permalinks saved successfully" }
return! redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/post/{model.id}/permalinks")) next ctx 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 // POST /admin/post/{id}/delete
let delete postId : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { let delete postId : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx let webLog = ctx.WebLog
match! Data.Post.delete (PostId postId) webLog.id (conn ctx) with match! Data.Post.delete (PostId postId) webLog.id ctx.Conn with
| true -> do! addMessage ctx { UserMessage.success with message = "Post deleted successfully" } | true -> do! addMessage ctx { UserMessage.success with message = "Post deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with message = "Post not found; nothing deleted" } | false -> do! addMessage ctx { UserMessage.error with message = "Post not found; nothing deleted" }
return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/posts")) next ctx 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" #nowarn "3511"
// POST /admin/post/save // POST /admin/post/save
let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { let save : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPostModel> () let! model = ctx.BindFormAsync<EditPostModel> ()
let webLog = webLog ctx let webLog = ctx.WebLog
let conn = conn ctx let conn = ctx.Conn
let now = DateTime.UtcNow let now = DateTime.UtcNow
let! pst = task { let! pst = task {
match model.postId with match model.postId with

6
src/MyWebLog/Handlers/Routes.fs
View File

@ -34,7 +34,7 @@ let router : HttpHandler = choose [
]) ])
route "/user/edit" >=> User.edit route "/user/edit" >=> User.edit
] ]
POST >=> choose [ POST >=> validateCsrf >=> choose [
subRoute "/category" (choose [ subRoute "/category" (choose [
route "/save" >=> Admin.saveCategory route "/save" >=> Admin.saveCategory
routef "/%s/delete" Admin.deleteCategory routef "/%s/delete" Admin.deleteCategory
@ -65,7 +65,7 @@ let router : HttpHandler = choose [
route "/log-on" >=> User.logOn None route "/log-on" >=> User.logOn None
route "/log-off" >=> User.logOff route "/log-off" >=> User.logOff
] ]
POST >=> choose [ POST >=> validateCsrf >=> choose [
route "/log-on" >=> User.doLogOn route "/log-on" >=> User.doLogOn
] ]
]) ])
@ -79,7 +79,7 @@ let routerWithPath extraPath : HttpHandler =
/// Handler to apply Giraffe routing with a possible sub-route /// Handler to apply Giraffe routing with a possible sub-route
let handleRoute : HttpHandler = fun next ctx -> task { 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 return! (if extraPath = "" then router else routerWithPath extraPath) next ctx
} }

16
src/MyWebLog/Handlers/User.fs
View File

@ -39,10 +39,10 @@ open Microsoft.AspNetCore.Authentication.Cookies
open MyWebLog open MyWebLog
// POST /user/log-on // POST /user/log-on
let doLogOn : HttpHandler = validateCsrf >=> fun next ctx -> task { let doLogOn : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<LogOnModel> () let! model = ctx.BindFormAsync<LogOnModel> ()
let webLog = webLog ctx let webLog = ctx.WebLog
match! Data.WebLogUser.findByEmail model.emailAddress webLog.id (conn ctx) with match! Data.WebLogUser.findByEmail model.emailAddress webLog.id ctx.Conn with
| Some user when user.passwordHash = hashedPassword model.password user.userName user.salt -> | Some user when user.passwordHash = hashedPassword model.password user.userName user.salt ->
let claims = seq { let claims = seq {
Claim (ClaimTypes.NameIdentifier, WebLogUserId.toString user.id) 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 { let logOff : HttpHandler = fun next ctx -> task {
do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme
do! addMessage ctx { UserMessage.info with message = "Log off successful" } 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 /// 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 // GET /admin/user/edit
let edit : HttpHandler = requireUser >=> fun next ctx -> task { let edit : HttpHandler = fun next ctx -> task {
match! Data.WebLogUser.findById (userId ctx) (conn ctx) with match! Data.WebLogUser.findById (userId ctx) ctx.Conn with
| Some user -> return! showEdit (Hash.FromAnonymousObject {| model = EditUserModel.fromUser user |}) next ctx | Some user -> return! showEdit (Hash.FromAnonymousObject {| model = EditUserModel.fromUser user |}) next ctx
| None -> return! Error.notFound 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 save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditUserModel> () let! model = ctx.BindFormAsync<EditUserModel> ()
if model.newPassword = model.newPasswordConfirm then if model.newPassword = model.newPasswordConfirm then
let conn = conn ctx let conn = ctx.Conn
match! Data.WebLogUser.findById (userId ctx) conn with match! Data.WebLogUser.findById (userId ctx) conn with
| Some user -> | Some user ->
let pw, salt = let pw, salt =
@ -107,7 +107,7 @@ let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
do! Data.WebLogUser.update user conn do! Data.WebLogUser.update user conn
let pwMsg = if model.newPassword = "" then "" else " and updated your password" let pwMsg = if model.newPassword = "" then "" else " and updated your password"
do! addMessage ctx { UserMessage.success with message = $"Saved your information{pwMsg} successfully" } 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 | None -> return! Error.notFound next ctx
else else
do! addMessage ctx { UserMessage.error with message = "Passwords did not match; no updates made" } do! addMessage ctx { UserMessage.error with message = "Passwords did not match; no updates made" }

12
src/MyWebLog/Program.fs
View File

@ -5,13 +5,13 @@ open MyWebLog
type WebLogMiddleware (next : RequestDelegate) = type WebLogMiddleware (next : RequestDelegate) =
member this.InvokeAsync (ctx : HttpContext) = task { member this.InvokeAsync (ctx : HttpContext) = task {
if WebLogCache.exists ctx then match WebLogCache.tryGet ctx with
ctx.Items["webLog"] <- WebLogCache.get ctx | Some webLog ->
ctx.Items["webLog"] <- webLog
if PageListCache.exists ctx then () else do! PageListCache.update ctx if PageListCache.exists ctx then () else do! PageListCache.update ctx
if CategoryCache.exists ctx then () else do! CategoryCache.update ctx if CategoryCache.exists ctx then () else do! CategoryCache.update ctx
return! next.Invoke ctx return! next.Invoke ctx
else | None -> ctx.Response.StatusCode <- 404
ctx.Response.StatusCode <- 404
} }
@ -151,6 +151,7 @@ open Giraffe.EndpointRouting
open Microsoft.AspNetCore.Antiforgery open Microsoft.AspNetCore.Antiforgery
open Microsoft.AspNetCore.Authentication.Cookies open Microsoft.AspNetCore.Authentication.Cookies
open Microsoft.AspNetCore.Builder open Microsoft.AspNetCore.Builder
open Microsoft.AspNetCore.HttpOverrides
open Microsoft.Extensions.Configuration open Microsoft.Extensions.Configuration
open Microsoft.Extensions.Logging open Microsoft.Extensions.Logging
open MyWebLog.ViewModels open MyWebLog.ViewModels
@ -161,6 +162,8 @@ open RethinkDb.Driver.FSharp
let main args = let main args =
let builder = WebApplication.CreateBuilder(args) let builder = WebApplication.CreateBuilder(args)
let _ = builder.Services.Configure<ForwardedHeadersOptions>(fun (opts : ForwardedHeadersOptions) ->
opts.ForwardedHeaders <- ForwardedHeaders.XForwardedFor ||| ForwardedHeaders.XForwardedProto)
let _ = let _ =
builder.Services builder.Services
.AddAuthentication(CookieAuthenticationDefaults.AuthenticationScheme) .AddAuthentication(CookieAuthenticationDefaults.AuthenticationScheme)
@ -227,6 +230,7 @@ let main args =
| Some it when it = "import-permalinks" -> | Some it when it = "import-permalinks" ->
NewWebLog.importPermalinks args app.Services |> Async.AwaitTask |> Async.RunSynchronously NewWebLog.importPermalinks args app.Services |> Async.AwaitTask |> Async.RunSynchronously
| _ -> | _ ->
let _ = app.UseForwardedHeaders ()
let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict)) let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict))
let _ = app.UseMiddleware<WebLogMiddleware> () let _ = app.UseMiddleware<WebLogMiddleware> ()
let _ = app.UseAuthentication () let _ = app.UseAuthentication ()

7
src/MyWebLog/appsettings.json
View File

@ -3,5 +3,10 @@
"hostname": "data02.bitbadger.solutions", "hostname": "data02.bitbadger.solutions",
"database": "myWebLog_dev" "database": "myWebLog_dev"
}, },
"Generator": "myWebLog 2.0-alpha08" "Generator": "myWebLog 2.0-alpha10",
"Logging": {
"LogLevel": {
"MyWebLog.Handlers": "Debug"
}
}
} }