V2 #1
@ -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
|
||||
[<RequireQualifiedAccess>]
|
||||
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)
|
||||
|
||||
|
||||
@ -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<ILoggerFactory> ()
|
||||
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<ILoggerFactory> ()
|
||||
let log = fac.CreateLogger $"MyWebLog.Handlers.{name}"
|
||||
log.LogWarning msg
|
||||
|
||||
@ -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}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user