bit-badger/myWebLog
1
0
Fork 0
Code Issues 3 Pull Requests Packages Projects Releases 11 Activity

V2 #1

Merged
danieljsummers merged 102 commits from v2 into main 2022-06-23 00:35:12 +00:00
Conversation 0 Commits 102 Files Changed 125 +132 -81
3 changed files with 132 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files
Showing only changes of commit d1d384812e - Show all commits

178
src/MyWebLog/Handlers/Feed.fs
View File

@ -23,28 +23,37 @@ type FeedType =
/// Derive the type of RSS feed requested /// Derive the type of RSS feed requested
let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option = let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option =
let webLog = ctx.WebLog let webLog = ctx.WebLog
let debug = debug "Feed" ctx
let name = $"/{webLog.rss.feedName}" let name = $"/{webLog.rss.feedName}"
let postCount = defaultArg webLog.rss.itemsInFeed webLog.postsPerPage let postCount = defaultArg webLog.rss.itemsInFeed webLog.postsPerPage
debug (fun () -> $"Considering potential feed for {feedPath} (configured feed name {name})")
// Standard feed // Standard feed
match webLog.rss.feedEnabled && feedPath = name with match webLog.rss.feedEnabled && feedPath = name with
| true -> Some (StandardFeed feedPath, postCount) | true ->
debug (fun () -> "Found standard feed")
Some (StandardFeed feedPath, postCount)
| false -> | false ->
// Category feed // Category feed
match CategoryCache.get ctx |> Array.tryFind (fun cat -> cat.slug = feedPath.Replace (name, "")) with 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 -> | None ->
// Tag feed // Tag feed
match feedPath.StartsWith "/tag/" with 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 -> | false ->
// Custom feed // Custom feed
match webLog.rss.customFeeds 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 -> | Some feed ->
debug (fun () -> "Found custom feed")
Some (Custom (feed, feedPath), Some (Custom (feed, feedPath),
feed.podcast |> Option.map (fun p -> p.itemsInFeed) |> Option.defaultValue postCount) feed.podcast |> Option.map (fun p -> p.itemsInFeed) |> Option.defaultValue postCount)
| None -> | None ->
// No feed debug (fun () -> $"No matching feed found")
None None
/// Determine the function to retrieve posts for the given feed /// 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 /// Strip HTML from a string
let private stripHtml text = Regex.Replace (text, "<(.|\n)*?>", "") 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 /// Create a feed item from the given post
let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[]) (tagMaps : TagMap list) let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[]) (tagMaps : TagMap list)
(post : Post) = (post : Post) =
@ -78,7 +106,7 @@ let private toFeedItem webLog (authors : MetaItem list) (cats : DisplayCategory[
let encoded = let encoded =
post.text.Replace("src=\"/", $"src=\"{webLog.urlBase}/").Replace ("href=\"/", $"href=\"{webLog.urlBase}/") 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 ( item.Authors.Add (SyndicationPerson (
Name = (authors |> List.find (fun a -> a.name = WebLogUserId.toString post.authorId)).value)) Name = (authors |> List.find (fun a -> a.name = WebLogUserId.toString post.authorId)).value))
[ post.categoryIds [ post.categoryIds
@ -122,26 +150,25 @@ let private addEpisode webLog (feed : CustomFeed) (post : Post) (item : Syndicat
|> ExplicitRating.toString |> ExplicitRating.toString
with :? ArgumentException -> ExplicitRating.toString podcast.explicit with :? ArgumentException -> ExplicitRating.toString podcast.explicit
let encXml = XmlDocument () let xmlDoc = XmlDocument ()
let encElt = encXml.CreateElement "enclosure" let enclosure = xmlDoc.CreateElement "enclosure"
encElt.SetAttribute ("url", epMediaUrl) enclosure.SetAttribute ("url", epMediaUrl)
meta "length" |> Option.iter (fun it -> encElt.SetAttribute ("length", it.value)) meta "length" |> Option.iter (fun it -> enclosure.SetAttribute ("length", it.value))
epMediaType |> Option.iter (fun typ -> encElt.SetAttribute ("type", typ)) epMediaType |> Option.iter (fun typ -> enclosure.SetAttribute ("type", typ))
item.ElementExtensions.Add ("enclosure", "", encXml) item.ElementExtensions.Add enclosure
item.ElementExtensions.Add ("creator", "dc", podcast.displayedAuthor) item.ElementExtensions.Add ("creator", Namespace.dc, podcast.displayedAuthor)
item.ElementExtensions.Add ("author", "itunes", podcast.displayedAuthor) item.ElementExtensions.Add ("author", Namespace.iTunes, podcast.displayedAuthor)
meta "subtitle" |> Option.iter (fun it -> item.ElementExtensions.Add ("subtitle", "itunes", it.value)) item.ElementExtensions.Add ("summary", Namespace.iTunes, stripHtml post.text)
item.ElementExtensions.Add ("summary", "itunes", stripHtml post.text) item.ElementExtensions.Add ("image", Namespace.iTunes, epImageUrl)
item.ElementExtensions.Add ("image", "itunes", epImageUrl) item.ElementExtensions.Add ("explicit", Namespace.iTunes, epExplicit)
item.ElementExtensions.Add ("explicit", "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", "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 if post.metadata |> List.exists (fun it -> it.name = "chapter") then
try try
let chapXml = XmlDocument () let chapters = xmlDoc.CreateElement ("psc", "chapters", Namespace.psc)
let chapsElt = chapXml.CreateElement ("psc", "chapters", "") chapters.SetAttribute ("version", "1.2")
chapsElt.SetAttribute ("version", "1.2")
post.metadata post.metadata
|> List.filter (fun it -> it.name = "chapter") |> 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)) TimeSpan.Parse (it.value.Split(" ")[0]), it.value.Substring (it.value.IndexOf(" ") + 1))
|> List.sortBy fst |> List.sortBy fst
|> List.iter (fun chap -> |> List.iter (fun chap ->
let chapElt = chapXml.CreateElement ("psc", "chapter", "") let chapter = xmlDoc.CreateElement ("psc", "chapter", Namespace.psc)
chapElt.SetAttribute ("start", (fst chap).ToString "hh:mm:ss") chapter.SetAttribute ("start", (fst chap).ToString "hh:mm:ss")
chapElt.SetAttribute ("title", snd chap) chapter.SetAttribute ("title", snd chap)
chapsElt.AppendChild chapElt |> ignore) chapters.AppendChild chapter |> ignore)
chapXml.AppendChild chapsElt |> ignore item.ElementExtensions.Add chapters
item.ElementExtensions.Add ("chapters", "psc", chapXml)
with _ -> () with _ -> ()
item item
@ -165,10 +191,12 @@ let private addNamespace (feed : SyndicationFeed) alias nsUrl =
/// Add items to the top of the feed required for podcasts /// Add items to the top of the feed required for podcasts
let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) = let private addPodcast webLog (rssFeed : SyndicationFeed) (feed : CustomFeed) =
let addChild (doc : XmlDocument) name prefix value = let addChild (doc : XmlDocument) ns prefix name value (elt : XmlElement) =
let child = doc.CreateElement (name, prefix, "") |> doc.AppendChild let child =
child.Value <- value if ns = "" then doc.CreateElement name else doc.CreateElement (prefix, name, ns)
doc |> elt.AppendChild
child.InnerText <- value
elt
let podcast = Option.get feed.podcast let podcast = Option.get feed.podcast
let feedUrl = WebLog.absoluteUrl webLog feed.path 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 link when link.StartsWith "http" -> link
| Permalink _ -> WebLog.absoluteUrl webLog podcast.imageUrl | Permalink _ -> WebLog.absoluteUrl webLog podcast.imageUrl
let categoryXml = XmlDocument () let xmlDoc = 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
[ "dc", "http://purl.org/dc/elements/1.1/" [ "dc", Namespace.dc; "itunes", Namespace.iTunes; "psc", Namespace.psc; "rawvoice", Namespace.rawVoice ]
"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) |> List.iter (fun (alias, nsUrl) -> addNamespace rssFeed alias nsUrl)
rssFeed.ElementExtensions.Add let categorization =
("image", "", let it = xmlDoc.CreateElement ("itunes", "category", Namespace.iTunes)
[ "title", podcast.title it.SetAttribute ("text", podcast.iTunesCategory)
"url", imageUrl podcast.iTunesSubcategory
"link", feedUrl |> Option.iter (fun subCat ->
] let subCatElt = xmlDoc.CreateElement ("itunes", "category", Namespace.iTunes)
|> List.fold (fun doc (name, value) -> addChild doc name "" value) (XmlDocument ())) subCatElt.SetAttribute ("text", subCat)
rssFeed.ElementExtensions.Add ("summary", "itunes", podcast.summary) it.AppendChild subCatElt |> ignore)
rssFeed.ElementExtensions.Add ("author", "itunes", podcast.displayedAuthor) it
podcast.subtitle |> Option.iter (fun sub -> rssFeed.ElementExtensions.Add ("subtitle", "itunes", sub)) let image =
rssFeed.ElementExtensions.Add [ "title", podcast.title
("owner", "itunes", "url", imageUrl
[ "name", podcast.displayedAuthor "link", feedUrl
"email", podcast.email ]
] |> List.fold (fun elt (name, value) -> addChild xmlDoc "" "" name value elt) (xmlDoc.CreateElement "image")
|> List.fold (fun doc (name, value) -> addChild doc name "itunes" value) (XmlDocument ())) let owner =
rssFeed.ElementExtensions.Add ("image", "itunes", imageUrl) [ "name", podcast.displayedAuthor
rssFeed.ElementExtensions.Add ("category", "itunes", categoryXml) "email", podcast.email
rssFeed.ElementExtensions.Add ("explicit", "itunes", ExplicitRating.toString podcast.explicit) ]
rssFeed.ElementExtensions.Add ("subscribe", "rawvoice", feedUrl) |> 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 /// Get the feed's self reference and non-feed link
let private selfAndLink webLog feedType = 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 /// Create a feed with a known non-zero-length list of posts
let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backgroundTask { let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backgroundTask {
let webLog = ctx.WebLog let webLog = ctx.WebLog
let conn = ctx.Conn let conn = ctx.Conn
let! authors = Post.getAuthors webLog posts conn let! authors = Post.getAuthors webLog posts conn
let! tagMaps = Post.getTagMappings webLog posts conn let! tagMaps = Post.getTagMappings webLog posts conn
let cats = CategoryCache.get ctx let cats = CategoryCache.get ctx
let podcast = match feedType with Custom (feed, _) when Option.isSome feed.podcast -> Some feed | _ -> None 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 toItem post =
let item = toFeedItem webLog authors cats tagMaps post let item = toFeedItem webLog authors cats tagMaps post
match podcast with match podcast with
| Some feed when post.metadata |> List.exists (fun it -> it.name = "media") -> | Some feed when post.metadata |> List.exists (fun it -> it.name = "media") ->
addEpisode webLog feed post item addEpisode webLog feed post item
| Some _ ->
warn "Feed" ctx $"[{webLog.name} {Permalink.toString self}] \"{stripHtml post.title}\" has no media"
item
| _ -> item | _ -> item
let feed = SyndicationFeed () 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.Title <- TextSyndicationContent webLog.name
feed.Description <- TextSyndicationContent <| defaultArg webLog.subtitle 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 feed.Id <- webLog.urlBase
webLog.rss.copyright |> Option.iter (fun copy -> feed.Copyright <- TextSyndicationContent copy) 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.Links.Add (SyndicationLink (Uri (WebLog.absoluteUrl webLog self), "self", "", "application/rss+xml", 0L))
feed.ElementExtensions.Add ("link", "", WebLog.absoluteUrl webLog link) feed.ElementExtensions.Add ("link", "", WebLog.absoluteUrl webLog link)

9
src/MyWebLog/Handlers/Helpers.fs
View File

@ -176,8 +176,15 @@ let private isDebugEnabled (ctx : HttpContext) =
debugEnabled.Value debugEnabled.Value
/// Log a debug message /// Log a debug message
let debug name ctx (msg : unit -> string) = let debug (name : string) ctx msg =
if isDebugEnabled ctx then if isDebugEnabled ctx then
let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory> () let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory> ()
let log = fac.CreateLogger $"MyWebLog.Handlers.{name}" let log = fac.CreateLogger $"MyWebLog.Handlers.{name}"
log.LogDebug (msg ()) 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

26
src/MyWebLog/Handlers/Routes.fs
View File

@ -15,19 +15,21 @@ module CatchAll =
let private deriveAction (ctx : HttpContext) : HttpHandler seq = let private deriveAction (ctx : HttpContext) : HttpHandler seq =
let webLog = ctx.WebLog let webLog = ctx.WebLog
let conn = ctx.Conn let conn = ctx.Conn
let debug = debug "Routes.CatchAll" ctx
let textLink = let textLink =
let _, extra = WebLog.hostAndPath webLog let _, extra = WebLog.hostAndPath webLog
let url = string ctx.Request.Path let url = string ctx.Request.Path
(if extra = "" then url else url.Substring extra.Length).ToLowerInvariant () (if extra = "" then url else url.Substring extra.Length).ToLowerInvariant ()
let await it = (Async.AwaitTask >> Async.RunSynchronously) it let await it = (Async.AwaitTask >> Async.RunSynchronously) it
seq { seq {
debug "Post" ctx (fun () -> $"Considering URL {textLink}") debug (fun () -> $"Considering URL {textLink}")
// Home page directory without the directory slash // Home page directory without the directory slash
if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.empty) if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.empty)
let permalink = Permalink (textLink.Substring 1) let permalink = Permalink (textLink.Substring 1)
// Current post // Current post
match Data.Post.findByPermalink permalink webLog.id conn |> await with match Data.Post.findByPermalink permalink webLog.id conn |> await with
| Some post -> | Some post ->
debug (fun () -> $"Found post by permalink")
let model = Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 ctx conn |> await let model = Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 ctx conn |> await
model.Add ("page_title", post.title) model.Add ("page_title", post.title)
yield fun next ctx -> themedView "single-post" next ctx model yield fun next ctx -> themedView "single-post" next ctx model
@ -35,31 +37,43 @@ module CatchAll =
// Current page // Current page
match Data.Page.findByPermalink permalink webLog.id conn |> await with match Data.Page.findByPermalink permalink webLog.id conn |> await with
| Some page -> | Some page ->
debug (fun () -> $"Found page by permalink")
yield fun next ctx -> yield fun next ctx ->
Hash.FromAnonymousObject {| page = DisplayPage.fromPage webLog page; page_title = page.title |} Hash.FromAnonymousObject {| page = DisplayPage.fromPage webLog page; page_title = page.title |}
|> themedView (defaultArg page.template "single-page") next ctx |> themedView (defaultArg page.template "single-page") next ctx
| None -> () | None -> ()
// RSS feed // RSS feed
match Feed.deriveFeedType ctx textLink with 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 -> () | None -> ()
// Post differing only by trailing slash // Post differing only by trailing slash
let altLink = Permalink (if textLink.EndsWith "/" then textLink[..textLink.Length - 2] else $"{textLink}/") let altLink = Permalink (if textLink.EndsWith "/" then textLink[..textLink.Length - 2] else $"{textLink}/")
match Data.Post.findByPermalink altLink webLog.id conn |> await with 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 -> () | None -> ()
// Page differing only by trailing slash // Page differing only by trailing slash
match Data.Page.findByPermalink altLink webLog.id conn |> await with 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 -> () | None -> ()
// Prior post // Prior post
match Data.Post.findCurrentPermalink [ permalink; altLink ] webLog.id conn |> await with 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 -> () | None -> ()
// Prior page // Prior page
match Data.Page.findCurrentPermalink [ permalink; altLink ] webLog.id conn |> await with 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 -> () | None -> ()
debug (fun () -> $"No content found")
} }
// GET {all-of-the-above} // GET {all-of-the-above}