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

Version 2.1 #41

Merged
danieljsummers merged 123 commits from version-2.1 into main 2024-03-27 00:13:28 +00:00
Conversation 0 Commits 123 Files Changed 116 +331 -371
16 changed files with 331 additions and 371 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files
Showing only changes of commit cb02055d87 - Show all commits

3
src/MyWebLog.Data/Interfaces.fs
View File

@ -7,6 +7,7 @@ open Newtonsoft.Json
open NodaTime
/// The result of a category deletion attempt
[<Struct>]
type CategoryDeleteResult =
/// The category was deleted successfully
| CategoryDeleted
@ -32,7 +33,7 @@ type ICategoryData =
abstract member Delete : CategoryId -> WebLogId -> Task<CategoryDeleteResult>
/// Find all categories for a web log, sorted alphabetically and grouped by hierarchy
abstract member FindAllForView : WebLogId -> Task<DisplayCategory[]>
abstract member FindAllForView : WebLogId -> Task<DisplayCategory array>
/// Find a category by its ID
abstract member FindById : CategoryId -> WebLogId -> Task<Category option>

6
src/MyWebLog.Data/PostgresData.fs
View File

@ -9,15 +9,15 @@ open Newtonsoft.Json
open Npgsql.FSharp
/// Data implementation for PostgreSQL
type PostgresData (log : ILogger<PostgresData>, ser : JsonSerializer) =
type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
/// Create any needed tables
let ensureTables () = backgroundTask {
// Set up the PostgreSQL document store
Configuration.useSerializer
{ new IDocumentSerializer with
member _.Serialize<'T> (it : 'T) : string = Utils.serialize ser it
member _.Deserialize<'T> (it : string) : 'T = Utils.deserialize ser it
member _.Serialize<'T>(it: 'T) : string = Utils.serialize ser it
member _.Deserialize<'T>(it: string) : 'T = Utils.deserialize ser it
}
let! tables =

39
src/MyWebLog.Data/RethinkDbData.fs
View File

@ -69,20 +69,20 @@ module private RethinkHelpers =
let r = RethinkDB.R
/// Verify that the web log ID matches before returning an item
let verifyWebLog<'T> webLogId (prop : 'T -> WebLogId) (f : Net.IConnection -> Task<'T option>) =
let verifyWebLog<'T> webLogId (prop: 'T -> WebLogId) (f: Net.IConnection -> Task<'T option>) =
fun conn -> backgroundTask {
match! f conn with Some it when (prop it) = webLogId -> return Some it | _ -> return None
}
/// Get the first item from a list, or None if the list is empty
let tryFirst<'T> (f : Net.IConnection -> Task<'T list>) =
let tryFirst<'T> (f: Net.IConnection -> Task<'T list>) =
fun conn -> backgroundTask {
let! results = f conn
return results |> List.tryHead
}
/// Cast a strongly-typed list to an object list
let objList<'T> (objects : 'T list) = objects |> List.map (fun it -> it :> obj)
let objList<'T> (objects: 'T list) = objects |> List.map (fun it -> it :> obj)
open System
@ -92,15 +92,15 @@ open RethinkDb.Driver.FSharp
open RethinkHelpers
/// RethinkDB implementation of data functions for myWebLog
type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<RethinkDbData>) =
type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<RethinkDbData>) =
/// Match theme asset IDs by their prefix (the theme ID)
let matchAssetByThemeId themeId =
let keyPrefix = $"^{themeId}/"
fun (row : Ast.ReqlExpr) -> row[nameof ThemeAsset.Empty.Id].Match keyPrefix :> obj
fun (row: Ast.ReqlExpr) -> row[nameof ThemeAsset.Empty.Id].Match keyPrefix :> obj
/// Function to exclude template text from themes
let withoutTemplateText (row : Ast.ReqlExpr) : obj =
let withoutTemplateText (row: Ast.ReqlExpr) : obj =
{| Templates = row[nameof Theme.Empty.Templates].Without [| nameof ThemeTemplate.Empty.Text |] |}
/// Ensure field indexes exist, as well as special indexes for selected tables
@ -192,7 +192,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
}
/// Set a specific database version
let setDbVersion (version : string) = backgroundTask {
let setDbVersion (version: string) = backgroundTask {
do! rethink {
withTable Table.DbVersion
delete
@ -320,8 +320,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
PostCount = counts
|> Array.tryFind (fun c -> fst c = cat.Id)
|> Option.map snd
|> Option.defaultValue 0
})
|> Option.defaultValue 0 })
|> Array.ofSeq
}
@ -331,7 +330,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
get catId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun c -> c.WebLogId) <| conn
|> verifyWebLog webLogId _.WebLogId <| conn
member _.FindByWebLog webLogId = rethink<Category list> {
withTable Table.Category
@ -533,7 +532,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
nameof page.PriorPermalinks, page.PriorPermalinks
nameof page.Metadata, page.Metadata
nameof page.Revisions, page.Revisions
]
]
write; withRetryDefault; ignoreResult conn
}
@ -586,7 +585,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
without [ nameof Post.Empty.PriorPermalinks; nameof Post.Empty.Revisions ]
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun p -> p.WebLogId) <| conn
|> verifyWebLog webLogId _.WebLogId <| conn
member _.FindByPermalink permalink webLogId =
rethink<Post list> {
@ -604,7 +603,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
get postId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun p -> p.WebLogId) <| conn
|> verifyWebLog webLogId _.WebLogId <| conn
member _.FindCurrentPermalink permalinks webLogId = backgroundTask {
let! result =
@ -617,7 +616,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
result; withRetryDefault
}
|> tryFirst) conn
return result |> Option.map (fun post -> post.Permalink)
return result |> Option.map _.Permalink
}
member _.FindFullByWebLog webLogId = rethink<Post> {
@ -756,7 +755,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
get tagMapId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (_.WebLogId) <| conn
|> verifyWebLog webLogId _.WebLogId <| conn
member _.FindByUrlValue urlValue webLogId =
rethink<TagMap list> {
@ -908,7 +907,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
get uploadId
resultOption; withRetryOptionDefault
}
|> verifyWebLog<Upload> webLogId (fun u -> u.WebLogId) <| conn
|> verifyWebLog<Upload> webLogId _.WebLogId <| conn
match upload with
| Some up ->
do! rethink {
@ -939,7 +938,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
member _.FindByWebLogWithData webLogId = rethink<Upload> {
withTable Table.Upload
between [| webLogId :> obj; r.Minval () |] [| webLogId :> obj; r.Maxval () |]
between [| webLogId :> obj; r.Minval() |] [| webLogId :> obj; r.Maxval() |]
[ Index Index.WebLogAndPath ]
resultCursor; withRetryCursorDefault; toList conn
}
@ -971,7 +970,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
member _.Delete webLogId = backgroundTask {
// Comments should be deleted by post IDs
let! thePostIds = rethink<{| Id : string |} list> {
let! thePostIds = rethink<{| Id: string |} list> {
withTable Table.Post
getAll [ webLogId ] (nameof Post.Empty.WebLogId)
pluck [ nameof Post.Empty.Id ]
@ -1078,7 +1077,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
get userId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun u -> u.WebLogId) <| conn
|> verifyWebLog webLogId _.WebLogId <| conn
member this.Delete userId webLogId = backgroundTask {
match! this.FindById userId webLogId with
@ -1205,7 +1204,7 @@ type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<R
do! ensureIndexes Table.WebLog [ nameof WebLog.Empty.UrlBase ]
do! ensureIndexes Table.WebLogUser [ nameof WebLogUser.Empty.WebLogId ]
let! version = rethink<{| Id : string |} list> {
let! version = rethink<{| Id: string |} list> {
withTable Table.DbVersion
limit 1
result; withRetryOnce conn

17
src/MyWebLog.Data/Utils.fs
View File

@ -9,17 +9,16 @@ open MyWebLog.ViewModels
let currentDbVersion = "v2.1"
/// Create a category hierarchy from the given list of categories
let rec orderByHierarchy (cats : Category list) parentId slugBase parentNames = seq {
let rec orderByHierarchy (cats: Category list) parentId slugBase parentNames = seq {
for cat in cats |> List.filter (fun c -> c.ParentId = parentId) do
let fullSlug = (match slugBase with Some it -> $"{it}/" | None -> "") + cat.Slug
{ Id = string cat.Id
Slug = fullSlug
Name = cat.Name
Description = cat.Description
ParentNames = Array.ofList parentNames
// Post counts are filled on a second pass
PostCount = 0
}
{ Id = string cat.Id
Slug = fullSlug
Name = cat.Name
Description = cat.Description
ParentNames = Array.ofList parentNames
// Post counts are filled on a second pass
PostCount = 0 }
yield! orderByHierarchy cats (Some cat.Id) (Some fullSlug) ([ cat.Name ] |> List.append parentNames)
}

46
src/MyWebLog/Caches.fs
View File

@ -13,25 +13,25 @@ module Extensions =
open Microsoft.Extensions.DependencyInjection
/// Hold variable for the configured generator string
let mutable private generatorString : string option = None
let mutable private generatorString: string option = None
type HttpContext with
/// The anti-CSRF service
member this.AntiForgery = this.RequestServices.GetRequiredService<IAntiforgery> ()
member this.AntiForgery = this.RequestServices.GetRequiredService<IAntiforgery>()
/// The cross-site request forgery token set for this request
member this.CsrfTokenSet = this.AntiForgery.GetAndStoreTokens this
/// The data implementation
member this.Data = this.RequestServices.GetRequiredService<IData> ()
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> ()
let cfg = this.RequestServices.GetRequiredService<IConfiguration>()
generatorString <-
match Option.ofObj cfg["Generator"] with
| Some gen -> Some gen
@ -84,7 +84,7 @@ module WebLogCache =
let tryGet (path : string) =
_cache
|> List.filter (fun wl -> path.StartsWith wl.UrlBase)
|> List.sortByDescending (fun wl -> wl.UrlBase.Length)
|> List.sortByDescending _.UrlBase.Length
|> List.tryHead
/// Cache the web log for a particular host
@ -106,8 +106,8 @@ module WebLogCache =
_cache
/// Fill the web log cache from the database
let fill (data : IData) = backgroundTask {
let! webLogs = data.WebLog.All ()
let fill (data: IData) = backgroundTask {
let! webLogs = data.WebLog.All()
webLogs |> List.iter set
}
@ -126,28 +126,28 @@ module PageListCache =
open MyWebLog.ViewModels
/// Cache of displayed pages
let private _cache = ConcurrentDictionary<WebLogId, DisplayPage[]> ()
let private _cache = ConcurrentDictionary<WebLogId, DisplayPage array> ()
let private fillPages (webLog : WebLog) pages =
let private fillPages (webLog: WebLog) pages =
_cache[webLog.Id] <-
pages
|> List.map (fun pg -> DisplayPage.FromPage webLog { pg with Text = "" })
|> Array.ofList
/// Are there pages cached for this web log?
let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.Id
let exists (ctx: HttpContext) = _cache.ContainsKey ctx.WebLog.Id
/// Get the pages for the web log for this request
let get (ctx : HttpContext) = _cache[ctx.WebLog.Id]
let get (ctx: HttpContext) = _cache[ctx.WebLog.Id]
/// Update the pages for the current web log
let update (ctx : HttpContext) = backgroundTask {
let update (ctx: HttpContext) = backgroundTask {
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 refresh (webLog: WebLog) (data: IData) = backgroundTask {
let! pages = data.Page.FindListed webLog.Id
fillPages webLog pages
}
@ -159,22 +159,22 @@ module CategoryCache =
open MyWebLog.ViewModels
/// The cache itself
let private _cache = ConcurrentDictionary<WebLogId, DisplayCategory[]> ()
let private _cache = ConcurrentDictionary<WebLogId, DisplayCategory array> ()
/// Are there categories cached for this web log?
let exists (ctx : HttpContext) = _cache.ContainsKey ctx.WebLog.Id
let exists (ctx: HttpContext) = _cache.ContainsKey ctx.WebLog.Id
/// Get the categories for the web log for this request
let get (ctx : HttpContext) = _cache[ctx.WebLog.Id]
let get (ctx: HttpContext) = _cache[ctx.WebLog.Id]
/// Update the cache with fresh data
let update (ctx : HttpContext) = backgroundTask {
let update (ctx: HttpContext) = backgroundTask {
let! cats = ctx.Data.Category.FindAllForView ctx.WebLog.Id
_cache[ctx.WebLog.Id] <- cats
}
/// Refresh the category cache for the given web log
let refresh webLogId (data : IData) = backgroundTask {
let refresh webLogId (data: IData) = backgroundTask {
let! cats = data.Category.FindAllForView webLogId
_cache[webLogId] <- cats
}
@ -191,7 +191,7 @@ module TemplateCache =
let private _cache = ConcurrentDictionary<string, Template> ()
/// Custom include parameter pattern
let private hasInclude = Regex ("""{% include_template \"(.*)\" %}""", RegexOptions.None, TimeSpan.FromSeconds 2)
let private hasInclude = Regex("""{% include_template \"(.*)\" %}""", RegexOptions.None, TimeSpan.FromSeconds 2)
/// Get a template for the given theme and template name
let get (themeId: ThemeId) (templateName: string) (data: IData) = backgroundTask {
@ -220,7 +220,7 @@ module TemplateCache =
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)
_cache[templatePath] <- Template.Parse(text, SyntaxCompatibility.DotLiquid22)
return Ok _cache[templatePath]
| None ->
return Error $"Theme ID {themeId} does not have a template named {templateName}"
@ -254,14 +254,14 @@ module ThemeAssetCache =
let get themeId = _cache[themeId]
/// Refresh the list of assets for the given theme
let refreshTheme themeId (data : IData) = backgroundTask {
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)
}
/// Fill the theme asset cache
let fill (data : IData) = backgroundTask {
let! assets = data.ThemeAsset.All ()
let fill (data: IData) = backgroundTask {
let! assets = data.ThemeAsset.All()
for asset in assets do
let (ThemeAssetId (themeId, path)) = asset.Id
if not (_cache.ContainsKey themeId) then _cache[themeId] <- []

16
src/MyWebLog/DotLiquidBespoke.fs
View File

@ -17,7 +17,7 @@ type Context with
/// Does an asset exist for the current theme?
let assetExists fileName (webLog : WebLog) =
let assetExists fileName (webLog: WebLog) =
ThemeAssetCache.get webLog.ThemeId |> List.exists (fun it -> it = fileName)
/// Obtain the link from known types
@ -149,10 +149,10 @@ type PageHeadTag() =
/// Create various items in the page header based on the state of the page being generated
type PageFootTag () =
inherit Tag ()
type PageFootTag() =
inherit Tag()
override this.Render (context : Context, result : TextWriter) =
override this.Render(context: Context, result: TextWriter) =
let webLog = context.WebLog
// spacer
let s = " "
@ -161,12 +161,12 @@ type PageFootTag () =
result.WriteLine $"{s}{RenderView.AsString.htmlNode Htmx.Script.minified}"
if assetExists "script.js" webLog then
result.WriteLine $"""{s}<script src="{ThemeAssetFilter.ThemeAsset (context, "script.js")}"></script>"""
result.WriteLine $"""{s}<script src="{ThemeAssetFilter.ThemeAsset(context, "script.js")}"></script>"""
/// A filter to generate a relative link
type RelativeLinkFilter () =
static member RelativeLink (ctx : Context, item : obj) =
type RelativeLinkFilter() =
static member RelativeLink(ctx: Context, item: obj) =
permalink item ctx.WebLog.RelativeUrl

74
src/MyWebLog/Handlers/Admin.fs
View File

@ -12,7 +12,7 @@ module Dashboard =
// GET /admin/dashboard
let user : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let getCount (f : WebLogId -> Task<int>) = f ctx.WebLog.Id
let getCount (f: WebLogId -> Task<int>) = f ctx.WebLog.Id
let data = ctx.Data
let! posts = getCount (data.Post.CountByStatus Published)
let! drafts = getCount (data.Post.CountByStatus Draft)
@ -89,7 +89,7 @@ module Cache =
do! addMessage ctx
{ UserMessage.Success with Message = "Successfully refresh web log cache for all web logs" }
else
match! data.WebLog.FindById (WebLogId webLogId) with
match! data.WebLog.FindById(WebLogId webLogId) with
| Some webLog ->
WebLogCache.set webLog
do! PageListCache.refresh webLog data
@ -109,17 +109,15 @@ module Cache =
do! ThemeAssetCache.fill data
do! addMessage ctx
{ UserMessage.Success with
Message = "Successfully cleared template cache and refreshed theme asset cache"
}
Message = "Successfully cleared template cache and refreshed theme asset cache" }
else
match! data.Theme.FindById (ThemeId themeId) with
match! data.Theme.FindById(ThemeId themeId) with
| Some theme ->
TemplateCache.invalidateTheme theme.Id
do! ThemeAssetCache.refreshTheme theme.Id data
do! addMessage ctx
{ UserMessage.Success with
Message = $"Successfully cleared template cache and refreshed theme asset cache for {theme.Name}"
}
Message = $"Successfully cleared template cache and refreshed theme asset cache for {theme.Name}" }
| None ->
do! addMessage ctx { UserMessage.Error with Message = $"No theme exists with ID {themeId}" }
return! toAdminDashboard next ctx
@ -156,10 +154,10 @@ module Category =
let edit catId : HttpHandler = fun next ctx -> task {
let! result = task {
match catId with
| "new" -> return Some ("Add a New Category", { Category.Empty with Id = CategoryId "new" })
| "new" -> return Some("Add a New Category", { Category.Empty with Id = CategoryId "new" })
| _ ->
match! ctx.Data.Category.FindById (CategoryId catId) ctx.WebLog.Id with
| Some cat -> return Some ("Edit Category", cat)
| Some cat -> return Some("Edit Category", cat)
| None -> return None
}
match result with
@ -175,7 +173,7 @@ module Category =
// POST /admin/category/save
let save : HttpHandler = fun next ctx -> task {
let data = ctx.Data
let! model = ctx.BindFormAsync<EditCategoryModel> ()
let! model = ctx.BindFormAsync<EditCategoryModel>()
let category =
if model.IsNew then someTask { Category.Empty with Id = CategoryId.Create(); WebLogId = ctx.WebLog.Id }
else data.Category.FindById (CategoryId model.CategoryId) ctx.WebLog.Id
@ -186,8 +184,7 @@ module Category =
Name = model.Name
Slug = model.Slug
Description = if model.Description = "" then None else Some model.Description
ParentId = if model.ParentId = "" then None else Some (CategoryId model.ParentId)
}
ParentId = if model.ParentId = "" then None else Some(CategoryId model.ParentId) }
do! (if model.IsNew then data.Category.Add else data.Category.Update) updatedCat
do! CategoryCache.update ctx
do! addMessage ctx { UserMessage.Success with Message = "Category saved successfully" }
@ -249,7 +246,7 @@ module RedirectRules =
}
/// Update the web log's redirect rules in the database, the request web log, and the web log cache
let private updateRedirectRules (ctx : HttpContext) webLog = backgroundTask {
let private updateRedirectRules (ctx: HttpContext) webLog = backgroundTask {
do! ctx.Data.WebLog.UpdateRedirectRules webLog
ctx.Items["webLog"] <- webLog
WebLogCache.set webLog
@ -311,7 +308,7 @@ module TagMapping =
open Microsoft.AspNetCore.Http
/// Add tag mappings to the given hash
let withTagMappings (ctx : HttpContext) hash = task {
let withTagMappings (ctx: HttpContext) hash = task {
let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id
return
addToHash "mappings" mappings hash
@ -414,9 +411,9 @@ module Theme =
zip.Entries
|> Seq.filter (fun it -> it.Name.EndsWith ".liquid")
|> Seq.map (fun templateItem -> backgroundTask {
use templateFile = new StreamReader (templateItem.Open ())
let! template = templateFile.ReadToEndAsync ()
return { Name = templateItem.Name.Replace (".liquid", ""); Text = template }
use templateFile = new StreamReader(templateItem.Open())
let! template = templateFile.ReadToEndAsync()
return { Name = templateItem.Name.Replace(".liquid", ""); Text = template }
})
let! templates = Task.WhenAll tasks
return
@ -427,37 +424,37 @@ module Theme =
}
/// Update theme assets from the ZIP archive
let private updateAssets themeId (zip : ZipArchive) (data : IData) = backgroundTask {
for asset in zip.Entries |> Seq.filter (fun it -> it.FullName.StartsWith "wwwroot") do
let assetName = asset.FullName.Replace ("wwwroot/", "")
let private updateAssets themeId (zip: ZipArchive) (data: IData) = backgroundTask {
for asset in zip.Entries |> Seq.filter _.FullName.StartsWith("wwwroot") do
let assetName = asset.FullName.Replace("wwwroot/", "")
if assetName <> "" && not (assetName.EndsWith "/") then
use stream = new MemoryStream ()
use stream = new MemoryStream()
do! asset.Open().CopyToAsync stream
do! data.ThemeAsset.Save
{ Id = ThemeAssetId (themeId, assetName)
{ Id = ThemeAssetId(themeId, assetName)
UpdatedOn = LocalDateTime.FromDateTime(asset.LastWriteTime.DateTime)
.InZoneLeniently(DateTimeZone.Utc).ToInstant ()
Data = stream.ToArray ()
.InZoneLeniently(DateTimeZone.Utc).ToInstant()
Data = stream.ToArray()
}
}
/// Derive the theme ID from the file name given
let deriveIdFromFileName (fileName : string) =
let themeName = fileName.Split(".").[0].ToLowerInvariant().Replace (" ", "-")
let deriveIdFromFileName (fileName: string) =
let themeName = fileName.Split(".").[0].ToLowerInvariant().Replace(" ", "-")
if themeName.EndsWith "-theme" then
if Regex.IsMatch (themeName, """^[a-z0-9\-]+$""") then
Ok (ThemeId (themeName.Substring (0, themeName.Length - 6)))
if Regex.IsMatch(themeName, """^[a-z0-9\-]+$""") then
Ok(ThemeId(themeName[..themeName.Length - 6]))
else Error $"Theme ID {fileName} is invalid"
else Error "Theme .zip file name must end in \"-theme.zip\""
/// Load a theme from the given stream, which should contain a ZIP archive
let loadFromZip themeId file (data : IData) = backgroundTask {
let loadFromZip themeId file (data: IData) = backgroundTask {
let! isNew, theme = backgroundTask {
match! data.Theme.FindById themeId with
| Some t -> return false, t
| None -> return true, { Theme.Empty with Id = themeId }
}
use zip = new ZipArchive (file, ZipArchiveMode.Read)
use zip = new ZipArchive(file, ZipArchiveMode.Read)
let! theme = updateNameAndVersion theme zip
if not isNew then do! data.ThemeAsset.DeleteByTheme theme.Id
let! theme = updateTemplates { theme with Templates = [] } zip
@ -489,14 +486,12 @@ module Theme =
do! themeFile.CopyToAsync file
do! addMessage ctx
{ UserMessage.Success with
Message = $"""Theme {if isNew then "add" else "updat"}ed successfully"""
}
Message = $"""Theme {if isNew then "add" else "updat"}ed successfully""" }
return! toAdminDashboard next ctx
else
do! addMessage ctx
{ UserMessage.Error with
Message = "Theme exists and overwriting was not requested; nothing saved"
}
Message = "Theme exists and overwriting was not requested; nothing saved" }
return! toAdminDashboard next ctx
| Ok _ ->
do! addMessage ctx { UserMessage.Error with Message = "You may not replace the admin theme" }
@ -517,8 +512,7 @@ module Theme =
| it when WebLogCache.isThemeInUse (ThemeId it) ->
do! addMessage ctx
{ UserMessage.Error with
Message = $"You may not delete the {themeId} theme, as it is currently in use"
}
Message = $"You may not delete the {themeId} theme, as it is currently in use" }
return! all next ctx
| _ ->
match! data.Theme.Delete (ThemeId themeId) with
@ -588,7 +582,7 @@ module WebLog =
// POST /admin/settings
let saveSettings : HttpHandler = fun next ctx -> task {
let data = ctx.Data
let! model = ctx.BindFormAsync<SettingsModel> ()
let! model = ctx.BindFormAsync<SettingsModel>()
match! data.WebLog.FindById ctx.WebLog.Id with
| Some webLog ->
let oldSlug = webLog.Slug
@ -600,9 +594,9 @@ module WebLog =
if oldSlug <> webLog.Slug then
// Rename disk directory if it exists
let uploadRoot = Path.Combine ("wwwroot", "upload")
let oldDir = Path.Combine (uploadRoot, oldSlug)
if Directory.Exists oldDir then Directory.Move (oldDir, Path.Combine (uploadRoot, webLog.Slug))
let uploadRoot = Path.Combine("wwwroot", "upload")
let oldDir = Path.Combine(uploadRoot, oldSlug)
if Directory.Exists oldDir then Directory.Move(oldDir, Path.Combine(uploadRoot, webLog.Slug))
do! addMessage ctx { UserMessage.Success with Message = "Web log settings saved successfully" }
return! redirectToGet "admin/settings" next ctx

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

@ -23,7 +23,7 @@ type FeedType =
| Custom of CustomFeed * string
/// 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 debug = debug "Feed" ctx
let name = $"/{webLog.Rss.FeedName}"
@ -33,14 +33,14 @@ let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option =
match webLog.Rss.IsFeedEnabled && feedPath = name with
| true ->
debug (fun () -> "Found standard feed")
Some (StandardFeed feedPath, postCount)
Some(StandardFeed feedPath, postCount)
| false ->
// Category and tag feeds are handled by defined routes; check for custom feed
match webLog.Rss.CustomFeeds
|> List.tryFind (fun it -> feedPath.EndsWith(string it.Path)) with
| Some feed ->
debug (fun () -> "Found custom feed")
Some (Custom (feed, feedPath), feed.Podcast |> Option.map _.ItemsInFeed |> Option.defaultValue postCount)
Some(Custom(feed, feedPath), feed.Podcast |> Option.map _.ItemsInFeed |> Option.defaultValue postCount)
| None ->
debug (fun () -> "No matching feed found")
None
@ -61,7 +61,7 @@ let private getFeedPosts ctx feedType =
| Tag tag -> data.Post.FindPageOfTaggedPosts ctx.WebLog.Id tag 1
/// Strip HTML from a string
let private stripHtml text = WebUtility.HtmlDecode <| Regex.Replace (text, "<(.|\n)*?>", "")
let private stripHtml text = WebUtility.HtmlDecode <| Regex.Replace(text, "<(.|\n)*?>", "")
/// XML namespaces for building RSS feeds
[<RequireQualifiedAccess>]
@ -231,8 +231,8 @@ let private addEpisode (webLog: WebLog) (podcast: PodcastOptions) (episode: Epis
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)
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: WebLog) (rssFeed: SyndicationFeed) (feed: CustomFeed) =
@ -313,7 +313,7 @@ let private addPodcast (webLog: WebLog) (rssFeed: SyndicationFeed) (feed: Custom
/// Get the feed's self reference and non-feed link
let private selfAndLink webLog feedType ctx =
let withoutFeed (it : string) = Permalink (it.Replace ($"/{webLog.Rss.FeedName}", ""))
let withoutFeed (it: string) = Permalink(it.Replace($"/{webLog.Rss.FeedName}", ""))
match feedType with
| StandardFeed path
| CategoryFeed (_, path)
@ -325,8 +325,8 @@ let private selfAndLink webLog feedType ctx =
| Tag tag -> feed.Path, Permalink $"""tag/{tag.Replace(" ", "+")}/"""
/// Set the title and description of the feed based on its source
let private setTitleAndDescription feedType (webLog : WebLog) (cats : DisplayCategory[]) (feed : SyndicationFeed) =
let cleanText opt def = TextSyndicationContent (stripHtml (defaultArg opt def))
let private setTitleAndDescription feedType (webLog: WebLog) (cats: DisplayCategory[]) (feed: SyndicationFeed) =
let cleanText opt def = TextSyndicationContent(stripHtml (defaultArg opt def))
match feedType with
| StandardFeed _ ->
feed.Title <- cleanText None webLog.Name
@ -412,7 +412,7 @@ let generate (feedType: FeedType) postCount : HttpHandler = fun next ctx -> back
// POST /admin/settings/rss
let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data
let! model = ctx.BindFormAsync<EditRssModel> ()
let! model = ctx.BindFormAsync<EditRssModel>()
match! data.WebLog.FindById ctx.WebLog.Id with
| Some webLog ->
let webLog = { webLog with Rss = model.UpdateOptions webLog.Rss }
@ -452,7 +452,7 @@ let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
let data = ctx.Data
match! data.WebLog.FindById ctx.WebLog.Id with
| Some webLog ->
let! model = ctx.BindFormAsync<EditCustomFeedModel> ()
let! model = ctx.BindFormAsync<EditCustomFeedModel>()
let theFeed =
match model.Id with
| "new" -> Some { CustomFeed.Empty with Id = CustomFeedId.Create() }
@ -460,13 +460,12 @@ let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
match theFeed with
| Some feed ->
let feeds = model.UpdateFeed feed :: (webLog.Rss.CustomFeeds |> List.filter (fun it -> it.Id <> feed.Id))
let webLog = { webLog with Rss = { webLog.Rss with CustomFeeds = feeds } }
let webLog = { webLog with Rss.CustomFeeds = feeds }
do! data.WebLog.UpdateRssOptions webLog
WebLogCache.set webLog
do! addMessage ctx {
UserMessage.Success with
Message = $"""Successfully {if model.Id = "new" then "add" else "sav"}ed custom feed"""
}
do! addMessage ctx
{ UserMessage.Success with
Message = $"""Successfully {if model.Id = "new" then "add" else "sav"}ed custom feed""" }
return! redirectToGet $"admin/settings/rss/{feed.Id}/edit" next ctx
| None -> return! Error.notFound next ctx
| None -> return! Error.notFound next ctx
@ -479,13 +478,11 @@ let deleteCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun ne
| Some webLog ->
let customId = CustomFeedId feedId
if webLog.Rss.CustomFeeds |> List.exists (fun f -> f.Id = customId) then
let webLog = {
webLog with
Rss = {
webLog.Rss with
CustomFeeds = webLog.Rss.CustomFeeds |> List.filter (fun f -> f.Id <> customId)
}
}
let webLog =
{ webLog with
Rss =
{ webLog.Rss with
CustomFeeds = webLog.Rss.CustomFeeds |> List.filter (fun f -> f.Id <> customId) } }
do! data.WebLog.UpdateRssOptions webLog
WebLogCache.set webLog
do! addMessage ctx { UserMessage.Success with Message = "Custom feed deleted successfully" }

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

@ -8,8 +8,8 @@ open Microsoft.AspNetCore.Http
type ISession with
/// Set an item in the session
member this.Set<'T> (key, item : 'T) =
this.SetString (key, JsonSerializer.Serialize item)
member this.Set<'T>(key, item: 'T) =
this.SetString(key, JsonSerializer.Serialize item)
/// Get an item from the session
member this.TryGet<'T> key =
@ -126,28 +126,28 @@ module ViewContext =
let private sessionLoadedKey = "session-loaded"
/// Load the session if it has not been loaded already; ensures async access but not excessive loading
let private loadSession (ctx : HttpContext) = task {
let private loadSession (ctx: HttpContext) = task {
if not (ctx.Items.ContainsKey sessionLoadedKey) then
do! ctx.Session.LoadAsync ()
ctx.Items.Add (sessionLoadedKey, "yes")
do! ctx.Session.LoadAsync()
ctx.Items.Add(sessionLoadedKey, "yes")
}
/// Ensure that the session is committed
let private commitSession (ctx : HttpContext) = task {
if ctx.Items.ContainsKey sessionLoadedKey then do! ctx.Session.CommitAsync ()
let private commitSession (ctx: HttpContext) = task {
if ctx.Items.ContainsKey sessionLoadedKey then do! ctx.Session.CommitAsync()
}
open MyWebLog.ViewModels
/// Add a message to the user's session
let addMessage (ctx : HttpContext) message = task {
let addMessage (ctx: HttpContext) message = task {
do! loadSession ctx
let msg = match ctx.Session.TryGet<UserMessage list> ViewContext.Messages with Some it -> it | None -> []
ctx.Session.Set (ViewContext.Messages, message :: msg)
ctx.Session.Set(ViewContext.Messages, message :: msg)
}
/// Get any messages from the user's session, removing them in the process
let messages (ctx : HttpContext) = task {
let messages (ctx: HttpContext) = task {
do! loadSession ctx
match ctx.Session.TryGet<UserMessage list> ViewContext.Messages with
| Some msg ->
@ -160,21 +160,21 @@ open MyWebLog
open DotLiquid
/// Shorthand for creating a DotLiquid hash from an anonymous object
let makeHash (values : obj) =
let makeHash (values: obj) =
Hash.FromAnonymousObject values
/// Create a hash with the page title filled
let hashForPage (title : string) =
let hashForPage (title: string) =
makeHash {| page_title = title |}
/// Add a key to the hash, returning the modified hash
// (note that the hash itself is mutated; this is only used to make it pipeable)
let addToHash key (value : obj) (hash : Hash) =
if hash.ContainsKey key then hash[key] <- value else hash.Add (key, value)
let addToHash key (value: obj) (hash: Hash) =
if hash.ContainsKey key then hash[key] <- value else hash.Add(key, value)
hash
/// Add anti-CSRF tokens to the given hash
let withAntiCsrf (ctx : HttpContext) =
let withAntiCsrf (ctx: HttpContext) =
addToHash ViewContext.AntiCsrfTokens ctx.CsrfTokenSet
open System.Security.Claims
@ -186,13 +186,13 @@ open Giraffe.ViewEngine
let private htmxScript = RenderView.AsString.htmlNode Htmx.Script.minified
/// Populate the DotLiquid hash with standard information
let addViewContext ctx (hash : Hash) = task {
let addViewContext ctx (hash: Hash) = task {
let! messages = messages ctx
do! commitSession ctx
return
if hash.ContainsKey ViewContext.HtmxScript && hash.ContainsKey ViewContext.Messages then
// We have already populated everything; just update messages
hash[ViewContext.Messages] <- Array.concat [ hash[ViewContext.Messages] :?> UserMessage[]; messages ]
hash[ViewContext.Messages] <- Array.concat [ hash[ViewContext.Messages] :?> UserMessage array; messages ]
hash
else
ctx.User.Claims
@ -214,11 +214,11 @@ let addViewContext ctx (hash : Hash) = task {
}
/// Is the request from htmx?
let isHtmx (ctx : HttpContext) =
let isHtmx (ctx: HttpContext) =
ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh
/// Convert messages to headers (used for htmx responses)
let messagesToHeaders (messages : UserMessage array) : HttpHandler =
let messagesToHeaders (messages: UserMessage array) : HttpHandler =
seq {
yield!
messages
@ -253,8 +253,7 @@ module Error =
if isHtmx ctx then
let messages = [|
{ UserMessage.Error with
Message = $"You are not authorized to access the URL {ctx.Request.Path.Value}"
}
Message = $"You are not authorized to access the URL {ctx.Request.Path.Value}" }
|]
(messagesToHeaders messages >=> setStatusCode 401) earlyReturn ctx
else setStatusCode 401 earlyReturn ctx
@ -278,7 +277,7 @@ module Error =
/// Render a view for the specified theme, using the specified template, layout, and hash
let viewForTheme themeId template next ctx (hash : Hash) = task {
let viewForTheme themeId template next ctx (hash: Hash) = task {
let! hash = addViewContext ctx hash
// NOTE: DotLiquid does not support {% render %} or {% include %} in its templates, so we will do a 2-pass render;
@ -296,13 +295,13 @@ let viewForTheme themeId template next ctx (hash : Hash) = task {
}
/// Render a bare view for the specified theme, using the specified template and hash
let bareForTheme themeId template next ctx (hash : Hash) = task {
let bareForTheme themeId template next ctx (hash: Hash) = task {
let! hash = addViewContext ctx hash
let withContent = task {
if hash.ContainsKey ViewContext.Content then return Ok hash
else
match! TemplateCache.get themeId template ctx.Data with
| Ok contentTemplate -> return Ok (addToHash ViewContext.Content (contentTemplate.Render hash) hash)
| Ok contentTemplate -> return Ok(addToHash ViewContext.Content (contentTemplate.Render hash) hash)
| Error message -> return Error message
}
match! withContent with
@ -311,7 +310,7 @@ let bareForTheme themeId template next ctx (hash : Hash) = task {
match! TemplateCache.get themeId "layout-bare" ctx.Data with
| Ok layoutTemplate ->
return!
(messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage[])
(messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage array)
>=> htmlString (layoutTemplate.Render completeHash))
next ctx
| Error message -> return! Error.server message next ctx
@ -353,8 +352,7 @@ let requireAccess level : HttpHandler = fun next ctx -> task {
do! addMessage ctx
{ UserMessage.Warning with
Message = $"The page you tried to access requires {level} privileges"
Detail = Some $"Your account only has {userLevel} privileges"
}
Detail = Some $"Your account only has {userLevel} privileges" }
return! Error.notAuthorized next ctx
| None ->
do! addMessage ctx
@ -363,44 +361,44 @@ let requireAccess level : HttpHandler = fun next ctx -> task {
}
/// Determine if a user is authorized to edit a page or post, given the author
let canEdit authorId (ctx : HttpContext) =
let canEdit authorId (ctx: HttpContext) =
ctx.UserId = authorId || ctx.HasAccessLevel Editor
open System.Threading.Tasks
/// Create a Task with a Some result for the given object
let someTask<'T> (it : 'T) = Task.FromResult (Some it)
let someTask<'T> (it: 'T) = Task.FromResult(Some it)
open System.Collections.Generic
open MyWebLog.Data
/// Get the templates available for the current web log's theme (in a key/value pair list)
let templatesForTheme (ctx : HttpContext) (typ : string) = backgroundTask {
let templatesForTheme (ctx: HttpContext) (typ: string) = backgroundTask {
match! ctx.Data.Theme.FindByIdWithoutText ctx.WebLog.ThemeId with
| Some theme ->
return seq {
KeyValuePair.Create ("", $"- Default (single-{typ}) -")
KeyValuePair.Create("", $"- Default (single-{typ}) -")
yield!
theme.Templates
|> Seq.ofList
|> Seq.filter (fun it -> it.Name.EndsWith $"-{typ}" && it.Name <> $"single-{typ}")
|> Seq.map (fun it -> KeyValuePair.Create (it.Name, it.Name))
|> Seq.map (fun it -> KeyValuePair.Create(it.Name, it.Name))
}
|> Array.ofSeq
| None -> return [| KeyValuePair.Create ("", $"- Default (single-{typ}) -") |]
| None -> return [| KeyValuePair.Create("", $"- Default (single-{typ}) -") |]
}
/// Get all authors for a list of posts as metadata items
let getAuthors (webLog : WebLog) (posts : Post list) (data : IData) =
let getAuthors (webLog: WebLog) (posts: Post list) (data: IData) =
posts
|> List.map (fun p -> p.AuthorId)
|> List.map _.AuthorId
|> List.distinct
|> data.WebLogUser.FindNames webLog.Id
/// Get all tag mappings for a list of posts as metadata items
let getTagMappings (webLog : WebLog) (posts : Post list) (data : IData) =
let getTagMappings (webLog: WebLog) (posts: Post list) (data: IData) =
posts
|> List.map (fun p -> p.Tags)
|> List.map _.Tags
|> List.concat
|> List.distinct
|> fun tags -> data.TagMap.FindMappingForTags tags webLog.Id
@ -421,8 +419,8 @@ open System.Globalization
open NodaTime
/// Parse a date/time to UTC
let parseToUtc (date : string) =
Instant.FromDateTimeUtc (DateTime.Parse (date, null, DateTimeStyles.AdjustToUniversal))
let parseToUtc (date: string) =
Instant.FromDateTimeUtc(DateTime.Parse(date, null, DateTimeStyles.AdjustToUniversal))
open Microsoft.Extensions.DependencyInjection
open Microsoft.Extensions.Logging
@ -431,25 +429,24 @@ open Microsoft.Extensions.Logging
let mutable private debugEnabled : bool option = None
/// Is debug enabled for handlers?
let private isDebugEnabled (ctx : HttpContext) =
let private isDebugEnabled (ctx: HttpContext) =
match debugEnabled with
| Some flag -> flag
| None ->
let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory> ()
let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory>()
let log = fac.CreateLogger "MyWebLog.Handlers"
debugEnabled <- Some (log.IsEnabled LogLevel.Debug)
debugEnabled <- Some(log.IsEnabled LogLevel.Debug)
debugEnabled.Value
/// Log a debug message
let debug (name : string) ctx msg =
let debug (name: string) ctx msg =
if isDebugEnabled ctx then
let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory> ()
let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory>()
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 warn (name: string) (ctx: HttpContext) msg =
let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory>()
let log = fac.CreateLogger $"MyWebLog.Handlers.{name}"
log.LogWarning msg

7
src/MyWebLog/Handlers/Page.fs
View File

@ -76,7 +76,7 @@ let editPermalinks pgId : HttpHandler = requireAccess Author >=> fun next ctx ->
// POST /admin/page/permalinks
let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
let! model = ctx.BindFormAsync<ManagePermalinksModel>()
let pageId = PageId model.Id
match! ctx.Data.Page.FindById pageId ctx.WebLog.Id with
| Some pg when canEdit pg.AuthorId ctx ->
@ -117,7 +117,7 @@ let purgeRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx ->
open Microsoft.AspNetCore.Http
/// Find the page and the requested revision
let private findPageRevision pgId revDate (ctx : HttpContext) = task {
let private findPageRevision pgId revDate (ctx: HttpContext) = task {
match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg ->
let asOf = parseToUtc revDate
@ -150,8 +150,7 @@ let restoreRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun
do! ctx.Data.Page.Update
{ pg with
Revisions = { rev with AsOf = Noda.now () }
:: (pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf))
}
:: (pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) }
do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" }
return! redirectToGet $"admin/page/{pgId}/revisions" next ctx
| Some _, Some _ -> return! Error.notAuthorized next ctx

27
src/MyWebLog/Handlers/Post.fs
View File

@ -6,7 +6,7 @@ open System.Collections.Generic
open MyWebLog
/// Parse a slug and page number from an "everything else" URL
let private parseSlugAndPage webLog (slugAndPage : string seq) =
let private parseSlugAndPage webLog (slugAndPage: string seq) =
let fullPath = slugAndPage |> Seq.head
let slugPath = slugAndPage |> Seq.skip 1 |> Seq.head
let slugs, isFeed =
@ -24,9 +24,10 @@ let private parseSlugAndPage webLog (slugAndPage : string seq) =
| idx when idx + 2 = slugs.Length -> Some (int slugs[pageIdx + 1])
| _ -> None
let slugParts = if pageIdx > 0 then Array.truncate pageIdx slugs else slugs
pageNbr, String.Join ("/", slugParts), isFeed
pageNbr, String.Join("/", slugParts), isFeed
/// The type of post list being prepared
[<Struct>]
type ListType =
| AdminList
| CategoryList
@ -55,7 +56,7 @@ let preparePostList webLog posts listType (url: string) pageNbr perPage (data: I
let post = List.head posts
let target = defaultArg post.PublishedOn post.UpdatedOn
data.Post.FindSurroundingPosts webLog.Id target
| _ -> Task.FromResult (None, None)
| _ -> Task.FromResult(None, None)
let newerLink =
match listType, pageNbr with
| SinglePost, _ -> newerPost |> Option.map (fun it -> string it.Permalink)
@ -114,7 +115,7 @@ let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
}
// GET /page/{pageNbr}/
let redirectToPageOfPosts (pageNbr : int) : HttpHandler = fun next ctx ->
let redirectToPageOfPosts (pageNbr: int) : HttpHandler = fun next ctx ->
redirectTo true (ctx.WebLog.RelativeUrl(Permalink $"page/{pageNbr}")) next ctx
// GET /category/{slug}/
@ -163,7 +164,7 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
| None -> return urlTag
}
if isFeed then
return! Feed.generate (Feed.TagFeed (tag, $"tag/{rawTag}/{webLog.Rss.FeedName}"))
return! Feed.generate (Feed.TagFeed(tag, $"tag/{rawTag}/{webLog.Rss.FeedName}"))
(defaultArg webLog.Rss.ItemsInFeed webLog.PostsPerPage) next ctx
else
match! data.Post.FindPageOfTaggedPosts webLog.Id tag pageNbr webLog.PostsPerPage with
@ -178,7 +179,7 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
|> themedView "index" next ctx
// Other systems use hyphens for spaces; redirect if this is an old tag link
| _ ->
let spacedTag = tag.Replace ("-", " ")
let spacedTag = tag.Replace("-", " ")
match! data.Post.FindPageOfTaggedPosts webLog.Id spacedTag pageNbr 1 with
| posts when List.length posts > 0 ->
let endUrl = if pageNbr = 1 then "" else $"page/{pageNbr}"
@ -275,7 +276,7 @@ let editPermalinks postId : HttpHandler = requireAccess Author >=> fun next ctx
// POST /admin/post/permalinks
let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
let! model = ctx.BindFormAsync<ManagePermalinksModel>()
let postId = PostId model.Id
match! ctx.Data.Post.FindById postId ctx.WebLog.Id with
| Some post when canEdit post.AuthorId ctx ->
@ -317,7 +318,7 @@ let purgeRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx
open Microsoft.AspNetCore.Http
/// Find the post and the requested revision
let private findPostRevision postId revDate (ctx : HttpContext) = task {
let private findPostRevision postId revDate (ctx: HttpContext) = task {
match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post ->
let asOf = parseToUtc revDate
@ -350,8 +351,7 @@ let restoreRevision (postId, revDate) : HttpHandler = requireAccess Author >=> f
do! ctx.Data.Post.Update
{ post with
Revisions = { rev with AsOf = Noda.now () }
:: (post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf))
}
:: (post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf)) }
do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" }
return! redirectToGet $"admin/post/{postId}/revisions" next ctx
| Some _, Some _ -> return! Error.notAuthorized next ctx
@ -380,8 +380,8 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
{ Post.Empty with
Id = PostId.Create()
WebLogId = ctx.WebLog.Id
AuthorId = ctx.UserId
} |> someTask
AuthorId = ctx.UserId }
|> someTask
else data.Post.FindFullById (PostId model.PostId) ctx.WebLog.Id
match! tryPost with
| Some post when canEdit post.AuthorId ctx ->
@ -396,8 +396,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
{ post with
PublishedOn = Some dt
UpdatedOn = dt
Revisions = [ { (List.head post.Revisions) with AsOf = dt } ]
}
Revisions = [ { (List.head post.Revisions) with AsOf = dt } ] }
else { post with PublishedOn = Some dt }
else post
do! (if model.PostId = "new" then data.Post.Add else data.Post.Update) updatedPost

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

@ -11,7 +11,7 @@ module CatchAll =
open MyWebLog.ViewModels
/// Sequence where the first returned value is the proper handler for the link
let private deriveAction (ctx: HttpContext): HttpHandler seq =
let private deriveAction (ctx: HttpContext) : HttpHandler seq =
let webLog = ctx.WebLog
let data = ctx.Data
let debug = debug "Routes.CatchAll" ctx
@ -80,7 +80,7 @@ module CatchAll =
}
// GET {all-of-the-above}
let route: HttpHandler = fun next ctx ->
let route : HttpHandler = fun next ctx ->
match deriveAction ctx |> Seq.tryHead with Some handler -> handler next ctx | None -> Error.notFound next ctx

40
src/MyWebLog/Handlers/Upload.fs
View File

@ -12,7 +12,7 @@ module private Helpers =
open Microsoft.AspNetCore.StaticFiles
/// A MIME type mapper instance to use when serving files from the database
let mimeMap = FileExtensionContentTypeProvider ()
let mimeMap = FileExtensionContentTypeProvider()
/// A cache control header that instructs the browser to cache the result for no more than 30 days
let cacheForThirtyDays =
@ -24,7 +24,7 @@ module private Helpers =
let slash = Path.DirectorySeparatorChar
/// The base directory where uploads are stored, relative to the executable
let uploadDir = Path.Combine ("wwwroot", "upload")
let uploadDir = Path.Combine("wwwroot", "upload")
// ~~ SERVING UPLOADS ~~
@ -35,10 +35,10 @@ open Microsoft.AspNetCore.Http
open NodaTime
/// Determine if the file has been modified since the date/time specified by the If-Modified-Since header
let checkModified since (ctx : HttpContext) : HttpHandler option =
let checkModified since (ctx: HttpContext) : HttpHandler option =
match ctx.Request.Headers.IfModifiedSince with
| it when it.Count < 1 -> None
| it when since > Instant.FromDateTimeUtc (DateTime.Parse (it[0], null, DateTimeStyles.AdjustToUniversal)) -> None
| it when since > Instant.FromDateTimeUtc(DateTime.Parse(it[0], null, DateTimeStyles.AdjustToUniversal)) -> None
| _ -> Some (setStatusCode 304)
@ -53,29 +53,29 @@ let sendFile updatedOn path (data : byte[]) : HttpHandler = fun next ctx ->
let headers = ResponseHeaders ctx.Response.Headers
headers.ContentType <- (deriveMimeType >> MediaTypeHeaderValue) path
headers.CacheControl <- cacheForThirtyDays
let stream = new MemoryStream (data)
let stream = new MemoryStream(data)
streamData true stream None (Some (DateTimeOffset updatedOn)) next ctx
open MyWebLog
// GET /upload/{web-log-slug}/{**path}
let serve (urlParts : string seq) : HttpHandler = fun next ctx -> task {
let serve (urlParts: string seq) : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog
let parts = (urlParts |> Seq.skip 1 |> Seq.head).Split '/'
let slug = Array.head parts
if slug = webLog.Slug then
// Static file middleware will not work in subdirectories; check for an actual file first
let fileName = Path.Combine ("wwwroot", (Seq.head urlParts)[1..])
let fileName = Path.Combine("wwwroot", (Seq.head urlParts)[1..])
if File.Exists fileName then
return! streamFile true fileName None None next ctx
else
let path = String.Join ('/', Array.skip 1 parts)
let path = String.Join('/', Array.skip 1 parts)
match! ctx.Data.Upload.FindByPath path webLog.Id with
| Some upload ->
match checkModified upload.UpdatedOn ctx with
| Some threeOhFour -> return! threeOhFour next ctx
| None -> return! sendFile (upload.UpdatedOn.ToDateTimeUtc ()) path upload.Data next ctx
| None -> return! sendFile (upload.UpdatedOn.ToDateTimeUtc()) path upload.Data next ctx
| None -> return! Error.notFound next ctx
else
return! Error.notFound next ctx
@ -87,28 +87,27 @@ open System.Text.RegularExpressions
open MyWebLog.ViewModels
/// Turn a string into a lowercase URL-safe slug
let makeSlug it = ((Regex """\s+""").Replace ((Regex "[^A-z0-9 -]").Replace (it, ""), "-")).ToLowerInvariant ()
let makeSlug it = (Regex """\s+""").Replace((Regex "[^A-z0-9 -]").Replace(it, ""), "-").ToLowerInvariant()
// GET /admin/uploads
let list : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let webLog = ctx.WebLog
let! dbUploads = ctx.Data.Upload.FindByWebLog webLog.Id
let diskUploads =
let path = Path.Combine (uploadDir, webLog.Slug)
let path = Path.Combine(uploadDir, webLog.Slug)
try
Directory.EnumerateFiles (path, "*", SearchOption.AllDirectories)
Directory.EnumerateFiles(path, "*", SearchOption.AllDirectories)
|> Seq.map (fun file ->
let name = Path.GetFileName file
let create =
match File.GetCreationTime (Path.Combine (path, file)) with
match File.GetCreationTime(Path.Combine(path, file)) with
| dt when dt > DateTime.UnixEpoch -> Some dt
| _ -> None
{ DisplayUpload.Id = ""
Name = name
Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace (slash, '/')
Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace(slash, '/')
UpdatedOn = create
Source = string Disk
})
Source = string Disk })
|> List.ofSeq
with
| :? DirectoryNotFoundException -> [] // This is fine
@ -160,8 +159,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
WebLogId = ctx.WebLog.Id
Path = Permalink $"{year}/{month}/{fileName}"
UpdatedOn = now
Data = stream.ToArray()
}
Data = stream.ToArray() }
do! ctx.Data.Upload.Add file
| Disk ->
let fullPath = Path.Combine(uploadDir, ctx.WebLog.Slug, year, month)
@ -185,11 +183,11 @@ let deleteFromDb upId : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx
}
/// Remove a directory tree if it is empty
let removeEmptyDirectories (webLog : WebLog) (filePath : string) =
let removeEmptyDirectories (webLog: WebLog) (filePath: string) =
let mutable path = Path.GetDirectoryName filePath
let mutable finished = false
while (not finished) && path > "" do
let fullPath = Path.Combine (uploadDir, webLog.Slug, path)
let fullPath = Path.Combine(uploadDir, webLog.Slug, path)
if Directory.EnumerateFileSystemEntries fullPath |> Seq.isEmpty then
Directory.Delete fullPath
path <- String.Join(slash, path.Split slash |> Array.rev |> Array.skip 1 |> Array.rev)
@ -198,7 +196,7 @@ let removeEmptyDirectories (webLog : WebLog) (filePath : string) =
// POST /admin/upload/delete/{**path}
let deleteFromDisk urlParts : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let filePath = urlParts |> Seq.skip 1 |> Seq.head
let path = Path.Combine (uploadDir, ctx.WebLog.Slug, filePath)
let path = Path.Combine(uploadDir, ctx.WebLog.Slug, filePath)
if File.Exists path then
File.Delete path
removeEmptyDirectories ctx.WebLog filePath

37
src/MyWebLog/Handlers/User.fs
View File

@ -11,17 +11,17 @@ open NodaTime
/// Create a password hash a password for a given user
let createPasswordHash user password =
PasswordHasher<WebLogUser>().HashPassword (user, password)
PasswordHasher<WebLogUser>().HashPassword(user, password)
/// Verify whether a password is valid
let verifyPassword user password (ctx : HttpContext) = backgroundTask {
let verifyPassword user password (ctx: HttpContext) = backgroundTask {
match user with
| Some usr ->
let hasher = PasswordHasher<WebLogUser> ()
match hasher.VerifyHashedPassword (usr, usr.PasswordHash, password) with
let hasher = PasswordHasher<WebLogUser>()
match hasher.VerifyHashedPassword(usr, usr.PasswordHash, password) with
| PasswordVerificationResult.Success -> return Ok ()
| PasswordVerificationResult.SuccessRehashNeeded ->
do! ctx.Data.WebLogUser.Update { usr with PasswordHash = hasher.HashPassword (usr, password) }
do! ctx.Data.WebLogUser.Update { usr with PasswordHash = hasher.HashPassword(usr, password) }
return Ok ()
| _ -> return Error "Log on attempt unsuccessful"
| None -> return Error "Log on attempt unsuccessful"
@ -68,11 +68,10 @@ let doLogOn : HttpHandler = fun next ctx -> task {
do! addMessage ctx
{ UserMessage.Success with
Message = "Log on successful"
Detail = Some $"Welcome to {ctx.WebLog.Name}!"
}
Detail = Some $"Welcome to {ctx.WebLog.Name}!" }
return!
match model.ReturnTo with
| Some url -> redirectTo false url next ctx
| Some url -> redirectTo false url next ctx // TODO: change to redirectToGet?
| None -> redirectToGet "admin/dashboard" next ctx
| Error msg ->
do! addMessage ctx { UserMessage.Error with Message = msg }
@ -105,7 +104,7 @@ let all : HttpHandler = fun next ctx -> task {
}
/// Show the edit user page
let private showEdit (model : EditUserModel) : HttpHandler = fun next ctx ->
let private showEdit (model: EditUserModel) : HttpHandler = fun next ctx ->
hashForPage (if model.IsNew then "Add a New User" else "Edit User")
|> withAntiCsrf ctx
|> addToHash ViewContext.Model model
@ -141,15 +140,13 @@ let delete userId : HttpHandler = fun next ctx -> task {
| Ok _ ->
do! addMessage ctx
{ UserMessage.Success with
Message = $"User {user.DisplayName} deleted successfully"
}
Message = $"User {user.DisplayName} deleted successfully" }
return! all next ctx
| Error msg ->
do! addMessage ctx
{ UserMessage.Error with
Message = $"User {user.DisplayName} was not deleted"
Detail = Some msg
}
Detail = Some msg }
return! all next ctx
| None -> return! Error.notFound next ctx
}
@ -174,7 +171,7 @@ let myInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
// POST /admin/my-info
let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditMyInfoModel> ()
let! model = ctx.BindFormAsync<EditMyInfoModel>()
let data = ctx.Data
match! data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with
| Some user when model.NewPassword = model.NewPasswordConfirm ->
@ -184,8 +181,7 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
FirstName = model.FirstName
LastName = model.LastName
PreferredName = model.PreferredName
PasswordHash = pw
}
PasswordHash = pw }
do! data.WebLogUser.Update user
let pwMsg = if model.NewPassword = "" then "" else " and updated your password"
do! addMessage ctx { UserMessage.Success with Message = $"Saved your information{pwMsg} successfully" }
@ -201,15 +197,15 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
// POST /admin/settings/user/save
let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditUserModel> ()
let! model = ctx.BindFormAsync<EditUserModel>()
let data = ctx.Data
let tryUser =
if model.IsNew then
{ WebLogUser.Empty with
Id = WebLogUserId.Create()
WebLogId = ctx.WebLog.Id
CreatedOn = Noda.now ()
} |> someTask
CreatedOn = Noda.now () }
|> someTask
else data.WebLogUser.FindById (WebLogUserId model.Id) ctx.WebLog.Id
match! tryUser with
| Some user when model.Password = model.PasswordConfirm ->
@ -223,8 +219,7 @@ let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
do! (if model.IsNew then data.WebLogUser.Add else data.WebLogUser.Update) toUpdate
do! addMessage ctx
{ UserMessage.Success with
Message = $"""{if model.IsNew then "Add" else "Updat"}ed user successfully"""
}
Message = $"""{if model.IsNew then "Add" else "Updat"}ed user successfully""" }
return! all next ctx
| Some _ ->
do! addMessage ctx { UserMessage.Error with Message = "The passwords did not match; nothing saved" }

152
src/MyWebLog/Maintenance.fs
View File

@ -7,9 +7,9 @@ open MyWebLog.Data
open NodaTime
/// Create the web log information
let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
let private doCreateWebLog (args: string[]) (sp: IServiceProvider) = task {
let data = sp.GetRequiredService<IData> ()
let data = sp.GetRequiredService<IData>()
let timeZone =
let local = TimeZoneInfo.Local.Id
@ -38,8 +38,7 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
Slug = slug
UrlBase = args[1]
DefaultPage = string homePageId
TimeZone = timeZone
}
TimeZone = timeZone }
// Create the admin user
let now = Noda.now ()
@ -52,8 +51,7 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
LastName = "User"
PreferredName = "Admin"
AccessLevel = accessLevel
CreatedOn = now
}
CreatedOn = now }
do! data.WebLogUser.Add { user with PasswordHash = Handlers.User.createPasswordHash user args[4] }
// Create the default home page
@ -69,16 +67,14 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
Text = "<p>This is your default home page.</p>"
Revisions = [
{ AsOf = now
Text = Html "<p>This is your default home page.</p>"
}
]
}
Text = Html "<p>This is your default home page.</p>" }
] }
printfn $"Successfully initialized database for {args[2]} with URL base {args[1]}"
match accessLevel with
| Administrator -> printfn $" ({args[3]} is an installation administrator)"
| WebLogAdmin ->
printfn $" ({args[3]} is a web log administrator;"
printfn $" ({args[3]} is a web log administrator;"
printfn """ use "upgrade-user" to promote to installation administrator)"""
| _ -> ()
}
@ -91,8 +87,8 @@ let createWebLog args sp = task {
}
/// Import prior permalinks from a text files with lines in the format "[old] [new]"
let private importPriorPermalinks urlBase file (sp : IServiceProvider) = task {
let data = sp.GetRequiredService<IData> ()
let private importPriorPermalinks urlBase file (sp: IServiceProvider) = task {
let data = sp.GetRequiredService<IData>()
match! data.WebLog.FindByHost urlBase with
| Some webLog ->
@ -129,7 +125,7 @@ let importLinks args sp = task {
open Microsoft.Extensions.Logging
/// Load a theme from the given ZIP file
let loadTheme (args : string[]) (sp : IServiceProvider) = task {
let loadTheme (args: string[]) (sp: IServiceProvider) = task {
if args.Length = 2 then
let fileName =
match args[1].LastIndexOf Path.DirectorySeparatorChar with
@ -137,12 +133,12 @@ let loadTheme (args : string[]) (sp : IServiceProvider) = task {
| it -> args[1][(it + 1)..]
match Handlers.Admin.Theme.deriveIdFromFileName fileName with
| Ok themeId ->
let data = sp.GetRequiredService<IData> ()
use stream = File.Open (args[1], FileMode.Open)
use copy = new MemoryStream ()
let data = sp.GetRequiredService<IData>()
use stream = File.Open(args[1], FileMode.Open)
use copy = new MemoryStream()
do! stream.CopyToAsync copy
let! theme = Handlers.Admin.Theme.loadFromZip themeId copy data
let fac = sp.GetRequiredService<ILoggerFactory> ()
let fac = sp.GetRequiredService<ILoggerFactory>()
let log = fac.CreateLogger "MyWebLog.Themes"
log.LogInformation $"{theme.Name} v{theme.Version} ({theme.Id}) loaded"
| Error message -> eprintfn $"{message}"
@ -159,103 +155,96 @@ module Backup =
/// A theme asset, with the data base-64 encoded
type EncodedAsset =
{ /// The ID of the theme asset
Id : ThemeAssetId
Id: ThemeAssetId
/// The updated date for this asset
UpdatedOn : Instant
UpdatedOn: Instant
/// The data for this asset, base-64 encoded
Data : string
}
Data: string }
/// Create an encoded theme asset from the original theme asset
static member fromAsset (asset : ThemeAsset) =
static member fromAsset (asset: ThemeAsset) =
{ Id = asset.Id
UpdatedOn = asset.UpdatedOn
Data = Convert.ToBase64String asset.Data
}
Data = Convert.ToBase64String asset.Data }
/// Create a theme asset from an encoded theme asset
static member toAsset (encoded : EncodedAsset) : ThemeAsset =
static member toAsset (encoded: EncodedAsset) : ThemeAsset =
{ Id = encoded.Id
UpdatedOn = encoded.UpdatedOn
Data = Convert.FromBase64String encoded.Data
}
Data = Convert.FromBase64String encoded.Data }
/// An uploaded file, with the data base-64 encoded
type EncodedUpload =
{ /// The ID of the upload
Id : UploadId
Id: UploadId
/// The ID of the web log to which the upload belongs
WebLogId : WebLogId
WebLogId: WebLogId
/// The path at which this upload is served
Path : Permalink
Path: Permalink
/// The date/time this upload was last updated (file time)
UpdatedOn : Instant
UpdatedOn: Instant
/// The data for the upload, base-64 encoded
Data : string
}
Data: string }
/// Create an encoded uploaded file from the original uploaded file
static member fromUpload (upload : Upload) : EncodedUpload =
static member fromUpload (upload: Upload) : EncodedUpload =
{ Id = upload.Id
WebLogId = upload.WebLogId
Path = upload.Path
UpdatedOn = upload.UpdatedOn
Data = Convert.ToBase64String upload.Data
}
Data = Convert.ToBase64String upload.Data }
/// Create an uploaded file from an encoded uploaded file
static member toUpload (encoded : EncodedUpload) : Upload =
static member toUpload (encoded: EncodedUpload) : Upload =
{ Id = encoded.Id
WebLogId = encoded.WebLogId
Path = encoded.Path
UpdatedOn = encoded.UpdatedOn
Data = Convert.FromBase64String encoded.Data
}
Data = Convert.FromBase64String encoded.Data }
/// A unified archive for a web log
type Archive =
{ /// The web log to which this archive belongs
WebLog : WebLog
WebLog: WebLog
/// The users for this web log
Users : WebLogUser list
Users: WebLogUser list
/// The theme used by this web log at the time the archive was made
Theme : Theme
Theme: Theme
/// Assets for the theme used by this web log at the time the archive was made
Assets : EncodedAsset list
Assets: EncodedAsset list
/// The categories for this web log
Categories : Category list
Categories: Category list
/// The tag mappings for this web log
TagMappings : TagMap list
TagMappings: TagMap list
/// The pages for this web log (containing only the most recent revision)
Pages : Page list
Pages: Page list
/// The posts for this web log (containing only the most recent revision)
Posts : Post list
Posts: Post list
/// The uploaded files for this web log
Uploads : EncodedUpload list
}
Uploads: EncodedUpload list }
/// Create a JSON serializer
let private getSerializer prettyOutput =
let serializer = Json.configure (JsonSerializer.CreateDefault ())
let serializer = Json.configure (JsonSerializer.CreateDefault())
if prettyOutput then serializer.Formatting <- Formatting.Indented
serializer
/// Display statistics for a backup archive
let private displayStats (msg : string) (webLog : WebLog) archive =
let private displayStats (msg: string) (webLog: WebLog) archive =
let userCount = List.length archive.Users
let assetCount = List.length archive.Assets
@ -280,7 +269,7 @@ module Backup =
printfn $""" - {uploadCount} uploaded file{plural uploadCount "" "s"}"""
/// Create a backup archive
let private createBackup webLog (fileName : string) prettyOutput (data : IData) = task {
let private createBackup webLog (fileName: string) prettyOutput (data: IData) = task {
// Create the data structure
printfn "- Exporting theme..."
let! theme = data.Theme.FindById webLog.ThemeId
@ -312,25 +301,24 @@ module Backup =
TagMappings = tagMaps
Pages = pages |> List.map (fun p -> { p with Revisions = List.truncate 1 p.Revisions })
Posts = posts |> List.map (fun p -> { p with Revisions = List.truncate 1 p.Revisions })
Uploads = uploads |> List.map EncodedUpload.fromUpload
}
Uploads = uploads |> List.map EncodedUpload.fromUpload }
// Write the structure to the backup file
if File.Exists fileName then File.Delete fileName
let serializer = getSerializer prettyOutput
use writer = new StreamWriter (fileName)
serializer.Serialize (writer, archive)
writer.Close ()
use writer = new StreamWriter(fileName)
serializer.Serialize(writer, archive)
writer.Close()
displayStats $"{fileName} (for <>NAME<>) contains:" webLog archive
}
let private doRestore archive newUrlBase (data : IData) = task {
let private doRestore archive newUrlBase (data: IData) = task {
let! restore = task {
match! data.WebLog.FindById archive.WebLog.Id with
| Some webLog when defaultArg newUrlBase webLog.UrlBase = webLog.UrlBase ->
do! data.WebLog.Delete webLog.Id
return { archive with WebLog = { archive.WebLog with UrlBase = defaultArg newUrlBase webLog.UrlBase } }
return { archive with Archive.WebLog.UrlBase = defaultArg newUrlBase webLog.UrlBase }
| Some _ ->
// Err'body gets new IDs...
let newWebLogId = WebLogId.Create()
@ -354,24 +342,18 @@ module Backup =
{ page with
Id = newPageIds[page.Id]
WebLogId = newWebLogId
AuthorId = newUserIds[page.AuthorId]
})
AuthorId = newUserIds[page.AuthorId] })
Posts = archive.Posts
|> List.map (fun post ->
{ post with
Id = newPostIds[post.Id]
WebLogId = newWebLogId
AuthorId = newUserIds[post.AuthorId]
CategoryIds = post.CategoryIds |> List.map (fun c -> newCatIds[c])
})
CategoryIds = post.CategoryIds |> List.map (fun c -> newCatIds[c]) })
Uploads = archive.Uploads
|> List.map (fun u -> { u with Id = newUpIds[u.Id]; WebLogId = newWebLogId })
}
|> List.map (fun u -> { u with Id = newUpIds[u.Id]; WebLogId = newWebLogId }) }
| None ->
return
{ archive with
WebLog = { archive.WebLog with UrlBase = defaultArg newUrlBase archive.WebLog.UrlBase }
}
return { archive with Archive.WebLog.UrlBase = defaultArg newUrlBase archive.WebLog.UrlBase }
}
// Restore theme and assets (one at a time, as assets can be large)
@ -413,12 +395,12 @@ module Backup =
}
/// Decide whether to restore a backup
let private restoreBackup (fileName : string) newUrlBase promptForOverwrite data = task {
let private restoreBackup fileName newUrlBase promptForOverwrite data = task {
let serializer = getSerializer false
use stream = new FileStream (fileName, FileMode.Open)
use reader = new StreamReader (stream)
use jsonReader = new JsonTextReader (reader)
use stream = new FileStream(fileName, FileMode.Open)
use reader = new StreamReader(stream)
use jsonReader = new JsonTextReader(reader)
let archive = serializer.Deserialize<Archive> jsonReader
let mutable doOverwrite = not promptForOverwrite
@ -428,7 +410,7 @@ module Backup =
printfn " theme in either case."
printfn ""
printf "Continue? [Y/n] "
doOverwrite <- not ((Console.ReadKey ()).Key = ConsoleKey.N)
doOverwrite <- not (Console.ReadKey().Key = ConsoleKey.N)
if doOverwrite then
do! doRestore archive newUrlBase data
@ -437,9 +419,9 @@ module Backup =
}
/// Generate a backup archive
let generateBackup (args : string[]) (sp : IServiceProvider) = task {
let generateBackup (args: string[]) (sp: IServiceProvider) = task {
if args.Length > 1 && args.Length < 5 then
let data = sp.GetRequiredService<IData> ()
let data = sp.GetRequiredService<IData>()
match! data.WebLog.FindByHost args[1] with
| Some webLog ->
let fileName =
@ -459,9 +441,9 @@ module Backup =
}
/// Restore a backup archive
let restoreFromBackup (args : string[]) (sp : IServiceProvider) = task {
let restoreFromBackup (args: string[]) (sp: IServiceProvider) = task {
if args.Length = 2 || args.Length = 3 then
let data = sp.GetRequiredService<IData> ()
let data = sp.GetRequiredService<IData>()
let newUrlBase = if args.Length = 3 then Some args[2] else None
do! restoreBackup args[1] newUrlBase (args[0] <> "do-restore") data
else
@ -472,7 +454,7 @@ module Backup =
/// Upgrade a WebLogAdmin user to an Administrator user
let private doUserUpgrade urlBase email (data : IData) = task {
let private doUserUpgrade urlBase email (data: IData) = task {
match! data.WebLog.FindByHost urlBase with
| Some webLog ->
match! data.WebLogUser.FindByEmail email webLog.Id with
@ -487,14 +469,14 @@ let private doUserUpgrade urlBase email (data : IData) = task {
}
/// Upgrade a WebLogAdmin user to an Administrator user if the command-line arguments are good
let upgradeUser (args : string[]) (sp : IServiceProvider) = task {
let upgradeUser (args: string[]) (sp: IServiceProvider) = task {
match args.Length with
| 3 -> do! doUserUpgrade args[1] args[2] (sp.GetRequiredService<IData> ())
| 3 -> do! doUserUpgrade args[1] args[2] (sp.GetRequiredService<IData>())
| _ -> eprintfn "Usage: myWebLog upgrade-user [web-log-url-base] [email-address]"
}
/// Set a user's password
let doSetPassword urlBase email password (data : IData) = task {
let doSetPassword urlBase email password (data: IData) = task {
match! data.WebLog.FindByHost urlBase with
| Some webLog ->
match! data.WebLogUser.FindByEmail email webLog.Id with
@ -506,8 +488,8 @@ let doSetPassword urlBase email password (data : IData) = task {
}
/// Set a user's password if the command-line arguments are good
let setPassword (args : string[]) (sp : IServiceProvider) = task {
let setPassword (args: string[]) (sp: IServiceProvider) = task {
match args.Length with
| 4 -> do! doSetPassword args[1] args[2] args[3] (sp.GetRequiredService<IData> ())
| 4 -> do! doSetPassword args[1] args[2] args[3] (sp.GetRequiredService<IData>())
| _ -> eprintfn "Usage: myWebLog set-password [web-log-url-base] [email-address] [password]"
}

98
src/MyWebLog/Program.fs
View File

@ -5,12 +5,12 @@ open Microsoft.Extensions.Logging
open MyWebLog
/// Middleware to derive the current web log
type WebLogMiddleware (next : RequestDelegate, log : ILogger<WebLogMiddleware>) =
type WebLogMiddleware(next: RequestDelegate, log: ILogger<WebLogMiddleware>) =
/// Is the debug level enabled on the logger?
let isDebug = log.IsEnabled LogLevel.Debug
member _.InvokeAsync (ctx : HttpContext) = task {
member _.InvokeAsync(ctx: HttpContext) = task {
/// Create the full path of the request
let path = $"{ctx.Request.Scheme}://{ctx.Request.Host.Value}{ctx.Request.Path.Value}"
match WebLogCache.tryGet path with
@ -27,14 +27,14 @@ type WebLogMiddleware (next : RequestDelegate, log : ILogger<WebLogMiddleware>)
/// Middleware to check redirects for the current web log
type RedirectRuleMiddleware (next : RequestDelegate, log : ILogger<RedirectRuleMiddleware>) =
type RedirectRuleMiddleware(next: RequestDelegate, log: ILogger<RedirectRuleMiddleware>) =
/// Shorthand for case-insensitive string equality
let ciEquals str1 str2 =
System.String.Equals (str1, str2, System.StringComparison.InvariantCultureIgnoreCase)
System.String.Equals(str1, str2, System.StringComparison.InvariantCultureIgnoreCase)
member _.InvokeAsync (ctx : HttpContext) = task {
let path = ctx.Request.Path.Value.ToLower ()
member _.InvokeAsync(ctx: HttpContext) = task {
let path = ctx.Request.Path.Value.ToLower()
let matched =
WebLogCache.redirectRules ctx.WebLog.Id
|> List.tryPick (fun rule ->
@ -42,9 +42,9 @@ type RedirectRuleMiddleware (next : RequestDelegate, log : ILogger<RedirectRuleM
| WebLogCache.CachedRedirectRule.Text (urlFrom, urlTo) ->
if ciEquals path urlFrom then Some urlTo else None
| WebLogCache.CachedRedirectRule.RegEx (regExFrom, patternTo) ->
if regExFrom.IsMatch path then Some (regExFrom.Replace (path, patternTo)) else None)
if regExFrom.IsMatch path then Some (regExFrom.Replace(path, patternTo)) else None)
match matched with
| Some url -> ctx.Response.Redirect (url, permanent = true)
| Some url -> ctx.Response.Redirect(url, permanent = true)
| None -> return! next.Invoke ctx
}
@ -64,39 +64,39 @@ module DataImplementation =
open RethinkDb.Driver.Net
/// Create an NpgsqlDataSource from the connection string, configuring appropriately
let createNpgsqlDataSource (cfg : IConfiguration) =
let builder = NpgsqlDataSourceBuilder (cfg.GetConnectionString "PostgreSQL")
let _ = builder.UseNodaTime ()
let createNpgsqlDataSource (cfg: IConfiguration) =
let builder = NpgsqlDataSourceBuilder(cfg.GetConnectionString "PostgreSQL")
let _ = builder.UseNodaTime()
// let _ = builder.UseLoggerFactory(LoggerFactory.Create(fun it -> it.AddConsole () |> ignore))
(builder.Build >> Configuration.useDataSource) ()
/// Get the configured data implementation
let get (sp : IServiceProvider) : IData =
let config = sp.GetRequiredService<IConfiguration> ()
let get (sp: IServiceProvider) : IData =
let config = sp.GetRequiredService<IConfiguration>()
let await it = (Async.AwaitTask >> Async.RunSynchronously) it
let connStr name = config.GetConnectionString name
let hasConnStr name = (connStr >> isNull >> not) name
let createSQLite connStr : IData =
let log = sp.GetRequiredService<ILogger<SQLiteData>> ()
let conn = new SqliteConnection (connStr)
let log = sp.GetRequiredService<ILogger<SQLiteData>>()
let conn = new SqliteConnection(connStr)
log.LogInformation $"Using SQLite database {conn.DataSource}"
await (SQLiteData.setUpConnection conn)
SQLiteData (conn, log, Json.configure (JsonSerializer.CreateDefault ()))
SQLiteData(conn, log, Json.configure (JsonSerializer.CreateDefault()))
if hasConnStr "SQLite" then
createSQLite (connStr "SQLite")
elif hasConnStr "RethinkDB" then
let log = sp.GetRequiredService<ILogger<RethinkDbData>> ()
let log = sp.GetRequiredService<ILogger<RethinkDbData>>()
let _ = Json.configure Converter.Serializer
let rethinkCfg = DataConfig.FromUri (connStr "RethinkDB")
let conn = await (rethinkCfg.CreateConnectionAsync log)
RethinkDbData (conn, rethinkCfg, log)
RethinkDbData(conn, rethinkCfg, log)
elif hasConnStr "PostgreSQL" then
createNpgsqlDataSource config
use conn = Configuration.dataSource().CreateConnection ()
let log = sp.GetRequiredService<ILogger<PostgresData>> ()
use conn = Configuration.dataSource().CreateConnection()
let log = sp.GetRequiredService<ILogger<PostgresData>>()
log.LogInformation $"Using PostgreSQL database {conn.Database}"
PostgresData (log, Json.configure (JsonSerializer.CreateDefault ()))
PostgresData(log, Json.configure (JsonSerializer.CreateDefault()))
else
createSQLite "Data Source=./myweblog.db;Cache=Shared"
@ -119,7 +119,7 @@ let showHelp () =
printfn "upgrade-user Upgrade a WebLogAdmin user to a full Administrator"
printfn " "
printfn "For more information on a particular command, run it with no options."
Task.FromResult ()
Task.FromResult()
open System.IO
@ -146,16 +146,16 @@ let main args =
opts.ExpireTimeSpan <- TimeSpan.FromMinutes 60.
opts.SlidingExpiration <- true
opts.AccessDeniedPath <- "/forbidden")
let _ = builder.Services.AddLogging ()
let _ = builder.Services.AddAuthorization ()
let _ = builder.Services.AddAntiforgery ()
let _ = builder.Services.AddLogging()
let _ = builder.Services.AddAuthorization()
let _ = builder.Services.AddAntiforgery()
let sp = builder.Services.BuildServiceProvider ()
let sp = builder.Services.BuildServiceProvider()
let data = DataImplementation.get sp
let _ = builder.Services.AddSingleton<JsonSerializer> data.Serializer
task {
do! data.StartUp ()
do! data.StartUp()
do! WebLogCache.fill data
do! ThemeAssetCache.fill data
} |> Async.AwaitTask |> Async.RunSynchronously
@ -166,30 +166,30 @@ let main args =
// A RethinkDB connection is designed to work as a singleton
let _ = builder.Services.AddSingleton<IData> data
let _ =
builder.Services.AddDistributedRethinkDBCache (fun opts ->
builder.Services.AddDistributedRethinkDBCache(fun opts ->
opts.TableName <- "Session"
opts.Connection <- rethink.Conn)
()
| :? SQLiteData as sql ->
// ADO.NET connections are designed to work as per-request instantiation
let cfg = sp.GetRequiredService<IConfiguration> ()
let cfg = sp.GetRequiredService<IConfiguration>()
let _ =
builder.Services.AddScoped<SqliteConnection> (fun sp ->
let conn = new SqliteConnection (sql.Conn.ConnectionString)
builder.Services.AddScoped<SqliteConnection>(fun sp ->
let conn = new SqliteConnection(sql.Conn.ConnectionString)
SQLiteData.setUpConnection conn |> Async.AwaitTask |> Async.RunSynchronously
conn)
let _ = builder.Services.AddScoped<IData, SQLiteData> () |> ignore
let _ = builder.Services.AddScoped<IData, SQLiteData>()
// Use SQLite for caching as well
let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./session.db"
let _ = builder.Services.AddSqliteCache (fun o -> o.CachePath <- cachePath)
let _ = builder.Services.AddSqliteCache(fun o -> o.CachePath <- cachePath)
()
| :? PostgresData as postgres ->
// ADO.NET Data Sources are designed to work as singletons
let _ = builder.Services.AddSingleton<NpgsqlDataSource> (Configuration.dataSource ())
let _ = builder.Services.AddSingleton<NpgsqlDataSource>(Configuration.dataSource ())
let _ = builder.Services.AddSingleton<IData> postgres
let _ =
builder.Services.AddSingleton<IDistributedCache> (fun _ ->
Postgres.DistributedCache () :> IDistributedCache)
builder.Services.AddSingleton<IDistributedCache>(fun _ ->
Postgres.DistributedCache() :> IDistributedCache)
()
| _ -> ()
@ -197,12 +197,12 @@ let main args =
opts.IdleTimeout <- TimeSpan.FromMinutes 60
opts.Cookie.HttpOnly <- true
opts.Cookie.IsEssential <- true)
let _ = builder.Services.AddGiraffe ()
let _ = builder.Services.AddGiraffe()
// Set up DotLiquid
DotLiquidBespoke.register ()
let app = builder.Build ()
let app = builder.Build()
match args |> Array.tryHead with
| Some it when it = "init" -> Maintenance.createWebLog args app.Services
@ -219,25 +219,25 @@ let main args =
showHelp ()
| None -> task {
// Load all themes in the application directory
for themeFile in Directory.EnumerateFiles (".", "*-theme.zip") do
for themeFile in Directory.EnumerateFiles(".", "*-theme.zip") do
do! Maintenance.loadTheme [| ""; themeFile |] app.Services
let _ = app.UseForwardedHeaders ()
let _ = app.UseForwardedHeaders()
(app.Services.GetRequiredService<IConfiguration>().GetSection "CanonicalDomains").Value
|> (isNull >> not)
|> function true -> app.UseCanonicalDomains () |> ignore | false -> ()
|> function true -> app.UseCanonicalDomains() |> ignore | false -> ()
let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict))
let _ = app.UseMiddleware<WebLogMiddleware> ()
let _ = app.UseMiddleware<RedirectRuleMiddleware> ()
let _ = app.UseAuthentication ()
let _ = app.UseStaticFiles ()
let _ = app.UseRouting ()
let _ = app.UseSession ()
let _ = app.UseCookiePolicy(CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict))
let _ = app.UseMiddleware<WebLogMiddleware>()
let _ = app.UseMiddleware<RedirectRuleMiddleware>()
let _ = app.UseAuthentication()
let _ = app.UseStaticFiles()
let _ = app.UseRouting()
let _ = app.UseSession()
let _ = app.UseGiraffe Handlers.Routes.endpoint
app.Run ()
app.Run()
}
|> Async.AwaitTask |> Async.RunSynchronously