From fbacacfb5b35a992413ff725056daee04aa1d1ac Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sat, 28 May 2022 13:51:07 -0400 Subject: [PATCH] WIP on feeds / podcasts --- src/MyWebLog.Data/Data.fs | 5 +- src/MyWebLog.Domain/SupportTypes.fs | 6 + src/MyWebLog/Handlers/Feed.fs | 257 ++++++++++++++++++++++++++++ src/MyWebLog/Handlers/Post.fs | 179 +------------------ src/MyWebLog/Handlers/Routes.fs | 68 +++++++- src/MyWebLog/MyWebLog.fsproj | 1 + 6 files changed, 336 insertions(+), 180 deletions(-) create mode 100644 src/MyWebLog/Handlers/Feed.fs diff --git a/src/MyWebLog.Data/Data.fs b/src/MyWebLog.Data/Data.fs index 1715a17..06b0087 100644 --- a/src/MyWebLog.Data/Data.fs +++ b/src/MyWebLog.Data/Data.fs @@ -524,8 +524,7 @@ module Post = } /// Find posts to be displayed on a category list page - let findPageOfCategorizedPosts (webLogId : WebLogId) (catIds : CategoryId list) (pageNbr : int64) postsPerPage = - let pg = int pageNbr + let findPageOfCategorizedPosts (webLogId : WebLogId) (catIds : CategoryId list) pageNbr postsPerPage = rethink { withTable Table.Post getAll (objList catIds) "categoryIds" @@ -534,7 +533,7 @@ module Post = without [ "priorPermalinks"; "revisions" ] distinct orderByDescending "publishedOn" - skip ((pg - 1) * postsPerPage) + skip ((pageNbr - 1) * postsPerPage) limit (postsPerPage + 1) result; withRetryDefault } diff --git a/src/MyWebLog.Domain/SupportTypes.fs b/src/MyWebLog.Domain/SupportTypes.fs index cb607e2..f0e226b 100644 --- a/src/MyWebLog.Domain/SupportTypes.fs +++ b/src/MyWebLog.Domain/SupportTypes.fs @@ -255,6 +255,9 @@ type PodcastOptions = /// The e-mail address of the user who registered the podcast at iTunes email : string + /// The link to the image for the podcast + imageUrl : Permalink + /// The category from iTunes under which this podcast is categorized iTunesCategory : string @@ -263,6 +266,9 @@ type PodcastOptions = /// The explictness rating (iTunes field) explicit : ExplicitRating + + /// The default media type for files in this podcast + defaultMediaType : string option } diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs new file mode 100644 index 0000000..fa88c98 --- /dev/null +++ b/src/MyWebLog/Handlers/Feed.fs @@ -0,0 +1,257 @@ +/// Functions to support generating RSS feeds +module MyWebLog.Handlers.Feed + +open System +open System.IO +open System.ServiceModel.Syndication +open System.Text.RegularExpressions +open System.Xml +open Giraffe +open Microsoft.AspNetCore.Http +open MyWebLog +open MyWebLog.ViewModels + +/// The type of feed to generate +type FeedType = + | StandardFeed + | CategoryFeed of CategoryId + | TagFeed of string + | Custom of CustomFeed + +/// Derive the type of RSS feed requested +let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option = + let webLog = ctx.WebLog + let name = $"/{webLog.rss.feedName}" + let postCount = defaultArg webLog.rss.itemsInFeed webLog.postsPerPage + // Standard feed + match webLog.rss.feedEnabled && feedPath = name with + | true -> Some (StandardFeed, postCount) + | false -> + // Category feed + match CategoryCache.get ctx |> Array.tryFind (fun cat -> cat.slug = feedPath.Replace (name, "")) with + | Some cat -> Some (CategoryFeed (CategoryId cat.id), postCount) + | None -> + // Tag feed + match feedPath.StartsWith "/tag/" with + | true -> Some (TagFeed (feedPath.Replace("/tag/", "").Replace(name, "")), postCount) + | false -> + // Custom feed + match webLog.rss.customFeeds + |> List.tryFind (fun it -> (Permalink.toString it.path).EndsWith feedPath) with + | Some feed -> + Some (Custom feed, + feed.podcast |> Option.map (fun p -> p.itemsInFeed) |> Option.defaultValue postCount) + | None -> + // No feed + None + +/// Determine the function to retrieve posts for the given feed +let private getFeedPosts (webLog : WebLog) feedType = + match feedType with + | StandardFeed -> Data.Post.findPageOfPublishedPosts webLog.id 1 + | CategoryFeed catId -> Data.Post.findPageOfCategorizedPosts webLog.id [ catId ] 1 + | TagFeed tag -> Data.Post.findPageOfTaggedPosts webLog.id tag 1 + | Custom feed -> + match feed.source with + | Category catId -> Data.Post.findPageOfCategorizedPosts webLog.id [ catId ] 1 + | Tag tag -> Data.Post.findPageOfTaggedPosts webLog.id tag 1 + +/// Strip HTML from a string +let private stripHtml text = Regex.Replace (text, "<(.|\n)*?>", "") + +/// Create a feed item from the given post +let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[]) (tagMaps : TagMap list) + (post : Post) = + let plainText = + match stripHtml post.text with + | txt when txt.Length < 255 -> txt + | txt -> $"{txt.Substring (0, 252)}..." + let item = SyndicationItem ( + Id = WebLog.absoluteUrl webLog post.permalink, + Title = TextSyndicationContent.CreateHtmlContent post.title, + PublishDate = DateTimeOffset post.publishedOn.Value, + LastUpdatedTime = DateTimeOffset post.updatedOn, + Content = TextSyndicationContent.CreatePlaintextContent plainText) + item.AddPermalink (Uri item.Id) + + let encoded = + post.text.Replace("src=\"/", $"src=\"{webLog.urlBase}/").Replace ("href=\"/", $"href=\"{webLog.urlBase}/") + item.ElementExtensions.Add ("encoded", "http://purl.org/rss/1.0/modules/content/", encoded) + item.Authors.Add (SyndicationPerson ( + Name = (authors |> List.find (fun a -> a.name = WebLogUserId.toString post.authorId)).value)) + [ post.categoryIds + |> List.map (fun catId -> + let cat = cats |> Array.find (fun c -> c.id = CategoryId.toString catId) + SyndicationCategory (cat.name, WebLog.absoluteUrl webLog (Permalink $"category/{cat.slug}/"), cat.name)) + post.tags + |> List.map (fun tag -> + let urlTag = + match tagMaps |> List.tryFind (fun tm -> tm.tag = tag) with + | Some tm -> tm.urlValue + | None -> tag.Replace (" ", "+") + SyndicationCategory (tag, WebLog.absoluteUrl webLog (Permalink $"tag/{urlTag}/"), $"{tag} (tag)")) + ] + |> List.concat + |> List.iter item.Categories.Add + item + +/// Add episode information to a podcast feed item +let private addEpisode webLog (feed : CustomFeed) (post : Post) (item : SyndicationItem) = + let podcast = Option.get feed.podcast + let meta name = post.metadata |> List.tryFind (fun it -> it.name = name) + let value (item : MetaItem) = item.value + let epMediaUrl = + match (meta >> Option.get >> value) "media" with + | link when link.StartsWith "http" -> link + | link -> WebLog.absoluteUrl webLog (Permalink link) + let epMediaType = + match meta "mediaType", podcast.defaultMediaType with + | Some epType, _ -> Some epType.value + | None, Some defType -> Some defType + | _ -> None + let epImageUrl = + match defaultArg ((meta >> Option.map value) "image") (Permalink.toString podcast.imageUrl) with + | link when link.StartsWith "http" -> link + | link -> WebLog.absoluteUrl webLog (Permalink link) + let epExplicit = + try + (meta >> Option.map (value >> ExplicitRating.parse)) "explicit" + |> Option.defaultValue podcast.explicit + |> ExplicitRating.toString + with :? ArgumentException -> ExplicitRating.toString podcast.explicit + + let encXml = XmlDocument () + let encElt = encXml.CreateElement "enclosure" + encElt.SetAttribute ("url", epMediaUrl) + meta "length" |> Option.iter (fun it -> encElt.SetAttribute ("length", it.value)) + epMediaType |> Option.iter (fun typ -> encElt.SetAttribute ("type", typ)) + item.ElementExtensions.Add ("enclosure", "", encXml) + + item.ElementExtensions.Add ("creator", "dc", podcast.displayedAuthor) + item.ElementExtensions.Add ("author", "itunes", podcast.displayedAuthor) + meta "subtitle" |> Option.iter (fun it -> item.ElementExtensions.Add ("subtitle", "itunes", it.value)) + item.ElementExtensions.Add ("summary", "itunes", stripHtml post.text) + item.ElementExtensions.Add ("image", "itunes", epImageUrl) + item.ElementExtensions.Add ("explicit", "itunes", epExplicit) + meta "duration" |> Option.iter (fun it -> item.ElementExtensions.Add ("duration", "itunes", it.value)) + + if post.metadata |> List.exists (fun it -> it.name = "chapter") then + try + let chapXml = XmlDocument () + let chapsElt = chapXml.CreateElement ("psc", "chapters", "") + chapsElt.SetAttribute ("version", "1.2") + + post.metadata + |> List.filter (fun it -> it.name = "chapter") + |> List.map (fun it -> + TimeSpan.Parse (it.value.Split(" ")[0]), it.value.Substring (it.value.IndexOf(" ") + 1)) + |> List.sortBy fst + |> List.iter (fun chap -> + let chapElt = chapXml.CreateElement ("psc", "chapter", "") + chapElt.SetAttribute ("start", (fst chap).ToString "hh:mm:ss") + chapElt.SetAttribute ("title", snd chap) + chapsElt.AppendChild chapElt |> ignore) + + chapXml.AppendChild chapsElt |> ignore + item.ElementExtensions.Add ("chapters", "psc", chapXml) + with _ -> () + item + +/// Add a namespace to the feed +let private addNamespace (feed : SyndicationFeed) alias nsUrl = + feed.AttributeExtensions.Add (XmlQualifiedName (alias, "http://www.w3.org/2000/xmlns/"), nsUrl) + +/// Add items to the top of the feed required for podcasts +let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) = + let addChild (doc : XmlDocument) name prefix value = + let child = doc.CreateElement (name, prefix, "") |> doc.AppendChild + child.Value <- value + doc + + let podcast = Option.get feed.podcast + let feedUrl = WebLog.absoluteUrl webLog feed.path + let imageUrl = + match podcast.imageUrl with + | Permalink link when link.StartsWith "http" -> link + | Permalink _ -> WebLog.absoluteUrl webLog podcast.imageUrl + + let categoryXml = XmlDocument () + let catElt = categoryXml.CreateElement ("itunes", "category", "") + catElt.SetAttribute ("text", podcast.iTunesCategory) + let subCat = categoryXml.CreateElement ("itunes", "category", "") + subCat.SetAttribute ("text", podcast.iTunesSubcategory) + catElt.AppendChild subCat |> ignore + categoryXml.AppendChild catElt |> ignore + + [ "dc", "http://purl.org/dc/elements/1.1/" + "itunes", "http://www.itunes.com/dtds/podcast-1.0.dtd" + "psc", "http://podlove.org/simple-chapters/" + "rawvoice", "http://www.rawvoice.com/rawvoiceRssModule/" + ] + |> List.iter (fun (alias, nsUrl) -> addNamespace rssFeed alias nsUrl) + + rssFeed.ElementExtensions.Add + ("image", "", + [ "title", podcast.title + "url", imageUrl + "link", feedUrl + ] + |> List.fold (fun doc (name, value) -> addChild doc name "" value) (XmlDocument ())) + // TODO: is copyright required? + rssFeed.ElementExtensions.Add ("summary", "itunes", podcast.summary) + rssFeed.ElementExtensions.Add ("author", "itunes", podcast.displayedAuthor) + podcast.subtitle |> Option.iter (fun sub -> rssFeed.ElementExtensions.Add ("subtitle", "itunes", sub)) + rssFeed.ElementExtensions.Add + ("owner", "itunes", + [ "name", podcast.displayedAuthor + "email", podcast.email + ] + |> List.fold (fun doc (name, value) -> addChild doc name "itunes" value) (XmlDocument ())) + rssFeed.ElementExtensions.Add ("image", "itunes", imageUrl) + rssFeed.ElementExtensions.Add ("category", "itunes", categoryXml) + rssFeed.ElementExtensions.Add ("explicit", "itunes", ExplicitRating.toString podcast.explicit) + rssFeed.ElementExtensions.Add ("subscribe", "rawvoice", feedUrl) + +// GET {any-prescribed-feed} +let generate (feedType : FeedType) postCount : HttpHandler = fun next ctx -> backgroundTask { + let webLog = ctx.WebLog + let conn = ctx.Conn + let! posts = getFeedPosts webLog feedType postCount conn + let! authors = Post.getAuthors webLog posts conn + let! tagMaps = Post.getTagMappings webLog posts conn + let cats = CategoryCache.get ctx + let podcast = match feedType with Custom feed when Option.isSome feed.podcast -> Some feed | _ -> None + + let toItem post = + let item = toFeedItem webLog authors cats tagMaps post + match podcast with + | Some feed when post.metadata |> List.exists (fun it -> it.name = "media") -> + addEpisode webLog feed post item + | _ -> 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 <- webLog.urlBase + + feed.Links.Add (SyndicationLink (Uri $"{webLog.urlBase}/feed.xml", "self", "", "application/rss+xml", 0L)) + feed.AttributeExtensions.Add + (XmlQualifiedName ("content", "http://www.w3.org/2000/xmlns/"), "http://purl.org/rss/1.0/modules/content/") + feed.ElementExtensions.Add ("link", "", webLog.urlBase) + podcast |> Option.iter (addPodcast webLog feed) + + 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 +} diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 7167802..ca502e1 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -2,7 +2,6 @@ module MyWebLog.Handlers.Post open System -open Microsoft.AspNetCore.Http /// Parse a slug and page number from an "everything else" URL let private parseSlugAndPage (slugAndPage : string seq) = @@ -27,14 +26,14 @@ type ListType = open MyWebLog /// Get all authors for a list of posts as metadata items -let private getAuthors (webLog : WebLog) (posts : Post list) conn = +let getAuthors (webLog : WebLog) (posts : Post list) conn = posts |> List.map (fun p -> p.authorId) |> List.distinct |> Data.WebLogUser.findNames webLog.id conn /// Get all tag mappings for a list of posts as metadata items -let private getTagMappings (webLog : WebLog) (posts : Post list) = +let getTagMappings (webLog : WebLog) (posts : Post list) = posts |> List.map (fun p -> p.tags) |> List.concat @@ -46,7 +45,7 @@ open DotLiquid open MyWebLog.ViewModels /// Convert a list of posts into items ready to be displayed -let private preparePostList webLog posts listType (url : string) pageNbr perPage ctx conn = task { +let preparePostList webLog posts listType (url : string) pageNbr perPage ctx conn = task { let! authors = getAuthors webLog posts conn let! tagMappings = getTagMappings webLog posts conn let relUrl it = Some <| WebLog.relativeUrl webLog (Permalink it) @@ -195,178 +194,6 @@ let home : HttpHandler = fun next ctx -> task { | None -> return! Error.notFound next ctx } -/// Functions to support generating RSS feeds -module Feed = - - open System.IO - open System.ServiceModel.Syndication - open System.Text.RegularExpressions - open System.Xml - - /// The type of feed to generate - type FeedType = - | Standard - | Category of CategoryId - | Tag of string - | Custom of CustomFeed - - /// Derive the type of RSS feed requested - let deriveFeedType ctx webLog feedPath : (FeedType * int) option = - let name = $"/{webLog.rss.feedName}" - let postCount = defaultArg webLog.rss.itemsInFeed webLog.postsPerPage - // Standard feed - match webLog.rss.feedEnabled && feedPath = name with - | true -> Some (Standard, postCount) - | false -> - // Category feed - match CategoryCache.get ctx |> Array.tryFind (fun cat -> cat.slug = feedPath.Replace (name, "")) with - | Some cat -> Some (Category (CategoryId cat.id), postCount) - | None -> - // Tag feed - match feedPath.StartsWith "/tag/" with - | true -> Some (Tag (feedPath.Replace("/tag/", "").Replace(name, "")), postCount) - | false -> - // Custom feed - match webLog.rss.customFeeds - |> List.tryFind (fun it -> (Permalink.toString it.path).EndsWith feedPath) with - | Some feed -> - Some (Custom feed, - feed.podcast |> Option.map (fun p -> p.itemsInFeed) |> Option.defaultValue postCount) - | None -> - // No feed - None - - // GET {any-prescribed-feed} - let generate (feedType : FeedType) postCount : HttpHandler = fun next ctx -> backgroundTask { - // TODO: stopped here; use feed type and count in the below function - let webLog = ctx.WebLog - let conn = ctx.Conn - let! posts = Data.Post.findPageOfPublishedPosts webLog.id 1 postCount conn - let! authors = getAuthors webLog posts conn - let! tagMaps = getTagMappings 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 = WebLog.absoluteUrl webLog post.permalink, - Title = TextSyndicationContent.CreateHtmlContent post.title, - PublishDate = DateTimeOffset post.publishedOn.Value, - LastUpdatedTime = DateTimeOffset post.updatedOn, - Content = TextSyndicationContent.CreatePlaintextContent plainText) - item.AddPermalink (Uri item.Id) - - let encoded = - post.text.Replace("src=\"/", $"src=\"{webLog.urlBase}/").Replace ("href=\"/", $"href=\"{webLog.urlBase}/") - item.ElementExtensions.Add ("encoded", "http://purl.org/rss/1.0/modules/content/", encoded) - item.Authors.Add (SyndicationPerson ( - Name = (authors |> List.find (fun a -> a.name = WebLogUserId.toString post.authorId)).value)) - [ post.categoryIds - |> List.map (fun catId -> - let cat = cats |> Array.find (fun c -> c.id = CategoryId.toString catId) - SyndicationCategory (cat.name, WebLog.absoluteUrl webLog (Permalink $"category/{cat.slug}/"), cat.name)) - post.tags - |> List.map (fun tag -> - let urlTag = - match tagMaps |> List.tryFind (fun tm -> tm.tag = tag) with - | Some tm -> tm.urlValue - | None -> tag.Replace (" ", "+") - SyndicationCategory (tag, WebLog.absoluteUrl webLog (Permalink $"tag/{urlTag}/"), $"{tag} (tag)")) - ] - |> List.concat - |> List.iter item.Categories.Add - 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 <- webLog.urlBase - - feed.Links.Add (SyndicationLink (Uri $"{webLog.urlBase}/feed.xml", "self", "", "application/rss+xml", 0L)) - feed.AttributeExtensions.Add - (XmlQualifiedName ("content", "http://www.w3.org/2000/xmlns/"), "http://purl.org/rss/1.0/modules/content/") - feed.ElementExtensions.Add ("link", "", webLog.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 : HttpContext) : HttpHandler seq = - let webLog = ctx.WebLog - let conn = ctx.Conn - let textLink = - let _, extra = WebLog.hostAndPath webLog - let url = string ctx.Request.Path - (if extra = "" then url else url.Substring extra.Length).ToLowerInvariant () - let await it = (Async.AwaitTask >> Async.RunSynchronously) it - seq { - debug "Post" ctx (fun () -> $"Considering URL {textLink}") - // Home page directory without the directory slash - if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.empty) - let permalink = Permalink (textLink.Substring 1) - // Current post - match Data.Post.findByPermalink permalink webLog.id conn |> await with - | Some post -> - 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 - match Feed.deriveFeedType ctx webLog textLink with - | Some (feedType, postCount) -> yield Feed.generate feedType postCount - | None -> () - // Post differing only by trailing slash - let altLink = Permalink (if textLink.EndsWith "/" then textLink[..textLink.Length - 2] else $"{textLink}/") - match Data.Post.findByPermalink altLink webLog.id conn |> await with - | Some post -> yield redirectTo true (WebLog.relativeUrl webLog post.permalink) - | None -> () - // Page differing only by trailing slash - match Data.Page.findByPermalink altLink webLog.id conn |> await with - | Some page -> yield redirectTo true (WebLog.relativeUrl webLog page.permalink) - | None -> () - // Prior post - match Data.Post.findCurrentPermalink [ permalink; altLink ] webLog.id conn |> await with - | Some link -> yield redirectTo true (WebLog.relativeUrl webLog link) - | None -> () - // Prior page - match Data.Page.findCurrentPermalink [ permalink; altLink ] webLog.id conn |> await with - | Some link -> yield redirectTo true (WebLog.relativeUrl webLog link) - | None -> () - } - -// GET {all-of-the-above} -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 /admin/posts // GET /admin/posts/page/{pageNbr} let all pageNbr : HttpHandler = fun next ctx -> task { diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 4f0fbda..be2f582 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -4,6 +4,72 @@ module MyWebLog.Handlers.Routes open Giraffe open MyWebLog +/// Module to resolve routes that do not match any other known route (web blog content) +module CatchAll = + + open DotLiquid + open Microsoft.AspNetCore.Http + open MyWebLog.ViewModels + + /// Sequence where the first returned value is the proper handler for the link + let private deriveAction (ctx : HttpContext) : HttpHandler seq = + let webLog = ctx.WebLog + let conn = ctx.Conn + let textLink = + let _, extra = WebLog.hostAndPath webLog + let url = string ctx.Request.Path + (if extra = "" then url else url.Substring extra.Length).ToLowerInvariant () + let await it = (Async.AwaitTask >> Async.RunSynchronously) it + seq { + debug "Post" ctx (fun () -> $"Considering URL {textLink}") + // Home page directory without the directory slash + if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.empty) + let permalink = Permalink (textLink.Substring 1) + // Current post + match Data.Post.findByPermalink permalink webLog.id conn |> await with + | Some post -> + let model = Post.preparePostList webLog [ post ] Post.ListType.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 + match Feed.deriveFeedType ctx textLink with + | Some (feedType, postCount) -> yield Feed.generate feedType postCount + | None -> () + // Post differing only by trailing slash + let altLink = Permalink (if textLink.EndsWith "/" then textLink[..textLink.Length - 2] else $"{textLink}/") + match Data.Post.findByPermalink altLink webLog.id conn |> await with + | Some post -> yield redirectTo true (WebLog.relativeUrl webLog post.permalink) + | None -> () + // Page differing only by trailing slash + match Data.Page.findByPermalink altLink webLog.id conn |> await with + | Some page -> yield redirectTo true (WebLog.relativeUrl webLog page.permalink) + | None -> () + // Prior post + match Data.Post.findCurrentPermalink [ permalink; altLink ] webLog.id conn |> await with + | Some link -> yield redirectTo true (WebLog.relativeUrl webLog link) + | None -> () + // Prior page + match Data.Page.findCurrentPermalink [ permalink; altLink ] webLog.id conn |> await with + | Some link -> yield redirectTo true (WebLog.relativeUrl webLog link) + | None -> () + } + + // GET {all-of-the-above} + let route : HttpHandler = fun next ctx -> task { + match deriveAction ctx |> Seq.tryHead with + | Some handler -> return! handler next ctx + | None -> return! Error.notFound next ctx + } + +/// The primary myWebLog router let router : HttpHandler = choose [ GET >=> choose [ route "/" >=> Post.home @@ -69,7 +135,7 @@ let router : HttpHandler = choose [ route "/log-on" >=> User.doLogOn ] ]) - GET >=> Post.catchAll + GET >=> CatchAll.route Error.notFound ] diff --git a/src/MyWebLog/MyWebLog.fsproj b/src/MyWebLog/MyWebLog.fsproj index 5ad84b1..ab6d573 100644 --- a/src/MyWebLog/MyWebLog.fsproj +++ b/src/MyWebLog/MyWebLog.fsproj @@ -13,6 +13,7 @@ +