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

Add user add/edit (#19)

Browse Source 
- Add makeHash function to simplify code around DotLiquid hashes
- Add context extension to determine if a user has an access level
- Add someTask function to simply Task.FromResult (Some x)
This commit is contained in:
Daniel J. Summers 2022-07-20 23:13:16 -04:00
parent 41ae1d8dad
commit 59f385122b
15 changed files with 523 additions and 292 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/MyWebLog.Data/RethinkDbData.fs
View File

@ -402,7 +402,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
getAll [ webLogId ] (nameof Page.empty.WebLogId) getAll [ webLogId ] (nameof Page.empty.WebLogId)
filter [ nameof Page.empty.IsInPageList, true :> obj ] filter [ nameof Page.empty.IsInPageList, true :> obj ]
without [ nameof Page.empty.Text; nameof Page.empty.PriorPermalinks; nameof Page.empty.Revisions ] without [ nameof Page.empty.Text; nameof Page.empty.PriorPermalinks; nameof Page.empty.Revisions ]
orderBy "title" orderBy (nameof Page.empty.Title)
result; withRetryDefault conn result; withRetryDefault conn
} }
@ -725,7 +725,9 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
member _.FindByIdWithoutText themeId = rethink<Theme> { member _.FindByIdWithoutText themeId = rethink<Theme> {
withTable Table.Theme withTable Table.Theme
get themeId get themeId
merge (fun row -> {| Templates = row[nameof Theme.empty.Templates].Without [| "Text" |] |}) merge (fun row ->
{| Templates = row[nameof Theme.empty.Templates].Without [| nameof ThemeTemplate.empty.Text |]
|})
resultOption; withRetryOptionDefault conn resultOption; withRetryOptionDefault conn
} }
@ -1013,11 +1015,13 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
withTable Table.WebLogUser withTable Table.WebLogUser
get user.Id get user.Id
update [ update [
nameof user.FirstName, user.FirstName :> obj nameof user.Email, user.Email :> obj
nameof user.FirstName, user.FirstName
nameof user.LastName, user.LastName nameof user.LastName, user.LastName
nameof user.PreferredName, user.PreferredName nameof user.PreferredName, user.PreferredName
nameof user.PasswordHash, user.PasswordHash nameof user.PasswordHash, user.PasswordHash
nameof user.Salt, user.Salt nameof user.Salt, user.Salt
nameof user.Url, user.Url
nameof user.AccessLevel, user.AccessLevel nameof user.AccessLevel, user.AccessLevel
] ]
write; withRetryDefault; ignoreResult conn write; withRetryDefault; ignoreResult conn

9
src/MyWebLog.Domain/SupportTypes.fs
View File

@ -600,6 +600,15 @@ type ThemeTemplate =
Text : string Text : string
} }
/// Functions to support theme templates
module ThemeTemplate =
/// An empty theme template
let empty =
{ Name = ""
Text = ""
}
/// Where uploads should be placed /// Where uploads should be placed
type UploadDestination = type UploadDestination =

64
src/MyWebLog.Domain/ViewModels.fs
View File

@ -280,6 +280,9 @@ type EditCategoryModel =
ParentId = cat.ParentId |> Option.map CategoryId.toString |> Option.defaultValue "" ParentId = cat.ParentId |> Option.map CategoryId.toString |> Option.defaultValue ""
} }
/// Is this a new category?
member this.IsNew = this.CategoryId = "new"
/// View model to edit a custom RSS feed /// View model to edit a custom RSS feed
[<CLIMutable; NoComparison; NoEquality>] [<CLIMutable; NoComparison; NoEquality>]
@ -789,7 +792,7 @@ type EditRssModel =
Copyright = defaultArg rss.Copyright "" Copyright = defaultArg rss.Copyright ""
} }
/// Update RSS options from values in this mode /// Update RSS options from values in this model
member this.UpdateOptions (rss : RssOptions) = member this.UpdateOptions (rss : RssOptions) =
{ rss with { rss with
IsFeedEnabled = this.IsFeedEnabled IsFeedEnabled = this.IsFeedEnabled
@ -825,6 +828,65 @@ type EditTagMapModel =
} }
/// View model to display a user's information
[<CLIMutable; NoComparison; NoEquality>]
type EditUserModel =
{ /// The ID of the user
Id : string
/// The user's access level
AccessLevel : string
/// The user name (e-mail address)
Email : string
/// The URL of the user's personal site
Url : string
/// The user's first name
FirstName : string
/// The user's last name
LastName : string
/// The user's preferred name
PreferredName : string
/// The user's password
Password : string
/// Confirmation of the user's password
PasswordConfirm : string
}
/// Construct a displayed user from a web log user
static member fromUser (user : WebLogUser) =
{ Id = WebLogUserId.toString user.Id
AccessLevel = AccessLevel.toString user.AccessLevel
Url = defaultArg user.Url ""
Email = user.Email
FirstName = user.FirstName
LastName = user.LastName
PreferredName = user.PreferredName
Password = ""
PasswordConfirm = ""
}
/// Is this a new user?
member this.IsNew = this.Id = "new"
/// Update a user with values from this model (excludes password)
member this.UpdateUser (user : WebLogUser) =
{ user with
AccessLevel = AccessLevel.parse this.AccessLevel
Email = this.Email
Url = noneIfBlank this.Url
FirstName = this.FirstName
LastName = this.LastName
PreferredName = this.PreferredName
}
/// The model to use to allow a user to log on /// The model to use to allow a user to log on
[<CLIMutable; NoComparison; NoEquality>] [<CLIMutable; NoComparison; NoEquality>]
type LogOnModel = type LogOnModel =

5
src/MyWebLog/Caches.fs
View File

@ -51,6 +51,11 @@ module Extensions =
/// The web log for the current request /// The web log for the current request
member this.WebLog = this.Items["webLog"] :?> WebLog member this.WebLog = this.Items["webLog"] :?> WebLog
/// Does the current user have the requested level of access?
member this.HasAccessLevel level =
defaultArg (this.UserAccessLevel |> Option.map (AccessLevel.hasAccess level)) false
open System.Collections.Concurrent open System.Collections.Concurrent

6
src/MyWebLog/DotLiquidBespoke.fs
View File

@ -230,9 +230,9 @@ let register () =
typeof<DashboardModel>; typeof<DisplayCategory>; typeof<DisplayCustomFeed>; typeof<DisplayPage> typeof<DashboardModel>; typeof<DisplayCategory>; typeof<DisplayCustomFeed>; typeof<DisplayPage>
typeof<DisplayRevision>; typeof<DisplayUpload>; typeof<DisplayUser>; typeof<EditCategoryModel> typeof<DisplayRevision>; typeof<DisplayUpload>; typeof<DisplayUser>; typeof<EditCategoryModel>
typeof<EditCustomFeedModel>; typeof<EditMyInfoModel>; typeof<EditPageModel>; typeof<EditPostModel> typeof<EditCustomFeedModel>; typeof<EditMyInfoModel>; typeof<EditPageModel>; typeof<EditPostModel>
typeof<EditRssModel>; typeof<EditTagMapModel>; typeof<LogOnModel>; typeof<ManagePermalinksModel> typeof<EditRssModel>; typeof<EditTagMapModel>; typeof<EditUserModel>; typeof<LogOnModel>
typeof<ManageRevisionsModel>; typeof<PostDisplay>; typeof<PostListItem>; typeof<SettingsModel> typeof<ManagePermalinksModel>; typeof<ManageRevisionsModel>; typeof<PostDisplay>; typeof<PostListItem>
typeof<UserMessage> typeof<SettingsModel>; typeof<UserMessage>
// Framework types // Framework types
typeof<AntiforgeryTokenSet>; typeof<DateTime option>; typeof<int option>; typeof<KeyValuePair> typeof<AntiforgeryTokenSet>; typeof<DateTime option>; typeof<int option>; typeof<KeyValuePair>
typeof<MetaItem list>; typeof<string list>; typeof<string option>; typeof<TagMap list> typeof<MetaItem list>; typeof<string list>; typeof<string option>; typeof<TagMap list>

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

@ -2,7 +2,6 @@
module MyWebLog.Handlers.Admin module MyWebLog.Handlers.Admin
open System.Threading.Tasks open System.Threading.Tasks
open DotLiquid
open Giraffe open Giraffe
open MyWebLog open MyWebLog
open MyWebLog.ViewModels open MyWebLog.ViewModels
@ -19,8 +18,7 @@ let dashboard : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let topCats = getCount data.Category.CountTopLevel let topCats = getCount data.Category.CountTopLevel
let! _ = Task.WhenAll (posts, drafts, pages, listed, cats, topCats) let! _ = Task.WhenAll (posts, drafts, pages, listed, cats, topCats)
return! return!
Hash.FromAnonymousObject {| {| page_title = "Dashboard"
page_title = "Dashboard"
model = model =
{ Posts = posts.Result { Posts = posts.Result
Drafts = drafts.Result Drafts = drafts.Result
@ -30,7 +28,7 @@ let dashboard : HttpHandler = requireAccess Author >=> fun next ctx -> task {
TopLevelCategories = topCats.Result TopLevelCategories = topCats.Result
} }
|} |}
|> adminView "dashboard" next ctx |> makeHash |> adminView "dashboard" next ctx
} }
// -- CATEGORIES -- // -- CATEGORIES --
@ -38,7 +36,7 @@ let dashboard : HttpHandler = requireAccess Author >=> fun next ctx -> task {
// GET /admin/categories // GET /admin/categories
let listCategories : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let listCategories : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! catListTemplate = TemplateCache.get "admin" "category-list-body" ctx.Data let! catListTemplate = TemplateCache.get "admin" "category-list-body" ctx.Data
let hash = Hash.FromAnonymousObject {| let hash = makeHash {|
page_title = "Categories" page_title = "Categories"
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
web_log = ctx.WebLog web_log = ctx.WebLog
@ -51,11 +49,10 @@ let listCategories : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
// GET /admin/categories/bare // GET /admin/categories/bare
let listCategoriesBare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> let listCategoriesBare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
Hash.FromAnonymousObject {| {| categories = CategoryCache.get ctx
categories = CategoryCache.get ctx
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
|} |}
|> adminBareView "category-list-body" next ctx |> makeHash |> adminBareView "category-list-body" next ctx
// GET /admin/category/{id}/edit // GET /admin/category/{id}/edit
@ -70,14 +67,13 @@ let editCategory catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ct
} }
match result with match result with
| Some (title, cat) -> | Some (title, cat) ->
return! return! {|
Hash.FromAnonymousObject {|
page_title = title page_title = title
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
model = EditCategoryModel.fromCategory cat model = EditCategoryModel.fromCategory cat
categories = CategoryCache.get ctx categories = CategoryCache.get ctx
|} |}
|> adminBareView "category-edit" next ctx |> makeHash |> adminBareView "category-edit" next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
} }
@ -86,19 +82,18 @@ let saveCategory : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> t
let data = ctx.Data let data = ctx.Data
let! model = ctx.BindFormAsync<EditCategoryModel> () let! model = ctx.BindFormAsync<EditCategoryModel> ()
let category = let category =
match model.CategoryId with if model.IsNew then someTask { Category.empty with Id = CategoryId.create (); WebLogId = ctx.WebLog.Id }
| "new" -> Task.FromResult (Some { Category.empty with Id = CategoryId.create (); WebLogId = ctx.WebLog.Id }) else data.Category.FindById (CategoryId model.CategoryId) ctx.WebLog.Id
| catId -> data.Category.FindById (CategoryId catId) ctx.WebLog.Id
match! category with match! category with
| Some cat -> | Some cat ->
let cat = let updatedCat =
{ cat with { cat with
Name = model.Name Name = model.Name
Slug = model.Slug Slug = model.Slug
Description = if model.Description = "" then None else Some model.Description Description = if model.Description = "" then None else Some model.Description
ParentId = if model.ParentId = "" then None else Some (CategoryId model.ParentId) ParentId = if model.ParentId = "" then None else Some (CategoryId model.ParentId)
} }
do! (match model.CategoryId with "new" -> data.Category.Add | _ -> data.Category.Update) cat do! (if model.IsNew then data.Category.Add else data.Category.Update) updatedCat
do! CategoryCache.update ctx do! CategoryCache.update ctx
do! addMessage ctx { UserMessage.success with Message = "Category saved successfully" } do! addMessage ctx { UserMessage.success with Message = "Category saved successfully" }
return! listCategoriesBare next ctx return! listCategoriesBare next ctx
@ -122,7 +117,7 @@ open Microsoft.AspNetCore.Http
/// Get the hash necessary to render the tag mapping list /// Get the hash necessary to render the tag mapping list
let private tagMappingHash (ctx : HttpContext) = task { let private tagMappingHash (ctx : HttpContext) = task {
let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id
return Hash.FromAnonymousObject {| return makeHash {|
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
web_log = ctx.WebLog web_log = ctx.WebLog
mappings = mappings mappings = mappings
@ -150,17 +145,16 @@ let tagMappingsBare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -
let editMapping tagMapId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let editMapping tagMapId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let isNew = tagMapId = "new" let isNew = tagMapId = "new"
let tagMap = let tagMap =
if isNew then Task.FromResult (Some { TagMap.empty with Id = TagMapId "new" }) if isNew then someTask { TagMap.empty with Id = TagMapId "new" }
else ctx.Data.TagMap.FindById (TagMapId tagMapId) ctx.WebLog.Id else ctx.Data.TagMap.FindById (TagMapId tagMapId) ctx.WebLog.Id
match! tagMap with match! tagMap with
| Some tm -> | Some tm ->
return! return! {|
Hash.FromAnonymousObject {|
page_title = if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag" page_title = if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag"
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
model = EditTagMapModel.fromMapping tm model = EditTagMapModel.fromMapping tm
|} |}
|> adminBareView "tag-mapping-edit" next ctx |> makeHash |> adminBareView "tag-mapping-edit" next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
} }
@ -169,8 +163,7 @@ let saveMapping : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> ta
let data = ctx.Data let data = ctx.Data
let! model = ctx.BindFormAsync<EditTagMapModel> () let! model = ctx.BindFormAsync<EditTagMapModel> ()
let tagMap = let tagMap =
if model.IsNew then if model.IsNew then someTask { TagMap.empty with Id = TagMapId.create (); WebLogId = ctx.WebLog.Id }
Task.FromResult (Some { TagMap.empty with Id = TagMapId.create (); WebLogId = ctx.WebLog.Id })
else data.TagMap.FindById (TagMapId model.Id) ctx.WebLog.Id else data.TagMap.FindById (TagMapId model.Id) ctx.WebLog.Id
match! tagMap with match! tagMap with
| Some tm -> | Some tm ->
@ -198,11 +191,10 @@ open MyWebLog.Data
// GET /admin/theme/update // GET /admin/theme/update
let themeUpdatePage : HttpHandler = requireAccess Administrator >=> fun next ctx -> let themeUpdatePage : HttpHandler = requireAccess Administrator >=> fun next ctx ->
Hash.FromAnonymousObject {| {| page_title = "Upload Theme"
page_title = "Upload Theme"
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
|} |}
|> adminView "upload-theme" next ctx |> makeHash |> adminView "upload-theme" next ctx
/// Update the name and version for a theme based on the version.txt file, if present /// Update the name and version for a theme based on the version.txt file, if present
let private updateNameAndVersion (theme : Theme) (zip : ZipArchive) = backgroundTask { let private updateNameAndVersion (theme : Theme) (zip : ZipArchive) = backgroundTask {
@ -311,8 +303,7 @@ let settings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task
let data = ctx.Data let data = ctx.Data
let! allPages = data.Page.All ctx.WebLog.Id let! allPages = data.Page.All ctx.WebLog.Id
let! themes = data.Theme.All () let! themes = data.Theme.All ()
return! return! {|
Hash.FromAnonymousObject {|
page_title = "Web Log Settings" page_title = "Web Log Settings"
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
model = SettingsModel.fromWebLog ctx.WebLog model = SettingsModel.fromWebLog ctx.WebLog
@ -333,7 +324,7 @@ let settings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task
KeyValuePair.Create (UploadDestination.toString Disk, "Disk") KeyValuePair.Create (UploadDestination.toString Disk, "Disk")
|] |]
|} |}
|> adminView "settings" next ctx |> makeHash |> adminView "settings" next ctx
} }
// POST /admin/settings // POST /admin/settings

20
src/MyWebLog/Handlers/Feed.fs
View File

@ -414,23 +414,20 @@ let generate (feedType : FeedType) postCount : HttpHandler = fun next ctx -> bac
// ~~ FEED ADMINISTRATION ~~ // ~~ FEED ADMINISTRATION ~~
open DotLiquid // GET /admin/settings/rss
// GET: /admin/settings/rss
let editSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> let editSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
let feeds = let feeds =
ctx.WebLog.Rss.CustomFeeds ctx.WebLog.Rss.CustomFeeds
|> List.map (DisplayCustomFeed.fromFeed (CategoryCache.get ctx)) |> List.map (DisplayCustomFeed.fromFeed (CategoryCache.get ctx))
|> Array.ofList |> Array.ofList
Hash.FromAnonymousObject {| {| page_title = "RSS Settings"
page_title = "RSS Settings"
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
model = EditRssModel.fromRssOptions ctx.WebLog.Rss model = EditRssModel.fromRssOptions ctx.WebLog.Rss
custom_feeds = feeds custom_feeds = feeds
|} |}
|> adminView "rss-settings" next ctx |> makeHash |> adminView "rss-settings" next ctx
// POST: /admin/settings/rss // POST /admin/settings/rss
let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data let data = ctx.Data
let! model = ctx.BindFormAsync<EditRssModel> () let! model = ctx.BindFormAsync<EditRssModel> ()
@ -444,7 +441,7 @@ let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> t
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
} }
// GET: /admin/settings/rss/{id}/edit // GET /admin/settings/rss/{id}/edit
let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
let customFeed = let customFeed =
match feedId with match feedId with
@ -452,8 +449,7 @@ let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next
| _ -> ctx.WebLog.Rss.CustomFeeds |> List.tryFind (fun f -> f.Id = CustomFeedId feedId) | _ -> ctx.WebLog.Rss.CustomFeeds |> List.tryFind (fun f -> f.Id = CustomFeedId feedId)
match customFeed with match customFeed with
| Some f -> | Some f ->
Hash.FromAnonymousObject {| {| page_title = $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed"""
page_title = $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed"""
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
model = EditCustomFeedModel.fromFeed f model = EditCustomFeedModel.fromFeed f
categories = CategoryCache.get ctx categories = CategoryCache.get ctx
@ -468,10 +464,10 @@ let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next
KeyValuePair.Create (PodcastMedium.toString Blog, "Blog") KeyValuePair.Create (PodcastMedium.toString Blog, "Blog")
|] |]
|} |}
|> adminView "custom-feed-edit" next ctx |> makeHash |> adminView "custom-feed-edit" next ctx
| None -> Error.notFound next ctx | None -> Error.notFound next ctx
// POST: /admin/settings/rss/save // POST /admin/settings/rss/save
let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data let data = ctx.Data
match! data.WebLog.FindById ctx.WebLog.Id with match! data.WebLog.FindById ctx.WebLog.Id with

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

@ -52,9 +52,14 @@ let messages (ctx : HttpContext) = task {
| None -> return [||] | None -> return [||]
} }
open System.Collections.Generic
open MyWebLog open MyWebLog
open DotLiquid open DotLiquid
let makeHash (values : obj) =
Hash.FromAnonymousObject values
/// Add a key to the hash, returning the modified hash /// Add a key to the hash, returning the modified hash
// (note that the hash itself is mutated; this is only used to make it pipeable) // (note that the hash itself is mutated; this is only used to make it pipeable)
let addToHash key (value : obj) (hash : Hash) = let addToHash key (value : obj) (hash : Hash) =
@ -74,9 +79,6 @@ let private populateHash hash ctx = task {
let! messages = messages ctx let! messages = messages ctx
do! commitSession ctx do! commitSession ctx
let accessLevel = ctx.UserAccessLevel
let hasLevel lvl = accessLevel |> Option.map (AccessLevel.hasAccess lvl) |> Option.defaultValue false
ctx.User.Claims ctx.User.Claims
|> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.NameIdentifier) |> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.NameIdentifier)
|> Option.map (fun claim -> claim.Value) |> Option.map (fun claim -> claim.Value)
@ -90,10 +92,10 @@ let private populateHash hash ctx = task {
|> addToHash "generator" ctx.Generator |> addToHash "generator" ctx.Generator
|> addToHash "htmx_script" htmxScript |> addToHash "htmx_script" htmxScript
|> addToHash "is_logged_on" ctx.User.Identity.IsAuthenticated |> addToHash "is_logged_on" ctx.User.Identity.IsAuthenticated
|> addToHash "is_author" (hasLevel Author) |> addToHash "is_author" (ctx.HasAccessLevel Author)
|> addToHash "is_editor" (hasLevel Editor) |> addToHash "is_editor" (ctx.HasAccessLevel Editor)
|> addToHash "is_web_log_admin" (hasLevel WebLogAdmin) |> addToHash "is_web_log_admin" (ctx.HasAccessLevel WebLogAdmin)
|> addToHash "is_administrator" (hasLevel Administrator) |> addToHash "is_administrator" (ctx.HasAccessLevel Administrator)
} }
/// Is the request from htmx? /// Is the request from htmx?
@ -215,25 +217,29 @@ let requireUser : HttpHandler = requiresAuthentication Error.notAuthorized
/// Require a specific level of access for a route /// Require a specific level of access for a route
let requireAccess level : HttpHandler = fun next ctx -> task { let requireAccess level : HttpHandler = fun next ctx -> task {
let userLevel = ctx.UserAccessLevel match ctx.UserAccessLevel with
if defaultArg (userLevel |> Option.map (AccessLevel.hasAccess level)) false then | Some userLevel when AccessLevel.hasAccess level userLevel -> return! next ctx
return! next ctx | Some userLevel ->
else do! addMessage ctx
let message = { UserMessage.warning with
match userLevel with Message = $"The page you tried to access requires {AccessLevel.toString level} privileges"
| Some lvl -> Detail = Some $"Your account only has {AccessLevel.toString userLevel} privileges"
$"The page you tried to access requires {AccessLevel.toString level} privileges; your account only has {AccessLevel.toString lvl} privileges" }
| None -> "The page you tried to access required you to be logged on" return! Error.notAuthorized next ctx
do! addMessage ctx { UserMessage.warning with Message = message } | None ->
printfn "Added message to context" do! addMessage ctx
do! commitSession ctx { UserMessage.warning with Message = "The page you tried to access required you to be logged on" }
return! Error.notAuthorized next ctx return! Error.notAuthorized next ctx
} }
/// Determine if a user is authorized to edit a page or post, given the author /// Determine if a user is authorized to edit a page or post, given the author
let canEdit authorId (ctx : HttpContext) = let canEdit authorId (ctx : HttpContext) =
if ctx.UserId = authorId then true ctx.UserId = authorId || ctx.HasAccessLevel Editor
else defaultArg (ctx.UserAccessLevel |> Option.map (AccessLevel.hasAccess Editor)) false
open System.Threading.Tasks
/// Create a Task with a Some result for the given object
let someTask<'T> (it : 'T) = Task.FromResult (Some it)
open System.Collections.Generic open System.Collections.Generic
open MyWebLog.Data open MyWebLog.Data

37
src/MyWebLog/Handlers/Page.fs
View File

@ -1,7 +1,6 @@
/// Handlers to manipulate pages /// Handlers to manipulate pages
module MyWebLog.Handlers.Page module MyWebLog.Handlers.Page
open DotLiquid
open Giraffe open Giraffe
open MyWebLog open MyWebLog
open MyWebLog.ViewModels open MyWebLog.ViewModels
@ -10,8 +9,7 @@ open MyWebLog.ViewModels
// GET /admin/pages/page/{pageNbr} // GET /admin/pages/page/{pageNbr}
let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task { let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! pages = ctx.Data.Page.FindPageOfPages ctx.WebLog.Id pageNbr let! pages = ctx.Data.Page.FindPageOfPages ctx.WebLog.Id pageNbr
return! return! {|
Hash.FromAnonymousObject {|
page_title = "Pages" page_title = "Pages"
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
pages = pages |> List.map (DisplayPage.fromPageMinimal ctx.WebLog) pages = pages |> List.map (DisplayPage.fromPageMinimal ctx.WebLog)
@ -19,7 +17,7 @@ let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task {
prev_page = if pageNbr = 2 then "" else $"/page/{pageNbr - 1}" prev_page = if pageNbr = 2 then "" else $"/page/{pageNbr - 1}"
next_page = $"/page/{pageNbr + 1}" next_page = $"/page/{pageNbr + 1}"
|} |}
|> adminView "page-list" next ctx |> makeHash |> adminView "page-list" next ctx
} }
// GET /admin/page/{id}/edit // GET /admin/page/{id}/edit
@ -36,8 +34,7 @@ let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
| Some (title, page) when canEdit page.AuthorId ctx -> | Some (title, page) when canEdit page.AuthorId ctx ->
let model = EditPageModel.fromPage page let model = EditPageModel.fromPage page
let! templates = templatesForTheme ctx "page" let! templates = templatesForTheme ctx "page"
return! return! {|
Hash.FromAnonymousObject {|
page_title = title page_title = title
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
model = model model = model
@ -45,7 +42,7 @@ let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
|> Array.mapi (fun idx (name, value) -> [| string idx; name; value |]) |> Array.mapi (fun idx (name, value) -> [| string idx; name; value |])
templates = templates templates = templates
|} |}
|> adminView "page-edit" next ctx |> makeHash |> adminView "page-edit" next ctx
| Some _ -> return! Error.notAuthorized next ctx | Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
} }
@ -64,13 +61,12 @@ let delete pgId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> ta
let editPermalinks pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task { let editPermalinks pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg when canEdit pg.AuthorId ctx -> | Some pg when canEdit pg.AuthorId ctx ->
return! return! {|
Hash.FromAnonymousObject {|
page_title = "Manage Prior Permalinks" page_title = "Manage Prior Permalinks"
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
model = ManagePermalinksModel.fromPage pg model = ManagePermalinksModel.fromPage pg
|} |}
|> adminView "permalinks" next ctx |> makeHash |> adminView "permalinks" next ctx
| Some _ -> return! Error.notAuthorized next ctx | Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
} }
@ -95,13 +91,12 @@ let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task
let editRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task { let editRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg when canEdit pg.AuthorId ctx -> | Some pg when canEdit pg.AuthorId ctx ->
return! return! {|
Hash.FromAnonymousObject {|
page_title = "Manage Page Revisions" page_title = "Manage Page Revisions"
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
model = ManageRevisionsModel.fromPage ctx.WebLog pg model = ManageRevisionsModel.fromPage ctx.WebLog pg
|} |}
|> adminView "revisions" next ctx |> makeHash |> adminView "revisions" next ctx
| Some _ -> return! Error.notAuthorized next ctx | Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
} }
@ -132,11 +127,10 @@ let private findPageRevision pgId revDate (ctx : HttpContext) = task {
let previewRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task { let previewRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPageRevision pgId revDate ctx with match! findPageRevision pgId revDate ctx with
| Some pg, Some rev when canEdit pg.AuthorId ctx -> | Some pg, Some rev when canEdit pg.AuthorId ctx ->
return! return! {|
Hash.FromAnonymousObject {|
content = $"""<div class="mwl-revision-preview mb-3">{MarkupText.toHtml rev.Text}</div>""" content = $"""<div class="mwl-revision-preview mb-3">{MarkupText.toHtml rev.Text}</div>"""
|} |}
|> adminBareView "" next ctx |> makeHash |> adminBareView "" next ctx
| Some _, Some _ -> return! Error.notAuthorized next ctx | Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _ | None, _
| _, None -> return! Error.notFound next ctx | _, None -> return! Error.notFound next ctx
@ -166,34 +160,31 @@ let deleteRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun
| Some pg, Some rev when canEdit pg.AuthorId ctx -> | Some pg, Some rev when canEdit pg.AuthorId ctx ->
do! ctx.Data.Page.Update { pg with Revisions = pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) } do! ctx.Data.Page.Update { pg with Revisions = pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) }
do! addMessage ctx { UserMessage.success with Message = "Revision deleted successfully" } do! addMessage ctx { UserMessage.success with Message = "Revision deleted successfully" }
return! adminBareView "" next ctx (Hash.FromAnonymousObject {| content = "" |}) return! adminBareView "" next ctx (makeHash {| content = "" |})
| Some _, Some _ -> return! Error.notAuthorized next ctx | Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _ | None, _
| _, None -> return! Error.notFound next ctx | _, None -> return! Error.notFound next ctx
} }
open System.Threading.Tasks
// POST /admin/page/save // POST /admin/page/save
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task { let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPageModel> () let! model = ctx.BindFormAsync<EditPageModel> ()
let data = ctx.Data let data = ctx.Data
let now = DateTime.UtcNow let now = DateTime.UtcNow
let tryPage = let tryPage =
if model.IsNew then Task.FromResult ( if model.IsNew then
Some
{ Page.empty with { Page.empty with
Id = PageId.create () Id = PageId.create ()
WebLogId = ctx.WebLog.Id WebLogId = ctx.WebLog.Id
AuthorId = ctx.UserId AuthorId = ctx.UserId
PublishedOn = now PublishedOn = now
}) } |> someTask
else data.Page.FindFullById (PageId model.PageId) ctx.WebLog.Id else data.Page.FindFullById (PageId model.PageId) ctx.WebLog.Id
match! tryPage with match! tryPage with
| Some page when canEdit page.AuthorId ctx -> | Some page when canEdit page.AuthorId ctx ->
let updateList = page.IsInPageList <> model.IsShownInPageList let updateList = page.IsInPageList <> model.IsShownInPageList
let updatedPage = model.UpdatePage page now let updatedPage = model.UpdatePage page now
do! (if model.PageId = "new" then data.Page.Add else data.Page.Update) updatedPage do! (if model.IsNew then data.Page.Add else data.Page.Update) updatedPage
if updateList then do! PageListCache.update ctx if updateList then do! PageListCache.update ctx
do! addMessage ctx { UserMessage.success with Message = "Page saved successfully" } do! addMessage ctx { UserMessage.success with Message = "Page saved successfully" }
return! redirectToGet $"admin/page/{PageId.toString page.Id}/edit" next ctx return! redirectToGet $"admin/page/{PageId.toString page.Id}/edit" next ctx

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

@ -35,7 +35,6 @@ type ListType =
| TagList | TagList
open System.Threading.Tasks open System.Threading.Tasks
open DotLiquid
open MyWebLog.Data open MyWebLog.Data
open MyWebLog.ViewModels open MyWebLog.ViewModels
@ -86,7 +85,7 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage ctx (da
OlderLink = olderLink OlderLink = olderLink
OlderName = olderPost |> Option.map (fun p -> p.Title) OlderName = olderPost |> Option.map (fun p -> p.Title)
} }
return Hash.FromAnonymousObject {| return makeHash {|
model = model model = model
categories = CategoryCache.get ctx categories = CategoryCache.get ctx
tag_mappings = tagMappings tag_mappings = tagMappings
@ -197,14 +196,13 @@ let home : HttpHandler = fun next ctx -> task {
| pageId -> | pageId ->
match! ctx.Data.Page.FindById (PageId pageId) webLog.Id with match! ctx.Data.Page.FindById (PageId pageId) webLog.Id with
| Some page -> | Some page ->
return! return! {|
Hash.FromAnonymousObject {|
page_title = page.Title page_title = page.Title
page = DisplayPage.fromPage webLog page page = DisplayPage.fromPage webLog page
categories = CategoryCache.get ctx categories = CategoryCache.get ctx
is_home = true is_home = true
|} |}
|> themedView (defaultArg page.Template "single-page") next ctx |> makeHash |> themedView (defaultArg page.Template "single-page") next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
} }
@ -236,8 +234,7 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! cats = data.Category.FindAllForView ctx.WebLog.Id let! cats = data.Category.FindAllForView ctx.WebLog.Id
let! templates = templatesForTheme ctx "post" let! templates = templatesForTheme ctx "post"
let model = EditPostModel.fromPost ctx.WebLog post let model = EditPostModel.fromPost ctx.WebLog post
return! return! {|
Hash.FromAnonymousObject {|
page_title = title page_title = title
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
model = model model = model
@ -252,7 +249,7 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
KeyValuePair.Create (ExplicitRating.toString Clean, "Clean") KeyValuePair.Create (ExplicitRating.toString Clean, "Clean")
|] |]
|} |}
|> adminView "post-edit" next ctx |> makeHash |> adminView "post-edit" next ctx
| Some _ -> return! Error.notAuthorized next ctx | Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
} }
@ -269,13 +266,12 @@ let delete postId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
let editPermalinks postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { let editPermalinks postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post when canEdit post.AuthorId ctx -> | Some post when canEdit post.AuthorId ctx ->
return! return! {|
Hash.FromAnonymousObject {|
page_title = "Manage Prior Permalinks" page_title = "Manage Prior Permalinks"
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
model = ManagePermalinksModel.fromPost post model = ManagePermalinksModel.fromPost post
|} |}
|> adminView "permalinks" next ctx |> makeHash |> adminView "permalinks" next ctx
| Some _ -> return! Error.notAuthorized next ctx | Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
} }
@ -300,13 +296,12 @@ let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task
let editRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx -> task { let editRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post when canEdit post.AuthorId ctx -> | Some post when canEdit post.AuthorId ctx ->
return! return! {|
Hash.FromAnonymousObject {|
page_title = "Manage Post Revisions" page_title = "Manage Post Revisions"
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
model = ManageRevisionsModel.fromPost ctx.WebLog post model = ManageRevisionsModel.fromPost ctx.WebLog post
|} |}
|> adminView "revisions" next ctx |> makeHash |> adminView "revisions" next ctx
| Some _ -> return! Error.notAuthorized next ctx | Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
} }
@ -338,11 +333,10 @@ let private findPostRevision postId revDate (ctx : HttpContext) = task {
let previewRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task { let previewRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPostRevision postId revDate ctx with match! findPostRevision postId revDate ctx with
| Some post, Some rev when canEdit post.AuthorId ctx -> | Some post, Some rev when canEdit post.AuthorId ctx ->
return! return! {|
Hash.FromAnonymousObject {|
content = $"""<div class="mwl-revision-preview mb-3">{MarkupText.toHtml rev.Text}</div>""" content = $"""<div class="mwl-revision-preview mb-3">{MarkupText.toHtml rev.Text}</div>"""
|} |}
|> adminBareView "" next ctx |> makeHash |> adminBareView "" next ctx
| Some _, Some _ -> return! Error.notAuthorized next ctx | Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _ | None, _
| _, None -> return! Error.notFound next ctx | _, None -> return! Error.notFound next ctx
@ -370,7 +364,7 @@ let deleteRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fu
| Some post, Some rev when canEdit post.AuthorId ctx -> | Some post, Some rev when canEdit post.AuthorId ctx ->
do! ctx.Data.Post.Update { post with Revisions = post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) } do! ctx.Data.Post.Update { post with Revisions = post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) }
do! addMessage ctx { UserMessage.success with Message = "Revision deleted successfully" } do! addMessage ctx { UserMessage.success with Message = "Revision deleted successfully" }
return! adminBareView "" next ctx (Hash.FromAnonymousObject {| content = "" |}) return! adminBareView "" next ctx (makeHash {| content = "" |})
| Some _, Some _ -> return! Error.notAuthorized next ctx | Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _ | None, _
| _, None -> return! Error.notFound next ctx | _, None -> return! Error.notFound next ctx
@ -382,13 +376,12 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data let data = ctx.Data
let now = DateTime.UtcNow let now = DateTime.UtcNow
let tryPost = let tryPost =
if model.IsNew then Task.FromResult ( if model.IsNew then
Some
{ Post.empty with { Post.empty with
Id = PostId.create () Id = PostId.create ()
WebLogId = ctx.WebLog.Id WebLogId = ctx.WebLog.Id
AuthorId = ctx.UserId AuthorId = ctx.UserId
}) } |> someTask
else data.Post.FindFullById (PostId model.PostId) ctx.WebLog.Id else data.Post.FindFullById (PostId model.PostId) ctx.WebLog.Id
match! tryPost with match! tryPost with
| Some post when canEdit post.AuthorId ctx -> | Some post when canEdit post.AuthorId ctx ->

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

@ -8,7 +8,6 @@ open MyWebLog
/// Module to resolve routes that do not match any other known route (web blog content) /// Module to resolve routes that do not match any other known route (web blog content)
module CatchAll = module CatchAll =
open DotLiquid
open MyWebLog.ViewModels open MyWebLog.ViewModels
/// 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
@ -30,22 +29,23 @@ module CatchAll =
match data.Post.FindByPermalink permalink webLog.Id |> await with match data.Post.FindByPermalink permalink webLog.Id |> await with
| Some post -> | Some post ->
debug (fun () -> "Found post by permalink") debug (fun () -> "Found post by permalink")
let model = Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 ctx data |> await let hash = Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 ctx data |> await
model.Add ("page_title", post.Title) yield fun next ctx ->
yield fun next ctx -> themedView (defaultArg post.Template "single-post") next ctx model addToHash "page_title" post.Title hash
|> themedView (defaultArg post.Template "single-post") next ctx
| None -> () | None -> ()
// Current page // Current page
match data.Page.FindByPermalink permalink webLog.Id |> await with match data.Page.FindByPermalink permalink webLog.Id |> await with
| Some page -> | Some page ->
debug (fun () -> "Found page by permalink") debug (fun () -> "Found page by permalink")
yield fun next ctx -> yield fun next ctx ->
Hash.FromAnonymousObject {| {|
page_title = page.Title page_title = page.Title
page = DisplayPage.fromPage webLog page page = DisplayPage.fromPage webLog page
categories = CategoryCache.get ctx categories = CategoryCache.get ctx
is_page = true is_page = true
|} |}
|> themedView (defaultArg page.Template "single-page") next ctx |> makeHash |> themedView (defaultArg page.Template "single-page") next ctx
| None -> () | None -> ()
// RSS feed // RSS feed
match Feed.deriveFeedType ctx textLink with match Feed.deriveFeedType ctx textLink with
@ -150,7 +150,9 @@ let router : HttpHandler = choose [
]) ])
subRoute "/user" (choose [ subRoute "/user" (choose [
route "s" >=> User.all route "s" >=> User.all
route "s/bare" >=> User.bare
route "/my-info" >=> User.myInfo route "/my-info" >=> User.myInfo
routef "/%s/edit" User.edit
]) ])
] ]
POST >=> validateCsrf >=> choose [ POST >=> validateCsrf >=> choose [
@ -194,6 +196,7 @@ let router : HttpHandler = choose [
]) ])
subRoute "/user" (choose [ subRoute "/user" (choose [
route "/my-info" >=> User.saveMyInfo route "/my-info" >=> User.saveMyInfo
route "/save" >=> User.save
]) ])
] ]
]) ])

23
src/MyWebLog/Handlers/Upload.fs
View File

@ -3,10 +3,7 @@ module MyWebLog.Handlers.Upload
open System open System
open System.IO open System.IO
open Giraffe
open Microsoft.AspNetCore.Http
open Microsoft.Net.Http.Headers open Microsoft.Net.Http.Headers
open MyWebLog
/// Helper functions for this module /// Helper functions for this module
[<AutoOpen>] [<AutoOpen>]
@ -30,6 +27,11 @@ module private Helpers =
let uploadDir = Path.Combine ("wwwroot", "upload") let uploadDir = Path.Combine ("wwwroot", "upload")
// ~~ SERVING UPLOADS ~~
open Giraffe
open Microsoft.AspNetCore.Http
/// Determine if the file has been modified since the date/time specified by the If-Modified-Since header /// Determine if the file has been modified since the date/time specified by the If-Modified-Since header
let checkModified since (ctx : HttpContext) : HttpHandler option = let checkModified since (ctx : HttpContext) : HttpHandler option =
match ctx.Request.Headers.IfModifiedSince with match ctx.Request.Headers.IfModifiedSince with
@ -53,6 +55,8 @@ let sendFile updatedOn path (data : byte[]) : HttpHandler = fun next ctx ->
streamData true stream None (Some (DateTimeOffset updatedOn)) next ctx streamData true stream None (Some (DateTimeOffset updatedOn)) next ctx
open MyWebLog
// GET /upload/{web-log-slug}/{**path} // GET /upload/{web-log-slug}/{**path}
let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task { let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog let webLog = ctx.WebLog
@ -75,10 +79,9 @@ let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task {
return! Error.notFound next ctx return! Error.notFound next ctx
} }
// ADMIN // ~~ ADMINISTRATION ~~
open System.Text.RegularExpressions open System.Text.RegularExpressions
open DotLiquid
open MyWebLog.ViewModels open MyWebLog.ViewModels
/// Turn a string into a lowercase URL-safe slug /// Turn a string into a lowercase URL-safe slug
@ -116,23 +119,21 @@ let list : HttpHandler = requireAccess Author >=> fun next ctx -> task {
|> List.append diskUploads |> List.append diskUploads
|> List.sortByDescending (fun file -> file.UpdatedOn, file.Path) |> List.sortByDescending (fun file -> file.UpdatedOn, file.Path)
return! return! {|
Hash.FromAnonymousObject {|
page_title = "Uploaded Files" page_title = "Uploaded Files"
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
files = allFiles files = allFiles
|} |}
|> adminView "upload-list" next ctx |> makeHash |> adminView "upload-list" next ctx
} }
// GET /admin/upload/new // GET /admin/upload/new
let showNew : HttpHandler = requireAccess Author >=> fun next ctx -> let showNew : HttpHandler = requireAccess Author >=> fun next ctx ->
Hash.FromAnonymousObject {| {| page_title = "Upload a File"
page_title = "Upload a File"
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
destination = UploadDestination.toString ctx.WebLog.Uploads destination = UploadDestination.toString ctx.WebLog.Uploads
|} |}
|> adminView "upload-new" next ctx |> makeHash |> adminView "upload-new" next ctx
/// Redirect to the upload list /// Redirect to the upload list

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

@ -13,7 +13,6 @@ let hashedPassword (plainText : string) (email : string) (salt : Guid) =
use alg = new Rfc2898DeriveBytes (plainText, allSalt, 2_048) use alg = new Rfc2898DeriveBytes (plainText, allSalt, 2_048)
Convert.ToBase64String (alg.GetBytes 64) Convert.ToBase64String (alg.GetBytes 64)
open DotLiquid
open Giraffe open Giraffe
open MyWebLog open MyWebLog
open MyWebLog.ViewModels open MyWebLog.ViewModels
@ -24,12 +23,11 @@ let logOn returnUrl : HttpHandler = fun next ctx ->
match returnUrl with match returnUrl with
| Some _ -> returnUrl | Some _ -> returnUrl
| None -> if ctx.Request.Query.ContainsKey "returnUrl" then Some ctx.Request.Query["returnUrl"].[0] else None | None -> if ctx.Request.Query.ContainsKey "returnUrl" then Some ctx.Request.Query["returnUrl"].[0] else None
Hash.FromAnonymousObject {| {| page_title = "Log On"
page_title = "Log On"
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
model = { LogOnModel.empty with ReturnTo = returnTo } model = { LogOnModel.empty with ReturnTo = returnTo }
|} |}
|> adminView "log-on" next ctx |> makeHash |> adminView "log-on" next ctx
open System.Security.Claims open System.Security.Claims
@ -73,22 +71,100 @@ let logOff : HttpHandler = fun next ctx -> task {
// ~~ ADMINISTRATION ~~ // ~~ ADMINISTRATION ~~
// GET /admin/users open System.Collections.Generic
let all : HttpHandler = fun next ctx -> task { open DotLiquid
let data = ctx.Data open Giraffe.Htmx
let! tmpl = TemplateCache.get "admin" "user-list-body" data open Microsoft.AspNetCore.Http
let! users = data.WebLogUser.FindByWebLog ctx.WebLog.Id
let hash = Hash.FromAnonymousObject {| /// Create the hash needed to display the user list
let private userListHash (ctx : HttpContext) = task {
let! users = ctx.Data.WebLogUser.FindByWebLog ctx.WebLog.Id
return makeHash {|
page_title = "User Administration" page_title = "User Administration"
csrf = ctx.CsrfTokenSet csrf = ctx.CsrfTokenSet
web_log = ctx.WebLog web_log = ctx.WebLog
users = users |> List.map (DisplayUser.fromUser ctx.WebLog) |> Array.ofList users = users |> List.map (DisplayUser.fromUser ctx.WebLog) |> Array.ofList
|} |}
}
// GET /admin/users
let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! hash = userListHash ctx
let! tmpl = TemplateCache.get "admin" "user-list-body" ctx.Data
return! return!
addToHash "user_list" (tmpl.Render hash) hash addToHash "user_list" (tmpl.Render hash) hash
|> adminView "user-list" next ctx |> adminView "user-list" next ctx
} }
// GET /admin/users/bare
let bare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! hash = userListHash ctx
return! adminBareView "user-list-body" next ctx hash
}
/// Show the edit user page
let private showEdit (hash : Hash) : HttpHandler = fun next ctx ->
addToHash "page_title" (if (hash["model"] :?> EditUserModel).IsNew then "Add a New User" else "Edit User") hash
|> addToHash "csrf" ctx.CsrfTokenSet
|> addToHash "access_levels"
[| KeyValuePair.Create (AccessLevel.toString Author, "Author")
KeyValuePair.Create (AccessLevel.toString Editor, "Editor")
KeyValuePair.Create (AccessLevel.toString WebLogAdmin, "Web Log Admin")
if ctx.HasAccessLevel Administrator then
KeyValuePair.Create (AccessLevel.toString Administrator, "Administrator")
|]
|> adminBareView "user-edit" next ctx
// GET /admin/user/{id}/edit
let edit usrId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let isNew = usrId = "new"
let userId = WebLogUserId usrId
let tryUser =
if isNew then someTask { WebLogUser.empty with Id = userId }
else ctx.Data.WebLogUser.FindById userId ctx.WebLog.Id
match! tryUser with
| Some user -> return! showEdit (makeHash {| model = EditUserModel.fromUser user |}) next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/user/save
let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditUserModel> ()
let data = ctx.Data
let tryUser =
if model.IsNew then
{ WebLogUser.empty with
Id = WebLogUserId.create ()
WebLogId = ctx.WebLog.Id
CreatedOn = DateTime.UtcNow
} |> someTask
else data.WebLogUser.FindById (WebLogUserId model.Id) ctx.WebLog.Id
match! tryUser with
| Some user when model.Password = model.PasswordConfirm ->
let updatedUser = model.UpdateUser user
if updatedUser.AccessLevel = Administrator && not (ctx.HasAccessLevel Administrator) then
return! RequestErrors.BAD_REQUEST "really?" next ctx
else
let updatedUser =
if model.Password = "" then updatedUser
else
let salt = Guid.NewGuid ()
{ updatedUser with PasswordHash = hashedPassword model.Password model.Email salt; Salt = salt }
do! (if model.IsNew then data.WebLogUser.Add else data.WebLogUser.Update) updatedUser
do! addMessage ctx
{ UserMessage.success with
Message = $"""{if model.IsNew then "Add" else "Updat"}ed user successfully"""
}
return! bare next ctx
| Some _ ->
do! addMessage ctx { UserMessage.error with Message = "The passwords did not match; nothing saved" }
return!
(withHxRetarget $"#user_{model.Id}"
>=> showEdit (makeHash {| model = { model with Password = ""; PasswordConfirm = "" } |}))
next ctx
| None -> return! Error.notFound next ctx
}
/// Display the user "my info" page, with information possibly filled in /// Display the user "my info" page, with information possibly filled in
let private showMyInfo (user : WebLogUser) (hash : Hash) : HttpHandler = fun next ctx -> let private showMyInfo (user : WebLogUser) (hash : Hash) : HttpHandler = fun next ctx ->
addToHash "page_title" "Edit Your Information" hash addToHash "page_title" "Edit Your Information" hash
@ -102,7 +178,7 @@ let private showMyInfo (user : WebLogUser) (hash : Hash) : HttpHandler = fun nex
// GET /admin/user/my-info // GET /admin/user/my-info
let myInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { let myInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with match! ctx.Data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with
| Some user -> return! showMyInfo user (Hash.FromAnonymousObject {| model = EditMyInfoModel.fromUser user |}) next ctx | Some user -> return! showMyInfo user (makeHash {| model = EditMyInfoModel.fromUser user |}) next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
} }
@ -132,8 +208,7 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
return! redirectToGet "admin/user/my-info" next ctx return! redirectToGet "admin/user/my-info" next ctx
| Some user -> | Some user ->
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" }
return! showMyInfo user (Hash.FromAnonymousObject {| return! showMyInfo user (makeHash {| model = { model with NewPassword = ""; NewPasswordConfirm = "" } |})
model = { model with NewPassword = ""; NewPasswordConfirm = "" } next ctx
|}) next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
} }

4
src/MyWebLog/Maintenance.fs
View File

@ -305,8 +305,8 @@ module Backup =
let! uploads = data.Upload.FindByWebLogWithData webLog.Id let! uploads = data.Upload.FindByWebLogWithData webLog.Id
printfn "- Writing archive..." printfn "- Writing archive..."
let archive = { let archive =
WebLog = webLog { WebLog = webLog
Users = users Users = users
Theme = Option.get theme Theme = Option.get theme
Assets = assets |> List.map EncodedAsset.fromAsset Assets = assets |> List.map EncodedAsset.fromAsset

95
src/admin-theme/user-edit.liquid Normal file
View File

@ -0,0 +1,95 @@
<div class="col-12">
<h5 class="my-3">{{ page_title }}</h5>
<form hx-post="{{ "admin/user/save" | relative_link }}" method="post" class="container"
hx-target="#userList" hx-swap="outerHTML show:window:top">
<input type="hidden" name="{{ csrf.form_field_name }}" value="{{ csrf.request_token }}">
<input type="hidden" name="Id" value="{{ model.id }}">
<div class="row">
<div class="col-12 col-md-5 col-lg-3 col-xxl-2 offset-xxl-1 mb-3">
<div class="form-floating">
<select name="AccessLevel" id="accessLevel" class="form-control" required>
{%- for level in access_levels %}
<option value="{{ level[0] }}"{% if model.access_level == level[0] %} selected{% endif %}>
{{ level[1] }}
</option>
{%- endfor %}
</select>
<label for="accessLevel">Access Level</label>
</div>
</div>
<div class="col-12 col-md-7 col-lg-4 col-xxl-3 mb-3">
<div class="form-floating">
<input type="email" name="Email" id="email" class="form-control" placeholder="E-mail" required
value="{{ model.email | escape }}">
<label for="email">E-mail Address</label>
</div>
</div>
<div class="col-12 col-lg-5 mb-3">
<div class="form-floating">
<input type="text" name="Url" id="url" class="form-control" placeholder="URL"
value="{{ model.url | escape }}">
<label for="url">User&rsquo;s Personal URL</label>
</div>
</div>
</div>
<div class="row mb-3">
<div class="col-12 col-md-6 col-lg-4 col-xl-3 offset-xl-1 pb-3">
<div class="form-floating">
<input type="text" name="FirstName" id="firstName" class="form-control" placeholder="First" required
value="{{ model.first_name | escape }}">
<label for="firstName">First Name</label>
</div>
</div>
<div class="col-12 col-md-6 col-lg-4 col-xl-3 pb-3">
<div class="form-floating">
<input type="text" name="LastName" id="lastName" class="form-control" placeholder="Last" required
value="{{ model.last_name | escape }}">
<label for="lastName">Last Name</label>
</div>
</div>
<div class="col-12 col-md-6 offset-md-3 col-lg-4 offset-lg-0 col-xl-3 offset-xl-1 pb-3">
<div class="form-floating">
<input type="text" name="PreferredName" id="preferredName" class="form-control"
placeholder="Preferred" required value="{{ model.preferred_name | escape }}">
<label for="preferredName">Preferred Name</label>
</div>
</div>
</div>
<div class="row mb-3">
<div class="col-12 col-xl-10 offset-xl-1">
<fieldset class="p-2">
<legend class="ps-1">{% unless model.is_new %}Change {% endunless %}Password</legend>
{% unless model.is_new %}
<div class="row">
<div class="col">
<p class="form-text">Optional; leave blank not change the user&rsquo;s password</p>
</div>
</div>
{% endunless %}
<div class="row">
<div class="col-12 col-md-6 pb-3">
<div class="form-floating">
<input type="password" name="Password" id="password" class="form-control"
placeholder="Password"{% if model.is_new %} required{% endif %}>
<label for="password">{% unless model.is_new %}New {% endunless %}Password</label>
</div>
</div>
<div class="col-12 col-md-6 pb-3">
<div class="form-floating">
<input type="password" name="PasswordConfirm" id="passwordConfirm" class="form-control"
placeholder="Confirm"{% if model.is_new %} required{% endif %}>
<label for="passwordConfirm">Confirm{% unless model.is_new %} New{% endunless %} Password</label>
</div>
</div>
</div>
</fieldset>
</div>
</div>
<div class="row mb-3">
<div class="col text-center">
<button type="submit" class="btn btn-sm btn-primary">Save Changes</button>
<a href="{{ "admin/users/bare" | relative_link }}" class="btn btn-sm btn-secondary ms-3">Cancel</a>
</div>
</div>
</form>
</div>