Delete user / admin clean-up (#19)
- Add CLI help (#22) - Add constants for common view items - Construct hashes with piped functions
This commit is contained in:
parent
59f385122b
commit
99ccdebcc7
@ -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>
|
||||
|
||||
|
@ -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
|
||||
}
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
}
|
||||
|
@ -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} « 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 “{tag}”{pgTitle}" hash
|
||||
|> addToHash "is_tag" true
|
||||
|> addToHash "is_tag_home" (pageNbr = 1)
|
||||
|> addToHash "slug" rawTag
|
||||
addToHash ViewContext.PageTitle $"Posts Tagged “{tag}”{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 ("", "– Default –")
|
||||
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
|
||||
}
|
||||
|
@ -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
|
||||
])
|
||||
]
|
||||
])
|
||||
|
@ -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
|
||||
|
@ -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 ->
|
||||