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

Support directory installations

Browse Source 
- Add web log to HttpContext on first retrieval per req
- Add several DotLiquid filters
- Use int for page numbers
- Update all themes to use rel/abs link and other filters
This commit is contained in:
Daniel J. Summers
2022-05-21 22:55:13 -04:00
parent 63425ad806
commit cbf87f5b49
41 changed files with 658 additions and 485 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -1,6 +1,8 @@
/// Handlers to manipulate admin functions
module MyWebLog.Handlers.Admin
// TODO: remove requireUser, as this is applied in the router
open System.Collections.Generic
open System.IO
@@ -21,9 +23,9 @@ open RethinkDb.Driver.Net
// GET /admin
let dashboard : HttpHandler = requireUser >=> fun next ctx -> task {
let webLogId = webLogId ctx
let conn = conn ctx
let getCount (f : WebLogId -> IConnection -> Task<int>) = f webLogId conn
let webLog = webLog ctx
let conn = conn ctx
let getCount (f : WebLogId -> IConnection -> Task<int>) = f webLog.id conn
let! posts = Data.Post.countByStatus Published |> getCount
let! drafts = Data.Post.countByStatus Draft |> getCount
let! pages = Data.Page.countAll |> getCount
@@ -60,13 +62,13 @@ let listCategories : HttpHandler = requireUser >=> fun next ctx -> task {
// GET /admin/category/{id}/edit
let editCategory catId : HttpHandler = requireUser >=> fun next ctx -> task {
let webLogId = webLogId ctx
let conn = conn ctx
let! result = task {
let webLog = webLog ctx
let conn = conn ctx
let! result = task {
match catId with
| "new" -> return Some ("Add a New Category", { Category.empty with id = CategoryId "new" })
| _ ->
match! Data.Category.findById (CategoryId catId) webLogId conn with
match! Data.Category.findById (CategoryId catId) webLog.id conn with
| Some cat -> return Some ("Edit Category", cat)
| None -> return None
}
@@ -86,12 +88,12 @@ let editCategory catId : HttpHandler = requireUser >=> fun next ctx -> task {
// POST /admin/category/save
let saveCategory : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditCategoryModel> ()
let webLogId = webLogId ctx
let conn = conn ctx
let webLog = webLog ctx
let conn = conn ctx
let! category = task {
match model.categoryId with
| "new" -> return Some { Category.empty with id = CategoryId.create (); webLogId = webLogId }
| catId -> return! Data.Category.findById (CategoryId catId) webLogId conn
| "new" -> return Some { Category.empty with id = CategoryId.create (); webLogId = webLog.id }
| catId -> return! Data.Category.findById (CategoryId catId) webLog.id conn
}
match category with
| Some cat ->
@@ -105,20 +107,22 @@ let saveCategory : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -
do! (match model.categoryId with "new" -> Data.Category.add | _ -> Data.Category.update) cat conn
do! CategoryCache.update ctx
do! addMessage ctx { UserMessage.success with message = "Category saved successfully" }
return! redirectToGet $"/admin/category/{CategoryId.toString cat.id}/edit" next ctx
return!
redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/category/{CategoryId.toString cat.id}/edit"))
next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/category/{id}/delete
let deleteCategory catId : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
let webLogId = webLogId ctx
let conn = conn ctx
match! Data.Category.delete (CategoryId catId) webLogId conn with
let webLog = webLog ctx
let conn = conn ctx
match! Data.Category.delete (CategoryId catId) webLog.id conn 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" }
return! redirectToGet "/admin/categories" next ctx
return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/categories")) next ctx
}
// -- PAGES --
@@ -126,7 +130,7 @@ let deleteCategory catId : HttpHandler = requireUser >=> validateCsrf >=> fun ne
// GET /admin/pages
// GET /admin/pages/page/{pageNbr}
let listPages pageNbr : HttpHandler = requireUser >=> fun next ctx -> task {
let webLog = WebLogCache.get ctx
let webLog = webLog ctx
let! pages = Data.Page.findPageOfPages webLog.id pageNbr (conn ctx)
return!
Hash.FromAnonymousObject
@@ -142,7 +146,7 @@ let editPage pgId : HttpHandler = requireUser >=> fun next ctx -> task {
match pgId with
| "new" -> return Some ("Add a New Page", { Page.empty with id = PageId "new" })
| _ ->
match! Data.Page.findByFullId (PageId pgId) (webLogId ctx) (conn ctx) with
match! Data.Page.findByFullId (PageId pgId) (webLog ctx).id (conn ctx) with
| Some page -> return Some ("Edit Page", page)
| None -> return None
}
@@ -164,7 +168,7 @@ let editPage pgId : HttpHandler = requireUser >=> fun next ctx -> task {
// GET /admin/page/{id}/permalinks
let editPagePermalinks pgId : HttpHandler = requireUser >=> fun next ctx -> task {
match! Data.Page.findByFullId (PageId pgId) (webLogId ctx) (conn ctx) with
match! Data.Page.findByFullId (PageId pgId) (webLog ctx).id (conn ctx) with
| Some pg ->
return!
Hash.FromAnonymousObject {|
@@ -178,44 +182,46 @@ let editPagePermalinks pgId : HttpHandler = requireUser >=> fun next ctx -> task
// POST /admin/page/permalinks
let savePagePermalinks : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
let links = model.prior |> Array.map Permalink |> List.ofArray
match! Data.Page.updatePriorPermalinks (PageId model.id) (webLogId ctx) links (conn ctx) with
let webLog = webLog ctx
let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
let links = model.prior |> Array.map Permalink |> List.ofArray
match! Data.Page.updatePriorPermalinks (PageId model.id) webLog.id links (conn ctx) with
| true ->
do! addMessage ctx { UserMessage.success with message = "Page permalinks saved successfully" }
return! redirectToGet $"/admin/page/{model.id}/permalinks" next ctx
return! redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/page/{model.id}/permalinks")) next ctx
| false -> return! Error.notFound next ctx
}
// POST /admin/page/{id}/delete
let deletePage pgId : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
match! Data.Page.delete (PageId pgId) (webLogId ctx) (conn ctx) with
let webLog = webLog ctx
match! Data.Page.delete (PageId pgId) webLog.id (conn ctx) with
| true -> 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
return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/pages")) next ctx
}
open System
#nowarn "3511"
// POST /page/save
// POST /admin/page/save
let savePage : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPageModel> ()
let webLogId = webLogId ctx
let conn = conn ctx
let now = DateTime.UtcNow
let! pg = task {
let! model = ctx.BindFormAsync<EditPageModel> ()
let webLog = webLog ctx
let conn = conn ctx
let now = DateTime.UtcNow
let! pg = task {
match model.pageId with
| "new" ->
return Some
{ Page.empty with
id = PageId.create ()
webLogId = webLogId
webLogId = webLog.id
authorId = userId ctx
publishedOn = now
}
| pgId -> return! Data.Page.findByFullId (PageId pgId) webLogId conn
| pgId -> return! Data.Page.findByFullId (PageId pgId) webLog.id conn
}
match pg with
| Some page ->
@@ -247,7 +253,8 @@ let savePage : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> ta
do! (if model.pageId = "new" then Data.Page.add else Data.Page.update) page conn
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 (WebLog.relativeUrl webLog (Permalink $"admin/page/{PageId.toString page.id}/edit")) next ctx
| None -> return! Error.notFound next ctx
}
@@ -255,7 +262,7 @@ let savePage : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> ta
// GET /admin/settings
let settings : HttpHandler = requireUser >=> fun next ctx -> task {
let webLog = WebLogCache.get ctx
let webLog = webLog ctx
let! allPages = Data.Page.findAll webLog.id (conn ctx)
return!
Hash.FromAnonymousObject
@@ -278,9 +285,10 @@ let settings : HttpHandler = requireUser >=> fun next ctx -> task {
// POST /admin/settings
let saveSettings : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
let conn = conn ctx
let! model = ctx.BindFormAsync<SettingsModel> ()
match! Data.WebLog.findById (WebLogCache.get ctx).id conn with
let webLog = webLog ctx
let conn = conn ctx
let! model = ctx.BindFormAsync<SettingsModel> ()
match! Data.WebLog.findById webLog.id conn with
| Some webLog ->
let updated =
{ webLog with
@@ -294,10 +302,10 @@ let saveSettings : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -
do! Data.WebLog.updateSettings updated conn
// Update cache
WebLogCache.set ctx updated
WebLogCache.set updated
do! addMessage ctx { UserMessage.success with message = "Web log settings saved successfully" }
return! redirectToGet "/admin" next ctx
return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin")) next ctx
| None -> return! Error.notFound next ctx
}
@@ -305,7 +313,7 @@ let saveSettings : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -
// GET /admin/tag-mappings
let tagMappings : HttpHandler = requireUser >=> fun next ctx -> task {
let! mappings = Data.TagMap.findByWebLogId (webLogId ctx) (conn ctx)
let! mappings = Data.TagMap.findByWebLogId (webLog ctx).id (conn ctx)
return!
Hash.FromAnonymousObject
{| csrf = csrfToken ctx
@@ -318,13 +326,12 @@ let tagMappings : HttpHandler = requireUser >=> fun next ctx -> task {
// GET /admin/tag-mapping/{id}/edit
let editMapping tagMapId : HttpHandler = requireUser >=> fun next ctx -> task {
let webLogId = webLogId ctx
let isNew = tagMapId = "new"
let tagMap =
let isNew = tagMapId = "new"
let tagMap =
if isNew then
Task.FromResult (Some { TagMap.empty with id = TagMapId "new" })
else
Data.TagMap.findById (TagMapId tagMapId) webLogId (conn ctx)
Data.TagMap.findById (TagMapId tagMapId) (webLog ctx).id (conn ctx)
match! tagMap with
| Some tm ->
return!
@@ -339,26 +346,29 @@ let editMapping tagMapId : HttpHandler = requireUser >=> fun next ctx -> task {
// POST /admin/tag-mapping/save
let saveMapping : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
let webLogId = webLogId ctx
let conn = conn ctx
let! model = ctx.BindFormAsync<EditTagMapModel> ()
let tagMap =
let webLog = webLog ctx
let conn = conn ctx
let! model = ctx.BindFormAsync<EditTagMapModel> ()
let tagMap =
if model.id = "new" then
Task.FromResult (Some { TagMap.empty with id = TagMapId.create (); webLogId = webLogId })
Task.FromResult (Some { TagMap.empty with id = TagMapId.create (); webLogId = webLog.id })
else
Data.TagMap.findById (TagMapId model.id) webLogId conn
Data.TagMap.findById (TagMapId model.id) webLog.id conn
match! tagMap with
| Some tm ->
do! Data.TagMap.save { tm with tag = model.tag.ToLower (); urlValue = model.urlValue.ToLower () } conn
do! addMessage ctx { UserMessage.success with message = "Tag mapping saved successfully" }
return! redirectToGet $"/admin/tag-mapping/{TagMapId.toString tm.id}/edit" next ctx
return!
redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/tag-mapping/{TagMapId.toString tm.id}/edit"))
next ctx
| None -> return! Error.notFound next ctx
}
// POST /admin/tag-mapping/{id}/delete
let deleteMapping tagMapId : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
match! Data.TagMap.delete (TagMapId tagMapId) (webLogId ctx) (conn ctx) with
let webLog = webLog ctx
match! Data.TagMap.delete (TagMapId tagMapId) webLog.id (conn ctx) 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! redirectToGet "/admin/tag-mappings" next ctx
return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/tag-mappings")) next ctx
}

16
src/MyWebLog/Handlers/Error.fs
View File

@@ -3,15 +3,19 @@ module MyWebLog.Handlers.Error
open System.Net
open System.Threading.Tasks
open Microsoft.AspNetCore.Http
open Giraffe
open Microsoft.AspNetCore.Http
open MyWebLog
/// Handle unauthorized actions, redirecting to log on for GETs, otherwise returning a 401 Not Authorized response
let notAuthorized : HttpHandler = fun next ctx ->
(next, ctx)
||> match ctx.Request.Method with
| "GET" -> redirectTo false $"/user/log-on?returnUrl={WebUtility.UrlEncode ctx.Request.Path}"
| _ -> setStatusCode 401 >=> fun _ _ -> Task.FromResult<HttpContext option> None
let notAuthorized : HttpHandler = fun next ctx -> task {
let webLog = ctx.Items["webLog"] :?> WebLog
if ctx.Request.Method = "GET" then
let returnUrl = WebUtility.UrlEncode ctx.Request.Path
return! redirectTo false (WebLog.relativeUrl webLog (Permalink $"user/log-on?returnUrl={returnUrl}")) next ctx
else
return! (setStatusCode 401 >=> fun _ _ -> Task.FromResult<HttpContext option> None) next ctx
}
/// Handle 404s from the API, sending known URL paths to the Vue app so that they can be handled there
let notFound : HttpHandler =

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

@@ -67,17 +67,18 @@ let generator (ctx : HttpContext) =
generatorString <- Option.ofObj cfg["Generator"]
defaultArg generatorString "generator not configured"
open DotLiquid
open MyWebLog
/// Get the web log for the request from the context (established by middleware)
let webLog (ctx : HttpContext) =
ctx.Items["webLog"] :?> WebLog
open DotLiquid
/// Either get the web log from the hash, or get it from the cache and add it to the hash
let private deriveWebLogFromHash (hash : Hash) ctx =
match hash.ContainsKey "web_log" with
| true -> hash["web_log"] :?> WebLog
| false ->
let wl = WebLogCache.get ctx
hash.Add ("web_log", wl)
wl
if hash.ContainsKey "web_log" then () else hash.Add ("web_log", webLog ctx)
hash["web_log"] :?> WebLog
open Giraffe
@@ -118,9 +119,6 @@ let redirectToGet url : HttpHandler = fun next ctx -> task {
return! redirectTo false url next ctx
}
/// Get the web log ID for the current request
let webLogId ctx = (WebLogCache.get ctx).id
open System.Security.Claims
/// Get the user ID for the current request
@@ -159,7 +157,7 @@ let templatesForTheme ctx (typ : string) =
seq {
KeyValuePair.Create ("", $"- Default (single-{typ}) -")
yield!
Path.Combine ("themes", (WebLogCache.get ctx).themePath)
Path.Combine ("themes", (webLog ctx).themePath)
|> Directory.EnumerateFiles
|> Seq.filter (fun it -> it.EndsWith $"{typ}.liquid")
|> Seq.map (fun it ->

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

@@ -2,21 +2,19 @@
module MyWebLog.Handlers.Post
open System
open Giraffe
open Microsoft.AspNetCore.Http
/// Split the "rest" capture for categories and tags into the page number and category/tag URL parts
let private pathAndPageNumber (ctx : HttpContext) =
let slugs = (string ctx.Request.RouteValues["slug"]).Split "/" |> Array.filter (fun it -> it <> "")
let pageIdx = Array.IndexOf (slugs, "page")
let pageNbr =
/// Parse a slug and page number from an "everything else" URL
let private parseSlugAndPage (slugAndPage : string seq) =
let slugs = (slugAndPage |> Seq.skip 1 |> Seq.head).Split "/" |> Array.filter (fun it -> it <> "")
let pageIdx = Array.IndexOf (slugs, "page")
let pageNbr =
match pageIdx with
| -1 -> Some 1L
| idx when idx + 2 = slugs.Length -> Some (int64 slugs[pageIdx + 1])
| -1 -> Some 1
| idx when idx + 2 = slugs.Length -> Some (int slugs[pageIdx + 1])
| _ -> None
let slugParts = if pageIdx > 0 then Array.truncate pageIdx slugs else slugs
pageNbr, String.Join ("/", slugParts)
/// The type of post list being prepared
type ListType =
| AdminList
@@ -47,10 +45,11 @@ open DotLiquid
open MyWebLog.ViewModels
/// Convert a list of posts into items ready to be displayed
let private preparePostList webLog posts listType url pageNbr perPage ctx conn = task {
let private preparePostList webLog posts listType (url : string) pageNbr perPage ctx conn = task {
let! authors = getAuthors webLog posts conn
let! tagMappings = getTagMappings webLog posts conn
let postItems =
let relUrl it = Some <| WebLog.relativeUrl webLog (Permalink it)
let postItems =
posts
|> Seq.ofList
|> Seq.truncate perPage
@@ -65,24 +64,24 @@ let private preparePostList webLog posts listType url pageNbr perPage ctx conn =
| _ -> Task.FromResult (None, None)
let newerLink =
match listType, pageNbr with
| SinglePost, _ -> newerPost |> Option.map (fun p -> Permalink.toString p.permalink)
| _, 1L -> None
| PostList, 2L when webLog.defaultPage = "posts" -> Some ""
| PostList, _ -> Some $"page/{pageNbr - 1L}"
| CategoryList, 2L -> Some $"category/{url}/"
| CategoryList, _ -> Some $"category/{url}/page/{pageNbr - 1L}"
| TagList, 2L -> Some $"tag/{url}/"
| TagList, _ -> Some $"tag/{url}/page/{pageNbr - 1L}"
| AdminList, 2L -> Some "admin/posts"
| AdminList, _ -> Some $"admin/posts/page/{pageNbr - 1L}"
| SinglePost, _ -> newerPost |> Option.map (fun p -> Permalink.toString p.permalink)
| _, 1 -> None
| PostList, 2 when webLog.defaultPage = "posts" -> Some ""
| PostList, _ -> relUrl $"page/{pageNbr - 1}"
| CategoryList, 2 -> relUrl $"category/{url}/"
| 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, _ -> 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)
| _, false -> None
| PostList, true -> Some $"page/{pageNbr + 1L}"
| CategoryList, true -> Some $"category/{url}/page/{pageNbr + 1L}"
| TagList, true -> Some $"tag/{url}/page/{pageNbr + 1L}"
| AdminList, true -> Some $"admin/posts/page/{pageNbr + 1L}"
| PostList, true -> relUrl $"page/{pageNbr + 1}"
| CategoryList, true -> relUrl $"category/{url}/page/{pageNbr + 1}"
| TagList, true -> relUrl $"tag/{url}/page/{pageNbr + 1}"
| AdminList, true -> relUrl $"admin/posts/page/{pageNbr + 1}"
let model =
{ posts = postItems
authors = authors
@@ -95,28 +94,30 @@ let private preparePostList webLog posts listType url pageNbr perPage ctx conn =
return Hash.FromAnonymousObject {| model = model; categories = CategoryCache.get ctx; tag_mappings = tagMappings |}
}
open Giraffe
// GET /page/{pageNbr}
let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
let webLog = WebLogCache.get ctx
let conn = conn ctx
let webLog = webLog ctx
let conn = conn ctx
let! posts = Data.Post.findPageOfPublishedPosts webLog.id pageNbr webLog.postsPerPage conn
let! hash = preparePostList webLog posts PostList "" pageNbr webLog.postsPerPage ctx conn
let title =
match pageNbr, webLog.defaultPage with
| 1L, "posts" -> None
| _, "posts" -> Some $"Page {pageNbr}"
| _, _ -> Some $"Page {pageNbr} &laquo; Posts"
| 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 = 1L && webLog.defaultPage = "posts" then hash.Add ("is_home", true)
if pageNbr = 1 && webLog.defaultPage = "posts" then hash.Add ("is_home", true)
return! themedView "index" next ctx hash
}
// GET /category/{slug}/
// GET /category/{slug}/page/{pageNbr}
let pageOfCategorizedPosts : HttpHandler = fun next ctx -> task {
let webLog = WebLogCache.get ctx
let conn = conn ctx
match pathAndPageNumber ctx with
let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx
let conn = conn ctx
match parseSlugAndPage slugAndPage with
| Some pageNbr, slug ->
let allCats = CategoryCache.get ctx
let cat = allCats |> Array.find (fun cat -> cat.slug = slug)
@@ -130,7 +131,7 @@ let pageOfCategorizedPosts : HttpHandler = fun next ctx -> task {
match! Data.Post.findPageOfCategorizedPosts webLog.id catIds pageNbr webLog.postsPerPage conn with
| posts when List.length posts > 0 ->
let! hash = preparePostList webLog posts CategoryList cat.slug pageNbr webLog.postsPerPage ctx conn
let pgTitle = if pageNbr = 1L then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
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", cat.description.Value)
hash.Add ("is_category", true)
@@ -143,10 +144,10 @@ open System.Web
// GET /tag/{tag}/
// GET /tag/{tag}/page/{pageNbr}
let pageOfTaggedPosts : HttpHandler = fun next ctx -> task {
let webLog = WebLogCache.get ctx
let conn = conn ctx
match pathAndPageNumber ctx with
let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
let webLog = webLog ctx
let conn = conn ctx
match parseSlugAndPage slugAndPage with
| Some pageNbr, rawTag ->
let urlTag = HttpUtility.UrlDecode rawTag
let! tag = backgroundTask {
@@ -157,7 +158,7 @@ let pageOfTaggedPosts : HttpHandler = fun next ctx -> task {
match! Data.Post.findPageOfTaggedPosts webLog.id tag pageNbr webLog.postsPerPage conn with
| posts when List.length posts > 0 ->
let! hash = preparePostList webLog posts TagList rawTag pageNbr webLog.postsPerPage ctx conn
let pgTitle = if pageNbr = 1L then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
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)
return! themedView "index" next ctx hash
@@ -166,15 +167,18 @@ let pageOfTaggedPosts : HttpHandler = fun next ctx -> task {
let spacedTag = tag.Replace ("-", " ")
match! Data.Post.findPageOfTaggedPosts webLog.id spacedTag pageNbr 1 conn with
| posts when List.length posts > 0 ->
let endUrl = if pageNbr = 1L then "" else $"page/{pageNbr}"
return! redirectTo true $"""/tag/{spacedTag.Replace (" ", "+")}/{endUrl}""" next ctx
let endUrl = if pageNbr = 1 then "" else $"page/{pageNbr}"
return!
redirectTo true
(WebLog.relativeUrl webLog (Permalink $"""tag/{spacedTag.Replace (" ", "+")}/{endUrl}"""))
next ctx
| _ -> return! Error.notFound next ctx
| None, _ -> return! Error.notFound next ctx
}
// GET /
let home : HttpHandler = fun next ctx -> task {
let webLog = WebLogCache.get ctx
let webLog = webLog ctx
match webLog.defaultPage with
| "posts" -> return! pageOfPosts 1 next ctx
| pageId ->
@@ -190,6 +194,7 @@ let home : HttpHandler = fun next ctx -> task {
| None -> return! Error.notFound next ctx
}
open System.IO
open System.ServiceModel.Syndication
open System.Text.RegularExpressions
@@ -198,12 +203,12 @@ open System.Xml
// GET /feed.xml
// (Routing handled by catch-all handler for future configurability)
let generateFeed : HttpHandler = fun next ctx -> backgroundTask {
let conn = conn ctx
let webLog = WebLogCache.get ctx
let urlBase = $"https://{webLog.urlBase}/"
let conn = conn ctx
let webLog = webLog ctx
// TODO: hard-coded number of items
let! posts = Data.Post.findPageOfPublishedPosts webLog.id 1L 10 conn
let! authors = getAuthors webLog posts conn
let! posts = Data.Post.findPageOfPublishedPosts webLog.id 1 10 conn
let! authors = getAuthors webLog posts conn
let! tagMaps = getTagMappings webLog posts conn
let cats = CategoryCache.get ctx
let toItem (post : Post) =
@@ -213,25 +218,29 @@ let generateFeed : HttpHandler = fun next ctx -> backgroundTask {
| txt when txt.Length < 255 -> txt
| txt -> $"{txt.Substring (0, 252)}..."
let item = SyndicationItem (
Id = $"{urlBase}{Permalink.toString post.permalink}",
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)
let encoded = post.text.Replace("src=\"/", $"src=\"{urlBase}").Replace ("href=\"/", $"href=\"{urlBase}")
let encoded =
post.text.Replace("src=\"/", $"src=\"{webLog.urlBase}/").Replace ("href=\"/", $"href=\"{webLog.urlBase}/")
item.ElementExtensions.Add ("encoded", "http://purl.org/rss/1.0/modules/content/", encoded)
item.Authors.Add (SyndicationPerson (
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, $"{urlBase}category/{cat.slug}/", cat.name))
SyndicationCategory (cat.name, WebLog.absoluteUrl webLog (Permalink $"category/{cat.slug}/"), cat.name))
post.tags
|> List.map (fun tag ->
let urlTag = tag.Replace (" ", "+")
SyndicationCategory (tag, $"{urlBase}tag/{urlTag}/", $"{tag} (tag)"))
let urlTag =
match tagMaps |> List.tryFind (fun tm -> tm.tag = tag) with
| Some tm -> tm.urlValue
| None -> tag.Replace (" ", "+")
SyndicationCategory (tag, WebLog.absoluteUrl webLog (Permalink $"tag/{urlTag}/"), $"{tag} (tag)"))
]
|> List.concat
|> List.iter item.Categories.Add
@@ -245,12 +254,12 @@ let generateFeed : HttpHandler = fun next ctx -> backgroundTask {
feed.Generator <- generator ctx
feed.Items <- posts |> Seq.ofList |> Seq.map toItem
feed.Language <- "en"
feed.Id <- urlBase
feed.Id <- webLog.urlBase
feed.Links.Add (SyndicationLink (Uri $"{urlBase}feed.xml", "self", "", "application/rss+xml", 0L))
feed.Links.Add (SyndicationLink (Uri $"{webLog.urlBase}/feed.xml", "self", "", "application/rss+xml", 0L))
feed.AttributeExtensions.Add
(XmlQualifiedName ("content", "http://www.w3.org/2000/xmlns/"), "http://purl.org/rss/1.0/modules/content/")
feed.ElementExtensions.Add ("link", "", urlBase)
feed.ElementExtensions.Add ("link", "", webLog.urlBase)
use mem = new MemoryStream ()
use xml = XmlWriter.Create mem
@@ -266,15 +275,18 @@ let generateFeed : HttpHandler = fun next ctx -> backgroundTask {
/// Sequence where the first returned value is the proper handler for the link
let private deriveAction ctx : HttpHandler seq =
let webLog = WebLogCache.get ctx
let conn = conn ctx
let textLink = string ctx.Request.RouteValues["link"]
let permalink = Permalink textLink
let webLog = webLog ctx
let conn = conn ctx
let _, extra = WebLog.hostAndPath webLog
let textLink = if extra = "" then ctx.Request.Path.Value else ctx.Request.Path.Value.Substring extra.Length
let await it = (Async.AwaitTask >> Async.RunSynchronously) it
seq {
// Home page directory without the directory slash
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 conn |> await with
| Some post ->
| Some post ->
let model = preparePostList webLog [ post ] SinglePost "" 1 1 ctx conn |> await
model.Add ("page_title", post.title)
yield fun next ctx -> themedView "single-post" next ctx model
@@ -288,27 +300,27 @@ let private deriveAction ctx : HttpHandler seq =
| None -> ()
// RSS feed
// TODO: configure this via web log
if textLink = "feed.xml" then yield generateFeed
if textLink = "/feed.xml" then yield generateFeed
// Post differing only by trailing slash
let altLink = Permalink (if textLink.EndsWith "/" then textLink[..textLink.Length - 2] else $"{textLink}/")
match Data.Post.findByPermalink altLink webLog.id conn |> await with
| Some post -> yield redirectTo true $"/{Permalink.toString post.permalink}"
| Some post -> yield redirectTo true (WebLog.relativeUrl webLog post.permalink)
| None -> ()
// Page differing only by trailing slash
match Data.Page.findByPermalink altLink webLog.id conn |> await with
| Some page -> yield redirectTo true $"/{Permalink.toString page.permalink}"
| Some page -> yield redirectTo true (WebLog.relativeUrl webLog page.permalink)
| None -> ()
// Prior post
match Data.Post.findCurrentPermalink [ permalink; altLink ] webLog.id conn |> await with
| Some link -> yield redirectTo true $"/{Permalink.toString link}"
| Some link -> yield redirectTo true (WebLog.relativeUrl webLog link)
| None -> ()
// Prior page
match Data.Page.findCurrentPermalink [ permalink; altLink ] webLog.id conn |> await with
| Some link -> yield redirectTo true $"/{Permalink.toString link}"
| Some link -> yield redirectTo true (WebLog.relativeUrl webLog link)
| None -> ()
}
// GET {**link}
// GET {all-of-the-above}
let catchAll : HttpHandler = fun next ctx -> task {
match deriveAction ctx |> Seq.tryHead with
| Some handler -> return! handler next ctx
@@ -318,8 +330,8 @@ let catchAll : HttpHandler = fun next ctx -> task {
// GET /admin/posts
// GET /admin/posts/page/{pageNbr}
let all pageNbr : HttpHandler = requireUser >=> fun next ctx -> task {
let webLog = WebLogCache.get ctx
let conn = conn ctx
let webLog = webLog ctx
let conn = conn ctx
let! posts = Data.Post.findPageOfPosts webLog.id pageNbr 25 conn
let! hash = preparePostList webLog posts AdminList "" pageNbr 25 ctx conn
hash.Add ("page_title", "Posts")
@@ -328,8 +340,8 @@ let all pageNbr : HttpHandler = requireUser >=> fun next ctx -> task {
// GET /admin/post/{id}/edit
let edit postId : HttpHandler = requireUser >=> fun next ctx -> task {
let webLog = WebLogCache.get ctx
let conn = conn ctx
let webLog = webLog ctx
let conn = conn ctx
let! result = task {
match postId with
| "new" -> return Some ("Write a New Post", { Post.empty with id = PostId "new" })
@@ -354,7 +366,7 @@ let edit postId : HttpHandler = requireUser >=> fun next ctx -> task {
// GET /admin/post/{id}/permalinks
let editPermalinks postId : HttpHandler = requireUser >=> fun next ctx -> task {
match! Data.Post.findByFullId (PostId postId) (webLogId ctx) (conn ctx) with
match! Data.Post.findByFullId (PostId postId) (webLog ctx).id (conn ctx) with
| Some post ->
return!
Hash.FromAnonymousObject {|
@@ -368,41 +380,43 @@ let editPermalinks postId : HttpHandler = requireUser >=> fun next ctx -> task {
// POST /admin/post/permalinks
let savePermalinks : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
let links = model.prior |> Array.map Permalink |> List.ofArray
match! Data.Post.updatePriorPermalinks (PostId model.id) (webLogId ctx) links (conn ctx) with
let webLog = webLog ctx
let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
let links = model.prior |> Array.map Permalink |> List.ofArray
match! Data.Post.updatePriorPermalinks (PostId model.id) webLog.id links (conn ctx) with
| true ->
do! addMessage ctx { UserMessage.success with message = "Post permalinks saved successfully" }
return! redirectToGet $"/admin/post/{model.id}/permalinks" next ctx
return! redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/post/{model.id}/permalinks")) next ctx
| false -> return! Error.notFound next ctx
}
// POST /admin/post/{id}/delete
let delete postId : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
match! Data.Post.delete (PostId postId) (webLogId ctx) (conn ctx) with
let webLog = webLog ctx
match! Data.Post.delete (PostId postId) webLog.id (conn ctx) 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
return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/posts")) next ctx
}
#nowarn "3511"
// POST /admin/post/save
let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPostModel> ()
let webLogId = webLogId ctx
let conn = conn ctx
let now = DateTime.UtcNow
let! pst = task {
let! model = ctx.BindFormAsync<EditPostModel> ()
let webLog = webLog ctx
let conn = conn ctx
let now = DateTime.UtcNow
let! pst = task {
match model.postId with
| "new" ->
return Some
{ Post.empty with
id = PostId.create ()
webLogId = webLogId
webLogId = webLog.id
authorId = userId ctx
}
| postId -> return! Data.Post.findByFullId (PostId postId) webLogId conn
| postId -> return! Data.Post.findByFullId (PostId postId) webLog.id conn
}
match pst with
| Some post ->
@@ -460,6 +474,7 @@ let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
|> List.length = List.length pst.Value.categoryIds) 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 (WebLog.relativeUrl webLog (Permalink $"admin/post/{PostId.toString post.id}/edit")) next ctx
| None -> return! Error.notFound next ctx
}

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

@@ -1,75 +1,89 @@
/// Routes for this application
module MyWebLog.Handlers.Routes
open Giraffe
open MyWebLog
let router : HttpHandler = choose [
GET >=> choose [
route "/" >=> Post.home
]
subRoute "/admin" (requireUser >=> choose [
GET >=> choose [
route "" >=> Admin.dashboard
subRoute "/categor" (choose [
route "ies" >=> Admin.listCategories
routef "y/%s/edit" Admin.editCategory
])
subRoute "/page" (choose [
route "s" >=> Admin.listPages 1
routef "s/page/%i" Admin.listPages
routef "/%s/edit" Admin.editPage
routef "/%s/permalinks" Admin.editPagePermalinks
])
subRoute "/post" (choose [
route "s" >=> Post.all 1
routef "s/page/%i" Post.all
routef "/%s/edit" Post.edit
routef "/%s/permalinks" Post.editPermalinks
])
route "/settings" >=> Admin.settings
subRoute "/tag-mapping" (choose [
route "s" >=> Admin.tagMappings
routef "/%s/edit" Admin.editMapping
])
route "/user/edit" >=> User.edit
]
POST >=> choose [
subRoute "/category" (choose [
route "/save" >=> Admin.saveCategory
routef "/%s/delete" Admin.deleteCategory
])
subRoute "/page" (choose [
route "/save" >=> Admin.savePage
route "/permalinks" >=> Admin.savePagePermalinks
routef "/%s/delete" Admin.deletePage
])
subRoute "/post" (choose [
route "/save" >=> Post.save
route "/permalinks" >=> Post.savePermalinks
routef "/%s/delete" Post.delete
])
route "/settings" >=> Admin.saveSettings
subRoute "/tag-mapping" (choose [
route "/save" >=> Admin.saveMapping
routef "/%s/delete" Admin.deleteMapping
])
route "/user/save" >=> User.save
]
])
GET >=> routexp "/category/(.*)" Post.pageOfCategorizedPosts
GET >=> routef "/page/%i" Post.pageOfPosts
GET >=> routexp "/tag/(.*)" Post.pageOfTaggedPosts
subRoute "/user" (choose [
GET >=> choose [
route "/log-on" >=> User.logOn None
route "/log-off" >=> User.logOff
]
POST >=> choose [
route "/log-on" >=> User.doLogOn
]
])
GET >=> Post.catchAll
Error.notFound
]
/// Wrap a router in a sub-route
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 _, extraPath = WebLog.hostAndPath (webLog ctx)
return! (if extraPath = "" then router else routerWithPath extraPath) next ctx
}
open Giraffe.EndpointRouting
/// The endpoints defined in the above handlers
let endpoints = [
GET [
route "/" Post.home
]
subRoute "/admin" [
GET [
route "" Admin.dashboard
subRoute "/categor" [
route "ies" Admin.listCategories
routef "y/%s/edit" Admin.editCategory
]
subRoute "/page" [
route "s" (Admin.listPages 1)
routef "s/page/%d" Admin.listPages
routef "/%s/edit" Admin.editPage
routef "/%s/permalinks" Admin.editPagePermalinks
]
subRoute "/post" [
route "s" (Post.all 1)
routef "s/page/%d" Post.all
routef "/%s/edit" Post.edit
routef "/%s/permalinks" Post.editPermalinks
]
route "/settings" Admin.settings
subRoute "/tag-mapping" [
route "s" Admin.tagMappings
routef "/%s/edit" Admin.editMapping
]
route "/user/edit" User.edit
]
POST [
subRoute "/category" [
route "/save" Admin.saveCategory
routef "/%s/delete" Admin.deleteCategory
]
subRoute "/page" [
route "/save" Admin.savePage
route "/permalinks" Admin.savePagePermalinks
routef "/%s/delete" Admin.deletePage
]
subRoute "/post" [
route "/save" Post.save
route "/permalinks" Post.savePermalinks
routef "/%s/delete" Post.delete
]
route "/settings" Admin.saveSettings
subRoute "/tag-mapping" [
route "/save" Admin.saveMapping
routef "/%s/delete" Admin.deleteMapping
]
route "/user/save" User.save
]
]
GET [
route "/category/{**slug}" Post.pageOfCategorizedPosts
routef "/page/%d" Post.pageOfPosts
route "/tag/{**slug}" Post.pageOfTaggedPosts
]
subRoute "/user" [
GET [
route "/log-on" (User.logOn None)
route "/log-off" User.logOff
]
POST [
route "/log-on" User.doLogOn
]
]
route "{**link}" Post.catchAll
]
/// Endpoint-routed handler to deal with sub-routes
let endpoint = [ route "{**url}" handleRoute ]

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

@@ -41,7 +41,7 @@ open MyWebLog
// POST /user/log-on
let doLogOn : HttpHandler = validateCsrf >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<LogOnModel> ()
let webLog = WebLogCache.get ctx
let webLog = webLog ctx
match! Data.WebLogUser.findByEmail model.emailAddress webLog.id (conn ctx) with
| Some user when user.passwordHash = hashedPassword model.password user.userName user.salt ->
let claims = seq {
@@ -56,7 +56,7 @@ let doLogOn : HttpHandler = validateCsrf >=> fun next ctx -> task {
AuthenticationProperties (IssuedUtc = DateTimeOffset.UtcNow))
do! addMessage ctx
{ UserMessage.success with message = $"Logged on successfully | Welcome to {webLog.name}!" }
return! redirectToGet (match model.returnTo with Some url -> url | None -> "/admin") next ctx
return! redirectToGet (defaultArg model.returnTo (WebLog.relativeUrl webLog (Permalink "admin"))) next ctx
| _ ->
do! addMessage ctx { UserMessage.error with message = "Log on attempt unsuccessful" }
return! logOn model.returnTo next ctx
@@ -66,7 +66,7 @@ let doLogOn : HttpHandler = validateCsrf >=> fun next ctx -> task {
let logOff : HttpHandler = fun next ctx -> task {
do! ctx.SignOutAsync CookieAuthenticationDefaults.AuthenticationScheme
do! addMessage ctx { UserMessage.info with message = "Log off successful" }
return! redirectToGet "/" next ctx
return! redirectToGet (WebLog.relativeUrl (webLog ctx) Permalink.empty) next ctx
}
/// Display the user edit page, with information possibly filled in
@@ -107,7 +107,7 @@ let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
do! Data.WebLogUser.update user conn
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
return! redirectToGet (WebLog.relativeUrl (webLog ctx) (Permalink "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" }