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

Add user created and last seen on (#19)

Browse Source 
- Updated view models / interfaces per F# naming guidelines
This commit is contained in:
Daniel J. Summers
2022-07-17 23:10:30 -04:00
parent e0a03bfca9
commit 5fb3a73dcf
39 changed files with 1234 additions and 1203 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
src/MyWebLog/Caches.fs
View File

@@ -77,7 +77,7 @@ module WebLogCache =
/// Fill the web log cache from the database
let fill (data : IData) = backgroundTask {
let! webLogs = data.WebLog.all ()
let! webLogs = data.WebLog.All ()
_cache <- webLogs
}
@@ -99,7 +99,7 @@ module PageListCache =
/// 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
let! pages = ctx.Data.Page.FindListed webLog.id
_cache[webLog.urlBase] <-
pages
|> List.map (fun pg -> DisplayPage.fromPage webLog { pg with text = "" })
@@ -123,7 +123,7 @@ module CategoryCache =
/// Update the cache with fresh data
let update (ctx : HttpContext) = backgroundTask {
let! cats = ctx.Data.Category.findAllForView ctx.WebLog.id
let! cats = ctx.Data.Category.FindAllForView ctx.WebLog.id
_cache[ctx.WebLog.urlBase] <- cats
}
@@ -147,7 +147,7 @@ module TemplateCache =
match _cache.ContainsKey templatePath with
| true -> ()
| false ->
match! data.Theme.findById (ThemeId themeId) with
match! data.Theme.FindById (ThemeId themeId) with
| Some theme ->
let mutable text = (theme.templates |> List.find (fun t -> t.name = templateName)).text
while hasInclude.IsMatch text do
@@ -178,13 +178,13 @@ module ThemeAssetCache =
/// Refresh the list of assets for the given theme
let refreshTheme themeId (data : IData) = backgroundTask {
let! assets = data.ThemeAsset.findByTheme themeId
let! assets = data.ThemeAsset.FindByTheme themeId
_cache[themeId] <- assets |> List.map (fun a -> match a.id with ThemeAssetId (_, path) -> path)
}
/// Fill the theme asset cache
let fill (data : IData) = backgroundTask {
let! assets = data.ThemeAsset.all ()
let! assets = data.ThemeAsset.All ()
for asset in assets do
let (ThemeAssetId (themeId, path)) = asset.id
if not (_cache.ContainsKey themeId) then _cache[themeId] <- []

47
src/MyWebLog/DotLiquidBespoke.fs
View File

@@ -8,9 +8,11 @@ open DotLiquid
open Giraffe.ViewEngine
open MyWebLog.ViewModels
/// Get the current web log from the DotLiquid context
let webLog (ctx : Context) =
ctx.Environments[0].["web_log"] :?> WebLog
/// Extensions on the DotLiquid Context object
type Context with
/// Get the current web log from the DotLiquid context
member this.WebLog = this.Environments[0].["web_log"] :?> WebLog
/// Does an asset exist for the current theme?
let assetExists fileName (webLog : WebLog) =
@@ -20,12 +22,12 @@ let assetExists fileName (webLog : WebLog) =
let permalink (ctx : Context) (item : obj) (linkFunc : WebLog -> Permalink -> string) =
match item with
| :? String as link -> Some link
| :? DisplayPage as page -> Some page.permalink
| :? PostListItem as post -> Some post.permalink
| :? DisplayPage as page -> Some page.Permalink
| :? PostListItem as post -> Some post.Permalink
| :? DropProxy as proxy -> Option.ofObj proxy["permalink"] |> Option.map string
| _ -> None
|> function
| Some link -> linkFunc (webLog ctx) (Permalink link)
| Some link -> linkFunc ctx.WebLog (Permalink link)
| None -> $"alert('unknown item type {item.GetType().Name}')"
@@ -39,11 +41,11 @@ type AbsoluteLinkFilter () =
type CategoryLinkFilter () =
static member CategoryLink (ctx : Context, catObj : obj) =
match catObj with
| :? DisplayCategory as cat -> Some cat.slug
| :? DisplayCategory as cat -> Some cat.Slug
| :? DropProxy as proxy -> Option.ofObj proxy["slug"] |> Option.map string
| _ -> None
|> function
| Some slug -> WebLog.relativeUrl (webLog ctx) (Permalink $"category/{slug}/")
| Some slug -> WebLog.relativeUrl ctx.WebLog (Permalink $"category/{slug}/")
| None -> $"alert('unknown category object type {catObj.GetType().Name}')"
@@ -51,12 +53,12 @@ type CategoryLinkFilter () =
type EditPageLinkFilter () =
static member EditPageLink (ctx : Context, pageObj : obj) =
match pageObj with
| :? DisplayPage as page -> Some page.id
| :? DisplayPage as page -> Some page.Id
| :? DropProxy as proxy -> Option.ofObj proxy["id"] |> Option.map string
| :? String as theId -> Some theId
| _ -> None
|> function
| Some pageId -> WebLog.relativeUrl (webLog ctx) (Permalink $"admin/page/{pageId}/edit")
| Some pageId -> WebLog.relativeUrl ctx.WebLog (Permalink $"admin/page/{pageId}/edit")
| None -> $"alert('unknown page object type {pageObj.GetType().Name}')"
@@ -64,26 +66,25 @@ type EditPageLinkFilter () =
type EditPostLinkFilter () =
static member EditPostLink (ctx : Context, postObj : obj) =
match postObj with
| :? PostListItem as post -> Some post.id
| :? PostListItem as post -> Some post.Id
| :? DropProxy as proxy -> Option.ofObj proxy["id"] |> Option.map string
| :? String as theId -> Some theId
| _ -> None
|> function
| Some postId -> WebLog.relativeUrl (webLog ctx) (Permalink $"admin/post/{postId}/edit")
| Some postId -> WebLog.relativeUrl ctx.WebLog (Permalink $"admin/post/{postId}/edit")
| None -> $"alert('unknown post object type {postObj.GetType().Name}')"
/// A filter to generate nav links, highlighting the active link (exact match)
type NavLinkFilter () =
static member NavLink (ctx : Context, url : string, text : string) =
let webLog = webLog ctx
let _, path = WebLog.hostAndPath webLog
let _, path = WebLog.hostAndPath ctx.WebLog
let path = if path = "" then path else $"{path.Substring 1}/"
seq {
"<li class=\"nav-item\"><a class=\"nav-link"
if (string ctx.Environments[0].["current_page"]).StartsWith $"{path}{url}" then " active"
"\" href=\""
WebLog.relativeUrl webLog (Permalink url)
WebLog.relativeUrl ctx.WebLog (Permalink url)
"\">"
text
"</a></li>"
@@ -94,8 +95,7 @@ type NavLinkFilter () =
/// A filter to generate a link for theme asset (image, stylesheet, script, etc.)
type ThemeAssetFilter () =
static member ThemeAsset (ctx : Context, asset : string) =
let webLog = webLog ctx
WebLog.relativeUrl webLog (Permalink $"themes/{webLog.themePath}/{asset}")
WebLog.relativeUrl ctx.WebLog (Permalink $"themes/{ctx.WebLog.themePath}/{asset}")
/// Create various items in the page header based on the state of the page being generated
@@ -103,7 +103,7 @@ type PageHeadTag () =
inherit Tag ()
override this.Render (context : Context, result : TextWriter) =
let webLog = webLog context
let webLog = context.WebLog
// spacer
let s = " "
let getBool name =
@@ -137,12 +137,12 @@ type PageHeadTag () =
if getBool "is_post" then
let post = context.Environments[0].["model"] :?> PostDisplay
let url = WebLog.absoluteUrl webLog (Permalink post.posts[0].permalink)
let url = WebLog.absoluteUrl webLog (Permalink post.Posts[0].Permalink)
result.WriteLine $"""{s}<link rel="canonical" href="{url}">"""
if getBool "is_page" then
let page = context.Environments[0].["page"] :?> DisplayPage
let url = WebLog.absoluteUrl webLog (Permalink page.permalink)
let url = WebLog.absoluteUrl webLog (Permalink page.Permalink)
result.WriteLine $"""{s}<link rel="canonical" href="{url}">"""
@@ -151,7 +151,7 @@ type PageFootTag () =
inherit Tag ()
override this.Render (context : Context, result : TextWriter) =
let webLog = webLog context
let webLog = context.WebLog
// spacer
let s = " "
@@ -176,7 +176,7 @@ type TagLinkFilter () =
|> function
| Some tagMap -> tagMap.urlValue
| None -> tag.Replace (" ", "+")
|> function tagUrl -> WebLog.relativeUrl (webLog ctx) (Permalink $"tag/{tagUrl}/")
|> function tagUrl -> WebLog.relativeUrl ctx.WebLog (Permalink $"tag/{tagUrl}/")
/// Create links for a user to log on or off, and a dashboard link if they are logged off
@@ -184,8 +184,7 @@ type UserLinksTag () =
inherit Tag ()
override this.Render (context : Context, result : TextWriter) =
let webLog = webLog context
let link it = WebLog.relativeUrl webLog (Permalink it)
let link it = WebLog.relativeUrl context.WebLog (Permalink it)
seq {
"""<ul class="navbar-nav flex-grow-1 justify-content-end">"""
match Convert.ToBoolean context.Environments[0].["is_logged_on"] with

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

@@ -9,25 +9,25 @@ open MyWebLog.ViewModels
// GET /admin
let dashboard : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let webLogId = ctx.WebLog.id
let data = ctx.Data
let getCount (f : WebLogId -> Task<int>) = f webLogId
let! posts = data.Post.countByStatus Published |> getCount
let! drafts = data.Post.countByStatus Draft |> getCount
let! pages = data.Page.countAll |> getCount
let! listed = data.Page.countListed |> getCount
let! cats = data.Category.countAll |> getCount
let! topCats = data.Category.countTopLevel |> getCount
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)
let pages = getCount data.Page.CountAll
let listed = getCount data.Page.CountListed
let cats = getCount data.Category.CountAll
let topCats = getCount data.Category.CountTopLevel
let! _ = Task.WhenAll (posts, drafts, pages, listed, cats, topCats)
return!
Hash.FromAnonymousObject {|
page_title = "Dashboard"
model =
{ posts = posts
drafts = drafts
pages = pages
listedPages = listed
categories = cats
topLevelCategories = topCats
{ Posts = posts.Result
Drafts = drafts.Result
Pages = pages.Result
ListedPages = listed.Result
Categories = cats.Result
TopLevelCategories = topCats.Result
}
|}
|> viewForTheme "admin" "dashboard" next ctx
@@ -49,14 +49,12 @@ let listCategories : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
}
// GET /admin/categories/bare
let listCategoriesBare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
return!
Hash.FromAnonymousObject {|
categories = CategoryCache.get ctx
csrf = ctx.CsrfTokenSet
|}
|> bareForTheme "admin" "category-list-body" next ctx
}
let listCategoriesBare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
Hash.FromAnonymousObject {|
categories = CategoryCache.get ctx
csrf = ctx.CsrfTokenSet
|}
|> bareForTheme "admin" "category-list-body" next ctx
// GET /admin/category/{id}/edit
@@ -65,7 +63,7 @@ let editCategory catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ct
match catId with
| "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
}
@@ -86,34 +84,33 @@ let editCategory catId : HttpHandler = requireAccess WebLogAdmin >=> fun next ct
let saveCategory : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data
let! model = ctx.BindFormAsync<EditCategoryModel> ()
let! category = task {
match model.categoryId with
| "new" -> return Some { Category.empty with id = CategoryId.create (); webLogId = ctx.WebLog.id }
| catId -> return! data.Category.findById (CategoryId catId) ctx.WebLog.id
}
match category with
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
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! (match model.CategoryId with "new" -> data.Category.Add | _ -> data.Category.Update) cat
do! CategoryCache.update ctx
do! addMessage ctx { UserMessage.success with message = "Category saved successfully" }
do! addMessage ctx { UserMessage.success with Message = "Category saved successfully" }
return! listCategoriesBare next ctx
| None -> return! Error.notFound next ctx
}
// 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" }
| false -> do! addMessage ctx { UserMessage.error with message = "Category not found; cannot delete" }
do! addMessage ctx { UserMessage.success with Message = "Category deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with Message = "Category not found; cannot delete" }
return! listCategoriesBare next ctx
}
@@ -123,7 +120,7 @@ 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
@@ -136,11 +133,10 @@ let private tagMappingHash (ctx : HttpContext) = task {
let tagMappings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! hash = tagMappingHash ctx
let! listTemplate = TemplateCache.get "admin" "tag-mapping-list-body" ctx.Data
hash.Add ("tag_mapping_list", listTemplate.Render hash)
hash.Add ("page_title", "Tag Mappings")
return! viewForTheme "admin" "tag-mapping-list" next ctx hash
return!
addToHash "tag_mapping_list" (listTemplate.Render hash) hash
|> addToHash "page_title" "Tag Mappings"
|> viewForTheme "admin" "tag-mapping-list" next ctx
}
// GET /admin/settings/tag-mappings/bare
@@ -153,10 +149,8 @@ let tagMappingsBare : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -
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!
@@ -174,23 +168,22 @@ let saveMapping : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> ta
let data = ctx.Data
let! model = ctx.BindFormAsync<EditTagMapModel> ()
let tagMap =
if model.id = "new" then
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
else data.TagMap.FindById (TagMapId model.Id) ctx.WebLog.id
match! tagMap with
| Some tm ->
do! data.TagMap.save { tm with tag = model.tag.ToLower (); urlValue = model.urlValue.ToLower () }
do! addMessage ctx { UserMessage.success with message = "Tag mapping saved successfully" }
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
}
// 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
| 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" }
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
}
@@ -203,14 +196,12 @@ open System.Text.RegularExpressions
open MyWebLog.Data
// GET /admin/theme/update
let themeUpdatePage : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
return!
Hash.FromAnonymousObject {|
page_title = "Upload Theme"
csrf = ctx.CsrfTokenSet
|}
|> viewForTheme "admin" "upload-theme" next ctx
}
let themeUpdatePage : HttpHandler = requireAccess Administrator >=> fun next ctx ->
Hash.FromAnonymousObject {|
page_title = "Upload Theme"
csrf = ctx.CsrfTokenSet
|}
|> viewForTheme "admin" "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 {
@@ -223,17 +214,15 @@ let private updateNameAndVersion (theme : Theme) (zip : ZipArchive) = background
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 () }
| 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
do! data.ThemeAsset.DeleteByTheme theme.id
return { theme with templates = [] }
else
return theme
else return theme
}
/// Update the theme with all templates from the ZIP archive
@@ -261,7 +250,7 @@ let private updateAssets themeId (zip : ZipArchive) (data : IData) = backgroundT
if assetName <> "" && not (assetName.EndsWith "/") then
use stream = new MemoryStream ()
do! asset.Open().CopyToAsync stream
do! data.ThemeAsset.save
do! data.ThemeAsset.Save
{ id = ThemeAssetId (themeId, assetName)
updatedOn = asset.LastWriteTime.DateTime
data = stream.ToArray ()
@@ -278,14 +267,14 @@ let loadThemeFromZip themeName file clean (data : IData) = backgroundTask {
use zip = new ZipArchive (file, ZipArchiveMode.Read)
let themeId = ThemeId themeName
let! theme = backgroundTask {
match! data.Theme.findById themeId with
match! data.Theme.FindById themeId with
| Some t -> return t
| None -> return { Theme.empty with id = themeId }
}
let! theme = updateNameAndVersion theme zip
let! theme = checkForCleanLoad theme clean data
let! theme = updateTemplates theme zip
do! data.Theme.save theme
do! data.Theme.Save theme
do! updateAssets themeId zip data
}
@@ -301,16 +290,15 @@ let updateTheme : HttpHandler = requireAccess Administrator >=> fun next ctx ->
do! loadThemeFromZip themeName stream true data
do! ThemeAssetCache.refreshTheme (ThemeId themeName) data
TemplateCache.invalidateTheme themeName
do! addMessage ctx { UserMessage.success with message = "Theme updated successfully" }
do! addMessage ctx { UserMessage.success with Message = "Theme updated successfully" }
return! redirectToGet "admin/dashboard" next ctx
| Ok _ ->
do! addMessage ctx { UserMessage.error with message = "You may not replace the admin theme" }
do! addMessage ctx { UserMessage.error with Message = "You may not replace the admin theme" }
return! redirectToGet "admin/theme/update" next ctx
| Error message ->
do! addMessage ctx { UserMessage.error with message = message }
do! addMessage ctx { UserMessage.error with Message = message }
return! redirectToGet "admin/theme/update" next ctx
else
return! RequestErrors.BAD_REQUEST "Bad request" next ctx
else return! RequestErrors.BAD_REQUEST "Bad request" next ctx
}
// -- WEB LOG SETTINGS --
@@ -320,8 +308,8 @@ 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! themes = data.Theme.all ()
let! allPages = data.Page.All ctx.WebLog.id
let! themes = data.Theme.All ()
return!
Hash.FromAnonymousObject {|
page_title = "Web Log Settings"
@@ -351,11 +339,11 @@ let settings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task
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 webLog = model.update webLog
do! data.WebLog.updateSettings webLog
do! data.WebLog.UpdateSettings webLog
// Update cache
WebLogCache.set webLog
@@ -366,7 +354,7 @@ let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> t
let oldDir = Path.Combine (uploadRoot, oldSlug)
if Directory.Exists oldDir then Directory.Move (oldDir, Path.Combine (uploadRoot, webLog.slug))
do! addMessage ctx { UserMessage.success with message = "Web log settings saved successfully" }
do! addMessage ctx { UserMessage.success with Message = "Web log settings saved successfully" }
return! redirectToGet "admin/settings" next ctx
| None -> return! Error.notFound next ctx
}

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

@@ -49,17 +49,17 @@ let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option =
/// Determine the function to retrieve posts for the given feed
let private getFeedPosts ctx feedType =
let childIds catId =
let cat = CategoryCache.get ctx |> Array.find (fun c -> c.id = CategoryId.toString catId)
getCategoryIds cat.slug ctx
let cat = CategoryCache.get ctx |> Array.find (fun c -> c.Id = CategoryId.toString catId)
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
| 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)*?>", "")
@@ -116,8 +116,8 @@ let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[
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))
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
|> List.map (fun tag ->
let urlTag =
@@ -326,7 +326,7 @@ let private selfAndLink webLog feedType ctx =
| Custom (feed, _) ->
match feed.source with
| Category (CategoryId catId) ->
feed.path, Permalink $"category/{(CategoryCache.get ctx |> Array.find (fun c -> c.id = catId)).slug}"
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
@@ -337,9 +337,9 @@ let private setTitleAndDescription feedType (webLog : WebLog) (cats : DisplayCat
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.Description <- cleanText cat.description $"""Posts categorized under "{cat.name}" """
let cat = cats |> Array.find (fun it -> it.Id = catId)
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.Description <- cleanText None $"""Posts with the "{tag}" tag"""
@@ -351,9 +351,9 @@ let private setTitleAndDescription feedType (webLog : WebLog) (cats : DisplayCat
| None ->
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.Description <- cleanText cat.description $"""Posts categorized under "{cat.name}" """
let cat = cats |> Array.find (fun it -> it.Id = catId)
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.Description <- cleanText None $"""Posts with the "{tag}" tag"""
@@ -417,81 +417,79 @@ let generate (feedType : FeedType) postCount : HttpHandler = fun next ctx -> bac
open DotLiquid
// GET: /admin/settings/rss
let editSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let editSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
let feeds =
ctx.WebLog.rss.customFeeds
|> List.map (DisplayCustomFeed.fromFeed (CategoryCache.get ctx))
|> Array.ofList
return! Hash.FromAnonymousObject {|
page_title = "RSS Settings"
csrf = ctx.CsrfTokenSet
model = EditRssModel.fromRssOptions ctx.WebLog.rss
custom_feeds = feeds
|}
|> viewForTheme "admin" "rss-settings" next ctx
}
Hash.FromAnonymousObject {|
page_title = "RSS Settings"
csrf = ctx.CsrfTokenSet
model = EditRssModel.fromRssOptions ctx.WebLog.rss
custom_feeds = feeds
|}
|> viewForTheme "admin" "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 }
do! data.WebLog.updateRssOptions webLog
do! data.WebLog.UpdateRssOptions webLog
WebLogCache.set webLog
do! addMessage ctx { UserMessage.success with message = "RSS settings updated successfully" }
do! addMessage ctx { UserMessage.success with Message = "RSS settings updated successfully" }
return! redirectToGet "admin/settings/rss" next ctx
| None -> return! Error.notFound next ctx
}
// GET: /admin/settings/rss/{id}/edit
let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
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)
match customFeed with
| Some f ->
return! Hash.FromAnonymousObject {|
page_title = $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed"""
csrf = ctx.CsrfTokenSet
model = EditCustomFeedModel.fromFeed f
categories = CategoryCache.get ctx
medium_values = [|
KeyValuePair.Create ("", "&ndash; Unspecified &ndash;")
KeyValuePair.Create (PodcastMedium.toString Podcast, "Podcast")
KeyValuePair.Create (PodcastMedium.toString Music, "Music")
KeyValuePair.Create (PodcastMedium.toString Video, "Video")
KeyValuePair.Create (PodcastMedium.toString Film, "Film")
KeyValuePair.Create (PodcastMedium.toString Audiobook, "Audiobook")
KeyValuePair.Create (PodcastMedium.toString Newsletter, "Newsletter")
KeyValuePair.Create (PodcastMedium.toString Blog, "Blog")
|]
|}
|> viewForTheme "admin" "custom-feed-edit" next ctx
| None -> return! Error.notFound next ctx
}
Hash.FromAnonymousObject {|
page_title = $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed"""
csrf = ctx.CsrfTokenSet
model = EditCustomFeedModel.fromFeed f
categories = CategoryCache.get ctx
medium_values = [|
KeyValuePair.Create ("", "&ndash; Unspecified &ndash;")
KeyValuePair.Create (PodcastMedium.toString Podcast, "Podcast")
KeyValuePair.Create (PodcastMedium.toString Music, "Music")
KeyValuePair.Create (PodcastMedium.toString Video, "Video")
KeyValuePair.Create (PodcastMedium.toString Film, "Film")
KeyValuePair.Create (PodcastMedium.toString Audiobook, "Audiobook")
KeyValuePair.Create (PodcastMedium.toString Newsletter, "Newsletter")
KeyValuePair.Create (PodcastMedium.toString Blog, "Blog")
|]
|}
|> viewForTheme "admin" "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
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)
| _ -> 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 } }
do! data.WebLog.updateRssOptions webLog
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"""
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
| None -> return! Error.notFound next ctx
@@ -501,7 +499,7 @@ 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
@@ -512,11 +510,11 @@ let deleteCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun ne
customFeeds = webLog.rss.customFeeds |> List.filter (fun f -> f.id <> customId)
}
}
do! data.WebLog.updateRssOptions webLog
do! data.WebLog.UpdateRssOptions webLog
WebLogCache.set webLog
do! addMessage ctx { UserMessage.success with message = "Custom feed deleted successfully" }
do! addMessage ctx { UserMessage.success with Message = "Custom feed deleted successfully" }
else
do! addMessage ctx { UserMessage.warning with message = "Custom feed not found; no action taken" }
do! addMessage ctx { UserMessage.warning with Message = "Custom feed not found; no action taken" }
return! redirectToGet "admin/settings/rss" next ctx
| None -> return! Error.notFound next ctx
}

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

@@ -125,9 +125,9 @@ let messagesToHeaders (messages : UserMessage array) : HttpHandler =
yield!
messages
|> Array.map (fun m ->
match m.detail with
| Some detail -> $"{m.level}|||{m.message}|||{detail}"
| None -> $"{m.level}|||{m.message}"
match m.Detail with
| Some detail -> $"{m.Level}|||{m.Message}|||{detail}"
| None -> $"{m.Level}|||{m.Message}"
|> setHttpHeader "X-Message")
withHxNoPushUrl
}
@@ -184,7 +184,7 @@ module Error =
if isHtmx ctx then
let messages = [|
{ UserMessage.error with
message = $"You are not authorized to access the URL {ctx.Request.Path.Value}"
Message = $"You are not authorized to access the URL {ctx.Request.Path.Value}"
}
|]
(messagesToHeaders messages >=> setStatusCode 401) earlyReturn ctx
@@ -195,7 +195,7 @@ module Error =
handleContext (fun ctx ->
if isHtmx ctx then
let messages = [|
{ UserMessage.error with message = $"The URL {ctx.Request.Path.Value} was not found" }
{ UserMessage.error with Message = $"The URL {ctx.Request.Path.Value} was not found" }
|]
(messagesToHeaders messages >=> setStatusCode 404) earlyReturn ctx
else
@@ -216,7 +216,7 @@ let requireAccess level : HttpHandler = fun next ctx -> task {
| Some lvl ->
$"The page you tried to access requires {AccessLevel.toString level} privileges; your account only has {AccessLevel.toString lvl} privileges"
| None -> "The page you tried to access required you to be logged on"
do! addMessage ctx { UserMessage.warning with message = message }
do! addMessage ctx { UserMessage.warning with Message = message }
printfn "Added message to context"
do! commitSession ctx
return! Error.notAuthorized next ctx
@@ -232,7 +232,7 @@ 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 (ThemeId ctx.WebLog.themePath) with
| Some theme ->
return seq {
KeyValuePair.Create ("", $"- Default (single-{typ}) -")
@@ -251,7 +251,7 @@ let getAuthors (webLog : WebLog) (posts : Post list) (data : IData) =
posts
|> 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) =
@@ -259,17 +259,17 @@ let getTagMappings (webLog : WebLog) (posts : Post list) (data : IData) =
|> 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 =
let allCats = CategoryCache.get ctx
let cat = allCats |> Array.find (fun cat -> cat.slug = slug)
let cat = allCats |> Array.find (fun cat -> cat.Slug = slug)
// Category pages include posts in subcategories
allCats
|> Seq.ofArray
|> Seq.filter (fun c -> c.id = cat.id || Array.contains cat.name c.parentNames)
|> Seq.map (fun c -> CategoryId c.id)
|> Seq.filter (fun c -> c.Id = cat.Id || Array.contains cat.Name c.ParentNames)
|> Seq.map (fun c -> CategoryId c.Id)
|> List.ofSeq
open System

92
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"
@@ -28,7 +28,7 @@ let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match pgId with
| "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
}
@@ -41,7 +41,7 @@ let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
page_title = title
csrf = ctx.CsrfTokenSet
model = model
metadata = Array.zip model.metaNames model.metaValues
metadata = Array.zip model.MetaNames model.MetaValues
|> Array.mapi (fun idx (name, value) -> [| string idx; name; value |])
templates = templates
|}
@@ -52,17 +52,17 @@ let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
// 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" }
| false -> do! addMessage ctx { UserMessage.error with message = "Page not found; nothing deleted" }
do! addMessage ctx { UserMessage.success with Message = "Page deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with Message = "Page not found; nothing deleted" }
return! redirectToGet "admin/pages" next ctx
}
// 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
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.id with
| Some pg when canEdit pg.authorId ctx ->
return!
Hash.FromAnonymousObject {|
@@ -78,14 +78,14 @@ let editPermalinks pgId : HttpHandler = requireAccess Author >=> fun next ctx ->
// POST /admin/page/permalinks
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
let pageId = PageId model.Id
match! ctx.Data.Page.FindById pageId ctx.WebLog.id with
| Some pg when canEdit pg.authorId ctx ->
let links = model.prior |> Array.map Permalink |> List.ofArray
match! ctx.Data.Page.updatePriorPermalinks pageId ctx.WebLog.id links with
let links = model.Prior |> Array.map Permalink |> List.ofArray
match! ctx.Data.Page.UpdatePriorPermalinks pageId ctx.WebLog.id links with
| true ->
do! addMessage ctx { UserMessage.success with message = "Page permalinks saved successfully" }
return! redirectToGet $"admin/page/{model.id}/permalinks" next ctx
do! addMessage ctx { UserMessage.success with Message = "Page permalinks saved successfully" }
return! redirectToGet $"admin/page/{model.Id}/permalinks" next ctx
| false -> return! Error.notFound next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
@@ -93,7 +93,7 @@ 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
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.id with
| Some pg when canEdit pg.authorId ctx ->
return!
Hash.FromAnonymousObject {|
@@ -109,10 +109,10 @@ 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! addMessage ctx { UserMessage.success with message = "Prior revisions purged successfully" }
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,7 +121,7 @@ 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)
@@ -148,12 +148,12 @@ open System
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 ->
do! ctx.Data.Page.update
do! ctx.Data.Page.Update
{ pg with
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" }
do! addMessage ctx { UserMessage.success with Message = "Revision restored successfully" }
return! redirectToGet $"admin/page/{pgId}/revisions" next ctx
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
@@ -164,52 +164,54 @@ let restoreRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun
let deleteRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPageRevision pgId revDate ctx with
| Some pg, Some rev when canEdit pg.authorId ctx ->
do! ctx.Data.Page.update { pg with revisions = pg.revisions |> List.filter (fun r -> r.asOf <> rev.asOf) }
do! addMessage ctx { UserMessage.success with message = "Revision deleted successfully" }
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 = "" |})
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
}
#nowarn "3511"
//#nowarn "3511"
open System.Threading.Tasks
// POST /admin/page/save
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPageModel> ()
let data = ctx.Data
let now = DateTime.UtcNow
let! pg = task {
match model.pageId with
let pg =
match model.PageId with
| "new" ->
return Some
{ Page.empty with
id = PageId.create ()
webLogId = ctx.WebLog.id
authorId = ctx.UserId
publishedOn = now
}
| pgId -> return! data.Page.findFullById (PageId pgId) ctx.WebLog.id
}
match pg with
Task.FromResult (
Some
{ Page.empty with
id = PageId.create ()
webLogId = ctx.WebLog.id
authorId = ctx.UserId
publishedOn = now
})
| 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}" }
let updateList = page.showInPageList <> 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
| "" -> page
| link when link = model.permalink -> page
| link when link = model.Permalink -> page
| _ -> { page with priorPermalinks = page.permalink :: page.priorPermalinks }
let page =
{ page with
title = model.title
permalink = Permalink model.permalink
title = model.Title
permalink = Permalink model.Permalink
updatedOn = now
showInPageList = model.isShownInPageList
template = match model.template with "" -> None | tmpl -> Some tmpl
showInPageList = model.IsShownInPageList
template = match model.Template with "" -> None | tmpl -> Some tmpl
text = MarkupText.toHtml revision.text
metadata = Seq.zip model.metaNames model.metaValues
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 ()}")
@@ -218,9 +220,9 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
| 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
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" }
do! addMessage ctx { UserMessage.success with Message = "Page saved successfully" }
return! redirectToGet $"admin/page/{PageId.toString page.id}/edit" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx

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

@@ -16,8 +16,7 @@ let private parseSlugAndPage webLog (slugAndPage : string seq) =
|| (webLog.rss.tagEnabled && fullPath.StartsWith "/tag/" ))
&& slugPath.EndsWith feedName then
notBlank (slugPath.Replace(feedName, "").Split "/"), true
else
notBlank (slugPath.Split "/"), false
else notBlank (slugPath.Split "/"), false
let pageIdx = Array.IndexOf (slugs, "page")
let pageNbr =
match pageIdx with
@@ -56,7 +55,7 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage ctx (da
| SinglePost ->
let post = List.head posts
let dateTime = defaultArg post.publishedOn post.updatedOn
data.Post.findSurroundingPosts webLog.id dateTime
data.Post.FindSurroundingPosts webLog.id dateTime
| _ -> Task.FromResult (None, None)
let newerLink =
match listType, pageNbr with
@@ -68,7 +67,7 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage ctx (da
| CategoryList, _ -> relUrl $"category/{url}/page/{pageNbr - 1}"
| TagList, 2 -> relUrl $"tag/{url}/"
| TagList, _ -> relUrl $"tag/{url}/page/{pageNbr - 1}"
| AdminList, 2 -> relUrl "admin/posts"
| AdminList, 2 -> relUrl "admin/posts"
| AdminList, _ -> relUrl $"admin/posts/page/{pageNbr - 1}"
let olderLink =
match listType, List.length posts > perPage with
@@ -79,13 +78,13 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage ctx (da
| TagList, true -> relUrl $"tag/{url}/page/{pageNbr + 1}"
| AdminList, true -> relUrl $"admin/posts/page/{pageNbr + 1}"
let model =
{ posts = postItems
authors = authors
subtitle = None
newerLink = newerLink
newerName = newerPost |> Option.map (fun p -> p.title)
olderLink = olderLink
olderName = olderPost |> Option.map (fun p -> p.title)
{ Posts = postItems
Authors = authors
Subtitle = None
NewerLink = newerLink
NewerName = newerPost |> Option.map (fun p -> p.title)
OlderLink = olderLink
OlderName = olderPost |> Option.map (fun p -> p.title)
}
return Hash.FromAnonymousObject {|
model = model
@@ -101,7 +100,7 @@ open Giraffe
let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
let count = ctx.WebLog.postsPerPage
let data = ctx.Data
let! posts = data.Post.findPageOfPublishedPosts ctx.WebLog.id pageNbr count
let! 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
@@ -124,23 +123,24 @@ let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task {
let data = ctx.Data
match parseSlugAndPage webLog slugAndPage with
| Some pageNbr, slug, isFeed ->
match CategoryCache.get ctx |> Array.tryFind (fun cat -> cat.slug = slug) with
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}"))
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>"""
hash.Add ("page_title", $"{cat.name}: Category Archive{pgTitle}")
hash.Add ("subtitle", defaultArg cat.description "")
hash.Add ("is_category", true)
hash.Add ("is_category_home", (pageNbr = 1))
hash.Add ("slug", slug)
return! themedView "index" next ctx hash
return!
addToHash "page_title" $"{cat.Name}: Category Archive{pgTitle}" hash
|> addToHash "subtitle" (defaultArg cat.Description "")
|> addToHash "is_category" true
|> addToHash "is_category_home" (pageNbr = 1)
|> addToHash "slug" slug
|> themedView "index" next ctx
| _ -> return! Error.notFound next ctx
| None -> return! Error.notFound next ctx
| None, _, _ -> return! Error.notFound next ctx
@@ -157,7 +157,7 @@ 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
match! data.TagMap.FindByUrlValue urlTag webLog.id with
| Some m -> return m.tag
| None -> return urlTag
}
@@ -165,19 +165,20 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
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 pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
hash.Add ("page_title", $"Posts Tagged &ldquo;{tag}&rdquo;{pgTitle}")
hash.Add ("is_tag", true)
hash.Add ("is_tag_home", (pageNbr = 1))
hash.Add ("slug", rawTag)
return! themedView "index" next ctx hash
return!
addToHash "page_title" $"Posts Tagged &ldquo;{tag}&rdquo;{pgTitle}" hash
|> addToHash "is_tag" true
|> addToHash "is_tag_home" (pageNbr = 1)
|> addToHash "slug" rawTag
|> themedView "index" next ctx
// 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!
@@ -194,7 +195,7 @@ let home : HttpHandler = fun next ctx -> task {
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 {|
@@ -211,11 +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
hash.Add ("page_title", "Posts")
hash.Add ("csrf", ctx.CsrfTokenSet)
return! viewForTheme "admin" "post-list" next ctx hash
return!
addToHash "page_title" "Posts" hash
|> addToHash "csrf" ctx.CsrfTokenSet
|> viewForTheme "admin" "post-list" next ctx
}
// GET /admin/post/{id}/edit
@@ -225,13 +227,13 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match postId with
| "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
let! cats = data.Category.FindAllForView ctx.WebLog.id
let! templates = templatesForTheme ctx "post"
let model = EditPostModel.fromPost ctx.WebLog post
return!
@@ -239,7 +241,7 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
page_title = title
csrf = ctx.CsrfTokenSet
model = model
metadata = Array.zip model.metaNames model.metaValues
metadata = Array.zip model.MetaNames model.MetaValues
|> Array.mapi (fun idx (name, value) -> [| string idx; name; value |])
templates = templates
categories = cats
@@ -257,15 +259,15 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
// 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
| true -> do! addMessage ctx { UserMessage.success with message = "Post deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with message = "Post not found; nothing deleted" }
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
}
// 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
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.id with
| Some post when canEdit post.authorId ctx ->
return!
Hash.FromAnonymousObject {|
@@ -281,14 +283,14 @@ let editPermalinks postId : HttpHandler = requireAccess Author >=> fun next ctx
// POST /admin/post/permalinks
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
let postId = PostId model.Id
match! ctx.Data.Post.FindById postId ctx.WebLog.id with
| Some post when canEdit post.authorId ctx ->
let links = model.prior |> Array.map Permalink |> List.ofArray
match! ctx.Data.Post.updatePriorPermalinks (PostId model.id) ctx.WebLog.id links with
let links = model.Prior |> Array.map Permalink |> List.ofArray
match! ctx.Data.Post.UpdatePriorPermalinks postId ctx.WebLog.id links with
| true ->
do! addMessage ctx { UserMessage.success with message = "Post permalinks saved successfully" }
return! redirectToGet $"admin/post/{model.id}/permalinks" next ctx
do! addMessage ctx { UserMessage.success with Message = "Post permalinks saved successfully" }
return! redirectToGet $"admin/post/{model.Id}/permalinks" next ctx
| false -> return! Error.notFound next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
@@ -296,7 +298,7 @@ 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
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.id with
| Some post when canEdit post.authorId ctx ->
return!
Hash.FromAnonymousObject {|
@@ -312,10 +314,10 @@ 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
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" }
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
| None -> return! Error.notFound next ctx
@@ -325,7 +327,7 @@ 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)
@@ -350,12 +352,12 @@ let previewRevision (postId, revDate) : HttpHandler = requireAccess Author >=> f
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 ->
do! ctx.Data.Post.update
do! ctx.Data.Post.Update
{ post with
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" }
do! addMessage ctx { UserMessage.success with Message = "Revision restored successfully" }
return! redirectToGet $"admin/post/{postId}/revisions" next ctx
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
@@ -366,64 +368,62 @@ let restoreRevision (postId, revDate) : HttpHandler = requireAccess Author >=> f
let deleteRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPostRevision postId revDate ctx with
| Some post, Some rev when canEdit post.authorId ctx ->
do! ctx.Data.Post.update { post with revisions = post.revisions |> List.filter (fun r -> r.asOf <> rev.asOf) }
do! addMessage ctx { UserMessage.success with message = "Revision deleted successfully" }
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 = "" |})
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
}
#nowarn "3511"
//#nowarn "3511"
// POST /admin/post/save
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPostModel> ()
let data = ctx.Data
let now = DateTime.UtcNow
let! pst = task {
match model.postId with
| "new" ->
return Some
{ Post.empty with
id = PostId.create ()
webLogId = ctx.WebLog.id
authorId = ctx.UserId
}
| postId -> return! data.Post.findFullById (PostId postId) ctx.WebLog.id
}
match pst with
let! model = ctx.BindFormAsync<EditPostModel> ()
let data = ctx.Data
let now = DateTime.UtcNow
let tryPost =
if model.PostId = "new" then
Task.FromResult (
Some
{ Post.empty with
id = PostId.create ()
webLogId = ctx.WebLog.id
authorId = ctx.UserId
})
else data.Post.FindFullById (PostId model.PostId) ctx.WebLog.id
match! tryPost with
| Some post when canEdit post.authorId ctx ->
let revision = { asOf = now; text = MarkupText.parse $"{model.source}: {model.text}" }
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
| "" -> post
| link when link = model.permalink -> post
| link when link = model.Permalink -> post
| _ -> { post with priorPermalinks = post.permalink :: post.priorPermalinks }
let post = model.updatePost post revision now
let post =
match model.setPublished with
| true ->
let dt = parseToUtc (model.pubOverride.Value.ToString "o")
match model.setUpdated with
| true ->
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 } ]
}
| false -> { post with publishedOn = Some dt }
| false -> post
do! (if model.postId = "new" then data.Post.add else data.Post.update) post
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 (pst.Value.categoryIds
if model.DoPublish
|| not (priorCats
|> List.append post.categoryIds
|> List.distinct
|> List.length = List.length pst.Value.categoryIds) then
|> List.length = List.length priorCats) then
do! CategoryCache.update ctx
do! addMessage ctx { UserMessage.success with message = "Post saved successfully" }
do! addMessage ctx { UserMessage.success with Message = "Post saved successfully" }
return! redirectToGet $"admin/post/{PostId.toString post.id}/edit" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx

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

@@ -27,7 +27,7 @@ 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
@@ -35,7 +35,7 @@ module CatchAll =
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 ->
@@ -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)
| 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)
| 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)
@@ -83,11 +83,8 @@ module CatchAll =
}
// GET {all-of-the-above}
let route : HttpHandler = fun next ctx -> task {
match deriveAction ctx |> Seq.tryHead with
| Some handler -> return! handler next ctx
| None -> return! Error.notFound next ctx
}
let route : HttpHandler = fun next ctx ->
match deriveAction ctx |> Seq.tryHead with Some handler -> handler next ctx | None -> Error.notFound next ctx
/// Serve theme assets
@@ -96,7 +93,7 @@ module Asset =
// GET /theme/{theme}/{**path}
let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task {
let path = urlParts |> Seq.skip 1 |> Seq.head
match! ctx.Data.ThemeAsset.findById (ThemeAssetId.ofString path) with
match! ctx.Data.ThemeAsset.FindById (ThemeAssetId.ofString path) with
| Some asset ->
match Upload.checkModified asset.updatedOn ctx with
| Some threeOhFour -> return! threeOhFour next ctx
@@ -219,10 +216,10 @@ let routerWithPath extraPath : HttpHandler =
subRoute extraPath router
/// Handler to apply Giraffe routing with a possible sub-route
let handleRoute : HttpHandler = fun next ctx -> task {
let handleRoute : HttpHandler = fun next ctx ->
let _, extraPath = WebLog.hostAndPath ctx.WebLog
return! (if extraPath = "" then router else routerWithPath extraPath) next ctx
}
(if extraPath = "" then router else routerWithPath extraPath) next ctx
open Giraffe.EndpointRouting

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

@@ -45,13 +45,13 @@ let deriveMimeType path =
match mimeMap.TryGetContentType path with true, typ -> typ | false, _ -> "application/octet-stream"
/// Send a file, caching the response for 30 days
let sendFile updatedOn path (data : byte[]) : HttpHandler = fun next ctx -> task {
let sendFile updatedOn path (data : byte[]) : HttpHandler = fun next ctx ->
let headers = ResponseHeaders ctx.Response.Headers
headers.ContentType <- (deriveMimeType >> MediaTypeHeaderValue) path
headers.CacheControl <- cacheForThirtyDays
let stream = new MemoryStream (data)
return! streamData true stream None (Some (DateTimeOffset updatedOn)) next ctx
}
streamData true stream None (Some (DateTimeOffset updatedOn)) next ctx
// GET /upload/{web-log-slug}/{**path}
let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task {
@@ -65,7 +65,7 @@ let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task {
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
| Some threeOhFour -> return! threeOhFour next ctx
@@ -87,7 +87,7 @@ 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)
try
@@ -98,11 +98,11 @@ let list : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match File.GetCreationTime (Path.Combine (path, file)) with
| dt when dt > DateTime.UnixEpoch -> Some dt
| _ -> None
{ DisplayUpload.id = ""
name = name
path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace (slash, '/')
updatedOn = create
source = UploadDestination.toString Disk
{ DisplayUpload.Id = ""
Name = name
Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace (slash, '/')
UpdatedOn = create
Source = UploadDestination.toString Disk
})
|> List.ofSeq
with
@@ -114,7 +114,7 @@ let list : HttpHandler = requireAccess Author >=> fun next ctx -> task {
dbUploads
|> List.map (DisplayUpload.fromUpload webLog Database)
|> List.append diskUploads
|> List.sortByDescending (fun file -> file.updatedOn, file.path)
|> List.sortByDescending (fun file -> file.UpdatedOn, file.Path)
return!
Hash.FromAnonymousObject {|
@@ -126,15 +126,14 @@ let list : HttpHandler = requireAccess Author >=> fun next ctx -> task {
}
// GET /admin/upload/new
let showNew : HttpHandler = requireAccess Author >=> fun next ctx -> task {
return!
Hash.FromAnonymousObject {|
page_title = "Upload a File"
csrf = ctx.CsrfTokenSet
destination = UploadDestination.toString ctx.WebLog.uploads
|}
|> viewForTheme "admin" "upload-new" next ctx
}
let showNew : HttpHandler = requireAccess Author >=> fun next ctx ->
Hash.FromAnonymousObject {|
page_title = "Upload a File"
csrf = ctx.CsrfTokenSet
destination = UploadDestination.toString ctx.WebLog.uploads
|}
|> viewForTheme "admin" "upload-new" next ctx
/// Redirect to the upload list
let showUploads : HttpHandler =
@@ -151,7 +150,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let month = localNow.ToString "MM"
let! form = ctx.BindFormAsync<UploadFileModel> ()
match UploadDestination.parse form.destination with
match UploadDestination.parse form.Destination with
| Database ->
use stream = new MemoryStream ()
do! upload.CopyToAsync stream
@@ -162,14 +161,14 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
updatedOn = DateTime.UtcNow
data = stream.ToArray ()
}
do! ctx.Data.Upload.add file
do! ctx.Data.Upload.Add file
| Disk ->
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
do! addMessage ctx { UserMessage.success with message = $"File uploaded to {form.destination} successfully" }
do! addMessage ctx { UserMessage.success with Message = $"File uploaded to {form.Destination} successfully" }
return! showUploads next ctx
else
return! RequestErrors.BAD_REQUEST "Bad request; no file present" next ctx
@@ -177,9 +176,9 @@ 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" }
do! addMessage ctx { UserMessage.success with Message = $"{fileName} deleted successfully" }
return! showUploads next ctx
| Error _ -> return! Error.notFound next ctx
}
@@ -193,8 +192,7 @@ let removeEmptyDirectories (webLog : WebLog) (filePath : string) =
if Directory.EnumerateFileSystemEntries fullPath |> Seq.isEmpty then
Directory.Delete fullPath
path <- String.Join(slash, path.Split slash |> Array.rev |> Array.skip 1 |> Array.rev)
else
finished <- true
else finished <- true
// POST /admin/upload/delete/{**path}
let deleteFromDisk urlParts : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
@@ -203,8 +201,7 @@ let deleteFromDisk urlParts : HttpHandler = requireAccess WebLogAdmin >=> fun ne
if File.Exists path then
File.Delete path
removeEmptyDirectories ctx.WebLog filePath
do! addMessage ctx { UserMessage.success with message = $"{filePath} deleted successfully" }
do! addMessage ctx { UserMessage.success with Message = $"{filePath} deleted successfully" }
return! showUploads next ctx
else
return! Error.notFound next ctx
else return! Error.notFound next ctx
}

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

@@ -17,22 +17,18 @@ open MyWebLog
open MyWebLog.ViewModels
// GET /user/log-on
let logOn returnUrl : HttpHandler = fun next ctx -> task {
let logOn returnUrl : HttpHandler = fun next ctx ->
let returnTo =
match returnUrl with
| Some _ -> returnUrl
| None ->
match ctx.Request.Query.ContainsKey "returnUrl" with
| true -> Some ctx.Request.Query["returnUrl"].[0]
| false -> None
return!
Hash.FromAnonymousObject {|
page_title = "Log On"
csrf = ctx.CsrfTokenSet
model = { LogOnModel.empty with returnTo = returnTo }
|}
|> viewForTheme "admin" "log-on" next ctx
}
| None -> if ctx.Request.Query.ContainsKey "returnUrl" then Some ctx.Request.Query["returnUrl"].[0] else None
Hash.FromAnonymousObject {|
page_title = "Log On"
csrf = ctx.CsrfTokenSet
model = { LogOnModel.empty with ReturnTo = returnTo }
|}
|> viewForTheme "admin" "log-on" next ctx
open System.Security.Claims
open Microsoft.AspNetCore.Authentication
@@ -41,8 +37,9 @@ open Microsoft.AspNetCore.Authentication.Cookies
// POST /user/log-on
let doLogOn : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<LogOnModel> ()
match! ctx.Data.WebLogUser.findByEmail model.emailAddress ctx.WebLog.id with
| Some user when user.passwordHash = hashedPassword model.password user.userName user.salt ->
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 ->
let claims = seq {
Claim (ClaimTypes.NameIdentifier, WebLogUserId.toString user.id)
Claim (ClaimTypes.Name, $"{user.firstName} {user.lastName}")
@@ -53,34 +50,35 @@ let doLogOn : HttpHandler = fun next ctx -> task {
do! ctx.SignInAsync (identity.AuthenticationType, ClaimsPrincipal identity,
AuthenticationProperties (IssuedUtc = DateTimeOffset.UtcNow))
do! data.WebLogUser.SetLastSeen user.id user.webLogId
do! addMessage ctx
{ UserMessage.success with 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
match model.ReturnTo with
| Some url -> redirectTo false url next ctx
| None -> redirectToGet "admin/dashboard" next ctx
| _ ->
do! addMessage ctx { UserMessage.error with message = "Log on attempt unsuccessful" }
return! logOn model.returnTo next ctx
do! addMessage ctx { UserMessage.error with Message = "Log on attempt unsuccessful" }
return! logOn model.ReturnTo next ctx
}
// GET /user/log-off
let logOff : HttpHandler = fun next ctx -> task {
do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme
do! addMessage ctx { UserMessage.info with message = "Log off successful" }
do! addMessage ctx { UserMessage.info with Message = "Log off successful" }
return! redirectToGet "" next ctx
}
/// Display the user edit page, with information possibly filled in
let private showEdit (hash : Hash) : HttpHandler = fun next ctx -> task {
hash.Add ("page_title", "Edit Your Information")
hash.Add ("csrf", ctx.CsrfTokenSet)
return! viewForTheme "admin" "user-edit" next ctx hash
}
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
// GET /admin/user/edit
let edit : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! ctx.Data.WebLogUser.findById ctx.UserId ctx.WebLog.id with
match! ctx.Data.WebLogUser.FindById ctx.UserId ctx.WebLog.id with
| Some user -> return! showEdit (Hash.FromAnonymousObject {| model = EditUserModel.fromUser user |}) next ctx
| None -> return! Error.notFound next ctx
}
@@ -88,32 +86,32 @@ let edit : HttpHandler = requireAccess Author >=> fun next ctx -> task {
// POST /admin/user/save
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditUserModel> ()
if model.newPassword = model.newPasswordConfirm then
if model.NewPassword = model.NewPasswordConfirm then
let data = ctx.Data
match! data.WebLogUser.findById ctx.UserId ctx.WebLog.id with
match! data.WebLogUser.FindById ctx.UserId ctx.WebLog.id with
| Some user ->
let pw, salt =
if model.newPassword = "" then
if model.NewPassword = "" then
user.passwordHash, user.salt
else
let newSalt = Guid.NewGuid ()
hashedPassword model.newPassword user.userName newSalt, newSalt
hashedPassword model.NewPassword user.userName newSalt, newSalt
let user =
{ user with
firstName = model.firstName
lastName = model.lastName
preferredName = model.preferredName
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" }
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" }
do! addMessage ctx { UserMessage.error with Message = "Passwords did not match; no updates made" }
return! showEdit (Hash.FromAnonymousObject {|
model = { model with newPassword = ""; newPasswordConfirm = "" }
model = { model with NewPassword = ""; NewPasswordConfirm = "" }
|}) next ctx
}

70
src/MyWebLog/Maintenance.fs
View File

@@ -27,10 +27,10 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
// If this is the first web log being created, the user will be an installation admin; otherwise, they will be an
// admin just over their web log
let! webLogs = data.WebLog.all ()
let! webLogs = data.WebLog.All ()
let accessLevel = if List.isEmpty webLogs then Administrator else WebLogAdmin
do! data.WebLog.add
do! data.WebLog.Add
{ WebLog.empty with
id = webLogId
name = args[2]
@@ -42,8 +42,9 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
// Create the admin user
let salt = Guid.NewGuid ()
let now = DateTime.UtcNow
do! data.WebLogUser.add
do! data.WebLogUser.Add
{ WebLogUser.empty with
id = userId
webLogId = webLogId
@@ -54,21 +55,22 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
passwordHash = Handlers.User.hashedPassword args[4] args[3] salt
salt = salt
accessLevel = accessLevel
createdOn = now
}
// Create the default home page
do! data.Page.add
do! data.Page.Add
{ Page.empty with
id = homePageId
webLogId = webLogId
authorId = userId
title = "Welcome to myWebLog!"
permalink = Permalink "welcome-to-myweblog.html"
publishedOn = DateTime.UtcNow
updatedOn = DateTime.UtcNow
publishedOn = now
updatedOn = now
text = "<p>This is your default home page.</p>"
revisions = [
{ asOf = DateTime.UtcNow
{ asOf = now
text = Html "<p>This is your default home page.</p>"
}
]
@@ -94,7 +96,7 @@ let createWebLog args sp = task {
let private importPriorPermalinks urlBase file (sp : IServiceProvider) = task {
let data = sp.GetRequiredService<IData> ()
match! data.WebLog.findByHost urlBase with
match! data.WebLog.FindByHost urlBase with
| Some webLog ->
let mapping =
@@ -105,10 +107,10 @@ 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
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}"
@@ -285,24 +287,24 @@ module Backup =
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 themeId
let! assets = data.ThemeAsset.FindByThemeWithData 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 = {
@@ -329,9 +331,9 @@ module Backup =
let private doRestore archive newUrlBase (data : IData) = task {
let! restore = task {
match! data.WebLog.findById archive.webLog.id with
match! data.WebLog.FindById archive.webLog.id with
| Some webLog when defaultArg newUrlBase webLog.urlBase = webLog.urlBase ->
do! data.WebLog.delete webLog.id
do! data.WebLog.Delete webLog.id
return { archive with webLog = { archive.webLog with urlBase = defaultArg newUrlBase webLog.urlBase } }
| Some _ ->
// Err'body gets new IDs...
@@ -379,31 +381,31 @@ module Backup =
// 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.fromEncoded >> 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.fromEncoded)
displayStats "Restored for <>NAME<>:" restore.webLog restore
}
@@ -436,7 +438,7 @@ module Backup =
let generateBackup (args : string[]) (sp : IServiceProvider) = task {
if args.Length > 1 && args.Length < 5 then
let data = sp.GetRequiredService<IData> ()
match! data.WebLog.findByHost args[1] with
match! data.WebLog.FindByHost args[1] with
| Some webLog ->
let fileName =
if args.Length = 2 || (args.Length = 3 && args[2] = "pretty") then
@@ -469,13 +471,13 @@ module Backup =
/// Upgrade a WebLogAdmin user to an Administrator user
let private doUserUpgrade urlBase email (data : IData) = task {
match! data.WebLog.findByHost urlBase with
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
| 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

@@ -90,7 +90,7 @@ let rec main args =
let data = DataImplementation.get sp
task {
do! data.startUp ()
do! data.StartUp ()
do! WebLogCache.fill data
do! ThemeAssetCache.fill data
} |> Async.AwaitTask |> Async.RunSynchronously