From d1d384812e9c116b97533d9ead2ede3fc0e6750e Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Mon, 30 May 2022 12:13:04 -0400 Subject: [PATCH] Fix podcast identifying data Still need to test episode data, but it is thought-fixed as well --- src/MyWebLog/Handlers/Feed.fs | 178 ++++++++++++++++++------------- src/MyWebLog/Handlers/Helpers.fs | 9 +- src/MyWebLog/Handlers/Routes.fs | 26 +++-- 3 files changed, 132 insertions(+), 81 deletions(-) diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs index dc3df97..68ab950 100644 --- a/src/MyWebLog/Handlers/Feed.fs +++ b/src/MyWebLog/Handlers/Feed.fs @@ -23,28 +23,37 @@ type FeedType = /// Derive the type of RSS feed requested let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option = let webLog = ctx.WebLog + let debug = debug "Feed" ctx let name = $"/{webLog.rss.feedName}" let postCount = defaultArg webLog.rss.itemsInFeed webLog.postsPerPage + debug (fun () -> $"Considering potential feed for {feedPath} (configured feed name {name})") // Standard feed match webLog.rss.feedEnabled && feedPath = name with - | true -> Some (StandardFeed feedPath, postCount) + | true -> + debug (fun () -> "Found standard feed") + Some (StandardFeed feedPath, 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, feedPath), postCount) + | Some cat -> + debug (fun () -> "Found category feed") + Some (CategoryFeed (CategoryId cat.id, feedPath), postCount) | None -> // Tag feed match feedPath.StartsWith "/tag/" with - | true -> Some (TagFeed (feedPath.Replace("/tag/", "").Replace(name, ""), feedPath), postCount) + | true -> + debug (fun () -> "Found tag feed") + Some (TagFeed (feedPath.Replace("/tag/", "").Replace(name, ""), feedPath), postCount) | false -> // Custom feed match webLog.rss.customFeeds - |> List.tryFind (fun it -> (Permalink.toString it.path).EndsWith feedPath) with + |> List.tryFind (fun it -> feedPath.EndsWith (Permalink.toString it.path)) with | Some feed -> + debug (fun () -> "Found custom feed") Some (Custom (feed, feedPath), feed.podcast |> Option.map (fun p -> p.itemsInFeed) |> Option.defaultValue postCount) | None -> - // No feed + debug (fun () -> $"No matching feed found") None /// Determine the function to retrieve posts for the given feed @@ -61,6 +70,25 @@ let private getFeedPosts (webLog : WebLog) feedType = /// Strip HTML from a string let private stripHtml text = Regex.Replace (text, "<(.|\n)*?>", "") +/// XML namespaces for building RSS feeds +[] +module private Namespace = + + /// Enables encoded (HTML) content + let content = "http://purl.org/rss/1.0/modules/content/" + + /// The dc XML namespace + let dc = "http://purl.org/dc/elements/1.1/" + + /// iTunes elements + let iTunes = "http://www.itunes.com/dtds/podcast-1.0.dtd" + + /// Enables chapters + let psc = "http://podlove.org/simple-chapters/" + + /// Enables another "subscribe" option + let rawVoice = "http://www.rawvoice.com/rawvoiceRssModule/" + /// Create a feed item from the given post let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[]) (tagMaps : TagMap list) (post : Post) = @@ -78,7 +106,7 @@ let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[ 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.ElementExtensions.Add ("encoded", Namespace.content, encoded) item.Authors.Add (SyndicationPerson ( Name = (authors |> List.find (fun a -> a.name = WebLogUserId.toString post.authorId)).value)) [ post.categoryIds @@ -122,26 +150,25 @@ let private addEpisode webLog (feed : CustomFeed) (post : Post) (item : Syndicat |> 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) + let xmlDoc = XmlDocument () + let enclosure = xmlDoc.CreateElement "enclosure" + enclosure.SetAttribute ("url", epMediaUrl) + meta "length" |> Option.iter (fun it -> enclosure.SetAttribute ("length", it.value)) + epMediaType |> Option.iter (fun typ -> enclosure.SetAttribute ("type", typ)) + item.ElementExtensions.Add enclosure - 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)) + item.ElementExtensions.Add ("creator", Namespace.dc, podcast.displayedAuthor) + item.ElementExtensions.Add ("author", Namespace.iTunes, podcast.displayedAuthor) + item.ElementExtensions.Add ("summary", Namespace.iTunes, stripHtml post.text) + item.ElementExtensions.Add ("image", Namespace.iTunes, epImageUrl) + item.ElementExtensions.Add ("explicit", Namespace.iTunes, epExplicit) + meta "subtitle" |> Option.iter (fun it -> item.ElementExtensions.Add ("subtitle", Namespace.iTunes, it.value)) + meta "duration" |> Option.iter (fun it -> item.ElementExtensions.Add ("duration", Namespace.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") + let chapters = xmlDoc.CreateElement ("psc", "chapters", Namespace.psc) + chapters.SetAttribute ("version", "1.2") post.metadata |> List.filter (fun it -> it.name = "chapter") @@ -149,13 +176,12 @@ let private addEpisode webLog (feed : CustomFeed) (post : Post) (item : Syndicat 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) + let chapter = xmlDoc.CreateElement ("psc", "chapter", Namespace.psc) + chapter.SetAttribute ("start", (fst chap).ToString "hh:mm:ss") + chapter.SetAttribute ("title", snd chap) + chapters.AppendChild chapter |> ignore) - chapXml.AppendChild chapsElt |> ignore - item.ElementExtensions.Add ("chapters", "psc", chapXml) + item.ElementExtensions.Add chapters with _ -> () item @@ -165,10 +191,12 @@ let private addNamespace (feed : SyndicationFeed) alias 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 addChild (doc : XmlDocument) ns prefix name value (elt : XmlElement) = + let child = + if ns = "" then doc.CreateElement name else doc.CreateElement (prefix, name, ns) + |> elt.AppendChild + child.InnerText <- value + elt let podcast = Option.get feed.podcast let feedUrl = WebLog.absoluteUrl webLog feed.path @@ -177,43 +205,42 @@ let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) = | 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) - podcast.iTunesSubcategory - |> Option.iter (fun subCat -> - let subCatElt = categoryXml.CreateElement ("itunes", "category", "") - subCatElt.SetAttribute ("text", subCat) - catElt.AppendChild subCatElt |> ignore) - categoryXml.AppendChild catElt |> ignore + let xmlDoc = XmlDocument () - [ "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/" - ] + [ "dc", Namespace.dc; "itunes", Namespace.iTunes; "psc", Namespace.psc; "rawvoice", Namespace.rawVoice ] |> 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 ())) - 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) + let categorization = + let it = xmlDoc.CreateElement ("itunes", "category", Namespace.iTunes) + it.SetAttribute ("text", podcast.iTunesCategory) + podcast.iTunesSubcategory + |> Option.iter (fun subCat -> + let subCatElt = xmlDoc.CreateElement ("itunes", "category", Namespace.iTunes) + subCatElt.SetAttribute ("text", subCat) + it.AppendChild subCatElt |> ignore) + it + let image = + [ "title", podcast.title + "url", imageUrl + "link", feedUrl + ] + |> List.fold (fun elt (name, value) -> addChild xmlDoc "" "" name value elt) (xmlDoc.CreateElement "image") + let owner = + [ "name", podcast.displayedAuthor + "email", podcast.email + ] + |> List.fold (fun elt (name, value) -> addChild xmlDoc Namespace.iTunes "itunes" name value elt) + (xmlDoc.CreateElement ("itunes", "owner", Namespace.iTunes)) + + rssFeed.ElementExtensions.Add image + rssFeed.ElementExtensions.Add owner + rssFeed.ElementExtensions.Add categorization + rssFeed.ElementExtensions.Add ("summary", Namespace.iTunes, podcast.summary) + rssFeed.ElementExtensions.Add ("author", Namespace.iTunes, podcast.displayedAuthor) + rssFeed.ElementExtensions.Add ("image", Namespace.iTunes, imageUrl) + rssFeed.ElementExtensions.Add ("explicit", Namespace.iTunes, ExplicitRating.toString podcast.explicit) + rssFeed.ElementExtensions.Add ("subscribe", Namespace.rawVoice, feedUrl) + podcast.subtitle |> Option.iter (fun sub -> rssFeed.ElementExtensions.Add ("subtitle", Namespace.iTunes, sub)) /// Get the feed's self reference and non-feed link let private selfAndLink webLog feedType = @@ -227,22 +254,26 @@ let private selfAndLink webLog feedType = /// Create a feed with a known non-zero-length list of posts let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backgroundTask { - let webLog = ctx.WebLog - let conn = ctx.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 webLog = ctx.WebLog + let conn = ctx.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 self, link = selfAndLink webLog feedType 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 + | Some _ -> + warn "Feed" ctx $"[{webLog.name} {Permalink.toString self}] \"{stripHtml post.title}\" has no media" + item | _ -> item let feed = SyndicationFeed () - addNamespace feed "content" "http://purl.org/rss/1.0/modules/content/" + addNamespace feed "content" Namespace.content feed.Title <- TextSyndicationContent webLog.name feed.Description <- TextSyndicationContent <| defaultArg webLog.subtitle webLog.name @@ -253,7 +284,6 @@ let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backg feed.Id <- webLog.urlBase webLog.rss.copyright |> Option.iter (fun copy -> feed.Copyright <- TextSyndicationContent copy) - let self, link = selfAndLink webLog feedType feed.Links.Add (SyndicationLink (Uri (WebLog.absoluteUrl webLog self), "self", "", "application/rss+xml", 0L)) feed.ElementExtensions.Add ("link", "", WebLog.absoluteUrl webLog link) diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index 33e2445..b9a428d 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -176,8 +176,15 @@ let private isDebugEnabled (ctx : HttpContext) = debugEnabled.Value /// Log a debug message -let debug name ctx (msg : unit -> string) = +let debug (name : string) ctx msg = if isDebugEnabled ctx then let fac = ctx.RequestServices.GetRequiredService () let log = fac.CreateLogger $"MyWebLog.Handlers.{name}" log.LogDebug (msg ()) + +/// Log a warning message +let warn (name : string) (ctx : HttpContext) msg = + let fac = ctx.RequestServices.GetRequiredService () + let log = fac.CreateLogger $"MyWebLog.Handlers.{name}" + log.LogWarning msg + \ No newline at end of file diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 95c10fb..42f3be8 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -15,19 +15,21 @@ module CatchAll = let private deriveAction (ctx : HttpContext) : HttpHandler seq = let webLog = ctx.WebLog let conn = ctx.Conn + let debug = debug "Routes.CatchAll" ctx 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}") + debug (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 -> + debug (fun () -> $"Found post by permalink") 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 @@ -35,31 +37,43 @@ module CatchAll = // Current page match Data.Page.findByPermalink permalink webLog.id conn |> await with | Some page -> + debug (fun () -> $"Found page by permalink") 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 + | Some (feedType, postCount) -> + debug (fun () -> $"Found RSS feed") + 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) + | Some post -> + debug (fun () -> $"Found post by trailing-slash-agnostic permalink") + yield redirectTo true (WebLog.relativeUrl webLog post.permalink) | None -> () // Page differing only by trailing slash match Data.Page.findByPermalink altLink webLog.id conn |> await with - | Some page -> yield redirectTo true (WebLog.relativeUrl webLog page.permalink) + | Some page -> + debug (fun () -> $"Found page by trailing-slash-agnostic permalink") + yield redirectTo true (WebLog.relativeUrl webLog page.permalink) | None -> () // Prior post match Data.Post.findCurrentPermalink [ permalink; altLink ] webLog.id conn |> await with - | Some link -> yield redirectTo true (WebLog.relativeUrl webLog link) + | Some link -> + debug (fun () -> $"Found post by prior permalink") + yield redirectTo true (WebLog.relativeUrl webLog link) | None -> () // Prior page match Data.Page.findCurrentPermalink [ permalink; altLink ] webLog.id conn |> await with - | Some link -> yield redirectTo true (WebLog.relativeUrl webLog link) + | Some link -> + debug (fun () -> $"Found page by prior permalink") + yield redirectTo true (WebLog.relativeUrl webLog link) | None -> () + debug (fun () -> $"No content found") } // GET {all-of-the-above}