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

Delete user / admin clean-up (#19)

Browse Source 
- Add CLI help (#22)
- Add constants for common view items
- Construct hashes with piped functions
This commit is contained in:
Daniel J. Summers 2022-07-21 21:42:38 -04:00
parent 59f385122b
commit 99ccdebcc7
13 changed files with 499 additions and 302 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/MyWebLog.Data/Interfaces.fs
View File

@ -255,6 +255,9 @@ type IWebLogUserData =
/// Add a web log user
abstract member Add : WebLogUser -> Task<unit>
/// Delete a web log user
abstract member Delete : WebLogUserId -> WebLogId -> Task<Result<bool, string>>
/// Find a web log user by their e-mail address
abstract member FindByEmail : email : string -> WebLogId -> Task<WebLogUser option>

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

@ -955,6 +955,44 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
write; withRetryDefault; ignoreResult conn
}
member _.FindById userId webLogId =
rethink<WebLogUser> {
withTable Table.WebLogUser
get userId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun u -> u.WebLogId) <| conn
member this.Delete userId webLogId = backgroundTask {
match! this.FindById userId webLogId with
| Some _ ->
let! pageCount = rethink<int> {
withTable Table.Page
getAll [ webLogId ] (nameof Page.empty.WebLogId)
filter (nameof Page.empty.AuthorId) userId
count
result; withRetryDefault conn
}
let! postCount = rethink<int> {
withTable Table.Post
getAll [ webLogId ] (nameof Post.empty.WebLogId)
filter (nameof Post.empty.AuthorId) userId
count
result; withRetryDefault conn
}
if pageCount + postCount > 0 then
return Result.Error "User has pages or posts; cannot delete"
else
do! rethink {
withTable Table.WebLogUser
get userId
delete
write; withRetryDefault; ignoreResult conn
}
return Ok true
| None -> return Result.Error "User does not exist"
}
member _.FindByEmail email webLogId =
rethink<WebLogUser list> {
withTable Table.WebLogUser
@ -964,17 +1002,10 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
}
|> tryFirst <| conn
member _.FindById userId webLogId =
rethink<WebLogUser> {
withTable Table.WebLogUser
get userId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun u -> u.WebLogId) <| conn
member _.FindByWebLog webLogId = rethink<WebLogUser list> {
withTable Table.WebLogUser
getAll [ webLogId ] (nameof WebLogUser.empty.WebLogId)
orderByFunc (fun row -> row[nameof WebLogUser.empty.PreferredName].Downcase ())
result; withRetryDefault conn
}

40
src/MyWebLog.Data/SQLite/SQLiteWebLogUserData.fs
View File

@ -43,6 +43,34 @@ type SQLiteWebLogUserData (conn : SqliteConnection) =
do! write cmd
}
/// Find a user by their ID for the given web log
let findById userId webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM web_log_user WHERE id = @id"
cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString userId) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return Helpers.verifyWebLog<WebLogUser> webLogId (fun u -> u.WebLogId) Map.toWebLogUser rdr
}
/// Delete a user if they have no posts or pages
let delete userId webLogId = backgroundTask {
match! findById userId webLogId with
| Some _ ->
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT COUNT(id) FROM page WHERE author_id = @userId"
cmd.Parameters.AddWithValue ("@userId", WebLogUserId.toString userId) |> ignore
let! pageCount = count cmd
cmd.CommandText <- "SELECT COUNT(id) FROM post WHERE author_id = @userId"
let! postCount = count cmd
if pageCount + postCount > 0 then
return Error "User has pages or posts; cannot delete"
else
cmd.CommandText <- "DELETE FROM web_log_user WHERE id = @userId"
let! _ = cmd.ExecuteNonQueryAsync ()
return Ok true
| None -> return Error "User does not exist"
}
/// Find a user by their e-mail address for the given web log
let findByEmail (email : string) webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
@ -53,19 +81,10 @@ type SQLiteWebLogUserData (conn : SqliteConnection) =
return if rdr.Read () then Some (Map.toWebLogUser rdr) else None
}
/// Find a user by their ID for the given web log
let findById userId webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM web_log_user WHERE id = @id"
cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString userId) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return Helpers.verifyWebLog<WebLogUser> webLogId (fun u -> u.WebLogId) Map.toWebLogUser rdr
}
/// Get all users for the given web log
let findByWebLog webLogId = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT * FROM web_log_user WHERE web_log_id = @webLogId"
cmd.CommandText <- "SELECT * FROM web_log_user WHERE web_log_id = @webLogId ORDER BY LOWER(preferred_name)"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
return toList Map.toWebLogUser rdr
@ -133,6 +152,7 @@ type SQLiteWebLogUserData (conn : SqliteConnection) =
interface IWebLogUserData with
member _.Add user = add user
member _.Delete userId webLogId = delete userId webLogId
member _.FindByEmail email webLogId = findByEmail email webLogId
member _.FindById userId webLogId = findById userId webLogId
member _.FindByWebLog webLogId = findByWebLog webLogId

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

@ -18,17 +18,16 @@ let dashboard : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let topCats = getCount data.Category.CountTopLevel
let! _ = Task.WhenAll (posts, drafts, pages, listed, cats, topCats)
return!
{| page_title = "Dashboard"
model =
{ Posts = posts.Result
Drafts = drafts.Result
Pages = pages.Result
ListedPages = listed.Result
Categories = cats.Result
TopLevelCategories = topCats.Result
}
|}
|> makeHash |> adminView "dashboard" next ctx
hashForPage "Dashboard"
|> addToHash ViewContext.Model {
Posts = posts.Result
Drafts = drafts.Result
Pages = pages.Result
ListedPages = listed.Result
Categories = cats.Result
TopLevelCategories = topCats.Result
}
|> adminView "dashboard" next ctx
}
// -- CATEGORIES --
@ -36,12 +35,10 @@ let dashboard : HttpHandler = requireAccess Author >=> fun next ctx -> task {
// GET /admin/categories
let listCategories : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! catListTemplate = TemplateCache.get "admin" "category-list-body" ctx.Data
let hash = makeHash {|
page_title = "Categories"
csrf = ctx.CsrfTokenSet
web_log = ctx.WebLog
categories = CategoryCache.get ctx
|}
let! hash =
hashForPage "Categories"
|> withAntiCsrf ctx
|> addViewContext ctx
return!
addToHash "category_list" (catListTemplate.Render hash) hash
|> adminView "category-list" next ctx
@ -49,10 +46,9 @@ let listCategories : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
// GET /admin/categories/bare
let listCategoriesBare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
{| categories = CategoryCache.get ctx
csrf = ctx.CsrfTokenSet
|}
|> makeHash |> adminBareView "category-list-body" next ctx
hashForPage "Categories"
|> withAntiCsrf ctx
|> adminBareView "category-list-body" next ctx
// GET /admin/category/{id}/edit
@ -67,13 +63,11 @@ let editCategory catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ct
}
match result with
| Some (title, cat) ->
return! {|
page_title = title
csrf = ctx.CsrfTokenSet
model = EditCategoryModel.fromCategory cat
categories = CategoryCache.get ctx
|}
|> makeHash |> adminBareView "category-edit" next ctx
return!
hashForPage title
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (EditCategoryModel.fromCategory cat)
|> adminBareView "category-edit" next ctx
| None -> return! Error.notFound next ctx
}
@ -117,12 +111,12 @@ open Microsoft.AspNetCore.Http
/// Get the hash necessary to render the tag mapping list
let private tagMappingHash (ctx : HttpContext) = task {
let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id
return makeHash {|
csrf = ctx.CsrfTokenSet
web_log = ctx.WebLog
mappings = mappings
mapping_ids = mappings |> List.map (fun it -> { Name = it.Tag; Value = TagMapId.toString it.Id })
|}
return!
hashForPage "Tag Mappings"
|> withAntiCsrf ctx
|> addToHash "mappings" mappings
|> addToHash "mapping_ids" (mappings |> List.map (fun it -> { Name = it.Tag; Value = TagMapId.toString it.Id }))
|> addViewContext ctx
}
// GET /admin/settings/tag-mappings
@ -131,7 +125,6 @@ let tagMappings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> ta
let! listTemplate = TemplateCache.get "admin" "tag-mapping-list-body" ctx.Data
return!
addToHash "tag_mapping_list" (listTemplate.Render hash) hash
|> addToHash "page_title" "Tag Mappings"
|> adminView "tag-mapping-list" next ctx
}
@ -149,12 +142,11 @@ let editMapping tagMapId : HttpHandler = requireAccess WebLogAdmin >=> fun next
else ctx.Data.TagMap.FindById (TagMapId tagMapId) ctx.WebLog.Id
match! tagMap with
| Some tm ->
return! {|
page_title = if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag"
csrf = ctx.CsrfTokenSet
model = EditTagMapModel.fromMapping tm
|}
|> makeHash |> adminBareView "tag-mapping-edit" next ctx
return!
hashForPage (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag")
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (EditTagMapModel.fromMapping tm)
|> adminBareView "tag-mapping-edit" next ctx
| None -> return! Error.notFound next ctx
}
@ -191,10 +183,9 @@ open MyWebLog.Data
// GET /admin/theme/update
let themeUpdatePage : HttpHandler = requireAccess Administrator >=> fun next ctx ->
{| page_title = "Upload Theme"
csrf = ctx.CsrfTokenSet
|}
|> makeHash |> adminView "upload-theme" next ctx
hashForPage "Upload Theme"
|> withAntiCsrf ctx
|> adminView "upload-theme" next ctx
/// Update the name and version for a theme based on the version.txt file, if present
let private updateNameAndVersion (theme : Theme) (zip : ZipArchive) = backgroundTask {
@ -244,9 +235,9 @@ let private updateAssets themeId (zip : ZipArchive) (data : IData) = backgroundT
use stream = new MemoryStream ()
do! asset.Open().CopyToAsync stream
do! data.ThemeAsset.Save
{ Id = ThemeAssetId (themeId, assetName)
UpdatedOn = asset.LastWriteTime.DateTime
Data = stream.ToArray ()
{ Id = ThemeAssetId (themeId, assetName)
UpdatedOn = asset.LastWriteTime.DateTime
Data = stream.ToArray ()
}
}
@ -303,28 +294,28 @@ let settings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task
let data = ctx.Data
let! allPages = data.Page.All ctx.WebLog.Id
let! themes = data.Theme.All ()
return! {|
page_title = "Web Log Settings"
csrf = ctx.CsrfTokenSet
model = SettingsModel.fromWebLog ctx.WebLog
pages = seq
{ KeyValuePair.Create ("posts", "- First Page of Posts -")
return!
hashForPage "Web Log Settings"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (SettingsModel.fromWebLog ctx.WebLog)
|> addToHash "pages" (
seq {
KeyValuePair.Create ("posts", "- First Page of Posts -")
yield! allPages
|> List.sortBy (fun p -> p.Title.ToLower ())
|> List.map (fun p -> KeyValuePair.Create (PageId.toString p.Id, p.Title))
}
|> Array.ofSeq
themes =
|> Array.ofSeq)
|> addToHash "themes" (
themes
|> Seq.ofList
|> Seq.map (fun it -> KeyValuePair.Create (ThemeId.toString it.Id, $"{it.Name} (v{it.Version})"))
|> Array.ofSeq
upload_values = [|
|> Seq.ofList
|> Seq.map (fun it -> KeyValuePair.Create (ThemeId.toString it.Id, $"{it.Name} (v{it.Version})"))
|> Array.ofSeq)
|> addToHash "upload_values" [|
KeyValuePair.Create (UploadDestination.toString Database, "Database")
KeyValuePair.Create (UploadDestination.toString Disk, "Disk")
|]
|}
|> makeHash |> adminView "settings" next ctx
|> adminView "settings" next ctx
}
// POST /admin/settings

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

@ -416,16 +416,14 @@ let generate (feedType : FeedType) postCount : HttpHandler = fun next ctx -> bac
// GET /admin/settings/rss
let editSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
let feeds =
hashForPage "RSS Settings"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (EditRssModel.fromRssOptions ctx.WebLog.Rss)
|> addToHash "custom_feeds" (
ctx.WebLog.Rss.CustomFeeds
|> List.map (DisplayCustomFeed.fromFeed (CategoryCache.get ctx))
|> Array.ofList
{| page_title = "RSS Settings"
csrf = ctx.CsrfTokenSet
model = EditRssModel.fromRssOptions ctx.WebLog.Rss
custom_feeds = feeds
|}
|> makeHash |> adminView "rss-settings" next ctx
|> Array.ofList)
|> adminView "rss-settings" next ctx
// POST /admin/settings/rss
let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
@ -449,22 +447,20 @@ let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next
| _ -> ctx.WebLog.Rss.CustomFeeds |> List.tryFind (fun f -> f.Id = CustomFeedId feedId)
match customFeed with
| Some f ->
{| page_title = $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed"""
csrf = ctx.CsrfTokenSet
model = EditCustomFeedModel.fromFeed f
categories = CategoryCache.get ctx
medium_values = [|
KeyValuePair.Create ("", "&ndash; Unspecified &ndash;")
KeyValuePair.Create (PodcastMedium.toString Podcast, "Podcast")
KeyValuePair.Create (PodcastMedium.toString Music, "Music")
KeyValuePair.Create (PodcastMedium.toString Video, "Video")
KeyValuePair.Create (PodcastMedium.toString Film, "Film")
KeyValuePair.Create (PodcastMedium.toString Audiobook, "Audiobook")
KeyValuePair.Create (PodcastMedium.toString Newsletter, "Newsletter")
KeyValuePair.Create (PodcastMedium.toString Blog, "Blog")
|]
|}
|> makeHash |> adminView "custom-feed-edit" next ctx
hashForPage $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed"""
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (EditCustomFeedModel.fromFeed f)
|> addToHash "medium_values" [|
KeyValuePair.Create ("", "&ndash; Unspecified &ndash;")
KeyValuePair.Create (PodcastMedium.toString Podcast, "Podcast")
KeyValuePair.Create (PodcastMedium.toString Music, "Music")
KeyValuePair.Create (PodcastMedium.toString Video, "Video")
KeyValuePair.Create (PodcastMedium.toString Film, "Film")
KeyValuePair.Create (PodcastMedium.toString Audiobook, "Audiobook")
KeyValuePair.Create (PodcastMedium.toString Newsletter, "Newsletter")
KeyValuePair.Create (PodcastMedium.toString Blog, "Blog")
|]
|> adminView "custom-feed-edit" next ctx
| None -> Error.notFound next ctx
// POST /admin/settings/rss/save

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

@ -12,12 +12,117 @@ type ISession with
this.SetString (key, JsonSerializer.Serialize item)
/// Get an item from the session
member this.Get<'T> key =
member this.TryGet<'T> key =
match this.GetString key with
| null -> None
| item -> Some (JsonSerializer.Deserialize<'T> item)
/// Keys used in the myWebLog-standard DotLiquid hash
module ViewContext =
/// The anti cross-site request forgery (CSRF) token set to use for form submissions
[<Literal>]
let AntiCsrfTokens = "csrf"
/// The categories for this web log
[<Literal>]
let Categories = "categories"
/// The main content of the view
[<Literal>]
let Content = "content"
/// The current page URL
[<Literal>]
let CurrentPage = "current_page"
/// The generator string for the current version of myWebLog
[<Literal>]
let Generator = "generator"
/// The HTML to load htmx from the unpkg CDN
[<Literal>]
let HtmxScript = "htmx_script"
/// Whether the current user has Administrator privileges
[<Literal>]
let IsAdministrator = "is_administrator"
/// Whether the current user has Author (or above) privileges
[<Literal>]
let IsAuthor = "is_author"
/// Whether the current view is displaying a category archive page
[<Literal>]
let IsCategory = "is_category"
/// Whether the current view is displaying the first page of a category archive
[<Literal>]
let IsCategoryHome = "is_category_home"
/// Whether the current user has Editor (or above) privileges
[<Literal>]
let IsEditor = "is_editor"
/// Whether the current view is the home page for the web log
[<Literal>]
let IsHome = "is_home"
/// Whether there is a user logged on
[<Literal>]
let IsLoggedOn = "is_logged_on"
/// Whether the current view is displaying a page
[<Literal>]
let IsPage = "is_page"
/// Whether the current view is displaying a post
[<Literal>]
let IsPost = "is_post"
/// Whether the current view is a tag archive page
[<Literal>]
let IsTag = "is_tag"
/// Whether the current view is the first page of a tag archive
[<Literal>]
let IsTagHome = "is_tag_home"
/// Whether the current user has Web Log Admin (or above) privileges
[<Literal>]
let IsWebLogAdmin = "is_web_log_admin"
/// Messages to be displayed to the user
[<Literal>]
let Messages = "messages"
/// The view model / form for the page
[<Literal>]
let Model = "model"
/// The listed pages for the web log
[<Literal>]
let PageList = "page_list"
/// The title of the page being displayed
[<Literal>]
let PageTitle = "page_title"
/// The slug for category or tag archive pages
[<Literal>]
let Slug = "slug"
/// The ID of the current user
[<Literal>]
let UserId = "user_id"
/// The current web log
[<Literal>]
let WebLog = "web_log"
/// The HTTP item key for loading the session
let private sessionLoadedKey = "session-loaded"
@ -38,34 +143,41 @@ open MyWebLog.ViewModels
/// Add a message to the user's session
let addMessage (ctx : HttpContext) message = task {
do! loadSession ctx
let msg = match ctx.Session.Get<UserMessage list> "messages" with Some it -> it | None -> []
ctx.Session.Set ("messages", message :: msg)
let msg = match ctx.Session.TryGet<UserMessage list> ViewContext.Messages with Some it -> it | None -> []
ctx.Session.Set (ViewContext.Messages, message :: msg)
}
/// Get any messages from the user's session, removing them in the process
let messages (ctx : HttpContext) = task {
do! loadSession ctx
match ctx.Session.Get<UserMessage list> "messages" with
match ctx.Session.TryGet<UserMessage list> ViewContext.Messages with
| Some msg ->
ctx.Session.Remove "messages"
ctx.Session.Remove ViewContext.Messages
return msg |> (List.rev >> Array.ofList)
| None -> return [||]
}
open System.Collections.Generic
open MyWebLog
open DotLiquid
/// Shorthand for creating a DotLiquid hash from an anonymous object
let makeHash (values : obj) =
Hash.FromAnonymousObject values
/// Create a hash with the page title filled
let hashForPage (title : string) =
makeHash {| page_title = title |}
/// 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)
let addToHash key (value : obj) (hash : Hash) =
if hash.ContainsKey key then hash[key] <- value else hash.Add (key, value)
hash
/// Add anti-CSRF tokens to the given hash
let withAntiCsrf (ctx : HttpContext) =
addToHash ViewContext.AntiCsrfTokens ctx.CsrfTokenSet
open System.Security.Claims
open Giraffe
open Giraffe.Htmx
@ -75,27 +187,31 @@ open Giraffe.ViewEngine
let private htmxScript = RenderView.AsString.htmlNode Htmx.Script.minified
/// Populate the DotLiquid hash with standard information
let private populateHash hash ctx = task {
let addViewContext ctx (hash : Hash) = task {
let! messages = messages ctx
do! commitSession ctx
ctx.User.Claims
|> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.NameIdentifier)
|> Option.map (fun claim -> claim.Value)
|> Option.iter (fun userId -> addToHash "user_id" userId hash |> ignore)
return
addToHash "web_log" ctx.WebLog hash
|> addToHash "page_list" (PageListCache.get ctx)
|> addToHash "current_page" ctx.Request.Path.Value[1..]
|> addToHash "messages" messages
|> addToHash "generator" ctx.Generator
|> addToHash "htmx_script" htmxScript
|> addToHash "is_logged_on" ctx.User.Identity.IsAuthenticated
|> addToHash "is_author" (ctx.HasAccessLevel Author)
|> addToHash "is_editor" (ctx.HasAccessLevel Editor)
|> addToHash "is_web_log_admin" (ctx.HasAccessLevel WebLogAdmin)
|> addToHash "is_administrator" (ctx.HasAccessLevel Administrator)
if hash.ContainsKey ViewContext.HtmxScript && hash.ContainsKey ViewContext.Messages then
// We have already populated everything; just update messages
hash[ViewContext.Messages] <- Array.concat [ hash[ViewContext.Messages] :?> UserMessage[]; messages ]
hash
else
ctx.User.Claims
|> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.NameIdentifier)
|> Option.map (fun claim -> addToHash ViewContext.UserId claim.Value hash)
|> Option.defaultValue hash
|> addToHash ViewContext.WebLog ctx.WebLog
|> addToHash ViewContext.PageList (PageListCache.get ctx)
|> addToHash ViewContext.Categories (CategoryCache.get ctx)
|> addToHash ViewContext.CurrentPage ctx.Request.Path.Value[1..]
|> addToHash ViewContext.Messages messages
|> addToHash ViewContext.Generator ctx.Generator
|> addToHash ViewContext.HtmxScript htmxScript
|> addToHash ViewContext.IsLoggedOn ctx.User.Identity.IsAuthenticated
|> addToHash ViewContext.IsAuthor (ctx.HasAccessLevel Author)
|> addToHash ViewContext.IsEditor (ctx.HasAccessLevel Editor)
|> addToHash ViewContext.IsWebLogAdmin (ctx.HasAccessLevel WebLogAdmin)
|> addToHash ViewContext.IsAdministrator (ctx.HasAccessLevel Administrator)
}
/// Is the request from htmx?
@ -104,16 +220,14 @@ let isHtmx (ctx : HttpContext) =
/// Render a view for the specified theme, using the specified template, layout, and hash
let viewForTheme themeId template next ctx (hash : Hash) = task {
if not (hash.ContainsKey "htmx_script") then
let! _ = populateHash hash ctx
()
let! hash = addViewContext ctx hash
let (ThemeId theme) = themeId
// NOTE: DotLiquid does not support {% render %} or {% include %} in its templates, so we will do a 2-pass render;
// the net effect is a "layout" capability similar to Razor or Pug
// Render view content...
let! contentTemplate = TemplateCache.get theme template ctx.Data
let _ = addToHash "content" (contentTemplate.Render hash) hash
let _ = addToHash ViewContext.Content (contentTemplate.Render hash) hash
// ...then render that content with its layout
let! layoutTemplate = TemplateCache.get theme (if isHtmx ctx then "layout-partial" else "layout") ctx.Data
@ -137,24 +251,25 @@ let messagesToHeaders (messages : UserMessage array) : HttpHandler =
/// Render a bare view for the specified theme, using the specified template and hash
let bareForTheme themeId template next ctx (hash : Hash) = task {
let! hash = populateHash hash ctx
let! hash = addViewContext ctx hash
let (ThemeId theme) = themeId
if not (hash.ContainsKey "content") then
if not (hash.ContainsKey ViewContext.Content) then
let! contentTemplate = TemplateCache.get theme template ctx.Data
addToHash "content" (contentTemplate.Render hash) hash |> ignore
addToHash ViewContext.Content (contentTemplate.Render hash) hash |> ignore
// Bare templates are rendered with layout-bare
let! layoutTemplate = TemplateCache.get theme "layout-bare" ctx.Data
return!
(messagesToHeaders (hash["messages"] :?> UserMessage[]) >=> htmlString (layoutTemplate.Render hash)) next ctx
(messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage[])
>=> htmlString (layoutTemplate.Render hash))
next ctx
}
/// Return a view for the web log's default theme
let themedView template next ctx hash = task {
let! hash = populateHash hash ctx
return! viewForTheme (hash["web_log"] :?> WebLog).ThemeId template next ctx hash
let! hash = addViewContext ctx hash
return! viewForTheme (hash[ViewContext.WebLog] :?> WebLog).ThemeId template next ctx hash
}
/// Display a view for the admin theme
@ -171,7 +286,7 @@ let redirectToGet url : HttpHandler = fun _ ctx -> task {
return! redirectTo false (WebLog.relativeUrl ctx.WebLog (Permalink url)) earlyReturn ctx
}
/// Validate the cross-site request forgery token in the current request
/// Validate the anti cross-site request forgery token in the current request
let validateCsrf : HttpHandler = fun next ctx -> task {
match! ctx.AntiForgery.IsRequestValidAsync ctx with
| true -> return! next ctx

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

@ -9,15 +9,14 @@ open MyWebLog.ViewModels
// GET /admin/pages/page/{pageNbr}
let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! pages = ctx.Data.Page.FindPageOfPages ctx.WebLog.Id pageNbr
return! {|
page_title = "Pages"
csrf = ctx.CsrfTokenSet
pages = pages |> List.map (DisplayPage.fromPageMinimal ctx.WebLog)
page_nbr = pageNbr
prev_page = if pageNbr = 2 then "" else $"/page/{pageNbr - 1}"
next_page = $"/page/{pageNbr + 1}"
|}
|> makeHash |> adminView "page-list" next ctx
return!
hashForPage "Pages"
|> withAntiCsrf ctx
|> addToHash "pages" (pages |> List.map (DisplayPage.fromPageMinimal ctx.WebLog))
|> addToHash "page_nbr" pageNbr
|> addToHash "prev_page" (if pageNbr = 2 then "" else $"/page/{pageNbr - 1}")
|> addToHash "next_page" $"/page/{pageNbr + 1}"
|> adminView "page-list" next ctx
}
// GET /admin/page/{id}/edit
@ -34,15 +33,15 @@ let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
| Some (title, page) when canEdit page.AuthorId ctx ->
let model = EditPageModel.fromPage page
let! templates = templatesForTheme ctx "page"
return! {|
page_title = title
csrf = ctx.CsrfTokenSet
model = model
metadata = Array.zip model.MetaNames model.MetaValues
|> Array.mapi (fun idx (name, value) -> [| string idx; name; value |])
templates = templates
|}
|> makeHash |> adminView "page-edit" next ctx
return!
hashForPage title
|> withAntiCsrf ctx
|> addToHash ViewContext.Model model
|> addToHash "metadata" (
Array.zip model.MetaNames model.MetaValues
|> Array.mapi (fun idx (name, value) -> [| string idx; name; value |]))
|> addToHash "templates" templates
|> adminView "page-edit" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@ -61,12 +60,11 @@ let delete pgId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> ta
let editPermalinks pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg when canEdit pg.AuthorId ctx ->
return! {|
page_title = "Manage Prior Permalinks"
csrf = ctx.CsrfTokenSet
model = ManagePermalinksModel.fromPage pg
|}
|> makeHash |> adminView "permalinks" next ctx
return!
hashForPage "Manage Prior Permalinks"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (ManagePermalinksModel.fromPage pg)
|> adminView "permalinks" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@ -91,12 +89,11 @@ let savePermalinks : 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
| Some pg when canEdit pg.AuthorId ctx ->
return! {|
page_title = "Manage Page Revisions"
csrf = ctx.CsrfTokenSet
model = ManageRevisionsModel.fromPage ctx.WebLog pg
|}
|> makeHash |> adminView "revisions" next ctx
return!
hashForPage "Manage Page Revisions"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (ManageRevisionsModel.fromPage ctx.WebLog pg)
|> adminView "revisions" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}

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

@ -39,7 +39,7 @@ open MyWebLog.Data
open MyWebLog.ViewModels
/// Convert a list of posts into items ready to be displayed
let preparePostList webLog posts listType (url : string) pageNbr perPage ctx (data : IData) = task {
let preparePostList webLog posts listType (url : string) pageNbr perPage (data : IData) = task {
let! authors = getAuthors webLog posts data
let! tagMappings = getTagMappings webLog posts data
let relUrl it = Some <| WebLog.relativeUrl webLog (Permalink it)
@ -85,12 +85,11 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage ctx (da
OlderLink = olderLink
OlderName = olderPost |> Option.map (fun p -> p.Title)
}
return makeHash {|
model = model
categories = CategoryCache.get ctx
tag_mappings = tagMappings
is_post = match listType with SinglePost -> true | _ -> false
|}
return
makeHash {||}
|> addToHash ViewContext.Model model
|> addToHash "tag_mappings" tagMappings
|> addToHash ViewContext.IsPost (match listType with SinglePost -> true | _ -> false)
}
open Giraffe
@ -100,15 +99,18 @@ let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
let count = ctx.WebLog.PostsPerPage
let data = ctx.Data
let! posts = data.Post.FindPageOfPublishedPosts ctx.WebLog.Id pageNbr count
let! hash = preparePostList ctx.WebLog posts PostList "" pageNbr count ctx data
let! hash = preparePostList ctx.WebLog posts PostList "" pageNbr count data
let title =
match pageNbr, ctx.WebLog.DefaultPage with
| 1, "posts" -> None
| _, "posts" -> Some $"Page {pageNbr}"
| _, _ -> Some $"Page {pageNbr} &laquo; Posts"
match title with Some ttl -> hash.Add ("page_title", ttl) | None -> ()
if pageNbr = 1 && ctx.WebLog.DefaultPage = "posts" then hash.Add ("is_home", true)
return! themedView "index" next ctx hash
return!
match title with Some ttl -> addToHash ViewContext.PageTitle ttl hash | None -> hash
|> function
| hash ->
if pageNbr = 1 && ctx.WebLog.DefaultPage = "posts" then addToHash ViewContext.IsHome true hash else hash
|> themedView "index" next ctx
}
// GET /page/{pageNbr}/
@ -131,14 +133,14 @@ let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task {
match! data.Post.FindPageOfCategorizedPosts webLog.Id (getCategoryIds slug ctx) pageNbr webLog.PostsPerPage
with
| posts when List.length posts > 0 ->
let! hash = preparePostList webLog posts CategoryList cat.Slug pageNbr webLog.PostsPerPage ctx data
let! hash = preparePostList webLog posts CategoryList cat.Slug pageNbr webLog.PostsPerPage data
let pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
return!
addToHash "page_title" $"{cat.Name}: Category Archive{pgTitle}" hash
|> addToHash "subtitle" (defaultArg cat.Description "")
|> addToHash "is_category" true
|> addToHash "is_category_home" (pageNbr = 1)
|> addToHash "slug" slug
addToHash ViewContext.PageTitle $"{cat.Name}: Category Archive{pgTitle}" hash
|> addToHash "subtitle" (defaultArg cat.Description "")
|> addToHash ViewContext.IsCategory true
|> addToHash ViewContext.IsCategoryHome (pageNbr = 1)
|> addToHash ViewContext.Slug slug
|> themedView "index" next ctx
| _ -> return! Error.notFound next ctx
| None -> return! Error.notFound next ctx
@ -166,13 +168,13 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
else
match! data.Post.FindPageOfTaggedPosts webLog.Id tag pageNbr webLog.PostsPerPage with
| posts when List.length posts > 0 ->
let! hash = preparePostList webLog posts TagList rawTag pageNbr webLog.PostsPerPage ctx data
let! hash = preparePostList webLog posts TagList rawTag pageNbr webLog.PostsPerPage data
let pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
return!
addToHash "page_title" $"Posts Tagged &ldquo;{tag}&rdquo;{pgTitle}" hash
|> addToHash "is_tag" true
|> addToHash "is_tag_home" (pageNbr = 1)
|> addToHash "slug" rawTag
addToHash ViewContext.PageTitle $"Posts Tagged &ldquo;{tag}&rdquo;{pgTitle}" hash
|> addToHash ViewContext.IsTag true
|> addToHash ViewContext.IsTagHome (pageNbr = 1)
|> addToHash ViewContext.Slug rawTag
|> themedView "index" next ctx
// Other systems use hyphens for spaces; redirect if this is an old tag link
| _ ->
@ -196,13 +198,11 @@ let home : HttpHandler = fun next ctx -> task {
| pageId ->
match! ctx.Data.Page.FindById (PageId pageId) webLog.Id with
| Some page ->
return! {|
page_title = page.Title
page = DisplayPage.fromPage webLog page
categories = CategoryCache.get ctx
is_home = true
|}
|> makeHash |> themedView (defaultArg page.Template "single-page") next ctx
return!
hashForPage page.Title
|> addToHash "page" (DisplayPage.fromPage webLog page)
|> addToHash ViewContext.IsHome true
|> themedView (defaultArg page.Template "single-page") next ctx
| None -> return! Error.notFound next ctx
}
@ -211,10 +211,10 @@ let home : HttpHandler = fun next ctx -> task {
let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data
let! posts = data.Post.FindPageOfPosts ctx.WebLog.Id pageNbr 25
let! hash = preparePostList ctx.WebLog posts AdminList "" pageNbr 25 ctx data
let! hash = preparePostList ctx.WebLog posts AdminList "" pageNbr 25 data
return!
addToHash "page_title" "Posts" hash
|> addToHash "csrf" ctx.CsrfTokenSet
addToHash ViewContext.PageTitle "Posts" hash
|> withAntiCsrf ctx
|> adminView "post-list" next ctx
}
@ -231,25 +231,23 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
}
match result with
| Some (title, post) when canEdit post.AuthorId ctx ->
let! cats = data.Category.FindAllForView ctx.WebLog.Id
let! templates = templatesForTheme ctx "post"
let model = EditPostModel.fromPost ctx.WebLog post
return! {|
page_title = title
csrf = ctx.CsrfTokenSet
model = model
metadata = Array.zip model.MetaNames model.MetaValues
|> Array.mapi (fun idx (name, value) -> [| string idx; name; value |])
templates = templates
categories = cats
explicit_values = [|
return!
hashForPage title
|> withAntiCsrf ctx
|> addToHash ViewContext.Model model
|> addToHash "metadata" (
Array.zip model.MetaNames model.MetaValues
|> Array.mapi (fun idx (name, value) -> [| string idx; name; value |]))
|> addToHash "templates" templates
|> addToHash "explicit_values" [|
KeyValuePair.Create ("", "&ndash; Default &ndash;")
KeyValuePair.Create (ExplicitRating.toString Yes, "Yes")
KeyValuePair.Create (ExplicitRating.toString No, "No")
KeyValuePair.Create (ExplicitRating.toString Clean, "Clean")
|]
|}
|> makeHash |> adminView "post-edit" next ctx
|> adminView "post-edit" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@ -266,12 +264,11 @@ let delete postId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
let editPermalinks postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post when canEdit post.AuthorId ctx ->
return! {|
page_title = "Manage Prior Permalinks"
csrf = ctx.CsrfTokenSet
model = ManagePermalinksModel.fromPost post
|}
|> makeHash |> adminView "permalinks" next ctx
return!
hashForPage "Manage Prior Permalinks"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (ManagePermalinksModel.fromPost post)
|> adminView "permalinks" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@ -296,12 +293,11 @@ let savePermalinks : 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
| Some post when canEdit post.AuthorId ctx ->
return! {|
page_title = "Manage Post Revisions"
csrf = ctx.CsrfTokenSet
model = ManageRevisionsModel.fromPost ctx.WebLog post
|}
|> makeHash |> adminView "revisions" next ctx
return!
hashForPage "Manage Post Revisions"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (ManageRevisionsModel.fromPost ctx.WebLog post)
|> adminView "revisions" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}

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

@ -29,9 +29,9 @@ module CatchAll =
match data.Post.FindByPermalink permalink webLog.Id |> await with
| Some post ->
debug (fun () -> "Found post by permalink")
let hash = Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 ctx data |> await
let hash = Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 data |> await
yield fun next ctx ->
addToHash "page_title" post.Title hash
addToHash ViewContext.PageTitle post.Title hash
|> themedView (defaultArg post.Template "single-post") next ctx
| None -> ()
// Current page
@ -39,13 +39,10 @@ module CatchAll =
| Some page ->
debug (fun () -> "Found page by permalink")
yield fun next ctx ->
{|
page_title = page.Title
page = DisplayPage.fromPage webLog page
categories = CategoryCache.get ctx
is_page = true
|}
|> makeHash |> themedView (defaultArg page.Template "single-page") next ctx
hashForPage page.Title
|> addToHash "page" (DisplayPage.fromPage webLog page)
|> addToHash ViewContext.IsPage true
|> themedView (defaultArg page.Template "single-page") next ctx
| None -> ()
// RSS feed
match Feed.deriveFeedType ctx textLink with
@ -195,8 +192,9 @@ let router : HttpHandler = choose [
routef "/%s/delete" Upload.deleteFromDb
])
subRoute "/user" (choose [
route "/my-info" >=> User.saveMyInfo
route "/save" >=> User.save
route "/my-info" >=> User.saveMyInfo
route "/save" >=> User.save
routef "/%s/delete" User.delete
])
]
])

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

@ -118,22 +118,19 @@ let list : HttpHandler = requireAccess Author >=> fun next ctx -> task {
|> List.map (DisplayUpload.fromUpload webLog Database)
|> List.append diskUploads
|> List.sortByDescending (fun file -> file.UpdatedOn, file.Path)
return! {|
page_title = "Uploaded Files"
csrf = ctx.CsrfTokenSet
files = allFiles
|}
|> makeHash |> adminView "upload-list" next ctx
return!
hashForPage "Uploaded Files"
|> withAntiCsrf ctx
|> addToHash "files" allFiles
|> adminView "upload-list" next ctx
}
// GET /admin/upload/new
let showNew : HttpHandler = requireAccess Author >=> fun next ctx ->
{| page_title = "Upload a File"
csrf = ctx.CsrfTokenSet
destination = UploadDestination.toString ctx.WebLog.Uploads
|}
|> makeHash |> adminView "upload-new" next ctx
hashForPage "Upload a File"
|> withAntiCsrf ctx
|> addToHash "destination" (UploadDestination.toString ctx.WebLog.Uploads)
|> adminView "upload-new" next ctx
/// Redirect to the upload list

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

@ -23,11 +23,10 @@ let logOn returnUrl : HttpHandler = fun next ctx ->
match returnUrl with
| Some _ -> returnUrl
| None -> if ctx.Request.Query.ContainsKey "returnUrl" then Some ctx.Request.Query["returnUrl"].[0] else None
{| page_title = "Log On"
csrf = ctx.CsrfTokenSet
model = { LogOnModel.empty with ReturnTo = returnTo }
|}
|> makeHash |> adminView "log-on" next ctx
hashForPage "Log On"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model { LogOnModel.empty with ReturnTo = returnTo }
|> adminView "log-on" next ctx
open System.Security.Claims
@ -72,21 +71,22 @@ let logOff : HttpHandler = fun next ctx -> task {
// ~~ ADMINISTRATION ~~
open System.Collections.Generic
open DotLiquid
open Giraffe.Htmx
open Microsoft.AspNetCore.Http
/// 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"
csrf = ctx.CsrfTokenSet
web_log = ctx.WebLog
users = users |> List.map (DisplayUser.fromUser ctx.WebLog) |> Array.ofList
|}
return!
hashForPage "User Administration"
|> withAntiCsrf ctx
|> addToHash "users" (users |> List.map (DisplayUser.fromUser ctx.WebLog) |> Array.ofList)
|> addViewContext ctx
}
/// Got no time for URL/form manipulators...
let private goAway : HttpHandler = RequestErrors.BAD_REQUEST "really?"
// GET /admin/users
let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! hash = userListHash ctx
@ -103,16 +103,17 @@ let bare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
}
/// 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")
|]
let private showEdit (model : EditUserModel) : HttpHandler = fun next ctx ->
hashForPage (if model.IsNew then "Add a New User" else "Edit User")
|> withAntiCsrf ctx
|> addToHash ViewContext.Model model
|> 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
@ -123,7 +124,7 @@ let edit usrId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> tas
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
| Some user -> return! showEdit (EditUserModel.fromUser user) next ctx
| None -> return! Error.notFound next ctx
}
@ -143,7 +144,7 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
| 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
return! goAway next ctx
else
let updatedUser =
if model.Password = "" then updatedUser
@ -159,26 +160,51 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
| 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 = "" } |}))
(withHxRetarget $"#user_{model.Id}" >=> showEdit { model with Password = ""; PasswordConfirm = "" })
next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/user/{id}/delete
let delete userId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data
match! data.WebLogUser.FindById (WebLogUserId userId) ctx.WebLog.Id with
| Some user ->
if user.AccessLevel = Administrator && not (ctx.HasAccessLevel Administrator) then
return! goAway next ctx
else
match! data.WebLogUser.Delete user.Id user.WebLogId with
| Ok _ ->
do! addMessage ctx
{ UserMessage.success with
Message = $"User {WebLogUser.displayName user} deleted successfully"
}
return! bare next ctx
| Error msg ->
do! addMessage ctx
{ UserMessage.error with
Message = $"User {WebLogUser.displayName user} was not deleted"
Detail = Some msg
}
return! bare next ctx
| None -> return! Error.notFound next ctx
}
/// Display the user "my info" page, with information possibly filled in
let private showMyInfo (user : WebLogUser) (hash : Hash) : HttpHandler = fun next ctx ->
addToHash "page_title" "Edit Your Information" hash
|> addToHash "csrf" ctx.CsrfTokenSet
|> addToHash "access_level" (AccessLevel.toString user.AccessLevel)
|> addToHash "created_on" (WebLog.localTime ctx.WebLog user.CreatedOn)
|> addToHash "last_seen_on" (WebLog.localTime ctx.WebLog (defaultArg user.LastSeenOn DateTime.UnixEpoch))
let private showMyInfo (model : EditMyInfoModel) (user : WebLogUser) : HttpHandler = fun next ctx ->
hashForPage "Edit Your Information"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model model
|> addToHash "access_level" (AccessLevel.toString user.AccessLevel)
|> addToHash "created_on" (WebLog.localTime ctx.WebLog user.CreatedOn)
|> addToHash "last_seen_on" (WebLog.localTime ctx.WebLog (defaultArg user.LastSeenOn DateTime.UnixEpoch))
|> adminView "my-info" next ctx
// GET /admin/user/my-info
let myInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with
| Some user -> return! showMyInfo user (makeHash {| model = EditMyInfoModel.fromUser user |}) next ctx
| Some user -> return! showMyInfo (EditMyInfoModel.fromUser user) user next ctx
| None -> return! Error.notFound next ctx
}
@ -208,7 +234,6 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
return! redirectToGet "admin/user/my-info" next ctx
| Some user ->
do! addMessage ctx { UserMessage.error with Message = "Passwords did not match; no updates made" }
return! showMyInfo user (makeHash {| model = { model with NewPassword = ""; NewPasswordConfirm = "" } |})
next ctx
return! showMyInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user next ctx
| None -> return! Error.notFound next ctx
}

30
src/MyWebLog/Program.fs
View File

@ -46,7 +46,7 @@ module DataImplementation =
let createSQLite connStr =
let log = sp.GetRequiredService<ILogger<SQLiteData>> ()
let conn = new SqliteConnection (connStr)
log.LogInformation $"Using SQL database {conn.DataSource}"
log.LogInformation $"Using SQLite database {conn.DataSource}"
await (SQLiteData.setUpConnection conn)
SQLiteData (conn, log)
@ -62,6 +62,26 @@ module DataImplementation =
upcast createSQLite "Data Source=./myweblog.db;Cache=Shared"
open System.Threading.Tasks
/// Show a list of valid command-line interface commands
let showHelp () =
printfn " "
printfn "COMMAND WHAT IT DOES"
printfn "----------- ------------------------------------------------------"
printfn "backup Create a JSON file backup of a web log"
printfn "do-restore Restore a JSON file backup (overwrite data silently)"
printfn "help Display this information"
printfn "import-links Import prior permalinks"
printfn "init Initializes a new web log"
printfn "load-theme Load a theme"
printfn "restore Restore a JSON file backup (prompt before overwriting)"
printfn "upgrade-user Upgrade a WebLogAdmin user to a full Administrator"
printfn " "
printfn "For more information on a particular command, run it with no options."
Task.FromResult ()
open Giraffe
open Giraffe.EndpointRouting
open Microsoft.AspNetCore.Authentication.Cookies
@ -138,7 +158,11 @@ let rec main args =
| Some it when it = "restore" -> Maintenance.Backup.restoreFromBackup args app.Services
| Some it when it = "do-restore" -> Maintenance.Backup.restoreFromBackup args app.Services
| Some it when it = "upgrade-user" -> Maintenance.upgradeUser args app.Services
| _ ->
| Some it when it = "help" -> showHelp ()
| Some it ->
printfn $"""Unrecognized command "{it}" - valid commands are:"""
showHelp ()
| None ->
let _ = app.UseForwardedHeaders ()
let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict))
let _ = app.UseMiddleware<WebLogMiddleware> ()
@ -148,7 +172,7 @@ let rec main args =
let _ = app.UseSession ()
let _ = app.UseGiraffe Handlers.Routes.endpoint
System.Threading.Tasks.Task.FromResult (app.Run ())
Task.FromResult (app.Run ())
|> Async.AwaitTask |> Async.RunSynchronously
0 // Exit code

30
src/admin-theme/user-list-body.liquid
View File

@ -19,19 +19,23 @@
{%- elsif user.access_level == "Author" %}
<span class="{{ badge }}-dark">AUTHOR</span>
{%- endif %}<br>
<small>
{%- assign user_url_base = "admin/user/" | append: user.id -%}
<a href="{{ user_url_base | append: "/edit" | relative_link }}" hx-target="#user_{{ user.id }}"
hx-swap="innerHTML show:#user_{{ user.id }}:top">
Edit
</a>
<span class="text-muted"> &bull; </span>
{%- assign user_del_link = user_url_base | append: "/delete" | relative_link -%}
<a href="{{ user_del_link }}" hx-post="{{ user_del_link }}" class="text-danger"
hx-confirm="Are you sure you want to delete the category &ldquo;{{ cat.name }}&rdquo;? This action cannot be undone. (This action will not succeed if the user has authored any posts or pages.)">
Delete
</a>
</small>
{%- unless is_administrator == false and user.access_level == "Administrator" %}
<small>
{%- assign user_url_base = "admin/user/" | append: user.id -%}
<a href="{{ user_url_base | append: "/edit" | relative_link }}" hx-target="#user_{{ user.id }}"
hx-swap="innerHTML show:#user_{{ user.id }}:top">
Edit
</a>
{% unless user_id == user.id %}
<span class="text-muted"> &bull; </span>
{%- assign user_del_link = user_url_base | append: "/delete" | relative_link -%}
<a href="{{ user_del_link }}" hx-post="{{ user_del_link }}" class="text-danger"
hx-confirm="Are you sure you want to delete the user &ldquo;{{ user.preferred_name }}&rdquo;? This action cannot be undone. (This action will not succeed if the user has authored any posts or pages.)">
Delete
</a>
{% endunless %}
</small>
{%- endunless %}
</div>
<div class="{{ email_col }}">
{{ user.first_name }} {{ user.last_name }}<br>