bit-badger/myWebLog
1
0
Fork 0
Code Issues 4 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
Download Patch File Download Diff File Expand all files Collapse all files

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 ("", "– Unspecified –")
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 ("", "– Unspecified –")
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