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

Version 2.1 (#41)

Browse Source 
- Add full chapter support (#6)
- Add built-in redirect functionality (#39)
- Support building Docker containers for release (#38)
- Support canonical domain configuration (#37)
- Add unit tests for domain/models and integration tests for all three data stores
- Convert SQLite storage to use JSON documents, similar to PostgreSQL
- Convert admin templates to Giraffe View Engine (from Liquid)
- Add .NET 8 support
This commit was merged in pull request #41.
This commit is contained in:
Daniel J. Summers
2024-03-26 20:13:28 -04:00
committed by GitHub
parent 7b325dc19e
commit f1a7e55f3e
116 changed files with 14807 additions and 8249 deletions
Download Patch File Download Diff File Expand all files Collapse all files

98
src/MyWebLog/Caches.fs
View File

@@ -13,25 +13,25 @@ module Extensions =
open Microsoft.Extensions.DependencyInjection
/// Hold variable for the configured generator string
let mutable private generatorString : string option = None
let mutable private generatorString: string option = None
type HttpContext with
/// The anti-CSRF service
member this.AntiForgery = this.RequestServices.GetRequiredService<IAntiforgery> ()
member this.AntiForgery = this.RequestServices.GetRequiredService<IAntiforgery>()
/// The cross-site request forgery token set for this request
member this.CsrfTokenSet = this.AntiForgery.GetAndStoreTokens this
/// The data implementation
member this.Data = this.RequestServices.GetRequiredService<IData> ()
member this.Data = this.RequestServices.GetRequiredService<IData>()
/// The generator string
member this.Generator =
match generatorString with
| Some gen -> gen
| None ->
let cfg = this.RequestServices.GetRequiredService<IConfiguration> ()
let cfg = this.RequestServices.GetRequiredService<IConfiguration>()
generatorString <-
match Option.ofObj cfg["Generator"] with
| Some gen -> Some gen
@@ -42,7 +42,7 @@ module Extensions =
member this.UserAccessLevel =
this.User.Claims
|> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.Role)
|> Option.map (fun claim -> AccessLevel.parse claim.Value)
|> Option.map (fun claim -> AccessLevel.Parse claim.Value)
/// The user ID for the current request
member this.UserId =
@@ -53,7 +53,7 @@ module Extensions =
/// Does the current user have the requested level of access?
member this.HasAccessLevel level =
defaultArg (this.UserAccessLevel |> Option.map (AccessLevel.hasAccess level)) false
defaultArg (this.UserAccessLevel |> Option.map _.HasAccess(level)) false
open System.Collections.Concurrent
@@ -65,30 +65,56 @@ open System.Collections.Concurrent
/// settings update page</remarks>
module WebLogCache =
open System.Text.RegularExpressions
/// A redirect rule that caches compiled regular expression rules
type CachedRedirectRule =
/// A straight text match rule
| Text of string * string
/// A regular expression match rule
| RegEx of Regex * string
/// The cache of web log details
let mutable private _cache : WebLog list = []
/// Redirect rules with compiled regular expressions
let mutable private _redirectCache = ConcurrentDictionary<WebLogId, CachedRedirectRule list> ()
/// Try to get the web log for the current request (longest matching URL base wins)
let tryGet (path : string) =
_cache
|> List.filter (fun wl -> path.StartsWith wl.UrlBase)
|> List.sortByDescending (fun wl -> wl.UrlBase.Length)
|> List.sortByDescending _.UrlBase.Length
|> List.tryHead
/// Cache the web log for a particular host
let set webLog =
_cache <- webLog :: (_cache |> List.filter (fun wl -> wl.Id <> webLog.Id))
_redirectCache[webLog.Id] <-
webLog.RedirectRules
|> List.map (fun it ->
let relUrl = Permalink >> webLog.RelativeUrl
let urlTo = if it.To.Contains "://" then it.To else relUrl it.To
if it.IsRegex then
let pattern = if it.From.StartsWith "^" then $"^{relUrl it.From[1..]}" else it.From
RegEx(Regex(pattern, RegexOptions.Compiled ||| RegexOptions.IgnoreCase), urlTo)
else
Text(relUrl it.From, urlTo))
/// Get all cached web logs
let all () =
_cache
/// Fill the web log cache from the database
let fill (data : IData) = backgroundTask {
let! webLogs = data.WebLog.All ()
_cache <- webLogs
let fill (data: IData) = backgroundTask {
let! webLogs = data.WebLog.All()
webLogs |> List.iter set
}
/// Get the cached redirect rules for the given web log
let redirectRules webLogId =
_redirectCache[webLogId]
/// Is the given theme in use by any web logs?
let isThemeInUse themeId =
_cache |> List.exists (fun wl -> wl.ThemeId = themeId)
@@ -100,28 +126,28 @@ module PageListCache =
open MyWebLog.ViewModels
/// Cache of displayed pages
let private _cache = ConcurrentDictionary<WebLogId, DisplayPage[]> ()
let private _cache = ConcurrentDictionary<WebLogId, DisplayPage array> ()
let private fillPages (webLog : WebLog) pages =
let private fillPages (webLog: WebLog) pages =
_cache[webLog.Id] <-
pages
|> List.map (fun pg -> DisplayPage.fromPage webLog { pg with Text = "" })
|> List.map (fun pg -> DisplayPage.FromPage webLog { pg with Text = "" })
|> Array.ofList
/// Are there pages cached for this web log?
let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.Id
let exists (ctx: HttpContext) = _cache.ContainsKey ctx.WebLog.Id
/// Get the pages for the web log for this request
let get (ctx : HttpContext) = _cache[ctx.WebLog.Id]
let get (ctx: HttpContext) = _cache[ctx.WebLog.Id]
/// Update the pages for the current web log
let update (ctx : HttpContext) = backgroundTask {
let update (ctx: HttpContext) = backgroundTask {
let! pages = ctx.Data.Page.FindListed ctx.WebLog.Id
fillPages ctx.WebLog pages
}
/// Refresh the pages for the given web log
let refresh (webLog : WebLog) (data : IData) = backgroundTask {
let refresh (webLog: WebLog) (data: IData) = backgroundTask {
let! pages = data.Page.FindListed webLog.Id
fillPages webLog pages
}
@@ -133,22 +159,22 @@ module CategoryCache =
open MyWebLog.ViewModels
/// The cache itself
let private _cache = ConcurrentDictionary<WebLogId, DisplayCategory[]> ()
let private _cache = ConcurrentDictionary<WebLogId, DisplayCategory array> ()
/// Are there categories cached for this web log?
let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.Id
let exists (ctx: HttpContext) = _cache.ContainsKey ctx.WebLog.Id
/// Get the categories for the web log for this request
let get (ctx : HttpContext) = _cache[ctx.WebLog.Id]
let get (ctx: HttpContext) = _cache[ctx.WebLog.Id]
/// Update the cache with fresh data
let update (ctx : HttpContext) = backgroundTask {
let update (ctx: HttpContext) = backgroundTask {
let! cats = ctx.Data.Category.FindAllForView ctx.WebLog.Id
_cache[ctx.WebLog.Id] <- cats
}
/// Refresh the category cache for the given web log
let refresh webLogId (data : IData) = backgroundTask {
let refresh webLogId (data: IData) = backgroundTask {
let! cats = data.Category.FindAllForView webLogId
_cache[webLogId] <- cats
}
@@ -165,11 +191,11 @@ module TemplateCache =
let private _cache = ConcurrentDictionary<string, Template> ()
/// Custom include parameter pattern
let private hasInclude = Regex ("""{% include_template \"(.*)\" %}""", RegexOptions.None, TimeSpan.FromSeconds 2)
let private hasInclude = Regex("""{% include_template \"(.*)\" %}""", RegexOptions.None, TimeSpan.FromSeconds 2)
/// Get a template for the given theme and template name
let get (themeId : ThemeId) (templateName : string) (data : IData) = backgroundTask {
let templatePath = $"{ThemeId.toString themeId}/{templateName}"
let get (themeId: ThemeId) (templateName: string) (data: IData) = backgroundTask {
let templatePath = $"{themeId}/{templateName}"
match _cache.ContainsKey templatePath with
| true -> return Ok _cache[templatePath]
| false ->
@@ -189,16 +215,16 @@ module TemplateCache =
if childNotFound = "" then child.Groups[1].Value
else $"{childNotFound}; {child.Groups[1].Value}"
""
text <- text.Replace (child.Value, childText)
text <- text.Replace(child.Value, childText)
if childNotFound <> "" then
let s = if childNotFound.IndexOf ";" >= 0 then "s" else ""
return Error $"Could not find the child template{s} {childNotFound} required by {templateName}"
else
_cache[templatePath] <- Template.Parse (text, SyntaxCompatibility.DotLiquid22)
_cache[templatePath] <- Template.Parse(text, SyntaxCompatibility.DotLiquid22)
return Ok _cache[templatePath]
| None ->
return Error $"Theme ID {ThemeId.toString themeId} does not have a template named {templateName}"
| None -> return Result.Error $"Theme ID {ThemeId.toString themeId} does not exist"
return Error $"Theme ID {themeId} does not have a template named {templateName}"
| None -> return Error $"Theme ID {themeId} does not exist"
}
/// Get all theme/template names currently cached
@@ -206,16 +232,16 @@ module TemplateCache =
_cache.Keys |> Seq.sort |> Seq.toList
/// Invalidate all template cache entries for the given theme ID
let invalidateTheme (themeId : ThemeId) =
let keyPrefix = ThemeId.toString themeId
let invalidateTheme (themeId: ThemeId) =
let keyPrefix = string themeId
_cache.Keys
|> Seq.filter (fun key -> key.StartsWith keyPrefix)
|> Seq.filter _.StartsWith(keyPrefix)
|> List.ofSeq
|> List.iter (fun key -> match _cache.TryRemove key with _, _ -> ())
/// Remove all entries from the template cache
let empty () =
_cache.Clear ()
_cache.Clear()
/// A cache of asset names by themes
@@ -228,14 +254,14 @@ module ThemeAssetCache =
let get themeId = _cache[themeId]
/// Refresh the list of assets for the given theme
let refreshTheme themeId (data : IData) = backgroundTask {
let refreshTheme themeId (data: IData) = backgroundTask {
let! assets = data.ThemeAsset.FindByTheme themeId
_cache[themeId] <- assets |> List.map (fun a -> match a.Id with ThemeAssetId (_, path) -> path)
}
/// Fill the theme asset cache
let fill (data : IData) = backgroundTask {
let! assets = data.ThemeAsset.All ()
let fill (data: IData) = backgroundTask {
let! assets = data.ThemeAsset.All()
for asset in assets do
let (ThemeAssetId (themeId, path)) = asset.Id
if not (_cache.ContainsKey themeId) then _cache[themeId] <- []

143
src/MyWebLog/DotLiquidBespoke.fs
View File

@@ -7,6 +7,7 @@ open System.Web
open DotLiquid
open Giraffe.ViewEngine
open MyWebLog.ViewModels
open MyWebLog.Views
/// Extensions on the DotLiquid Context object
type Context with
@@ -17,11 +18,11 @@ type Context with
/// Does an asset exist for the current theme?
let assetExists fileName (webLog : WebLog) =
let assetExists fileName (webLog: WebLog) =
ThemeAssetCache.get webLog.ThemeId |> List.exists (fun it -> it = fileName)
/// Obtain the link from known types
let permalink (ctx : Context) (item : obj) (linkFunc : WebLog -> Permalink -> string) =
let permalink (item: obj) (linkFunc: Permalink -> string) =
match item with
| :? String as link -> Some link
| :? DisplayPage as page -> Some page.Permalink
@@ -29,130 +30,130 @@ let permalink (ctx : Context) (item : obj) (linkFunc : WebLog -> Permalink -> st
| :? DropProxy as proxy -> Option.ofObj proxy["Permalink"] |> Option.map string
| _ -> None
|> function
| Some link -> linkFunc ctx.WebLog (Permalink link)
| Some link -> linkFunc (Permalink link)
| None -> $"alert('unknown item type {item.GetType().Name}')"
/// A filter to generate an absolute link
type AbsoluteLinkFilter () =
static member AbsoluteLink (ctx : Context, item : obj) =
permalink ctx item WebLog.absoluteUrl
type AbsoluteLinkFilter() =
static member AbsoluteLink(ctx: Context, item: obj) =
permalink item ctx.WebLog.AbsoluteUrl
/// A filter to generate a link with posts categorized under the given category
type CategoryLinkFilter () =
static member CategoryLink (ctx : Context, catObj : obj) =
type CategoryLinkFilter() =
static member CategoryLink(ctx: Context, catObj: obj) =
match catObj with
| :? DisplayCategory as cat -> Some cat.Slug
| :? DropProxy as proxy -> Option.ofObj proxy["Slug"] |> Option.map string
| _ -> None
|> function
| Some slug -> WebLog.relativeUrl ctx.WebLog (Permalink $"category/{slug}/")
| Some slug -> ctx.WebLog.RelativeUrl(Permalink $"category/{slug}/")
| None -> $"alert('unknown category object type {catObj.GetType().Name}')"
/// A filter to generate a link that will edit a page
type EditPageLinkFilter () =
static member EditPageLink (ctx : Context, pageObj : obj) =
type EditPageLinkFilter() =
static member EditPageLink(ctx: Context, pageObj: obj) =
match pageObj with
| :? DisplayPage as page -> Some page.Id
| :? DropProxy as proxy -> Option.ofObj proxy["Id"] |> Option.map string
| :? String as theId -> Some theId
| _ -> None
|> function
| Some pageId -> WebLog.relativeUrl ctx.WebLog (Permalink $"admin/page/{pageId}/edit")
| Some pageId -> ctx.WebLog.RelativeUrl(Permalink $"admin/page/{pageId}/edit")
| None -> $"alert('unknown page object type {pageObj.GetType().Name}')"
/// A filter to generate a link that will edit a post
type EditPostLinkFilter () =
static member EditPostLink (ctx : Context, postObj : obj) =
type EditPostLinkFilter() =
static member EditPostLink(ctx: Context, postObj: obj) =
match postObj with
| :? PostListItem as post -> Some post.Id
| :? DropProxy as proxy -> Option.ofObj proxy["Id"] |> Option.map string
| :? String as theId -> Some theId
| _ -> None
|> function
| Some postId -> WebLog.relativeUrl ctx.WebLog (Permalink $"admin/post/{postId}/edit")
| Some postId -> ctx.WebLog.RelativeUrl(Permalink $"admin/post/{postId}/edit")
| None -> $"alert('unknown post object type {postObj.GetType().Name}')"
/// A filter to generate nav links, highlighting the active link (exact match)
type NavLinkFilter () =
static member NavLink (ctx : Context, url : string, text : string) =
let _, path = WebLog.hostAndPath ctx.WebLog
let path = if path = "" then path else $"{path.Substring 1}/"
type NavLinkFilter() =
static member NavLink(ctx: Context, url: string, text: string) =
let extraPath = ctx.WebLog.ExtraPath
let path = if extraPath = "" then "" else $"{extraPath[1..]}/"
seq {
"<li class=\"nav-item\"><a class=\"nav-link"
"<li class=nav-item><a class=\"nav-link"
if (string ctx.Environments[0].["current_page"]).StartsWith $"{path}{url}" then " active"
"\" href=\""
WebLog.relativeUrl ctx.WebLog (Permalink url)
ctx.WebLog.RelativeUrl(Permalink url)
"\">"
text
"</a></li>"
"</a>"
}
|> String.concat ""
/// A filter to generate a link for theme asset (image, stylesheet, script, etc.)
type ThemeAssetFilter () =
static member ThemeAsset (ctx : Context, asset : string) =
WebLog.relativeUrl ctx.WebLog (Permalink $"themes/{ThemeId.toString ctx.WebLog.ThemeId}/{asset}")
type ThemeAssetFilter() =
static member ThemeAsset(ctx: Context, asset: string) =
ctx.WebLog.RelativeUrl(Permalink $"themes/{ctx.WebLog.ThemeId}/{asset}")
/// Create various items in the page header based on the state of the page being generated
type PageHeadTag () =
inherit Tag ()
type PageHeadTag() =
inherit Tag()
override this.Render (context : Context, result : TextWriter) =
override this.Render(context: Context, result: TextWriter) =
let webLog = context.WebLog
// spacer
let s = " "
let getBool name =
defaultArg (context.Environments[0].[name] |> Option.ofObj |> Option.map Convert.ToBoolean) false
result.WriteLine $"""<meta name="generator" content="{context.Environments[0].["generator"]}">"""
result.WriteLine $"""<meta name=generator content="{context.Environments[0].["generator"]}">"""
// Theme assets
if assetExists "style.css" webLog then
result.WriteLine $"""{s}<link rel="stylesheet" href="{ThemeAssetFilter.ThemeAsset (context, "style.css")}">"""
result.WriteLine $"""{s}<link rel=stylesheet href="{ThemeAssetFilter.ThemeAsset(context, "style.css")}">"""
if assetExists "favicon.ico" webLog then
result.WriteLine $"""{s}<link rel="icon" href="{ThemeAssetFilter.ThemeAsset (context, "favicon.ico")}">"""
result.WriteLine $"""{s}<link rel=icon href="{ThemeAssetFilter.ThemeAsset(context, "favicon.ico")}">"""
// RSS feeds and canonical URLs
let feedLink title url =
let escTitle = HttpUtility.HtmlAttributeEncode title
let relUrl = WebLog.relativeUrl webLog (Permalink url)
$"""{s}<link rel="alternate" type="application/rss+xml" title="{escTitle}" href="{relUrl}">"""
let relUrl = webLog.RelativeUrl(Permalink url)
$"""{s}<link rel=alternate type="application/rss+xml" title="{escTitle}" href="{relUrl}">"""
if webLog.Rss.IsFeedEnabled && getBool "is_home" then
result.WriteLine (feedLink webLog.Name webLog.Rss.FeedName)
result.WriteLine $"""{s}<link rel="canonical" href="{WebLog.absoluteUrl webLog Permalink.empty}">"""
result.WriteLine(feedLink webLog.Name webLog.Rss.FeedName)
result.WriteLine $"""{s}<link rel=canonical href="{webLog.AbsoluteUrl Permalink.Empty}">"""
if webLog.Rss.IsCategoryEnabled && getBool "is_category_home" then
let slug = context.Environments[0].["slug"] :?> string
result.WriteLine (feedLink webLog.Name $"category/{slug}/{webLog.Rss.FeedName}")
result.WriteLine(feedLink webLog.Name $"category/{slug}/{webLog.Rss.FeedName}")
if webLog.Rss.IsTagEnabled && getBool "is_tag_home" then
let slug = context.Environments[0].["slug"] :?> string
result.WriteLine (feedLink webLog.Name $"tag/{slug}/{webLog.Rss.FeedName}")
result.WriteLine(feedLink webLog.Name $"tag/{slug}/{webLog.Rss.FeedName}")
if getBool "is_post" then
let post = context.Environments[0].["model"] :?> PostDisplay
let url = WebLog.absoluteUrl webLog (Permalink post.Posts[0].Permalink)
result.WriteLine $"""{s}<link rel="canonical" href="{url}">"""
let url = webLog.AbsoluteUrl (Permalink post.Posts[0].Permalink)
result.WriteLine $"""{s}<link rel=canonical href="{url}">"""
if getBool "is_page" then
let page = context.Environments[0].["page"] :?> DisplayPage
let url = WebLog.absoluteUrl webLog (Permalink page.Permalink)
result.WriteLine $"""{s}<link rel="canonical" href="{url}">"""
let url = webLog.AbsoluteUrl (Permalink page.Permalink)
result.WriteLine $"""{s}<link rel=canonical href="{url}">"""
/// Create various items in the page header based on the state of the page being generated
type PageFootTag () =
inherit Tag ()
type PageFootTag() =
inherit Tag()
override this.Render (context : Context, result : TextWriter) =
override this.Render(context: Context, result: TextWriter) =
let webLog = context.WebLog
// spacer
let s = " "
@@ -161,48 +162,48 @@ type PageFootTag () =
result.WriteLine $"{s}{RenderView.AsString.htmlNode Htmx.Script.minified}"
if assetExists "script.js" webLog then
result.WriteLine $"""{s}<script src="{ThemeAssetFilter.ThemeAsset (context, "script.js")}"></script>"""
result.WriteLine $"""{s}<script src="{ThemeAssetFilter.ThemeAsset(context, "script.js")}"></script>"""
/// A filter to generate a relative link
type RelativeLinkFilter () =
static member RelativeLink (ctx : Context, item : obj) =
permalink ctx item WebLog.relativeUrl
type RelativeLinkFilter() =
static member RelativeLink(ctx: Context, item: obj) =
permalink item ctx.WebLog.RelativeUrl
/// A filter to generate a link with posts tagged with the given tag
type TagLinkFilter () =
static member TagLink (ctx : Context, tag : string) =
type TagLinkFilter() =
static member TagLink(ctx: Context, tag: string) =
ctx.Environments[0].["tag_mappings"] :?> TagMap list
|> List.tryFind (fun it -> it.Tag = tag)
|> function
| Some tagMap -> tagMap.UrlValue
| None -> tag.Replace (" ", "+")
|> function tagUrl -> WebLog.relativeUrl ctx.WebLog (Permalink $"tag/{tagUrl}/")
| None -> tag.Replace(" ", "+")
|> function tagUrl -> ctx.WebLog.RelativeUrl(Permalink $"tag/{tagUrl}/")
/// Create links for a user to log on or off, and a dashboard link if they are logged off
type UserLinksTag () =
inherit Tag ()
type UserLinksTag() =
inherit Tag()
override this.Render (context : Context, result : TextWriter) =
let link it = WebLog.relativeUrl context.WebLog (Permalink it)
override this.Render(context: Context, result: TextWriter) =
let link it = context.WebLog.RelativeUrl(Permalink it)
seq {
"""<ul class="navbar-nav flex-grow-1 justify-content-end">"""
match Convert.ToBoolean context.Environments[0].["is_logged_on"] with
| true ->
$"""<li class="nav-item"><a class="nav-link" href="{link "admin/dashboard"}">Dashboard</a></li>"""
$"""<li class="nav-item"><a class="nav-link" href="{link "user/log-off"}">Log Off</a></li>"""
$"""<li class=nav-item><a class=nav-link href="{link "admin/dashboard"}">Dashboard</a>"""
$"""<li class=nav-item><a class=nav-link href="{link "user/log-off"}">Log Off</a>"""
| false ->
$"""<li class="nav-item"><a class="nav-link" href="{link "user/log-on"}">Log On</a></li>"""
$"""<li class=nav-item><a class=nav-link href="{link "user/log-on"}">Log On</a>"""
"</ul>"
}
|> Seq.iter result.WriteLine
/// A filter to retrieve the value of a meta item from a list
// (shorter than `{% assign item = list | where: "Name", [name] | first %}{{ item.value }}`)
type ValueFilter () =
static member Value (_ : Context, items : MetaItem list, name : string) =
type ValueFilter() =
static member Value(_: Context, items: MetaItem list, name: string) =
match items |> List.tryFind (fun it -> it.Name = name) with
| Some item -> item.Value
| None -> $"-- {name} not found --"
@@ -224,15 +225,11 @@ let register () =
Template.RegisterTag<UserLinksTag> "user_links"
[ // Domain types
typeof<CustomFeed>; typeof<Episode>; typeof<Episode option>; typeof<MetaItem>; typeof<Page>
typeof<RssOptions>; typeof<TagMap>; typeof<UploadDestination>; typeof<WebLog>
typeof<CustomFeed>; typeof<Episode>; typeof<Episode option>; typeof<MetaItem>; typeof<Page>; typeof<RssOptions>
typeof<TagMap>; typeof<WebLog>
// View models
typeof<DashboardModel>; typeof<DisplayCategory>; typeof<DisplayCustomFeed>; typeof<DisplayPage>
typeof<DisplayRevision>; typeof<DisplayTheme>; typeof<DisplayUpload>; typeof<DisplayUser>
typeof<EditCategoryModel>; typeof<EditCustomFeedModel>; typeof<EditMyInfoModel>; typeof<EditPageModel>
typeof<EditPostModel>; typeof<EditRssModel>; typeof<EditTagMapModel>; typeof<EditUserModel>
typeof<LogOnModel>; typeof<ManagePermalinksModel>; typeof<ManageRevisionsModel>; typeof<PostDisplay>
typeof<PostListItem>; typeof<SettingsModel>; typeof<UserMessage>
typeof<AppViewContext>; typeof<DisplayCategory>; typeof<DisplayPage>; typeof<EditPageModel>; typeof<PostDisplay>
typeof<PostListItem>; typeof<UserMessage>
// Framework types
typeof<AntiforgeryTokenSet>; typeof<DateTime option>; typeof<int option>; typeof<KeyValuePair>
typeof<MetaItem list>; typeof<string list>; typeof<string option>; typeof<TagMap list>

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

@@ -3,16 +3,17 @@ module MyWebLog.Handlers.Admin
open System.Threading.Tasks
open Giraffe
open Giraffe.Htmx
open MyWebLog
open MyWebLog.ViewModels
open NodaTime
/// ~~ DASHBOARDS ~~
/// ~~~ DASHBOARDS ~~~
module Dashboard =
// GET /admin/dashboard
let user : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let getCount (f : WebLogId -> Task<int>) = f ctx.WebLog.Id
let getCount (f: WebLogId -> Task<int>) = f ctx.WebLog.Id
let data = ctx.Data
let! posts = getCount (data.Post.CountByStatus Published)
let! drafts = getCount (data.Post.CountByStatus Draft)
@@ -20,62 +21,27 @@ module Dashboard =
let! listed = getCount data.Page.CountListed
let! cats = getCount data.Category.CountAll
let! topCats = getCount data.Category.CountTopLevel
return!
hashForPage "Dashboard"
|> addToHash ViewContext.Model {
Posts = posts
Drafts = drafts
Pages = pages
ListedPages = listed
Categories = cats
TopLevelCategories = topCats
}
|> adminView "dashboard" next ctx
let model =
{ Posts = posts
Drafts = drafts
Pages = pages
ListedPages = listed
Categories = cats
TopLevelCategories = topCats }
return! adminPage "Dashboard" false next ctx (Views.WebLog.dashboard model)
}
// GET /admin/administration
let admin : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
match! TemplateCache.get adminTheme "theme-list-body" ctx.Data with
| Ok bodyTemplate ->
let! themes = ctx.Data.Theme.All ()
let cachedTemplates = TemplateCache.allNames ()
let! hash =
hashForPage "myWebLog Administration"
|> withAntiCsrf ctx
|> addToHash "themes" (
themes
|> List.map (DisplayTheme.fromTheme WebLogCache.isThemeInUse)
|> Array.ofList)
|> addToHash "cached_themes" (
themes
|> Seq.ofList
|> Seq.map (fun it -> [|
ThemeId.toString it.Id
it.Name
cachedTemplates
|> List.filter (fun n -> n.StartsWith (ThemeId.toString it.Id))
|> List.length
|> string
|])
|> Array.ofSeq)
|> addToHash "web_logs" (
WebLogCache.all ()
|> Seq.ofList
|> Seq.sortBy (fun it -> it.Name)
|> Seq.map (fun it -> [| WebLogId.toString it.Id; it.Name; it.UrlBase |])
|> Array.ofSeq)
|> addViewContext ctx
return!
addToHash "theme_list" (bodyTemplate.Render hash) hash
|> adminView "admin-dashboard" next ctx
| Error message -> return! Error.server message next ctx
let! themes = ctx.Data.Theme.All()
return! adminPage "myWebLog Administration" true next ctx (Views.Admin.dashboard themes)
}
/// Redirect the user to the admin dashboard
let toAdminDashboard : HttpHandler = redirectToGet "admin/administration"
/// ~~ CACHES ~~
/// ~~~ CACHES ~~~
module Cache =
// POST /admin/cache/web-log/{id}/refresh
@@ -87,17 +53,17 @@ module Cache =
do! PageListCache.refresh webLog data
do! CategoryCache.refresh webLog.Id data
do! addMessage ctx
{ UserMessage.success with Message = "Successfully refresh web log cache for all web logs" }
{ UserMessage.Success with Message = "Successfully refresh web log cache for all web logs" }
else
match! data.WebLog.FindById (WebLogId webLogId) with
match! data.WebLog.FindById(WebLogId webLogId) with
| Some webLog ->
WebLogCache.set webLog
do! PageListCache.refresh webLog data
do! CategoryCache.refresh webLog.Id data
do! addMessage ctx
{ UserMessage.success with Message = $"Successfully refreshed web log cache for {webLog.Name}" }
{ UserMessage.Success with Message = $"Successfully refreshed web log cache for {webLog.Name}" }
| None ->
do! addMessage ctx { UserMessage.error with Message = $"No web log exists with ID {webLogId}" }
do! addMessage ctx { UserMessage.Error with Message = $"No web log exists with ID {webLogId}" }
return! toAdminDashboard next ctx
}
@@ -108,55 +74,38 @@ module Cache =
TemplateCache.empty ()
do! ThemeAssetCache.fill data
do! addMessage ctx
{ UserMessage.success with
Message = "Successfully cleared template cache and refreshed theme asset cache"
}
{ UserMessage.Success with
Message = "Successfully cleared template cache and refreshed theme asset cache" }
else
match! data.Theme.FindById (ThemeId themeId) with
match! data.Theme.FindById(ThemeId themeId) with
| Some theme ->
TemplateCache.invalidateTheme theme.Id
do! ThemeAssetCache.refreshTheme theme.Id data
do! addMessage ctx
{ UserMessage.success with
Message = $"Successfully cleared template cache and refreshed theme asset cache for {theme.Name}"
}
{ UserMessage.Success with
Message = $"Successfully cleared template cache and refreshed theme asset cache for {theme.Name}" }
| None ->
do! addMessage ctx { UserMessage.error with Message = $"No theme exists with ID {themeId}" }
do! addMessage ctx { UserMessage.Error with Message = $"No theme exists with ID {themeId}" }
return! toAdminDashboard next ctx
}
/// ~~ CATEGORIES ~~
/// ~~~ CATEGORIES ~~~
module Category =
open MyWebLog.Data
// GET /admin/categories
let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
match! TemplateCache.get adminTheme "category-list-body" ctx.Data with
| Ok catListTemplate ->
let! hash =
hashForPage "Categories"
|> withAntiCsrf ctx
|> addViewContext ctx
return!
addToHash "category_list" (catListTemplate.Render hash) hash
|> adminView "category-list" next ctx
| Error message -> return! Error.server message next ctx
}
// GET /admin/categories/bare
let bare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
hashForPage "Categories"
|> withAntiCsrf ctx
|> adminBareView "category-list-body" next ctx
let all : HttpHandler = fun next ctx ->
let response = fun next ctx ->
adminPage "Categories" true next ctx (Views.WebLog.categoryList (ctx.Request.Query.ContainsKey "new"))
(withHxPushUrl (ctx.WebLog.RelativeUrl (Permalink "admin/categories")) >=> response) next ctx
// GET /admin/category/{id}/edit
let edit catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let edit catId : HttpHandler = fun next ctx -> task {
let! result = task {
match catId with
| "new" -> return Some ("Add a New Category", { Category.empty with Id = CategoryId "new" })
| "new" -> return Some ("Add a New Category", { Category.Empty with Id = CategoryId "new" })
| _ ->
match! ctx.Data.Category.FindById (CategoryId catId) ctx.WebLog.Id with
| Some cat -> return Some ("Edit Category", cat)
@@ -165,19 +114,17 @@ module Category =
match result with
| Some (title, cat) ->
return!
hashForPage title
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (EditCategoryModel.fromCategory cat)
|> adminBareView "category-edit" next ctx
Views.WebLog.categoryEdit (EditCategoryModel.FromCategory cat)
|> adminBarePage title true next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/category/save
let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let save : HttpHandler = fun next ctx -> task {
let data = ctx.Data
let! model = ctx.BindFormAsync<EditCategoryModel> ()
let! model = ctx.BindFormAsync<EditCategoryModel>()
let category =
if model.IsNew then someTask { Category.empty with Id = CategoryId.create (); WebLogId = ctx.WebLog.Id }
if model.IsNew then someTask { Category.Empty with Id = CategoryId.Create(); WebLogId = ctx.WebLog.Id }
else data.Category.FindById (CategoryId model.CategoryId) ctx.WebLog.Id
match! category with
| Some cat ->
@@ -186,16 +133,15 @@ module Category =
Name = model.Name
Slug = model.Slug
Description = if model.Description = "" then None else Some model.Description
ParentId = if model.ParentId = "" then None else Some (CategoryId model.ParentId)
}
ParentId = if model.ParentId = "" then None else Some (CategoryId model.ParentId) }
do! (if model.IsNew then data.Category.Add else data.Category.Update) updatedCat
do! CategoryCache.update ctx
do! addMessage ctx { UserMessage.success with Message = "Category saved successfully" }
return! bare next ctx
do! addMessage ctx { UserMessage.Success with Message = "Category saved successfully" }
return! all next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/category/{id}/delete
// DELETE /admin/category/{id}
let delete catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! result = ctx.Data.Category.Delete (CategoryId catId) ctx.WebLog.Id
match result with
@@ -207,78 +153,142 @@ module Category =
| ReassignedChildCategories ->
Some "<em>(Its child categories were reassigned to its parent category)</em>"
| _ -> None
do! addMessage ctx { UserMessage.success with Message = "Category deleted successfully"; Detail = detail }
do! addMessage ctx { UserMessage.Success with Message = "Category deleted successfully"; Detail = detail }
| CategoryNotFound ->
do! addMessage ctx { UserMessage.error with Message = "Category not found; cannot delete" }
return! bare next ctx
}
/// ~~ TAG MAPPINGS ~~
module TagMapping =
open Microsoft.AspNetCore.Http
/// Add tag mappings to the given hash
let withTagMappings (ctx : HttpContext) hash = task {
let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id
return
addToHash "mappings" mappings hash
|> addToHash "mapping_ids" (
mappings
|> List.map (fun it -> { Name = it.Tag; Value = TagMapId.toString it.Id }))
}
// GET /admin/settings/tag-mappings
let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! hash =
hashForPage ""
|> withAntiCsrf ctx
|> withTagMappings ctx
return! adminBareView "tag-mapping-list-body" next ctx hash
}
// GET /admin/settings/tag-mapping/{id}/edit
let edit tagMapId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let isNew = tagMapId = "new"
let tagMap =
if isNew then someTask { TagMap.empty with Id = TagMapId "new" }
else ctx.Data.TagMap.FindById (TagMapId tagMapId) ctx.WebLog.Id
match! tagMap with
| Some tm ->
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
}
// POST /admin/settings/tag-mapping/save
let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data
let! model = ctx.BindFormAsync<EditTagMapModel> ()
let tagMap =
if model.IsNew then someTask { TagMap.empty with Id = TagMapId.create (); WebLogId = ctx.WebLog.Id }
else data.TagMap.FindById (TagMapId model.Id) ctx.WebLog.Id
match! tagMap with
| Some tm ->
do! data.TagMap.Save { tm with Tag = model.Tag.ToLower (); UrlValue = model.UrlValue.ToLower () }
do! addMessage ctx { UserMessage.success with Message = "Tag mapping saved successfully" }
return! all next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/settings/tag-mapping/{id}/delete
let delete tagMapId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
match! ctx.Data.TagMap.Delete (TagMapId tagMapId) ctx.WebLog.Id with
| true -> do! addMessage ctx { UserMessage.success with Message = "Tag mapping deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with Message = "Tag mapping not found; nothing deleted" }
do! addMessage ctx { UserMessage.Error with Message = "Category not found; cannot delete" }
return! all next ctx
}
/// ~~ THEMES ~~
/// ~~~ REDIRECT RULES ~~~
module RedirectRules =
open Microsoft.AspNetCore.Http
// GET /admin/settings/redirect-rules
let all : HttpHandler = fun next ctx ->
adminPage "Redirect Rules" true next ctx (Views.WebLog.redirectList ctx.WebLog.RedirectRules)
// GET /admin/settings/redirect-rules/[index]
let edit idx : HttpHandler = fun next ctx ->
let titleAndView =
if idx = -1 then
Some ("Add", Views.WebLog.redirectEdit (EditRedirectRuleModel.FromRule -1 RedirectRule.Empty))
else
let rules = ctx.WebLog.RedirectRules
if rules.Length < idx || idx < 0 then
None
else
Some
("Edit", (Views.WebLog.redirectEdit (EditRedirectRuleModel.FromRule idx (List.item idx rules))))
match titleAndView with
| Some (title, view) -> adminBarePage $"{title} Redirect Rule" true next ctx view
| None -> Error.notFound next ctx
/// Update the web log's redirect rules in the database, the request web log, and the web log cache
let private updateRedirectRules (ctx: HttpContext) webLog = backgroundTask {
do! ctx.Data.WebLog.UpdateRedirectRules webLog
ctx.Items["webLog"] <- webLog
WebLogCache.set webLog
}
// POST /admin/settings/redirect-rules/[index]
let save idx : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<EditRedirectRuleModel>()
let rule = model.ToRule()
let rules =
ctx.WebLog.RedirectRules
|> match idx with
| -1 when model.InsertAtTop -> List.insertAt 0 rule
| -1 -> List.insertAt ctx.WebLog.RedirectRules.Length rule
| _ -> List.removeAt idx >> List.insertAt idx rule
do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = rules }
do! addMessage ctx { UserMessage.Success with Message = "Redirect rule saved successfully" }
return! all next ctx
}
// POST /admin/settings/redirect-rules/[index]/up
let moveUp idx : HttpHandler = fun next ctx -> task {
if idx < 1 || idx >= ctx.WebLog.RedirectRules.Length then
return! Error.notFound next ctx
else
let toMove = List.item idx ctx.WebLog.RedirectRules
let newRules = ctx.WebLog.RedirectRules |> List.removeAt idx |> List.insertAt (idx - 1) toMove
do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = newRules }
return! all next ctx
}
// POST /admin/settings/redirect-rules/[index]/down
let moveDown idx : HttpHandler = fun next ctx -> task {
if idx < 0 || idx >= ctx.WebLog.RedirectRules.Length - 1 then
return! Error.notFound next ctx
else
let toMove = List.item idx ctx.WebLog.RedirectRules
let newRules = ctx.WebLog.RedirectRules |> List.removeAt idx |> List.insertAt (idx + 1) toMove
do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = newRules }
return! all next ctx
}
// DELETE /admin/settings/redirect-rules/[index]
let delete idx : HttpHandler = fun next ctx -> task {
if idx < 0 || idx >= ctx.WebLog.RedirectRules.Length then
return! Error.notFound next ctx
else
let rules = ctx.WebLog.RedirectRules |> List.removeAt idx
do! updateRedirectRules ctx { ctx.WebLog with RedirectRules = rules }
do! addMessage ctx { UserMessage.Success with Message = "Redirect rule deleted successfully" }
return! all next ctx
}
/// ~~~ TAG MAPPINGS ~~~
module TagMapping =
// GET /admin/settings/tag-mappings
let all : HttpHandler = fun next ctx -> task {
let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id
return! adminBarePage "Tag Mapping List" true next ctx (Views.WebLog.tagMapList mappings)
}
// GET /admin/settings/tag-mapping/{id}/edit
let edit tagMapId : HttpHandler = fun next ctx -> task {
let isNew = tagMapId = "new"
let tagMap =
if isNew then someTask { TagMap.Empty with Id = TagMapId "new" }
else ctx.Data.TagMap.FindById (TagMapId tagMapId) ctx.WebLog.Id
match! tagMap with
| Some tm ->
return!
Views.WebLog.tagMapEdit (EditTagMapModel.FromMapping tm)
|> adminBarePage (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag") true next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/settings/tag-mapping/save
let save : HttpHandler = fun next ctx -> task {
let data = ctx.Data
let! model = ctx.BindFormAsync<EditTagMapModel>()
let tagMap =
if model.IsNew then someTask { TagMap.Empty with Id = TagMapId.Create(); WebLogId = ctx.WebLog.Id }
else data.TagMap.FindById (TagMapId model.Id) ctx.WebLog.Id
match! tagMap with
| Some tm ->
do! data.TagMap.Save { tm with Tag = model.Tag.ToLower(); UrlValue = model.UrlValue.ToLower() }
do! addMessage ctx { UserMessage.Success with Message = "Tag mapping saved successfully" }
return! all next ctx
| None -> return! Error.notFound next ctx
}
// DELETE /admin/settings/tag-mapping/{id}
let delete tagMapId : HttpHandler = fun next ctx -> task {
match! ctx.Data.TagMap.Delete (TagMapId tagMapId) ctx.WebLog.Id with
| true -> do! addMessage ctx { UserMessage.Success with Message = "Tag mapping deleted successfully" }
| false -> do! addMessage ctx { UserMessage.Error with Message = "Tag mapping not found; nothing deleted" }
return! all next ctx
}
/// ~~~ THEMES ~~~
module Theme =
open System
@@ -291,30 +301,26 @@ module Theme =
let all : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
let! themes = ctx.Data.Theme.All ()
return!
hashForPage "Themes"
|> withAntiCsrf ctx
|> addToHash "themes" (themes |> List.map (DisplayTheme.fromTheme WebLogCache.isThemeInUse) |> Array.ofList)
|> adminBareView "theme-list-body" next ctx
Views.Admin.themeList (List.map (DisplayTheme.FromTheme WebLogCache.isThemeInUse) themes)
|> adminBarePage "Themes" true next ctx
}
// GET /admin/theme/new
let add : HttpHandler = requireAccess Administrator >=> fun next ctx ->
hashForPage "Upload a Theme File"
|> withAntiCsrf ctx
|> adminBareView "theme-upload" next ctx
adminBarePage "Upload a Theme File" true next ctx Views.Admin.themeUpload
/// Update the name and version for a theme based on the version.txt file, if present
let private updateNameAndVersion (theme : Theme) (zip : ZipArchive) = backgroundTask {
let private updateNameAndVersion (theme: Theme) (zip: ZipArchive) = backgroundTask {
let now () = DateTime.UtcNow.ToString "yyyyMMdd.HHmm"
match zip.Entries |> Seq.filter (fun it -> it.FullName = "version.txt") |> Seq.tryHead with
| Some versionItem ->
use versionFile = new StreamReader(versionItem.Open ())
let! versionText = versionFile.ReadToEndAsync ()
use versionFile = new StreamReader(versionItem.Open())
let! versionText = versionFile.ReadToEndAsync()
let parts = versionText.Trim().Replace("\r", "").Split "\n"
let displayName = if parts[0] > "" then parts[0] else ThemeId.toString theme.Id
let displayName = if parts[0] > "" then parts[0] else string theme.Id
let version = if parts.Length > 1 && parts[1] > "" then parts[1] else now ()
return { theme with Name = displayName; Version = version }
| None -> return { theme with Name = ThemeId.toString theme.Id; Version = now () }
| None -> return { theme with Name = string theme.Id; Version = now () }
}
/// Update the theme with all templates from the ZIP archive
@@ -323,9 +329,9 @@ module Theme =
zip.Entries
|> Seq.filter (fun it -> it.Name.EndsWith ".liquid")
|> Seq.map (fun templateItem -> backgroundTask {
use templateFile = new StreamReader (templateItem.Open ())
let! template = templateFile.ReadToEndAsync ()
return { Name = templateItem.Name.Replace (".liquid", ""); Text = template }
use templateFile = new StreamReader(templateItem.Open())
let! template = templateFile.ReadToEndAsync()
return { Name = templateItem.Name.Replace(".liquid", ""); Text = template }
})
let! templates = Task.WhenAll tasks
return
@@ -336,37 +342,37 @@ module Theme =
}
/// Update theme assets from the ZIP archive
let private updateAssets themeId (zip : ZipArchive) (data : IData) = backgroundTask {
for asset in zip.Entries |> Seq.filter (fun it -> it.FullName.StartsWith "wwwroot") do
let assetName = asset.FullName.Replace ("wwwroot/", "")
let private updateAssets themeId (zip: ZipArchive) (data: IData) = backgroundTask {
for asset in zip.Entries |> Seq.filter _.FullName.StartsWith("wwwroot") do
let assetName = asset.FullName.Replace("wwwroot/", "")
if assetName <> "" && not (assetName.EndsWith "/") then
use stream = new MemoryStream ()
use stream = new MemoryStream()
do! asset.Open().CopyToAsync stream
do! data.ThemeAsset.Save
{ Id = ThemeAssetId (themeId, assetName)
{ Id = ThemeAssetId(themeId, assetName)
UpdatedOn = LocalDateTime.FromDateTime(asset.LastWriteTime.DateTime)
.InZoneLeniently(DateTimeZone.Utc).ToInstant ()
Data = stream.ToArray ()
.InZoneLeniently(DateTimeZone.Utc).ToInstant()
Data = stream.ToArray()
}
}
/// Derive the theme ID from the file name given
let deriveIdFromFileName (fileName : string) =
let themeName = fileName.Split(".").[0].ToLowerInvariant().Replace (" ", "-")
let deriveIdFromFileName (fileName: string) =
let themeName = fileName.Split(".").[0].ToLowerInvariant().Replace(" ", "-")
if themeName.EndsWith "-theme" then
if Regex.IsMatch (themeName, """^[a-z0-9\-]+$""") then
Ok (ThemeId (themeName.Substring (0, themeName.Length - 6)))
if Regex.IsMatch(themeName, """^[a-z0-9\-]+$""") then
Ok(ThemeId(themeName[..themeName.Length - 7]))
else Error $"Theme ID {fileName} is invalid"
else Error "Theme .zip file name must end in \"-theme.zip\""
/// Load a theme from the given stream, which should contain a ZIP archive
let loadFromZip themeId file (data : IData) = backgroundTask {
let loadFromZip themeId file (data: IData) = backgroundTask {
let! isNew, theme = backgroundTask {
match! data.Theme.FindById themeId with
| Some t -> return false, t
| None -> return true, { Theme.empty with Id = themeId }
| None -> return true, { Theme.Empty with Id = themeId }
}
use zip = new ZipArchive (file, ZipArchiveMode.Read)
use zip = new ZipArchive(file, ZipArchiveMode.Read)
let! theme = updateNameAndVersion theme zip
if not isNew then do! data.ThemeAsset.DeleteByTheme theme.Id
let! theme = updateTemplates { theme with Templates = [] } zip
@@ -381,37 +387,35 @@ module Theme =
if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then
let themeFile = Seq.head ctx.Request.Form.Files
match deriveIdFromFileName themeFile.FileName with
| Ok themeId when themeId <> adminTheme ->
| Ok themeId when themeId <> ThemeId "admin" ->
let data = ctx.Data
let! exists = data.Theme.Exists themeId
let isNew = not exists
let! model = ctx.BindFormAsync<UploadThemeModel> ()
let! model = ctx.BindFormAsync<UploadThemeModel>()
if isNew || model.DoOverwrite then
// Load the theme to the database
use stream = new MemoryStream ()
use stream = new MemoryStream()
do! themeFile.CopyToAsync stream
let! _ = loadFromZip themeId stream data
do! ThemeAssetCache.refreshTheme themeId data
TemplateCache.invalidateTheme themeId
// Save the .zip file
use file = new FileStream ($"{ThemeId.toString themeId}-theme.zip", FileMode.Create)
use file = new FileStream($"./themes/{themeId}-theme.zip", FileMode.Create)
do! themeFile.CopyToAsync file
do! addMessage ctx
{ UserMessage.success with
Message = $"""Theme {if isNew then "add" else "updat"}ed successfully"""
}
{ UserMessage.Success with
Message = $"""Theme {if isNew then "add" else "updat"}ed successfully""" }
return! toAdminDashboard next ctx
else
do! addMessage ctx
{ UserMessage.error with
Message = "Theme exists and overwriting was not requested; nothing saved"
}
{ UserMessage.Error with
Message = "Theme exists and overwriting was not requested; nothing saved" }
return! toAdminDashboard next ctx
| Ok _ ->
do! addMessage ctx { UserMessage.error with Message = "You may not replace the admin theme" }
do! addMessage ctx { UserMessage.Error with Message = "You may not replace the admin theme" }
return! toAdminDashboard next ctx
| Error message ->
do! addMessage ctx { UserMessage.error with Message = message }
do! addMessage ctx { UserMessage.Error with Message = message }
return! toAdminDashboard next ctx
else return! RequestErrors.BAD_REQUEST "Bad request" next ctx
}
@@ -421,87 +425,53 @@ module Theme =
let data = ctx.Data
match themeId with
| "admin" | "default" ->
do! addMessage ctx { UserMessage.error with Message = $"You may not delete the {themeId} theme" }
do! addMessage ctx { UserMessage.Error with Message = $"You may not delete the {themeId} theme" }
return! all next ctx
| it when WebLogCache.isThemeInUse (ThemeId it) ->
do! addMessage ctx
{ UserMessage.error with
Message = $"You may not delete the {themeId} theme, as it is currently in use"
}
{ UserMessage.Error with
Message = $"You may not delete the {themeId} theme, as it is currently in use" }
return! all next ctx
| _ ->
match! data.Theme.Delete (ThemeId themeId) with
| true ->
let zippedTheme = $"{themeId}-theme.zip"
let zippedTheme = $"./themes/{themeId}-theme.zip"
if File.Exists zippedTheme then File.Delete zippedTheme
do! addMessage ctx { UserMessage.success with Message = $"Theme ID {themeId} deleted successfully" }
do! addMessage ctx { UserMessage.Success with Message = $"Theme ID {themeId} deleted successfully" }
return! all next ctx
| false -> return! Error.notFound next ctx
}
/// ~~ WEB LOG SETTINGS ~~
/// ~~~ WEB LOG SETTINGS ~~~
module WebLog =
open System.Collections.Generic
open System.IO
// GET /admin/settings
let settings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data
match! TemplateCache.get adminTheme "user-list-body" data with
| Ok userTemplate ->
match! TemplateCache.get adminTheme "tag-mapping-list-body" ctx.Data with
| Ok tagMapTemplate ->
let! allPages = data.Page.All ctx.WebLog.Id
let! themes = data.Theme.All ()
let! users = data.WebLogUser.FindByWebLog ctx.WebLog.Id
let! hash =
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)
|> addToHash "themes" (
themes
|> 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")
|]
|> addToHash "users" (users |> List.map (DisplayUser.fromUser ctx.WebLog) |> Array.ofList)
|> addToHash "rss_model" (EditRssModel.fromRssOptions ctx.WebLog.Rss)
|> addToHash "custom_feeds" (
ctx.WebLog.Rss.CustomFeeds
|> List.map (DisplayCustomFeed.fromFeed (CategoryCache.get ctx))
|> Array.ofList)
|> addViewContext ctx
let! hash' = TagMapping.withTagMappings ctx hash
return!
addToHash "user_list" (userTemplate.Render hash') hash'
|> addToHash "tag_mapping_list" (tagMapTemplate.Render hash')
|> adminView "settings" next ctx
| Error message -> return! Error.server message next ctx
| Error message -> return! Error.server message next ctx
let settings : HttpHandler = fun next ctx -> task {
let data = ctx.Data
let! allPages = data.Page.All ctx.WebLog.Id
let pages =
allPages
|> List.sortBy _.Title.ToLower()
|> List.append [ { Page.Empty with Id = PageId "posts"; Title = "- First Page of Posts -" } ]
let! themes = data.Theme.All()
let uploads = [ Database; Disk ]
return!
Views.WebLog.webLogSettings
(SettingsModel.FromWebLog ctx.WebLog) themes pages uploads (EditRssModel.FromRssOptions ctx.WebLog.Rss)
|> adminPage "Web Log Settings" true next ctx
}
// POST /admin/settings
let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let saveSettings : HttpHandler = fun next ctx -> task {
let data = ctx.Data
let! model = ctx.BindFormAsync<SettingsModel> ()
let! model = ctx.BindFormAsync<SettingsModel>()
match! data.WebLog.FindById ctx.WebLog.Id with
| Some webLog ->
let oldSlug = webLog.Slug
let webLog = model.update webLog
let webLog = model.Update webLog
do! data.WebLog.UpdateSettings webLog
// Update cache
@@ -509,11 +479,11 @@ module WebLog =
if oldSlug <> webLog.Slug then
// Rename disk directory if it exists
let uploadRoot = Path.Combine ("wwwroot", "upload")
let oldDir = Path.Combine (uploadRoot, oldSlug)
if Directory.Exists oldDir then Directory.Move (oldDir, Path.Combine (uploadRoot, webLog.Slug))
let uploadRoot = Path.Combine("wwwroot", "upload")
let oldDir = Path.Combine(uploadRoot, oldSlug)
if Directory.Exists oldDir then Directory.Move(oldDir, Path.Combine(uploadRoot, webLog.Slug))
do! addMessage ctx { UserMessage.success with Message = "Web log settings saved successfully" }
do! addMessage ctx { UserMessage.Success with Message = "Web log settings saved successfully" }
return! redirectToGet "admin/settings" next ctx
| None -> return! Error.notFound next ctx
}

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

@@ -2,7 +2,6 @@
module MyWebLog.Handlers.Feed
open System
open System.Collections.Generic
open System.IO
open System.Net
open System.ServiceModel.Syndication
@@ -23,7 +22,7 @@ type FeedType =
| Custom of CustomFeed * string
/// Derive the type of RSS feed requested
let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option =
let deriveFeedType (ctx: HttpContext) feedPath : (FeedType * int) option =
let webLog = ctx.WebLog
let debug = debug "Feed" ctx
let name = $"/{webLog.Rss.FeedName}"
@@ -33,23 +32,22 @@ let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option =
match webLog.Rss.IsFeedEnabled && feedPath = name with
| true ->
debug (fun () -> "Found standard feed")
Some (StandardFeed feedPath, postCount)
Some(StandardFeed feedPath, postCount)
| false ->
// Category and tag feeds are handled by defined routes; check for custom feed
match webLog.Rss.CustomFeeds
|> List.tryFind (fun it -> feedPath.EndsWith (Permalink.toString it.Path)) with
|> List.tryFind (fun it -> feedPath.EndsWith(string it.Path)) with
| Some feed ->
debug (fun () -> "Found custom feed")
Some (Custom (feed, feedPath),
feed.Podcast |> Option.map (fun p -> p.ItemsInFeed) |> Option.defaultValue postCount)
Some(Custom(feed, feedPath), feed.Podcast |> Option.map _.ItemsInFeed |> Option.defaultValue postCount)
| None ->
debug (fun () -> $"No matching feed found")
debug (fun () -> "No matching feed found")
None
/// Determine the function to retrieve posts for the given feed
let private getFeedPosts ctx feedType =
let childIds catId =
let cat = CategoryCache.get ctx |> Array.find (fun c -> c.Id = CategoryId.toString catId)
let childIds (catId: CategoryId) =
let cat = CategoryCache.get ctx |> Array.find (fun c -> c.Id = string catId)
getCategoryIds cat.Slug ctx
let data = ctx.Data
match feedType with
@@ -62,7 +60,7 @@ let private getFeedPosts ctx feedType =
| Tag tag -> data.Post.FindPageOfTaggedPosts ctx.WebLog.Id tag 1
/// Strip HTML from a string
let private stripHtml text = WebUtility.HtmlDecode <| Regex.Replace (text, "<(.|\n)*?>", "")
let private stripHtml text = WebUtility.HtmlDecode <| Regex.Replace(text, "<(.|\n)*?>", "")
/// XML namespaces for building RSS feeds
[<RequireQualifiedAccess>]
@@ -87,108 +85,113 @@ module private Namespace =
let rawVoice = "http://www.rawvoice.com/rawvoiceRssModule/"
/// Create a feed item from the given post
let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[]) (tagMaps : TagMap list)
(post : Post) =
let private toFeedItem (webLog: WebLog) (authors: MetaItem list) (cats: DisplayCategory array) (tagMaps: TagMap list)
(post: Post) =
let plainText =
let endingP = post.Text.IndexOf "</p>"
stripHtml <| if endingP >= 0 then post.Text[..(endingP - 1)] else post.Text
let item = SyndicationItem (
Id = WebLog.absoluteUrl webLog post.Permalink,
let item = SyndicationItem(
Id = webLog.AbsoluteUrl post.Permalink,
Title = TextSyndicationContent.CreateHtmlContent post.Title,
PublishDate = post.PublishedOn.Value.ToDateTimeOffset (),
LastUpdatedTime = post.UpdatedOn.ToDateTimeOffset (),
PublishDate = post.PublishedOn.Value.ToDateTimeOffset(),
LastUpdatedTime = post.UpdatedOn.ToDateTimeOffset(),
Content = TextSyndicationContent.CreatePlaintextContent plainText)
item.AddPermalink (Uri item.Id)
let xmlDoc = XmlDocument ()
let xmlDoc = XmlDocument()
let encoded =
let txt =
post.Text
.Replace("src=\"/", $"src=\"{webLog.UrlBase}/")
.Replace ("href=\"/", $"href=\"{webLog.UrlBase}/")
let it = xmlDoc.CreateElement ("content", "encoded", Namespace.content)
let _ = it.AppendChild (xmlDoc.CreateCDataSection txt)
.Replace("href=\"/", $"href=\"{webLog.UrlBase}/")
let it = xmlDoc.CreateElement("content", "encoded", Namespace.content)
let _ = it.AppendChild(xmlDoc.CreateCDataSection txt)
it
item.ElementExtensions.Add encoded
item.Authors.Add (SyndicationPerson (
Name = (authors |> List.find (fun a -> a.Name = WebLogUserId.toString post.AuthorId)).Value))
item.Authors.Add(SyndicationPerson(Name = (authors |> List.find (fun a -> a.Name = string post.AuthorId)).Value))
[ post.CategoryIds
|> List.map (fun catId ->
let cat = cats |> Array.find (fun c -> c.Id = CategoryId.toString catId)
SyndicationCategory (cat.Name, WebLog.absoluteUrl webLog (Permalink $"category/{cat.Slug}/"), cat.Name))
let cat = cats |> Array.find (fun c -> c.Id = string catId)
SyndicationCategory(cat.Name, webLog.AbsoluteUrl(Permalink $"category/{cat.Slug}/"), cat.Name))
post.Tags
|> List.map (fun tag ->
let urlTag =
match tagMaps |> List.tryFind (fun tm -> tm.Tag = tag) with
| Some tm -> tm.UrlValue
| None -> tag.Replace (" ", "+")
SyndicationCategory (tag, WebLog.absoluteUrl webLog (Permalink $"tag/{urlTag}/"), $"{tag} (tag)"))
SyndicationCategory(tag, webLog.AbsoluteUrl(Permalink $"tag/{urlTag}/"), $"{tag} (tag)"))
]
|> List.concat
|> List.iter item.Categories.Add
item
/// Convert non-absolute URLs to an absolute URL for this web log
let toAbsolute webLog (link : string) =
if link.StartsWith "http" then link else WebLog.absoluteUrl webLog (Permalink link)
let toAbsolute (webLog: WebLog) (link: string) =
if link.StartsWith "http" then link else webLog.AbsoluteUrl(Permalink link)
/// Add episode information to a podcast feed item
let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (post : Post) (item : SyndicationItem) =
let private addEpisode (webLog: WebLog) (podcast: PodcastOptions) (episode: Episode) (post: Post)
(item: SyndicationItem) =
let epMediaUrl =
match episode.Media with
| link when link.StartsWith "http" -> link
| link when Option.isSome podcast.MediaBaseUrl -> $"{podcast.MediaBaseUrl.Value}{link}"
| link -> WebLog.absoluteUrl webLog (Permalink link)
| link -> webLog.AbsoluteUrl(Permalink link)
let epMediaType = [ episode.MediaType; podcast.DefaultMediaType ] |> List.tryFind Option.isSome |> Option.flatten
let epImageUrl = defaultArg episode.ImageUrl (Permalink.toString podcast.ImageUrl) |> toAbsolute webLog
let epExplicit = defaultArg episode.Explicit podcast.Explicit |> ExplicitRating.toString
let epImageUrl = defaultArg episode.ImageUrl (string podcast.ImageUrl) |> toAbsolute webLog
let epExplicit = string (defaultArg episode.Explicit podcast.Explicit)
let xmlDoc = XmlDocument ()
let xmlDoc = XmlDocument()
let enclosure =
let it = xmlDoc.CreateElement "enclosure"
it.SetAttribute ("url", epMediaUrl)
it.SetAttribute ("length", string episode.Length)
epMediaType |> Option.iter (fun typ -> it.SetAttribute ("type", typ))
it.SetAttribute("url", epMediaUrl)
it.SetAttribute("length", string episode.Length)
epMediaType |> Option.iter (fun typ -> it.SetAttribute("type", typ))
it
let image =
let it = xmlDoc.CreateElement ("itunes", "image", Namespace.iTunes)
it.SetAttribute ("href", epImageUrl)
let it = xmlDoc.CreateElement("itunes", "image", Namespace.iTunes)
it.SetAttribute("href", epImageUrl)
it
item.ElementExtensions.Add enclosure
item.ElementExtensions.Add image
item.ElementExtensions.Add ("creator", Namespace.dc, podcast.DisplayedAuthor)
item.ElementExtensions.Add ("author", Namespace.iTunes, podcast.DisplayedAuthor)
item.ElementExtensions.Add ("explicit", Namespace.iTunes, epExplicit)
episode.Subtitle |> Option.iter (fun it -> item.ElementExtensions.Add ("subtitle", Namespace.iTunes, it))
Episode.formatDuration episode
|> Option.iter (fun it -> item.ElementExtensions.Add ("duration", Namespace.iTunes, it))
item.ElementExtensions.Add("creator", Namespace.dc, podcast.DisplayedAuthor)
item.ElementExtensions.Add("author", Namespace.iTunes, podcast.DisplayedAuthor)
item.ElementExtensions.Add("explicit", Namespace.iTunes, epExplicit)
episode.Subtitle |> Option.iter (fun it -> item.ElementExtensions.Add("subtitle", Namespace.iTunes, it))
episode.FormatDuration() |> Option.iter (fun it -> item.ElementExtensions.Add("duration", Namespace.iTunes, it))
match episode.ChapterFile with
| Some chapters ->
let url = toAbsolute webLog chapters
let typ =
match episode.ChapterType with
| Some mime -> Some mime
| None when chapters.EndsWith ".json" -> Some "application/json+chapters"
| None -> None
let elt = xmlDoc.CreateElement ("podcast", "chapters", Namespace.podcast)
elt.SetAttribute ("url", url)
typ |> Option.iter (fun it -> elt.SetAttribute ("type", it))
let chapterUrl, chapterMimeType =
match episode.Chapters, episode.ChapterFile with
| Some _, _ ->
Some $"{webLog.AbsoluteUrl post.Permalink}?chapters", Some JSON_CHAPTERS
| None, Some chapters ->
let typ =
match episode.ChapterType with
| Some mime -> Some mime
| None when chapters.EndsWith ".json" -> Some JSON_CHAPTERS
| None -> None
Some (toAbsolute webLog chapters), typ
| None, None -> None, None
match chapterUrl with
| Some url ->
let elt = xmlDoc.CreateElement("podcast", "chapters", Namespace.podcast)
elt.SetAttribute("url", url)
chapterMimeType |> Option.iter (fun it -> elt.SetAttribute("type", it))
item.ElementExtensions.Add elt
| None -> ()
match episode.TranscriptUrl with
| Some transcript ->
let url = toAbsolute webLog transcript
let elt = xmlDoc.CreateElement ("podcast", "transcript", Namespace.podcast)
elt.SetAttribute ("url", url)
elt.SetAttribute ("type", Option.get episode.TranscriptType)
episode.TranscriptLang |> Option.iter (fun it -> elt.SetAttribute ("language", it))
if defaultArg episode.TranscriptCaptions false then
elt.SetAttribute ("rel", "captions")
let elt = xmlDoc.CreateElement("podcast", "transcript", Namespace.podcast)
elt.SetAttribute("url", url)
elt.SetAttribute("type", Option.get episode.TranscriptType)
episode.TranscriptLang |> Option.iter (fun it -> elt.SetAttribute("language", it))
if defaultArg episode.TranscriptCaptions false then elt.SetAttribute("rel", "captions")
item.ElementExtensions.Add elt
| None -> ()
@@ -196,38 +199,37 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po
| Some season ->
match episode.SeasonDescription with
| Some desc ->
let elt = xmlDoc.CreateElement ("podcast", "season", Namespace.podcast)
elt.SetAttribute ("name", desc)
let elt = xmlDoc.CreateElement("podcast", "season", Namespace.podcast)
elt.SetAttribute("name", desc)
elt.InnerText <- string season
item.ElementExtensions.Add elt
| None -> item.ElementExtensions.Add ("season", Namespace.podcast, string season)
| None -> item.ElementExtensions.Add("season", Namespace.podcast, string season)
| None -> ()
match episode.EpisodeNumber with
| Some epNumber ->
match episode.EpisodeDescription with
| Some desc ->
let elt = xmlDoc.CreateElement ("podcast", "episode", Namespace.podcast)
elt.SetAttribute ("name", desc)
let elt = xmlDoc.CreateElement("podcast", "episode", Namespace.podcast)
elt.SetAttribute("name", desc)
elt.InnerText <- string epNumber
item.ElementExtensions.Add elt
| None -> item.ElementExtensions.Add ("episode", Namespace.podcast, string epNumber)
| None -> item.ElementExtensions.Add("episode", Namespace.podcast, string epNumber)
| None -> ()
if post.Metadata |> List.exists (fun it -> it.Name = "chapter") then
try
let chapters = xmlDoc.CreateElement ("psc", "chapters", Namespace.psc)
chapters.SetAttribute ("version", "1.2")
let chapters = xmlDoc.CreateElement("psc", "chapters", Namespace.psc)
chapters.SetAttribute("version", "1.2")
post.Metadata
|> List.filter (fun it -> it.Name = "chapter")
|> List.map (fun it ->
TimeSpan.Parse (it.Value.Split(" ")[0]), it.Value.Substring (it.Value.IndexOf(" ") + 1))
|> List.map (fun it -> TimeSpan.Parse(it.Value.Split(" ")[0]), it.Value[it.Value.IndexOf(" ") + 1..])
|> List.sortBy fst
|> List.iter (fun chap ->
let chapter = xmlDoc.CreateElement ("psc", "chapter", Namespace.psc)
chapter.SetAttribute ("start", (fst chap).ToString "hh:mm:ss")
chapter.SetAttribute ("title", snd chap)
let chapter = xmlDoc.CreateElement("psc", "chapter", Namespace.psc)
chapter.SetAttribute("start", (fst chap).ToString "hh:mm:ss")
chapter.SetAttribute("title", snd chap)
chapters.AppendChild chapter |> ignore)
item.ElementExtensions.Add chapters
@@ -235,26 +237,26 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po
item
/// Add a namespace to the feed
let private addNamespace (feed : SyndicationFeed) alias nsUrl =
feed.AttributeExtensions.Add (XmlQualifiedName (alias, "http://www.w3.org/2000/xmlns/"), nsUrl)
let private addNamespace (feed: SyndicationFeed) alias nsUrl =
feed.AttributeExtensions.Add(XmlQualifiedName(alias, "http://www.w3.org/2000/xmlns/"), nsUrl)
/// Add items to the top of the feed required for podcasts
let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) =
let addChild (doc : XmlDocument) ns prefix name value (elt : XmlElement) =
let private addPodcast (webLog: WebLog) (rssFeed: SyndicationFeed) (feed: CustomFeed) =
let addChild (doc: XmlDocument) ns prefix name value (elt: XmlElement) =
let child =
if ns = "" then doc.CreateElement name else doc.CreateElement (prefix, name, ns)
if ns = "" then doc.CreateElement name else doc.CreateElement(prefix, name, ns)
|> elt.AppendChild
child.InnerText <- value
elt
let podcast = Option.get feed.Podcast
let feedUrl = WebLog.absoluteUrl webLog feed.Path
let feedUrl = webLog.AbsoluteUrl feed.Path
let imageUrl =
match podcast.ImageUrl with
| Permalink link when link.StartsWith "http" -> link
| Permalink _ -> WebLog.absoluteUrl webLog podcast.ImageUrl
| Permalink _ -> webLog.AbsoluteUrl podcast.ImageUrl
let xmlDoc = XmlDocument ()
let xmlDoc = XmlDocument()
[ "dc", Namespace.dc
"itunes", Namespace.iTunes
@@ -265,12 +267,12 @@ let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) =
|> List.iter (fun (alias, nsUrl) -> addNamespace rssFeed alias nsUrl)
let categorization =
let it = xmlDoc.CreateElement ("itunes", "category", Namespace.iTunes)
it.SetAttribute ("text", podcast.AppleCategory)
let it = xmlDoc.CreateElement("itunes", "category", Namespace.iTunes)
it.SetAttribute("text", podcast.AppleCategory)
podcast.AppleSubcategory
|> Option.iter (fun subCat ->
let subCatElt = xmlDoc.CreateElement ("itunes", "category", Namespace.iTunes)
subCatElt.SetAttribute ("text", subCat)
let subCatElt = xmlDoc.CreateElement("itunes", "category", Namespace.iTunes)
subCatElt.SetAttribute("text", subCat)
it.AppendChild subCatElt |> ignore)
it
let image =
@@ -280,19 +282,19 @@ let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) =
]
|> List.fold (fun elt (name, value) -> addChild xmlDoc "" "" name value elt) (xmlDoc.CreateElement "image")
let iTunesImage =
let it = xmlDoc.CreateElement ("itunes", "image", Namespace.iTunes)
it.SetAttribute ("href", imageUrl)
let it = xmlDoc.CreateElement("itunes", "image", Namespace.iTunes)
it.SetAttribute("href", imageUrl)
it
let owner =
[ "name", podcast.DisplayedAuthor
"email", podcast.Email
]
|> List.fold (fun elt (name, value) -> addChild xmlDoc Namespace.iTunes "itunes" name value elt)
(xmlDoc.CreateElement ("itunes", "owner", Namespace.iTunes))
(xmlDoc.CreateElement("itunes", "owner", Namespace.iTunes))
let rawVoice =
let it = xmlDoc.CreateElement ("rawvoice", "subscribe", Namespace.rawVoice)
it.SetAttribute ("feed", feedUrl)
it.SetAttribute ("itunes", "")
let it = xmlDoc.CreateElement("rawvoice", "subscribe", Namespace.rawVoice)
it.SetAttribute("feed", feedUrl)
it.SetAttribute("itunes", "")
it
rssFeed.ElementExtensions.Add image
@@ -300,25 +302,24 @@ let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) =
rssFeed.ElementExtensions.Add categorization
rssFeed.ElementExtensions.Add iTunesImage
rssFeed.ElementExtensions.Add rawVoice
rssFeed.ElementExtensions.Add ("summary", Namespace.iTunes, podcast.Summary)
rssFeed.ElementExtensions.Add ("author", Namespace.iTunes, podcast.DisplayedAuthor)
rssFeed.ElementExtensions.Add ("explicit", Namespace.iTunes, ExplicitRating.toString podcast.Explicit)
podcast.Subtitle |> Option.iter (fun sub -> rssFeed.ElementExtensions.Add ("subtitle", Namespace.iTunes, sub))
rssFeed.ElementExtensions.Add("summary", Namespace.iTunes, podcast.Summary)
rssFeed.ElementExtensions.Add("author", Namespace.iTunes, podcast.DisplayedAuthor)
rssFeed.ElementExtensions.Add("explicit", Namespace.iTunes, string podcast.Explicit)
podcast.Subtitle |> Option.iter (fun sub -> rssFeed.ElementExtensions.Add("subtitle", Namespace.iTunes, sub))
podcast.FundingUrl
|> Option.iter (fun url ->
let funding = xmlDoc.CreateElement ("podcast", "funding", Namespace.podcast)
funding.SetAttribute ("url", toAbsolute webLog url)
let funding = xmlDoc.CreateElement("podcast", "funding", Namespace.podcast)
funding.SetAttribute("url", toAbsolute webLog url)
funding.InnerText <- defaultArg podcast.FundingText "Support This Podcast"
rssFeed.ElementExtensions.Add funding)
podcast.PodcastGuid
|> Option.iter (fun guid ->
rssFeed.ElementExtensions.Add ("guid", Namespace.podcast, guid.ToString().ToLowerInvariant ()))
podcast.Medium
|> Option.iter (fun med -> rssFeed.ElementExtensions.Add ("medium", Namespace.podcast, PodcastMedium.toString med))
rssFeed.ElementExtensions.Add("guid", Namespace.podcast, guid.ToString().ToLowerInvariant()))
podcast.Medium |> Option.iter (fun med -> rssFeed.ElementExtensions.Add("medium", Namespace.podcast, string med))
/// Get the feed's self reference and non-feed link
let private selfAndLink webLog feedType ctx =
let withoutFeed (it : string) = Permalink (it.Replace ($"/{webLog.Rss.FeedName}", ""))
let withoutFeed (it: string) = Permalink(it.Replace($"/{webLog.Rss.FeedName}", ""))
match feedType with
| StandardFeed path
| CategoryFeed (_, path)
@@ -330,8 +331,8 @@ let private selfAndLink webLog feedType ctx =
| Tag tag -> feed.Path, Permalink $"""tag/{tag.Replace(" ", "+")}/"""
/// Set the title and description of the feed based on its source
let private setTitleAndDescription feedType (webLog : WebLog) (cats : DisplayCategory[]) (feed : SyndicationFeed) =
let cleanText opt def = TextSyndicationContent (stripHtml (defaultArg opt def))
let private setTitleAndDescription feedType (webLog: WebLog) (cats: DisplayCategory[]) (feed: SyndicationFeed) =
let cleanText opt def = TextSyndicationContent(stripHtml (defaultArg opt def))
match feedType with
| StandardFeed _ ->
feed.Title <- cleanText None webLog.Name
@@ -359,7 +360,7 @@ let private setTitleAndDescription feedType (webLog : WebLog) (cats : DisplayCat
feed.Description <- cleanText None $"""Posts with the "{tag}" tag"""
/// Create a feed with a known non-zero-length list of posts
let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backgroundTask {
let createFeed (feedType: FeedType) posts : HttpHandler = fun next ctx -> backgroundTask {
let webLog = ctx.WebLog
let data = ctx.Data
let! authors = getAuthors webLog posts data
@@ -373,40 +374,40 @@ let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backg
match podcast, post.Episode with
| Some feed, Some episode -> addEpisode webLog (Option.get feed.Podcast) episode post item
| Some _, _ ->
warn "Feed" ctx $"[{webLog.Name} {Permalink.toString self}] \"{stripHtml post.Title}\" has no media"
warn "Feed" ctx $"[{webLog.Name} {self}] \"{stripHtml post.Title}\" has no media"
item
| _ -> item
let feed = SyndicationFeed ()
let feed = SyndicationFeed()
addNamespace feed "content" Namespace.content
setTitleAndDescription feedType webLog cats feed
feed.LastUpdatedTime <- (List.head posts).UpdatedOn.ToDateTimeOffset ()
feed.LastUpdatedTime <- (List.head posts).UpdatedOn.ToDateTimeOffset()
feed.Generator <- ctx.Generator
feed.Items <- posts |> Seq.ofList |> Seq.map toItem
feed.Language <- "en"
feed.Id <- WebLog.absoluteUrl webLog link
feed.Id <- webLog.AbsoluteUrl link
webLog.Rss.Copyright |> Option.iter (fun copy -> feed.Copyright <- TextSyndicationContent copy)
feed.Links.Add (SyndicationLink (Uri (WebLog.absoluteUrl webLog self), "self", "", "application/rss+xml", 0L))
feed.ElementExtensions.Add ("link", "", WebLog.absoluteUrl webLog link)
feed.Links.Add(SyndicationLink(Uri(webLog.AbsoluteUrl self), "self", "", "application/rss+xml", 0L))
feed.ElementExtensions.Add("link", "", webLog.AbsoluteUrl link)
podcast |> Option.iter (addPodcast webLog feed)
use mem = new MemoryStream ()
use mem = new MemoryStream()
use xml = XmlWriter.Create mem
feed.SaveAsRss20 xml
xml.Close ()
xml.Close()
let _ = mem.Seek (0L, SeekOrigin.Begin)
let _ = mem.Seek(0L, SeekOrigin.Begin)
let rdr = new StreamReader(mem)
let! output = rdr.ReadToEndAsync ()
let! output = rdr.ReadToEndAsync()
return! (setHttpHeader "Content-Type" "text/xml" >=> setStatusCode 200 >=> setBodyFromString output) next ctx
}
// GET {any-prescribed-feed}
let generate (feedType : FeedType) postCount : HttpHandler = fun next ctx -> backgroundTask {
let generate (feedType: FeedType) postCount : HttpHandler = fun next ctx -> backgroundTask {
match! getFeedPosts ctx feedType postCount with
| posts when List.length posts > 0 -> return! createFeed feedType posts next ctx
| _ -> return! Error.notFound next ctx
@@ -417,13 +418,13 @@ let generate (feedType : FeedType) postCount : HttpHandler = fun next ctx -> bac
// POST /admin/settings/rss
let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data
let! model = ctx.BindFormAsync<EditRssModel> ()
let! model = ctx.BindFormAsync<EditRssModel>()
match! data.WebLog.FindById ctx.WebLog.Id with
| Some webLog ->
let webLog = { webLog with Rss = model.UpdateOptions webLog.Rss }
do! data.WebLog.UpdateRssOptions webLog
WebLogCache.set webLog
do! addMessage ctx { UserMessage.success with Message = "RSS settings updated successfully" }
do! addMessage ctx { UserMessage.Success with Message = "RSS settings updated successfully" }
return! redirectToGet "admin/settings#rss-settings" next ctx
| None -> return! Error.notFound next ctx
}
@@ -432,24 +433,27 @@ let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> t
let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
let customFeed =
match feedId with
| "new" -> Some { CustomFeed.empty with Id = CustomFeedId "new" }
| "new" -> Some { CustomFeed.Empty with Id = CustomFeedId "new" }
| _ -> ctx.WebLog.Rss.CustomFeeds |> List.tryFind (fun f -> f.Id = CustomFeedId feedId)
match customFeed with
| Some f ->
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
let ratings = [
{ Name = string Yes; Value = "Yes" }
{ Name = string No; Value = "No" }
{ Name = string Clean; Value = "Clean" }
]
let mediums = [
{ Name = ""; Value = "&ndash; Unspecified &ndash;" }
{ Name = string Podcast; Value = "Podcast" }
{ Name = string Music; Value = "Music" }
{ Name = string Video; Value = "Video" }
{ Name = string Film; Value = "Film" }
{ Name = string Audiobook; Value = "Audiobook" }
{ Name = string Newsletter; Value = "Newsletter" }
{ Name = string Blog; Value = "Blog" }
]
Views.WebLog.feedEdit (EditCustomFeedModel.FromFeed f) ratings mediums
|> adminPage $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed""" true next ctx
| None -> Error.notFound next ctx
// POST /admin/settings/rss/save
@@ -457,45 +461,42 @@ let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
let data = ctx.Data
match! data.WebLog.FindById ctx.WebLog.Id with
| Some webLog ->
let! model = ctx.BindFormAsync<EditCustomFeedModel> ()
let! model = ctx.BindFormAsync<EditCustomFeedModel>()
let theFeed =
match model.Id with
| "new" -> Some { CustomFeed.empty with Id = CustomFeedId.create () }
| _ -> webLog.Rss.CustomFeeds |> List.tryFind (fun it -> CustomFeedId.toString it.Id = model.Id)
| "new" -> Some { CustomFeed.Empty with Id = CustomFeedId.Create() }
| _ -> webLog.Rss.CustomFeeds |> List.tryFind (fun it -> string it.Id = model.Id)
match theFeed with
| Some feed ->
let feeds = model.UpdateFeed feed :: (webLog.Rss.CustomFeeds |> List.filter (fun it -> it.Id <> feed.Id))
let webLog = { webLog with Rss = { webLog.Rss with CustomFeeds = feeds } }
let webLog = { webLog with Rss.CustomFeeds = feeds }
do! data.WebLog.UpdateRssOptions webLog
WebLogCache.set webLog
do! addMessage ctx {
UserMessage.success with
Message = $"""Successfully {if model.Id = "new" then "add" else "sav"}ed custom feed"""
}
return! redirectToGet $"admin/settings/rss/{CustomFeedId.toString feed.Id}/edit" next ctx
do! addMessage ctx
{ UserMessage.Success with
Message = $"""Successfully {if model.Id = "new" then "add" else "sav"}ed custom feed""" }
return! redirectToGet $"admin/settings/rss/{feed.Id}/edit" next ctx
| None -> return! Error.notFound next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/settings/rss/{id}/delete
// DELETE /admin/settings/rss/{id}
let deleteCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data
match! data.WebLog.FindById ctx.WebLog.Id with
| Some webLog ->
let customId = CustomFeedId feedId
if webLog.Rss.CustomFeeds |> List.exists (fun f -> f.Id = customId) then
let webLog = {
webLog with
Rss = {
webLog.Rss with
CustomFeeds = webLog.Rss.CustomFeeds |> List.filter (fun f -> f.Id <> customId)
}
}
let webLog =
{ webLog with
Rss =
{ webLog.Rss with
CustomFeeds = webLog.Rss.CustomFeeds |> List.filter (fun f -> f.Id <> customId) } }
do! data.WebLog.UpdateRssOptions webLog
WebLogCache.set webLog
do! addMessage ctx { UserMessage.success with Message = "Custom feed deleted successfully" }
do! addMessage ctx { UserMessage.Success with Message = "Custom feed deleted successfully" }
else
do! addMessage ctx { UserMessage.warning with Message = "Custom feed not found; no action taken" }
do! addMessage ctx { UserMessage.Warning with Message = "Custom feed not found; no action taken" }
return! redirectToGet "admin/settings#rss-settings" next ctx
| None -> return! Error.notFound next ctx
}

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

@@ -3,13 +3,14 @@ module private MyWebLog.Handlers.Helpers
open System.Text.Json
open Microsoft.AspNetCore.Http
open MyWebLog.Views
/// Session extensions to get and set objects
type ISession with
/// Set an item in the session
member this.Set<'T> (key, item : 'T) =
this.SetString (key, JsonSerializer.Serialize item)
member this.Set<'T>(key, item: 'T) =
this.SetString(key, JsonSerializer.Serialize item)
/// Get an item from the session
member this.TryGet<'T> key =
@@ -25,6 +26,10 @@ module ViewContext =
[<Literal>]
let AntiCsrfTokens = "csrf"
/// The unified application view context
[<Literal>]
let AppViewContext = "app"
/// The categories for this web log
[<Literal>]
let Categories = "categories"
@@ -126,28 +131,28 @@ module ViewContext =
let private sessionLoadedKey = "session-loaded"
/// Load the session if it has not been loaded already; ensures async access but not excessive loading
let private loadSession (ctx : HttpContext) = task {
let private loadSession (ctx: HttpContext) = task {
if not (ctx.Items.ContainsKey sessionLoadedKey) then
do! ctx.Session.LoadAsync ()
ctx.Items.Add (sessionLoadedKey, "yes")
do! ctx.Session.LoadAsync()
ctx.Items.Add(sessionLoadedKey, "yes")
}
/// Ensure that the session is committed
let private commitSession (ctx : HttpContext) = task {
if ctx.Items.ContainsKey sessionLoadedKey then do! ctx.Session.CommitAsync ()
let private commitSession (ctx: HttpContext) = task {
if ctx.Items.ContainsKey sessionLoadedKey then do! ctx.Session.CommitAsync()
}
open MyWebLog.ViewModels
/// Add a message to the user's session
let addMessage (ctx : HttpContext) message = task {
let addMessage (ctx: HttpContext) message = task {
do! loadSession ctx
let msg = match ctx.Session.TryGet<UserMessage list> ViewContext.Messages with Some it -> it | None -> []
ctx.Session.Set (ViewContext.Messages, message :: msg)
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 {
let messages (ctx: HttpContext) = task {
do! loadSession ctx
match ctx.Session.TryGet<UserMessage list> ViewContext.Messages with
| Some msg ->
@@ -160,23 +165,19 @@ open MyWebLog
open DotLiquid
/// Shorthand for creating a DotLiquid hash from an anonymous object
let makeHash (values : obj) =
let makeHash (values: obj) =
Hash.FromAnonymousObject values
/// Create a hash with the page title filled
let hashForPage (title : string) =
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)
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
@@ -185,40 +186,70 @@ open Giraffe.ViewEngine
/// htmx script tag
let private htmxScript = RenderView.AsString.htmlNode Htmx.Script.minified
/// Populate the DotLiquid hash with standard information
let addViewContext ctx (hash : Hash) = task {
/// Get the current user messages, and commit the session so that they are preserved
let private getCurrentMessages ctx = task {
let! messages = messages ctx
do! commitSession ctx
return
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 ]
return messages
}
/// Generate the view context for a response
let private generateViewContext pageTitle messages includeCsrf (ctx: HttpContext) =
{ WebLog = ctx.WebLog
UserId = ctx.User.Claims
|> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.NameIdentifier)
|> Option.map (fun claim -> WebLogUserId claim.Value)
PageTitle = pageTitle
Csrf = if includeCsrf then Some ctx.CsrfTokenSet else None
PageList = PageListCache.get ctx
Categories = CategoryCache.get ctx
CurrentPage = ctx.Request.Path.Value[1..]
Messages = messages
Generator = ctx.Generator
HtmxScript = htmxScript
IsAuthor = ctx.HasAccessLevel Author
IsEditor = ctx.HasAccessLevel Editor
IsWebLogAdmin = ctx.HasAccessLevel WebLogAdmin
IsAdministrator = ctx.HasAccessLevel Administrator }
/// Populate the DotLiquid hash with standard information
let addViewContext ctx (hash: Hash) = task {
let! messages = getCurrentMessages ctx
if hash.ContainsKey ViewContext.AppViewContext then
let oldApp = hash[ViewContext.AppViewContext] :?> AppViewContext
let newApp = { oldApp with Messages = Array.concat [ oldApp.Messages; messages ] }
return
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)
|> addToHash ViewContext.AppViewContext newApp
|> addToHash ViewContext.Messages newApp.Messages
else
let app =
generateViewContext (string hash[ViewContext.PageTitle]) messages
(hash.ContainsKey ViewContext.AntiCsrfTokens) ctx
return
hash
|> addToHash ViewContext.UserId (app.UserId |> Option.map string |> Option.defaultValue "")
|> addToHash ViewContext.WebLog app.WebLog
|> addToHash ViewContext.PageList app.PageList
|> addToHash ViewContext.Categories app.Categories
|> addToHash ViewContext.CurrentPage app.CurrentPage
|> addToHash ViewContext.Messages app.Messages
|> addToHash ViewContext.Generator app.Generator
|> addToHash ViewContext.HtmxScript app.HtmxScript
|> addToHash ViewContext.IsLoggedOn app.IsLoggedOn
|> addToHash ViewContext.IsAuthor app.IsAuthor
|> addToHash ViewContext.IsEditor app.IsEditor
|> addToHash ViewContext.IsWebLogAdmin app.IsWebLogAdmin
|> addToHash ViewContext.IsAdministrator app.IsAdministrator
}
/// Is the request from htmx?
let isHtmx (ctx : HttpContext) =
let isHtmx (ctx: HttpContext) =
ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh
/// Convert messages to headers (used for htmx responses)
let messagesToHeaders (messages : UserMessage array) : HttpHandler =
let messagesToHeaders (messages: UserMessage array) : HttpHandler =
seq {
yield!
messages
@@ -234,9 +265,12 @@ let messagesToHeaders (messages : UserMessage array) : HttpHandler =
/// Redirect after doing some action; commits session and issues a temporary redirect
let redirectToGet url : HttpHandler = fun _ ctx -> task {
do! commitSession ctx
return! redirectTo false (WebLog.relativeUrl ctx.WebLog (Permalink url)) earlyReturn ctx
return! redirectTo false (ctx.WebLog.RelativeUrl(Permalink url)) earlyReturn ctx
}
/// The MIME type for podcast episode JSON chapters
let JSON_CHAPTERS = "application/json+chapters"
/// Handlers for error conditions
module Error =
@@ -247,24 +281,24 @@ module Error =
let notAuthorized : HttpHandler = fun next ctx ->
if ctx.Request.Method = "GET" then
let redirectUrl = $"user/log-on?returnUrl={WebUtility.UrlEncode ctx.Request.Path}"
if isHtmx ctx then (withHxRedirect redirectUrl >=> redirectToGet redirectUrl) next ctx
else redirectToGet redirectUrl next ctx
(next, ctx)
||> if isHtmx ctx then withHxRedirect redirectUrl >=> withHxRetarget "body" >=> redirectToGet redirectUrl
else redirectToGet redirectUrl
else
if isHtmx ctx then
let messages = [|
{ UserMessage.error with
Message = $"You are not authorized to access the URL {ctx.Request.Path.Value}"
}
{ UserMessage.Error with
Message = $"You are not authorized to access the URL {ctx.Request.Path.Value}" }
|]
(messagesToHeaders messages >=> setStatusCode 401) earlyReturn ctx
else setStatusCode 401 earlyReturn ctx
/// Handle 404s from the API, sending known URL paths to the Vue app so that they can be handled there
/// Handle 404s
let notFound : HttpHandler =
handleContext (fun ctx ->
if isHtmx ctx then
let messages = [|
{ UserMessage.error with Message = $"The URL {ctx.Request.Path.Value} was not found" }
{ UserMessage.Error with Message = $"The URL {ctx.Request.Path.Value} was not found" }
|]
RequestErrors.notFound (messagesToHeaders messages) earlyReturn ctx
else RequestErrors.NOT_FOUND "Not found" earlyReturn ctx)
@@ -272,13 +306,13 @@ module Error =
let server message : HttpHandler =
handleContext (fun ctx ->
if isHtmx ctx then
let messages = [| { UserMessage.error with Message = message } |]
let messages = [| { UserMessage.Error with Message = message } |]
ServerErrors.internalError (messagesToHeaders messages) earlyReturn ctx
else ServerErrors.INTERNAL_ERROR message earlyReturn ctx)
/// Render a view for the specified theme, using the specified template, layout, and hash
let viewForTheme themeId template next ctx (hash : Hash) = task {
let viewForTheme themeId template next ctx (hash: Hash) = task {
let! hash = addViewContext ctx hash
// NOTE: DotLiquid does not support {% render %} or {% include %} in its templates, so we will do a 2-pass render;
@@ -296,13 +330,13 @@ let viewForTheme themeId template next ctx (hash : Hash) = task {
}
/// Render a bare view for the specified theme, using the specified template and hash
let bareForTheme themeId template next ctx (hash : Hash) = task {
let bareForTheme themeId template next ctx (hash: Hash) = task {
let! hash = addViewContext ctx hash
let withContent = task {
if hash.ContainsKey ViewContext.Content then return Ok hash
else
match! TemplateCache.get themeId template ctx.Data with
| Ok contentTemplate -> return Ok (addToHash ViewContext.Content (contentTemplate.Render hash) hash)
| Ok contentTemplate -> return Ok(addToHash ViewContext.Content (contentTemplate.Render hash) hash)
| Error message -> return Error message
}
match! withContent with
@@ -311,7 +345,7 @@ let bareForTheme themeId template next ctx (hash : Hash) = task {
match! TemplateCache.get themeId "layout-bare" ctx.Data with
| Ok layoutTemplate ->
return!
(messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage[])
(messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage array)
>=> htmlString (layoutTemplate.Render completeHash))
next ctx
| Error message -> return! Error.server message next ctx
@@ -324,16 +358,22 @@ let themedView template next ctx hash = task {
return! viewForTheme (hash[ViewContext.WebLog] :?> WebLog).ThemeId template next ctx hash
}
/// The ID for the admin theme
let adminTheme = ThemeId "admin"
/// Display a page for an admin endpoint
let adminPage pageTitle includeCsrf next ctx (content: AppViewContext -> XmlNode list) = task {
let! messages = getCurrentMessages ctx
let appCtx = generateViewContext pageTitle messages includeCsrf ctx
let layout = if isHtmx ctx then Layout.partial else Layout.full
return! htmlString (layout content appCtx |> RenderView.AsString.htmlDocument) next ctx
}
/// Display a view for the admin theme
let adminView template =
viewForTheme adminTheme template
/// Display a bare view for the admin theme
let adminBareView template =
bareForTheme adminTheme template
/// Display a bare page for an admin endpoint
let adminBarePage pageTitle includeCsrf next ctx (content: AppViewContext -> XmlNode list) = task {
let! messages = getCurrentMessages ctx
let appCtx = generateViewContext pageTitle messages includeCsrf ctx
return!
( messagesToHeaders appCtx.Messages
>=> htmlString (Layout.bare content appCtx |> RenderView.AsString.htmlDocument)) next ctx
}
/// Validate the anti cross-site request forgery token in the current request
let validateCsrf : HttpHandler = fun next ctx -> task {
@@ -348,59 +388,61 @@ let requireUser : HttpHandler = requiresAuthentication Error.notAuthorized
/// Require a specific level of access for a route
let requireAccess level : HttpHandler = fun next ctx -> task {
match ctx.UserAccessLevel with
| Some userLevel when AccessLevel.hasAccess level userLevel -> return! next ctx
| Some userLevel when userLevel.HasAccess level -> return! next ctx
| Some userLevel ->
do! addMessage ctx
{ UserMessage.warning with
Message = $"The page you tried to access requires {AccessLevel.toString level} privileges"
Detail = Some $"Your account only has {AccessLevel.toString userLevel} privileges"
}
{ UserMessage.Warning with
Message = $"The page you tried to access requires {level} privileges"
Detail = Some $"Your account only has {userLevel} privileges" }
return! Error.notAuthorized next ctx
| None ->
do! addMessage ctx
{ UserMessage.warning with Message = "The page you tried to access required you to be logged on" }
{ UserMessage.Warning with Message = "The page you tried to access required you to be logged on" }
return! Error.notAuthorized next ctx
}
/// Determine if a user is authorized to edit a page or post, given the author
let canEdit authorId (ctx : HttpContext) =
let canEdit authorId (ctx: HttpContext) =
ctx.UserId = authorId || ctx.HasAccessLevel Editor
open System.Threading.Tasks
/// Create a Task with a Some result for the given object
let someTask<'T> (it : 'T) = Task.FromResult (Some it)
let someTask<'T> (it: 'T) = Task.FromResult(Some it)
/// Create an absolute URL from a string that may already be an absolute URL
let absoluteUrl (url: string) (ctx: HttpContext) =
if url.StartsWith "http" then url else ctx.WebLog.AbsoluteUrl(Permalink url)
open System.Collections.Generic
open MyWebLog.Data
/// Get the templates available for the current web log's theme (in a key/value pair list)
let templatesForTheme (ctx : HttpContext) (typ : string) = backgroundTask {
/// Get the templates available for the current web log's theme (in a meta item list)
let templatesForTheme (ctx: HttpContext) (typ: string) = backgroundTask {
match! ctx.Data.Theme.FindByIdWithoutText ctx.WebLog.ThemeId with
| Some theme ->
return seq {
KeyValuePair.Create ("", $"- Default (single-{typ}) -")
{ Name = ""; Value = $"- Default (single-{typ}) -" }
yield!
theme.Templates
|> Seq.ofList
|> Seq.filter (fun it -> it.Name.EndsWith $"-{typ}" && it.Name <> $"single-{typ}")
|> Seq.map (fun it -> KeyValuePair.Create (it.Name, it.Name))
|> Seq.map (fun it -> { Name = it.Name; Value = it.Name })
}
|> Array.ofSeq
| None -> return [| KeyValuePair.Create ("", $"- Default (single-{typ}) -") |]
| None -> return seq { { Name = ""; Value = $"- Default (single-{typ}) -" } }
}
/// Get all authors for a list of posts as metadata items
let getAuthors (webLog : WebLog) (posts : Post list) (data : IData) =
let getAuthors (webLog: WebLog) (posts: Post list) (data: IData) =
posts
|> List.map (fun p -> p.AuthorId)
|> List.map _.AuthorId
|> List.distinct
|> data.WebLogUser.FindNames webLog.Id
/// Get all tag mappings for a list of posts as metadata items
let getTagMappings (webLog : WebLog) (posts : Post list) (data : IData) =
let getTagMappings (webLog: WebLog) (posts: Post list) (data: IData) =
posts
|> List.map (fun p -> p.Tags)
|> List.map _.Tags
|> List.concat
|> List.distinct
|> fun tags -> data.TagMap.FindMappingForTags tags webLog.Id
@@ -416,13 +458,12 @@ let getCategoryIds slug ctx =
|> Seq.map (fun c -> CategoryId c.Id)
|> List.ofSeq
open System
open System.Globalization
open NodaTime
/// Parse a date/time to UTC
let parseToUtc (date : string) =
Instant.FromDateTimeUtc (DateTime.Parse (date, null, DateTimeStyles.AdjustToUniversal))
let parseToUtc (date: string) : Instant =
let result = roundTrip.Parse date
if result.Success then result.Value else raise result.Exception
open Microsoft.Extensions.DependencyInjection
open Microsoft.Extensions.Logging
@@ -431,25 +472,24 @@ open Microsoft.Extensions.Logging
let mutable private debugEnabled : bool option = None
/// Is debug enabled for handlers?
let private isDebugEnabled (ctx : HttpContext) =
let private isDebugEnabled (ctx: HttpContext) =
match debugEnabled with
| Some flag -> flag
| None ->
let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory> ()
let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory>()
let log = fac.CreateLogger "MyWebLog.Handlers"
debugEnabled <- Some (log.IsEnabled LogLevel.Debug)
debugEnabled <- Some(log.IsEnabled LogLevel.Debug)
debugEnabled.Value
/// Log a debug message
let debug (name : string) ctx msg =
let debug (name: string) ctx msg =
if isDebugEnabled ctx then
let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory> ()
let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory>()
let log = fac.CreateLogger $"MyWebLog.Handlers.{name}"
log.LogDebug (msg ())
log.LogDebug(msg ())
/// Log a warning message
let warn (name : string) (ctx : HttpContext) msg =
let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory> ()
let warn (name: string) (ctx: HttpContext) msg =
let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory>()
let log = fac.CreateLogger $"MyWebLog.Handlers.{name}"
log.LogWarning msg

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

@@ -9,26 +9,22 @@ 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
let displayPages =
pages
|> Seq.ofList
|> Seq.truncate 25
|> Seq.map (DisplayPage.FromPageMinimal ctx.WebLog)
|> List.ofSeq
return!
hashForPage "Pages"
|> withAntiCsrf ctx
|> addToHash "pages" (pages
|> Seq.ofList
|> Seq.truncate 25
|> Seq.map (DisplayPage.fromPageMinimal ctx.WebLog)
|> List.ofSeq)
|> addToHash "page_nbr" pageNbr
|> addToHash "prev_page" (if pageNbr = 2 then "" else $"/page/{pageNbr - 1}")
|> addToHash "has_next" (List.length pages > 25)
|> addToHash "next_page" $"/page/{pageNbr + 1}"
|> adminView "page-list" next ctx
Views.Page.pageList displayPages pageNbr (pages.Length > 25)
|> adminPage "Pages" true next ctx
}
// GET /admin/page/{id}/edit
let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! result = task {
match pgId with
| "new" -> return Some ("Add a New Page", { Page.empty with Id = PageId "new"; AuthorId = ctx.UserId })
| "new" -> return Some ("Add a New Page", { Page.Empty with Id = PageId "new"; AuthorId = ctx.UserId })
| _ ->
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some page -> return Some ("Edit Page", page)
@@ -36,29 +32,21 @@ let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
}
match result with
| Some (title, page) when canEdit page.AuthorId ctx ->
let model = EditPageModel.fromPage page
let model = EditPageModel.FromPage page
let! templates = templatesForTheme ctx "page"
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
return! adminPage title true next ctx (Views.Page.pageEdit model templates)
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/page/{id}/delete
// DELETE /admin/page/{id}
let delete pgId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
match! ctx.Data.Page.Delete (PageId pgId) ctx.WebLog.Id with
| true ->
do! PageListCache.update ctx
do! addMessage ctx { UserMessage.success with Message = "Page deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with Message = "Page not found; nothing deleted" }
return! redirectToGet "admin/pages" next ctx
do! addMessage ctx { UserMessage.Success with Message = "Page deleted successfully" }
| false -> do! addMessage ctx { UserMessage.Error with Message = "Page not found; nothing deleted" }
return! all 1 next ctx
}
// GET /admin/page/{id}/permalinks
@@ -66,24 +54,23 @@ let editPermalinks pgId : HttpHandler = requireAccess Author >=> fun next ctx ->
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg when canEdit pg.AuthorId ctx ->
return!
hashForPage "Manage Prior Permalinks"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (ManagePermalinksModel.fromPage pg)
|> adminView "permalinks" next ctx
ManagePermalinksModel.FromPage pg
|> Views.Helpers.managePermalinks
|> adminPage "Manage Prior Permalinks" true next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/page/permalinks
let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
let! model = ctx.BindFormAsync<ManagePermalinksModel>()
let pageId = PageId model.Id
match! ctx.Data.Page.FindById pageId ctx.WebLog.Id with
| Some pg when canEdit pg.AuthorId ctx ->
let links = model.Prior |> Array.map Permalink |> List.ofArray
match! ctx.Data.Page.UpdatePriorPermalinks pageId ctx.WebLog.Id links with
| true ->
do! addMessage ctx { UserMessage.success with Message = "Page permalinks saved successfully" }
do! addMessage ctx { UserMessage.Success with Message = "Page permalinks saved successfully" }
return! redirectToGet $"admin/page/{model.Id}/permalinks" next ctx
| false -> return! Error.notFound next ctx
| Some _ -> return! Error.notAuthorized next ctx
@@ -95,29 +82,28 @@ let editRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx ->
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg when canEdit pg.AuthorId ctx ->
return!
hashForPage "Manage Page Revisions"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (ManageRevisionsModel.fromPage ctx.WebLog pg)
|> adminView "revisions" next ctx
ManageRevisionsModel.FromPage pg
|> Views.Helpers.manageRevisions
|> adminPage "Manage Page Revisions" true next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// GET /admin/page/{id}/revisions/purge
// DELETE /admin/page/{id}/revisions
let purgeRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data
match! data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg ->
do! data.Page.Update { pg with Revisions = [ List.head pg.Revisions ] }
do! addMessage ctx { UserMessage.success with Message = "Prior revisions purged successfully" }
return! redirectToGet $"admin/page/{pgId}/revisions" next ctx
do! addMessage ctx { UserMessage.Success with Message = "Prior revisions purged successfully" }
return! editRevisions pgId next ctx
| None -> return! Error.notFound next ctx
}
open Microsoft.AspNetCore.Http
/// Find the page and the requested revision
let private findPageRevision pgId revDate (ctx : HttpContext) = task {
let private findPageRevision pgId revDate (ctx: HttpContext) = task {
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg ->
let asOf = parseToUtc revDate
@@ -129,19 +115,9 @@ let private findPageRevision pgId revDate (ctx : HttpContext) = task {
let previewRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPageRevision pgId revDate ctx with
| Some pg, Some rev when canEdit pg.AuthorId ctx ->
let _, extra = WebLog.hostAndPath ctx.WebLog
return! {|
content =
[ """<div class="mwl-revision-preview mb-3">"""
(MarkupText.toHtml >> addBaseToRelativeUrls extra) rev.Text
"</div>"
]
|> String.concat ""
|}
|> makeHash |> adminBareView "" next ctx
return! adminBarePage "" false next ctx (Views.Helpers.commonPreview rev)
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
| None, _ | _, None -> return! Error.notFound next ctx
}
// POST /admin/page/{id}/revision/{revision-date}/restore
@@ -151,22 +127,21 @@ let restoreRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun
do! ctx.Data.Page.Update
{ pg with
Revisions = { rev with AsOf = Noda.now () }
:: (pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf))
}
do! addMessage ctx { UserMessage.success with Message = "Revision restored successfully" }
:: (pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) }
do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" }
return! redirectToGet $"admin/page/{pgId}/revisions" next ctx
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
}
// POST /admin/page/{id}/revision/{revision-date}/delete
// DELETE /admin/page/{id}/revision/{revision-date}
let deleteRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPageRevision pgId revDate ctx with
| Some pg, Some rev when canEdit pg.AuthorId ctx ->
do! ctx.Data.Page.Update { pg with Revisions = pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) }
do! addMessage ctx { UserMessage.success with Message = "Revision deleted successfully" }
return! adminBareView "" next ctx (makeHash {| content = "" |})
do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" }
return! adminBarePage "" false next ctx (fun _ -> [])
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
@@ -174,26 +149,26 @@ let deleteRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun
// POST /admin/page/save
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPageModel> ()
let! model = ctx.BindFormAsync<EditPageModel>()
let data = ctx.Data
let now = Noda.now ()
let tryPage =
if model.IsNew then
{ Page.empty with
Id = PageId.create ()
{ Page.Empty with
Id = PageId.Create()
WebLogId = ctx.WebLog.Id
AuthorId = ctx.UserId
PublishedOn = now
} |> someTask
else data.Page.FindFullById (PageId model.PageId) ctx.WebLog.Id
else data.Page.FindFullById (PageId model.Id) ctx.WebLog.Id
match! tryPage with
| Some page when canEdit page.AuthorId ctx ->
let updateList = page.IsInPageList <> model.IsShownInPageList
let updatedPage = model.UpdatePage page now
do! (if model.IsNew then data.Page.Add else data.Page.Update) updatedPage
if updateList then do! PageListCache.update ctx
do! addMessage ctx { UserMessage.success with Message = "Page saved successfully" }
return! redirectToGet $"admin/page/{PageId.toString page.Id}/edit" next ctx
do! addMessage ctx { UserMessage.Success with Message = "Page saved successfully" }
return! redirectToGet $"admin/page/{page.Id}/edit" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}

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

@@ -6,7 +6,7 @@ open System.Collections.Generic
open MyWebLog
/// Parse a slug and page number from an "everything else" URL
let private parseSlugAndPage webLog (slugAndPage : string seq) =
let private parseSlugAndPage webLog (slugAndPage: string seq) =
let fullPath = slugAndPage |> Seq.head
let slugPath = slugAndPage |> Seq.skip 1 |> Seq.head
let slugs, isFeed =
@@ -24,9 +24,10 @@ let private parseSlugAndPage webLog (slugAndPage : string seq) =
| idx when idx + 2 = slugs.Length -> Some (int slugs[pageIdx + 1])
| _ -> None
let slugParts = if pageIdx > 0 then Array.truncate pageIdx slugs else slugs
pageNbr, String.Join ("/", slugParts), isFeed
pageNbr, String.Join("/", slugParts), isFeed
/// The type of post list being prepared
[<Struct>]
type ListType =
| AdminList
| CategoryList
@@ -39,15 +40,15 @@ 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 (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)
let relUrl it = Some <| webLog.RelativeUrl(Permalink it)
let postItems =
posts
|> Seq.ofList
|> Seq.truncate perPage
|> Seq.map (PostListItem.fromPost webLog)
|> Seq.map (PostListItem.FromPost webLog)
|> Array.ofSeq
let! olderPost, newerPost =
match listType with
@@ -55,10 +56,10 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage (data :
let post = List.head posts
let target = defaultArg post.PublishedOn post.UpdatedOn
data.Post.FindSurroundingPosts webLog.Id target
| _ -> Task.FromResult (None, None)
| _ -> Task.FromResult(None, None)
let newerLink =
match listType, pageNbr with
| SinglePost, _ -> newerPost |> Option.map (fun p -> Permalink.toString p.Permalink)
| SinglePost, _ -> newerPost |> Option.map (fun it -> string it.Permalink)
| _, 1 -> None
| PostList, 2 when webLog.DefaultPage = "posts" -> Some ""
| PostList, _ -> relUrl $"page/{pageNbr - 1}"
@@ -70,7 +71,7 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage (data :
| AdminList, _ -> relUrl $"admin/posts/page/{pageNbr - 1}"
let olderLink =
match listType, List.length posts > perPage with
| SinglePost, _ -> olderPost |> Option.map (fun p -> Permalink.toString p.Permalink)
| SinglePost, _ -> olderPost |> Option.map (fun it -> string it.Permalink)
| _, false -> None
| PostList, true -> relUrl $"page/{pageNbr + 1}"
| CategoryList, true -> relUrl $"category/{url}/page/{pageNbr + 1}"
@@ -81,9 +82,9 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage (data :
Authors = authors
Subtitle = None
NewerLink = newerLink
NewerName = newerPost |> Option.map (fun p -> p.Title)
NewerName = newerPost |> Option.map _.Title
OlderLink = olderLink
OlderName = olderPost |> Option.map (fun p -> p.Title)
OlderName = olderPost |> Option.map _.Title
}
return
makeHash {||}
@@ -114,8 +115,8 @@ let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
}
// GET /page/{pageNbr}/
let redirectToPageOfPosts (pageNbr : int) : HttpHandler = fun next ctx ->
redirectTo true (WebLog.relativeUrl ctx.WebLog (Permalink $"page/{pageNbr}")) next ctx
let redirectToPageOfPosts (pageNbr: int) : HttpHandler = fun next ctx ->
redirectTo true (ctx.WebLog.RelativeUrl(Permalink $"page/{pageNbr}")) next ctx
// GET /category/{slug}/
// GET /category/{slug}/page/{pageNbr}
@@ -163,7 +164,7 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
| None -> return urlTag
}
if isFeed then
return! Feed.generate (Feed.TagFeed (tag, $"tag/{rawTag}/{webLog.Rss.FeedName}"))
return! Feed.generate (Feed.TagFeed(tag, $"tag/{rawTag}/{webLog.Rss.FeedName}"))
(defaultArg webLog.Rss.ItemsInFeed webLog.PostsPerPage) next ctx
else
match! data.Post.FindPageOfTaggedPosts webLog.Id tag pageNbr webLog.PostsPerPage with
@@ -178,13 +179,13 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
|> themedView "index" next ctx
// Other systems use hyphens for spaces; redirect if this is an old tag link
| _ ->
let spacedTag = tag.Replace ("-", " ")
let spacedTag = tag.Replace("-", " ")
match! data.Post.FindPageOfTaggedPosts webLog.Id spacedTag pageNbr 1 with
| posts when List.length posts > 0 ->
let endUrl = if pageNbr = 1 then "" else $"page/{pageNbr}"
return!
redirectTo true
(WebLog.relativeUrl webLog (Permalink $"""tag/{spacedTag.Replace (" ", "+")}/{endUrl}"""))
(webLog.RelativeUrl(Permalink $"""tag/{spacedTag.Replace (" ", "+")}/{endUrl}"""))
next ctx
| _ -> return! Error.notFound next ctx
| None, _, _ -> return! Error.notFound next ctx
@@ -200,22 +201,60 @@ let home : HttpHandler = fun next ctx -> task {
| Some page ->
return!
hashForPage page.Title
|> addToHash "page" (DisplayPage.fromPage webLog page)
|> addToHash "page" (DisplayPage.FromPage webLog page)
|> addToHash ViewContext.IsHome true
|> themedView (defaultArg page.Template "single-page") next ctx
| None -> return! Error.notFound next ctx
}
// GET /{post-permalink}?chapters
let chapters (post: Post) : HttpHandler = fun next ctx ->
match post.Episode with
| Some ep ->
match ep.Chapters with
| Some chapters ->
let chapterData =
chapters
|> Seq.ofList
|> Seq.map (fun it ->
let dic = Dictionary<string, obj>()
dic["startTime"] <- Math.Round(it.StartTime.TotalSeconds, 2)
it.Title |> Option.iter (fun ttl -> dic["title"] <- ttl)
it.ImageUrl |> Option.iter (fun img -> dic["img"] <- absoluteUrl img ctx)
it.Url |> Option.iter (fun url -> dic["url"] <- absoluteUrl url ctx)
it.IsHidden |> Option.iter (fun toc -> dic["toc"] <- not toc)
it.EndTime |> Option.iter (fun ent -> dic["endTime"] <- Math.Round(ent.TotalSeconds, 2))
it.Location |> Option.iter (fun loc ->
let locData = Dictionary<string, obj>()
locData["name"] <- loc.Name
locData["geo"] <- loc.Geo
loc.Osm |> Option.iter (fun osm -> locData["osm"] <- osm)
dic["location"] <- locData)
dic)
|> ResizeArray
let jsonFile = Dictionary<string, obj>()
jsonFile["version"] <- "1.2.0"
jsonFile["title"] <- post.Title
jsonFile["fileName"] <- absoluteUrl ep.Media ctx
if defaultArg ep.ChapterWaypoints false then jsonFile["waypoints"] <- true
jsonFile["chapters"] <- chapterData
(setContentType JSON_CHAPTERS >=> json jsonFile) next ctx
| None ->
match ep.ChapterFile with
| Some file -> redirectTo true file next ctx
| None -> Error.notFound next ctx
| None -> Error.notFound next ctx
// ~~ ADMINISTRATION ~~
// GET /admin/posts
// GET /admin/posts/page/{pageNbr}
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 data
return!
addToHash ViewContext.PageTitle "Posts" hash
|> withAntiCsrf ctx
|> adminView "post-list" next ctx
return! adminPage "Posts" true next ctx (Views.Post.list (hash[ViewContext.Model] :?> PostDisplay))
}
// GET /admin/post/{id}/edit
@@ -223,7 +262,7 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data
let! result = task {
match postId with
| "new" -> return Some ("Write a New Post", { Post.empty with Id = PostId "new" })
| "new" -> return Some ("Write a New Post", { Post.Empty with Id = PostId "new" })
| _ ->
match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post -> return Some ("Edit Post", post)
@@ -232,32 +271,25 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match result with
| Some (title, post) when canEdit post.AuthorId ctx ->
let! templates = templatesForTheme ctx "post"
let model = EditPostModel.fromPost ctx.WebLog post
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")
|]
|> adminView "post-edit" next ctx
let model = EditPostModel.FromPost ctx.WebLog post
let ratings = [
{ Name = ""; Value = "&ndash; Default &ndash;" }
{ Name = string Yes; Value = "Yes" }
{ Name = string No; Value = "No" }
{ Name = string Clean; Value = "Clean" }
]
return! adminPage title true next ctx (Views.Post.postEdit model templates ratings)
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/post/{id}/delete
// DELETE /admin/post/{id}
let delete postId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
match! ctx.Data.Post.Delete (PostId postId) ctx.WebLog.Id with
| true -> do! addMessage ctx { UserMessage.success with Message = "Post deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with Message = "Post not found; nothing deleted" }
return! redirectToGet "admin/posts" next ctx
| true -> do! addMessage ctx { UserMessage.Success with Message = "Post deleted successfully" }
| false -> do! addMessage ctx { UserMessage.Error with Message = "Post not found; nothing deleted" }
//return! redirectToGet "admin/posts" next ctx
return! all 1 next ctx
}
// GET /admin/post/{id}/permalinks
@@ -265,24 +297,23 @@ let editPermalinks postId : HttpHandler = requireAccess Author >=> fun next ctx
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post when canEdit post.AuthorId ctx ->
return!
hashForPage "Manage Prior Permalinks"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (ManagePermalinksModel.fromPost post)
|> adminView "permalinks" next ctx
ManagePermalinksModel.FromPost post
|> Views.Helpers.managePermalinks
|> adminPage "Manage Prior Permalinks" true next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/post/permalinks
let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
let! model = ctx.BindFormAsync<ManagePermalinksModel>()
let postId = PostId model.Id
match! ctx.Data.Post.FindById postId ctx.WebLog.Id with
| Some post when canEdit post.AuthorId ctx ->
let links = model.Prior |> Array.map Permalink |> List.ofArray
match! ctx.Data.Post.UpdatePriorPermalinks postId ctx.WebLog.Id links with
| true ->
do! addMessage ctx { UserMessage.success with Message = "Post permalinks saved successfully" }
do! addMessage ctx { UserMessage.Success with Message = "Post permalinks saved successfully" }
return! redirectToGet $"admin/post/{model.Id}/permalinks" next ctx
| false -> return! Error.notFound next ctx
| Some _ -> return! Error.notAuthorized next ctx
@@ -294,22 +325,21 @@ let editRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx -
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post when canEdit post.AuthorId ctx ->
return!
hashForPage "Manage Post Revisions"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model (ManageRevisionsModel.fromPost ctx.WebLog post)
|> adminView "revisions" next ctx
ManageRevisionsModel.FromPost post
|> Views.Helpers.manageRevisions
|> adminPage "Manage Post Revisions" true next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// GET /admin/post/{id}/revisions/purge
// DELETE /admin/post/{id}/revisions
let purgeRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data
match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post when canEdit post.AuthorId ctx ->
do! data.Post.Update { post with Revisions = [ List.head post.Revisions ] }
do! addMessage ctx { UserMessage.success with Message = "Prior revisions purged successfully" }
return! redirectToGet $"admin/post/{postId}/revisions" next ctx
do! addMessage ctx { UserMessage.Success with Message = "Prior revisions purged successfully" }
return! editRevisions postId next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@@ -317,7 +347,7 @@ let purgeRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx
open Microsoft.AspNetCore.Http
/// Find the post and the requested revision
let private findPostRevision postId revDate (ctx : HttpContext) = task {
let private findPostRevision postId revDate (ctx: HttpContext) = task {
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post ->
let asOf = parseToUtc revDate
@@ -329,19 +359,9 @@ let private findPostRevision postId revDate (ctx : HttpContext) = task {
let previewRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPostRevision postId revDate ctx with
| Some post, Some rev when canEdit post.AuthorId ctx ->
let _, extra = WebLog.hostAndPath ctx.WebLog
return! {|
content =
[ """<div class="mwl-revision-preview mb-3">"""
(MarkupText.toHtml >> addBaseToRelativeUrls extra) rev.Text
"</div>"
]
|> String.concat ""
|}
|> makeHash |> adminBareView "" next ctx
return! adminBarePage "" false next ctx (Views.Helpers.commonPreview rev)
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
| None, _ | _, None -> return! Error.notFound next ctx
}
// POST /admin/post/{id}/revision/{revision-date}/restore
@@ -351,39 +371,124 @@ let restoreRevision (postId, revDate) : HttpHandler = requireAccess Author >=> f
do! ctx.Data.Post.Update
{ post with
Revisions = { rev with AsOf = Noda.now () }
:: (post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf))
}
do! addMessage ctx { UserMessage.success with Message = "Revision restored successfully" }
:: (post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) }
do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" }
return! redirectToGet $"admin/post/{postId}/revisions" next ctx
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
}
// POST /admin/post/{id}/revision/{revision-date}/delete
// DELETE /admin/post/{id}/revision/{revision-date}
let deleteRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPostRevision postId revDate ctx with
| Some post, Some rev when canEdit post.AuthorId ctx ->
do! ctx.Data.Post.Update { post with Revisions = post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) }
do! addMessage ctx { UserMessage.success with Message = "Revision deleted successfully" }
return! adminBareView "" next ctx (makeHash {| content = "" |})
do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" }
return! adminBarePage "" false next ctx (fun _ -> [])
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
}
// GET /admin/post/{id}/chapters
let manageChapters postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.Post.FindById (PostId postId) ctx.WebLog.Id with
| Some post
when Option.isSome post.Episode
&& Option.isSome post.Episode.Value.Chapters
&& canEdit post.AuthorId ctx ->
return!
Views.Post.chapters false (ManageChaptersModel.Create post)
|> adminPage "Manage Chapters" true next ctx
| Some _ | None -> return! Error.notFound next ctx
}
// GET /admin/post/{id}/chapter/{idx}
let editChapter (postId, index) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.Post.FindById (PostId postId) ctx.WebLog.Id with
| Some post
when Option.isSome post.Episode
&& Option.isSome post.Episode.Value.Chapters
&& canEdit post.AuthorId ctx ->
let chapter =
if index = -1 then Some Chapter.Empty
else
let chapters = post.Episode.Value.Chapters.Value
if index < List.length chapters then Some chapters[index] else None
match chapter with
| Some chap ->
return!
Views.Post.chapterEdit (EditChapterModel.FromChapter post.Id index chap)
|> adminBarePage (if index = -1 then "Add a Chapter" else "Edit Chapter") true next ctx
| None -> return! Error.notFound next ctx
| Some _ | None -> return! Error.notFound next ctx
}
// POST /admin/post/{id}/chapter/{idx}
let saveChapter (postId, index) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data
match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post
when Option.isSome post.Episode
&& Option.isSome post.Episode.Value.Chapters
&& canEdit post.AuthorId ctx ->
let! form = ctx.BindFormAsync<EditChapterModel>()
let chapters = post.Episode.Value.Chapters.Value
if index >= -1 && index < List.length chapters then
try
let chapter = form.ToChapter()
let existing = if index = -1 then chapters else List.removeAt index chapters
let updatedPost =
{ post with
Episode = Some
{ post.Episode.Value with
Chapters = Some (chapter :: existing |> List.sortBy _.StartTime) } }
do! data.Post.Update updatedPost
do! addMessage ctx { UserMessage.Success with Message = "Chapter saved successfully" }
return!
Views.Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost)
|> adminBarePage "Manage Chapters" true next ctx
with
| ex -> return! Error.server ex.Message next ctx
else return! Error.notFound next ctx
| Some _ | None -> return! Error.notFound next ctx
}
// DELETE /admin/post/{id}/chapter/{idx}
let deleteChapter (postId, index) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data
match! data.Post.FindById (PostId postId) ctx.WebLog.Id with
| Some post
when Option.isSome post.Episode
&& Option.isSome post.Episode.Value.Chapters
&& canEdit post.AuthorId ctx ->
let chapters = post.Episode.Value.Chapters.Value
if index >= 0 && index < List.length chapters then
let updatedPost =
{ post with
Episode = Some { post.Episode.Value with Chapters = Some (List.removeAt index chapters) } }
do! data.Post.Update updatedPost
do! addMessage ctx { UserMessage.Success with Message = "Chapter deleted successfully" }
return!
Views.Post.chapterList false (ManageChaptersModel.Create updatedPost)
|> adminPage "Manage Chapters" true next ctx
else return! Error.notFound next ctx
| Some _ | None -> return! Error.notFound next ctx
}
// POST /admin/post/save
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPostModel> ()
let! model = ctx.BindFormAsync<EditPostModel>()
let data = ctx.Data
let tryPost =
if model.IsNew then
{ Post.empty with
Id = PostId.create ()
{ Post.Empty with
Id = PostId.Create()
WebLogId = ctx.WebLog.Id
AuthorId = ctx.UserId
} |> someTask
else data.Post.FindFullById (PostId model.PostId) ctx.WebLog.Id
AuthorId = ctx.UserId }
|> someTask
else data.Post.FindFullById (PostId model.Id) ctx.WebLog.Id
match! tryPost with
| Some post when canEdit post.AuthorId ctx ->
let priorCats = post.CategoryIds
@@ -397,11 +502,10 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
{ post with
PublishedOn = Some dt
UpdatedOn = dt
Revisions = [ { (List.head post.Revisions) with AsOf = dt } ]
}
Revisions = [ { (List.head post.Revisions) with AsOf = dt } ] }
else { post with PublishedOn = Some dt }
else post
do! (if model.PostId = "new" then data.Post.Add else data.Post.Update) updatedPost
do! (if model.IsNew then data.Post.Add else data.Post.Update) updatedPost
// If the post was published or its categories changed, refresh the category cache
if model.DoPublish
|| not (priorCats
@@ -409,8 +513,8 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
|> List.distinct
|> List.length = List.length priorCats) then
do! CategoryCache.update ctx
do! addMessage ctx { UserMessage.success with Message = "Post saved successfully" }
return! redirectToGet $"admin/post/{PostId.toString post.Id}/edit" next ctx
do! addMessage ctx { UserMessage.Success with Message = "Post saved successfully" }
return! redirectToGet $"admin/post/{post.Id}/edit" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}

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

@@ -11,28 +11,33 @@ module CatchAll =
open MyWebLog.ViewModels
/// Sequence where the first returned value is the proper handler for the link
let private deriveAction (ctx : HttpContext) : HttpHandler seq =
let private deriveAction (ctx: HttpContext) : HttpHandler seq =
let webLog = ctx.WebLog
let data = ctx.Data
let debug = debug "Routes.CatchAll" ctx
let textLink =
let _, extra = WebLog.hostAndPath webLog
let url = string ctx.Request.Path
(if extra = "" then url else url.Substring extra.Length).ToLowerInvariant ()
let extra = webLog.ExtraPath
let url = string ctx.Request.Path
(if extra = "" then url else url[extra.Length..]).ToLowerInvariant()
let await it = (Async.AwaitTask >> Async.RunSynchronously) it
seq {
debug (fun () -> $"Considering URL {textLink}")
// Home page directory without the directory slash
if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.empty)
let permalink = Permalink (textLink.Substring 1)
if textLink = "" then yield redirectTo true (webLog.RelativeUrl Permalink.Empty)
let permalink = Permalink textLink[1..]
// Current post
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 data |> await
yield fun next ctx ->
addToHash ViewContext.PageTitle post.Title hash
|> themedView (defaultArg post.Template "single-post") next ctx
if post.Status = Published || Option.isSome ctx.UserAccessLevel then
if ctx.Request.Query.ContainsKey "chapters" then
yield Post.chapters post
else
yield fun next ctx ->
Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 data
|> await
|> addToHash ViewContext.PageTitle post.Title
|> themedView (defaultArg post.Template "single-post") next ctx
| None -> ()
// Current page
match data.Page.FindByPermalink permalink webLog.Id |> await with
@@ -40,7 +45,7 @@ module CatchAll =
debug (fun () -> "Found page by permalink")
yield fun next ctx ->
hashForPage page.Title
|> addToHash "page" (DisplayPage.fromPage webLog page)
|> addToHash "page" (DisplayPage.FromPage webLog page)
|> addToHash ViewContext.IsPage true
|> themedView (defaultArg page.Template "single-page") next ctx
| None -> ()
@@ -56,25 +61,25 @@ module CatchAll =
match data.Post.FindByPermalink altLink webLog.Id |> await with
| Some post ->
debug (fun () -> "Found post by trailing-slash-agnostic permalink")
yield redirectTo true (WebLog.relativeUrl webLog post.Permalink)
yield redirectTo true (webLog.RelativeUrl post.Permalink)
| None -> ()
// Page differing only by trailing slash
match data.Page.FindByPermalink altLink webLog.Id |> await with
| Some page ->
debug (fun () -> "Found page by trailing-slash-agnostic permalink")
yield redirectTo true (WebLog.relativeUrl webLog page.Permalink)
yield redirectTo true (webLog.RelativeUrl page.Permalink)
| None -> ()
// Prior post
match data.Post.FindCurrentPermalink [ permalink; altLink ] webLog.Id |> await with
| Some link ->
debug (fun () -> "Found post by prior permalink")
yield redirectTo true (WebLog.relativeUrl webLog link)
yield redirectTo true (webLog.RelativeUrl link)
| None -> ()
// Prior page
match data.Page.FindCurrentPermalink [ permalink; altLink ] webLog.Id |> await with
| Some link ->
debug (fun () -> "Found page by prior permalink")
yield redirectTo true (WebLog.relativeUrl webLog link)
yield redirectTo true (webLog.RelativeUrl link)
| None -> ()
debug (fun () -> "No content found")
}
@@ -88,13 +93,13 @@ module CatchAll =
module Asset =
// GET /theme/{theme}/{**path}
let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task {
let serve (urlParts: string seq) : HttpHandler = fun next ctx -> task {
let path = urlParts |> Seq.skip 1 |> Seq.head
match! ctx.Data.ThemeAsset.FindById (ThemeAssetId.ofString path) with
match! ctx.Data.ThemeAsset.FindById(ThemeAssetId.Parse path) with
| Some asset ->
match Upload.checkModified asset.UpdatedOn ctx with
| Some threeOhFour -> return! threeOhFour next ctx
| None -> return! Upload.sendFile (asset.UpdatedOn.ToDateTimeUtc ()) path asset.Data next ctx
| None -> return! Upload.sendFile (asset.UpdatedOn.ToDateTimeUtc()) path asset.Data next ctx
| None -> return! Error.notFound next ctx
}
@@ -107,9 +112,8 @@ let router : HttpHandler = choose [
subRoute "/admin" (requireUser >=> choose [
GET_HEAD >=> choose [
route "/administration" >=> Admin.Dashboard.admin
subRoute "/categor" (choose [
subRoute "/categor" (requireAccess WebLogAdmin >=> choose [
route "ies" >=> Admin.Category.all
route "ies/bare" >=> Admin.Category.bare
routef "y/%s/edit" Admin.Category.edit
])
route "/dashboard" >=> Admin.Dashboard.user
@@ -129,18 +133,24 @@ let router : HttpHandler = choose [
routef "/%s/permalinks" Post.editPermalinks
routef "/%s/revision/%s/preview" Post.previewRevision
routef "/%s/revisions" Post.editRevisions
routef "/%s/chapter/%i" Post.editChapter
routef "/%s/chapters" Post.manageChapters
])
subRoute "/settings" (choose [
route "" >=> Admin.WebLog.settings
routef "/rss/%s/edit" Feed.editCustomFeed
subRoute "/user" (choose [
route "s" >=> User.all
routef "/%s/edit" User.edit
subRoute "/settings" (requireAccess WebLogAdmin >=> choose [
route "" >=> Admin.WebLog.settings
routef "/rss/%s/edit" Feed.editCustomFeed
subRoute "/redirect-rules" (choose [
route "" >=> Admin.RedirectRules.all
routef "/%i" Admin.RedirectRules.edit
])
subRoute "/tag-mapping" (choose [
route "s" >=> Admin.TagMapping.all
routef "/%s/edit" Admin.TagMapping.edit
])
subRoute "/user" (choose [
route "s" >=> User.all
routef "/%s/edit" User.edit
])
])
subRoute "/theme" (choose [
route "/list" >=> Admin.Theme.all
@@ -156,7 +166,7 @@ let router : HttpHandler = choose [
routef "/theme/%s/refresh" Admin.Cache.refreshTheme
routef "/web-log/%s/refresh" Admin.Cache.refreshWebLog
])
subRoute "/category" (choose [
subRoute "/category" (requireAccess WebLogAdmin >=> choose [
route "/save" >=> Admin.Category.save
routef "/%s/delete" Admin.Category.delete
])
@@ -164,43 +174,56 @@ let router : HttpHandler = choose [
subRoute "/page" (choose [
route "/save" >=> Page.save
route "/permalinks" >=> Page.savePermalinks
routef "/%s/delete" Page.delete
routef "/%s/revision/%s/delete" Page.deleteRevision
routef "/%s/revision/%s/restore" Page.restoreRevision
routef "/%s/revisions/purge" Page.purgeRevisions
])
subRoute "/post" (choose [
route "/save" >=> Post.save
route "/permalinks" >=> Post.savePermalinks
routef "/%s/delete" Post.delete
routef "/%s/revision/%s/delete" Post.deleteRevision
routef "/%s/chapter/%i" Post.saveChapter
routef "/%s/revision/%s/restore" Post.restoreRevision
routef "/%s/revisions/purge" Post.purgeRevisions
])
subRoute "/settings" (choose [
route "" >=> Admin.WebLog.saveSettings
subRoute "/settings" (requireAccess WebLogAdmin >=> choose [
route "" >=> Admin.WebLog.saveSettings
subRoute "/rss" (choose [
route "" >=> Feed.saveSettings
route "/save" >=> Feed.saveCustomFeed
routef "/%s/delete" Feed.deleteCustomFeed
route "" >=> Feed.saveSettings
route "/save" >=> Feed.saveCustomFeed
])
subRoute "/tag-mapping" (choose [
route "/save" >=> Admin.TagMapping.save
routef "/%s/delete" Admin.TagMapping.delete
])
subRoute "/user" (choose [
route "/save" >=> User.save
routef "/%s/delete" User.delete
subRoute "/redirect-rules" (choose [
routef "/%i" Admin.RedirectRules.save
routef "/%i/up" Admin.RedirectRules.moveUp
routef "/%i/down" Admin.RedirectRules.moveDown
])
route "/tag-mapping/save" >=> Admin.TagMapping.save
route "/user/save" >=> User.save
])
subRoute "/theme" (choose [
route "/new" >=> Admin.Theme.save
routef "/%s/delete" Admin.Theme.delete
])
subRoute "/upload" (choose [
route "/save" >=> Upload.save
routexp "/delete/(.*)" Upload.deleteFromDisk
routef "/%s/delete" Upload.deleteFromDb
route "/upload/save" >=> Upload.save
]
DELETE >=> validateCsrf >=> choose [
routef "/category/%s" Admin.Category.delete
subRoute "/page" (choose [
routef "/%s" Page.delete
routef "/%s/revision/%s" Page.deleteRevision
routef "/%s/revisions" Page.purgeRevisions
])
subRoute "/post" (choose [
routef "/%s" Post.delete
routef "/%s/chapter/%i" Post.deleteChapter
routef "/%s/revision/%s" Post.deleteRevision
routef "/%s/revisions" Post.purgeRevisions
])
subRoute "/settings" (requireAccess WebLogAdmin >=> choose [
routef "/redirect-rules/%i" Admin.RedirectRules.delete
routef "/rss/%s" Feed.deleteCustomFeed
routef "/tag-mapping/%s" Admin.TagMapping.delete
routef "/user/%s" User.delete
])
subRoute "/upload" (requireAccess WebLogAdmin >=> choose [
routexp "/disk/(.*)" Upload.deleteFromDisk
routef "/%s" Upload.deleteFromDb
])
]
])
@@ -229,7 +252,7 @@ let routerWithPath extraPath : HttpHandler =
/// Handler to apply Giraffe routing with a possible sub-route
let handleRoute : HttpHandler = fun next ctx ->
let _, extraPath = WebLog.hostAndPath ctx.WebLog
let extraPath = ctx.WebLog.ExtraPath
(if extraPath = "" then router else routerWithPath extraPath) next ctx

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

@@ -12,7 +12,7 @@ module private Helpers =
open Microsoft.AspNetCore.StaticFiles
/// A MIME type mapper instance to use when serving files from the database
let mimeMap = FileExtensionContentTypeProvider ()
let mimeMap = FileExtensionContentTypeProvider()
/// A cache control header that instructs the browser to cache the result for no more than 30 days
let cacheForThirtyDays =
@@ -24,7 +24,7 @@ module private Helpers =
let slash = Path.DirectorySeparatorChar
/// The base directory where uploads are stored, relative to the executable
let uploadDir = Path.Combine ("wwwroot", "upload")
let uploadDir = Path.Combine("wwwroot", "upload")
// ~~ SERVING UPLOADS ~~
@@ -35,10 +35,10 @@ open Microsoft.AspNetCore.Http
open NodaTime
/// Determine if the file has been modified since the date/time specified by the If-Modified-Since header
let checkModified since (ctx : HttpContext) : HttpHandler option =
let checkModified since (ctx: HttpContext) : HttpHandler option =
match ctx.Request.Headers.IfModifiedSince with
| it when it.Count < 1 -> None
| it when since > Instant.FromDateTimeUtc (DateTime.Parse (it[0], null, DateTimeStyles.AdjustToUniversal)) -> None
| it when since > Instant.FromDateTimeUtc(DateTime.Parse(it[0], null, DateTimeStyles.AdjustToUniversal)) -> None
| _ -> Some (setStatusCode 304)
@@ -53,29 +53,29 @@ let sendFile updatedOn path (data : byte[]) : HttpHandler = fun next ctx ->
let headers = ResponseHeaders ctx.Response.Headers
headers.ContentType <- (deriveMimeType >> MediaTypeHeaderValue) path
headers.CacheControl <- cacheForThirtyDays
let stream = new MemoryStream (data)
let stream = new MemoryStream(data)
streamData true stream None (Some (DateTimeOffset updatedOn)) next ctx
open MyWebLog
// GET /upload/{web-log-slug}/{**path}
let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task {
let serve (urlParts: string seq) : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog
let parts = (urlParts |> Seq.skip 1 |> Seq.head).Split '/'
let slug = Array.head parts
if slug = webLog.Slug then
// Static file middleware will not work in subdirectories; check for an actual file first
let fileName = Path.Combine ("wwwroot", (Seq.head urlParts)[1..])
let fileName = Path.Combine("wwwroot", (Seq.head urlParts)[1..])
if File.Exists fileName then
return! streamFile true fileName None None next ctx
else
let path = String.Join ('/', Array.skip 1 parts)
let path = String.Join('/', Array.skip 1 parts)
match! ctx.Data.Upload.FindByPath path webLog.Id with
| Some upload ->
match checkModified upload.UpdatedOn ctx with
| Some threeOhFour -> return! threeOhFour next ctx
| None -> return! sendFile (upload.UpdatedOn.ToDateTimeUtc ()) path upload.Data next ctx
| None -> return! sendFile (upload.UpdatedOn.ToDateTimeUtc()) path upload.Data next ctx
| None -> return! Error.notFound next ctx
else
return! Error.notFound next ctx
@@ -87,122 +87,109 @@ open System.Text.RegularExpressions
open MyWebLog.ViewModels
/// Turn a string into a lowercase URL-safe slug
let makeSlug it = ((Regex """\s+""").Replace ((Regex "[^A-z0-9 -]").Replace (it, ""), "-")).ToLowerInvariant ()
let makeSlug it = (Regex """\s+""").Replace((Regex "[^A-z0-9 -]").Replace(it, ""), "-").ToLowerInvariant()
// GET /admin/uploads
let list : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let webLog = ctx.WebLog
let! dbUploads = ctx.Data.Upload.FindByWebLog webLog.Id
let diskUploads =
let path = Path.Combine (uploadDir, webLog.Slug)
let path = Path.Combine(uploadDir, webLog.Slug)
try
Directory.EnumerateFiles (path, "*", SearchOption.AllDirectories)
Directory.EnumerateFiles(path, "*", SearchOption.AllDirectories)
|> Seq.map (fun file ->
let name = Path.GetFileName file
let create =
match File.GetCreationTime (Path.Combine (path, file)) with
match File.GetCreationTime(Path.Combine(path, file)) with
| dt when dt > DateTime.UnixEpoch -> Some dt
| _ -> None
{ DisplayUpload.Id = ""
Name = name
Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace (slash, '/')
Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace(slash, '/')
UpdatedOn = create
Source = UploadDestination.toString Disk
})
|> List.ofSeq
Source = string Disk })
with
| :? DirectoryNotFoundException -> [] // This is fine
| ex ->
warn "Upload" ctx $"Encountered {ex.GetType().Name} listing uploads for {path}:\n{ex.Message}"
[]
let allFiles =
dbUploads
|> List.map (DisplayUpload.fromUpload webLog Database)
|> List.append diskUploads
|> List.sortByDescending (fun file -> file.UpdatedOn, file.Path)
return!
hashForPage "Uploaded Files"
|> withAntiCsrf ctx
|> addToHash "files" allFiles
|> adminView "upload-list" next ctx
dbUploads
|> Seq.ofList
|> Seq.map (DisplayUpload.FromUpload webLog Database)
|> Seq.append diskUploads
|> Seq.sortByDescending (fun file -> file.UpdatedOn, file.Path)
|> Views.WebLog.uploadList
|> adminPage "Uploaded Files" true next ctx
}
// GET /admin/upload/new
let showNew : HttpHandler = requireAccess Author >=> fun 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
let showUploads : HttpHandler =
redirectToGet "admin/uploads"
adminPage "Upload a File" true next ctx Views.WebLog.uploadNew
// POST /admin/upload/save
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then
let upload = Seq.head ctx.Request.Form.Files
let fileName = String.Concat (makeSlug (Path.GetFileNameWithoutExtension upload.FileName),
Path.GetExtension(upload.FileName).ToLowerInvariant ())
Path.GetExtension(upload.FileName).ToLowerInvariant())
let now = Noda.now ()
let localNow = WebLog.localTime ctx.WebLog now
let localNow = ctx.WebLog.LocalTime now
let year = localNow.ToString "yyyy"
let month = localNow.ToString "MM"
let! form = ctx.BindFormAsync<UploadFileModel> ()
let! form = ctx.BindFormAsync<UploadFileModel>()
match UploadDestination.parse form.Destination with
match UploadDestination.Parse form.Destination with
| Database ->
use stream = new MemoryStream ()
use stream = new MemoryStream()
do! upload.CopyToAsync stream
let file =
{ Id = UploadId.create ()
{ Id = UploadId.Create()
WebLogId = ctx.WebLog.Id
Path = Permalink $"{year}/{month}/{fileName}"
UpdatedOn = now
Data = stream.ToArray ()
}
Data = stream.ToArray() }
do! ctx.Data.Upload.Add file
| Disk ->
let fullPath = Path.Combine (uploadDir, ctx.WebLog.Slug, year, month)
let fullPath = Path.Combine(uploadDir, ctx.WebLog.Slug, year, month)
let _ = Directory.CreateDirectory fullPath
use stream = new FileStream (Path.Combine (fullPath, fileName), FileMode.Create)
use stream = new FileStream(Path.Combine(fullPath, fileName), FileMode.Create)
do! upload.CopyToAsync stream
do! addMessage ctx { UserMessage.success with Message = $"File uploaded to {form.Destination} successfully" }
return! showUploads next ctx
do! addMessage ctx { UserMessage.Success with Message = $"File uploaded to {form.Destination} successfully" }
return! redirectToGet "admin/uploads" next ctx
else
return! RequestErrors.BAD_REQUEST "Bad request; no file present" next ctx
}
// POST /admin/upload/{id}/delete
let deleteFromDb upId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
// DELETE /admin/upload/{id}
let deleteFromDb upId : HttpHandler = fun next ctx -> task {
match! ctx.Data.Upload.Delete (UploadId upId) ctx.WebLog.Id with
| Ok fileName ->
do! addMessage ctx { UserMessage.success with Message = $"{fileName} deleted successfully" }
return! showUploads next ctx
do! addMessage ctx { UserMessage.Success with Message = $"{fileName} deleted successfully" }
return! list next ctx
| Error _ -> return! Error.notFound next ctx
}
/// Remove a directory tree if it is empty
let removeEmptyDirectories (webLog : WebLog) (filePath : string) =
let removeEmptyDirectories (webLog: WebLog) (filePath: string) =
let mutable path = Path.GetDirectoryName filePath
let mutable finished = false
while (not finished) && path > "" do
let fullPath = Path.Combine (uploadDir, webLog.Slug, path)
let fullPath = Path.Combine(uploadDir, webLog.Slug, path)
if Directory.EnumerateFileSystemEntries fullPath |> Seq.isEmpty then
Directory.Delete fullPath
path <- String.Join(slash, path.Split slash |> Array.rev |> Array.skip 1 |> Array.rev)
else finished <- true
// POST /admin/upload/delete/{**path}
let deleteFromDisk urlParts : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
// DELETE /admin/upload/disk/{**path}
let deleteFromDisk urlParts : HttpHandler = fun next ctx -> task {
let filePath = urlParts |> Seq.skip 1 |> Seq.head
let path = Path.Combine (uploadDir, ctx.WebLog.Slug, filePath)
let path = Path.Combine(uploadDir, ctx.WebLog.Slug, filePath)
if File.Exists path then
File.Delete path
removeEmptyDirectories ctx.WebLog filePath
do! addMessage ctx { UserMessage.success with Message = $"{filePath} deleted successfully" }
return! showUploads next ctx
do! addMessage ctx { UserMessage.Success with Message = $"{filePath} deleted successfully" }
return! list next ctx
else return! Error.notFound next ctx
}

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

@@ -5,23 +5,22 @@ open System
open Microsoft.AspNetCore.Http
open Microsoft.AspNetCore.Identity
open MyWebLog
open NodaTime
// ~~ LOG ON / LOG OFF ~~
/// Create a password hash a password for a given user
let createPasswordHash user password =
PasswordHasher<WebLogUser>().HashPassword (user, password)
PasswordHasher<WebLogUser>().HashPassword(user, password)
/// Verify whether a password is valid
let verifyPassword user password (ctx : HttpContext) = backgroundTask {
let verifyPassword user password (ctx: HttpContext) = backgroundTask {
match user with
| Some usr ->
let hasher = PasswordHasher<WebLogUser> ()
match hasher.VerifyHashedPassword (usr, usr.PasswordHash, password) with
let hasher = PasswordHasher<WebLogUser>()
match hasher.VerifyHashedPassword(usr, usr.PasswordHash, password) with
| PasswordVerificationResult.Success -> return Ok ()
| PasswordVerificationResult.SuccessRehashNeeded ->
do! ctx.Data.WebLogUser.Update { usr with PasswordHash = hasher.HashPassword (usr, password) }
do! ctx.Data.WebLogUser.Update { usr with PasswordHash = hasher.HashPassword(usr, password) }
return Ok ()
| _ -> return Error "Log on attempt unsuccessful"
| None -> return Error "Log on attempt unsuccessful"
@@ -36,10 +35,7 @@ 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
hashForPage "Log On"
|> withAntiCsrf ctx
|> addToHash ViewContext.Model { LogOnModel.empty with ReturnTo = returnTo }
|> adminView "log-on" next ctx
adminPage "Log On" true next ctx (Views.User.logOn { LogOnModel.Empty with ReturnTo = returnTo })
open System.Security.Claims
@@ -48,90 +44,74 @@ open Microsoft.AspNetCore.Authentication.Cookies
// POST /user/log-on
let doLogOn : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<LogOnModel> ()
let! model = ctx.BindFormAsync<LogOnModel>()
let data = ctx.Data
let! tryUser = data.WebLogUser.FindByEmail model.EmailAddress ctx.WebLog.Id
match! verifyPassword tryUser model.Password ctx with
| Ok _ ->
let user = tryUser.Value
let claims = seq {
Claim (ClaimTypes.NameIdentifier, WebLogUserId.toString user.Id)
Claim (ClaimTypes.Name, $"{user.FirstName} {user.LastName}")
Claim (ClaimTypes.GivenName, user.PreferredName)
Claim (ClaimTypes.Role, AccessLevel.toString user.AccessLevel)
Claim(ClaimTypes.NameIdentifier, string user.Id)
Claim(ClaimTypes.Name, $"{user.FirstName} {user.LastName}")
Claim(ClaimTypes.GivenName, user.PreferredName)
Claim(ClaimTypes.Role, string user.AccessLevel)
}
let identity = ClaimsIdentity (claims, CookieAuthenticationDefaults.AuthenticationScheme)
let identity = ClaimsIdentity(claims, CookieAuthenticationDefaults.AuthenticationScheme)
do! ctx.SignInAsync (identity.AuthenticationType, ClaimsPrincipal identity,
AuthenticationProperties (IssuedUtc = DateTimeOffset.UtcNow))
do! ctx.SignInAsync(identity.AuthenticationType, ClaimsPrincipal identity,
AuthenticationProperties(IssuedUtc = DateTimeOffset.UtcNow))
do! data.WebLogUser.SetLastSeen user.Id user.WebLogId
do! addMessage ctx
{ UserMessage.success with
{ UserMessage.Success with
Message = "Log on successful"
Detail = Some $"Welcome to {ctx.WebLog.Name}!"
}
Detail = Some $"Welcome to {ctx.WebLog.Name}!" }
return!
match model.ReturnTo with
| Some url -> redirectTo false url next ctx
| Some url -> redirectTo false url next ctx // TODO: change to redirectToGet?
| None -> redirectToGet "admin/dashboard" next ctx
| Error msg ->
do! addMessage ctx { UserMessage.error with Message = msg }
do! addMessage ctx { UserMessage.Error with Message = msg }
return! logOn model.ReturnTo next ctx
}
// GET /user/log-off
let logOff : HttpHandler = fun next ctx -> task {
do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme
do! addMessage ctx { UserMessage.info with Message = "Log off successful" }
do! addMessage ctx { UserMessage.Info with Message = "Log off successful" }
return! redirectToGet "" next ctx
}
// ~~ ADMINISTRATION ~~
open System.Collections.Generic
open Giraffe.Htmx
/// Got no time for URL/form manipulators...
let private goAway : HttpHandler = RequestErrors.BAD_REQUEST "really?"
// GET /admin/settings/users
let all : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let all : HttpHandler = fun next ctx -> task {
let! users = ctx.Data.WebLogUser.FindByWebLog ctx.WebLog.Id
return!
hashForPage "User Administration"
|> withAntiCsrf ctx
|> addToHash "users" (users |> List.map (DisplayUser.fromUser ctx.WebLog) |> Array.ofList)
|> adminBareView "user-list-body" next ctx
return! adminBarePage "User Administration" true next ctx (Views.User.userList users)
}
/// Show the edit user page
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
let private showEdit (model: EditUserModel) : HttpHandler = fun next ctx ->
adminBarePage (if model.IsNew then "Add a New User" else "Edit User") true next ctx (Views.User.edit model)
// GET /admin/settings/user/{id}/edit
let edit usrId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let edit usrId : HttpHandler = fun next ctx -> task {
let isNew = usrId = "new"
let userId = WebLogUserId usrId
let tryUser =
if isNew then someTask { WebLogUser.empty with Id = userId }
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 (EditUserModel.fromUser user) next ctx
| Some user -> return! showEdit (EditUserModel.FromUser user) next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/settings/user/{id}/delete
let delete userId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
// DELETE /admin/settings/user/{id}
let delete userId : HttpHandler = fun next ctx -> task {
let data = ctx.Data
match! data.WebLogUser.FindById (WebLogUserId userId) ctx.WebLog.Id with
| Some user ->
@@ -141,43 +121,31 @@ let delete userId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
match! data.WebLogUser.Delete user.Id user.WebLogId with
| Ok _ ->
do! addMessage ctx
{ UserMessage.success with
Message = $"User {WebLogUser.displayName user} deleted successfully"
}
{ UserMessage.Success with
Message = $"User {user.DisplayName} deleted successfully" }
return! all next ctx
| Error msg ->
do! addMessage ctx
{ UserMessage.error with
Message = $"User {WebLogUser.displayName user} was not deleted"
Detail = Some msg
}
{ UserMessage.Error with
Message = $"User {user.DisplayName} was not deleted"
Detail = Some msg }
return! all next ctx
| None -> return! Error.notFound next ctx
}
/// Display the user "my info" page, with information possibly filled in
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 (Instant.FromUnixTimeSeconds 0)))
|> adminView "my-info" next ctx
// GET /admin/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 (EditMyInfoModel.fromUser user) user next ctx
| Some user ->
return!
Views.User.myInfo (EditMyInfoModel.FromUser user) user
|> adminPage "Edit Your Information" true next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/my-info
let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditMyInfoModel> ()
let! model = ctx.BindFormAsync<EditMyInfoModel>()
let data = ctx.Data
match! data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with
| Some user when model.NewPassword = model.NewPasswordConfirm ->
@@ -187,15 +155,16 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
FirstName = model.FirstName
LastName = model.LastName
PreferredName = model.PreferredName
PasswordHash = pw
}
PasswordHash = pw }
do! data.WebLogUser.Update user
let pwMsg = if model.NewPassword = "" then "" else " and updated your password"
do! addMessage ctx { UserMessage.success with Message = $"Saved your information{pwMsg} successfully" }
do! addMessage ctx { UserMessage.Success with Message = $"Saved your information{pwMsg} successfully" }
return! redirectToGet "admin/my-info" next ctx
| Some user ->
do! addMessage ctx { UserMessage.error with Message = "Passwords did not match; no updates made" }
return! showMyInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user next ctx
do! addMessage ctx { UserMessage.Error with Message = "Passwords did not match; no updates made" }
return!
Views.User.myInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user
|> adminPage "Edit Your Information" true next ctx
| None -> return! Error.notFound next ctx
}
@@ -204,15 +173,15 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
// POST /admin/settings/user/save
let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditUserModel> ()
let! model = ctx.BindFormAsync<EditUserModel>()
let data = ctx.Data
let tryUser =
if model.IsNew then
{ WebLogUser.empty with
Id = WebLogUserId.create ()
{ WebLogUser.Empty with
Id = WebLogUserId.Create()
WebLogId = ctx.WebLog.Id
CreatedOn = Noda.now ()
} |> someTask
CreatedOn = Noda.now () }
|> someTask
else data.WebLogUser.FindById (WebLogUserId model.Id) ctx.WebLog.Id
match! tryUser with
| Some user when model.Password = model.PasswordConfirm ->
@@ -225,12 +194,11 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
else { updatedUser with PasswordHash = createPasswordHash updatedUser model.Password }
do! (if model.IsNew then data.WebLogUser.Add else data.WebLogUser.Update) toUpdate
do! addMessage ctx
{ UserMessage.success with
Message = $"""{if model.IsNew then "Add" else "Updat"}ed user successfully"""
}
{ UserMessage.Success with
Message = $"""{if model.IsNew then "Add" else "Updat"}ed user successfully""" }
return! all next ctx
| Some _ ->
do! addMessage ctx { UserMessage.error with Message = "The passwords did not match; nothing saved" }
do! addMessage ctx { UserMessage.Error with Message = "The passwords did not match; nothing saved" }
return!
(withHxRetarget $"#user_{model.Id}" >=> showEdit { model with Password = ""; PasswordConfirm = "" })
next ctx

219
src/MyWebLog/Maintenance.fs
View File

@@ -7,9 +7,9 @@ open MyWebLog.Data
open NodaTime
/// Create the web log information
let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
let private doCreateWebLog (args: string[]) (sp: IServiceProvider) = task {
let data = sp.GetRequiredService<IData> ()
let data = sp.GetRequiredService<IData>()
let timeZone =
let local = TimeZoneInfo.Local.Id
@@ -21,30 +21,29 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
| false, _ -> raise <| TimeZoneNotFoundException $"Cannot find IANA timezone for {local}"
// Create the web log
let webLogId = WebLogId.create ()
let userId = WebLogUserId.create ()
let homePageId = PageId.create ()
let webLogId = WebLogId.Create()
let userId = WebLogUserId.Create()
let homePageId = PageId.Create()
let slug = Handlers.Upload.makeSlug args[2]
// If this is the first web log being created, the user will be an installation admin; otherwise, they will be an
// admin just over their web log
let! webLogs = data.WebLog.All ()
let! webLogs = data.WebLog.All()
let accessLevel = if List.isEmpty webLogs then Administrator else WebLogAdmin
do! data.WebLog.Add
{ WebLog.empty with
{ WebLog.Empty with
Id = webLogId
Name = args[2]
Slug = slug
UrlBase = args[1]
DefaultPage = PageId.toString homePageId
TimeZone = timeZone
}
DefaultPage = string homePageId
TimeZone = timeZone }
// Create the admin user
let now = Noda.now ()
let user =
{ WebLogUser.empty with
{ WebLogUser.Empty with
Id = userId
WebLogId = webLogId
Email = args[3]
@@ -52,13 +51,12 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
LastName = "User"
PreferredName = "Admin"
AccessLevel = accessLevel
CreatedOn = now
}
CreatedOn = now }
do! data.WebLogUser.Add { user with PasswordHash = Handlers.User.createPasswordHash user args[4] }
// Create the default home page
do! data.Page.Add
{ Page.empty with
{ Page.Empty with
Id = homePageId
WebLogId = webLogId
AuthorId = userId
@@ -69,16 +67,14 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
Text = "<p>This is your default home page.</p>"
Revisions = [
{ AsOf = now
Text = Html "<p>This is your default home page.</p>"
}
]
}
Text = Html "<p>This is your default home page.</p>" }
] }
printfn $"Successfully initialized database for {args[2]} with URL base {args[1]}"
match accessLevel with
| Administrator -> printfn $" ({args[3]} is an installation administrator)"
| WebLogAdmin ->
printfn $" ({args[3]} is a web log administrator;"
printfn $" ({args[3]} is a web log administrator;"
printfn """ use "upgrade-user" to promote to installation administrator)"""
| _ -> ()
}
@@ -91,8 +87,8 @@ let createWebLog args sp = task {
}
/// Import prior permalinks from a text files with lines in the format "[old] [new]"
let private importPriorPermalinks urlBase file (sp : IServiceProvider) = task {
let data = sp.GetRequiredService<IData> ()
let private importPriorPermalinks urlBase file (sp: IServiceProvider) = task {
let data = sp.GetRequiredService<IData>()
match! data.WebLog.FindByHost urlBase with
| Some webLog ->
@@ -110,8 +106,8 @@ let private importPriorPermalinks urlBase file (sp : IServiceProvider) = task {
let! withLinks = data.Post.FindFullById post.Id post.WebLogId
let! _ = data.Post.UpdatePriorPermalinks post.Id post.WebLogId
(old :: withLinks.Value.PriorPermalinks)
printfn $"{Permalink.toString old} -> {Permalink.toString current}"
| None -> eprintfn $"Cannot find current post for {Permalink.toString current}"
printfn $"{old} -> {current}"
| None -> eprintfn $"Cannot find current post for {current}"
printfn "Done!"
| None -> eprintfn $"No web log found at {urlBase}"
}
@@ -129,7 +125,7 @@ let importLinks args sp = task {
open Microsoft.Extensions.Logging
/// Load a theme from the given ZIP file
let loadTheme (args : string[]) (sp : IServiceProvider) = task {
let loadTheme (args: string[]) (sp: IServiceProvider) = task {
if args.Length = 2 then
let fileName =
match args[1].LastIndexOf Path.DirectorySeparatorChar with
@@ -137,14 +133,14 @@ let loadTheme (args : string[]) (sp : IServiceProvider) = task {
| it -> args[1][(it + 1)..]
match Handlers.Admin.Theme.deriveIdFromFileName fileName with
| Ok themeId ->
let data = sp.GetRequiredService<IData> ()
use stream = File.Open (args[1], FileMode.Open)
use copy = new MemoryStream ()
let data = sp.GetRequiredService<IData>()
use stream = File.Open(args[1], FileMode.Open)
use copy = new MemoryStream()
do! stream.CopyToAsync copy
let! theme = Handlers.Admin.Theme.loadFromZip themeId copy data
let fac = sp.GetRequiredService<ILoggerFactory> ()
let fac = sp.GetRequiredService<ILoggerFactory>()
let log = fac.CreateLogger "MyWebLog.Themes"
log.LogInformation $"{theme.Name} v{theme.Version} ({ThemeId.toString theme.Id}) loaded"
log.LogInformation $"{theme.Name} v{theme.Version} ({theme.Id}) loaded"
| Error message -> eprintfn $"{message}"
else
eprintfn "Usage: myWebLog load-theme [theme-zip-file-name]"
@@ -159,103 +155,96 @@ module Backup =
/// A theme asset, with the data base-64 encoded
type EncodedAsset =
{ /// The ID of the theme asset
Id : ThemeAssetId
Id: ThemeAssetId
/// The updated date for this asset
UpdatedOn : Instant
UpdatedOn: Instant
/// The data for this asset, base-64 encoded
Data : string
}
Data: string }
/// Create an encoded theme asset from the original theme asset
static member fromAsset (asset : ThemeAsset) =
static member fromAsset (asset: ThemeAsset) =
{ Id = asset.Id
UpdatedOn = asset.UpdatedOn
Data = Convert.ToBase64String asset.Data
}
Data = Convert.ToBase64String asset.Data }
/// Create a theme asset from an encoded theme asset
static member toAsset (encoded : EncodedAsset) : ThemeAsset =
static member toAsset (encoded: EncodedAsset) : ThemeAsset =
{ Id = encoded.Id
UpdatedOn = encoded.UpdatedOn
Data = Convert.FromBase64String encoded.Data
}
Data = Convert.FromBase64String encoded.Data }
/// An uploaded file, with the data base-64 encoded
type EncodedUpload =
{ /// The ID of the upload
Id : UploadId
Id: UploadId
/// The ID of the web log to which the upload belongs
WebLogId : WebLogId
WebLogId: WebLogId
/// The path at which this upload is served
Path : Permalink
Path: Permalink
/// The date/time this upload was last updated (file time)
UpdatedOn : Instant
UpdatedOn: Instant
/// The data for the upload, base-64 encoded
Data : string
}
Data: string }
/// Create an encoded uploaded file from the original uploaded file
static member fromUpload (upload : Upload) : EncodedUpload =
static member fromUpload (upload: Upload) : EncodedUpload =
{ Id = upload.Id
WebLogId = upload.WebLogId
Path = upload.Path
UpdatedOn = upload.UpdatedOn
Data = Convert.ToBase64String upload.Data
}
Data = Convert.ToBase64String upload.Data }
/// Create an uploaded file from an encoded uploaded file
static member toUpload (encoded : EncodedUpload) : Upload =
static member toUpload (encoded: EncodedUpload) : Upload =
{ Id = encoded.Id
WebLogId = encoded.WebLogId
Path = encoded.Path
UpdatedOn = encoded.UpdatedOn
Data = Convert.FromBase64String encoded.Data
}
Data = Convert.FromBase64String encoded.Data }
/// A unified archive for a web log
type Archive =
{ /// The web log to which this archive belongs
WebLog : WebLog
WebLog: WebLog
/// The users for this web log
Users : WebLogUser list
Users: WebLogUser list
/// The theme used by this web log at the time the archive was made
Theme : Theme
Theme: Theme
/// Assets for the theme used by this web log at the time the archive was made
Assets : EncodedAsset list
Assets: EncodedAsset list
/// The categories for this web log
Categories : Category list
Categories: Category list
/// The tag mappings for this web log
TagMappings : TagMap list
TagMappings: TagMap list
/// The pages for this web log (containing only the most recent revision)
Pages : Page list
Pages: Page list
/// The posts for this web log (containing only the most recent revision)
Posts : Post list
Posts: Post list
/// The uploaded files for this web log
Uploads : EncodedUpload list
}
Uploads: EncodedUpload list }
/// Create a JSON serializer
let private getSerializer prettyOutput =
let serializer = Json.configure (JsonSerializer.CreateDefault ())
let serializer = Json.configure (JsonSerializer.CreateDefault())
if prettyOutput then serializer.Formatting <- Formatting.Indented
serializer
/// Display statistics for a backup archive
let private displayStats (msg : string) (webLog : WebLog) archive =
let private displayStats (msg: string) (webLog: WebLog) archive =
let userCount = List.length archive.Users
let assetCount = List.length archive.Assets
@@ -280,7 +269,7 @@ module Backup =
printfn $""" - {uploadCount} uploaded file{plural uploadCount "" "s"}"""
/// Create a backup archive
let private createBackup webLog (fileName : string) prettyOutput (data : IData) = task {
let private createBackup webLog (fileName: string) prettyOutput (data: IData) = task {
// Create the data structure
printfn "- Exporting theme..."
let! theme = data.Theme.FindById webLog.ThemeId
@@ -312,34 +301,33 @@ module Backup =
TagMappings = tagMaps
Pages = pages |> List.map (fun p -> { p with Revisions = List.truncate 1 p.Revisions })
Posts = posts |> List.map (fun p -> { p with Revisions = List.truncate 1 p.Revisions })
Uploads = uploads |> List.map EncodedUpload.fromUpload
}
Uploads = uploads |> List.map EncodedUpload.fromUpload }
// Write the structure to the backup file
if File.Exists fileName then File.Delete fileName
let serializer = getSerializer prettyOutput
use writer = new StreamWriter (fileName)
serializer.Serialize (writer, archive)
writer.Close ()
use writer = new StreamWriter(fileName)
serializer.Serialize(writer, archive)
writer.Close()
displayStats $"{fileName} (for <>NAME<>) contains:" webLog archive
}
let private doRestore archive newUrlBase (data : IData) = task {
let private doRestore archive newUrlBase isInteractive (data: IData) = task {
let! restore = task {
match! data.WebLog.FindById archive.WebLog.Id with
| Some webLog when defaultArg newUrlBase webLog.UrlBase = webLog.UrlBase ->
do! data.WebLog.Delete webLog.Id
return { archive with WebLog = { archive.WebLog with UrlBase = defaultArg newUrlBase webLog.UrlBase } }
return { archive with Archive.WebLog.UrlBase = defaultArg newUrlBase webLog.UrlBase }
| Some _ ->
// Err'body gets new IDs...
let newWebLogId = WebLogId.create ()
let newCatIds = archive.Categories |> List.map (fun cat -> cat.Id, CategoryId.create ()) |> dict
let newMapIds = archive.TagMappings |> List.map (fun tm -> tm.Id, TagMapId.create ()) |> dict
let newPageIds = archive.Pages |> List.map (fun page -> page.Id, PageId.create ()) |> dict
let newPostIds = archive.Posts |> List.map (fun post -> post.Id, PostId.create ()) |> dict
let newUserIds = archive.Users |> List.map (fun user -> user.Id, WebLogUserId.create ()) |> dict
let newUpIds = archive.Uploads |> List.map (fun up -> up.Id, UploadId.create ()) |> dict
let newWebLogId = WebLogId.Create()
let newCatIds = archive.Categories |> List.map (fun cat -> cat.Id, CategoryId.Create() ) |> dict
let newMapIds = archive.TagMappings |> List.map (fun tm -> tm.Id, TagMapId.Create() ) |> dict
let newPageIds = archive.Pages |> List.map (fun page -> page.Id, PageId.Create() ) |> dict
let newPostIds = archive.Posts |> List.map (fun post -> post.Id, PostId.Create() ) |> dict
let newUserIds = archive.Users |> List.map (fun user -> user.Id, WebLogUserId.Create()) |> dict
let newUpIds = archive.Uploads |> List.map (fun up -> up.Id, UploadId.Create() ) |> dict
return
{ archive with
WebLog = { archive.WebLog with Id = newWebLogId; UrlBase = Option.get newUrlBase }
@@ -354,67 +342,66 @@ module Backup =
{ page with
Id = newPageIds[page.Id]
WebLogId = newWebLogId
AuthorId = newUserIds[page.AuthorId]
})
AuthorId = newUserIds[page.AuthorId] })
Posts = archive.Posts
|> List.map (fun post ->
{ post with
Id = newPostIds[post.Id]
WebLogId = newWebLogId
AuthorId = newUserIds[post.AuthorId]
CategoryIds = post.CategoryIds |> List.map (fun c -> newCatIds[c])
})
CategoryIds = post.CategoryIds |> List.map (fun c -> newCatIds[c]) })
Uploads = archive.Uploads
|> List.map (fun u -> { u with Id = newUpIds[u.Id]; WebLogId = newWebLogId })
}
|> List.map (fun u -> { u with Id = newUpIds[u.Id]; WebLogId = newWebLogId }) }
| None ->
return
{ archive with
WebLog = { archive.WebLog with UrlBase = defaultArg newUrlBase archive.WebLog.UrlBase }
}
return { archive with Archive.WebLog.UrlBase = defaultArg newUrlBase archive.WebLog.UrlBase }
}
// Restore theme and assets (one at a time, as assets can be large)
printfn ""
printfn "- Importing theme..."
if isInteractive then
printfn ""
printfn "- Importing theme..."
do! data.Theme.Save restore.Theme
restore.Assets
|> List.iter (EncodedAsset.toAsset >> data.ThemeAsset.Save >> Async.AwaitTask >> Async.RunSynchronously)
// Restore web log data
printfn "- Restoring web log..."
do! data.WebLog.Add restore.WebLog
if isInteractive then printfn "- Restoring web log..."
// v2.0 backups will not have redirect rules; fix that if restoring to v2.1 or later
let webLog =
if isNull (box restore.WebLog.RedirectRules) then { restore.WebLog with RedirectRules = [] }
else restore.WebLog
do! data.WebLog.Add webLog
printfn "- Restoring users..."
if isInteractive then printfn "- Restoring users..."
do! data.WebLogUser.Restore restore.Users
printfn "- Restoring categories and tag mappings..."
if isInteractive then printfn "- Restoring categories and tag mappings..."
if not (List.isEmpty restore.TagMappings) then do! data.TagMap.Restore restore.TagMappings
if not (List.isEmpty restore.Categories) then do! data.Category.Restore restore.Categories
printfn "- Restoring pages..."
if isInteractive then printfn "- Restoring pages..."
if not (List.isEmpty restore.Pages) then do! data.Page.Restore restore.Pages
printfn "- Restoring posts..."
if isInteractive then printfn "- Restoring posts..."
if not (List.isEmpty restore.Posts) then do! data.Post.Restore restore.Posts
// TODO: comments not yet implemented
printfn "- Restoring uploads..."
if isInteractive then printfn "- Restoring uploads..."
if not (List.isEmpty restore.Uploads) then
do! data.Upload.Restore (restore.Uploads |> List.map EncodedUpload.toUpload)
displayStats "Restored for <>NAME<>:" restore.WebLog restore
if isInteractive then displayStats "Restored for <>NAME<>:" restore.WebLog restore
}
/// Decide whether to restore a backup
let private restoreBackup (fileName : string) newUrlBase promptForOverwrite data = task {
let internal restoreBackup fileName newUrlBase promptForOverwrite isInteractive data = task {
let serializer = getSerializer false
use stream = new FileStream (fileName, FileMode.Open)
use reader = new StreamReader (stream)
use jsonReader = new JsonTextReader (reader)
use stream = new FileStream(fileName, FileMode.Open)
use reader = new StreamReader(stream)
use jsonReader = new JsonTextReader(reader)
let archive = serializer.Deserialize<Archive> jsonReader
let mutable doOverwrite = not promptForOverwrite
@@ -424,18 +411,18 @@ module Backup =
printfn " theme in either case."
printfn ""
printf "Continue? [Y/n] "
doOverwrite <- not ((Console.ReadKey ()).Key = ConsoleKey.N)
doOverwrite <- not (Console.ReadKey().Key = ConsoleKey.N)
if doOverwrite then
do! doRestore archive newUrlBase data
do! doRestore archive newUrlBase isInteractive data
else
printfn $"{archive.WebLog.Name} backup restoration canceled"
}
/// Generate a backup archive
let generateBackup (args : string[]) (sp : IServiceProvider) = task {
let generateBackup (args: string[]) (sp: IServiceProvider) = task {
if args.Length > 1 && args.Length < 5 then
let data = sp.GetRequiredService<IData> ()
let data = sp.GetRequiredService<IData>()
match! data.WebLog.FindByHost args[1] with
| Some webLog ->
let fileName =
@@ -455,11 +442,11 @@ module Backup =
}
/// Restore a backup archive
let restoreFromBackup (args : string[]) (sp : IServiceProvider) = task {
let restoreFromBackup (args: string[]) (sp: IServiceProvider) = task {
if args.Length = 2 || args.Length = 3 then
let data = sp.GetRequiredService<IData> ()
let data = sp.GetRequiredService<IData>()
let newUrlBase = if args.Length = 3 then Some args[2] else None
do! restoreBackup args[1] newUrlBase (args[0] <> "do-restore") data
do! restoreBackup args[1] newUrlBase (args[0] <> "do-restore") true data
else
eprintfn "Usage: myWebLog restore [backup-file-name] [*url-base]"
eprintfn " * optional - will restore to original URL base if omitted"
@@ -468,7 +455,7 @@ module Backup =
/// Upgrade a WebLogAdmin user to an Administrator user
let private doUserUpgrade urlBase email (data : IData) = task {
let private doUserUpgrade urlBase email (data: IData) = task {
match! data.WebLog.FindByHost urlBase with
| Some webLog ->
match! data.WebLogUser.FindByEmail email webLog.Id with
@@ -477,20 +464,20 @@ let private doUserUpgrade urlBase email (data : IData) = task {
| WebLogAdmin ->
do! data.WebLogUser.Update { user with AccessLevel = Administrator }
printfn $"{email} is now an Administrator user"
| other -> eprintfn $"ERROR: {email} is an {AccessLevel.toString other}, not a WebLogAdmin"
| other -> eprintfn $"ERROR: {email} is an {other}, not a WebLogAdmin"
| None -> eprintfn $"ERROR: no user {email} found at {urlBase}"
| None -> eprintfn $"ERROR: no web log found for {urlBase}"
}
/// Upgrade a WebLogAdmin user to an Administrator user if the command-line arguments are good
let upgradeUser (args : string[]) (sp : IServiceProvider) = task {
let upgradeUser (args: string[]) (sp: IServiceProvider) = task {
match args.Length with
| 3 -> do! doUserUpgrade args[1] args[2] (sp.GetRequiredService<IData> ())
| 3 -> do! doUserUpgrade args[1] args[2] (sp.GetRequiredService<IData>())
| _ -> eprintfn "Usage: myWebLog upgrade-user [web-log-url-base] [email-address]"
}
/// Set a user's password
let doSetPassword urlBase email password (data : IData) = task {
let doSetPassword urlBase email password (data: IData) = task {
match! data.WebLog.FindByHost urlBase with
| Some webLog ->
match! data.WebLogUser.FindByEmail email webLog.Id with
@@ -502,8 +489,8 @@ let doSetPassword urlBase email password (data : IData) = task {
}
/// Set a user's password if the command-line arguments are good
let setPassword (args : string[]) (sp : IServiceProvider) = task {
let setPassword (args: string[]) (sp: IServiceProvider) = task {
match args.Length with
| 4 -> do! doSetPassword args[1] args[2] args[3] (sp.GetRequiredService<IData> ())
| 4 -> do! doSetPassword args[1] args[2] args[3] (sp.GetRequiredService<IData>())
| _ -> eprintfn "Usage: myWebLog set-password [web-log-url-base] [email-address] [password]"
}

26
src/MyWebLog/MyWebLog.fsproj
View File

@@ -9,6 +9,12 @@
<ItemGroup>
<Content Include="appsettings*.json" CopyToOutputDirectory="Always" />
<Compile Include="Caches.fs" />
<Compile Include="Views\Helpers.fs" />
<Compile Include="Views\Admin.fs" />
<Compile Include="Views\Page.fs" />
<Compile Include="Views\Post.fs" />
<Compile Include="Views\User.fs" />
<Compile Include="Views\WebLog.fs" />
<Compile Include="Handlers\Helpers.fs" />
<Compile Include="Handlers\Admin.fs" />
<Compile Include="Handlers\Feed.fs" />
@@ -23,13 +29,15 @@
</ItemGroup>
<ItemGroup>
<PackageReference Include="DotLiquid" Version="2.2.682" />
<PackageReference Include="Giraffe" Version="6.0.0" />
<PackageReference Include="Giraffe.Htmx" Version="1.8.5" />
<PackageReference Include="Giraffe.ViewEngine.Htmx" Version="1.8.5" />
<PackageReference Include="NeoSmart.Caching.Sqlite" Version="6.0.1" />
<PackageReference Include="BitBadger.AspNetCore.CanonicalDomains" Version="1.0.0" />
<PackageReference Include="DotLiquid" Version="2.2.692" />
<PackageReference Include="Giraffe" Version="6.3.0" />
<PackageReference Include="Giraffe.Htmx" Version="1.9.11" />
<PackageReference Include="Giraffe.ViewEngine.Htmx" Version="1.9.11" />
<PackageReference Include="NeoSmart.Caching.Sqlite.AspNetCore" Version="8.0.0" />
<PackageReference Include="RethinkDB.DistributedCache" Version="1.0.0-rc1" />
<PackageReference Include="System.ServiceModel.Syndication" Version="7.0.0" />
<PackageReference Include="System.ServiceModel.Syndication" Version="8.0.0" />
<PackageReference Update="FSharp.Core" Version="8.0.200" />
</ItemGroup>
<ItemGroup>
@@ -41,4 +49,10 @@
<None Include=".\wwwroot\upload\*" CopyToOutputDirectory="Always" />
</ItemGroup>
<ItemGroup>
<AssemblyAttribute Include="System.Runtime.CompilerServices.InternalsVisibleToAttribute">
<_Parameter1>MyWebLog.Tests</_Parameter1>
</AssemblyAttribute>
</ItemGroup>
</Project>

147
src/MyWebLog/Program.fs
View File

@@ -5,17 +5,17 @@ open Microsoft.Extensions.Logging
open MyWebLog
/// Middleware to derive the current web log
type WebLogMiddleware (next : RequestDelegate, log : ILogger<WebLogMiddleware>) =
type WebLogMiddleware(next: RequestDelegate, log: ILogger<WebLogMiddleware>) =
/// Is the debug level enabled on the logger?
let isDebug = log.IsEnabled LogLevel.Debug
member _.InvokeAsync (ctx : HttpContext) = task {
member _.InvokeAsync(ctx: HttpContext) = task {
/// Create the full path of the request
let path = $"{ctx.Request.Scheme}://{ctx.Request.Host.Value}{ctx.Request.Path.Value}"
match WebLogCache.tryGet path with
| Some webLog ->
if isDebug then log.LogDebug $"Resolved web log {WebLogId.toString webLog.Id} for {path}"
if isDebug then log.LogDebug $"Resolved web log {webLog.Id} for {path}"
ctx.Items["webLog"] <- webLog
if PageListCache.exists ctx then () else do! PageListCache.update ctx
if CategoryCache.exists ctx then () else do! CategoryCache.update ctx
@@ -26,7 +26,32 @@ type WebLogMiddleware (next : RequestDelegate, log : ILogger<WebLogMiddleware>)
}
/// Middleware to check redirects for the current web log
type RedirectRuleMiddleware(next: RequestDelegate, log: ILogger<RedirectRuleMiddleware>) =
/// Shorthand for case-insensitive string equality
let ciEquals str1 str2 =
System.String.Equals(str1, str2, System.StringComparison.InvariantCultureIgnoreCase)
member _.InvokeAsync(ctx: HttpContext) = task {
let path = ctx.Request.Path.Value.ToLower()
let matched =
WebLogCache.redirectRules ctx.WebLog.Id
|> List.tryPick (fun rule ->
match rule with
| WebLogCache.CachedRedirectRule.Text (urlFrom, urlTo) ->
if ciEquals path urlFrom then Some urlTo else None
| WebLogCache.CachedRedirectRule.RegEx (regExFrom, patternTo) ->
if regExFrom.IsMatch path then Some (regExFrom.Replace(path, patternTo)) else None)
match matched with
| Some url -> ctx.Response.Redirect(url, permanent = true)
| None -> return! next.Invoke ctx
}
open System
open System.IO
open BitBadger.Documents
open Microsoft.Extensions.DependencyInjection
open MyWebLog.Data
open Newtonsoft.Json
@@ -38,43 +63,44 @@ module DataImplementation =
open MyWebLog.Converters
open RethinkDb.Driver.FSharp
open RethinkDb.Driver.Net
/// Create an NpgsqlDataSource from the connection string, configuring appropriately
let createNpgsqlDataSource (cfg : IConfiguration) =
let builder = NpgsqlDataSourceBuilder (cfg.GetConnectionString "PostgreSQL")
let _ = builder.UseNodaTime ()
let createNpgsqlDataSource (cfg: IConfiguration) =
let builder = NpgsqlDataSourceBuilder(cfg.GetConnectionString "PostgreSQL")
let _ = builder.UseNodaTime()
// let _ = builder.UseLoggerFactory(LoggerFactory.Create(fun it -> it.AddConsole () |> ignore))
builder.Build ()
(builder.Build >> Postgres.Configuration.useDataSource) ()
/// Get the configured data implementation
let get (sp : IServiceProvider) : IData =
let config = sp.GetRequiredService<IConfiguration> ()
let get (sp: IServiceProvider) : IData =
let config = sp.GetRequiredService<IConfiguration>()
let await it = (Async.AwaitTask >> Async.RunSynchronously) it
let connStr name = config.GetConnectionString name
let hasConnStr name = (connStr >> isNull >> not) name
let createSQLite connStr : IData =
let log = sp.GetRequiredService<ILogger<SQLiteData>> ()
let conn = new SqliteConnection (connStr)
Sqlite.Configuration.useConnectionString connStr
let log = sp.GetRequiredService<ILogger<SQLiteData>>()
let conn = Sqlite.Configuration.dbConn ()
log.LogInformation $"Using SQLite database {conn.DataSource}"
await (SQLiteData.setUpConnection conn)
SQLiteData (conn, log, Json.configure (JsonSerializer.CreateDefault ()))
SQLiteData(conn, log, Json.configure (JsonSerializer.CreateDefault()))
if hasConnStr "SQLite" then
createSQLite (connStr "SQLite")
elif hasConnStr "RethinkDB" then
let log = sp.GetRequiredService<ILogger<RethinkDbData>> ()
let log = sp.GetRequiredService<ILogger<RethinkDbData>>()
let _ = Json.configure Converter.Serializer
let rethinkCfg = DataConfig.FromUri (connStr "RethinkDB")
let conn = await (rethinkCfg.CreateConnectionAsync log)
RethinkDbData (conn, rethinkCfg, log)
RethinkDbData(conn, rethinkCfg, log)
elif hasConnStr "PostgreSQL" then
let source = createNpgsqlDataSource config
use conn = source.CreateConnection ()
let log = sp.GetRequiredService<ILogger<PostgresData>> ()
createNpgsqlDataSource config
use conn = Postgres.Configuration.dataSource().CreateConnection()
let log = sp.GetRequiredService<ILogger<PostgresData>>()
log.LogInformation $"Using PostgreSQL database {conn.Database}"
PostgresData (source, log, Json.configure (JsonSerializer.CreateDefault ()))
PostgresData(log, Json.configure (JsonSerializer.CreateDefault()))
else
createSQLite "Data Source=./myweblog.db;Cache=Shared"
if not (Directory.Exists "./data") then Directory.CreateDirectory "./data" |> ignore
createSQLite "Data Source=./data/myweblog.db;Cache=Shared"
open System.Threading.Tasks
@@ -95,21 +121,21 @@ let showHelp () =
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 ()
Task.FromResult()
open System.IO
open BitBadger.AspNetCore.CanonicalDomains
open Giraffe
open Giraffe.EndpointRouting
open Microsoft.AspNetCore.Authentication.Cookies
open Microsoft.AspNetCore.Builder
open Microsoft.AspNetCore.HttpOverrides
open Microsoft.Extensions.Caching.Distributed
open NeoSmart.Caching.Sqlite
open NeoSmart.Caching.Sqlite.AspNetCore
open RethinkDB.DistributedCache
[<EntryPoint>]
let rec main args =
let main args =
let builder = WebApplication.CreateBuilder(args)
let _ = builder.Services.Configure<ForwardedHeadersOptions>(fun (opts : ForwardedHeadersOptions) ->
@@ -121,16 +147,16 @@ let rec main args =
opts.ExpireTimeSpan <- TimeSpan.FromMinutes 60.
opts.SlidingExpiration <- true
opts.AccessDeniedPath <- "/forbidden")
let _ = builder.Services.AddLogging ()
let _ = builder.Services.AddAuthorization ()
let _ = builder.Services.AddAntiforgery ()
let _ = builder.Services.AddLogging()
let _ = builder.Services.AddAuthorization()
let _ = builder.Services.AddAntiforgery()
let sp = builder.Services.BuildServiceProvider ()
let sp = builder.Services.BuildServiceProvider()
let data = DataImplementation.get sp
let _ = builder.Services.AddSingleton<JsonSerializer> data.Serializer
task {
do! data.StartUp ()
do! data.StartUp()
do! WebLogCache.fill data
do! ThemeAssetCache.fill data
} |> Async.AwaitTask |> Async.RunSynchronously
@@ -141,32 +167,26 @@ let rec main args =
// A RethinkDB connection is designed to work as a singleton
let _ = builder.Services.AddSingleton<IData> data
let _ =
builder.Services.AddDistributedRethinkDBCache (fun opts ->
builder.Services.AddDistributedRethinkDBCache(fun opts ->
opts.TableName <- "Session"
opts.Connection <- rethink.Conn)
()
| :? SQLiteData as sql ->
| :? SQLiteData ->
// ADO.NET connections are designed to work as per-request instantiation
let cfg = sp.GetRequiredService<IConfiguration> ()
let _ =
builder.Services.AddScoped<SqliteConnection> (fun sp ->
let conn = new SqliteConnection (sql.Conn.ConnectionString)
SQLiteData.setUpConnection conn |> Async.AwaitTask |> Async.RunSynchronously
conn)
let _ = builder.Services.AddScoped<IData, SQLiteData> () |> ignore
let cfg = sp.GetRequiredService<IConfiguration>()
let _ = builder.Services.AddScoped<SqliteConnection>(fun sp -> Sqlite.Configuration.dbConn ())
let _ = builder.Services.AddScoped<IData, SQLiteData>()
// Use SQLite for caching as well
let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./session.db"
let _ = builder.Services.AddSqliteCache (fun o -> o.CachePath <- cachePath)
let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./data/session.db"
let _ = builder.Services.AddSqliteCache(fun o -> o.CachePath <- cachePath)
()
| :? PostgresData as postgres ->
// ADO.NET Data Sources are designed to work as singletons
let _ =
builder.Services.AddSingleton<NpgsqlDataSource> (fun sp ->
DataImplementation.createNpgsqlDataSource (sp.GetRequiredService<IConfiguration> ()))
let _ = builder.Services.AddSingleton<NpgsqlDataSource>(Postgres.Configuration.dataSource ())
let _ = builder.Services.AddSingleton<IData> postgres
let _ =
builder.Services.AddSingleton<IDistributedCache> (fun _ ->
Postgres.DistributedCache () :> IDistributedCache)
builder.Services.AddSingleton<IDistributedCache>(fun _ ->
Postgres.DistributedCache() :> IDistributedCache)
()
| _ -> ()
@@ -174,12 +194,12 @@ let rec main args =
opts.IdleTimeout <- TimeSpan.FromMinutes 60
opts.Cookie.HttpOnly <- true
opts.Cookie.IsEssential <- true)
let _ = builder.Services.AddGiraffe ()
let _ = builder.Services.AddGiraffe()
// Set up DotLiquid
DotLiquidBespoke.register ()
let app = builder.Build ()
let app = builder.Build()
match args |> Array.tryHead with
| Some it when it = "init" -> Maintenance.createWebLog args app.Services
@@ -195,20 +215,29 @@ let rec main args =
printfn $"""Unrecognized command "{it}" - valid commands are:"""
showHelp ()
| None -> task {
// Load all themes in the application directory
for themeFile in Directory.EnumerateFiles (".", "*-theme.zip") do
do! Maintenance.loadTheme [| ""; themeFile |] app.Services
// Load admin and default themes, and all themes in the /themes directory
do! Maintenance.loadTheme [| ""; "./admin-theme.zip" |] app.Services
do! Maintenance.loadTheme [| ""; "./default-theme.zip" |] app.Services
if Directory.Exists "./themes" then
for themeFile in Directory.EnumerateFiles("./themes", "*-theme.zip") do
do! Maintenance.loadTheme [| ""; themeFile |] app.Services
let _ = app.UseForwardedHeaders ()
let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict))
let _ = app.UseMiddleware<WebLogMiddleware> ()
let _ = app.UseAuthentication ()
let _ = app.UseStaticFiles ()
let _ = app.UseRouting ()
let _ = app.UseSession ()
let _ = app.UseForwardedHeaders()
(app.Services.GetRequiredService<IConfiguration>().GetSection "CanonicalDomains").Value
|> (isNull >> not)
|> function true -> app.UseCanonicalDomains() |> ignore | false -> ()
let _ = app.UseCookiePolicy(CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict))
let _ = app.UseMiddleware<WebLogMiddleware>()
let _ = app.UseMiddleware<RedirectRuleMiddleware>()
let _ = app.UseAuthentication()
let _ = app.UseStaticFiles()
let _ = app.UseRouting()
let _ = app.UseSession()
let _ = app.UseGiraffe Handlers.Routes.endpoint
app.Run ()
app.Run()
}
|> Async.AwaitTask |> Async.RunSynchronously

190
src/MyWebLog/Views/Admin.fs Normal file
View File

@@ -0,0 +1,190 @@
module MyWebLog.Views.Admin
open Giraffe.Htmx.Common
open Giraffe.ViewEngine
open Giraffe.ViewEngine.Htmx
open MyWebLog
open MyWebLog.ViewModels
/// The administrator dashboard
let dashboard (themes: Theme list) app = [
let templates = TemplateCache.allNames ()
let cacheBaseUrl = relUrl app "admin/cache/"
let webLogCacheUrl = $"{cacheBaseUrl}web-log/"
let themeCacheUrl = $"{cacheBaseUrl}theme/"
let webLogDetail (webLog: WebLog) =
let refreshUrl = $"{webLogCacheUrl}{webLog.Id}/refresh"
div [ _class "row mwl-table-detail" ] [
div [ _class "col" ] [
txt webLog.Name; br []
small [] [
span [ _class "text-muted" ] [ raw webLog.UrlBase ]; br []
a [ _href refreshUrl; _hxPost refreshUrl ] [ raw "Refresh" ]
]
]
]
let themeDetail (theme: Theme) =
let refreshUrl = $"{themeCacheUrl}{theme.Id}/refresh"
div [ _class "row mwl-table-detail" ] [
div [ _class "col-8" ] [
txt theme.Name; br []
small [] [
span [ _class "text-muted" ] [ txt (string theme.Id); raw " &bull; " ]
a [ _href refreshUrl; _hxPost refreshUrl ] [ raw "Refresh" ]
]
]
div [ _class "col-4" ] [
raw (templates |> List.filter _.StartsWith(string theme.Id) |> List.length |> string)
]
]
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
fieldset [ _class "container mb-3 pb-0" ] [
legend [] [ raw "Themes" ]
span [ _hxGet (relUrl app "admin/theme/list"); _hxTrigger HxTrigger.Load; _hxSwap HxSwap.OuterHtml ] []
]
fieldset [ _class "container mb-3 pb-0" ] [
legend [] [ raw "Caches" ]
p [ _class "pb-2" ] [
raw "myWebLog uses a few caches to ensure that it serves pages as fast as possible. ("
a [ _href "https://bitbadger.solutions/open-source/myweblog/advanced.html#cache-management"
_target "_blank" ] [
raw "more information"
]; raw ")"
]
div [ _class "row" ] [
div [ _class "col-12 col-lg-6 pb-3" ] [
div [ _class "card" ] [
header [ _class "card-header text-white bg-secondary" ] [ raw "Web Logs" ]
div [ _class "card-body pb-0" ] [
h6 [ _class "card-subtitle text-muted pb-3" ] [
raw "These caches include the page list and categories for each web log"
]
let webLogUrl = $"{cacheBaseUrl}web-log/"
form [ _method "post"; _class "container g-0"; _hxNoBoost; _hxTarget "body"
_hxSwap $"{HxSwap.InnerHtml} show:window:top" ] [
antiCsrf app
button [ _type "submit"; _class "btn btn-sm btn-primary mb-2"
_hxPost $"{webLogUrl}all/refresh" ] [
raw "Refresh All"
]
div [ _class "row mwl-table-heading" ] [ div [ _class "col" ] [ raw "Web Log" ] ]
yield! WebLogCache.all () |> List.sortBy _.Name |> List.map webLogDetail
]
]
]
]
div [ _class "col-12 col-lg-6 pb-3" ] [
div [ _class "card" ] [
header [ _class "card-header text-white bg-secondary" ] [ raw "Themes" ]
div [ _class "card-body pb-0" ] [
h6 [ _class "card-subtitle text-muted pb-3" ] [
raw "The theme template cache is filled on demand as pages are displayed; "
raw "refreshing a theme with no cached templates will still refresh its asset cache"
]
form [ _method "post"; _class "container g-0"; _hxNoBoost; _hxTarget "body"
_hxSwap $"{HxSwap.InnerHtml} show:window:top" ] [
antiCsrf app
button [ _type "submit"; _class "btn btn-sm btn-primary mb-2"
_hxPost $"{themeCacheUrl}all/refresh" ] [
raw "Refresh All"
]
div [ _class "row mwl-table-heading" ] [
div [ _class "col-8" ] [ raw "Theme" ]; div [ _class "col-4" ] [ raw "Cached" ]
]
yield! themes |> List.filter (fun t -> t.Id <> ThemeId "admin") |> List.map themeDetail
]
]
]
]
]
]
]
]
/// Display a list of themes
let themeList (model: DisplayTheme list) app =
let themeCol = "col-12 col-md-6"
let slugCol = "d-none d-md-block col-md-3"
let tmplCol = "d-none d-md-block col-md-3"
div [ _id "theme_panel" ] [
a [ _href (relUrl app "admin/theme/new"); _class "btn btn-primary btn-sm mb-3"; _hxTarget "#theme_new" ] [
raw "Upload a New Theme"
]
div [ _class "container g-0" ] [
div [ _class "row mwl-table-heading" ] [
div [ _class themeCol ] [ raw "Theme" ]
div [ _class slugCol ] [ raw "Slug" ]
div [ _class tmplCol ] [ raw "Templates" ]
]
]
div [ _class "row mwl-table-detail"; _id "theme_new" ] []
form [ _method "post"; _id "themeList"; _class "container g-0"; _hxTarget "#theme_panel"
_hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [
antiCsrf app
for theme in model do
let url = relUrl app $"admin/theme/{theme.Id}"
div [ _class "row mwl-table-detail"; _id $"theme_{theme.Id}" ] [
div [ _class $"{themeCol} no-wrap" ] [
txt theme.Name
if theme.IsInUse then span [ _class "badge bg-primary ms-2" ] [ raw "IN USE" ]
if not theme.IsOnDisk then
span [ _class "badge bg-warning text-dark ms-2" ] [ raw "NOT ON DISK" ]
br []
small [] [
span [ _class "text-muted" ] [ txt $"v{theme.Version}" ]
if not (theme.IsInUse || theme.Id = "default") then
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href url; _hxDelete url; _class "text-danger"
_hxConfirm $"Are you sure you want to delete the theme “{theme.Name}”? This action cannot be undone." ] [
raw "Delete"
]
span [ _class "d-md-none text-muted" ] [
br []; raw "Slug: "; txt theme.Id; raw $" &bull; {theme.TemplateCount} Templates"
]
]
]
div [ _class slugCol ] [ txt (string theme.Id) ]
div [ _class tmplCol ] [ txt (string theme.TemplateCount) ]
]
]
]
|> List.singleton
/// Form to allow a theme to be uploaded
let themeUpload app =
div [ _class "col" ] [
h5 [ _class "mt-2" ] [ raw app.PageTitle ]
form [ _action (relUrl app "admin/theme/new"); _method "post"; _class "container"
_enctype "multipart/form-data"; _hxNoBoost ] [
antiCsrf app
div [ _class "row " ] [
div [ _class "col-12 col-sm-6 pb-3" ] [
div [ _class "form-floating" ] [
input [ _type "file"; _id "file"; _name "file"; _class "form-control"; _accept ".zip"
_placeholder "Theme File"; _required ]
label [ _for "file" ] [ raw "Theme File" ]
]
]
div [ _class "col-12 col-sm-6 pb-3 d-flex justify-content-center align-items-center" ] [
div [ _class "form-check form-switch pb-2" ] [
input [ _type "checkbox"; _name "DoOverwrite"; _id "doOverwrite"; _class "form-check-input"
_value "true" ]
label [ _for "doOverwrite"; _class "form-check-label" ] [ raw "Overwrite" ]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col text-center" ] [
button [ _type "submit"; _class "btn btn-sm btn-primary" ] [ raw "Upload Theme" ]; raw " &nbsp; "
button [ _type "button"; _class "btn btn-sm btn-secondary ms-3"
_onclick "document.getElementById('theme_new').innerHTML = ''" ] [
raw "Cancel"
]
]
]
]
]
|> List.singleton

527
src/MyWebLog/Views/Helpers.fs Normal file
View File

@@ -0,0 +1,527 @@
[<AutoOpen>]
module MyWebLog.Views.Helpers
open Microsoft.AspNetCore.Antiforgery
open Giraffe.ViewEngine
open Giraffe.ViewEngine.Accessibility
open Giraffe.ViewEngine.Htmx
open MyWebLog
open MyWebLog.ViewModels
open NodaTime
open NodaTime.Text
/// The rendering context for this application
[<NoComparison; NoEquality>]
type AppViewContext = {
/// The web log for this request
WebLog: WebLog
/// The ID of the current user
UserId: WebLogUserId option
/// The title of the page being rendered
PageTitle: string
/// The anti-Cross Site Request Forgery (CSRF) token set to use when rendering a form
Csrf: AntiforgeryTokenSet option
/// The page list for the web log
PageList: DisplayPage array
/// Categories and post counts for the web log
Categories: DisplayCategory array
/// The URL of the page being rendered
CurrentPage: string
/// User messages
Messages: UserMessage array
/// The generator string for the rendered page
Generator: string
/// A string to load the minified htmx script
HtmxScript: string
/// Whether the current user is an author
IsAuthor: bool
/// Whether the current user is an editor (implies author)
IsEditor: bool
/// Whether the current user is a web log administrator (implies author and editor)
IsWebLogAdmin: bool
/// Whether the current user is an installation administrator (implies all web log rights)
IsAdministrator: bool
} with
/// Whether there is a user logged on
member this.IsLoggedOn = Option.isSome this.UserId
/// Create a relative URL for the current web log
let relUrl app =
Permalink >> app.WebLog.RelativeUrl
/// Add a hidden input with the anti-Cross Site Request Forgery (CSRF) token
let antiCsrf app =
input [ _type "hidden"; _name app.Csrf.Value.FormFieldName; _value app.Csrf.Value.RequestToken ]
/// Shorthand for encoded text in a template
let txt = encodedText
/// Shorthand for raw text in a template
let raw = rawText
/// Rel attribute to prevent opener information from being provided to the new window
let _relNoOpener = _rel "noopener"
/// The pattern for a long date
let longDatePattern =
ZonedDateTimePattern.CreateWithInvariantCulture("MMMM d, yyyy", DateTimeZoneProviders.Tzdb)
/// Create a long date
let longDate app (instant: Instant) =
DateTimeZoneProviders.Tzdb[app.WebLog.TimeZone]
|> Option.ofObj
|> Option.map (fun tz -> longDatePattern.Format(instant.InZone(tz)))
|> Option.defaultValue "--"
|> txt
/// The pattern for a short time
let shortTimePattern =
ZonedDateTimePattern.CreateWithInvariantCulture("h:mmtt", DateTimeZoneProviders.Tzdb)
/// Create a short time
let shortTime app (instant: Instant) =
DateTimeZoneProviders.Tzdb[app.WebLog.TimeZone]
|> Option.ofObj
|> Option.map (fun tz -> shortTimePattern.Format(instant.InZone(tz)).ToLowerInvariant())
|> Option.defaultValue "--"
|> txt
/// Display "Yes" or "No" based on the state of a boolean value
let yesOrNo value =
raw (if value then "Yes" else "No")
/// Extract an attribute value from a list of attributes, remove that attribute if it is found
let extractAttrValue name attrs =
let valueAttr = attrs |> List.tryFind (fun x -> match x with KeyValue (key, _) when key = name -> true | _ -> false)
match valueAttr with
| Some (KeyValue (_, value)) ->
Some value,
attrs |> List.filter (fun x -> match x with KeyValue (key, _) when key = name -> false | _ -> true)
| Some _ | None -> None, attrs
/// Create a text input field
let inputField fieldType attrs name labelText value extra =
let fieldId, attrs = extractAttrValue "id" attrs
let cssClass, attrs = extractAttrValue "class" attrs
div [ _class $"""form-floating {defaultArg cssClass ""}""" ] [
[ _type fieldType; _name name; _id (defaultArg fieldId name); _class "form-control"; _placeholder labelText
_value value ]
|> List.append attrs
|> input
label [ _for (defaultArg fieldId name) ] [ raw labelText ]
yield! extra
]
/// Create a text input field
let textField attrs name labelText value extra =
inputField "text" attrs name labelText value extra
/// Create a number input field
let numberField attrs name labelText value extra =
inputField "number" attrs name labelText value extra
/// Create an e-mail input field
let emailField attrs name labelText value extra =
inputField "email" attrs name labelText value extra
/// Create a password input field
let passwordField attrs name labelText value extra =
inputField "password" attrs name labelText value extra
/// Create a select (dropdown) field
let selectField<'T, 'a>
attrs name labelText value (values: 'T seq) (idFunc: 'T -> 'a) (displayFunc: 'T -> string) extra =
let cssClass, attrs = extractAttrValue "class" attrs
div [ _class $"""form-floating {defaultArg cssClass ""}""" ] [
select ([ _name name; _id name; _class "form-control" ] |> List.append attrs) [
for item in values do
let itemId = string (idFunc item)
option [ _value itemId; if value = itemId then _selected ] [ raw (displayFunc item) ]
]
label [ _for name ] [ raw labelText ]
yield! extra
]
/// Create a checkbox input styled as a switch
let checkboxSwitch attrs name labelText (value: bool) extra =
let cssClass, attrs = extractAttrValue "class" attrs
div [ _class $"""form-check form-switch {defaultArg cssClass ""}""" ] [
[ _type "checkbox"; _name name; _id name; _class "form-check-input"; _value "true"; if value then _checked ]
|> List.append attrs
|> input
label [ _for name; _class "form-check-label" ] [ raw labelText ]
yield! extra
]
/// A standard save button
let saveButton =
button [ _type "submit"; _class "btn btn-sm btn-primary" ] [ raw "Save Changes" ]
/// A spacer bullet to use between action links
let actionSpacer =
span [ _class "text-muted" ] [ raw " &bull; " ]
/// Functions for generating content in varying layouts
module Layout =
/// Generate the title tag for a page
let private titleTag (app: AppViewContext) =
title [] [ txt app.PageTitle; raw " &laquo; Admin &laquo; "; txt app.WebLog.Name ]
/// Create a navigation link
let private navLink app name url =
let extraPath = app.WebLog.ExtraPath
let path = if extraPath = "" then "" else $"{extraPath[1..]}/"
let active = if app.CurrentPage.StartsWith $"{path}{url}" then " active" else ""
li [ _class "nav-item" ] [
a [ _class $"nav-link{active}"; _href (relUrl app url) ] [ txt name ]
]
/// Create a page view for the given content
let private pageView (content: AppViewContext -> XmlNode list) app = [
header [] [
nav [ _class "navbar navbar-dark bg-dark navbar-expand-md justify-content-start px-2 position-fixed top-0 w-100" ] [
div [ _class "container-fluid" ] [
a [ _class "navbar-brand"; _href (relUrl app ""); _hxNoBoost ] [ txt app.WebLog.Name ]
button [ _type "button"; _class "navbar-toggler"; _data "bs-toggle" "collapse"
_data "bs-target" "#navbarText"; _ariaControls "navbarText"; _ariaExpanded "false"
_ariaLabel "Toggle navigation" ] [
span [ _class "navbar-toggler-icon" ] []
]
div [ _class "collapse navbar-collapse"; _id "navbarText" ] [
if app.IsLoggedOn then
ul [ _class "navbar-nav" ] [
navLink app "Dashboard" "admin/dashboard"
if app.IsAuthor then
navLink app "Pages" "admin/pages"
navLink app "Posts" "admin/posts"
navLink app "Uploads" "admin/uploads"
if app.IsWebLogAdmin then
navLink app "Categories" "admin/categories"
navLink app "Settings" "admin/settings"
if app.IsAdministrator then navLink app "Admin" "admin/administration"
]
ul [ _class "navbar-nav flex-grow-1 justify-content-end" ] [
if app.IsLoggedOn then navLink app "My Info" "admin/my-info"
li [ _class "nav-item" ] [
a [ _class "nav-link"
_href "https://bitbadger.solutions/open-source/myweblog/#how-to-use-myweblog"
_target "_blank" ] [
raw "Docs"
]
]
if app.IsLoggedOn then
li [ _class "nav-item" ] [
a [ _class "nav-link"; _href (relUrl app "user/log-off"); _hxNoBoost ] [
raw "Log Off"
]
]
else
navLink app "Log On" "user/log-on"
]
]
]
]
]
div [ _id "toastHost"; _class "position-fixed top-0 w-100"; _ariaLive "polite"; _ariaAtomic "true" ] [
div [ _id "toasts"; _class "toast-container position-absolute p-3 mt-5 top-0 end-0" ] [
for msg in app.Messages do
let textColor = if msg.Level = "warning" then "" else " text-white"
div [ _class "toast"; _roleAlert; _ariaLive "assertive"; _ariaAtomic "true"
if msg.Level <> "success" then _data "bs-autohide" "false" ] [
div [ _class $"toast-header bg-{msg.Level}{textColor}" ] [
strong [ _class "me-auto text-uppercase" ] [
raw (if msg.Level = "danger" then "error" else msg.Level)
]
button [ _type "button"; _class "btn-close"; _data "bs-dismiss" "toast"
_ariaLabel "Close" ] []
]
div [ _class $"toast-body bg-{msg.Level} bg-opacity-25" ] [
txt msg.Message
if Option.isSome msg.Detail then
hr []
txt msg.Detail.Value
]
]
]
]
main [ _class "mx-3 mt-3" ] [
div [ _class "load-overlay p-5"; _id "loadOverlay" ] [ h1 [ _class "p-3" ] [ raw "Loading&hellip;" ] ]
yield! content app
]
footer [ _class "position-fixed bottom-0 w-100" ] [
div [ _class "text-end text-white me-2" ] [
let version = app.Generator.Split ' '
small [ _class "me-1 align-baseline"] [ raw $"v{version[1]}" ]
img [ _src (relUrl app "themes/admin/logo-light.png"); _alt "myWebLog"; _width "120"; _height "34" ]
]
]
]
/// Render a page with a partial layout (htmx request)
let partial content app =
html [ _lang "en" ] [
titleTag app
yield! pageView content app
]
/// Render a page with a full layout
let full content app =
html [ _lang "en" ] [
meta [ _name "viewport"; _content "width=device-width, initial-scale=1" ]
meta [ _name "generator"; _content app.Generator ]
titleTag app
link [ _rel "stylesheet"; _href "https://cdn.jsdelivr.net/npm/bootstrap@5.1.3/dist/css/bootstrap.min.css"
_integrity "sha384-1BmE4kWBq78iYhFldvKuhfTAU6auU8tT94WrHftjDbrCEXSU1oBoqyl2QvZ6jIW3"
_crossorigin "anonymous" ]
link [ _rel "stylesheet"; _href (relUrl app "themes/admin/admin.css") ]
body [ _hxBoost; _hxIndicator "#loadOverlay" ] [
yield! pageView content app
script [ _src "https://cdn.jsdelivr.net/npm/bootstrap@5.1.3/dist/js/bootstrap.bundle.min.js"
_integrity "sha384-ka7Sk0Gln4gmtz2MlQnikT1wXgYsOg+OMhuP+IlRH9sENBO0LRn5q+8nbTov4+1p"
_crossorigin "anonymous" ] []
Script.minified
script [ _src (relUrl app "themes/admin/admin.js") ] []
]
]
/// Render a bare layout
let bare (content: AppViewContext -> XmlNode list) app =
html [ _lang "en" ] [
title [] []
yield! content app
]
// ~~ SHARED TEMPLATES BETWEEN POSTS AND PAGES
open Giraffe.Htmx.Common
/// The round-trip instant pattern
let roundTrip = InstantPattern.CreateWithInvariantCulture "uuuu'-'MM'-'dd'T'HH':'mm':'ss'.'fffffff"
/// Capitalize the first letter in the given string
let private capitalize (it: string) =
$"{(string it[0]).ToUpper()}{it[1..]}"
/// The common edit form shared by pages and posts
let commonEdit (model: EditCommonModel) app = [
textField [ _class "mb-3"; _required; _autofocus ] (nameof model.Title) "Title" model.Title []
textField [ _class "mb-3"; _required ] (nameof model.Permalink) "Permalink" model.Permalink [
if not model.IsNew then
let urlBase = relUrl app $"admin/{model.Entity}/{model.Id}"
span [ _class "form-text" ] [
a [ _href $"{urlBase}/permalinks" ] [ raw "Manage Permalinks" ]; actionSpacer
a [ _href $"{urlBase}/revisions" ] [ raw "Manage Revisions" ]
if model.IncludeChapterLink then
span [ _id "chapterEditLink" ] [
actionSpacer; a [ _href $"{urlBase}/chapters" ] [ raw "Manage Chapters" ]
]
]
]
div [ _class "mb-2" ] [
label [ _for "text" ] [ raw "Text" ]; raw " &nbsp; &nbsp; "
div [ _class "btn-group btn-group-sm"; _roleGroup; _ariaLabel "Text format button group" ] [
input [ _type "radio"; _name (nameof model.Source); _id "source_html"; _class "btn-check"
_value "HTML"; if model.Source = "HTML" then _checked ]
label [ _class "btn btn-sm btn-outline-secondary"; _for "source_html" ] [ raw "HTML" ]
input [ _type "radio"; _name (nameof model.Source); _id "source_md"; _class "btn-check"
_value "Markdown"; if model.Source = "Markdown" then _checked ]
label [ _class "btn btn-sm btn-outline-secondary"; _for "source_md" ] [ raw "Markdown" ]
]
]
div [ _class "mb-3" ] [
textarea [ _name (nameof model.Text); _id (nameof model.Text); _class "form-control"; _rows "20" ] [
raw model.Text
]
]
]
/// Display a common template list
let commonTemplates (model: EditCommonModel) (templates: MetaItem seq) =
selectField [ _class "mb-3" ] (nameof model.Template) $"{capitalize model.Entity} Template" model.Template templates
(_.Name) (_.Value) []
/// Display the metadata item edit form
let commonMetaItems (model: EditCommonModel) =
let items = Array.zip model.MetaNames model.MetaValues
let metaDetail idx (name, value) =
div [ _id $"meta_%i{idx}"; _class "row mb-3" ] [
div [ _class "col-1 text-center align-self-center" ] [
button [ _type "button"; _class "btn btn-sm btn-danger"; _onclick $"Admin.removeMetaItem({idx})" ] [
raw "&minus;"
]
]
div [ _class "col-3" ] [ textField [ _id $"MetaNames_{idx}" ] (nameof model.MetaNames) "Name" name [] ]
div [ _class "col-8" ] [ textField [ _id $"MetaValues_{idx}" ] (nameof model.MetaValues) "Value" value [] ]
]
fieldset [] [
legend [] [
raw "Metadata "
button [ _type "button"; _class "btn btn-sm btn-secondary"; _data "bs-toggle" "collapse"
_data "bs-target" "#meta_item_container" ] [
raw "show"
]
]
div [ _id "meta_item_container"; _class "collapse" ] [
div [ _id "meta_items"; _class "container" ] (items |> Array.mapi metaDetail |> List.ofArray)
button [ _type "button"; _class "btn btn-sm btn-secondary"; _onclick "Admin.addMetaItem()" ] [
raw "Add an Item"
]
script [] [
raw """document.addEventListener("DOMContentLoaded", """
raw $"() => Admin.setNextMetaIndex({items.Length}))"
]
]
]
/// Revision preview template
let commonPreview (rev: Revision) app =
div [ _class "mwl-revision-preview mb-3" ] [
rev.Text.AsHtml() |> addBaseToRelativeUrls app.WebLog.ExtraPath |> raw
]
|> List.singleton
/// Form to manage permalinks for pages or posts
let managePermalinks (model: ManagePermalinksModel) app = [
let baseUrl = relUrl app $"admin/{model.Entity}/"
let linkDetail idx link =
div [ _id $"link_%i{idx}"; _class "row mb-3" ] [
div [ _class "col-1 text-center align-self-center" ] [
button [ _type "button"; _class "btn btn-sm btn-danger"
_onclick $"Admin.removePermalink({idx})" ] [
raw "&minus;"
]
]
div [ _class "col-11" ] [
div [ _class "form-floating" ] [
input [ _type "text"; _name "Prior"; _id $"prior_{idx}"; _class "form-control"; _placeholder "Link"
_value link ]
label [ _for $"prior_{idx}" ] [ raw "Link" ]
]
]
]
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
form [ _action $"{baseUrl}permalinks"; _method "post"; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row" ] [
div [ _class "col" ] [
p [ _style "line-height:1.2rem;" ] [
strong [] [ txt model.CurrentTitle ]; br []
small [ _class "text-muted" ] [
span [ _class "fst-italic" ] [ txt model.CurrentPermalink ]; br []
a [ _href $"{baseUrl}{model.Id}/edit" ] [
raw $"&laquo; Back to Edit {capitalize model.Entity}"
]
]
]
]
]
div [ _class "row mb-3" ] [
div [ _class "col" ] [
button [ _type "button"; _class "btn btn-sm btn-secondary"; _onclick "Admin.addPermalink()" ] [
raw "Add a Permalink"
]
]
]
div [ _class "row mb-3" ] [
div [ _class "col" ] [
div [ _id "permalinks"; _class "container g-0" ] [
yield! Array.mapi linkDetail model.Prior
script [] [
raw """document.addEventListener("DOMContentLoaded", """
raw $"() => Admin.setPermalinkIndex({model.Prior.Length}))"
]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col " ] [
button [ _type "submit"; _class "btn btn-primary" ] [ raw "Save Changes" ]
]
]
]
]
]
/// Form to manage revisions for pages or posts
let manageRevisions (model: ManageRevisionsModel) app = [
let revUrlBase = relUrl app $"admin/{model.Entity}/{model.Id}/revision"
let revDetail idx (rev: Revision) =
let asOfString = roundTrip.Format rev.AsOf
let asOfId = $"""rev_{asOfString.Replace(".", "_").Replace(":", "-")}"""
div [ _id asOfId; _class "row pb-3 mwl-table-detail" ] [
div [ _class "col-12 mb-1" ] [
longDate app rev.AsOf; raw " at "; shortTime app rev.AsOf; raw " "
span [ _class "badge bg-secondary text-uppercase ms-2" ] [ txt (string rev.Text.SourceType) ]
if idx = 0 then span [ _class "badge bg-primary text-uppercase ms-2" ] [ raw "Current Revision" ]
br []
if idx > 0 then
let revUrlPrefix = $"{revUrlBase}/{asOfString}"
let revRestore = $"{revUrlPrefix}/restore"
small [] [
a [ _href $"{revUrlPrefix}/preview"; _hxTarget $"#{asOfId}_preview" ] [ raw "Preview" ]
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href revRestore; _hxPost revRestore ] [ raw "Restore as Current" ]
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href revUrlPrefix; _hxDelete revUrlPrefix; _hxTarget $"#{asOfId}"
_hxSwap HxSwap.OuterHtml; _class "text-danger" ] [
raw "Delete"
]
]
]
if idx > 0 then div [ _id $"{asOfId}_preview"; _class "col-12" ] []
]
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
form [ _method "post"; _hxTarget "body"; _class "container mb-3" ] [
antiCsrf app
input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row" ] [
div [ _class "col" ] [
p [ _style "line-height:1.2rem;" ] [
strong [] [ txt model.CurrentTitle ]; br []
small [ _class "text-muted" ] [
a [ _href (relUrl app $"admin/{model.Entity}/{model.Id}/edit") ] [
raw $"&laquo; Back to Edit {(string model.Entity[0]).ToUpper()}{model.Entity[1..]}"
]
]
]
]
]
if model.Revisions.Length > 1 then
div [ _class "row mb-3" ] [
div [ _class "col" ] [
button [ _type "button"; _class "btn btn-sm btn-danger"; _hxDelete $"{revUrlBase}s"
_hxConfirm "This will remove all revisions but the current one; are you sure this is what you wish to do?" ] [
raw "Delete All Prior Revisions"
]
]
]
div [ _class "row mwl-table-heading" ] [ div [ _class "col" ] [ raw "Revision" ] ]
yield! List.mapi revDetail model.Revisions
]
]
]

105
src/MyWebLog/Views/Page.fs Normal file
View File

@@ -0,0 +1,105 @@
module MyWebLog.Views.Page
open Giraffe.ViewEngine
open Giraffe.ViewEngine.Htmx
open MyWebLog
open MyWebLog.ViewModels
/// The form to edit pages
let pageEdit (model: EditPageModel) templates app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
form [ _action (relUrl app "admin/page/save"); _method "post"; _hxPushUrl "true"; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name (nameof model.Id); _value model.Id ]
div [ _class "row mb-3" ] [
div [ _class "col-9" ] (commonEdit model app)
div [ _class "col-3" ] [
commonTemplates model templates
checkboxSwitch [] (nameof model.IsShownInPageList) "Show in Page List" model.IsShownInPageList []
]
]
div [ _class "row mb-3" ] [ div [ _class "col" ] [ saveButton ] ]
div [ _class "row mb-3" ] [ div [ _class "col" ] [ commonMetaItems model ] ]
]
]
]
/// Display a list of pages for this web log
let pageList (pages: DisplayPage list) pageNbr hasNext app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
a [ _href (relUrl app "admin/page/new/edit"); _class "btn btn-primary btn-sm mb-3" ] [ raw "Create a New Page" ]
if pages.Length = 0 then
p [ _class "text-muted fst-italic text-center" ] [ raw "This web log has no pages" ]
else
let titleCol = "col-12 col-md-5"
let linkCol = "col-12 col-md-5"
let upd8Col = "col-12 col-md-2"
form [ _method "post"; _class "container mb-3"; _hxTarget "body" ] [
antiCsrf app
div [ _class "row mwl-table-heading" ] [
div [ _class titleCol ] [
span [ _class "d-none d-md-inline" ] [ raw "Title" ]; span [ _class "d-md-none" ] [ raw "Page" ]
]
div [ _class $"{linkCol} d-none d-md-inline-block" ] [ raw "Permalink" ]
div [ _class $"{upd8Col} d-none d-md-inline-block" ] [ raw "Updated" ]
]
for pg in pages do
let pageLink = if pg.IsDefault then "" else pg.Permalink
div [ _class "row mwl-table-detail" ] [
div [ _class titleCol ] [
txt pg.Title
if pg.IsDefault then
raw " &nbsp; "; span [ _class "badge bg-success" ] [ raw "HOME PAGE" ]
if pg.IsInPageList then
raw " &nbsp; "; span [ _class "badge bg-primary" ] [ raw "IN PAGE LIST" ]
br [] ; small [] [
let adminUrl = relUrl app $"admin/page/{pg.Id}"
a [ _href (relUrl app pageLink); _target "_blank" ] [ raw "View Page" ]
if app.IsEditor || (app.IsAuthor && app.UserId.Value = WebLogUserId pg.AuthorId) then
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href $"{adminUrl}/edit" ] [ raw "Edit" ]
if app.IsWebLogAdmin then
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href adminUrl; _hxDelete adminUrl; _class "text-danger"
_hxConfirm $"Are you sure you want to delete the page &ldquo;{pg.Title}&rdquo;? This action cannot be undone." ] [
raw "Delete"
]
]
]
div [ _class linkCol ] [
small [ _class "d-md-none" ] [ txt pageLink ]
span [ _class "d-none d-md-inline" ] [ txt pageLink ]
]
div [ _class upd8Col ] [
small [ _class "d-md-none text-muted" ] [
raw "Updated "; txt (pg.UpdatedOn.ToString "MMMM d, yyyy")
]
span [ _class "d-none d-md-inline" ] [ txt (pg.UpdatedOn.ToString "MMMM d, yyyy") ]
]
]
]
if pageNbr > 1 || hasNext then
div [ _class "d-flex justify-content-evenly mb-3" ] [
div [] [
if pageNbr > 1 then
let prevPage = if pageNbr = 2 then "" else $"/page/{pageNbr - 1}"
p [] [
a [ _class "btn btn-secondary"; _href (relUrl app $"admin/pages{prevPage}") ] [
raw "&laquo; Previous"
]
]
]
div [ _class "text-right" ] [
if hasNext then
p [] [
a [ _class "btn btn-secondary"; _href (relUrl app $"admin/pages/page/{pageNbr + 1}") ] [
raw "Next &raquo;"
]
]
]
]
]
]

524
src/MyWebLog/Views/Post.fs Normal file
View File

@@ -0,0 +1,524 @@
module MyWebLog.Views.Post
open Giraffe.Htmx.Common
open Giraffe.ViewEngine
open Giraffe.ViewEngine.Htmx
open MyWebLog
open MyWebLog.ViewModels
open NodaTime.Text
/// The pattern for chapter start times
let startTimePattern = DurationPattern.CreateWithInvariantCulture "H:mm:ss.FF"
/// The form to add or edit a chapter
let chapterEdit (model: EditChapterModel) app = [
let postUrl = relUrl app $"admin/post/{model.PostId}/chapter/{model.Index}"
h3 [ _class "my-3" ] [ raw (if model.Index < 0 then "Add" else "Edit"); raw " Chapter" ]
p [ _class "form-text" ] [
raw "Times may be entered as seconds; minutes and seconds; or hours, minutes and seconds. Fractional seconds "
raw "are supported to two decimal places."
]
form [ _method "post"; _action postUrl; _hxPost postUrl; _hxTarget "#chapter_list"; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name "PostId"; _value model.PostId ]
input [ _type "hidden"; _name "Index"; _value (string model.Index) ]
div [ _class "row" ] [
div [ _class "col-6 col-lg-3 mb-3" ] [
textField [ _required; _autofocus ] (nameof model.StartTime) "Start Time"
(if model.Index < 0 then "" else model.StartTime) []
]
div [ _class "col-6 col-lg-3 mb-3" ] [
textField [] (nameof model.EndTime) "End Time" model.EndTime [
span [ _class "form-text" ] [ raw "Optional; ends when next starts" ]
]
]
div [ _class "col-12 col-lg-6 mb-3" ] [
textField [] (nameof model.Title) "Chapter Title" model.Title [
span [ _class "form-text" ] [ raw "Optional" ]
]
]
div [ _class "col-12 col-lg-6 col-xl-5 mb-3" ] [
textField [] (nameof model.ImageUrl) "Image URL" model.ImageUrl [
span [ _class "form-text" ] [
raw "Optional; a separate image to display while this chapter is playing"
]
]
]
div [ _class "col-12 col-lg-6 col-xl-5 mb-3" ] [
textField [] (nameof model.Url) "URL" model.Url [
span [ _class "form-text" ] [ raw "Optional; informational link for this chapter" ]
]
]
div [ _class "col-12 col-lg-6 offset-lg-3 col-xl-2 offset-xl-0 mb-3 align-self-end d-flex flex-column" ] [
checkboxSwitch [] (nameof model.IsHidden) "Hidden Chapter" model.IsHidden []
span [ _class "mt-2 form-text" ] [ raw "Not displayed, but may update image and location" ]
]
]
div [ _class "row" ] [
let hasLoc, attrs = if model.LocationName = "" then false, [ _disabled ] else true, []
div [ _class "col-12 col-md-4 col-lg-3 offset-lg-1 mb-3 align-self-end" ] [
checkboxSwitch [ _onclick "Admin.checkChapterLocation()" ] "has_location" "Associate Location" hasLoc []
]
div [ _class "col-12 col-md-8 col-lg-6 offset-lg-1 mb-3" ] [
textField (_required :: attrs) (nameof model.LocationName) "Name" model.LocationName []
]
div [ _class "col-6 col-lg-4 offset-lg-2 mb-3" ] [
textField (_required :: attrs) (nameof model.LocationGeo) "Geo URL" model.LocationGeo [
em [ _class "form-text" ] [
a [ _href "https://github.com/Podcastindex-org/podcast-namespace/blob/main/location/location.md#geo-recommended"
_target "_blank"; _relNoOpener ] [
raw "see spec"
]
]
]
]
div [ _class "col-6 col-lg-4 mb-3" ] [
textField attrs (nameof model.LocationOsm) "OpenStreetMap ID" model.LocationOsm [
em [ _class "form-text" ] [
raw "Optional; "
a [ _href "https://www.openstreetmap.org/"; _target "_blank"; _relNoOpener ] [ raw "get ID" ]
raw ", "
a [ _href "https://github.com/Podcastindex-org/podcast-namespace/blob/main/location/location.md#osm-recommended"
_target "_blank"; _relNoOpener ] [
raw "see spec"
]
]
]
]
]
div [ _class "row" ] [
div [ _class "col" ] [
let cancelLink = relUrl app $"admin/post/{model.PostId}/chapters"
if model.Index < 0 then
checkboxSwitch [ _checked ] (nameof model.AddAnother) "Add Another New Chapter" true []
else
input [ _type "hidden"; _name "AddAnother"; _value "false" ]
saveButton; raw " &nbsp; "
a [ _href cancelLink; _hxGet cancelLink; _class "btn btn-secondary"; _hxTarget "body" ] [ raw "Cancel" ]
]
]
]
]
/// Display a list of chapters
let chapterList withNew (model: ManageChaptersModel) app =
form [ _method "post"; _id "chapter_list"; _class "container mb-3"; _hxTarget "this"; _hxSwap HxSwap.OuterHtml ] [
antiCsrf app
input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row mwl-table-heading" ] [
div [ _class "col-3 col-md-2" ] [ raw "Start" ]
div [ _class "col-3 col-md-6 col-lg-8" ] [ raw "Title" ]
div [ _class "col-3 col-md-2 col-lg-1 text-center" ] [ raw "Image?" ]
div [ _class "col-3 col-md-2 col-lg-1 text-center" ] [ raw "Location?" ]
]
yield! model.Chapters |> List.mapi (fun idx chapter ->
div [ _class "row mwl-table-detail"; _id $"chapter{idx}" ] [
div [ _class "col-3 col-md-2" ] [ txt (startTimePattern.Format chapter.StartTime) ]
div [ _class "col-3 col-md-6 col-lg-8" ] [
match chapter.Title with
| Some title -> txt title
| None -> em [ _class "text-muted" ] [ raw "no title" ]
br []
small [] [
if withNew then
raw "&nbsp;"
else
let chapterUrl = relUrl app $"admin/post/{model.Id}/chapter/{idx}"
a [ _href chapterUrl; _hxGet chapterUrl; _hxTarget $"#chapter{idx}"
_hxSwap $"{HxSwap.InnerHtml} show:#chapter{idx}:top" ] [
raw "Edit"
]
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href chapterUrl; _hxDelete chapterUrl; _class "text-danger" ] [
raw "Delete"
]
]
]
div [ _class "col-3 col-md-2 col-lg-1 text-center" ] [ yesOrNo (Option.isSome chapter.ImageUrl) ]
div [ _class "col-3 col-md-2 col-lg-1 text-center" ] [ yesOrNo (Option.isSome chapter.Location) ]
])
div [ _class "row pb-3"; _id "chapter-1" ] [
let newLink = relUrl app $"admin/post/{model.Id}/chapter/-1"
if withNew then
span [ _hxGet newLink; _hxTarget "#chapter-1"; _hxTrigger "load"; _hxSwap "show:#chapter-1:top" ] []
else
div [ _class "row pb-3 mwl-table-detail" ] [
div [ _class "col-12" ] [
a [ _class "btn btn-primary"; _href newLink; _hxGet newLink; _hxTarget "#chapter-1"
_hxSwap "show:#chapter-1:top" ] [
raw "Add a New Chapter"
]
]
]
]
]
|> List.singleton
/// Manage Chapters page
let chapters withNew (model: ManageChaptersModel) app = [
h2 [ _class "my-3" ] [ txt app.PageTitle ]
article [] [
p [ _style "line-height:1.2rem;" ] [
strong [] [ txt model.Title ]; br []
small [ _class "text-muted" ] [
a [ _href (relUrl app $"admin/post/{model.Id}/edit") ] [
raw "&laquo; Back to Edit Post"
]
]
]
yield! chapterList withNew model app
]
]
/// Display a list of posts
let list (model: PostDisplay) app = [
let dateCol = "col-xs-12 col-md-3 col-lg-2"
let titleCol = "col-xs-12 col-md-7 col-lg-6 col-xl-5 col-xxl-4"
let authorCol = "col-xs-12 col-md-2 col-lg-1"
let tagCol = "col-lg-3 col-xl-4 col-xxl-5 d-none d-lg-inline-block"
h2 [ _class "my-3" ] [ txt app.PageTitle ]
article [] [
a [ _href (relUrl app "admin/post/new/edit"); _class "btn btn-primary btn-sm mb-3" ] [ raw "Write a New Post" ]
if model.Posts.Length > 0 then
form [ _method "post"; _class "container mb-3"; _hxTarget "body" ] [
antiCsrf app
div [ _class "row mwl-table-heading" ] [
div [ _class dateCol ] [
span [ _class "d-md-none" ] [ raw "Post" ]; span [ _class "d-none d-md-inline" ] [ raw "Date" ]
]
div [ _class $"{titleCol} d-none d-md-inline-block" ] [ raw "Title" ]
div [ _class $"{authorCol} d-none d-md-inline-block" ] [ raw "Author" ]
div [ _class tagCol ] [ raw "Tags" ]
]
for post in model.Posts do
div [ _class "row mwl-table-detail" ] [
div [ _class $"{dateCol} no-wrap" ] [
small [ _class "d-md-none" ] [
if post.PublishedOn.HasValue then
raw "Published "; txt (post.PublishedOn.Value.ToString "MMMM d, yyyy")
else raw "Not Published"
if post.PublishedOn.HasValue && post.PublishedOn.Value <> post.UpdatedOn then
em [ _class "text-muted" ] [
raw " (Updated "; txt (post.UpdatedOn.ToString "MMMM d, yyyy"); raw ")"
]
]
span [ _class "d-none d-md-inline" ] [
if post.PublishedOn.HasValue then txt (post.PublishedOn.Value.ToString "MMMM d, yyyy")
else raw "Not Published"
if not post.PublishedOn.HasValue || post.PublishedOn.Value <> post.UpdatedOn then
br []
small [ _class "text-muted" ] [
em [] [ txt (post.UpdatedOn.ToString "MMMM d, yyyy") ]
]
]
]
div [ _class titleCol ] [
if Option.isSome post.Episode then
span [ _class "badge bg-success float-end text-uppercase mt-1" ] [ raw "Episode" ]
raw post.Title; br []
small [] [
let postUrl = relUrl app $"admin/post/{post.Id}"
a [ _href (relUrl app post.Permalink); _target "_blank" ] [ raw "View Post" ]
if app.IsEditor || (app.IsAuthor && app.UserId.Value = WebLogUserId post.AuthorId) then
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href $"{postUrl}/edit" ] [ raw "Edit" ]
if app.IsWebLogAdmin then
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href postUrl; _hxDelete postUrl; _class "text-danger"
_hxConfirm $"Are you sure you want to delete the post “{post.Title}”? This action cannot be undone." ] [
raw "Delete"
]
]
]
div [ _class authorCol ] [
let author =
model.Authors
|> List.tryFind (fun a -> a.Name = post.AuthorId)
|> Option.map _.Value
|> Option.defaultValue "--"
|> txt
small [ _class "d-md-none" ] [
raw "Authored by "; author; raw " | "
raw (if post.Tags.Length = 0 then "No" else string post.Tags.Length)
raw " Tag"; if post.Tags.Length <> 0 then raw "s"
]
span [ _class "d-none d-md-inline" ] [ author ]
]
div [ _class tagCol ] [
let tags =
post.Tags |> List.mapi (fun idx tag -> idx, span [ _class "no-wrap" ] [ txt tag ])
for tag in tags do
snd tag
if fst tag < tags.Length - 1 then raw ", "
]
]
]
if Option.isSome model.NewerLink || Option.isSome model.OlderLink then
div [ _class "d-flex justify-content-evenly mb-3" ] [
div [] [
if Option.isSome model.NewerLink then
p [] [
a [ _href model.NewerLink.Value; _class "btn btn-secondary"; ] [
raw "&laquo; Newer Posts"
]
]
]
div [ _class "text-right" ] [
if Option.isSome model.OlderLink then
p [] [
a [ _href model.OlderLink.Value; _class "btn btn-secondary" ] [
raw "Older Posts &raquo;"
]
]
]
]
else
p [ _class "text-muted fst-italic text-center" ] [ raw "This web log has no posts" ]
]
]
let postEdit (model: EditPostModel) templates (ratings: MetaItem list) app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
form [ _action (relUrl app "admin/post/save"); _method "post"; _hxPushUrl "true"; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name (nameof model.Id); _value model.Id ]
div [ _class "row mb-3" ] [
div [ _class "col-12 col-lg-9" ] [
yield! commonEdit model app
textField [ _class "mb-3" ] (nameof model.Tags) "Tags" model.Tags [
div [ _class "form-text" ] [ raw "comma-delimited" ]
]
if model.Status = string Draft then
checkboxSwitch [ _class "mb-2" ] (nameof model.DoPublish) "Publish This Post" model.DoPublish []
saveButton
hr [ _class "mb-3" ]
fieldset [ _class "mb-3" ] [
legend [] [
span [ _class "form-check form-switch" ] [
small [] [
input [ _type "checkbox"; _name (nameof model.IsEpisode)
_id (nameof model.IsEpisode); _class "form-check-input"; _value "true"
_data "bs-toggle" "collapse"; _data "bs-target" "#episode_items"
_onclick "Admin.toggleEpisodeFields()"; if model.IsEpisode then _checked ]
]
label [ _for (nameof model.IsEpisode) ] [ raw "Podcast Episode" ]
]
]
div [ _id "episode_items"
_class $"""container p-0 collapse{if model.IsEpisode then " show" else ""}""" ] [
div [ _class "row" ] [
div [ _class "col-12 col-md-8 pb-3" ] [
textField [ _required ] (nameof model.Media) "Media File" model.Media [
div [ _class "form-text" ] [
raw "Relative URL will be appended to base media path (if set) "
raw "or served from this web log"
]
]
]
div [ _class "col-12 col-md-4 pb-3" ] [
textField [] (nameof model.MediaType) "Media MIME Type" model.MediaType [
div [ _class "form-text" ] [ raw "Optional; overrides podcast default" ]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col" ] [
numberField [ _required ] (nameof model.Length) "Media Length (bytes)"
(string model.Length) [
div [ _class "form-text" ] [ raw "TODO: derive from above file name" ]
]
]
div [ _class "col" ] [
textField [] (nameof model.Duration) "Duration" model.Duration [
div [ _class "form-text" ] [
raw "Recommended; enter in "; code [] [ raw "HH:MM:SS"]; raw " format"
]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col" ] [
textField [] (nameof model.Subtitle) "Subtitle" model.Subtitle [
div [ _class "form-text" ] [ raw "Optional; a subtitle for this episode" ]
]
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-8 pb-3" ] [
textField [] (nameof model.ImageUrl) "Image URL" model.ImageUrl [
div [ _class "form-text" ] [
raw "Optional; overrides podcast default; "
raw "relative URL served from this web log"
]
]
]
div [ _class "col-12 col-md-4 pb-3" ] [
selectField [] (nameof model.Explicit) "Explicit Rating" model.Explicit ratings
(_.Name) (_.Value) [
div [ _class "form-text" ] [ raw "Optional; overrides podcast default" ]
]
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-8 pb-3" ] [
div [ _class "form-text" ] [ raw "Chapters" ]
div [ _class "form-check form-check-inline" ] [
input [ _type "radio"; _name (nameof model.ChapterSource)
_id "chapter_source_none"; _value "none"; _class "form-check-input"
if model.ChapterSource = "none" then _checked
_onclick "Admin.setChapterSource('none')" ]
label [ _for "chapter_source_none" ] [ raw "None" ]
]
div [ _class "form-check form-check-inline" ] [
input [ _type "radio"; _name (nameof model.ChapterSource)
_id "chapter_source_internal"; _value "internal"
_class "form-check-input"
if model.ChapterSource= "internal" then _checked
_onclick "Admin.setChapterSource('internal')" ]
label [ _for "chapter_source_internal" ] [ raw "Defined Here" ]
]
div [ _class "form-check form-check-inline" ] [
input [ _type "radio"; _name (nameof model.ChapterSource)
_id "chapter_source_external"; _value "external"
_class "form-check-input"
if model.ChapterSource = "external" then _checked
_onclick "Admin.setChapterSource('external')" ]
label [ _for "chapter_source_external" ] [ raw "Separate File" ]
]
]
div [ _class "col-md-4 d-flex justify-content-center" ] [
checkboxSwitch [ _class "align-self-center pb-3" ] (nameof model.ContainsWaypoints)
"Chapters contain waypoints" model.ContainsWaypoints []
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-8 pb-3" ] [
textField [] (nameof model.ChapterFile) "Chapter File" model.ChapterFile [
div [ _class "form-text" ] [ raw "Relative URL served from this web log" ]
]
]
div [ _class "col-12 col-md-4 pb-3" ] [
textField [] (nameof model.ChapterType) "Chapter MIME Type" model.ChapterType [
div [ _class "form-text" ] [
raw "Optional; "; code [] [ raw "application/json+chapters" ]
raw " assumed if chapter file ends with "; code [] [ raw ".json" ]
]
]
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-8 pb-3" ] [
textField [ _onkeyup "Admin.requireTranscriptType()" ] (nameof model.TranscriptUrl)
"Transcript URL" model.TranscriptUrl [
div [ _class "form-text" ] [
raw "Optional; relative URL served from this web log"
]
]
]
div [ _class "col-12 col-md-4 pb-3" ] [
textField [ if model.TranscriptUrl <> "" then _required ]
(nameof model.TranscriptType) "Transcript MIME Type"
model.TranscriptType [
div [ _class "form-text" ] [ raw "Required if transcript URL provided" ]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col" ] [
textField [] (nameof model.TranscriptLang) "Transcript Language"
model.TranscriptLang [
div [ _class "form-text" ] [ raw "Optional; overrides podcast default" ]
]
]
div [ _class "col d-flex justify-content-center" ] [
checkboxSwitch [ _class "align-self-center pb-3" ] (nameof model.TranscriptCaptions)
"This is a captions file" model.TranscriptCaptions []
]
]
div [ _class "row pb-3" ] [
div [ _class "col col-md-4" ] [
numberField [] (nameof model.SeasonNumber) "Season Number"
(string model.SeasonNumber) [
div [ _class "form-text" ] [ raw "Optional" ]
]
]
div [ _class "col col-md-8" ] [
textField [ _maxlength "128" ] (nameof model.SeasonDescription) "Season Description"
model.SeasonDescription [
div [ _class "form-text" ] [ raw "Optional" ]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col col-md-4" ] [
numberField [ _step "0.01" ] (nameof model.EpisodeNumber) "Episode Number"
model.EpisodeNumber [
div [ _class "form-text" ] [ raw "Optional; up to 2 decimal points" ]
]
]
div [ _class "col col-md-8" ] [
textField [ _maxlength "128" ] (nameof model.EpisodeDescription)
"Episode Description" model.EpisodeDescription [
div [ _class "form-text" ] [ raw "Optional" ]
]
]
]
]
script [] [
raw """document.addEventListener("DOMContentLoaded", () => Admin.toggleEpisodeFields())"""
]
]
commonMetaItems model
if model.Status = string Published then
fieldset [ _class "pb-3" ] [
legend [] [ raw "Maintenance" ]
div [ _class "container" ] [
div [ _class "row" ] [
div [ _class "col align-self-center" ] [
checkboxSwitch [ _class "pb-2" ] (nameof model.SetPublished)
"Set Published Date" model.SetPublished []
]
div [ _class "col-4" ] [
div [ _class "form-floating" ] [
input [ _type "datetime-local"; _name (nameof model.PubOverride)
_id (nameof model.PubOverride); _class "form-control"
_placeholder "Override Date"
if model.PubOverride.HasValue then
_value (model.PubOverride.Value.ToString "yyyy-MM-dd\THH:mm") ]
label [ _for (nameof model.PubOverride); _class "form-label" ] [
raw "Published On"
]
]
]
div [ _class "col-5 align-self-center" ] [
checkboxSwitch [ _class "pb-2" ] (nameof model.SetUpdated)
"Purge revisions and<br>set as updated date as well"
model.SetUpdated []
]
]
]
]
]
div [ _class "col-12 col-lg-3" ] [
commonTemplates model templates
fieldset [] [
legend [] [ raw "Categories" ]
for cat in app.Categories do
div [ _class "form-check" ] [
input [ _type "checkbox"; _name (nameof model.CategoryIds); _id $"category_{cat.Id}"
_class "form-check-input"; _value cat.Id
if model.CategoryIds |> Array.contains cat.Id then _checked ]
label [ _for $"category_{cat.Id}"; _class "form-check-label"
match cat.Description with Some it -> _title it | None -> () ] [
yield! cat.ParentNames |> Array.map (fun _ -> raw "&nbsp; &rang; &nbsp;")
txt cat.Name
]
]
]
]
]
]
]
script [] [ raw "window.setTimeout(() => Admin.toggleEpisodeFields(), 500)" ]
]

258
src/MyWebLog/Views/User.fs Normal file
View File

@@ -0,0 +1,258 @@
module MyWebLog.Views.User
open Giraffe.Htmx.Common
open Giraffe.ViewEngine
open Giraffe.ViewEngine.Htmx
open MyWebLog
open MyWebLog.ViewModels
/// User edit form
let edit (model: EditUserModel) app =
let levelOption value name =
option [ _value value; if model.AccessLevel = value then _selected ] [ txt name ]
div [ _class "col-12" ] [
h5 [ _class "my-3" ] [ txt app.PageTitle ]
form [ _hxPost (relUrl app "admin/settings/user/save"); _method "post"; _class "container"
_hxTarget "#user_panel"; _hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [
antiCsrf app
input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row" ] [
div [ _class "col-12 col-md-5 col-lg-3 col-xxl-2 offset-xxl-1 mb-3" ] [
div [ _class "form-floating" ] [
select [ _name "AccessLevel"; _id "accessLevel"; _class "form-control"; _required
_autofocus ] [
levelOption (string Author) "Author"
levelOption (string Editor) "Editor"
levelOption (string WebLogAdmin) "Web Log Admin"
if app.IsAdministrator then levelOption (string Administrator) "Administrator"
]
label [ _for "accessLevel" ] [ raw "Access Level" ]
]
]
div [ _class "col-12 col-md-7 col-lg-4 col-xxl-3 mb-3" ] [
emailField [ _required ] (nameof model.Email) "E-mail Address" model.Email []
]
div [ _class "col-12 col-lg-5 mb-3" ] [
textField [] (nameof model.Url) "User&rsquo;s Personal URL" model.Url []
]
]
div [ _class "row mb-3" ] [
div [ _class "col-12 col-md-6 col-lg-4 col-xl-3 offset-xl-1 pb-3" ] [
textField [ _required ] (nameof model.FirstName) "First Name" model.FirstName []
]
div [ _class "col-12 col-md-6 col-lg-4 col-xl-3 pb-3" ] [
textField [ _required ] (nameof model.LastName) "Last Name" model.LastName []
]
div [ _class "col-12 col-md-6 offset-md-3 col-lg-4 offset-lg-0 col-xl-3 offset-xl-1 pb-3" ] [
textField [ _required ] (nameof model.PreferredName) "Preferred Name" model.PreferredName []
]
]
div [ _class "row mb-3" ] [
div [ _class "col-12 col-xl-10 offset-xl-1" ] [
fieldset [ _class "p-2" ] [
legend [ _class "ps-1" ] [
if not model.IsNew then raw "Change "
raw "Password"
]
if not model.IsNew then
div [ _class "row" ] [
div [ _class "col" ] [
p [ _class "form-text" ] [
raw "Optional; leave blank not change the user&rsquo;s password"
]
]
]
div [ _class "row" ] [
let attrs, newLbl = if model.IsNew then [ _required ], "" else [], "New "
div [ _class "col-12 col-md-6 pb-3" ] [
passwordField attrs (nameof model.Password) $"{newLbl}Password" "" []
]
div [ _class "col-12 col-md-6 pb-3" ] [
passwordField attrs (nameof model.PasswordConfirm) $"Confirm {newLbl}Password" "" []
]
]
]
]
]
div [ _class "row mb-3" ] [
div [ _class "col text-center" ] [
saveButton; raw " &nbsp; "
if model.IsNew then
button [ _type "button"; _class "btn btn-sm btn-secondary ms-3"
_onclick "document.getElementById('user_new').innerHTML = ''" ] [
raw "Cancel"
]
else
a [ _href (relUrl app "admin/settings/users"); _class "btn btn-sm btn-secondary ms-3" ] [
raw "Cancel"
]
]
]
]
]
|> List.singleton
/// User log on form
let logOn (model: LogOnModel) (app: AppViewContext) = [
h2 [ _class "my-3" ] [ rawText "Log On to "; encodedText app.WebLog.Name ]
article [ _class "py-3" ] [
form [ _action (relUrl app "user/log-on"); _method "post"; _class "container"; _hxPushUrl "true" ] [
antiCsrf app
if Option.isSome model.ReturnTo then input [ _type "hidden"; _name "ReturnTo"; _value model.ReturnTo.Value ]
div [ _class "row" ] [
div [ _class "col-12 col-md-6 col-lg-4 offset-lg-2 pb-3" ] [
emailField [ _required; _autofocus ] (nameof model.EmailAddress) "E-mail Address" "" []
]
div [ _class "col-12 col-md-6 col-lg-4 pb-3" ] [
passwordField [ _required ] (nameof model.Password) "Password" "" []
]
]
div [ _class "row pb-3" ] [
div [ _class "col text-center" ] [
button [ _type "submit"; _class "btn btn-primary" ] [ rawText "Log On" ]
]
]
]
]
]
/// The list of users for a web log (part of web log settings page)
let userList (model: WebLogUser list) app =
let userCol = "col-12 col-md-4 col-xl-3"
let emailCol = "col-12 col-md-4 col-xl-4"
let cre8Col = "d-none d-xl-block col-xl-2"
let lastCol = "col-12 col-md-4 col-xl-3"
let badge = "ms-2 badge bg"
let userDetail (user: WebLogUser) =
div [ _class "row mwl-table-detail"; _id $"user_{user.Id}" ] [
div [ _class $"{userCol} no-wrap" ] [
txt user.PreferredName; raw " "
match user.AccessLevel with
| Administrator -> span [ _class $"{badge}-success" ] [ raw "ADMINISTRATOR" ]
| WebLogAdmin -> span [ _class $"{badge}-primary" ] [ raw "WEB LOG ADMIN" ]
| Editor -> span [ _class $"{badge}-secondary" ] [ raw "EDITOR" ]
| Author -> span [ _class $"{badge}-dark" ] [ raw "AUTHOR" ]
br []
if app.IsAdministrator || (app.IsWebLogAdmin && not (user.AccessLevel = Administrator)) then
let userUrl = relUrl app $"admin/settings/user/{user.Id}"
small [] [
a [ _href $"{userUrl}/edit"; _hxTarget $"#user_{user.Id}"
_hxSwap $"{HxSwap.InnerHtml} show:#user_{user.Id}:top" ] [
raw "Edit"
]
if app.UserId.Value <> user.Id then
span [ _class "text-muted" ] [ raw " &bull; " ]
a [ _href userUrl; _hxDelete userUrl; _class "text-danger"
_hxConfirm $"Are you sure you want to delete the user “{user.PreferredName}”? This action cannot be undone. (This action will not succeed if the user has authored any posts or pages.)" ] [
raw "Delete"
]
]
]
div [ _class emailCol ] [
txt $"{user.FirstName} {user.LastName}"; br []
small [ _class "text-muted" ] [
txt user.Email
if Option.isSome user.Url then
br []; txt user.Url.Value
]
]
div [ _class "d-none d-xl-block col-xl-2" ] [
if user.CreatedOn = Noda.epoch then raw "N/A" else longDate app user.CreatedOn
]
div [ _class "col-12 col-md-4 col-xl-3" ] [
match user.LastSeenOn with
| Some it -> longDate app it; raw " at "; shortTime app it
| None -> raw "--"
]
]
div [ _id "user_panel" ] [
a [ _href (relUrl app "admin/settings/user/new/edit"); _class "btn btn-primary btn-sm mb-3"
_hxTarget "#user_new" ] [
raw "Add a New User"
]
div [ _class "container g-0" ] [
div [ _class "row mwl-table-heading" ] [
div [ _class userCol ] [
raw "User"; span [ _class "d-md-none" ] [ raw "; Full Name / E-mail; Last Log On" ]
]
div [ _class $"{emailCol} d-none d-md-inline-block" ] [ raw "Full Name / E-mail" ]
div [ _class cre8Col ] [ raw "Created" ]
div [ _class $"{lastCol} d-none d-md-block" ] [ raw "Last Log On" ]
]
]
div [ _id "userList" ] [
div [ _class "container g-0" ] [
div [ _class "row mwl-table-detail"; _id "user_new" ] []
]
form [ _method "post"; _class "container g-0"; _hxTarget "#user_panel"
_hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [
antiCsrf app
yield! List.map userDetail model
]
]
]
|> List.singleton
/// Edit My Info form
let myInfo (model: EditMyInfoModel) (user: WebLogUser) app = [
h2 [ _class "my-3" ] [ txt app.PageTitle ]
article [] [
form [ _action (relUrl app "admin/my-info"); _method "post" ] [
antiCsrf app
div [ _class "d-flex flex-row flex-wrap justify-content-around" ] [
div [ _class "text-center mb-3 lh-sm" ] [
strong [ _class "text-decoration-underline" ] [ raw "Access Level" ]; br []
raw (string user.AccessLevel)
]
div [ _class "text-center mb-3 lh-sm" ] [
strong [ _class "text-decoration-underline" ] [ raw "Created" ]; br []
if user.CreatedOn = Noda.epoch then raw "N/A" else longDate app user.CreatedOn
]
div [ _class "text-center mb-3 lh-sm" ] [
strong [ _class "text-decoration-underline" ] [ raw "Last Log On" ]; br []
longDate app user.LastSeenOn.Value; raw " at "; shortTime app user.LastSeenOn.Value
]
]
div [ _class "container" ] [
div [ _class "row" ] [ div [ _class "col" ] [ hr [ _class "mt-0" ] ] ]
div [ _class "row mb-3" ] [
div [ _class "col-12 col-md-6 col-lg-4 pb-3" ] [
textField [ _required; _autofocus ] (nameof model.FirstName) "First Name" model.FirstName []
]
div [ _class "col-12 col-md-6 col-lg-4 pb-3" ] [
textField [ _required ] (nameof model.LastName) "Last Name" model.LastName []
]
div [ _class "col-12 col-md-6 col-lg-4 pb-3" ] [
textField [ _required ] (nameof model.PreferredName) "Preferred Name" model.PreferredName []
]
]
div [ _class "row mb-3" ] [
div [ _class "col" ] [
fieldset [ _class "p-2" ] [
legend [ _class "ps-1" ] [ raw "Change Password" ]
div [ _class "row" ] [
div [ _class "col" ] [
p [ _class "form-text" ] [
raw "Optional; leave blank to keep your current password"
]
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-6 pb-3" ] [
passwordField [] (nameof model.NewPassword) "New Password" "" []
]
div [ _class "col-12 col-md-6 pb-3" ] [
passwordField [] (nameof model.NewPasswordConfirm) "Confirm New Password" "" []
]
]
]
]
]
div [ _class "row" ] [ div [ _class "col text-center mb-3" ] [ saveButton ] ]
]
]
]
]

895
src/MyWebLog/Views/WebLog.fs Normal file
View File

@@ -0,0 +1,895 @@
module MyWebLog.Views.WebLog
open Giraffe.Htmx.Common
open Giraffe.ViewEngine
open Giraffe.ViewEngine.Accessibility
open Giraffe.ViewEngine.Htmx
open MyWebLog
open MyWebLog.ViewModels
/// Form to add or edit a category
let categoryEdit (model: EditCategoryModel) app =
div [ _class "col-12" ] [
h5 [ _class "my-3" ] [ raw app.PageTitle ]
form [ _action (relUrl app "admin/category/save"); _method "post"; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name (nameof model.CategoryId); _value model.CategoryId ]
div [ _class "row" ] [
div [ _class "col-12 col-sm-6 col-lg-4 col-xxl-3 offset-xxl-1 mb-3" ] [
textField [ _required; _autofocus ] (nameof model.Name) "Name" model.Name []
]
div [ _class "col-12 col-sm-6 col-lg-4 col-xxl-3 mb-3" ] [
textField [ _required ] (nameof model.Slug) "Slug" model.Slug []
]
div [ _class "col-12 col-lg-4 col-xxl-3 offset-xxl-1 mb-3" ] [
let cats =
app.Categories
|> Seq.ofArray
|> Seq.filter (fun c -> c.Id <> model.CategoryId)
|> Seq.map (fun c ->
let parents =
c.ParentNames
|> Array.map (fun it -> $"{it} &rang; ")
|> String.concat ""
{ Name = c.Id; Value = $"{parents}{c.Name}" })
|> Seq.append [ { Name = ""; Value = "&ndash; None &ndash;" } ]
selectField [] (nameof model.ParentId) "Parent Category" model.ParentId cats (_.Name) (_.Value) []
]
div [ _class "col-12 col-xl-10 offset-xl-1 mb-3" ] [
textField [] (nameof model.Description) "Description" model.Description []
]
]
div [ _class "row mb-3" ] [
div [ _class "col text-center" ] [
saveButton
a [ _href (relUrl app "admin/categories"); _class "btn btn-sm btn-secondary ms-3" ] [ raw "Cancel" ]
]
]
]
]
|> List.singleton
/// Category list page
let categoryList includeNew app = [
let catCol = "col-12 col-md-6 col-xl-5 col-xxl-4"
let descCol = "col-12 col-md-6 col-xl-7 col-xxl-8"
let categoryDetail (cat: DisplayCategory) =
div [ _class "row mwl-table-detail"; _id $"cat_{cat.Id}" ] [
div [ _class $"{catCol} no-wrap" ] [
if cat.ParentNames.Length > 0 then
cat.ParentNames
|> Seq.ofArray
|> Seq.map (fun it -> raw $"{it} &rang; ")
|> List.ofSeq
|> small [ _class "text-muted" ]
raw cat.Name; br []
small [] [
let catUrl = relUrl app $"admin/category/{cat.Id}"
if cat.PostCount > 0 then
a [ _href (relUrl app $"category/{cat.Slug}"); _target "_blank" ] [
raw $"View { cat.PostCount} Post"; if cat.PostCount <> 1 then raw "s"
]; actionSpacer
a [ _href $"{catUrl}/edit"; _hxTarget $"#cat_{cat.Id}"
_hxSwap $"{HxSwap.InnerHtml} show:#cat_{cat.Id}:top" ] [
raw "Edit"
]; actionSpacer
a [ _href catUrl; _hxDelete catUrl; _hxTarget "body"; _class "text-danger"
_hxConfirm $"Are you sure you want to delete the category “{cat.Name}”? This action cannot be undone." ] [
raw "Delete"
]
]
]
div [ _class descCol ] [
match cat.Description with Some value -> raw value | None -> em [ _class "text-muted" ] [ raw "none" ]
]
]
let loadNew =
span [ _hxGet (relUrl app "admin/category/new/edit"); _hxTrigger HxTrigger.Load; _hxSwap HxSwap.OuterHtml ] []
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
a [ _href (relUrl app "admin/category/new/edit"); _class "btn btn-primary btn-sm mb-3"; _hxTarget "#cat_new" ] [
raw "Add a New Category"
]
div [ _id "catList"; _class "container" ] [
if app.Categories.Length = 0 then
if includeNew then loadNew
else
div [ _id "cat_new" ] [
p [ _class "text-muted fst-italic text-center" ] [
raw "This web log has no categories defined"
]
]
else
div [ _class "container" ] [
div [ _class "row mwl-table-heading" ] [
div [ _class catCol ] [ raw "Category"; span [ _class "d-md-none" ] [ raw "; Description" ] ]
div [ _class $"{descCol} d-none d-md-inline-block" ] [ raw "Description" ]
]
]
form [ _method "post"; _class "container" ] [
antiCsrf app
div [ _class "row mwl-table-detail"; _id "cat_new" ] [ if includeNew then loadNew ]
yield! app.Categories |> Seq.ofArray |> Seq.map categoryDetail |> List.ofSeq
]
]
]
]
/// The main dashboard
let dashboard (model: DashboardModel) app = [
h2 [ _class "my-3" ] [ txt app.WebLog.Name; raw " &bull; Dashboard" ]
article [ _class "container" ] [
div [ _class "row" ] [
section [ _class "col-lg-5 offset-lg-1 col-xl-4 offset-xl-2 pb-3" ] [
div [ _class "card" ] [
header [ _class "card-header text-white bg-primary" ] [ raw "Posts" ]
div [ _class "card-body" ] [
h6 [ _class "card-subtitle text-muted pb-3" ] [
raw "Published "
span [ _class "badge rounded-pill bg-secondary" ] [ raw (string model.Posts) ]
raw "&nbsp; Drafts "
span [ _class "badge rounded-pill bg-secondary" ] [ raw (string model.Drafts) ]
]
if app.IsAuthor then
a [ _href (relUrl app "admin/posts"); _class "btn btn-secondary me-2" ] [ raw "View All" ]
a [ _href (relUrl app "admin/post/new/edit"); _class "btn btn-primary" ] [
raw "Write a New Post"
]
]
]
]
section [ _class "col-lg-5 col-xl-4 pb-3" ] [
div [ _class "card" ] [
header [ _class "card-header text-white bg-primary" ] [ raw "Pages" ]
div [ _class "card-body" ] [
h6 [ _class "card-subtitle text-muted pb-3" ] [
raw "All "
span [ _class "badge rounded-pill bg-secondary" ] [ raw (string model.Pages) ]
raw "&nbsp; Shown in Page List "
span [ _class "badge rounded-pill bg-secondary" ] [ raw (string model.ListedPages) ]
]
if app.IsAuthor then
a [ _href (relUrl app "admin/pages"); _class "btn btn-secondary me-2" ] [ raw "View All" ]
a [ _href (relUrl app "admin/page/new/edit"); _class "btn btn-primary" ] [
raw "Create a New Page"
]
]
]
]
]
div [ _class "row" ] [
section [ _class "col-lg-5 offset-lg-1 col-xl-4 offset-xl-2 pb-3" ] [
div [ _class "card" ] [
header [ _class "card-header text-white bg-secondary" ] [ raw "Categories" ]
div [ _class "card-body" ] [
h6 [ _class "card-subtitle text-muted pb-3"] [
raw "All "
span [ _class "badge rounded-pill bg-secondary" ] [ raw (string model.Categories) ]
raw "&nbsp; Top Level "
span [ _class "badge rounded-pill bg-secondary" ] [ raw (string model.TopLevelCategories) ]
]
if app.IsWebLogAdmin then
a [ _href (relUrl app "admin/categories"); _class "btn btn-secondary me-2" ] [
raw "View All"
]
a [ _href (relUrl app "admin/categories?new"); _class "btn btn-secondary" ] [
raw "Add a New Category"
]
]
]
]
]
if app.IsWebLogAdmin then
div [ _class "row pb-3" ] [
div [ _class "col text-end" ] [
a [ _href (relUrl app "admin/settings"); _class "btn btn-secondary" ] [ raw "Modify Settings" ]
]
]
]
]
/// Custom RSS feed edit form
let feedEdit (model: EditCustomFeedModel) (ratings: MetaItem list) (mediums: MetaItem list) app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
form [ _action (relUrl app "admin/settings/rss/save"); _method "post"; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row pb-3" ] [
div [ _class "col" ] [
a [ _href (relUrl app "admin/settings#rss-settings") ] [ raw "&laquo; Back to Settings" ]
]
]
div [ _class "row pb-3" ] [
div [ _class "col-12 col-lg-6" ] [
fieldset [ _class "container pb-0" ] [
legend [] [ raw "Identification" ]
div [ _class "row" ] [
div [ _class "col" ] [
textField [ _required ] (nameof model.Path) "Relative Feed Path" model.Path [
span [ _class "form-text fst-italic" ] [ raw "Appended to "; txt app.WebLog.UrlBase ]
]
]
]
div [ _class "row" ] [
div [ _class "col py-3 d-flex align-self-center justify-content-center" ] [
checkboxSwitch [ _onclick "Admin.checkPodcast()"; if model.IsPodcast then _checked ]
(nameof model.IsPodcast) "This Is a Podcast Feed" model.IsPodcast []
]
]
]
]
div [ _class "col-12 col-lg-6" ] [
fieldset [ _class "container pb-0" ] [
legend [] [ raw "Feed Source" ]
div [ _class "row d-flex align-items-center" ] [
div [ _class "col-1 d-flex justify-content-end pb-3" ] [
div [ _class "form-check form-check-inline me-0" ] [
input [ _type "radio"; _name (nameof model.SourceType); _id "SourceTypeCat"
_class "form-check-input"; _value "category"
if model.SourceType <> "tag" then _checked
_onclick "Admin.customFeedBy('category')" ]
label [ _for "SourceTypeCat"; _class "form-check-label d-none" ] [ raw "Category" ]
]
]
div [ _class "col-11 pb-3" ] [
let cats =
app.Categories
|> Seq.ofArray
|> Seq.map (fun c ->
let parents =
c.ParentNames
|> Array.map (fun it -> $"{it} &rang; ")
|> String.concat ""
{ Name = c.Id; Value = $"{parents}{c.Name}" })
|> Seq.append [ { Name = ""; Value = "&ndash; Select Category &ndash;" } ]
selectField [ _id "SourceValueCat"; _required
if model.SourceType = "tag" then _disabled ]
(nameof model.SourceValue) "Category" model.SourceValue cats (_.Name)
(_.Value) []
]
div [ _class "col-1 d-flex justify-content-end pb-3" ] [
div [ _class "form-check form-check-inline me-0" ] [
input [ _type "radio"; _name (nameof model.SourceType); _id "SourceTypeTag"
_class "form-check-input"; _value "tag"
if model.SourceType= "tag" then _checked
_onclick "Admin.customFeedBy('tag')" ]
label [ _for "sourceTypeTag"; _class "form-check-label d-none" ] [ raw "Tag" ]
]
]
div [ _class "col-11 pb-3" ] [
textField [ _id "SourceValueTag"; _required
if model.SourceType <> "tag" then _disabled ]
(nameof model.SourceValue) "Tag"
(if model.SourceType = "tag" then model.SourceValue else "") []
]
]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col" ] [
fieldset [ _class "container"; _id "podcastFields"; if not model.IsPodcast then _disabled ] [
legend [] [ raw "Podcast Settings" ]
div [ _class "row" ] [
div [ _class "col-12 col-md-5 col-lg-4 offset-lg-1 pb-3" ] [
textField [ _required ] (nameof model.Title) "Title" model.Title []
]
div [ _class "col-12 col-md-4 col-lg-4 pb-3" ] [
textField [] (nameof model.Subtitle) "Podcast Subtitle" model.Subtitle []
]
div [ _class "col-12 col-md-3 col-lg-2 pb-3" ] [
numberField [ _required ] (nameof model.ItemsInFeed) "# Episodes"
(string model.ItemsInFeed) []
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-5 col-lg-4 offset-lg-1 pb-3" ] [
textField [ _required ] (nameof model.AppleCategory) "iTunes Category"
model.AppleCategory [
span [ _class "form-text fst-italic" ] [
a [ _href "https://www.thepodcasthost.com/planning/itunes-podcast-categories/"
_target "_blank"; _relNoOpener ] [
raw "iTunes Category / Subcategory List"
]
]
]
]
div [ _class "col-12 col-md-4 pb-3" ] [
textField [] (nameof model.AppleSubcategory) "iTunes Subcategory" model.AppleSubcategory
[]
]
div [ _class "col-12 col-md-3 col-lg-2 pb-3" ] [
selectField [ _required ] (nameof model.Explicit) "Explicit Rating" model.Explicit
ratings (_.Name) (_.Value) []
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-6 col-lg-4 offset-xxl-1 pb-3" ] [
textField [ _required ] (nameof model.DisplayedAuthor) "Displayed Author"
model.DisplayedAuthor []
]
div [ _class "col-12 col-md-6 col-lg-4 pb-3" ] [
emailField [ _required ] (nameof model.Email) "Author E-mail" model.Email [
span [ _class "form-text fst-italic" ] [
raw "For iTunes, must match registered e-mail"
]
]
]
div [ _class "col-12 col-sm-5 col-md-4 col-lg-4 col-xl-3 offset-xl-1 col-xxl-2 offset-xxl-0 pb-3" ] [
textField [] (nameof model.DefaultMediaType) "Default Media Type"
model.DefaultMediaType [
span [ _class "form-text fst-italic" ] [ raw "Optional; blank for no default" ]
]
]
div [ _class "col-12 col-sm-7 col-md-8 col-lg-10 offset-lg-1 pb-3" ] [
textField [ _required ] (nameof model.ImageUrl) "Image URL" model.ImageUrl [
span [ _class "form-text fst-italic"] [
raw "Relative URL will be appended to "; txt app.WebLog.UrlBase; raw "/"
]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col-12 col-lg-10 offset-lg-1" ] [
textField [ _required ] (nameof model.Summary) "Summary" model.Summary [
span [ _class "form-text fst-italic" ] [ raw "Displayed in podcast directories" ]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col-12 col-lg-10 offset-lg-1" ] [
textField [] (nameof model.MediaBaseUrl) "Media Base URL" model.MediaBaseUrl [
span [ _class "form-text fst-italic" ] [
raw "Optional; prepended to episode media file if present"
]
]
]
]
div [ _class "row" ] [
div [ _class "col-12 col-lg-5 offset-lg-1 pb-3" ] [
textField [] (nameof model.FundingUrl) "Funding URL" model.FundingUrl [
span [ _class "form-text fst-italic" ] [
raw "Optional; URL describing donation options for this podcast, "
raw "relative URL supported"
]
]
]
div [ _class "col-12 col-lg-5 pb-3" ] [
textField [ _maxlength "128" ] (nameof model.FundingText) "Funding Text"
model.FundingText [
span [ _class "form-text fst-italic" ] [ raw "Optional; text for the funding link" ]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col-8 col-lg-5 offset-lg-1 pb-3" ] [
textField [] (nameof model.PodcastGuid) "Podcast GUID" model.PodcastGuid [
span [ _class "form-text fst-italic" ] [
raw "Optional; v5 UUID uniquely identifying this podcast; "
raw "once entered, do not change this value ("
a [ _href "https://github.com/Podcastindex-org/podcast-namespace/blob/main/docs/1.0.md#guid"
_target "_blank"; _relNoOpener ] [
raw "documentation"
]; raw ")"
]
]
]
div [ _class "col-4 col-lg-3 offset-lg-2 pb-3" ] [
selectField [] (nameof model.Medium) "Medium" model.Medium mediums (_.Name) (_.Value) [
span [ _class "form-text fst-italic" ] [
raw "Optional; medium of the podcast content ("
a [ _href "https://github.com/Podcastindex-org/podcast-namespace/blob/main/docs/1.0.md#medium"
_target "_blank"; _relNoOpener ] [
raw "documentation"
]; raw ")"
]
]
]
]
]
]
]
div [ _class "row pb-3" ] [ div [ _class "col text-center" ] [ saveButton ] ]
]
]
]
/// Redirect Rule edit form
let redirectEdit (model: EditRedirectRuleModel) app = [
let url = relUrl app $"admin/settings/redirect-rules/{model.RuleId}"
h3 [] [ raw (if model.RuleId < 0 then "Add" else "Edit"); raw " Redirect Rule" ]
form [ _action url; _hxPost url; _hxTarget "body"; _method "post"; _class "container" ] [
antiCsrf app
input [ _type "hidden"; _name "RuleId"; _value (string model.RuleId) ]
div [ _class "row" ] [
div [ _class "col-12 col-lg-5 mb-3" ] [
textField [ _autofocus; _required ] (nameof model.From) "From" model.From [
span [ _class "form-text" ] [ raw "From local URL/pattern" ]
]
]
div [ _class "col-12 col-lg-5 mb-3" ] [
textField [ _required ] (nameof model.To) "To" model.To [
span [ _class "form-text" ] [ raw "To URL/pattern" ]
]
]
div [ _class "col-12 col-lg-2 mb-3" ] [
checkboxSwitch [] (nameof model.IsRegex) "Use RegEx" model.IsRegex []
]
]
if model.RuleId < 0 then
div [ _class "row mb-3" ] [
div [ _class "col-12 text-center" ] [
label [ _class "me-1" ] [ raw "Add Rule" ]
div [ _class "btn-group btn-group-sm"; _roleGroup; _ariaLabel "New rule placement button group" ] [
input [ _type "radio"; _name "InsertAtTop"; _id "at_top"; _class "btn-check"; _value "true" ]
label [ _class "btn btn-sm btn-outline-secondary"; _for "at_top" ] [ raw "Top" ]
input [ _type "radio"; _name "InsertAtTop"; _id "at_bot"; _class "btn-check"; _value "false"
_checked ]
label [ _class "btn btn-sm btn-outline-secondary"; _for "at_bot" ] [ raw "Bottom" ]
]
]
]
div [ _class "row mb-3" ] [
div [ _class "col text-center" ] [
saveButton; raw " &nbsp; "
a [ _href (relUrl app "admin/settings/redirect-rules"); _class "btn btn-sm btn-secondary ms-3" ] [
raw "Cancel"
]
]
]
]
]
/// The list of current redirect rules
let redirectList (model: RedirectRule list) app = [
// Generate the detail for a redirect rule
let ruleDetail idx (rule: RedirectRule) =
let ruleId = $"rule_{idx}"
div [ _class "row mwl-table-detail"; _id ruleId ] [
div [ _class "col-5 no-wrap" ] [
txt rule.From; br []
small [] [
let ruleUrl = relUrl app $"admin/settings/redirect-rules/{idx}"
a [ _href ruleUrl; _hxTarget $"#{ruleId}"; _hxSwap $"{HxSwap.InnerHtml} show:#{ruleId}:top" ] [
raw "Edit"
]
if idx > 0 then
actionSpacer; a [ _href $"{ruleUrl}/up"; _hxPost $"{ruleUrl}/up" ] [ raw "Move Up" ]
if idx <> model.Length - 1 then
actionSpacer; a [ _href $"{ruleUrl}/down"; _hxPost $"{ruleUrl}/down" ] [ raw "Move Down" ]
actionSpacer
a [ _class "text-danger"; _href ruleUrl; _hxDelete ruleUrl
_hxConfirm "Are you sure you want to delete this redirect rule?" ] [
raw "Delete"
]
]
]
div [ _class "col-5" ] [ txt rule.To ]
div [ _class "col-2 text-center" ] [ yesOrNo rule.IsRegex ]
]
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
p [ _class "mb-3" ] [
a [ _href (relUrl app "admin/settings") ] [ raw "&laquo; Back to Settings" ]
]
div [ _class "container" ] [
p [] [
a [ _href (relUrl app "admin/settings/redirect-rules/-1"); _class "btn btn-primary btn-sm mb-3"
_hxTarget "#rule_new" ] [
raw "Add Redirect Rule"
]
]
if List.isEmpty model then
div [ _id "rule_new" ] [
p [ _class "text-muted text-center fst-italic" ] [
raw "This web log has no redirect rules defined"
]
]
else
div [ _class "container g-0" ] [
div [ _class "row mwl-table-heading" ] [
div [ _class "col-5" ] [ raw "From" ]
div [ _class "col-5" ] [ raw "To" ]
div [ _class "col-2 text-center" ] [ raw "RegEx?" ]
]
]
div [ _class "row mwl-table-detail"; _id "rule_new" ] []
form [ _method "post"; _class "container g-0"; _hxTarget "body" ] [
antiCsrf app; yield! List.mapi ruleDetail model
]
]
p [ _class "mt-3 text-muted fst-italic text-center" ] [
raw "This is an advanced feature; please "
a [ _href "https://bitbadger.solutions/open-source/myweblog/advanced.html#redirect-rules"
_target "_blank" ] [
raw "read and understand the documentation on this feature"
]
raw " before adding rules."
]
]
]
/// Edit a tag mapping
let tagMapEdit (model: EditTagMapModel) app = [
h5 [ _class "my-3" ] [ txt app.PageTitle ]
form [ _hxPost (relUrl app "admin/settings/tag-mapping/save"); _method "post"; _class "container"
_hxTarget "#tagList"; _hxSwap $"{HxSwap.OuterHtml} show:window:top" ] [
antiCsrf app
input [ _type "hidden"; _name "Id"; _value model.Id ]
div [ _class "row mb-3" ] [
div [ _class "col-6 col-lg-4 offset-lg-2" ] [
textField [ _autofocus; _required ] (nameof model.Tag) "Tag" model.Tag []
]
div [ _class "col-6 col-lg-4" ] [
textField [ _required ] (nameof model.UrlValue) "URL Value" model.UrlValue []
]
]
div [ _class "row mb-3" ] [
div [ _class "col text-center" ] [
saveButton; raw " &nbsp; "
a [ _href (relUrl app "admin/settings/tag-mappings"); _class "btn btn-sm btn-secondary ms-3" ] [
raw "Cancel"
]
]
]
]
]
/// Display a list of the web log's current tag mappings
let tagMapList (model: TagMap list) app =
let tagMapDetail (map: TagMap) =
let url = relUrl app $"admin/settings/tag-mapping/{map.Id}"
div [ _class "row mwl-table-detail"; _id $"tag_{map.Id}" ] [
div [ _class "col no-wrap" ] [
txt map.Tag; br []
small [] [
a [ _href $"{url}/edit"; _hxTarget $"#tag_{map.Id}"
_hxSwap $"{HxSwap.InnerHtml} show:#tag_{map.Id}:top" ] [
raw "Edit"
]; actionSpacer
a [ _href url; _hxDelete url; _class "text-danger"
_hxConfirm $"Are you sure you want to delete the mapping for “{map.Tag}”? This action cannot be undone." ] [
raw "Delete"
]
]
]
div [ _class "col" ] [ txt map.UrlValue ]
]
div [ _id "tagList"; _class "container" ] [
if List.isEmpty model then
div [ _id "tag_new" ] [
p [ _class "text-muted text-center fst-italic" ] [ raw "This web log has no tag mappings" ]
]
else
div [ _class "container g-0" ] [
div [ _class "row mwl-table-heading" ] [
div [ _class "col" ] [ raw "Tag" ]
div [ _class "col" ] [ raw "URL Value" ]
]
]
form [ _method "post"; _class "container g-0"; _hxTarget "#tagList"; _hxSwap HxSwap.OuterHtml ] [
antiCsrf app
div [ _class "row mwl-table-detail"; _id "tag_new" ] []
yield! List.map tagMapDetail model
]
]
|> List.singleton
/// The list of uploaded files for a web log
let uploadList (model: DisplayUpload seq) app = [
let webLogBase = $"upload/{app.WebLog.Slug}/"
let relativeBase = relUrl app $"upload/{app.WebLog.Slug}/"
let absoluteBase = app.WebLog.AbsoluteUrl(Permalink webLogBase)
let uploadDetail (upload: DisplayUpload) =
div [ _class "row mwl-table-detail" ] [
div [ _class "col-6" ] [
let badgeClass = if upload.Source = string Disk then "secondary" else "primary"
let pathAndName = $"{upload.Path}{upload.Name}"
span [ _class $"badge bg-{badgeClass} text-uppercase float-end mt-1" ] [ raw upload.Source ]
raw upload.Name; br []
small [] [
a [ _href $"{relativeBase}{pathAndName}"; _target "_blank" ] [ raw "View File" ]
actionSpacer; span [ _class "text-muted" ] [ raw "Copy " ]
a [ _href $"{absoluteBase}{pathAndName}"; _hxNoBoost
_onclick $"return Admin.copyText('{absoluteBase}{pathAndName}', this)" ] [
raw "Absolute"
]
span [ _class "text-muted" ] [ raw " | " ]
a [ _href $"{relativeBase}{pathAndName}"; _hxNoBoost
_onclick $"return Admin.copyText('{relativeBase}{pathAndName}', this)" ] [
raw "Relative"
]
if app.WebLog.ExtraPath <> "" then
span [ _class "text-muted" ] [ raw " | " ]
a [ _href $"{webLogBase}{pathAndName}"; _hxNoBoost
_onclick $"return Admin.copyText('/{webLogBase}{pathAndName}', this)" ] [
raw "For Post"
]
span [ _class "text-muted" ] [ raw " Link" ]
if app.IsWebLogAdmin then
actionSpacer
let deleteUrl =
if upload.Source = string "Disk" then $"admin/upload/disk/{pathAndName}"
else $"admin/upload/{upload.Id}"
|> relUrl app
a [ _href deleteUrl; _hxDelete deleteUrl; _class "text-danger"
_hxConfirm $"Are you sure you want to delete {upload.Name}? This action cannot be undone." ] [
raw "Delete"
]
]
]
div [ _class "col-3" ] [ raw upload.Path ]
div [ _class "col-3" ] [
match upload.UpdatedOn with
| Some updated -> updated.ToString("yyyy-MM-dd/h:mmtt").ToLowerInvariant()
| None -> "--"
|> raw
]
]
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
a [ _href (relUrl app "admin/upload/new"); _class "btn btn-primary btn-sm mb-3" ] [ raw "Upload a New File" ]
form [ _method "post"; _class "container"; _hxTarget "body" ] [
antiCsrf app
div [ _class "row" ] [
div [ _class "col text-center" ] [
em [ _class "text-muted" ] [ raw "Uploaded files served from" ]; br []; raw relativeBase
]
]
if Seq.isEmpty model then
div [ _class "row" ] [
div [ _class "col text-muted fst-italic text-center" ] [
br []; raw "This web log has uploaded files"
]
]
else
div [ _class "row mwl-table-heading" ] [
div [ _class "col-6" ] [ raw "File Name" ]
div [ _class "col-3" ] [ raw "Path" ]
div [ _class "col-3" ] [ raw "File Date/Time" ]
]
yield! model |> Seq.map uploadDetail
]
]
]
/// Form to upload a new file
let uploadNew app = [
h2 [ _class "my-3" ] [ raw app.PageTitle ]
article [] [
form [ _action (relUrl app "admin/upload/save"); _method "post"; _class "container"
_enctype "multipart/form-data"; _hxNoBoost ] [
antiCsrf app
div [ _class "row" ] [
div [ _class "col-12 col-md-6 pb-3" ] [
div [ _class "form-floating" ] [
input [ _type "file"; _id "file"; _name "File"; _class "form-control"; _placeholder "File"
_required ]
label [ _for "file" ] [ raw "File to Upload" ]
]
]
div [ _class "col-12 col-md-6 pb-3 d-flex align-self-center justify-content-around" ] [
div [ _class "text-center" ] [
raw "Destination"; br []
div [ _class "btn-group"; _roleGroup; _ariaLabel "Upload destination button group" ] [
input [ _type "radio"; _name "Destination"; _id "destination_db"; _class "btn-check"
_value (string Database); if app.WebLog.Uploads = Database then _checked ]
label [ _class "btn btn-outline-primary"; _for "destination_db" ] [ raw (string Database) ]
input [ _type "radio"; _name "Destination"; _id "destination_disk"; _class "btn-check"
_value (string Disk); if app.WebLog.Uploads= Disk then _checked ]
label [ _class "btn btn-outline-secondary"; _for "destination_disk" ] [ raw "Disk" ]
]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col text-center" ] [
button [ _type "submit"; _class "btn btn-primary" ] [ raw "Upload File" ]
]
]
]
]
]
/// Web log settings page
let webLogSettings
(model: SettingsModel) (themes: Theme list) (pages: Page list) (uploads: UploadDestination list)
(rss: EditRssModel) (app: AppViewContext) = [
let feedDetail (feed: CustomFeed) =
let source =
match feed.Source with
| Category (CategoryId catId) ->
app.Categories
|> Array.tryFind (fun cat -> cat.Id = catId)
|> Option.map _.Name
|> Option.defaultValue "--INVALID; DELETE THIS FEED--"
|> sprintf "Category: %s"
| Tag tag -> $"Tag: {tag}"
div [ _class "row mwl-table-detail" ] [
div [ _class "col-12 col-md-6" ] [
txt source
if Option.isSome feed.Podcast then
raw " &nbsp; "; span [ _class "badge bg-primary" ] [ raw "PODCAST" ]
br []
small [] [
let feedUrl = relUrl app $"admin/settings/rss/{feed.Id}"
a [ _href (relUrl app (string feed.Path)); _target "_blank" ] [ raw "View Feed" ]
actionSpacer
a [ _href $"{feedUrl}/edit" ] [ raw "Edit" ]; actionSpacer
a [ _href feedUrl; _hxDelete feedUrl; _class "text-danger"
_hxConfirm $"Are you sure you want to delete the custom RSS feed based on {feed.Source}? This action cannot be undone." ] [
raw "Delete"
]
]
]
div [ _class "col-12 col-md-6" ] [
small [ _class "d-md-none" ] [ raw "Served at "; txt (string feed.Path) ]
span [ _class "d-none d-md-inline" ] [ txt (string feed.Path) ]
]
]
h2 [ _class "my-3" ] [ txt app.WebLog.Name; raw " Settings" ]
article [] [
p [ _class "text-muted" ] [
raw "Go to: "; a [ _href "#users" ] [ raw "Users" ]; raw " &bull; "
a [ _href "#rss-settings" ] [ raw "RSS Settings" ]; raw " &bull; "
a [ _href "#tag-mappings" ] [ raw "Tag Mappings" ]; raw " &bull; "
a [ _href (relUrl app "admin/settings/redirect-rules") ] [ raw "Redirect Rules" ]
]
fieldset [ _class "container mb-3" ] [
legend [] [ raw "Web Log Settings" ]
form [ _action (relUrl app "admin/settings"); _method "post" ] [
antiCsrf app
div [ _class "container g-0" ] [
div [ _class "row" ] [
div [ _class "col-12 col-md-6 col-xl-4 pb-3" ] [
textField [ _required; _autofocus ] (nameof model.Name) "Name" model.Name []
]
div [ _class "col-12 col-md-6 col-xl-4 pb-3" ] [
textField [ _required ] (nameof model.Slug) "Slug" model.Slug [
span [ _class "form-text" ] [
span [ _class "badge rounded-pill bg-warning text-dark" ] [ raw "WARNING" ]
raw " changing this value may break links ("
a [ _href "https://bitbadger.solutions/open-source/myweblog/configuring.html#blog-settings"
_target "_blank" ] [
raw "more"
]; raw ")"
]
]
]
div [ _class "col-12 col-md-6 col-xl-4 pb-3" ] [
textField [] (nameof model.Subtitle) "Subtitle" model.Subtitle []
]
div [ _class "col-12 col-md-6 col-xl-4 offset-xl-1 pb-3" ] [
selectField [ _required ] (nameof model.ThemeId) "Theme" model.ThemeId themes
(fun t -> string t.Id) (fun t -> $"{t.Name} (v{t.Version})") []
]
div [ _class "col-12 col-md-6 offset-md-1 col-xl-4 offset-xl-0 pb-3" ] [
selectField [ _required ] (nameof model.DefaultPage) "Default Page" model.DefaultPage pages
(fun p -> string p.Id) (_.Title) []
]
div [ _class "col-12 col-md-4 col-xl-2 pb-3" ] [
numberField [ _required; _min "0"; _max "50" ] (nameof model.PostsPerPage) "Posts per Page"
(string model.PostsPerPage) []
]
]
div [ _class "row" ] [
div [ _class "col-12 col-md-4 col-xl-3 offset-xl-2 pb-3" ] [
textField [ _required ] (nameof model.TimeZone) "Time Zone" model.TimeZone []
]
div [ _class "col-12 col-md-4 col-xl-2" ] [
checkboxSwitch [] (nameof model.AutoHtmx) "Auto-Load htmx" model.AutoHtmx []
span [ _class "form-text fst-italic" ] [
a [ _href "https://htmx.org"; _target "_blank"; _relNoOpener ] [ raw "What is this?" ]
]
]
div [ _class "col-12 col-md-4 col-xl-3 pb-3" ] [
selectField [] (nameof model.Uploads) "Default Upload Destination" model.Uploads uploads
string string []
]
]
div [ _class "row pb-3" ] [
div [ _class "col text-center" ] [
button [ _type "submit"; _class "btn btn-primary" ] [ raw "Save Changes" ]
]
]
]
]
]
fieldset [ _id "users"; _class "container mb-3 pb-0" ] [
legend [] [ raw "Users" ]
span [ _hxGet (relUrl app "admin/settings/users"); _hxTrigger HxTrigger.Load; _hxSwap HxSwap.OuterHtml ] []
]
fieldset [ _id "rss-settings"; _class "container mb-3 pb-0" ] [
legend [] [ raw "RSS Settings" ]
form [ _action (relUrl app "admin/settings/rss"); _method "post"; _class "container g-0" ] [
antiCsrf app
div [ _class "row pb-3" ] [
div [ _class "col col-xl-8 offset-xl-2" ] [
fieldset [ _class "d-flex justify-content-evenly flex-row" ] [
legend [] [ raw "Feeds Enabled" ]
checkboxSwitch [] (nameof rss.IsFeedEnabled) "All Posts" rss.IsFeedEnabled []
checkboxSwitch [] (nameof rss.IsCategoryEnabled) "Posts by Category" rss.IsCategoryEnabled
[]
checkboxSwitch [] (nameof rss.IsTagEnabled) "Posts by Tag" rss.IsTagEnabled []
]
]
]
div [ _class "row" ] [
div [ _class "col-12 col-sm-6 col-md-3 col-xl-2 offset-xl-2 pb-3" ] [
textField [] (nameof rss.FeedName) "Feed File Name" rss.FeedName [
span [ _class "form-text" ] [ raw "Default is "; code [] [ raw "feed.xml" ] ]
]
]
div [ _class "col-12 col-sm-6 col-md-4 col-xl-2 pb-3" ] [
numberField [ _required; _min "0" ] (nameof rss.ItemsInFeed) "Items in Feed"
(string rss.ItemsInFeed) [
span [ _class "form-text" ] [
raw "Set to &ldquo;0&rdquo; to use &ldquo;Posts per Page&rdquo; setting ("
raw (string app.WebLog.PostsPerPage); raw ")"
]
]
]
div [ _class "col-12 col-md-5 col-xl-4 pb-3" ] [
textField [] (nameof rss.Copyright) "Copyright String" rss.Copyright [
span [ _class "form-text" ] [
raw "Can be a "
a [ _href "https://creativecommons.org/share-your-work/"; _target "_blank"
_relNoOpener ] [
raw "Creative Commons license string"
]
]
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col text-center" ] [
button [ _type "submit"; _class "btn btn-primary" ] [ raw "Save Changes" ]
]
]
]
fieldset [ _class "container mb-3 pb-0" ] [
legend [] [ raw "Custom Feeds" ]
a [ _class "btn btn-sm btn-secondary"; _href (relUrl app "admin/settings/rss/new/edit") ] [
raw "Add a New Custom Feed"
]
if app.WebLog.Rss.CustomFeeds.Length = 0 then
p [ _class "text-muted fst-italic text-center" ] [ raw "No custom feeds defined" ]
else
form [ _method "post"; _class "container g-0"; _hxTarget "body" ] [
antiCsrf app
div [ _class "row mwl-table-heading" ] [
div [ _class "col-12 col-md-6" ] [
span [ _class "d-md-none" ] [ raw "Feed" ]
span [ _class "d-none d-md-inline" ] [ raw "Source" ]
]
div [ _class "col-12 col-md-6 d-none d-md-inline-block" ] [ raw "Relative Path" ]
]
yield! app.WebLog.Rss.CustomFeeds |> List.map feedDetail
]
]
]
fieldset [ _id "tag-mappings"; _class "container mb-3 pb-0" ] [
legend [] [ raw "Tag Mappings" ]
a [ _href (relUrl app "admin/settings/tag-mapping/new/edit"); _class "btn btn-primary btn-sm mb-3"
_hxTarget "#tag_new" ] [
raw "Add a New Tag Mapping"
]
span [ _hxGet (relUrl app "admin/settings/tag-mappings"); _hxTrigger HxTrigger.Load
_hxSwap HxSwap.OuterHtml ] []
]
]
]

9
src/MyWebLog/appsettings.json
View File

@@ -1,8 +1,15 @@
{
"Generator": "myWebLog 2.0",
"Generator": "myWebLog 2.1",
"Logging": {
"LogLevel": {
"MyWebLog.Handlers": "Information"
}
},
"Kestrel": {
"Endpoints": {
"Http": {
"Url": "http://0.0.0.0:80"
}
}
}
}