diff --git a/src/MyWebLog.Data/Data.fs b/src/MyWebLog.Data/Data.fs index 0feeefa..47eab12 100644 --- a/src/MyWebLog.Data/Data.fs +++ b/src/MyWebLog.Data/Data.fs @@ -82,14 +82,16 @@ module Startup = indexCreate "priorPermalinks" [ Multi ] write; withRetryOnce; ignoreResult conn } - // Post needs index by category (used for counting posts) - if Table.Post = table && not (indexes |> List.contains "categoryIds") then - log.LogInformation $"Creating index {table}.categoryIds..." - do! rethink { - withTable table - indexCreate "categoryIds" [ Multi ] - write; withRetryOnce; ignoreResult conn - } + // Post needs indexes by category and tag (used for counting and retrieving posts) + if Table.Post = table then + for idx in [ "categoryIds"; "tags" ] do + if not (List.contains idx indexes) then + log.LogInformation $"Creating index {table}.{idx}..." + do! rethink { + withTable table + indexCreate idx [ Multi ] + write; withRetryOnce; ignoreResult conn + } // Users log on with e-mail if Table.WebLogUser = table && not (indexes |> List.contains "logOn") then log.LogInformation $"Creating index {table}.logOn..." @@ -194,6 +196,7 @@ module Category = withTable Table.Post getAll catIds "categoryIds" filter "status" Published + distinct count result; withRetryDefault conn } @@ -395,6 +398,8 @@ module Page = /// Functions to manipulate posts module Post = + open System + /// Add a post let add (post : Post) = rethink { @@ -445,6 +450,22 @@ module Post = } |> tryFirst + /// Find posts to be displayed on a category list page + let findPageOfCategorizedPosts (webLogId : WebLogId) (catIds : CategoryId list) (pageNbr : int64) postsPerPage = + let pg = int pageNbr + rethink { + withTable Table.Post + getAll (catIds |> List.map (fun it -> it :> obj)) "categoryIds" + filter "webLogId" webLogId + filter "status" Published + without [ "priorPermalinks"; "revisions" ] + distinct + orderByDescending "publishedOn" + skip ((pg - 1) * postsPerPage) + limit (postsPerPage + 1) + result; withRetryDefault + } + /// Find posts to be displayed on an admin page let findPageOfPosts (webLogId : WebLogId) (pageNbr : int64) postsPerPage = let pg = int pageNbr @@ -472,6 +493,46 @@ module Post = result; withRetryDefault } + /// Find posts to be displayed on a tag list page + let findPageOfTaggedPosts (webLogId : WebLogId) (tag : string) (pageNbr : int64) postsPerPage = + let pg = int pageNbr + rethink { + withTable Table.Post + getAll [ tag ] "tags" + filter "webLogId" webLogId + filter "status" Published + without [ "priorPermalinks"; "revisions" ] + orderByDescending "publishedOn" + skip ((pg - 1) * postsPerPage) + limit (postsPerPage + 1) + result; withRetryDefault + } + + /// Find the next older and newer post for the given post + let findSurroundingPosts (webLogId : WebLogId) (publishedOn : DateTime) conn = backgroundTask { + let! older = + rethink { + withTable Table.Post + getAll [ webLogId ] (nameof webLogId) + filter (fun row -> row.G("publishedOn").Lt publishedOn :> obj) + orderByDescending "publishedOn" + limit 1 + result; withRetryDefault + } + |> tryFirst <| conn + let! newer = + rethink { + withTable Table.Post + getAll [ webLogId ] (nameof webLogId) + filter (fun row -> row.G("publishedOn").Gt publishedOn :> obj) + orderBy "publishedOn" + limit 1 + result; withRetryDefault + } + |> tryFirst <| conn + return older, newer + } + /// Update a post (all fields are updated) let update (post : Post) = rethink { @@ -542,6 +603,14 @@ module WebLogUser = } |> tryFirst + /// Find a user by their ID + let findById (userId : WebLogUserId) = + rethink { + withTable Table.WebLogUser + get userId + resultOption; withRetryOptionDefault + } + /// Get a user ID -> name dictionary for the given user IDs let findNames (webLogId : WebLogId) conn (userIds : WebLogUserId list) = backgroundTask { let! users = rethink { @@ -552,3 +621,19 @@ module WebLogUser = } return users |> List.map (fun u -> { name = WebLogUserId.toString u.id; value = WebLogUser.displayName u }) } + + /// Update a user + let update (user : WebLogUser) = + rethink { + withTable Table.WebLogUser + get user.id + update [ + "firstName", user.firstName :> obj + "lastName", user.lastName + "preferredName", user.preferredName + "passwordHash", user.passwordHash + "salt", user.salt + ] + write; withRetryDefault; ignoreResult + } + \ No newline at end of file diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index ca2d46e..34ddfd4 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -14,7 +14,7 @@ - + diff --git a/src/MyWebLog.Domain/ViewModels.fs b/src/MyWebLog.Domain/ViewModels.fs index 18df515..ab2c521 100644 --- a/src/MyWebLog.Domain/ViewModels.fs +++ b/src/MyWebLog.Domain/ViewModels.fs @@ -255,6 +255,32 @@ type EditPostModel = } +/// View model to edit a user +[] +type EditUserModel = + { /// The user's first name + firstName : string + + /// The user's last name + lastName : string + + /// The user's preferred name + preferredName : string + + /// A new password for the user + newPassword : string + + /// A new password for the user, confirmed + newPasswordConfirm : string + } + /// Create an edit model from a user + static member fromUser (user : WebLogUser) = + { firstName = user.firstName + lastName = user.lastName + preferredName = user.preferredName + newPassword = "" + newPasswordConfirm = "" + } /// The model to use to allow a user to log on [] type LogOnModel = @@ -342,8 +368,14 @@ type PostDisplay = /// The link to view newer (more recent) posts newerLink : string option + /// The name of the next newer post (single-post only) + newerName : string option + /// The link to view older (less recent) posts olderLink : string option + + /// The name of the next older post (single-post only) + olderName : string option } diff --git a/src/MyWebLog/Handlers.fs b/src/MyWebLog/Handlers.fs index 2fff220..08eb4b2 100644 --- a/src/MyWebLog/Handlers.fs +++ b/src/MyWebLog/Handlers.fs @@ -1,15 +1,16 @@ [] module MyWebLog.Handlers +open System +open System.Net +open System.Threading.Tasks +open System.Web open DotLiquid open Giraffe open Microsoft.AspNetCore.Http open MyWebLog open MyWebLog.ViewModels open RethinkDb.Driver.Net -open System -open System.Net -open System.Threading.Tasks /// Handlers for error conditions module Error = @@ -99,7 +100,7 @@ module private Helpers = let mutable private generatorString : string option = None /// Get the generator string - let private generator (ctx : HttpContext) = + let generator (ctx : HttpContext) = if Option.isNone generatorString then let cfg = ctx.RequestServices.GetRequiredService () generatorString <- Option.ofObj cfg["Generator"] @@ -454,55 +455,78 @@ module Page = | None -> return! Error.notFound next ctx } - + /// Handlers to manipulate posts module Post = + open System.IO + open System.ServiceModel.Syndication + open System.Xml + + /// 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 = if pageIdx > 0 then (int64 slugs[pageIdx + 1]) else 1L + 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 | CategoryList - | TagList | PostList | SinglePost - | AdminList + | TagList + /// Get all authors for a list of posts as metadata items + let private getAuthors (webLog : WebLog) (posts : Post list) conn = + posts + |> List.map (fun p -> p.authorId) + |> List.distinct + |> Data.WebLogUser.findNames webLog.id conn + /// Convert a list of posts into items ready to be displayed - let private preparePostList (webLog : WebLog) (posts : Post list) listType pageNbr perPage ctx conn = task { - let! authors = - posts - |> List.map (fun p -> p.authorId) - |> List.distinct - |> Data.WebLogUser.findNames webLog.id conn + let private preparePostList webLog posts listType url pageNbr perPage ctx conn = task { + let! authors = getAuthors webLog posts conn let postItems = posts |> Seq.ofList |> Seq.truncate perPage |> Seq.map (PostListItem.fromPost webLog) |> Array.ofSeq + let! olderPost, newerPost = + match listType with + | SinglePost -> Data.Post.findSurroundingPosts webLog.id (List.head posts).publishedOn.Value conn + | _ -> Task.FromResult (None, None) let newerLink = match listType, pageNbr with - | SinglePost, _ -> Some "TODO: retrieve prior post" + | 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, _ -> Some "TODO" - | TagList, _ -> Some "TODO" + | 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 "posts" | AdminList, _ -> Some $"posts/page/{pageNbr - 1L}" let olderLink = match listType, List.length posts > perPage with - | SinglePost, _ -> Some "TODO: retrieve next post" + | SinglePost, _ -> olderPost |> Option.map (fun p -> Permalink.toString p.permalink) | _, false -> None | PostList, true -> Some $"page/{pageNbr + 1L}" - | CategoryList, true -> Some $"category/TODO-slug-goes-here/page/{pageNbr + 1L}" - | TagList, true -> Some $"tag/TODO-slug-goes-here/page/{pageNbr + 1L}" + | CategoryList, true -> Some $"category/{url}/page/{pageNbr + 1L}" + | TagList, true -> Some $"tag/{url}/page/{pageNbr + 1L}" | AdminList, true -> Some $"posts/page/{pageNbr + 1L}" 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) } return Hash.FromAnonymousObject {| model = model; categories = CategoryCache.get ctx |} } @@ -512,15 +536,59 @@ module Post = let webLog = WebLogCache.get 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! 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} « Posts" match title with Some ttl -> hash.Add ("page_title", ttl) | None -> () + if pageNbr = 1L && 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 + let pageNbr, slug = pathAndPageNumber ctx + let allCats = CategoryCache.get ctx + let cat = allCats |> Array.find (fun cat -> cat.slug = slug) + // Category pages include posts in subcategories + let catIds = + allCats + |> Seq.ofArray + |> Seq.filter (fun c -> c.id = cat.id || Array.contains cat.name c.parentNames) + |> Seq.map (fun c -> CategoryId c.id) + |> List.ofSeq + 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 $""" (Page {pageNbr})""" + hash.Add ("page_title", $"{cat.name}: Category Archive{pgTitle}") + hash.Add ("subtitle", cat.description.Value) + hash.Add ("is_category", true) + return! themedView "index" next ctx hash + | _ -> return! Error.notFound next ctx + } + + // GET /tag/{tag}/ + // GET /tag/{tag}/page/{pageNbr} + let pageOfTaggedPosts : HttpHandler = fun next ctx -> task { + let webLog = WebLogCache.get ctx + let conn = conn ctx + let pageNbr, rawTag = pathAndPageNumber ctx + let tag = HttpUtility.UrlDecode rawTag + 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 $""" (Page {pageNbr})""" + hash.Add ("page_title", $"Posts Tagged “{tag}”{pgTitle}") + hash.Add ("is_tag", true) + return! themedView "index" next ctx hash + | _ -> return! Error.notFound next ctx + } // GET / let home : HttpHandler = fun next ctx -> task { @@ -531,41 +599,108 @@ module Post = match! Data.Page.findById (PageId pageId) webLog.id (conn ctx) with | Some page -> return! - Hash.FromAnonymousObject {| page = DisplayPage.fromPage webLog page; page_title = page.title |} + Hash.FromAnonymousObject {| + page = DisplayPage.fromPage webLog page + page_title = page.title + is_home = true + |} |> themedView (defaultArg page.template "single-page") next ctx | None -> return! Error.notFound next ctx } - // GET {**link} - let catchAll : HttpHandler = fun next ctx -> task { + // 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 + // TODO: hard-coded number of items + let! posts = Data.Post.findPageOfPublishedPosts webLog.id 1L 10 conn + let! authors = getAuthors webLog posts conn + let cats = CategoryCache.get ctx + + let toItem (post : Post) = + let urlBase = $"https://{webLog.urlBase}/" + let item = SyndicationItem ( + Id = $"{urlBase}{Permalink.toString post.permalink}", + Title = TextSyndicationContent.CreateHtmlContent post.title, + PublishDate = DateTimeOffset post.publishedOn.Value) + item.AddPermalink (Uri item.Id) + let doc = XmlDocument () + let content = doc.CreateElement ("content", "encoded", "http://purl.org/rss/1.0/modules/content/") + content.InnerText <- post.text + .Replace("src=\"/", $"src=\"{urlBase}") + .Replace ("href=\"/", $"href=\"{urlBase}") + item.ElementExtensions.Add content + item.Authors.Add (SyndicationPerson ( + Name = (authors |> List.find (fun a -> a.name = WebLogUserId.toString post.authorId)).value)) + for catId in post.categoryIds do + let cat = cats |> Array.find (fun c -> c.id = CategoryId.toString catId) + item.Categories.Add (SyndicationCategory (cat.name, $"{urlBase}category/{cat.slug}/", cat.name)) + for tag in post.tags do + let urlTag = tag.Replace (" ", "+") + item.Categories.Add (SyndicationCategory (tag, $"{urlBase}tag/{urlTag}/", $"{tag} (tag)")) + item + + + let feed = SyndicationFeed () + feed.Title <- TextSyndicationContent webLog.name + feed.Description <- TextSyndicationContent <| defaultArg webLog.subtitle webLog.name + feed.LastUpdatedTime <- DateTimeOffset <| (List.head posts).updatedOn + feed.Generator <- generator ctx + feed.Items <- posts |> Seq.ofList |> Seq.map toItem + + use mem = new MemoryStream () + use xml = XmlWriter.Create mem + let formatter = Rss20FeedFormatter feed + formatter.WriteTo xml + xml.Close () + + let _ = mem.Seek (0L, SeekOrigin.Begin) + let rdr = new StreamReader(mem) + let! output = rdr.ReadToEndAsync () + + return! ( setHttpHeader "Content-Type" "text/xml" >=> setStatusCode 200 >=> setBodyFromString output) next ctx + } + + /// 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 permalink = (string >> Permalink) ctx.Request.RouteValues["link"] - // Current post - match! Data.Post.findByPermalink permalink webLog.id conn with - | Some post -> - let! model = preparePostList webLog [ post ] SinglePost 1 1 ctx conn - model.Add ("page_title", post.title) - return! themedView "single-post" next ctx model - | None -> + let await it = (Async.AwaitTask >> Async.RunSynchronously) it + seq { + // Current post + match Data.Post.findByPermalink permalink webLog.id conn |> await with + | 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 + | None -> () // Current page - match! Data.Page.findByPermalink permalink webLog.id conn with + match Data.Page.findByPermalink permalink webLog.id conn |> await with | Some page -> - return! + yield fun next ctx -> Hash.FromAnonymousObject {| page = DisplayPage.fromPage webLog page; page_title = page.title |} |> themedView (defaultArg page.template "single-page") next ctx - | None -> - // Prior post - match! Data.Post.findCurrentPermalink permalink webLog.id conn with - | Some link -> return! redirectTo true $"/{Permalink.toString link}" next ctx - | None -> - // Prior page - match! Data.Page.findCurrentPermalink permalink webLog.id conn with - | Some link -> return! redirectTo true $"/{Permalink.toString link}" next ctx - | None -> - // We tried, we really did... - Console.Write($"Returning 404 for permalink |{permalink}|"); - return! Error.notFound next ctx + | None -> () + // RSS feed + // TODO: configure this via web log + if Permalink.toString permalink = "feed.xml" then yield generateFeed + // Prior post + match Data.Post.findCurrentPermalink permalink webLog.id conn |> await with + | Some link -> yield redirectTo true $"/{Permalink.toString link}" + | None -> () + // Prior permalink + match Data.Page.findCurrentPermalink permalink webLog.id conn |> await with + | Some link -> yield redirectTo true $"/{Permalink.toString link}" + | None -> () + } + + // GET {**link} + let catchAll : HttpHandler = fun next ctx -> task { + match deriveAction ctx |> Seq.tryHead with + | Some handler -> return! handler next ctx + | None -> return! Error.notFound next ctx } // GET /posts @@ -574,7 +709,7 @@ module Post = let webLog = WebLogCache.get 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 + let! hash = preparePostList webLog posts AdminList "" pageNbr 25 ctx conn hash.Add ("page_title", "Posts") return! viewForTheme "admin" "post-list" next ctx hash } @@ -746,6 +881,52 @@ module User = 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", csrfToken ctx) + return! viewForTheme "admin" "user-edit" next ctx hash + } + + // GET /user/edit + let edit : HttpHandler = requireUser >=> fun next ctx -> task { + match! Data.WebLogUser.findById (userId ctx) (conn ctx) with + | Some user -> return! showEdit (Hash.FromAnonymousObject {| model = EditUserModel.fromUser user |}) next ctx + | None -> return! Error.notFound next ctx + } + + // POST /user/save + let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { + let! model = ctx.BindFormAsync () + if model.newPassword = model.newPasswordConfirm then + let conn = conn ctx + match! Data.WebLogUser.findById (userId ctx) conn with + | Some user -> + let pw, salt = + if model.newPassword = "" then + user.passwordHash, user.salt + else + let newSalt = Guid.NewGuid () + hashedPassword model.newPassword user.userName newSalt, newSalt + let user = + { user with + firstName = model.firstName + lastName = model.lastName + preferredName = model.preferredName + passwordHash = pw + salt = salt + } + 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 "/user/edit" next ctx + | None -> return! Error.notFound next ctx + else + do! addMessage ctx { UserMessage.error with message = "Passwords did not match; no updates made" } + return! showEdit (Hash.FromAnonymousObject {| + model = { model with newPassword = ""; newPasswordConfirm = "" } + |}) next ctx + } open Giraffe.EndpointRouting @@ -765,8 +946,9 @@ let endpoints = [ ] subRoute "/categor" [ GET [ - route "ies" Category.all - routef "y/%s/edit" Category.edit + route "ies" Category.all + routef "y/%s/edit" Category.edit + route "y/{**slug}" Post.pageOfCategorizedPosts ] POST [ route "y/save" Category.save @@ -776,6 +958,7 @@ let endpoints = [ subRoute "/page" [ GET [ routef "/%d" Post.pageOfPosts + //routef "/%d/" (fun pg -> redirectTo true $"/page/{pg}") routef "/%s/edit" Page.edit route "s" (Page.all 1) routef "s/page/%d" Page.all @@ -794,13 +977,20 @@ let endpoints = [ route "/save" Post.save ] ] + subRoute "/tag" [ + GET [ + route "/{**slug}" Post.pageOfTaggedPosts + ] + ] subRoute "/user" [ GET [ + route "/edit" User.edit route "/log-on" (User.logOn None) route "/log-off" User.logOff ] POST [ route "/log-on" User.doLogOn + route "/save" User.save ] ] route "{**link}" Post.catchAll diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index 49ea0f1..ca515e6 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -207,9 +207,9 @@ let main args = [ // Domain types typeof; typeof; typeof // View models - typeof; typeof; typeof; typeof - typeof; typeof; typeof; typeof - typeof; typeof; typeof + typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof + typeof; typeof; typeof; typeof // Framework types typeof; typeof; typeof; typeof typeof diff --git a/src/MyWebLog/themes/admin/layout.liquid b/src/MyWebLog/themes/admin/layout.liquid index 736ad76..87ee26e 100644 --- a/src/MyWebLog/themes/admin/layout.liquid +++ b/src/MyWebLog/themes/admin/layout.liquid @@ -28,6 +28,7 @@ {%- endif %}