bit-badger/myWebLog
1
0
Fork 0
Code Issues 4 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

55
src/MyWebLog/Caches.fs
View File

@ -2,16 +2,22 @@
open Microsoft.AspNetCore.Http
/// Helper functions for caches
module Cache =
/// Extension properties on HTTP context for web log
[<AutoOpen>]
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<IConnection> ()
open System.Collections.Concurrent
open Microsoft.Extensions.DependencyInjection
open RethinkDb.Driver.Net
/// <summary>
/// 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<string, DisplayPage[]> ()
/// 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<IConnection> ()
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<string, DisplayCategory[]> ()
/// 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<IConnection> ()
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
}

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

@ -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<int>) = 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<int>) = 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<EditCategoryModel> ()
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<ManagePermalinksModel> ()
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<EditPageModel> ()
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<SettingsModel> ()
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<EditTagMapModel> ()
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

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
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<HttpContext option> None) next ctx
}

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

@ -64,20 +64,18 @@ let generator (ctx : HttpContext) =
| Some gen -> gen
| None ->
let cfg = ctx.RequestServices.GetRequiredService<IConfiguration> ()
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<IConnection> ()
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<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
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<ManagePermalinksModel> ()
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<EditPostModel> ()
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

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

@ -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
}

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

@ -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<LogOnModel> ()
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<EditUserModel> ()
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" }

12
src/MyWebLog/Program.fs
View File

@ -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<ForwardedHeadersOptions>(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<WebLogMiddleware> ()
let _ = app.UseAuthentication ()

7
src/MyWebLog/appsettings.json
View File

@ -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"
}
}
}