myWebLog/src/MyWebLog/Caches.fs

270 lines
10 KiB
Forth
Raw Normal View History

2022-06-23 00:35:12 +00:00
namespace MyWebLog
open Microsoft.AspNetCore.Http
open MyWebLog.Data
/// Extension properties on HTTP context for web log
[<AutoOpen>]
module Extensions =
open System.Security.Claims
open Microsoft.AspNetCore.Antiforgery
open Microsoft.Extensions.Configuration
2022-06-23 00:35:12 +00:00
open Microsoft.Extensions.DependencyInjection
/// Hold variable for the configured generator string
let mutable private generatorString : string option = None
2022-06-23 00:35:12 +00:00
type HttpContext with
/// The anti-CSRF service
member this.AntiForgery = this.RequestServices.GetRequiredService<IAntiforgery> ()
/// The cross-site request forgery token set for this request
member this.CsrfTokenSet = this.AntiForgery.GetAndStoreTokens this
2022-06-23 00:35:12 +00:00
/// The data implementation
member this.Data = this.RequestServices.GetRequiredService<IData> ()
/// The generator string
member this.Generator =
match generatorString with
| Some gen -> gen
| None ->
let cfg = this.RequestServices.GetRequiredService<IConfiguration> ()
generatorString <-
match Option.ofObj cfg["Generator"] with
| Some gen -> Some gen
| None -> Some "generator not configured"
generatorString.Value
/// The access level for the current user
member this.UserAccessLevel =
this.User.Claims
|> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.Role)
|> Option.map (fun claim -> AccessLevel.parse claim.Value)
/// The user ID for the current request
member this.UserId =
WebLogUserId (this.User.Claims |> Seq.find (fun c -> c.Type = ClaimTypes.NameIdentifier)).Value
/// The web log for the current request
member this.WebLog = this.Items["webLog"] :?> WebLog
/// Does the current user have the requested level of access?
member this.HasAccessLevel level =
defaultArg (this.UserAccessLevel |> Option.map (AccessLevel.hasAccess level)) false
2022-06-23 00:35:12 +00:00
open System.Collections.Concurrent
/// <summary>
/// In-memory cache of web log details
/// </summary>
/// <remarks>This is filled by the middleware via the first request for each host, and can be updated via the web log
/// settings update page</remarks>
module WebLogCache =
open System.Text.RegularExpressions
/// A redirect rule that caches compiled regular expression rules
type CachedRedirectRule =
/// A straight text match rule
| Text of string * string
/// A regular expression match rule
| RegEx of Regex * string
2022-06-23 00:35:12 +00:00
/// The cache of web log details
let mutable private _cache : WebLog list = []
/// Redirect rules with compiled regular expressions
let mutable private _redirectCache = ConcurrentDictionary<WebLogId, CachedRedirectRule list> ()
2022-06-23 00:35:12 +00:00
/// Try to get the web log for the current request (longest matching URL base wins)
let tryGet (path : string) =
_cache
|> List.filter (fun wl -> path.StartsWith wl.UrlBase)
|> List.sortByDescending (fun wl -> wl.UrlBase.Length)
2022-06-23 00:35:12 +00:00
|> List.tryHead
/// Cache the web log for a particular host
let set webLog =
_cache <- webLog :: (_cache |> List.filter (fun wl -> wl.Id <> webLog.Id))
_redirectCache[webLog.Id] <-
webLog.RedirectRules
|> List.map (fun it ->
let relUrl = Permalink >> WebLog.relativeUrl webLog
let urlTo = if it.To.Contains "://" then it.To else relUrl it.To
if it.IsRegex then
let pattern = if it.From.StartsWith "^" then $"^{relUrl (it.From.Substring 1)}" else it.From
RegEx (new Regex (pattern, RegexOptions.Compiled ||| RegexOptions.IgnoreCase), urlTo)
else
Text (relUrl it.From, urlTo))
2022-06-23 00:35:12 +00:00
2022-07-25 03:55:00 +00:00
/// Get all cached web logs
let all () =
_cache
2022-06-23 00:35:12 +00:00
/// Fill the web log cache from the database
let fill (data : IData) = backgroundTask {
let! webLogs = data.WebLog.All ()
webLogs |> List.iter set
2022-06-23 00:35:12 +00:00
}
2022-07-23 01:19:19 +00:00
/// Get the cached redirect rules for the given web log
let redirectRules webLogId =
_redirectCache[webLogId]
2022-07-23 01:19:19 +00:00
/// Is the given theme in use by any web logs?
let isThemeInUse themeId =
_cache |> List.exists (fun wl -> wl.ThemeId = themeId)
2022-06-23 00:35:12 +00:00
/// A cache of page information needed to display the page list in templates
module PageListCache =
open MyWebLog.ViewModels
/// Cache of displayed pages
2022-07-25 03:55:00 +00:00
let private _cache = ConcurrentDictionary<WebLogId, DisplayPage[]> ()
let private fillPages (webLog : WebLog) pages =
_cache[webLog.Id] <-
pages
2023-12-13 20:43:35 +00:00
|> List.map (fun pg -> DisplayPage.FromPage webLog { pg with Text = "" })
2022-07-25 03:55:00 +00:00
|> Array.ofList
2022-06-23 00:35:12 +00:00
/// Are there pages cached for this web log?
2022-07-25 03:55:00 +00:00
let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.Id
2022-06-23 00:35:12 +00:00
/// Get the pages for the web log for this request
2022-07-25 03:55:00 +00:00
let get (ctx : HttpContext) = _cache[ctx.WebLog.Id]
2022-06-23 00:35:12 +00:00
/// Update the pages for the current web log
let update (ctx : HttpContext) = backgroundTask {
2022-07-25 03:55:00 +00:00
let! pages = ctx.Data.Page.FindListed ctx.WebLog.Id
fillPages ctx.WebLog pages
}
/// Refresh the pages for the given web log
let refresh (webLog : WebLog) (data : IData) = backgroundTask {
let! pages = data.Page.FindListed webLog.Id
fillPages webLog pages
2022-06-23 00:35:12 +00:00
}
/// Cache of all categories, indexed by web log
module CategoryCache =
open MyWebLog.ViewModels
/// The cache itself
2022-07-25 03:55:00 +00:00
let private _cache = ConcurrentDictionary<WebLogId, DisplayCategory[]> ()
2022-06-23 00:35:12 +00:00
/// Are there categories cached for this web log?
2022-07-25 03:55:00 +00:00
let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.Id
2022-06-23 00:35:12 +00:00
/// Get the categories for the web log for this request
2022-07-25 03:55:00 +00:00
let get (ctx : HttpContext) = _cache[ctx.WebLog.Id]
2022-06-23 00:35:12 +00:00
/// Update the cache with fresh data
let update (ctx : HttpContext) = backgroundTask {
let! cats = ctx.Data.Category.FindAllForView ctx.WebLog.Id
2022-07-25 03:55:00 +00:00
_cache[ctx.WebLog.Id] <- cats
}
/// Refresh the category cache for the given web log
let refresh webLogId (data : IData) = backgroundTask {
let! cats = data.Category.FindAllForView webLogId
_cache[webLogId] <- cats
2022-06-23 00:35:12 +00:00
}
/// Cache for parsed templates
module TemplateCache =
open System
open System.Text.RegularExpressions
open DotLiquid
/// Cache of parsed templates
let private _cache = ConcurrentDictionary<string, Template> ()
/// Custom include parameter pattern
let private hasInclude = Regex ("""{% include_template \"(.*)\" %}""", RegexOptions.None, TimeSpan.FromSeconds 2)
/// Get a template for the given theme and template name
2022-07-23 01:19:19 +00:00
let get (themeId : ThemeId) (templateName : string) (data : IData) = backgroundTask {
let templatePath = $"{ThemeId.toString themeId}/{templateName}"
2022-06-23 00:35:12 +00:00
match _cache.ContainsKey templatePath with
| true -> return Ok _cache[templatePath]
2022-06-23 00:35:12 +00:00
| false ->
2022-07-23 01:19:19 +00:00
match! data.Theme.FindById themeId with
2022-06-23 00:35:12 +00:00
| Some theme ->
match theme.Templates |> List.tryFind (fun t -> t.Name = templateName) with
| Some template ->
let mutable text = template.Text
let mutable childNotFound = ""
while hasInclude.IsMatch text do
let child = hasInclude.Match text
let childText =
match theme.Templates |> List.tryFind (fun t -> t.Name = child.Groups[1].Value) with
| Some childTemplate -> childTemplate.Text
| None ->
childNotFound <-
if childNotFound = "" then child.Groups[1].Value
else $"{childNotFound}; {child.Groups[1].Value}"
""
text <- text.Replace (child.Value, childText)
if childNotFound <> "" then
let s = if childNotFound.IndexOf ";" >= 0 then "s" else ""
return Error $"Could not find the child template{s} {childNotFound} required by {templateName}"
else
_cache[templatePath] <- Template.Parse (text, SyntaxCompatibility.DotLiquid22)
return Ok _cache[templatePath]
| None ->
return Error $"Theme ID {ThemeId.toString themeId} does not have a template named {templateName}"
| None -> return Result.Error $"Theme ID {ThemeId.toString themeId} does not exist"
2022-06-23 00:35:12 +00:00
}
2022-07-25 03:55:00 +00:00
/// Get all theme/template names currently cached
let allNames () =
_cache.Keys |> Seq.sort |> Seq.toList
2022-06-23 00:35:12 +00:00
/// Invalidate all template cache entries for the given theme ID
2022-07-24 20:32:37 +00:00
let invalidateTheme (themeId : ThemeId) =
let keyPrefix = ThemeId.toString themeId
2022-06-23 00:35:12 +00:00
_cache.Keys
2022-07-24 20:32:37 +00:00
|> Seq.filter (fun key -> key.StartsWith keyPrefix)
2022-06-23 00:35:12 +00:00
|> List.ofSeq
|> List.iter (fun key -> match _cache.TryRemove key with _, _ -> ())
2022-07-25 03:55:00 +00:00
/// Remove all entries from the template cache
let empty () =
_cache.Clear ()
2022-06-23 00:35:12 +00:00
/// A cache of asset names by themes
module ThemeAssetCache =
/// A list of asset names for each theme
let private _cache = ConcurrentDictionary<ThemeId, string list> ()
/// Retrieve the assets for the given theme ID
let get themeId = _cache[themeId]
/// Refresh the list of assets for the given theme
let refreshTheme themeId (data : IData) = backgroundTask {
let! assets = data.ThemeAsset.FindByTheme themeId
_cache[themeId] <- assets |> List.map (fun a -> match a.Id with ThemeAssetId (_, path) -> path)
2022-06-23 00:35:12 +00:00
}
/// Fill the theme asset cache
let fill (data : IData) = backgroundTask {
let! assets = data.ThemeAsset.All ()
2022-06-23 00:35:12 +00:00
for asset in assets do
let (ThemeAssetId (themeId, path)) = asset.Id
2022-06-23 00:35:12 +00:00
if not (_cache.ContainsKey themeId) then _cache[themeId] <- []
_cache[themeId] <- path :: _cache[themeId]
}