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

Clean up database names (#21)

Browse Source 
- Moved user edit to "my info" (#19)
This commit is contained in:
Daniel J. Summers
2022-07-18 20:05:10 -04:00
parent 5fb3a73dcf
commit 7eaad4a076
36 changed files with 1993 additions and 1745 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
src/MyWebLog/Caches.fs
View File

@@ -67,13 +67,13 @@ module WebLogCache =
/// 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.filter (fun wl -> path.StartsWith wl.UrlBase)
|> List.sortByDescending (fun wl -> wl.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))
_cache <- webLog :: (_cache |> List.filter (fun wl -> wl.Id <> webLog.Id))
/// Fill the web log cache from the database
let fill (data : IData) = backgroundTask {
@@ -91,18 +91,18 @@ module PageListCache =
let private _cache = ConcurrentDictionary<string, DisplayPage[]> ()
/// Are there pages cached for this web log?
let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.urlBase
let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.UrlBase
/// Get the pages for the web log for this request
let get (ctx : HttpContext) = _cache[ctx.WebLog.urlBase]
let get (ctx : HttpContext) = _cache[ctx.WebLog.UrlBase]
/// Update the pages for the current web log
let update (ctx : HttpContext) = backgroundTask {
let webLog = ctx.WebLog
let! pages = ctx.Data.Page.FindListed webLog.id
_cache[webLog.urlBase] <-
let! pages = ctx.Data.Page.FindListed webLog.Id
_cache[webLog.UrlBase] <-
pages
|> List.map (fun pg -> DisplayPage.fromPage webLog { pg with text = "" })
|> List.map (fun pg -> DisplayPage.fromPage webLog { pg with Text = "" })
|> Array.ofList
}
@@ -116,15 +116,15 @@ module CategoryCache =
let private _cache = ConcurrentDictionary<string, DisplayCategory[]> ()
/// Are there categories cached for this web log?
let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.urlBase
let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.UrlBase
/// Get the categories for the web log for this request
let get (ctx : HttpContext) = _cache[ctx.WebLog.urlBase]
let get (ctx : HttpContext) = _cache[ctx.WebLog.UrlBase]
/// Update the cache with fresh data
let update (ctx : HttpContext) = backgroundTask {
let! cats = ctx.Data.Category.FindAllForView ctx.WebLog.id
_cache[ctx.WebLog.urlBase] <- cats
let! cats = ctx.Data.Category.FindAllForView ctx.WebLog.Id
_cache[ctx.WebLog.UrlBase] <- cats
}
@@ -149,10 +149,10 @@ module TemplateCache =
| false ->
match! data.Theme.FindById (ThemeId themeId) with
| Some theme ->
let mutable text = (theme.templates |> List.find (fun t -> t.name = templateName)).text
let mutable text = (theme.Templates |> List.find (fun t -> t.Name = templateName)).Text
while hasInclude.IsMatch text do
let child = hasInclude.Match text
let childText = (theme.templates |> List.find (fun t -> t.name = child.Groups[1].Value)).text
let childText = (theme.Templates |> List.find (fun t -> t.Name = child.Groups[1].Value)).Text
text <- text.Replace (child.Value, childText)
_cache[templatePath] <- Template.Parse (text, SyntaxCompatibility.DotLiquid22)
| None -> ()
@@ -179,14 +179,14 @@ module ThemeAssetCache =
/// Refresh the list of assets for the given theme
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)
_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 ()
for asset in assets do
let (ThemeAssetId (themeId, path)) = asset.id
let (ThemeAssetId (themeId, path)) = asset.Id
if not (_cache.ContainsKey themeId) then _cache[themeId] <- []
_cache[themeId] <- path :: _cache[themeId]
}

52
src/MyWebLog/DotLiquidBespoke.fs
View File

@@ -12,11 +12,13 @@ open MyWebLog.ViewModels
type Context with
/// Get the current web log from the DotLiquid context
member this.WebLog = this.Environments[0].["web_log"] :?> WebLog
member this.WebLog =
this.Environments[0].["web_log"] :?> WebLog
/// Does an asset exist for the current theme?
let assetExists fileName (webLog : WebLog) =
ThemeAssetCache.get (ThemeId webLog.themePath) |> List.exists (fun it -> it = fileName)
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) =
@@ -24,7 +26,7 @@ let permalink (ctx : Context) (item : obj) (linkFunc : WebLog -> Permalink -> st
| :? String as link -> Some link
| :? DisplayPage as page -> Some page.Permalink
| :? PostListItem as post -> Some post.Permalink
| :? DropProxy as proxy -> Option.ofObj proxy["permalink"] |> Option.map string
| :? DropProxy as proxy -> Option.ofObj proxy["Permalink"] |> Option.map string
| _ -> None
|> function
| Some link -> linkFunc ctx.WebLog (Permalink link)
@@ -42,7 +44,7 @@ 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
| :? DropProxy as proxy -> Option.ofObj proxy["Slug"] |> Option.map string
| _ -> None
|> function
| Some slug -> WebLog.relativeUrl ctx.WebLog (Permalink $"category/{slug}/")
@@ -54,7 +56,7 @@ 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
| :? DropProxy as proxy -> Option.ofObj proxy["Id"] |> Option.map string
| :? String as theId -> Some theId
| _ -> None
|> function
@@ -67,7 +69,7 @@ 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
| :? DropProxy as proxy -> Option.ofObj proxy["Id"] |> Option.map string
| :? String as theId -> Some theId
| _ -> None
|> function
@@ -89,13 +91,13 @@ type NavLinkFilter () =
text
"</a></li>"
}
|> Seq.fold (+) ""
|> 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/{ctx.WebLog.themePath}/{asset}")
WebLog.relativeUrl ctx.WebLog (Permalink $"themes/{ThemeId.toString ctx.WebLog.ThemeId}/{asset}")
/// Create various items in the page header based on the state of the page being generated
@@ -107,7 +109,7 @@ type PageHeadTag () =
// spacer
let s = " "
let getBool name =
context.Environments[0].[name] |> Option.ofObj |> Option.map Convert.ToBoolean |> Option.defaultValue false
defaultArg (context.Environments[0].[name] |> Option.ofObj |> Option.map Convert.ToBoolean) false
result.WriteLine $"""<meta name="generator" content="{context.Environments[0].["generator"]}">"""
@@ -123,17 +125,17 @@ type PageHeadTag () =
let relUrl = WebLog.relativeUrl webLog (Permalink url)
$"""{s}<link rel="alternate" type="application/rss+xml" title="{escTitle}" href="{relUrl}">"""
if webLog.rss.feedEnabled && getBool "is_home" then
result.WriteLine (feedLink webLog.name webLog.rss.feedName)
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}">"""
if webLog.rss.categoryEnabled && getBool "is_category_home" then
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.tagEnabled && getBool "is_tag_home" then
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
@@ -155,7 +157,7 @@ type PageFootTag () =
// spacer
let s = " "
if webLog.autoHtmx then
if webLog.AutoHtmx then
result.WriteLine $"{s}{RenderView.AsString.htmlNode Htmx.Script.minified}"
if assetExists "script.js" webLog then
@@ -172,9 +174,9 @@ type RelativeLinkFilter () =
type TagLinkFilter () =
static member TagLink (ctx : Context, tag : string) =
ctx.Environments[0].["tag_mappings"] :?> TagMap list
|> List.tryFind (fun it -> it.tag = tag)
|> List.tryFind (fun it -> it.Tag = tag)
|> function
| Some tagMap -> tagMap.urlValue
| Some tagMap -> tagMap.UrlValue
| None -> tag.Replace (" ", "+")
|> function tagUrl -> WebLog.relativeUrl ctx.WebLog (Permalink $"tag/{tagUrl}/")
@@ -201,8 +203,8 @@ type UserLinksTag () =
// (shorter than `{% assign item = list | where: "name", [name] | first %}{{ item.value }}`)
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
match items |> List.tryFind (fun it -> it.Name = name) with
| Some item -> item.Value
| None -> $"-- {name} not found --"
@@ -225,11 +227,11 @@ let register () =
typeof<CustomFeed>; typeof<Episode>; typeof<Episode option>; typeof<MetaItem>; typeof<Page>
typeof<RssOptions>; typeof<TagMap>; typeof<UploadDestination>; typeof<WebLog>
// View models
typeof<DashboardModel>; typeof<DisplayCategory>; typeof<DisplayCustomFeed>; typeof<DisplayPage>
typeof<DisplayRevision>; typeof<DisplayUpload>; typeof<EditCategoryModel>; typeof<EditCustomFeedModel>
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<DashboardModel>; typeof<DisplayCategory>; typeof<DisplayCustomFeed>; typeof<DisplayPage>
typeof<DisplayRevision>; typeof<DisplayUpload>; typeof<EditCategoryModel>; typeof<EditCustomFeedModel>
typeof<EditMyInfoModel>; typeof<EditPageModel>; typeof<EditPostModel>; typeof<EditRssModel>
typeof<EditTagMapModel>; typeof<LogOnModel>; typeof<ManagePermalinksModel>; typeof<ManageRevisionsModel>
typeof<PostDisplay>; typeof<PostListItem>; typeof<SettingsModel>; 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>

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

@@ -9,7 +9,7 @@ open MyWebLog.ViewModels
// GET /admin
let dashboard : 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)
@@ -30,7 +30,7 @@ let dashboard : HttpHandler = requireAccess Author >=> fun next ctx -> task {
TopLevelCategories = topCats.Result
}
|}
|> viewForTheme "admin" "dashboard" next ctx
|> adminView "dashboard" next ctx
}
// -- CATEGORIES --
@@ -44,8 +44,9 @@ let listCategories : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
web_log = ctx.WebLog
categories = CategoryCache.get ctx
|}
hash.Add ("category_list", catListTemplate.Render hash)
return! viewForTheme "admin" "category-list" next ctx hash
return!
addToHash "category_list" (catListTemplate.Render hash) hash
|> adminView "category-list" next ctx
}
// GET /admin/categories/bare
@@ -54,16 +55,16 @@ let listCategoriesBare : HttpHandler = requireAccess WebLogAdmin >=> fun next ct
categories = CategoryCache.get ctx
csrf = ctx.CsrfTokenSet
|}
|> bareForTheme "admin" "category-list-body" next ctx
|> adminBareView "category-list-body" next ctx
// GET /admin/category/{id}/edit
let editCategory catId : HttpHandler = requireAccess WebLogAdmin >=> 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
match! ctx.Data.Category.FindById (CategoryId catId) ctx.WebLog.Id with
| Some cat -> return Some ("Edit Category", cat)
| None -> return None
}
@@ -76,7 +77,7 @@ let editCategory catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ct
model = EditCategoryModel.fromCategory cat
categories = CategoryCache.get ctx
|}
|> bareForTheme "admin" "category-edit" next ctx
|> adminBareView "category-edit" next ctx
| None -> return! Error.notFound next ctx
}
@@ -86,16 +87,16 @@ let saveCategory : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> t
let! model = ctx.BindFormAsync<EditCategoryModel> ()
let category =
match model.CategoryId with
| "new" -> Task.FromResult (Some { Category.empty with id = CategoryId.create (); webLogId = ctx.WebLog.id })
| catId -> data.Category.FindById (CategoryId catId) ctx.WebLog.id
| "new" -> Task.FromResult (Some { Category.empty with Id = CategoryId.create (); WebLogId = ctx.WebLog.Id })
| catId -> data.Category.FindById (CategoryId catId) ctx.WebLog.Id
match! category with
| Some cat ->
let cat =
{ cat with
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)
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)
}
do! (match model.CategoryId with "new" -> data.Category.Add | _ -> data.Category.Update) cat
do! CategoryCache.update ctx
@@ -106,7 +107,7 @@ let saveCategory : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> t
// POST /admin/category/{id}/delete
let deleteCategory catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
match! ctx.Data.Category.Delete (CategoryId catId) ctx.WebLog.id with
match! ctx.Data.Category.Delete (CategoryId catId) ctx.WebLog.Id with
| true ->
do! CategoryCache.update ctx
do! addMessage ctx { UserMessage.success with Message = "Category deleted successfully" }
@@ -120,12 +121,12 @@ open Microsoft.AspNetCore.Http
/// Get the hash necessary to render the tag mapping list
let private tagMappingHash (ctx : HttpContext) = task {
let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.id
let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id
return Hash.FromAnonymousObject {|
csrf = ctx.CsrfTokenSet
web_log = ctx.WebLog
mappings = mappings
mapping_ids = mappings |> List.map (fun it -> { name = it.tag; value = TagMapId.toString it.id })
mapping_ids = mappings |> List.map (fun it -> { Name = it.Tag; Value = TagMapId.toString it.Id })
|}
}
@@ -136,30 +137,30 @@ let tagMappings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> ta
return!
addToHash "tag_mapping_list" (listTemplate.Render hash) hash
|> addToHash "page_title" "Tag Mappings"
|> viewForTheme "admin" "tag-mapping-list" next ctx
|> adminView "tag-mapping-list" next ctx
}
// GET /admin/settings/tag-mappings/bare
let tagMappingsBare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! hash = tagMappingHash ctx
return! bareForTheme "admin" "tag-mapping-list-body" next ctx hash
return! adminBareView "tag-mapping-list-body" next ctx hash
}
// GET /admin/settings/tag-mapping/{id}/edit
let editMapping tagMapId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let isNew = tagMapId = "new"
let tagMap =
if isNew then Task.FromResult (Some { TagMap.empty with id = TagMapId "new" })
else ctx.Data.TagMap.FindById (TagMapId tagMapId) ctx.WebLog.id
if isNew then Task.FromResult (Some { TagMap.empty with Id = TagMapId "new" })
else ctx.Data.TagMap.FindById (TagMapId tagMapId) ctx.WebLog.Id
match! tagMap with
| Some tm ->
return!
Hash.FromAnonymousObject {|
page_title = if isNew then "Add Tag Mapping" else $"Mapping for {tm.tag} Tag"
page_title = if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag"
csrf = ctx.CsrfTokenSet
model = EditTagMapModel.fromMapping tm
|}
|> bareForTheme "admin" "tag-mapping-edit" next ctx
|> adminBareView "tag-mapping-edit" next ctx
| None -> return! Error.notFound next ctx
}
@@ -169,11 +170,11 @@ let saveMapping : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> ta
let! model = ctx.BindFormAsync<EditTagMapModel> ()
let tagMap =
if model.IsNew then
Task.FromResult (Some { TagMap.empty with id = TagMapId.create (); webLogId = ctx.WebLog.id })
else data.TagMap.FindById (TagMapId model.Id) ctx.WebLog.id
Task.FromResult (Some { TagMap.empty with Id = TagMapId.create (); WebLogId = ctx.WebLog.Id })
else data.TagMap.FindById (TagMapId model.Id) ctx.WebLog.Id
match! tagMap with
| Some tm ->
do! data.TagMap.Save { tm with tag = model.Tag.ToLower (); urlValue = model.UrlValue.ToLower () }
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! tagMappingsBare next ctx
| None -> return! Error.notFound next ctx
@@ -181,7 +182,7 @@ let saveMapping : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> ta
// POST /admin/settings/tag-mapping/{id}/delete
let deleteMapping tagMapId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
match! ctx.Data.TagMap.Delete (TagMapId tagMapId) ctx.WebLog.id with
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! tagMappingsBare next ctx
@@ -201,7 +202,7 @@ let themeUpdatePage : HttpHandler = requireAccess Administrator >=> fun next ctx
page_title = "Upload Theme"
csrf = ctx.CsrfTokenSet
|}
|> viewForTheme "admin" "upload-theme" next ctx
|> adminView "upload-theme" next ctx
/// Update the name and version for a theme based on the version.txt file, if present
let private updateNameAndVersion (theme : Theme) (zip : ZipArchive) = backgroundTask {
@@ -211,17 +212,17 @@ let private updateNameAndVersion (theme : Theme) (zip : ZipArchive) = background
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 ThemeId.toString 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 () }
return { theme with Name = displayName; Version = version }
| None -> return { theme with Name = ThemeId.toString theme.Id; Version = now () }
}
/// Delete all theme assets, and remove templates from theme
let private checkForCleanLoad (theme : Theme) cleanLoad (data : IData) = backgroundTask {
if cleanLoad then
do! data.ThemeAsset.DeleteByTheme theme.id
return { theme with templates = [] }
do! data.ThemeAsset.DeleteByTheme theme.Id
return { theme with Templates = [] }
else return theme
}
@@ -233,13 +234,13 @@ let private updateTemplates (theme : Theme) (zip : ZipArchive) = backgroundTask
|> Seq.map (fun templateItem -> backgroundTask {
use templateFile = new StreamReader (templateItem.Open ())
let! template = templateFile.ReadToEndAsync ()
return { name = templateItem.Name.Replace (".liquid", ""); text = template }
return { Name = templateItem.Name.Replace (".liquid", ""); Text = template }
})
let! templates = Task.WhenAll tasks
return
templates
|> Array.fold (fun t template ->
{ t with templates = template :: (t.templates |> List.filter (fun it -> it.name <> template.name)) })
{ t with Templates = template :: (t.Templates |> List.filter (fun it -> it.Name <> template.Name)) })
theme
}
@@ -251,9 +252,9 @@ let private updateAssets themeId (zip : ZipArchive) (data : IData) = backgroundT
use stream = new MemoryStream ()
do! asset.Open().CopyToAsync stream
do! data.ThemeAsset.Save
{ id = ThemeAssetId (themeId, assetName)
updatedOn = asset.LastWriteTime.DateTime
data = stream.ToArray ()
{ Id = ThemeAssetId (themeId, assetName)
UpdatedOn = asset.LastWriteTime.DateTime
Data = stream.ToArray ()
}
}
@@ -269,7 +270,7 @@ let loadThemeFromZip themeName file clean (data : IData) = backgroundTask {
let! theme = backgroundTask {
match! data.Theme.FindById themeId with
| Some t -> return t
| None -> return { Theme.empty with id = themeId }
| None -> return { Theme.empty with Id = themeId }
}
let! theme = updateNameAndVersion theme zip
let! theme = checkForCleanLoad theme clean data
@@ -308,7 +309,7 @@ open System.Collections.Generic
// GET /admin/settings
let settings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data
let! allPages = data.Page.All ctx.WebLog.id
let! allPages = data.Page.All ctx.WebLog.Id
let! themes = data.Theme.All ()
return!
Hash.FromAnonymousObject {|
@@ -318,41 +319,41 @@ let settings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task
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))
|> List.sortBy (fun p -> p.Title.ToLower ())
|> List.map (fun p -> KeyValuePair.Create (PageId.toString p.Id, p.Title))
}
|> Array.ofSeq
themes =
themes
|> Seq.ofList
|> Seq.map (fun it -> KeyValuePair.Create (ThemeId.toString it.id, $"{it.name} (v{it.version})"))
|> Seq.map (fun it -> KeyValuePair.Create (ThemeId.toString it.Id, $"{it.Name} (v{it.Version})"))
|> Array.ofSeq
upload_values = [|
KeyValuePair.Create (UploadDestination.toString Database, "Database")
KeyValuePair.Create (UploadDestination.toString Disk, "Disk")
|]
|}
|> viewForTheme "admin" "settings" next ctx
|> adminView "settings" next ctx
}
// POST /admin/settings
let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data
let! model = ctx.BindFormAsync<SettingsModel> ()
match! data.WebLog.FindById ctx.WebLog.id with
match! data.WebLog.FindById ctx.WebLog.Id with
| Some webLog ->
let oldSlug = webLog.slug
let oldSlug = webLog.Slug
let webLog = model.update webLog
do! data.WebLog.UpdateSettings webLog
// Update cache
WebLogCache.set webLog
if oldSlug <> webLog.slug then
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))
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" }
return! redirectToGet "admin/settings" next ctx

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

@@ -26,22 +26,22 @@ type FeedType =
let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option =
let webLog = ctx.WebLog
let debug = debug "Feed" ctx
let name = $"/{webLog.rss.feedName}"
let postCount = defaultArg webLog.rss.itemsInFeed webLog.postsPerPage
let name = $"/{webLog.Rss.FeedName}"
let postCount = defaultArg webLog.Rss.ItemsInFeed webLog.PostsPerPage
debug (fun () -> $"Considering potential feed for {feedPath} (configured feed name {name})")
// Standard feed
match webLog.rss.feedEnabled && feedPath = name with
match webLog.Rss.IsFeedEnabled && feedPath = name with
| true ->
debug (fun () -> "Found standard feed")
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
match webLog.Rss.CustomFeeds
|> List.tryFind (fun it -> feedPath.EndsWith (Permalink.toString 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)
feed.Podcast |> Option.map (fun p -> p.ItemsInFeed) |> Option.defaultValue postCount)
| None ->
debug (fun () -> $"No matching feed found")
None
@@ -53,13 +53,13 @@ let private getFeedPosts ctx feedType =
getCategoryIds cat.Slug ctx
let data = ctx.Data
match feedType with
| StandardFeed _ -> data.Post.FindPageOfPublishedPosts ctx.WebLog.id 1
| CategoryFeed (catId, _) -> data.Post.FindPageOfCategorizedPosts ctx.WebLog.id (childIds catId) 1
| TagFeed (tag, _) -> data.Post.FindPageOfTaggedPosts ctx.WebLog.id tag 1
| StandardFeed _ -> data.Post.FindPageOfPublishedPosts ctx.WebLog.Id 1
| CategoryFeed (catId, _) -> data.Post.FindPageOfCategorizedPosts ctx.WebLog.Id (childIds catId) 1
| TagFeed (tag, _) -> data.Post.FindPageOfTaggedPosts ctx.WebLog.Id tag 1
| Custom (feed, _) ->
match feed.source with
| Category catId -> data.Post.FindPageOfCategorizedPosts ctx.WebLog.id (childIds catId) 1
| Tag tag -> data.Post.FindPageOfTaggedPosts ctx.WebLog.id tag 1
match feed.Source with
| Category catId -> data.Post.FindPageOfCategorizedPosts ctx.WebLog.Id (childIds catId) 1
| 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)*?>", "")
@@ -90,13 +90,13 @@ module private Namespace =
let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[]) (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 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,
Title = TextSyndicationContent.CreateHtmlContent post.title,
PublishDate = DateTimeOffset post.publishedOn.Value,
LastUpdatedTime = DateTimeOffset post.updatedOn,
Id = WebLog.absoluteUrl webLog post.Permalink,
Title = TextSyndicationContent.CreateHtmlContent post.Title,
PublishDate = DateTimeOffset post.PublishedOn.Value,
LastUpdatedTime = DateTimeOffset post.UpdatedOn,
Content = TextSyndicationContent.CreatePlaintextContent plainText)
item.AddPermalink (Uri item.Id)
@@ -104,25 +104,25 @@ let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[
let encoded =
let txt =
post.text
.Replace("src=\"/", $"src=\"{webLog.urlBase}/")
.Replace ("href=\"/", $"href=\"{webLog.urlBase}/")
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)
it
item.ElementExtensions.Add encoded
item.Authors.Add (SyndicationPerson (
Name = (authors |> List.find (fun a -> a.name = WebLogUserId.toString post.authorId)).value))
[ post.categoryIds
Name = (authors |> List.find (fun a -> a.Name = WebLogUserId.toString 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))
post.tags
post.Tags
|> List.map (fun tag ->
let urlTag =
match tagMaps |> List.tryFind (fun tm -> tm.tag = tag) with
| Some tm -> tm.urlValue
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)"))
]
@@ -137,19 +137,19 @@ let toAbsolute webLog (link : string) =
/// Add episode information to a podcast feed item
let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (post : Post) (item : SyndicationItem) =
let epMediaUrl =
match episode.media with
match episode.Media with
| link when link.StartsWith "http" -> link
| link when Option.isSome podcast.mediaBaseUrl -> $"{podcast.mediaBaseUrl.Value}{link}"
| link when Option.isSome podcast.MediaBaseUrl -> $"{podcast.MediaBaseUrl.Value}{link}"
| link -> WebLog.absoluteUrl webLog (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 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 xmlDoc = XmlDocument ()
let enclosure =
let it = xmlDoc.CreateElement "enclosure"
it.SetAttribute ("url", epMediaUrl)
it.SetAttribute ("length", string episode.length)
it.SetAttribute ("length", string episode.Length)
epMediaType |> Option.iter (fun typ -> it.SetAttribute ("type", typ))
it
let image =
@@ -159,18 +159,18 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po
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 ("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.duration
episode.Subtitle |> Option.iter (fun it -> item.ElementExtensions.Add ("subtitle", Namespace.iTunes, it))
episode.Duration
|> Option.iter (fun it -> item.ElementExtensions.Add ("duration", Namespace.iTunes, it.ToString """hh\:mm\:ss"""))
match episode.chapterFile with
match episode.ChapterFile with
| Some chapters ->
let url = toAbsolute webLog chapters
let typ =
match episode.chapterType with
match episode.ChapterType with
| Some mime -> Some mime
| None when chapters.EndsWith ".json" -> Some "application/json+chapters"
| None -> None
@@ -180,21 +180,21 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po
item.ElementExtensions.Add elt
| None -> ()
match episode.transcriptUrl with
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 ("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 -> ()
match episode.seasonNumber with
match episode.SeasonNumber with
| Some season ->
match episode.seasonDescription with
match episode.SeasonDescription with
| Some desc ->
let elt = xmlDoc.CreateElement ("podcast", "season", Namespace.podcast)
elt.SetAttribute ("name", desc)
@@ -203,9 +203,9 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po
| None -> item.ElementExtensions.Add ("season", Namespace.podcast, string season)
| None -> ()
match episode.episodeNumber with
match episode.EpisodeNumber with
| Some epNumber ->
match episode.episodeDescription with
match episode.EpisodeDescription with
| Some desc ->
let elt = xmlDoc.CreateElement ("podcast", "episode", Namespace.podcast)
elt.SetAttribute ("name", desc)
@@ -214,15 +214,15 @@ let private addEpisode webLog (podcast : PodcastOptions) (episode : Episode) (po
| None -> item.ElementExtensions.Add ("episode", Namespace.podcast, string epNumber)
| None -> ()
if post.metadata |> List.exists (fun it -> it.name = "chapter") then
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")
post.metadata
|> List.filter (fun it -> it.name = "chapter")
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))
TimeSpan.Parse (it.Value.Split(" ")[0]), it.Value.Substring (it.Value.IndexOf(" ") + 1))
|> List.sortBy fst
|> List.iter (fun chap ->
let chapter = xmlDoc.CreateElement ("psc", "chapter", Namespace.psc)
@@ -247,12 +247,12 @@ let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) =
child.InnerText <- value
elt
let podcast = Option.get feed.podcast
let feedUrl = WebLog.absoluteUrl webLog feed.path
let podcast = Option.get feed.Podcast
let feedUrl = WebLog.absoluteUrl webLog feed.Path
let imageUrl =
match podcast.imageUrl with
match podcast.ImageUrl with
| Permalink link when link.StartsWith "http" -> link
| Permalink _ -> WebLog.absoluteUrl webLog podcast.imageUrl
| Permalink _ -> WebLog.absoluteUrl webLog podcast.ImageUrl
let xmlDoc = XmlDocument ()
@@ -266,15 +266,15 @@ let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) =
let categorization =
let it = xmlDoc.CreateElement ("itunes", "category", Namespace.iTunes)
it.SetAttribute ("text", podcast.iTunesCategory)
podcast.iTunesSubcategory
it.SetAttribute ("text", podcast.AppleCategory)
podcast.AppleSubcategory
|> Option.iter (fun subCat ->
let subCatElt = xmlDoc.CreateElement ("itunes", "category", Namespace.iTunes)
subCatElt.SetAttribute ("text", subCat)
it.AppendChild subCatElt |> ignore)
it
let image =
[ "title", podcast.title
[ "title", podcast.Title
"url", imageUrl
"link", feedUrl
]
@@ -284,8 +284,8 @@ let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) =
it.SetAttribute ("href", imageUrl)
it
let owner =
[ "name", podcast.displayedAuthor
"email", podcast.email
[ "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))
@@ -300,62 +300,62 @@ 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))
podcast.fundingUrl
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))
podcast.FundingUrl
|> Option.iter (fun url ->
let funding = xmlDoc.CreateElement ("podcast", "funding", Namespace.podcast)
funding.SetAttribute ("url", toAbsolute webLog url)
funding.InnerText <- defaultArg podcast.fundingText "Support This Podcast"
funding.InnerText <- defaultArg podcast.FundingText "Support This Podcast"
rssFeed.ElementExtensions.Add funding)
podcast.guid
podcast.PodcastGuid
|> Option.iter (fun guid ->
rssFeed.ElementExtensions.Add ("guid", Namespace.podcast, guid.ToString().ToLowerInvariant ()))
podcast.medium
podcast.Medium
|> Option.iter (fun med -> rssFeed.ElementExtensions.Add ("medium", Namespace.podcast, PodcastMedium.toString 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)
| TagFeed (_, path) -> Permalink path[1..], withoutFeed path
| Custom (feed, _) ->
match feed.source with
match feed.Source with
| Category (CategoryId catId) ->
feed.path, Permalink $"category/{(CategoryCache.get ctx |> Array.find (fun c -> c.Id = catId)).Slug}"
| Tag tag -> feed.path, Permalink $"""tag/{tag.Replace(" ", "+")}/"""
feed.Path, Permalink $"category/{(CategoryCache.get ctx |> Array.find (fun c -> c.Id = catId)).Slug}"
| 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))
match feedType with
| StandardFeed _ ->
feed.Title <- cleanText None webLog.name
feed.Description <- cleanText webLog.subtitle webLog.name
feed.Title <- cleanText None webLog.Name
feed.Description <- cleanText webLog.Subtitle webLog.Name
| CategoryFeed (CategoryId catId, _) ->
let cat = cats |> Array.find (fun it -> it.Id = catId)
feed.Title <- cleanText None $"""{webLog.name} - "{stripHtml cat.Name}" Category"""
feed.Title <- cleanText None $"""{webLog.Name} - "{stripHtml cat.Name}" Category"""
feed.Description <- cleanText cat.Description $"""Posts categorized under "{cat.Name}" """
| TagFeed (tag, _) ->
feed.Title <- cleanText None $"""{webLog.name} - "{tag}" Tag"""
feed.Title <- cleanText None $"""{webLog.Name} - "{tag}" Tag"""
feed.Description <- cleanText None $"""Posts with the "{tag}" tag"""
| Custom (custom, _) ->
match custom.podcast with
match custom.Podcast with
| Some podcast ->
feed.Title <- cleanText None podcast.title
feed.Description <- cleanText podcast.subtitle podcast.title
feed.Title <- cleanText None podcast.Title
feed.Description <- cleanText podcast.Subtitle podcast.Title
| None ->
match custom.source with
match custom.Source with
| Category (CategoryId catId) ->
let cat = cats |> Array.find (fun it -> it.Id = catId)
feed.Title <- cleanText None $"""{webLog.name} - "{stripHtml cat.Name}" Category"""
feed.Title <- cleanText None $"""{webLog.Name} - "{stripHtml cat.Name}" Category"""
feed.Description <- cleanText cat.Description $"""Posts categorized under "{cat.Name}" """
| Tag tag ->
feed.Title <- cleanText None $"""{webLog.name} - "{tag}" Tag"""
feed.Title <- cleanText None $"""{webLog.Name} - "{tag}" Tag"""
feed.Description <- cleanText None $"""Posts with the "{tag}" tag"""
/// Create a feed with a known non-zero-length list of posts
@@ -365,15 +365,15 @@ let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backg
let! authors = getAuthors webLog posts data
let! tagMaps = getTagMappings webLog posts data
let cats = CategoryCache.get ctx
let podcast = match feedType with Custom (feed, _) when Option.isSome feed.podcast -> Some feed | _ -> None
let podcast = match feedType with Custom (feed, _) when Option.isSome feed.Podcast -> Some feed | _ -> None
let self, link = selfAndLink webLog feedType ctx
let toItem post =
let item = toFeedItem webLog authors cats tagMaps post
match podcast, post.episode with
| Some feed, Some episode -> addEpisode webLog (Option.get feed.podcast) episode post item
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} {Permalink.toString self}] \"{stripHtml post.Title}\" has no media"
item
| _ -> item
@@ -381,12 +381,12 @@ let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backg
addNamespace feed "content" Namespace.content
setTitleAndDescription feedType webLog cats feed
feed.LastUpdatedTime <- (List.head posts).updatedOn |> DateTimeOffset
feed.LastUpdatedTime <- (List.head posts).UpdatedOn |> DateTimeOffset
feed.Generator <- ctx.Generator
feed.Items <- posts |> Seq.ofList |> Seq.map toItem
feed.Language <- "en"
feed.Id <- WebLog.absoluteUrl webLog link
webLog.rss.copyright |> Option.iter (fun copy -> feed.Copyright <- TextSyndicationContent copy)
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)
@@ -419,24 +419,24 @@ open DotLiquid
// GET: /admin/settings/rss
let editSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
let feeds =
ctx.WebLog.rss.customFeeds
ctx.WebLog.Rss.CustomFeeds
|> List.map (DisplayCustomFeed.fromFeed (CategoryCache.get ctx))
|> Array.ofList
Hash.FromAnonymousObject {|
page_title = "RSS Settings"
csrf = ctx.CsrfTokenSet
model = EditRssModel.fromRssOptions ctx.WebLog.rss
model = EditRssModel.fromRssOptions ctx.WebLog.Rss
custom_feeds = feeds
|}
|> viewForTheme "admin" "rss-settings" next ctx
|> adminView "rss-settings" next ctx
// POST: /admin/settings/rss
let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data
let! model = ctx.BindFormAsync<EditRssModel> ()
match! data.WebLog.FindById ctx.WebLog.id with
match! data.WebLog.FindById ctx.WebLog.Id with
| Some webLog ->
let webLog = { webLog with rss = model.updateOptions webLog.rss }
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" }
@@ -448,8 +448,8 @@ 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" }
| _ -> ctx.WebLog.rss.customFeeds |> List.tryFind (fun f -> f.id = CustomFeedId feedId)
| "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 ->
Hash.FromAnonymousObject {|
@@ -468,30 +468,30 @@ let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next
KeyValuePair.Create (PodcastMedium.toString Blog, "Blog")
|]
|}
|> viewForTheme "admin" "custom-feed-edit" next ctx
|> adminView "custom-feed-edit" next ctx
| None -> Error.notFound next ctx
// POST: /admin/settings/rss/save
let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data
match! data.WebLog.FindById ctx.WebLog.id with
match! data.WebLog.FindById ctx.WebLog.Id with
| Some webLog ->
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 -> CustomFeedId.toString 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 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 } }
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
return! redirectToGet $"admin/settings/rss/{CustomFeedId.toString feed.Id}/edit" next ctx
| None -> return! Error.notFound next ctx
| None -> return! Error.notFound next ctx
}
@@ -499,15 +499,15 @@ let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
// POST /admin/settings/rss/{id}/delete
let deleteCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data
match! data.WebLog.FindById ctx.WebLog.id with
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
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)
Rss = {
webLog.Rss with
CustomFeeds = webLog.Rss.CustomFeeds |> List.filter (fun f -> f.Id <> customId)
}
}
do! data.WebLog.UpdateRssOptions webLog

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

@@ -58,7 +58,7 @@ open DotLiquid
/// 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) =
hash.Add (key, value)
if hash.ContainsKey key then hash[key] <- value else hash.Add (key, value)
hash
open System.Security.Claims
@@ -101,11 +101,11 @@ let isHtmx (ctx : HttpContext) =
ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh
/// Render a view for the specified theme, using the specified template, layout, and hash
let viewForTheme theme template next ctx (hash : Hash) = task {
if not (hash.ContainsKey "web_log") then
let viewForTheme themeId template next ctx (hash : Hash) = task {
if not (hash.ContainsKey "htmx_script") then
let! _ = populateHash hash ctx
()
let (ThemeId theme) = themeId
// NOTE: DotLiquid does not support {% render %} or {% include %} in its templates, so we will do a 2-pass render;
// the net effect is a "layout" capability similar to Razor or Pug
@@ -134,8 +134,9 @@ let messagesToHeaders (messages : UserMessage array) : HttpHandler =
|> Seq.reduce (>=>)
/// Render a bare view for the specified theme, using the specified template and hash
let bareForTheme theme template next ctx (hash : Hash) = task {
let bareForTheme themeId template next ctx (hash : Hash) = task {
let! hash = populateHash hash ctx
let (ThemeId theme) = themeId
if not (hash.ContainsKey "content") then
let! contentTemplate = TemplateCache.get theme template ctx.Data
@@ -151,9 +152,16 @@ let bareForTheme theme template next ctx (hash : Hash) = task {
/// Return a view for the web log's default theme
let themedView template next ctx hash = task {
let! hash = populateHash hash ctx
return! viewForTheme (hash["web_log"] :?> WebLog).themePath template next ctx hash
return! viewForTheme (hash["web_log"] :?> WebLog).ThemeId template next ctx hash
}
/// Display a view for the admin theme
let adminView template =
viewForTheme (ThemeId "admin") template
/// Display a bare view for the admin theme
let adminBareView template =
bareForTheme (ThemeId "admin") template
/// Redirect after doing some action; commits session and issues a temporary redirect
let redirectToGet url : HttpHandler = fun _ ctx -> task {
@@ -232,15 +240,15 @@ 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 {
match! ctx.Data.Theme.FindByIdWithoutText (ThemeId ctx.WebLog.themePath) with
match! ctx.Data.Theme.FindByIdWithoutText ctx.WebLog.ThemeId with
| Some theme ->
return seq {
KeyValuePair.Create ("", $"- Default (single-{typ}) -")
yield!
theme.templates
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.filter (fun it -> it.Name.EndsWith $"-{typ}" && it.Name <> $"single-{typ}")
|> Seq.map (fun it -> KeyValuePair.Create (it.Name, it.Name))
}
|> Array.ofSeq
| None -> return [| KeyValuePair.Create ("", $"- Default (single-{typ}) -") |]
@@ -249,17 +257,17 @@ let templatesForTheme (ctx : HttpContext) (typ : string) = backgroundTask {
/// Get all authors for a list of posts as metadata items
let getAuthors (webLog : WebLog) (posts : Post list) (data : IData) =
posts
|> List.map (fun p -> p.authorId)
|> List.map (fun p -> p.AuthorId)
|> List.distinct
|> data.WebLogUser.FindNames webLog.id
|> 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) =
posts
|> List.map (fun p -> p.tags)
|> List.map (fun p -> p.Tags)
|> List.concat
|> List.distinct
|> fun tags -> data.TagMap.FindMappingForTags tags webLog.id
|> fun tags -> data.TagMap.FindMappingForTags tags webLog.Id
/// Get all category IDs for the given slug (includes owned subcategories)
let getCategoryIds slug ctx =

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

@@ -9,7 +9,7 @@ open MyWebLog.ViewModels
// GET /admin/pages
// 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! pages = ctx.Data.Page.FindPageOfPages ctx.WebLog.Id pageNbr
return!
Hash.FromAnonymousObject {|
page_title = "Pages"
@@ -19,21 +19,21 @@ let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task {
prev_page = if pageNbr = 2 then "" else $"/page/{pageNbr - 1}"
next_page = $"/page/{pageNbr + 1}"
|}
|> viewForTheme "admin" "page-list" next ctx
|> adminView "page-list" 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
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some page -> return Some ("Edit Page", page)
| None -> return None
}
match result with
| Some (title, page) when canEdit page.authorId ctx ->
| Some (title, page) when canEdit page.AuthorId ctx ->
let model = EditPageModel.fromPage page
let! templates = templatesForTheme ctx "page"
return!
@@ -45,14 +45,14 @@ let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
|> Array.mapi (fun idx (name, value) -> [| string idx; name; value |])
templates = templates
|}
|> viewForTheme "admin" "page-edit" next ctx
|> adminView "page-edit" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/page/{id}/delete
let delete pgId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
match! ctx.Data.Page.Delete (PageId pgId) ctx.WebLog.id with
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" }
@@ -62,15 +62,15 @@ let delete pgId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> ta
// GET /admin/page/{id}/permalinks
let editPermalinks pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.id with
| Some pg when canEdit pg.authorId ctx ->
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg when canEdit pg.AuthorId ctx ->
return!
Hash.FromAnonymousObject {|
page_title = "Manage Prior Permalinks"
csrf = ctx.CsrfTokenSet
model = ManagePermalinksModel.fromPage pg
|}
|> viewForTheme "admin" "permalinks" next ctx
|> adminView "permalinks" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@@ -79,10 +79,10 @@ let editPermalinks pgId : HttpHandler = requireAccess Author >=> fun next ctx ->
let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task {
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 ->
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
match! ctx.Data.Page.UpdatePriorPermalinks pageId ctx.WebLog.Id links with
| true ->
do! addMessage ctx { UserMessage.success with Message = "Page permalinks saved successfully" }
return! redirectToGet $"admin/page/{model.Id}/permalinks" next ctx
@@ -93,15 +93,15 @@ let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task
// GET /admin/page/{id}/revisions
let editRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.id with
| Some pg when canEdit pg.authorId ctx ->
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg when canEdit pg.AuthorId ctx ->
return!
Hash.FromAnonymousObject {|
page_title = "Manage Page Revisions"
csrf = ctx.CsrfTokenSet
model = ManageRevisionsModel.fromPage ctx.WebLog pg
|}
|> viewForTheme "admin" "revisions" next ctx
|> adminView "revisions" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@@ -109,9 +109,9 @@ let editRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx ->
// GET /admin/page/{id}/revisions/purge
let purgeRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data
match! data.Page.FindFullById (PageId pgId) ctx.WebLog.id with
match! data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg ->
do! data.Page.Update { pg with revisions = [ List.head pg.revisions ] }
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
| None -> return! Error.notFound next ctx
@@ -121,22 +121,22 @@ open Microsoft.AspNetCore.Http
/// Find the page and the requested revision
let private findPageRevision pgId revDate (ctx : HttpContext) = task {
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.id with
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg ->
let asOf = parseToUtc revDate
return Some pg, pg.revisions |> List.tryFind (fun r -> r.asOf = asOf)
return Some pg, pg.Revisions |> List.tryFind (fun r -> r.AsOf = asOf)
| None -> return None, None
}
// GET /admin/page/{id}/revision/{revision-date}/preview
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 ->
| Some pg, Some rev when canEdit pg.AuthorId ctx ->
return!
Hash.FromAnonymousObject {|
content = $"""<div class="mwl-revision-preview mb-3">{MarkupText.toHtml rev.text}</div>"""
content = $"""<div class="mwl-revision-preview mb-3">{MarkupText.toHtml rev.Text}</div>"""
|}
|> bareForTheme "admin" "" next ctx
|> adminBareView "" next ctx
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
@@ -147,11 +147,11 @@ open System
// POST /admin/page/{id}/revision/{revision-date}/restore
let restoreRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPageRevision pgId revDate ctx with
| Some pg, Some rev when canEdit pg.authorId ctx ->
| Some pg, Some rev when canEdit pg.AuthorId ctx ->
do! ctx.Data.Page.Update
{ pg with
revisions = { rev with asOf = DateTime.UtcNow }
:: (pg.revisions |> List.filter (fun r -> r.asOf <> rev.asOf))
Revisions = { rev with AsOf = DateTime.UtcNow }
:: (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
@@ -163,10 +163,10 @@ let restoreRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun
// POST /admin/page/{id}/revision/{revision-date}/delete
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) }
| 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! bareForTheme "admin" "" next ctx (Hash.FromAnonymousObject {| content = "" |})
return! adminBareView "" next ctx (Hash.FromAnonymousObject {| content = "" |})
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
@@ -187,43 +187,43 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
Task.FromResult (
Some
{ Page.empty with
id = PageId.create ()
webLogId = ctx.WebLog.id
authorId = ctx.UserId
publishedOn = now
Id = PageId.create ()
WebLogId = ctx.WebLog.Id
AuthorId = ctx.UserId
PublishedOn = now
})
| pgId -> data.Page.FindFullById (PageId pgId) ctx.WebLog.id
| pgId -> data.Page.FindFullById (PageId pgId) ctx.WebLog.Id
match! pg with
| Some page when canEdit page.authorId ctx ->
let updateList = page.showInPageList <> model.IsShownInPageList
let revision = { asOf = now; text = MarkupText.parse $"{model.Source}: {model.Text}" }
| Some page when canEdit page.AuthorId ctx ->
let updateList = page.IsInPageList <> model.IsShownInPageList
let revision = { AsOf = now; Text = MarkupText.parse $"{model.Source}: {model.Text}" }
// Detect a permalink change, and add the prior one to the prior list
let page =
match Permalink.toString page.permalink with
match Permalink.toString page.Permalink with
| "" -> page
| link when link = model.Permalink -> page
| _ -> { page with priorPermalinks = page.permalink :: page.priorPermalinks }
| _ -> { page with PriorPermalinks = page.Permalink :: page.PriorPermalinks }
let page =
{ page with
title = model.Title
permalink = Permalink model.Permalink
updatedOn = now
showInPageList = model.IsShownInPageList
template = match model.Template with "" -> None | tmpl -> Some tmpl
text = MarkupText.toHtml revision.text
metadata = Seq.zip model.MetaNames model.MetaValues
Title = model.Title
Permalink = Permalink model.Permalink
UpdatedOn = now
IsInPageList = model.IsShownInPageList
Template = match model.Template with "" -> None | tmpl -> Some tmpl
Text = MarkupText.toHtml revision.Text
Metadata = Seq.zip model.MetaNames model.MetaValues
|> Seq.filter (fun it -> fst it > "")
|> Seq.map (fun it -> { name = fst it; value = snd it })
|> Seq.sortBy (fun it -> $"{it.name.ToLower ()} {it.value.ToLower ()}")
|> Seq.map (fun it -> { Name = fst it; Value = snd it })
|> Seq.sortBy (fun it -> $"{it.Name.ToLower ()} {it.Value.ToLower ()}")
|> List.ofSeq
revisions = match page.revisions |> List.tryHead with
| Some r when r.text = revision.text -> page.revisions
| _ -> revision :: page.revisions
Revisions = match page.Revisions |> List.tryHead with
| Some r when r.Text = revision.Text -> page.Revisions
| _ -> revision :: page.Revisions
}
do! (if model.PageId = "new" then data.Page.Add else data.Page.Update) page
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
return! redirectToGet $"admin/page/{PageId.toString page.Id}/edit" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}

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

@@ -10,10 +10,10 @@ let private parseSlugAndPage webLog (slugAndPage : string seq) =
let fullPath = slugAndPage |> Seq.head
let slugPath = slugAndPage |> Seq.skip 1 |> Seq.head
let slugs, isFeed =
let feedName = $"/{webLog.rss.feedName}"
let feedName = $"/{webLog.Rss.FeedName}"
let notBlank = Array.filter (fun it -> it <> "")
if ( (webLog.rss.categoryEnabled && fullPath.StartsWith "/category/")
|| (webLog.rss.tagEnabled && fullPath.StartsWith "/tag/" ))
if ( (webLog.Rss.IsCategoryEnabled && fullPath.StartsWith "/category/")
|| (webLog.Rss.IsTagEnabled && fullPath.StartsWith "/tag/" ))
&& slugPath.EndsWith feedName then
notBlank (slugPath.Replace(feedName, "").Split "/"), true
else notBlank (slugPath.Split "/"), false
@@ -54,14 +54,14 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage ctx (da
match listType with
| SinglePost ->
let post = List.head posts
let dateTime = defaultArg post.publishedOn post.updatedOn
data.Post.FindSurroundingPosts webLog.id dateTime
let dateTime = defaultArg post.PublishedOn post.UpdatedOn
data.Post.FindSurroundingPosts webLog.Id dateTime
| _ -> 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 p -> Permalink.toString p.Permalink)
| _, 1 -> None
| PostList, 2 when webLog.defaultPage = "posts" -> Some ""
| PostList, 2 when webLog.DefaultPage = "posts" -> Some ""
| PostList, _ -> relUrl $"page/{pageNbr - 1}"
| CategoryList, 2 -> relUrl $"category/{url}/"
| CategoryList, _ -> relUrl $"category/{url}/page/{pageNbr - 1}"
@@ -71,7 +71,7 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage ctx (da
| 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 p -> Permalink.toString p.Permalink)
| _, false -> None
| PostList, true -> relUrl $"page/{pageNbr + 1}"
| CategoryList, true -> relUrl $"category/{url}/page/{pageNbr + 1}"
@@ -82,9 +82,9 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage ctx (da
Authors = authors
Subtitle = None
NewerLink = newerLink
NewerName = newerPost |> Option.map (fun p -> p.title)
NewerName = newerPost |> Option.map (fun p -> p.Title)
OlderLink = olderLink
OlderName = olderPost |> Option.map (fun p -> p.title)
OlderName = olderPost |> Option.map (fun p -> p.Title)
}
return Hash.FromAnonymousObject {|
model = model
@@ -98,17 +98,17 @@ open Giraffe
// GET /page/{pageNbr}
let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
let count = ctx.WebLog.postsPerPage
let count = ctx.WebLog.PostsPerPage
let data = ctx.Data
let! posts = data.Post.FindPageOfPublishedPosts ctx.WebLog.id pageNbr count
let! posts = data.Post.FindPageOfPublishedPosts ctx.WebLog.Id pageNbr count
let! hash = preparePostList ctx.WebLog posts PostList "" pageNbr count ctx data
let title =
match pageNbr, ctx.WebLog.defaultPage with
match pageNbr, ctx.WebLog.DefaultPage with
| 1, "posts" -> None
| _, "posts" -> Some $"Page {pageNbr}"
| _, _ -> Some $"Page {pageNbr} &laquo; Posts"
match title with Some ttl -> hash.Add ("page_title", ttl) | None -> ()
if pageNbr = 1 && ctx.WebLog.defaultPage = "posts" then hash.Add ("is_home", true)
if pageNbr = 1 && ctx.WebLog.DefaultPage = "posts" then hash.Add ("is_home", true)
return! themedView "index" next ctx hash
}
@@ -125,14 +125,14 @@ let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task {
| Some pageNbr, slug, isFeed ->
match CategoryCache.get ctx |> Array.tryFind (fun cat -> cat.Slug = slug) with
| Some cat when isFeed ->
return! Feed.generate (Feed.CategoryFeed ((CategoryId cat.Id), $"category/{slug}/{webLog.rss.feedName}"))
(defaultArg webLog.rss.itemsInFeed webLog.postsPerPage) next ctx
return! Feed.generate (Feed.CategoryFeed ((CategoryId cat.Id), $"category/{slug}/{webLog.Rss.FeedName}"))
(defaultArg webLog.Rss.ItemsInFeed webLog.PostsPerPage) next ctx
| Some cat ->
// Category pages include posts in subcategories
match! data.Post.FindPageOfCategorizedPosts webLog.id (getCategoryIds slug ctx) pageNbr webLog.postsPerPage
match! data.Post.FindPageOfCategorizedPosts webLog.Id (getCategoryIds slug ctx) pageNbr webLog.PostsPerPage
with
| posts when List.length posts > 0 ->
let! hash = preparePostList webLog posts CategoryList cat.Slug pageNbr webLog.postsPerPage ctx data
let! hash = preparePostList webLog posts CategoryList cat.Slug pageNbr webLog.PostsPerPage ctx data
let pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
return!
addToHash "page_title" $"{cat.Name}: Category Archive{pgTitle}" hash
@@ -157,17 +157,17 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
| Some pageNbr, rawTag, isFeed ->
let urlTag = HttpUtility.UrlDecode rawTag
let! tag = backgroundTask {
match! data.TagMap.FindByUrlValue urlTag webLog.id with
| Some m -> return m.tag
match! data.TagMap.FindByUrlValue urlTag webLog.Id with
| Some m -> return m.Tag
| None -> return urlTag
}
if isFeed then
return! Feed.generate (Feed.TagFeed (tag, $"tag/{rawTag}/{webLog.rss.feedName}"))
(defaultArg webLog.rss.itemsInFeed webLog.postsPerPage) next ctx
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
match! data.Post.FindPageOfTaggedPosts webLog.Id tag pageNbr webLog.PostsPerPage with
| posts when List.length posts > 0 ->
let! hash = preparePostList webLog posts TagList rawTag pageNbr webLog.postsPerPage ctx data
let! hash = preparePostList webLog posts TagList rawTag pageNbr webLog.PostsPerPage ctx data
let pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
return!
addToHash "page_title" $"Posts Tagged &ldquo;{tag}&rdquo;{pgTitle}" hash
@@ -178,7 +178,7 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
// Other systems use hyphens for spaces; redirect if this is an old tag link
| _ ->
let spacedTag = tag.Replace ("-", " ")
match! data.Post.FindPageOfTaggedPosts webLog.id spacedTag pageNbr 1 with
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!
@@ -192,19 +192,19 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
// GET /
let home : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog
match webLog.defaultPage with
match webLog.DefaultPage with
| "posts" -> return! pageOfPosts 1 next ctx
| pageId ->
match! ctx.Data.Page.FindById (PageId pageId) webLog.id with
match! ctx.Data.Page.FindById (PageId pageId) webLog.Id with
| Some page ->
return!
Hash.FromAnonymousObject {|
page_title = page.title
page_title = page.Title
page = DisplayPage.fromPage webLog page
categories = CategoryCache.get ctx
is_home = true
|}
|> themedView (defaultArg page.template "single-page") next ctx
|> themedView (defaultArg page.Template "single-page") next ctx
| None -> return! Error.notFound next ctx
}
@@ -212,12 +212,12 @@ let home : HttpHandler = fun next ctx -> task {
// 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! posts = data.Post.FindPageOfPosts ctx.WebLog.Id pageNbr 25
let! hash = preparePostList ctx.WebLog posts AdminList "" pageNbr 25 ctx data
return!
addToHash "page_title" "Posts" hash
|> addToHash "csrf" ctx.CsrfTokenSet
|> viewForTheme "admin" "post-list" next ctx
|> adminView "post-list" next ctx
}
// GET /admin/post/{id}/edit
@@ -225,15 +225,15 @@ 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
match! data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post -> return Some ("Edit Post", post)
| None -> return None
}
match result with
| Some (title, post) when canEdit post.authorId ctx ->
let! cats = data.Category.FindAllForView ctx.WebLog.id
| Some (title, post) when canEdit post.AuthorId ctx ->
let! cats = data.Category.FindAllForView ctx.WebLog.Id
let! templates = templatesForTheme ctx "post"
let model = EditPostModel.fromPost ctx.WebLog post
return!
@@ -252,14 +252,14 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
KeyValuePair.Create (ExplicitRating.toString Clean, "Clean")
|]
|}
|> viewForTheme "admin" "post-edit" next ctx
|> adminView "post-edit" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/post/{id}/delete
let delete postId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
match! ctx.Data.Post.Delete (PostId postId) ctx.WebLog.id with
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
@@ -267,15 +267,15 @@ let delete postId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
// GET /admin/post/{id}/permalinks
let editPermalinks postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.id with
| Some post when canEdit post.authorId ctx ->
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post when canEdit post.AuthorId ctx ->
return!
Hash.FromAnonymousObject {|
page_title = "Manage Prior Permalinks"
csrf = ctx.CsrfTokenSet
model = ManagePermalinksModel.fromPost post
|}
|> viewForTheme "admin" "permalinks" next ctx
|> adminView "permalinks" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@@ -284,10 +284,10 @@ let editPermalinks postId : HttpHandler = requireAccess Author >=> fun next ctx
let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task {
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 ->
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
match! ctx.Data.Post.UpdatePriorPermalinks postId ctx.WebLog.Id links with
| true ->
do! addMessage ctx { UserMessage.success with Message = "Post permalinks saved successfully" }
return! redirectToGet $"admin/post/{model.Id}/permalinks" next ctx
@@ -298,15 +298,15 @@ let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task
// GET /admin/post/{id}/revisions
let editRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.id with
| Some post when canEdit post.authorId ctx ->
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post when canEdit post.AuthorId ctx ->
return!
Hash.FromAnonymousObject {|
page_title = "Manage Post Revisions"
csrf = ctx.CsrfTokenSet
model = ManageRevisionsModel.fromPost ctx.WebLog post
|}
|> viewForTheme "admin" "revisions" next ctx
|> adminView "revisions" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@@ -314,9 +314,9 @@ let editRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx -
// GET /admin/post/{id}/revisions/purge
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 ] }
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
| Some _ -> return! Error.notAuthorized next ctx
@@ -327,22 +327,22 @@ open Microsoft.AspNetCore.Http
/// Find the post and the requested revision
let private findPostRevision postId revDate (ctx : HttpContext) = task {
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.id with
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post ->
let asOf = parseToUtc revDate
return Some post, post.revisions |> List.tryFind (fun r -> r.asOf = asOf)
return Some post, post.Revisions |> List.tryFind (fun r -> r.AsOf = asOf)
| None -> return None, None
}
// GET /admin/post/{id}/revision/{revision-date}/preview
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 ->
| Some post, Some rev when canEdit post.AuthorId ctx ->
return!
Hash.FromAnonymousObject {|
content = $"""<div class="mwl-revision-preview mb-3">{MarkupText.toHtml rev.text}</div>"""
content = $"""<div class="mwl-revision-preview mb-3">{MarkupText.toHtml rev.Text}</div>"""
|}
|> bareForTheme "admin" "" next ctx
|> adminBareView "" next ctx
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
@@ -351,11 +351,11 @@ let previewRevision (postId, revDate) : HttpHandler = requireAccess Author >=> f
// POST /admin/post/{id}/revision/{revision-date}/restore
let restoreRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPostRevision postId revDate ctx with
| Some post, Some rev when canEdit post.authorId ctx ->
| Some post, Some rev when canEdit post.AuthorId ctx ->
do! ctx.Data.Post.Update
{ post with
revisions = { rev with asOf = DateTime.UtcNow }
:: (post.revisions |> List.filter (fun r -> r.asOf <> rev.asOf))
Revisions = { rev with AsOf = DateTime.UtcNow }
:: (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
@@ -367,10 +367,10 @@ let restoreRevision (postId, revDate) : HttpHandler = requireAccess Author >=> f
// POST /admin/post/{id}/revision/{revision-date}/delete
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) }
| 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! bareForTheme "admin" "" next ctx (Hash.FromAnonymousObject {| content = "" |})
return! adminBareView "" next ctx (Hash.FromAnonymousObject {| content = "" |})
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
@@ -388,43 +388,43 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
Task.FromResult (
Some
{ Post.empty with
id = PostId.create ()
webLogId = ctx.WebLog.id
authorId = ctx.UserId
Id = PostId.create ()
WebLogId = ctx.WebLog.Id
AuthorId = ctx.UserId
})
else data.Post.FindFullById (PostId model.PostId) ctx.WebLog.id
else data.Post.FindFullById (PostId model.PostId) ctx.WebLog.Id
match! tryPost with
| Some post when canEdit post.authorId ctx ->
let priorCats = post.categoryIds
let revision = { asOf = now; text = MarkupText.parse $"{model.Source}: {model.Text}" }
| Some post when canEdit post.AuthorId ctx ->
let priorCats = post.CategoryIds
let revision = { AsOf = now; Text = MarkupText.parse $"{model.Source}: {model.Text}" }
// Detect a permalink change, and add the prior one to the prior list
let post =
match Permalink.toString post.permalink with
match Permalink.toString post.Permalink with
| "" -> post
| link when link = model.Permalink -> post
| _ -> { post with priorPermalinks = post.permalink :: post.priorPermalinks }
let post = model.updatePost post revision now
| _ -> { post with PriorPermalinks = post.Permalink :: post.PriorPermalinks }
let post = model.UpdatePost post revision now
let post =
if model.SetPublished then
let dt = parseToUtc (model.PubOverride.Value.ToString "o")
if model.SetUpdated then
{ post with
publishedOn = Some dt
updatedOn = dt
revisions = [ { (List.head post.revisions) with asOf = dt } ]
PublishedOn = Some dt
UpdatedOn = dt
Revisions = [ { (List.head post.Revisions) with AsOf = dt } ]
}
else { post with publishedOn = Some dt }
else { post with PublishedOn = Some dt }
else post
do! (if model.PostId = "new" then data.Post.Add else data.Post.Update) post
// If the post was published or its categories changed, refresh the category cache
if model.DoPublish
|| not (priorCats
|> List.append post.categoryIds
|> List.append post.CategoryIds
|> 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
return! redirectToGet $"admin/post/{PostId.toString post.Id}/edit" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}

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

@@ -27,25 +27,25 @@ module CatchAll =
if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.empty)
let permalink = Permalink (textLink.Substring 1)
// Current post
match data.Post.FindByPermalink permalink webLog.id |> await with
match data.Post.FindByPermalink permalink webLog.Id |> await with
| Some post ->
debug (fun () -> "Found post by permalink")
let model = Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 ctx data |> await
model.Add ("page_title", post.title)
yield fun next ctx -> themedView (defaultArg post.template "single-post") next ctx model
model.Add ("page_title", post.Title)
yield fun next ctx -> themedView (defaultArg post.Template "single-post") next ctx model
| None -> ()
// Current page
match data.Page.FindByPermalink permalink webLog.id |> await with
match data.Page.FindByPermalink permalink webLog.Id |> await with
| Some page ->
debug (fun () -> "Found page by permalink")
yield fun next ctx ->
Hash.FromAnonymousObject {|
page_title = page.title
page_title = page.Title
page = DisplayPage.fromPage webLog page
categories = CategoryCache.get ctx
is_page = true
|}
|> themedView (defaultArg page.template "single-page") next ctx
|> themedView (defaultArg page.Template "single-page") next ctx
| None -> ()
// RSS feed
match Feed.deriveFeedType ctx textLink with
@@ -56,25 +56,25 @@ module CatchAll =
// Post differing only by trailing slash
let altLink =
Permalink (if textLink.EndsWith "/" then textLink[1..textLink.Length - 2] else $"{textLink[1..]}/")
match data.Post.FindByPermalink altLink webLog.id |> await with
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 webLog post.Permalink)
| None -> ()
// Page differing only by trailing slash
match data.Page.FindByPermalink altLink webLog.id |> await with
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 webLog page.Permalink)
| None -> ()
// Prior post
match data.Post.FindCurrentPermalink [ permalink; altLink ] webLog.id |> await with
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)
| None -> ()
// Prior page
match data.Page.FindCurrentPermalink [ permalink; altLink ] webLog.id |> await with
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)
@@ -95,9 +95,9 @@ module Asset =
let path = urlParts |> Seq.skip 1 |> Seq.head
match! ctx.Data.ThemeAsset.FindById (ThemeAssetId.ofString path) with
| Some asset ->
match Upload.checkModified asset.updatedOn ctx with
match Upload.checkModified asset.UpdatedOn ctx with
| Some threeOhFour -> return! threeOhFour next ctx
| None -> return! Upload.sendFile asset.updatedOn path asset.data next ctx
| None -> return! Upload.sendFile asset.UpdatedOn path asset.Data next ctx
| None -> return! Error.notFound next ctx
}
@@ -148,7 +148,9 @@ let router : HttpHandler = choose [
route "s" >=> Upload.list
route "/new" >=> Upload.showNew
])
route "/user/edit" >=> User.edit
subRoute "/user" (choose [
route "/my-info" >=> User.myInfo
])
]
POST >=> validateCsrf >=> choose [
subRoute "/category" (choose [
@@ -189,7 +191,9 @@ let router : HttpHandler = choose [
routexp "/delete/(.*)" Upload.deleteFromDisk
routef "/%s/delete" Upload.deleteFromDb
])
route "/user/save" >=> User.save
subRoute "/user" (choose [
route "/my-info" >=> User.saveMyInfo
])
]
])
GET_HEAD >=> routexp "/category/(.*)" Post.pageOfCategorizedPosts

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

@@ -58,18 +58,18 @@ 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
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..])
if File.Exists fileName then
return! streamFile true fileName None None next ctx
else
let path = String.Join ('/', Array.skip 1 parts)
match! ctx.Data.Upload.FindByPath path webLog.id with
match! ctx.Data.Upload.FindByPath path webLog.Id with
| Some upload ->
match checkModified upload.updatedOn ctx with
match checkModified upload.UpdatedOn ctx with
| Some threeOhFour -> return! threeOhFour next ctx
| None -> return! sendFile upload.updatedOn path upload.data next ctx
| None -> return! sendFile upload.UpdatedOn path upload.Data next ctx
| None -> return! Error.notFound next ctx
else
return! Error.notFound next ctx
@@ -87,9 +87,9 @@ let makeSlug it = ((Regex """\s+""").Replace ((Regex "[^A-z0-9 ]").Replace (it,
// 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! 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)
|> Seq.map (fun file ->
@@ -122,7 +122,7 @@ let list : HttpHandler = requireAccess Author >=> fun next ctx -> task {
csrf = ctx.CsrfTokenSet
files = allFiles
|}
|> viewForTheme "admin" "upload-list" next ctx
|> adminView "upload-list" next ctx
}
// GET /admin/upload/new
@@ -130,9 +130,9 @@ let showNew : HttpHandler = requireAccess Author >=> fun next ctx ->
Hash.FromAnonymousObject {|
page_title = "Upload a File"
csrf = ctx.CsrfTokenSet
destination = UploadDestination.toString ctx.WebLog.uploads
destination = UploadDestination.toString ctx.WebLog.Uploads
|}
|> viewForTheme "admin" "upload-new" next ctx
|> adminView "upload-new" next ctx
/// Redirect to the upload list
@@ -155,15 +155,15 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
use stream = new MemoryStream ()
do! upload.CopyToAsync stream
let file =
{ id = UploadId.create ()
webLogId = ctx.WebLog.id
path = Permalink $"{year}/{month}/{fileName}"
updatedOn = DateTime.UtcNow
data = stream.ToArray ()
{ Id = UploadId.create ()
WebLogId = ctx.WebLog.Id
Path = Permalink $"{year}/{month}/{fileName}"
UpdatedOn = DateTime.UtcNow
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)
do! upload.CopyToAsync stream
@@ -176,7 +176,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
// POST /admin/upload/{id}/delete
let deleteFromDb upId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
match! ctx.Data.Upload.Delete (UploadId upId) ctx.WebLog.id with
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
@@ -188,7 +188,7 @@ 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)
@@ -197,7 +197,7 @@ let removeEmptyDirectories (webLog : WebLog) (filePath : string) =
// POST /admin/upload/delete/{**path}
let deleteFromDisk urlParts : HttpHandler = requireAccess WebLogAdmin >=> 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

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

@@ -27,7 +27,7 @@ let logOn returnUrl : HttpHandler = fun next ctx ->
csrf = ctx.CsrfTokenSet
model = { LogOnModel.empty with ReturnTo = returnTo }
|}
|> viewForTheme "admin" "log-on" next ctx
|> adminView "log-on" next ctx
open System.Security.Claims
@@ -38,21 +38,21 @@ open Microsoft.AspNetCore.Authentication.Cookies
let doLogOn : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<LogOnModel> ()
let data = ctx.Data
match! data.WebLogUser.FindByEmail model.EmailAddress ctx.WebLog.id with
| Some user when user.passwordHash = hashedPassword model.Password user.userName user.salt ->
match! data.WebLogUser.FindByEmail model.EmailAddress ctx.WebLog.Id with
| Some user when user.PasswordHash = hashedPassword model.Password user.Email user.Salt ->
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, WebLogUserId.toString user.Id)
Claim (ClaimTypes.Name, $"{user.FirstName} {user.LastName}")
Claim (ClaimTypes.GivenName, user.PreferredName)
Claim (ClaimTypes.Role, AccessLevel.toString user.AccessLevel)
}
let identity = ClaimsIdentity (claims, CookieAuthenticationDefaults.AuthenticationScheme)
do! ctx.SignInAsync (identity.AuthenticationType, ClaimsPrincipal identity,
AuthenticationProperties (IssuedUtc = DateTimeOffset.UtcNow))
do! data.WebLogUser.SetLastSeen user.id user.webLogId
do! data.WebLogUser.SetLastSeen user.Id user.WebLogId
do! addMessage ctx
{ UserMessage.success with Message = $"Logged on successfully | Welcome to {ctx.WebLog.name}!" }
{ UserMessage.success with Message = $"Logged on successfully | Welcome to {ctx.WebLog.Name}!" }
return!
match model.ReturnTo with
| Some url -> redirectTo false url next ctx
@@ -69,49 +69,52 @@ let logOff : HttpHandler = fun next ctx -> task {
return! redirectToGet "" next ctx
}
/// Display the user edit page, with information possibly filled in
let private showEdit (hash : Hash) : HttpHandler = fun next ctx ->
addToHash "page_title" "Edit Your Information" hash
|> addToHash "csrf" ctx.CsrfTokenSet
|> viewForTheme "admin" "user-edit" next ctx
/// Display the user "my info" page, with information possibly filled in
let private showMyInfo (user : WebLogUser) (hash : Hash) : HttpHandler = fun next ctx ->
addToHash "page_title" "Edit Your Information" hash
|> addToHash "csrf" ctx.CsrfTokenSet
|> addToHash "access_level" (AccessLevel.toString user.AccessLevel)
|> addToHash "created_on" (WebLog.localTime ctx.WebLog user.CreatedOn)
|> addToHash "last_seen_on" (WebLog.localTime ctx.WebLog (defaultArg user.LastSeenOn DateTime.UnixEpoch))
|> adminView "my-info" next ctx
// GET /admin/user/edit
let edit : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.WebLogUser.FindById ctx.UserId ctx.WebLog.id with
| Some user -> return! showEdit (Hash.FromAnonymousObject {| model = EditUserModel.fromUser user |}) next ctx
// GET /admin/user/my-info
let myInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with
| Some user -> return! showMyInfo user (Hash.FromAnonymousObject {| model = EditMyInfoModel.fromUser user |}) next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/user/save
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditUserModel> ()
if model.NewPassword = model.NewPasswordConfirm then
let data = ctx.Data
match! data.WebLogUser.FindById ctx.UserId ctx.WebLog.id with
| Some user ->
// POST /admin/user/my-info
let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditMyInfoModel> ()
let data = ctx.Data
match! data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with
| Some user ->
if model.NewPassword = model.NewPasswordConfirm then
let pw, salt =
if model.NewPassword = "" then
user.passwordHash, user.salt
user.PasswordHash, user.Salt
else
let newSalt = Guid.NewGuid ()
hashedPassword model.NewPassword user.userName newSalt, newSalt
hashedPassword model.NewPassword user.Email newSalt, newSalt
let user =
{ user with
firstName = model.FirstName
lastName = model.LastName
preferredName = model.PreferredName
passwordHash = pw
salt = salt
FirstName = model.FirstName
LastName = model.LastName
PreferredName = model.PreferredName
PasswordHash = pw
Salt = salt
}
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" }
return! redirectToGet "admin/user/edit" next ctx
| None -> return! Error.notFound next ctx
else
do! addMessage ctx { UserMessage.error with Message = "Passwords did not match; no updates made" }
return! showEdit (Hash.FromAnonymousObject {|
model = { model with NewPassword = ""; NewPasswordConfirm = "" }
|}) next ctx
return! redirectToGet "admin/user/my-info" next ctx
else
do! addMessage ctx { UserMessage.error with Message = "Passwords did not match; no updates made" }
return! showMyInfo user (Hash.FromAnonymousObject {|
model = { model with NewPassword = ""; NewPasswordConfirm = "" }
|}) next ctx
| None -> return! Error.notFound next ctx
}

274
src/MyWebLog/Maintenance.fs
View File

@@ -32,12 +32,12 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
do! data.WebLog.Add
{ WebLog.empty with
id = webLogId
name = args[2]
slug = slug
urlBase = args[1]
defaultPage = PageId.toString homePageId
timeZone = timeZone
Id = webLogId
Name = args[2]
Slug = slug
UrlBase = args[1]
DefaultPage = PageId.toString homePageId
TimeZone = timeZone
}
// Create the admin user
@@ -46,32 +46,32 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
do! data.WebLogUser.Add
{ WebLogUser.empty with
id = userId
webLogId = webLogId
userName = args[3]
firstName = "Admin"
lastName = "User"
preferredName = "Admin"
passwordHash = Handlers.User.hashedPassword args[4] args[3] salt
salt = salt
accessLevel = accessLevel
createdOn = now
Id = userId
WebLogId = webLogId
Email = args[3]
FirstName = "Admin"
LastName = "User"
PreferredName = "Admin"
PasswordHash = Handlers.User.hashedPassword args[4] args[3] salt
Salt = salt
AccessLevel = accessLevel
CreatedOn = now
}
// Create the default home page
do! data.Page.Add
{ Page.empty with
id = homePageId
webLogId = webLogId
authorId = userId
title = "Welcome to myWebLog!"
permalink = Permalink "welcome-to-myweblog.html"
publishedOn = now
updatedOn = now
text = "<p>This is your default home page.</p>"
revisions = [
{ asOf = now
text = Html "<p>This is your default home page.</p>"
Id = homePageId
WebLogId = webLogId
AuthorId = userId
Title = "Welcome to myWebLog!"
Permalink = Permalink "welcome-to-myweblog.html"
PublishedOn = now
UpdatedOn = now
Text = "<p>This is your default home page.</p>"
Revisions = [
{ AsOf = now
Text = Html "<p>This is your default home page.</p>"
}
]
}
@@ -107,11 +107,11 @@ let private importPriorPermalinks urlBase file (sp : IServiceProvider) = task {
Permalink parts[0], Permalink parts[1])
for old, current in mapping do
match! data.Post.FindByPermalink current webLog.id with
match! data.Post.FindByPermalink current webLog.Id with
| Some post ->
let! withLinks = data.Post.FindFullById post.id post.webLogId
let! _ = data.Post.UpdatePriorPermalinks post.id post.webLogId
(old :: withLinks.Value.priorPermalinks)
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 "Done!"
@@ -160,93 +160,93 @@ 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 : DateTime
UpdatedOn : DateTime
/// 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) =
{ id = asset.id
updatedOn = asset.updatedOn
data = Convert.ToBase64String asset.data
{ Id = asset.Id
UpdatedOn = asset.UpdatedOn
Data = Convert.ToBase64String asset.Data
}
/// Create a theme asset from an encoded theme asset
static member fromEncoded (encoded : EncodedAsset) : ThemeAsset =
{ id = encoded.id
updatedOn = encoded.updatedOn
data = Convert.FromBase64String encoded.data
static member toAsset (encoded : EncodedAsset) : ThemeAsset =
{ Id = encoded.Id
UpdatedOn = encoded.UpdatedOn
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 : DateTime
UpdatedOn : DateTime
/// 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 =
{ id = upload.id
webLogId = upload.webLogId
path = upload.path
updatedOn = upload.updatedOn
data = Convert.ToBase64String upload.data
{ Id = upload.Id
WebLogId = upload.WebLogId
Path = upload.Path
UpdatedOn = upload.UpdatedOn
Data = Convert.ToBase64String upload.Data
}
/// Create an uploaded file from an encoded uploaded file
static member fromEncoded (encoded : EncodedUpload) : Upload =
{ id = encoded.id
webLogId = encoded.webLogId
path = encoded.path
updatedOn = encoded.updatedOn
data = Convert.FromBase64String encoded.data
static member toUpload (encoded : EncodedUpload) : Upload =
{ Id = encoded.Id
WebLogId = encoded.WebLogId
Path = encoded.Path
UpdatedOn = encoded.UpdatedOn
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 (uses RethinkDB data implementation's JSON converters)
@@ -259,21 +259,21 @@ module Backup =
/// Display statistics for a backup archive
let private displayStats (msg : string) (webLog : WebLog) archive =
let userCount = List.length archive.users
let assetCount = List.length archive.assets
let categoryCount = List.length archive.categories
let tagMapCount = List.length archive.tagMappings
let pageCount = List.length archive.pages
let postCount = List.length archive.posts
let uploadCount = List.length archive.uploads
let userCount = List.length archive.Users
let assetCount = List.length archive.Assets
let categoryCount = List.length archive.Categories
let tagMapCount = List.length archive.TagMappings
let pageCount = List.length archive.Pages
let postCount = List.length archive.Posts
let uploadCount = List.length archive.Uploads
// Create a pluralized output based on the count
let plural count ifOne ifMany =
if count = 1 then ifOne else ifMany
printfn ""
printfn $"""{msg.Replace ("<>NAME<>", webLog.name)}"""
printfn $""" - The theme "{archive.theme.name}" with {assetCount} asset{plural assetCount "" "s"}"""
printfn $"""{msg.Replace ("<>NAME<>", webLog.Name)}"""
printfn $""" - The theme "{archive.Theme.Name}" with {assetCount} asset{plural assetCount "" "s"}"""
printfn $""" - {userCount} user{plural userCount "" "s"}"""
printfn $""" - {categoryCount} categor{plural categoryCount "y" "ies"}"""
printfn $""" - {tagMapCount} tag mapping{plural tagMapCount "" "s"}"""
@@ -284,39 +284,37 @@ module Backup =
/// Create a backup archive
let private createBackup webLog (fileName : string) prettyOutput (data : IData) = task {
// Create the data structure
let themeId = ThemeId webLog.themePath
printfn "- Exporting theme..."
let! theme = data.Theme.FindById themeId
let! assets = data.ThemeAsset.FindByThemeWithData themeId
let! theme = data.Theme.FindById webLog.ThemeId
let! assets = data.ThemeAsset.FindByThemeWithData webLog.ThemeId
printfn "- Exporting users..."
let! users = data.WebLogUser.FindByWebLog webLog.id
let! users = data.WebLogUser.FindByWebLog webLog.Id
printfn "- Exporting categories and tag mappings..."
let! categories = data.Category.FindByWebLog webLog.id
let! tagMaps = data.TagMap.FindByWebLog webLog.id
let! categories = data.Category.FindByWebLog webLog.Id
let! tagMaps = data.TagMap.FindByWebLog webLog.Id
printfn "- Exporting pages..."
let! pages = data.Page.FindFullByWebLog webLog.id
let! pages = data.Page.FindFullByWebLog webLog.Id
printfn "- Exporting posts..."
let! posts = data.Post.FindFullByWebLog webLog.id
let! posts = data.Post.FindFullByWebLog webLog.Id
printfn "- Exporting uploads..."
let! uploads = data.Upload.FindByWebLogWithData webLog.id
let! uploads = data.Upload.FindByWebLogWithData webLog.Id
printfn "- Writing archive..."
let archive = {
webLog = webLog
users = users
theme = Option.get theme
assets = assets |> List.map EncodedAsset.fromAsset
categories = categories
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
WebLog = webLog
Users = users
Theme = Option.get theme
Assets = assets |> List.map EncodedAsset.fromAsset
Categories = categories
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
}
// Write the structure to the backup file
@@ -331,83 +329,83 @@ module Backup =
let private doRestore archive newUrlBase (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 } }
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 } }
| 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 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 }
users = archive.users
|> List.map (fun u -> { u with id = newUserIds[u.id]; webLogId = newWebLogId })
categories = archive.categories
|> List.map (fun c -> { c with id = newCatIds[c.id]; webLogId = newWebLogId })
tagMappings = archive.tagMappings
|> List.map (fun tm -> { tm with id = newMapIds[tm.id]; webLogId = newWebLogId })
pages = archive.pages
WebLog = { archive.WebLog with Id = newWebLogId; UrlBase = Option.get newUrlBase }
Users = archive.Users
|> List.map (fun u -> { u with Id = newUserIds[u.Id]; WebLogId = newWebLogId })
Categories = archive.Categories
|> List.map (fun c -> { c with Id = newCatIds[c.Id]; WebLogId = newWebLogId })
TagMappings = archive.TagMappings
|> List.map (fun tm -> { tm with Id = newMapIds[tm.Id]; WebLogId = newWebLogId })
Pages = archive.Pages
|> List.map (fun page ->
{ page with
id = newPageIds[page.id]
webLogId = newWebLogId
authorId = newUserIds[page.authorId]
Id = newPageIds[page.Id]
WebLogId = newWebLogId
AuthorId = newUserIds[page.AuthorId]
})
posts = archive.posts
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])
Id = newPostIds[post.Id]
WebLogId = newWebLogId
AuthorId = newUserIds[post.AuthorId]
CategoryIds = post.CategoryIds |> List.map (fun c -> newCatIds[c])
})
uploads = archive.uploads
|> List.map (fun u -> { u with id = newUpIds[u.id]; webLogId = newWebLogId })
Uploads = archive.Uploads
|> 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 }
WebLog = { archive.WebLog with UrlBase = defaultArg newUrlBase archive.WebLog.UrlBase }
}
}
// Restore theme and assets (one at a time, as assets can be large)
printfn ""
printfn "- Importing theme..."
do! data.Theme.Save restore.theme
let! _ = restore.assets |> List.map (EncodedAsset.fromEncoded >> data.ThemeAsset.Save) |> Task.WhenAll
do! data.Theme.Save restore.Theme
let! _ = restore.Assets |> List.map (EncodedAsset.toAsset >> data.ThemeAsset.Save) |> Task.WhenAll
// Restore web log data
printfn "- Restoring web log..."
do! data.WebLog.Add restore.webLog
do! data.WebLog.Add restore.WebLog
printfn "- Restoring users..."
do! data.WebLogUser.Restore restore.users
do! data.WebLogUser.Restore restore.Users
printfn "- Restoring categories and tag mappings..."
do! data.TagMap.Restore restore.tagMappings
do! data.Category.Restore restore.categories
do! data.TagMap.Restore restore.TagMappings
do! data.Category.Restore restore.Categories
printfn "- Restoring pages..."
do! data.Page.Restore restore.pages
do! data.Page.Restore restore.Pages
printfn "- Restoring posts..."
do! data.Post.Restore restore.posts
do! data.Post.Restore restore.Posts
// TODO: comments not yet implemented
printfn "- Restoring uploads..."
do! data.Upload.Restore (restore.uploads |> List.map EncodedUpload.fromEncoded)
do! data.Upload.Restore (restore.Uploads |> List.map EncodedUpload.toUpload)
displayStats "Restored for <>NAME<>:" restore.webLog restore
displayStats "Restored for <>NAME<>:" restore.WebLog restore
}
/// Decide whether to restore a backup
@@ -431,7 +429,7 @@ module Backup =
if doOverwrite then
do! doRestore archive newUrlBase data
else
printfn $"{archive.webLog.name} backup restoration canceled"
printfn $"{archive.WebLog.Name} backup restoration canceled"
}
/// Generate a backup archive
@@ -442,7 +440,7 @@ module Backup =
| Some webLog ->
let fileName =
if args.Length = 2 || (args.Length = 3 && args[2] = "pretty") then
$"{webLog.slug}.json"
$"{webLog.Slug}.json"
elif args[2].EndsWith ".json" then
args[2]
else
@@ -473,11 +471,11 @@ module Backup =
let private doUserUpgrade urlBase email (data : IData) = task {
match! data.WebLog.FindByHost urlBase with
| Some webLog ->
match! data.WebLogUser.FindByEmail email webLog.id with
match! data.WebLogUser.FindByEmail email webLog.Id with
| Some user ->
match user.accessLevel with
match user.AccessLevel with
| WebLogAdmin ->
do! data.WebLogUser.Update { user with accessLevel = Administrator }
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"
| None -> eprintfn $"ERROR: no user {email} found at {urlBase}"

2
src/MyWebLog/Program.fs
View File

@@ -15,7 +15,7 @@ type WebLogMiddleware (next : RequestDelegate, log : ILogger<WebLogMiddleware>)
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 {WebLogId.toString 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