From 20b7ba1150031b34c412240f8a3cb9b5d159e7f3 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Wed, 18 May 2022 17:04:10 -0400 Subject: [PATCH] Split handlers into individual files - Fix 500 when viewing draft posts --- src/MyWebLog.Data/MyWebLog.Data.fsproj | 6 +- src/MyWebLog.Domain/MyWebLog.Domain.fsproj | 2 +- src/MyWebLog/Handlers.fs | 1019 -------------------- src/MyWebLog/Handlers/Admin.fs | 95 ++ src/MyWebLog/Handlers/Category.fs | 82 ++ src/MyWebLog/Handlers/Error.fs | 18 + src/MyWebLog/Handlers/Helpers.fs | 171 ++++ src/MyWebLog/Handlers/Page.fs | 100 ++ src/MyWebLog/Handlers/Post.fs | 397 ++++++++ src/MyWebLog/Handlers/Routes.fs | 70 ++ src/MyWebLog/Handlers/User.fs | 117 +++ src/MyWebLog/MyWebLog.fsproj | 15 +- src/MyWebLog/Program.fs | 2 +- src/MyWebLog/appsettings.json | 2 +- 14 files changed, 1066 insertions(+), 1030 deletions(-) delete mode 100644 src/MyWebLog/Handlers.fs create mode 100644 src/MyWebLog/Handlers/Admin.fs create mode 100644 src/MyWebLog/Handlers/Category.fs create mode 100644 src/MyWebLog/Handlers/Error.fs create mode 100644 src/MyWebLog/Handlers/Helpers.fs create mode 100644 src/MyWebLog/Handlers/Page.fs create mode 100644 src/MyWebLog/Handlers/Post.fs create mode 100644 src/MyWebLog/Handlers/Routes.fs create mode 100644 src/MyWebLog/Handlers/User.fs diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index 34ddfd4..588f479 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -10,12 +10,12 @@ - + - - + + diff --git a/src/MyWebLog.Domain/MyWebLog.Domain.fsproj b/src/MyWebLog.Domain/MyWebLog.Domain.fsproj index 0a0bea0..a3c3e9b 100644 --- a/src/MyWebLog.Domain/MyWebLog.Domain.fsproj +++ b/src/MyWebLog.Domain/MyWebLog.Domain.fsproj @@ -13,7 +13,7 @@ - + diff --git a/src/MyWebLog/Handlers.fs b/src/MyWebLog/Handlers.fs deleted file mode 100644 index 0ab62dc..0000000 --- a/src/MyWebLog/Handlers.fs +++ /dev/null @@ -1,1019 +0,0 @@ -[] -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 - -/// Handlers for error conditions -module Error = - - (* open Microsoft.Extensions.Logging *) - - (*/// Handle errors - let error (ex : Exception) (log : ILogger) = - log.LogError (EventId(), ex, "An unhandled exception has occurred while executing the request.") - clearResponse - >=> setStatusCode 500 - >=> setHttpHeader "X-Toast" (sprintf "error|||%s: %s" (ex.GetType().Name) ex.Message) - >=> text ex.Message *) - - /// 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 None - - /// Handle 404s from the API, sending known URL paths to the Vue app so that they can be handled there - let notFound : HttpHandler = - setStatusCode 404 >=> text "Not found" - - -open System.Text.Json - -/// Session extensions to get and set objects -type ISession with - - /// Set an item in the session - member this.Set<'T> (key, item : 'T) = - this.SetString (key, JsonSerializer.Serialize item) - - /// Get an item from the session - member this.Get<'T> key = - match this.GetString key with - | null -> None - | item -> Some (JsonSerializer.Deserialize<'T> item) - - -open System.Collections.Generic - -[] -module private Helpers = - - open Microsoft.AspNetCore.Antiforgery - open Microsoft.Extensions.Configuration - open Microsoft.Extensions.DependencyInjection - open System.Security.Claims - open System.IO - - /// The HTTP item key for loading the session - let private sessionLoadedKey = "session-loaded" - - /// Load the session if it has not been loaded already; ensures async access but not excessive loading - let private loadSession (ctx : HttpContext) = task { - if not (ctx.Items.ContainsKey sessionLoadedKey) then - do! ctx.Session.LoadAsync () - ctx.Items.Add (sessionLoadedKey, "yes") - } - - /// Ensure that the session is committed - let private commitSession (ctx : HttpContext) = task { - if ctx.Items.ContainsKey sessionLoadedKey then do! ctx.Session.CommitAsync () - } - - /// Add a message to the user's session - let addMessage (ctx : HttpContext) message = task { - do! loadSession ctx - let msg = match ctx.Session.Get "messages" with Some it -> it | None -> [] - ctx.Session.Set ("messages", message :: msg) - } - - /// Get any messages from the user's session, removing them in the process - let messages (ctx : HttpContext) = task { - do! loadSession ctx - match ctx.Session.Get "messages" with - | Some msg -> - ctx.Session.Remove "messages" - return msg |> (List.rev >> Array.ofList) - | None -> return [||] - } - - /// Hold variable for the configured generator string - let mutable private generatorString : string option = None - - /// Get the generator string - let generator (ctx : HttpContext) = - if Option.isNone generatorString then - let cfg = ctx.RequestServices.GetRequiredService () - generatorString <- Option.ofObj cfg["Generator"] - match generatorString with Some gen -> gen | None -> "generator not configured" - - /// 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 - - /// Render a view for the specified theme, using the specified template, layout, and hash - let viewForTheme theme template next ctx = fun (hash : Hash) -> task { - // Don't need the web log, but this adds it to the hash if the function is called directly - let _ = deriveWebLogFromHash hash ctx - let! messages = messages ctx - hash.Add ("logged_on", ctx.User.Identity.IsAuthenticated) - hash.Add ("page_list", PageListCache.get ctx) - hash.Add ("current_page", ctx.Request.Path.Value.Substring 1) - hash.Add ("messages", messages) - hash.Add ("generator", generator ctx) - - do! commitSession ctx - - // NOTE: DotLiquid does not support {% render %} or {% include %} in its templates, so we will do a two-pass - // render; the net effect is a "layout" capability similar to Razor or Pug - - // Render view content... - let! contentTemplate = TemplateCache.get theme template - hash.Add ("content", contentTemplate.Render hash) - - // ...then render that content with its layout - let! layoutTemplate = TemplateCache.get theme "layout" - - return! htmlString (layoutTemplate.Render hash) next ctx - } - - /// Return a view for the web log's default theme - let themedView template next ctx = fun (hash : Hash) -> task { - return! viewForTheme (deriveWebLogFromHash hash ctx).themePath template next ctx hash - } - - /// Redirect after doing some action; commits session and issues a temporary redirect - let redirectToGet url : HttpHandler = fun next ctx -> task { - do! commitSession ctx - return! redirectTo false url next ctx - } - - /// Get the web log ID for the current request - let webLogId ctx = (WebLogCache.get ctx).id - - /// Get the user ID for the current request - let userId (ctx : HttpContext) = - WebLogUserId (ctx.User.Claims |> Seq.find (fun c -> c.Type = ClaimTypes.NameIdentifier)).Value - - /// Get the RethinkDB connection - let conn (ctx : HttpContext) = ctx.RequestServices.GetRequiredService () - - /// Get the Anti-CSRF service - let private antiForgery (ctx : HttpContext) = ctx.RequestServices.GetRequiredService () - - /// Get the cross-site request forgery token set - let csrfToken (ctx : HttpContext) = - (antiForgery ctx).GetAndStoreTokens ctx - - /// Validate the cross-site request forgery token in the current request - let validateCsrf : HttpHandler = fun next ctx -> task { - match! (antiForgery ctx).IsRequestValidAsync ctx with - | true -> return! next ctx - | false -> return! RequestErrors.BAD_REQUEST "CSRF token invalid" next ctx - } - - /// Require a user to be logged on - let requireUser = requiresAuthentication Error.notAuthorized - - /// Get the templates available for the current web log's theme (in a key/value pair list) - let templatesForTheme ctx (typ : string) = - seq { - KeyValuePair.Create ("", $"- Default (single-{typ}) -") - yield! - Path.Combine ("themes", (WebLogCache.get ctx).themePath) - |> Directory.EnumerateFiles - |> Seq.filter (fun it -> it.EndsWith $"{typ}.liquid") - |> Seq.map (fun it -> - let parts = it.Split Path.DirectorySeparatorChar - let template = parts[parts.Length - 1].Replace (".liquid", "") - KeyValuePair.Create (template, template)) - } - |> Array.ofSeq - - -/// Handlers to manipulate admin functions -module Admin = - - open System.IO - - /// The currently available themes - let private themes () = - Directory.EnumerateDirectories "themes" - |> Seq.map (fun it -> it.Split Path.DirectorySeparatorChar |> Array.last) - |> Seq.filter (fun it -> it <> "admin") - |> Seq.map (fun it -> KeyValuePair.Create (it, it)) - |> Array.ofSeq - - // GET /admin - let dashboard : HttpHandler = requireUser >=> fun next ctx -> task { - let webLogId = webLogId ctx - let conn = conn ctx - let getCount (f : WebLogId -> IConnection -> Task) = f webLogId conn - 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 - return! - Hash.FromAnonymousObject - {| page_title = "Dashboard" - model = - { posts = posts - drafts = drafts - pages = pages - listedPages = listed - categories = cats - topLevelCategories = topCats - } - |} - |> viewForTheme "admin" "dashboard" next ctx - } - - // GET /admin/settings - let settings : HttpHandler = requireUser >=> fun next ctx -> task { - let webLog = WebLogCache.get ctx - let! allPages = Data.Page.findAll webLog.id (conn ctx) - return! - Hash.FromAnonymousObject - {| csrf = csrfToken ctx - model = SettingsModel.fromWebLog webLog - pages = - seq { - KeyValuePair.Create ("posts", "- First Page of Posts -") - yield! allPages - |> List.sortBy (fun p -> p.title.ToLower ()) - |> List.map (fun p -> KeyValuePair.Create (PageId.toString p.id, p.title)) - } - |> Array.ofSeq - themes = themes () - web_log = webLog - page_title = "Web Log Settings" - |} - |> viewForTheme "admin" "settings" next ctx - } - - // POST /admin/settings - let saveSettings : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { - let conn = conn ctx - let! model = ctx.BindFormAsync () - match! Data.WebLog.findById (WebLogCache.get ctx).id conn with - | Some webLog -> - let updated = - { webLog with - name = model.name - subtitle = if model.subtitle = "" then None else Some model.subtitle - defaultPage = model.defaultPage - postsPerPage = model.postsPerPage - timeZone = model.timeZone - themePath = model.themePath - } - do! Data.WebLog.updateSettings updated conn - - // Update cache - WebLogCache.set ctx updated - - do! addMessage ctx { UserMessage.success with message = "Web log settings saved successfully" } - return! redirectToGet "/admin" next ctx - | None -> return! Error.notFound next ctx - } - - -/// Handlers to manipulate categories -module Category = - - // GET /categories - let all : HttpHandler = requireUser >=> fun next ctx -> task { - return! - Hash.FromAnonymousObject {| - categories = CategoryCache.get ctx - page_title = "Categories" - csrf = csrfToken ctx - |} - |> viewForTheme "admin" "category-list" next ctx - } - - // GET /category/{id}/edit - let edit catId : HttpHandler = requireUser >=> fun next ctx -> task { - let webLogId = webLogId 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 - | Some cat -> return Some ("Edit Category", cat) - | None -> return None - } - match result with - | Some (title, cat) -> - return! - Hash.FromAnonymousObject {| - csrf = csrfToken ctx - model = EditCategoryModel.fromCategory cat - page_title = title - categories = CategoryCache.get ctx - |} - |> viewForTheme "admin" "category-edit" next ctx - | None -> return! Error.notFound next ctx - } - - // POST /category/save - let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { - let! model = ctx.BindFormAsync () - let webLogId = webLogId 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 - } - 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) - } - 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 $"/category/{CategoryId.toString cat.id}/edit" next ctx - | None -> return! Error.notFound next ctx - } - - // POST /category/{id}/delete - let delete 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 - | 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 "/categories" next ctx - } - - -/// Handlers to manipulate pages -module Page = - - // GET /pages - // GET /pages/page/{pageNbr} - let all pageNbr : HttpHandler = requireUser >=> fun next ctx -> task { - let webLog = WebLogCache.get ctx - let! pages = Data.Page.findPageOfPages webLog.id pageNbr (conn ctx) - return! - Hash.FromAnonymousObject - {| pages = pages |> List.map (DisplayPage.fromPageMinimal webLog) - page_title = "Pages" - |} - |> viewForTheme "admin" "page-list" next ctx - } - - // GET /page/{id}/edit - let edit pgId : HttpHandler = requireUser >=> fun next ctx -> task { - let! result = 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 - | Some page -> return Some ("Edit Page", page) - | None -> return None - } - match result with - | Some (title, page) -> - let model = EditPageModel.fromPage page - return! - Hash.FromAnonymousObject {| - csrf = csrfToken ctx - model = model - metadata = Array.zip model.metaNames model.metaValues - |> Array.mapi (fun idx (name, value) -> [| string idx; name; value |]) - page_title = title - templates = templatesForTheme ctx "page" - |} - |> viewForTheme "admin" "page-edit" next ctx - | None -> return! Error.notFound next ctx - } - - // POST /page/save - let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { - let! model = ctx.BindFormAsync () - let webLogId = webLogId 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 - authorId = userId ctx - publishedOn = now - } - | pgId -> return! Data.Page.findByFullId (PageId pgId) webLogId conn - } - match pg with - | Some page -> - 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 - | _ -> { page with priorPermalinks = page.permalink :: page.priorPermalinks } - let page = - { page with - title = model.title - permalink = Permalink model.permalink - updatedOn = now - showInPageList = model.isShownInPageList - template = match model.template with "" -> None | tmpl -> Some tmpl - text = MarkupText.toHtml revision.text - metadata = Seq.zip model.metaNames model.metaValues - |> 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 ()}") - |> List.ofSeq - revisions = match page.revisions |> List.tryHead with - | Some r when r.text = revision.text -> page.revisions - | _ -> revision :: page.revisions - } - do! (match model.pageId with "new" -> Data.Page.add | _ -> Data.Page.update) page conn - if updateList then do! PageListCache.update ctx - do! addMessage ctx { UserMessage.success with message = "Page saved successfully" } - return! redirectToGet $"/page/{PageId.toString page.id}/edit" next ctx - | None -> return! Error.notFound next ctx - } - - -/// Handlers to manipulate posts -module Post = - - open System.IO - open System.ServiceModel.Syndication - open System.Text.RegularExpressions - 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 - | PostList - | SinglePost - | 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 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, _ -> 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 "posts" - | AdminList, _ -> Some $"posts/page/{pageNbr - 1L}" - 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 $"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 |} - } - - // GET /page/{pageNbr} - let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task { - 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 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 - // 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 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 - | _ -> return! Error.notFound next ctx - } - - // GET / - let home : HttpHandler = fun next ctx -> task { - let webLog = WebLogCache.get ctx - match webLog.defaultPage with - | "posts" -> return! pageOfPosts 1 next ctx - | pageId -> - 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 - is_home = true - |} - |> themedView (defaultArg page.template "single-page") next ctx - | None -> return! Error.notFound next ctx - } - - // 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}/" - // 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 plainText = - Regex.Replace (post.text, "<(.|\n)*?>", "") - |> function - | txt when txt.Length < 255 -> txt - | txt -> $"{txt.Substring (0, 252)}..." - let item = SyndicationItem ( - Id = $"{urlBase}{Permalink.toString 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}") - 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)) - post.tags - |> List.map (fun tag -> - let urlTag = tag.Replace (" ", "+") - SyndicationCategory (tag, $"{urlBase}tag/{urlTag}/", $"{tag} (tag)")) - ] - |> List.concat - |> List.iter item.Categories.Add - 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 - feed.Language <- "en" - feed.Id <- urlBase - - feed.Links.Add (SyndicationLink (Uri $"{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) - - use mem = new MemoryStream () - use xml = XmlWriter.Create mem - feed.SaveAsRss20 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"] - 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 |> await with - | Some page -> - yield fun next ctx -> - Hash.FromAnonymousObject {| page = DisplayPage.fromPage webLog page; page_title = page.title |} - |> themedView (defaultArg page.template "single-page") 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 - // GET /posts/page/{pageNbr} - let all pageNbr : HttpHandler = requireUser >=> fun next ctx -> task { - 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 - hash.Add ("page_title", "Posts") - return! viewForTheme "admin" "post-list" next ctx hash - } - - // GET /post/{id}/edit - let edit postId : HttpHandler = requireUser >=> fun next ctx -> task { - let webLog = WebLogCache.get ctx - let conn = conn ctx - let! result = task { - match postId with - | "new" -> return Some ("Write a New Post", { Post.empty with id = PostId "new" }) - | _ -> - match! Data.Post.findByFullId (PostId postId) webLog.id conn with - | Some post -> return Some ("Edit Post", post) - | None -> return None - } - match result with - | Some (title, post) -> - let! cats = Data.Category.findAllForView webLog.id conn - return! - Hash.FromAnonymousObject {| - csrf = csrfToken ctx - model = EditPostModel.fromPost webLog post - page_title = title - categories = cats - |} - |> viewForTheme "admin" "post-edit" next ctx - | None -> return! Error.notFound next ctx - } - - // POST /post/save - let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { - let! model = ctx.BindFormAsync () - let webLogId = webLogId 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 - authorId = userId ctx - } - | postId -> return! Data.Post.findByFullId (PostId postId) webLogId conn - } - match pst with - | Some post -> - 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 - | _ -> { post with priorPermalinks = post.permalink :: post.priorPermalinks } - let post = - { post with - title = model.title - permalink = Permalink model.permalink - publishedOn = if model.doPublish then Some now else post.publishedOn - updatedOn = now - text = MarkupText.toHtml revision.text - tags = model.tags.Split "," - |> Seq.ofArray - |> Seq.map (fun it -> it.Trim().ToLower ()) - |> Seq.sort - |> List.ofSeq - categoryIds = model.categoryIds |> Array.map CategoryId |> List.ofArray - status = if model.doPublish then Published else post.status - 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 ()}") - |> List.ofSeq - revisions = match post.revisions |> List.tryHead with - | Some r when r.text = revision.text -> post.revisions - | _ -> revision :: post.revisions - } - let post = - match model.setPublished with - | true -> - let dt = DateTime (model.pubOverride.Value.ToUniversalTime().Ticks, DateTimeKind.Utc) - printf $"**** DateKind = {dt.Kind}" - match model.setUpdated with - | true -> - { post with - publishedOn = Some dt - updatedOn = dt - revisions = [ { (List.head post.revisions) with asOf = dt } ] - } - | false -> { post with publishedOn = Some dt } - | false -> post - do! (match model.postId with "new" -> Data.Post.add | _ -> Data.Post.update) post conn - // If the post was published or its categories changed, refresh the category cache - if model.doPublish - || not (pst.Value.categoryIds - |> List.append post.categoryIds - |> List.distinct - |> List.length = List.length pst.Value.categoryIds) then - do! CategoryCache.update ctx - do! addMessage ctx { UserMessage.success with message = "Post saved successfully" } - return! redirectToGet $"/post/{PostId.toString post.id}/edit" next ctx - | None -> return! Error.notFound next ctx - } - - -/// Handlers to manipulate users -module User = - - open Microsoft.AspNetCore.Authentication; - open Microsoft.AspNetCore.Authentication.Cookies - open System.Security.Claims - open System.Security.Cryptography - open System.Text - - /// Hash a password for a given user - let hashedPassword (plainText : string) (email : string) (salt : Guid) = - let allSalt = Array.concat [ salt.ToByteArray (); Encoding.UTF8.GetBytes email ] - use alg = new Rfc2898DeriveBytes (plainText, allSalt, 2_048) - Convert.ToBase64String (alg.GetBytes 64) - - // GET /user/log-on - let logOn returnUrl : HttpHandler = fun next ctx -> task { - 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 {| - model = { LogOnModel.empty with returnTo = returnTo } - page_title = "Log On" - csrf = csrfToken ctx - |} - |> viewForTheme "admin" "log-on" next ctx - } - - // POST /user/log-on - let doLogOn : HttpHandler = validateCsrf >=> fun next ctx -> task { - let! model = ctx.BindFormAsync () - let webLog = WebLogCache.get 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 { - Claim (ClaimTypes.NameIdentifier, WebLogUserId.toString user.id) - Claim (ClaimTypes.Name, $"{user.firstName} {user.lastName}") - Claim (ClaimTypes.GivenName, user.preferredName) - Claim (ClaimTypes.Role, user.authorizationLevel.ToString ()) - } - let identity = ClaimsIdentity (claims, CookieAuthenticationDefaults.AuthenticationScheme) - - do! ctx.SignInAsync (identity.AuthenticationType, ClaimsPrincipal identity, - 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 - | _ -> - 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" } - 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 - -/// The endpoints defined in the above handlers -let endpoints = [ - GET [ - route "/" Post.home - ] - subRoute "/admin" [ - GET [ - route "" Admin.dashboard - route "/settings" Admin.settings - ] - POST [ - route "/settings" Admin.saveSettings - ] - ] - subRoute "/categor" [ - GET [ - route "ies" Category.all - routef "y/%s/edit" Category.edit - route "y/{**slug}" Post.pageOfCategorizedPosts - ] - POST [ - route "y/save" Category.save - routef "y/%s/delete" Category.delete - ] - ] - 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 - ] - POST [ - route "/save" Page.save - ] - ] - subRoute "/post" [ - GET [ - routef "/%s/edit" Post.edit - route "s" (Post.all 1) - routef "s/page/%d" Post.all - ] - POST [ - 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/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs new file mode 100644 index 0000000..5fbd7ce --- /dev/null +++ b/src/MyWebLog/Handlers/Admin.fs @@ -0,0 +1,95 @@ +/// Handlers to manipulate admin functions +module MyWebLog.Handlers.Admin + +open System.Collections.Generic +open System.IO + +/// The currently available themes +let private themes () = + Directory.EnumerateDirectories "themes" + |> Seq.map (fun it -> it.Split Path.DirectorySeparatorChar |> Array.last) + |> Seq.filter (fun it -> it <> "admin") + |> Seq.map (fun it -> KeyValuePair.Create (it, it)) + |> Array.ofSeq + +open System.Threading.Tasks +open DotLiquid +open Giraffe +open MyWebLog +open MyWebLog.ViewModels +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) = f webLogId conn + 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 + return! + Hash.FromAnonymousObject + {| page_title = "Dashboard" + model = + { posts = posts + drafts = drafts + pages = pages + listedPages = listed + categories = cats + topLevelCategories = topCats + } + |} + |> viewForTheme "admin" "dashboard" next ctx +} + +// GET /admin/settings +let settings : HttpHandler = requireUser >=> fun next ctx -> task { + let webLog = WebLogCache.get ctx + let! allPages = Data.Page.findAll webLog.id (conn ctx) + return! + Hash.FromAnonymousObject + {| csrf = csrfToken ctx + model = SettingsModel.fromWebLog webLog + pages = + seq { + KeyValuePair.Create ("posts", "- First Page of Posts -") + yield! allPages + |> List.sortBy (fun p -> p.title.ToLower ()) + |> List.map (fun p -> KeyValuePair.Create (PageId.toString p.id, p.title)) + } + |> Array.ofSeq + themes = themes () + web_log = webLog + page_title = "Web Log Settings" + |} + |> viewForTheme "admin" "settings" next ctx +} + +// POST /admin/settings +let saveSettings : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { + let conn = conn ctx + let! model = ctx.BindFormAsync () + match! Data.WebLog.findById (WebLogCache.get ctx).id conn with + | Some webLog -> + let updated = + { webLog with + name = model.name + subtitle = if model.subtitle = "" then None else Some model.subtitle + defaultPage = model.defaultPage + postsPerPage = model.postsPerPage + timeZone = model.timeZone + themePath = model.themePath + } + do! Data.WebLog.updateSettings updated conn + + // Update cache + WebLogCache.set ctx updated + + do! addMessage ctx { UserMessage.success with message = "Web log settings saved successfully" } + return! redirectToGet "/admin" next ctx + | None -> return! Error.notFound next ctx +} + diff --git a/src/MyWebLog/Handlers/Category.fs b/src/MyWebLog/Handlers/Category.fs new file mode 100644 index 0000000..d0d8e73 --- /dev/null +++ b/src/MyWebLog/Handlers/Category.fs @@ -0,0 +1,82 @@ +/// Handlers to manipulate categories +module MyWebLog.Handlers.Category + +open DotLiquid +open Giraffe +open MyWebLog + +// GET /categories +let all : HttpHandler = requireUser >=> fun next ctx -> task { + return! + Hash.FromAnonymousObject {| + categories = CategoryCache.get ctx + page_title = "Categories" + csrf = csrfToken ctx + |} + |> viewForTheme "admin" "category-list" next ctx +} + +open MyWebLog.ViewModels + +// GET /category/{id}/edit +let edit catId : HttpHandler = requireUser >=> fun next ctx -> task { + let webLogId = webLogId 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 + | Some cat -> return Some ("Edit Category", cat) + | None -> return None + } + match result with + | Some (title, cat) -> + return! + Hash.FromAnonymousObject {| + csrf = csrfToken ctx + model = EditCategoryModel.fromCategory cat + page_title = title + categories = CategoryCache.get ctx + |} + |> viewForTheme "admin" "category-edit" next ctx + | None -> return! Error.notFound next ctx +} + +// POST /category/save +let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { + let! model = ctx.BindFormAsync () + let webLogId = webLogId 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 + } + 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) + } + 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 $"/category/{CategoryId.toString cat.id}/edit" next ctx + | None -> return! Error.notFound next ctx +} + +// POST /category/{id}/delete +let delete 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 + | 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 "/categories" next ctx +} diff --git a/src/MyWebLog/Handlers/Error.fs b/src/MyWebLog/Handlers/Error.fs new file mode 100644 index 0000000..794e6bd --- /dev/null +++ b/src/MyWebLog/Handlers/Error.fs @@ -0,0 +1,18 @@ +/// Handlers for error conditions +module MyWebLog.Handlers.Error + +open System.Net +open System.Threading.Tasks +open Microsoft.AspNetCore.Http +open Giraffe + +/// 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 None + +/// Handle 404s from the API, sending known URL paths to the Vue app so that they can be handled there +let notFound : HttpHandler = + setStatusCode 404 >=> text "Not found" diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs new file mode 100644 index 0000000..3fc78b8 --- /dev/null +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -0,0 +1,171 @@ +[] +module private MyWebLog.Handlers.Helpers + +open System.Text.Json +open Microsoft.AspNetCore.Http + +/// Session extensions to get and set objects +type ISession with + + /// Set an item in the session + member this.Set<'T> (key, item : 'T) = + this.SetString (key, JsonSerializer.Serialize item) + + /// Get an item from the session + member this.Get<'T> key = + match this.GetString key with + | null -> None + | item -> Some (JsonSerializer.Deserialize<'T> item) + + +/// The HTTP item key for loading the session +let private sessionLoadedKey = "session-loaded" + +/// Load the session if it has not been loaded already; ensures async access but not excessive loading +let private loadSession (ctx : HttpContext) = task { + if not (ctx.Items.ContainsKey sessionLoadedKey) then + do! ctx.Session.LoadAsync () + ctx.Items.Add (sessionLoadedKey, "yes") +} + +/// Ensure that the session is committed +let private commitSession (ctx : HttpContext) = task { + if ctx.Items.ContainsKey sessionLoadedKey then do! ctx.Session.CommitAsync () +} + +open MyWebLog.ViewModels + +/// Add a message to the user's session +let addMessage (ctx : HttpContext) message = task { + do! loadSession ctx + let msg = match ctx.Session.Get "messages" with Some it -> it | None -> [] + ctx.Session.Set ("messages", message :: msg) +} + +/// Get any messages from the user's session, removing them in the process +let messages (ctx : HttpContext) = task { + do! loadSession ctx + match ctx.Session.Get "messages" with + | Some msg -> + ctx.Session.Remove "messages" + return msg |> (List.rev >> Array.ofList) + | None -> return [||] +} + +/// Hold variable for the configured generator string +let mutable private generatorString : string option = None + +open Microsoft.Extensions.Configuration +open Microsoft.Extensions.DependencyInjection + +/// Get the generator string +let generator (ctx : HttpContext) = + match generatorString with + | Some gen -> gen + | None -> + let cfg = ctx.RequestServices.GetRequiredService () + generatorString <- Option.ofObj cfg["Generator"] + defaultArg generatorString "generator not configured" + +open DotLiquid +open MyWebLog + +/// 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 + +open Giraffe + +/// Render a view for the specified theme, using the specified template, layout, and hash +let viewForTheme theme template next ctx = fun (hash : Hash) -> task { + // Don't need the web log, but this adds it to the hash if the function is called directly + let _ = deriveWebLogFromHash hash ctx + let! messages = messages ctx + hash.Add ("logged_on", ctx.User.Identity.IsAuthenticated) + hash.Add ("page_list", PageListCache.get ctx) + hash.Add ("current_page", ctx.Request.Path.Value.Substring 1) + hash.Add ("messages", messages) + hash.Add ("generator", generator ctx) + + do! commitSession ctx + + // NOTE: DotLiquid does not support {% render %} or {% include %} in its templates, so we will do a 2-pass render; + // the net effect is a "layout" capability similar to Razor or Pug + + // Render view content... + let! contentTemplate = TemplateCache.get theme template + hash.Add ("content", contentTemplate.Render hash) + + // ...then render that content with its layout + let! layoutTemplate = TemplateCache.get theme "layout" + + return! htmlString (layoutTemplate.Render hash) next ctx +} + +/// Return a view for the web log's default theme +let themedView template next ctx = fun (hash : Hash) -> task { + return! viewForTheme (deriveWebLogFromHash hash ctx).themePath template next ctx hash +} + +/// Redirect after doing some action; commits session and issues a temporary redirect +let redirectToGet url : HttpHandler = fun next ctx -> task { + do! commitSession ctx + 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 +let userId (ctx : HttpContext) = + WebLogUserId (ctx.User.Claims |> Seq.find (fun c -> c.Type = ClaimTypes.NameIdentifier)).Value + +open RethinkDb.Driver.Net + +/// Get the RethinkDB connection +let conn (ctx : HttpContext) = ctx.RequestServices.GetRequiredService () + +open Microsoft.AspNetCore.Antiforgery + +/// Get the Anti-CSRF service +let private antiForgery (ctx : HttpContext) = ctx.RequestServices.GetRequiredService () + +/// Get the cross-site request forgery token set +let csrfToken (ctx : HttpContext) = + (antiForgery ctx).GetAndStoreTokens ctx + +/// Validate the cross-site request forgery token in the current request +let validateCsrf : HttpHandler = fun next ctx -> task { + match! (antiForgery ctx).IsRequestValidAsync ctx with + | true -> return! next ctx + | false -> return! RequestErrors.BAD_REQUEST "CSRF token invalid" next ctx +} + +/// Require a user to be logged on +let requireUser : HttpHandler = requiresAuthentication Error.notAuthorized + +open System.Collections.Generic +open System.IO + +/// Get the templates available for the current web log's theme (in a key/value pair list) +let templatesForTheme ctx (typ : string) = + seq { + KeyValuePair.Create ("", $"- Default (single-{typ}) -") + yield! + Path.Combine ("themes", (WebLogCache.get ctx).themePath) + |> Directory.EnumerateFiles + |> Seq.filter (fun it -> it.EndsWith $"{typ}.liquid") + |> Seq.map (fun it -> + let parts = it.Split Path.DirectorySeparatorChar + let template = parts[parts.Length - 1].Replace (".liquid", "") + KeyValuePair.Create (template, template)) + } + |> Array.ofSeq + diff --git a/src/MyWebLog/Handlers/Page.fs b/src/MyWebLog/Handlers/Page.fs new file mode 100644 index 0000000..c725a77 --- /dev/null +++ b/src/MyWebLog/Handlers/Page.fs @@ -0,0 +1,100 @@ +/// Handlers to manipulate pages +module MyWebLog.Handlers.Page + +open DotLiquid +open Giraffe +open MyWebLog +open MyWebLog.ViewModels + +// GET /pages +// GET /pages/page/{pageNbr} +let all pageNbr : HttpHandler = requireUser >=> fun next ctx -> task { + let webLog = WebLogCache.get ctx + let! pages = Data.Page.findPageOfPages webLog.id pageNbr (conn ctx) + return! + Hash.FromAnonymousObject + {| pages = pages |> List.map (DisplayPage.fromPageMinimal webLog) + page_title = "Pages" + |} + |> viewForTheme "admin" "page-list" next ctx +} + +// GET /page/{id}/edit +let edit pgId : HttpHandler = requireUser >=> fun next ctx -> task { + let! result = 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 + | Some page -> return Some ("Edit Page", page) + | None -> return None + } + match result with + | Some (title, page) -> + let model = EditPageModel.fromPage page + return! + Hash.FromAnonymousObject {| + csrf = csrfToken ctx + model = model + metadata = Array.zip model.metaNames model.metaValues + |> Array.mapi (fun idx (name, value) -> [| string idx; name; value |]) + page_title = title + templates = templatesForTheme ctx "page" + |} + |> viewForTheme "admin" "page-edit" next ctx + | None -> return! Error.notFound next ctx +} + +open System + +// POST /page/save +let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { + let! model = ctx.BindFormAsync () + let webLogId = webLogId 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 + authorId = userId ctx + publishedOn = now + } + | pgId -> return! Data.Page.findByFullId (PageId pgId) webLogId conn + } + match pg with + | Some page -> + 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 + | _ -> { page with priorPermalinks = page.permalink :: page.priorPermalinks } + let page = + { page with + title = model.title + permalink = Permalink model.permalink + updatedOn = now + showInPageList = model.isShownInPageList + template = match model.template with "" -> None | tmpl -> Some tmpl + text = MarkupText.toHtml revision.text + metadata = Seq.zip model.metaNames model.metaValues + |> 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 ()}") + |> List.ofSeq + revisions = match page.revisions |> List.tryHead with + | Some r when r.text = revision.text -> page.revisions + | _ -> revision :: page.revisions + } + do! (match model.pageId with "new" -> Data.Page.add | _ -> Data.Page.update) page conn + if updateList then do! PageListCache.update ctx + do! addMessage ctx { UserMessage.success with message = "Page saved successfully" } + return! redirectToGet $"/page/{PageId.toString page.id}/edit" next ctx + | None -> return! Error.notFound next ctx +} diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs new file mode 100644 index 0000000..c67ef7c --- /dev/null +++ b/src/MyWebLog/Handlers/Post.fs @@ -0,0 +1,397 @@ +/// Handlers to manipulate posts +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 = 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 + | PostList + | SinglePost + | TagList + +open MyWebLog + +/// 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 + +open System.Threading.Tasks +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! 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 -> + let post = List.head posts + let dateTime = defaultArg post.publishedOn post.updatedOn + Data.Post.findSurroundingPosts webLog.id dateTime 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 "posts" + | AdminList, _ -> Some $"posts/page/{pageNbr - 1L}" + 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 $"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 |} +} + +// GET /page/{pageNbr} +let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task { + 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 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 +} + +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 + 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 + // 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 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 + | _ -> return! Error.notFound next ctx +} + +// GET / +let home : HttpHandler = fun next ctx -> task { + let webLog = WebLogCache.get ctx + match webLog.defaultPage with + | "posts" -> return! pageOfPosts 1 next ctx + | pageId -> + 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 + is_home = true + |} + |> themedView (defaultArg page.template "single-page") next ctx + | None -> return! Error.notFound next ctx +} + +open System.IO +open System.ServiceModel.Syndication +open System.Text.RegularExpressions +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}/" + // 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 plainText = + Regex.Replace (post.text, "<(.|\n)*?>", "") + |> function + | txt when txt.Length < 255 -> txt + | txt -> $"{txt.Substring (0, 252)}..." + let item = SyndicationItem ( + Id = $"{urlBase}{Permalink.toString 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}") + 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)) + post.tags + |> List.map (fun tag -> + let urlTag = tag.Replace (" ", "+") + SyndicationCategory (tag, $"{urlBase}tag/{urlTag}/", $"{tag} (tag)")) + ] + |> List.concat + |> List.iter item.Categories.Add + 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 + feed.Language <- "en" + feed.Id <- urlBase + + feed.Links.Add (SyndicationLink (Uri $"{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) + + use mem = new MemoryStream () + use xml = XmlWriter.Create mem + feed.SaveAsRss20 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"] + 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 |> await with + | Some page -> + yield fun next ctx -> + Hash.FromAnonymousObject {| page = DisplayPage.fromPage webLog page; page_title = page.title |} + |> themedView (defaultArg page.template "single-page") 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 +// GET /posts/page/{pageNbr} +let all pageNbr : HttpHandler = requireUser >=> fun next ctx -> task { + 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 + hash.Add ("page_title", "Posts") + return! viewForTheme "admin" "post-list" next ctx hash +} + +// GET /post/{id}/edit +let edit postId : HttpHandler = requireUser >=> fun next ctx -> task { + let webLog = WebLogCache.get ctx + let conn = conn ctx + let! result = task { + match postId with + | "new" -> return Some ("Write a New Post", { Post.empty with id = PostId "new" }) + | _ -> + match! Data.Post.findByFullId (PostId postId) webLog.id conn with + | Some post -> return Some ("Edit Post", post) + | None -> return None + } + match result with + | Some (title, post) -> + let! cats = Data.Category.findAllForView webLog.id conn + return! + Hash.FromAnonymousObject {| + csrf = csrfToken ctx + model = EditPostModel.fromPost webLog post + page_title = title + categories = cats + |} + |> viewForTheme "admin" "post-edit" next ctx + | None -> return! Error.notFound next ctx +} + +// POST /post/save +let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { + let! model = ctx.BindFormAsync () + let webLogId = webLogId 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 + authorId = userId ctx + } + | postId -> return! Data.Post.findByFullId (PostId postId) webLogId conn + } + match pst with + | Some post -> + 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 + | _ -> { post with priorPermalinks = post.permalink :: post.priorPermalinks } + let post = + { post with + title = model.title + permalink = Permalink model.permalink + publishedOn = if model.doPublish then Some now else post.publishedOn + updatedOn = now + text = MarkupText.toHtml revision.text + tags = model.tags.Split "," + |> Seq.ofArray + |> Seq.map (fun it -> it.Trim().ToLower ()) + |> Seq.sort + |> List.ofSeq + categoryIds = model.categoryIds |> Array.map CategoryId |> List.ofArray + status = if model.doPublish then Published else post.status + 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 ()}") + |> List.ofSeq + revisions = match post.revisions |> List.tryHead with + | Some r when r.text = revision.text -> post.revisions + | _ -> revision :: post.revisions + } + let post = + match model.setPublished with + | true -> + let dt = DateTime (model.pubOverride.Value.ToUniversalTime().Ticks, DateTimeKind.Utc) + printf $"**** DateKind = {dt.Kind}" + match model.setUpdated with + | true -> + { post with + publishedOn = Some dt + updatedOn = dt + revisions = [ { (List.head post.revisions) with asOf = dt } ] + } + | false -> { post with publishedOn = Some dt } + | false -> post + do! (match model.postId with "new" -> Data.Post.add | _ -> Data.Post.update) post conn + // If the post was published or its categories changed, refresh the category cache + if model.doPublish + || not (pst.Value.categoryIds + |> List.append post.categoryIds + |> List.distinct + |> List.length = List.length pst.Value.categoryIds) then + do! CategoryCache.update ctx + do! addMessage ctx { UserMessage.success with message = "Post saved successfully" } + return! redirectToGet $"/post/{PostId.toString post.id}/edit" next ctx + | None -> return! Error.notFound next ctx +} diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs new file mode 100644 index 0000000..64f07c3 --- /dev/null +++ b/src/MyWebLog/Handlers/Routes.fs @@ -0,0 +1,70 @@ +/// Routes for this application +module MyWebLog.Handlers.Routes + +open Giraffe.EndpointRouting + +/// The endpoints defined in the above handlers +let endpoints = [ + GET [ + route "/" Post.home + ] + subRoute "/admin" [ + GET [ + route "" Admin.dashboard + route "/settings" Admin.settings + ] + POST [ + route "/settings" Admin.saveSettings + ] + ] + subRoute "/categor" [ + GET [ + route "ies" Category.all + routef "y/%s/edit" Category.edit + route "y/{**slug}" Post.pageOfCategorizedPosts + ] + POST [ + route "y/save" Category.save + routef "y/%s/delete" Category.delete + ] + ] + 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 + ] + POST [ + route "/save" Page.save + ] + ] + subRoute "/post" [ + GET [ + routef "/%s/edit" Post.edit + route "s" (Post.all 1) + routef "s/page/%d" Post.all + ] + POST [ + 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/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs new file mode 100644 index 0000000..253196b --- /dev/null +++ b/src/MyWebLog/Handlers/User.fs @@ -0,0 +1,117 @@ +/// Handlers to manipulate users +module MyWebLog.Handlers.User + +open System +open System.Security.Cryptography +open System.Text + +/// Hash a password for a given user +let hashedPassword (plainText : string) (email : string) (salt : Guid) = + let allSalt = Array.concat [ salt.ToByteArray (); Encoding.UTF8.GetBytes email ] + use alg = new Rfc2898DeriveBytes (plainText, allSalt, 2_048) + Convert.ToBase64String (alg.GetBytes 64) + +open DotLiquid +open Giraffe +open MyWebLog.ViewModels + +// GET /user/log-on +let logOn returnUrl : HttpHandler = fun next ctx -> task { + 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 {| + model = { LogOnModel.empty with returnTo = returnTo } + page_title = "Log On" + csrf = csrfToken ctx + |} + |> viewForTheme "admin" "log-on" next ctx +} + +open System.Security.Claims +open Microsoft.AspNetCore.Authentication +open Microsoft.AspNetCore.Authentication.Cookies +open MyWebLog + +// POST /user/log-on +let doLogOn : HttpHandler = validateCsrf >=> fun next ctx -> task { + let! model = ctx.BindFormAsync () + let webLog = WebLogCache.get 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 { + Claim (ClaimTypes.NameIdentifier, WebLogUserId.toString user.id) + Claim (ClaimTypes.Name, $"{user.firstName} {user.lastName}") + Claim (ClaimTypes.GivenName, user.preferredName) + Claim (ClaimTypes.Role, user.authorizationLevel.ToString ()) + } + let identity = ClaimsIdentity (claims, CookieAuthenticationDefaults.AuthenticationScheme) + + do! ctx.SignInAsync (identity.AuthenticationType, ClaimsPrincipal identity, + 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 + | _ -> + 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" } + 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 +} diff --git a/src/MyWebLog/MyWebLog.fsproj b/src/MyWebLog/MyWebLog.fsproj index d58ba53..2497096 100644 --- a/src/MyWebLog/MyWebLog.fsproj +++ b/src/MyWebLog/MyWebLog.fsproj @@ -9,15 +9,22 @@ - + + + + + + + + - + - + @@ -31,6 +38,4 @@ - - diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index 904b5ea..656dbd7 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -276,7 +276,7 @@ let main args = let _ = app.UseStaticFiles () let _ = app.UseRouting () let _ = app.UseSession () - let _ = app.UseGiraffe Handlers.endpoints + let _ = app.UseGiraffe Handlers.Routes.endpoints app.Run() diff --git a/src/MyWebLog/appsettings.json b/src/MyWebLog/appsettings.json index 2081e58..ec1c59d 100644 --- a/src/MyWebLog/appsettings.json +++ b/src/MyWebLog/appsettings.json @@ -3,5 +3,5 @@ "hostname": "data02.bitbadger.solutions", "database": "myWebLog_dev" }, - "Generator": "myWebLog 2.0-alpha02" + "Generator": "myWebLog 2.0-alpha03" }