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

WIP on formatting

Browse Source
This commit is contained in:
Daniel J. Summers 2023-12-16 20:38:37 -05:00
parent 8ec84e8680
commit cb02055d87
16 changed files with 331 additions and 371 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -7,6 +7,7 @@ open Newtonsoft.Json
open NodaTime open NodaTime
/// The result of a category deletion attempt /// The result of a category deletion attempt
[<Struct>]
type CategoryDeleteResult = type CategoryDeleteResult =
/// The category was deleted successfully /// The category was deleted successfully
| CategoryDeleted | CategoryDeleted
@ -32,7 +33,7 @@ type ICategoryData =
abstract member Delete : CategoryId -> WebLogId -> Task<CategoryDeleteResult> abstract member Delete : CategoryId -> WebLogId -> Task<CategoryDeleteResult>
/// Find all categories for a web log, sorted alphabetically and grouped by hierarchy /// 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 /// Find a category by its ID
abstract member FindById : CategoryId -> WebLogId -> Task<Category option> 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 open Npgsql.FSharp
/// Data implementation for PostgreSQL /// Data implementation for PostgreSQL
type PostgresData (log : ILogger<PostgresData>, ser : JsonSerializer) = type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
/// Create any needed tables /// Create any needed tables
let ensureTables () = backgroundTask { let ensureTables () = backgroundTask {
// Set up the PostgreSQL document store // Set up the PostgreSQL document store
Configuration.useSerializer Configuration.useSerializer
{ new IDocumentSerializer with { new IDocumentSerializer with
member _.Serialize<'T> (it : 'T) : string = Utils.serialize ser it member _.Serialize<'T>(it: 'T) : string = Utils.serialize ser it
member _.Deserialize<'T> (it : string) : 'T = Utils.deserialize ser it member _.Deserialize<'T>(it: string) : 'T = Utils.deserialize ser it
} }
let! tables = let! tables =

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

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

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

@ -9,7 +9,7 @@ open MyWebLog.ViewModels
let currentDbVersion = "v2.1" let currentDbVersion = "v2.1"
/// Create a category hierarchy from the given list of categories /// 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 for cat in cats |> List.filter (fun c -> c.ParentId = parentId) do
let fullSlug = (match slugBase with Some it -> $"{it}/" | None -> "") + cat.Slug let fullSlug = (match slugBase with Some it -> $"{it}/" | None -> "") + cat.Slug
{ Id = string cat.Id { Id = string cat.Id
@ -18,8 +18,7 @@ let rec orderByHierarchy (cats : Category list) parentId slugBase parentNames =
Description = cat.Description Description = cat.Description
ParentNames = Array.ofList parentNames ParentNames = Array.ofList parentNames
// Post counts are filled on a second pass // Post counts are filled on a second pass
PostCount = 0 PostCount = 0 }
}
yield! orderByHierarchy cats (Some cat.Id) (Some fullSlug) ([ cat.Name ] |> List.append parentNames) 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 open Microsoft.Extensions.DependencyInjection
/// Hold variable for the configured generator string /// Hold variable for the configured generator string
let mutable private generatorString : string option = None let mutable private generatorString: string option = None
type HttpContext with type HttpContext with
/// The anti-CSRF service /// 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 /// The cross-site request forgery token set for this request
member this.CsrfTokenSet = this.AntiForgery.GetAndStoreTokens this member this.CsrfTokenSet = this.AntiForgery.GetAndStoreTokens this
/// The data implementation /// The data implementation
member this.Data = this.RequestServices.GetRequiredService<IData> () member this.Data = this.RequestServices.GetRequiredService<IData>()
/// The generator string /// The generator string
member this.Generator = member this.Generator =
match generatorString with match generatorString with
| Some gen -> gen | Some gen -> gen
| None -> | None ->
let cfg = this.RequestServices.GetRequiredService<IConfiguration> () let cfg = this.RequestServices.GetRequiredService<IConfiguration>()
generatorString <- generatorString <-
match Option.ofObj cfg["Generator"] with match Option.ofObj cfg["Generator"] with
| Some gen -> Some gen | Some gen -> Some gen
@ -84,7 +84,7 @@ module WebLogCache =
let tryGet (path : string) = let tryGet (path : string) =
_cache _cache
|> List.filter (fun wl -> path.StartsWith wl.UrlBase) |> List.filter (fun wl -> path.StartsWith wl.UrlBase)
|> List.sortByDescending (fun wl -> wl.UrlBase.Length) |> List.sortByDescending _.UrlBase.Length
|> List.tryHead |> List.tryHead
/// Cache the web log for a particular host /// Cache the web log for a particular host
@ -106,8 +106,8 @@ module WebLogCache =
_cache _cache
/// Fill the web log cache from the database /// Fill the web log cache from the database
let fill (data : IData) = backgroundTask { let fill (data: IData) = backgroundTask {
let! webLogs = data.WebLog.All () let! webLogs = data.WebLog.All()
webLogs |> List.iter set webLogs |> List.iter set
} }
@ -126,28 +126,28 @@ module PageListCache =
open MyWebLog.ViewModels open MyWebLog.ViewModels
/// Cache of displayed pages /// 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] <- _cache[webLog.Id] <-
pages pages
|> List.map (fun pg -> DisplayPage.FromPage webLog { pg with Text = "" }) |> List.map (fun pg -> DisplayPage.FromPage webLog { pg with Text = "" })
|> Array.ofList |> Array.ofList
/// Are there pages cached for this web log? /// 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 /// 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 /// 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 let! pages = ctx.Data.Page.FindListed ctx.WebLog.Id
fillPages ctx.WebLog pages fillPages ctx.WebLog pages
} }
/// Refresh the pages for the given web log /// 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 let! pages = data.Page.FindListed webLog.Id
fillPages webLog pages fillPages webLog pages
} }
@ -159,22 +159,22 @@ module CategoryCache =
open MyWebLog.ViewModels open MyWebLog.ViewModels
/// The cache itself /// The cache itself
let private _cache = ConcurrentDictionary<WebLogId, DisplayCategory[]> () let private _cache = ConcurrentDictionary<WebLogId, DisplayCategory array> ()
/// Are there categories cached for this web log? /// 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 /// 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 /// 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 let! cats = ctx.Data.Category.FindAllForView ctx.WebLog.Id
_cache[ctx.WebLog.Id] <- cats _cache[ctx.WebLog.Id] <- cats
} }
/// Refresh the category cache for the given web log /// 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 let! cats = data.Category.FindAllForView webLogId
_cache[webLogId] <- cats _cache[webLogId] <- cats
} }
@ -191,7 +191,7 @@ module TemplateCache =
let private _cache = ConcurrentDictionary<string, Template> () let private _cache = ConcurrentDictionary<string, Template> ()
/// Custom include parameter pattern /// 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 /// Get a template for the given theme and template name
let get (themeId: ThemeId) (templateName: string) (data: IData) = backgroundTask { let get (themeId: ThemeId) (templateName: string) (data: IData) = backgroundTask {
@ -220,7 +220,7 @@ module TemplateCache =
let s = if childNotFound.IndexOf ";" >= 0 then "s" else "" let s = if childNotFound.IndexOf ";" >= 0 then "s" else ""
return Error $"Could not find the child template{s} {childNotFound} required by {templateName}" return Error $"Could not find the child template{s} {childNotFound} required by {templateName}"
else else
_cache[templatePath] <- Template.Parse (text, SyntaxCompatibility.DotLiquid22) _cache[templatePath] <- Template.Parse(text, SyntaxCompatibility.DotLiquid22)
return Ok _cache[templatePath] return Ok _cache[templatePath]
| None -> | None ->
return Error $"Theme ID {themeId} does not have a template named {templateName}" return Error $"Theme ID {themeId} does not have a template named {templateName}"
@ -254,14 +254,14 @@ module ThemeAssetCache =
let get themeId = _cache[themeId] let get themeId = _cache[themeId]
/// Refresh the list of assets for the given theme /// 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 let! assets = data.ThemeAsset.FindByTheme themeId
_cache[themeId] <- assets |> List.map (fun a -> match a.Id with ThemeAssetId (_, path) -> path) _cache[themeId] <- assets |> List.map (fun a -> match a.Id with ThemeAssetId (_, path) -> path)
} }
/// Fill the theme asset cache /// Fill the theme asset cache
let fill (data : IData) = backgroundTask { let fill (data: IData) = backgroundTask {
let! assets = data.ThemeAsset.All () let! assets = data.ThemeAsset.All()
for asset in assets do for asset in assets do
let (ThemeAssetId (themeId, path)) = asset.Id let (ThemeAssetId (themeId, path)) = asset.Id
if not (_cache.ContainsKey themeId) then _cache[themeId] <- [] if not (_cache.ContainsKey themeId) then _cache[themeId] <- []

14
src/MyWebLog/DotLiquidBespoke.fs
View File

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

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

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

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

@ -23,7 +23,7 @@ type FeedType =
| Custom of CustomFeed * string | Custom of CustomFeed * string
/// 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 debug = debug "Feed" ctx
let name = $"/{webLog.Rss.FeedName}" let name = $"/{webLog.Rss.FeedName}"
@ -33,14 +33,14 @@ let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option =
match webLog.Rss.IsFeedEnabled && feedPath = name with match webLog.Rss.IsFeedEnabled && feedPath = name with
| true -> | true ->
debug (fun () -> "Found standard feed") debug (fun () -> "Found standard feed")
Some (StandardFeed feedPath, postCount) Some(StandardFeed feedPath, postCount)
| false -> | false ->
// Category and tag feeds are handled by defined routes; check for custom feed // Category and tag feeds are handled by defined routes; check for custom feed
match webLog.Rss.CustomFeeds match webLog.Rss.CustomFeeds
|> List.tryFind (fun it -> feedPath.EndsWith(string it.Path)) with |> List.tryFind (fun it -> feedPath.EndsWith(string it.Path)) with
| Some feed -> | Some feed ->
debug (fun () -> "Found custom 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 -> | None ->
debug (fun () -> "No matching feed found") debug (fun () -> "No matching feed found")
None None
@ -61,7 +61,7 @@ let private getFeedPosts ctx feedType =
| Tag tag -> data.Post.FindPageOfTaggedPosts ctx.WebLog.Id tag 1 | Tag tag -> data.Post.FindPageOfTaggedPosts ctx.WebLog.Id tag 1
/// Strip HTML from a string /// 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 /// XML namespaces for building RSS feeds
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
@ -231,8 +231,8 @@ let private addEpisode (webLog: WebLog) (podcast: PodcastOptions) (episode: Epis
item item
/// Add a namespace to the feed /// Add a namespace to the feed
let private addNamespace (feed : SyndicationFeed) alias nsUrl = let private addNamespace (feed: SyndicationFeed) alias nsUrl =
feed.AttributeExtensions.Add (XmlQualifiedName (alias, "http://www.w3.org/2000/xmlns/"), nsUrl) feed.AttributeExtensions.Add(XmlQualifiedName(alias, "http://www.w3.org/2000/xmlns/"), 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: WebLog) (rssFeed: SyndicationFeed) (feed: CustomFeed) = 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 /// Get the feed's self reference and non-feed link
let private selfAndLink webLog feedType ctx = 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 match feedType with
| StandardFeed path | StandardFeed path
| CategoryFeed (_, path) | CategoryFeed (_, path)
@ -325,8 +325,8 @@ let private selfAndLink webLog feedType ctx =
| Tag tag -> feed.Path, Permalink $"""tag/{tag.Replace(" ", "+")}/""" | Tag tag -> feed.Path, Permalink $"""tag/{tag.Replace(" ", "+")}/"""
/// Set the title and description of the feed based on its source /// Set the title and description of the feed based on its source
let private setTitleAndDescription feedType (webLog : WebLog) (cats : DisplayCategory[]) (feed : SyndicationFeed) = let private setTitleAndDescription feedType (webLog: WebLog) (cats: DisplayCategory[]) (feed: SyndicationFeed) =
let cleanText opt def = TextSyndicationContent (stripHtml (defaultArg opt def)) let cleanText opt def = TextSyndicationContent(stripHtml (defaultArg opt def))
match feedType with match feedType with
| StandardFeed _ -> | StandardFeed _ ->
feed.Title <- cleanText None webLog.Name feed.Title <- cleanText None webLog.Name
@ -412,7 +412,7 @@ let generate (feedType: FeedType) postCount : HttpHandler = fun next ctx -> back
// POST /admin/settings/rss // POST /admin/settings/rss
let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let saveSettings : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let data = ctx.Data let data = ctx.Data
let! model = ctx.BindFormAsync<EditRssModel> () let! model = ctx.BindFormAsync<EditRssModel>()
match! data.WebLog.FindById ctx.WebLog.Id with match! data.WebLog.FindById ctx.WebLog.Id with
| Some webLog -> | Some webLog ->
let webLog = { webLog with Rss = model.UpdateOptions webLog.Rss } 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 let data = ctx.Data
match! data.WebLog.FindById ctx.WebLog.Id with match! data.WebLog.FindById ctx.WebLog.Id with
| Some webLog -> | Some webLog ->
let! model = ctx.BindFormAsync<EditCustomFeedModel> () let! model = ctx.BindFormAsync<EditCustomFeedModel>()
let theFeed = let theFeed =
match model.Id with match model.Id with
| "new" -> Some { CustomFeed.Empty with Id = CustomFeedId.Create() } | "new" -> Some { CustomFeed.Empty with Id = CustomFeedId.Create() }
@ -460,13 +460,12 @@ let saveCustomFeed : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx ->
match theFeed with match theFeed with
| Some feed -> | Some feed ->
let feeds = model.UpdateFeed feed :: (webLog.Rss.CustomFeeds |> List.filter (fun it -> it.Id <> feed.Id)) 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 do! data.WebLog.UpdateRssOptions webLog
WebLogCache.set webLog WebLogCache.set webLog
do! addMessage ctx { do! addMessage ctx
UserMessage.Success with { UserMessage.Success with
Message = $"""Successfully {if model.Id = "new" then "add" else "sav"}ed custom feed""" Message = $"""Successfully {if model.Id = "new" then "add" else "sav"}ed custom feed""" }
}
return! redirectToGet $"admin/settings/rss/{feed.Id}/edit" next ctx return! redirectToGet $"admin/settings/rss/{feed.Id}/edit" next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound 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 -> | Some webLog ->
let customId = CustomFeedId feedId let customId = CustomFeedId feedId
if webLog.Rss.CustomFeeds |> List.exists (fun f -> f.Id = customId) then if webLog.Rss.CustomFeeds |> List.exists (fun f -> f.Id = customId) then
let webLog = { let webLog =
webLog with { webLog with
Rss = { Rss =
webLog.Rss with { webLog.Rss with
CustomFeeds = webLog.Rss.CustomFeeds |> List.filter (fun f -> f.Id <> customId) CustomFeeds = webLog.Rss.CustomFeeds |> List.filter (fun f -> f.Id <> customId) } }
}
}
do! data.WebLog.UpdateRssOptions webLog do! data.WebLog.UpdateRssOptions webLog
WebLogCache.set webLog WebLogCache.set webLog
do! addMessage ctx { UserMessage.Success with Message = "Custom feed deleted successfully" } 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 type ISession with
/// Set an item in the session /// Set an item in the session
member this.Set<'T> (key, item : 'T) = member this.Set<'T>(key, item: 'T) =
this.SetString (key, JsonSerializer.Serialize item) this.SetString(key, JsonSerializer.Serialize item)
/// Get an item from the session /// Get an item from the session
member this.TryGet<'T> key = member this.TryGet<'T> key =
@ -126,28 +126,28 @@ module ViewContext =
let private sessionLoadedKey = "session-loaded" let private sessionLoadedKey = "session-loaded"
/// Load the session if it has not been loaded already; ensures async access but not excessive loading /// 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 if not (ctx.Items.ContainsKey sessionLoadedKey) then
do! ctx.Session.LoadAsync () do! ctx.Session.LoadAsync()
ctx.Items.Add (sessionLoadedKey, "yes") ctx.Items.Add(sessionLoadedKey, "yes")
} }
/// Ensure that the session is committed /// Ensure that the session is committed
let private commitSession (ctx : HttpContext) = task { let private commitSession (ctx: HttpContext) = task {
if ctx.Items.ContainsKey sessionLoadedKey then do! ctx.Session.CommitAsync () if ctx.Items.ContainsKey sessionLoadedKey then do! ctx.Session.CommitAsync()
} }
open MyWebLog.ViewModels open MyWebLog.ViewModels
/// Add a message to the user's session /// Add a message to the user's session
let addMessage (ctx : HttpContext) message = task { let addMessage (ctx: HttpContext) message = task {
do! loadSession ctx do! loadSession ctx
let msg = match ctx.Session.TryGet<UserMessage list> ViewContext.Messages with Some it -> it | None -> [] 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 /// 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 do! loadSession ctx
match ctx.Session.TryGet<UserMessage list> ViewContext.Messages with match ctx.Session.TryGet<UserMessage list> ViewContext.Messages with
| Some msg -> | Some msg ->
@ -160,21 +160,21 @@ open MyWebLog
open DotLiquid open DotLiquid
/// Shorthand for creating a DotLiquid hash from an anonymous object /// Shorthand for creating a DotLiquid hash from an anonymous object
let makeHash (values : obj) = let makeHash (values: obj) =
Hash.FromAnonymousObject values Hash.FromAnonymousObject values
/// Create a hash with the page title filled /// Create a hash with the page title filled
let hashForPage (title : string) = let hashForPage (title: string) =
makeHash {| page_title = title |} makeHash {| page_title = title |}
/// Add a key to the hash, returning the modified hash /// 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) // (note that the hash itself is mutated; this is only used to make it pipeable)
let addToHash key (value : obj) (hash : Hash) = let addToHash key (value: obj) (hash: Hash) =
if hash.ContainsKey key then hash[key] <- value else hash.Add (key, value) if hash.ContainsKey key then hash[key] <- value else hash.Add(key, value)
hash hash
/// Add anti-CSRF tokens to the given hash /// Add anti-CSRF tokens to the given hash
let withAntiCsrf (ctx : HttpContext) = let withAntiCsrf (ctx: HttpContext) =
addToHash ViewContext.AntiCsrfTokens ctx.CsrfTokenSet addToHash ViewContext.AntiCsrfTokens ctx.CsrfTokenSet
open System.Security.Claims open System.Security.Claims
@ -186,13 +186,13 @@ open Giraffe.ViewEngine
let private htmxScript = RenderView.AsString.htmlNode Htmx.Script.minified let private htmxScript = RenderView.AsString.htmlNode Htmx.Script.minified
/// Populate the DotLiquid hash with standard information /// Populate the DotLiquid hash with standard information
let addViewContext ctx (hash : Hash) = task { let addViewContext ctx (hash: Hash) = task {
let! messages = messages ctx let! messages = messages ctx
do! commitSession ctx do! commitSession ctx
return return
if hash.ContainsKey ViewContext.HtmxScript && hash.ContainsKey ViewContext.Messages then if hash.ContainsKey ViewContext.HtmxScript && hash.ContainsKey ViewContext.Messages then
// We have already populated everything; just update messages // 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 hash
else else
ctx.User.Claims ctx.User.Claims
@ -214,11 +214,11 @@ let addViewContext ctx (hash : Hash) = task {
} }
/// Is the request from htmx? /// Is the request from htmx?
let isHtmx (ctx : HttpContext) = let isHtmx (ctx: HttpContext) =
ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh
/// Convert messages to headers (used for htmx responses) /// Convert messages to headers (used for htmx responses)
let messagesToHeaders (messages : UserMessage array) : HttpHandler = let messagesToHeaders (messages: UserMessage array) : HttpHandler =
seq { seq {
yield! yield!
messages messages
@ -253,8 +253,7 @@ module Error =
if isHtmx ctx then if isHtmx ctx then
let messages = [| let messages = [|
{ UserMessage.Error with { 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 (messagesToHeaders messages >=> setStatusCode 401) earlyReturn ctx
else 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 /// 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 let! hash = addViewContext ctx hash
// NOTE: DotLiquid does not support {% render %} or {% include %} in its templates, so we will do a 2-pass render; // 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 /// 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! hash = addViewContext ctx hash
let withContent = task { let withContent = task {
if hash.ContainsKey ViewContext.Content then return Ok hash if hash.ContainsKey ViewContext.Content then return Ok hash
else else
match! TemplateCache.get themeId template ctx.Data with 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 | Error message -> return Error message
} }
match! withContent with 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 match! TemplateCache.get themeId "layout-bare" ctx.Data with
| Ok layoutTemplate -> | Ok layoutTemplate ->
return! return!
(messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage[]) (messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage array)
>=> htmlString (layoutTemplate.Render completeHash)) >=> htmlString (layoutTemplate.Render completeHash))
next ctx next ctx
| Error message -> return! Error.server message 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 do! addMessage ctx
{ UserMessage.Warning with { UserMessage.Warning with
Message = $"The page you tried to access requires {level} privileges" 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 return! Error.notAuthorized next ctx
| None -> | None ->
do! addMessage ctx 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 /// 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 ctx.UserId = authorId || ctx.HasAccessLevel Editor
open System.Threading.Tasks open System.Threading.Tasks
/// Create a Task with a Some result for the given object /// 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 System.Collections.Generic
open MyWebLog.Data open MyWebLog.Data
/// Get the templates available for the current web log's theme (in a key/value pair list) /// 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 match! ctx.Data.Theme.FindByIdWithoutText ctx.WebLog.ThemeId with
| Some theme -> | Some theme ->
return seq { return seq {
KeyValuePair.Create ("", $"- Default (single-{typ}) -") KeyValuePair.Create("", $"- Default (single-{typ}) -")
yield! yield!
theme.Templates theme.Templates
|> Seq.ofList |> Seq.ofList
|> Seq.filter (fun it -> it.Name.EndsWith $"-{typ}" && it.Name <> $"single-{typ}") |> 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 |> 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 /// 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 posts
|> List.map (fun p -> p.AuthorId) |> List.map _.AuthorId
|> List.distinct |> List.distinct
|> data.WebLogUser.FindNames webLog.Id |> data.WebLogUser.FindNames webLog.Id
/// Get all tag mappings for a list of posts as metadata items /// 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 posts
|> List.map (fun p -> p.Tags) |> List.map _.Tags
|> List.concat |> List.concat
|> List.distinct |> List.distinct
|> fun tags -> data.TagMap.FindMappingForTags tags webLog.Id |> fun tags -> data.TagMap.FindMappingForTags tags webLog.Id
@ -421,8 +419,8 @@ open System.Globalization
open NodaTime open NodaTime
/// Parse a date/time to UTC /// Parse a date/time to UTC
let parseToUtc (date : string) = let parseToUtc (date: string) =
Instant.FromDateTimeUtc (DateTime.Parse (date, null, DateTimeStyles.AdjustToUniversal)) Instant.FromDateTimeUtc(DateTime.Parse(date, null, DateTimeStyles.AdjustToUniversal))
open Microsoft.Extensions.DependencyInjection open Microsoft.Extensions.DependencyInjection
open Microsoft.Extensions.Logging open Microsoft.Extensions.Logging
@ -431,25 +429,24 @@ open Microsoft.Extensions.Logging
let mutable private debugEnabled : bool option = None let mutable private debugEnabled : bool option = None
/// Is debug enabled for handlers? /// Is debug enabled for handlers?
let private isDebugEnabled (ctx : HttpContext) = let private isDebugEnabled (ctx: HttpContext) =
match debugEnabled with match debugEnabled with
| Some flag -> flag | Some flag -> flag
| None -> | None ->
let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory> () let fac = ctx.RequestServices.GetRequiredService<ILoggerFactory>()
let log = fac.CreateLogger "MyWebLog.Handlers" let log = fac.CreateLogger "MyWebLog.Handlers"
debugEnabled <- Some (log.IsEnabled LogLevel.Debug) debugEnabled <- Some(log.IsEnabled LogLevel.Debug)
debugEnabled.Value debugEnabled.Value
/// Log a debug message /// Log a debug message
let debug (name : string) ctx msg = 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 /// Log a warning message
let warn (name : string) (ctx : HttpContext) msg = let warn (name: string) (ctx: HttpContext) msg =
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.LogWarning msg 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 // POST /admin/page/permalinks
let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task { let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<ManagePermalinksModel> () let! model = ctx.BindFormAsync<ManagePermalinksModel>()
let pageId = PageId model.Id let pageId = PageId model.Id
match! ctx.Data.Page.FindById pageId ctx.WebLog.Id with match! ctx.Data.Page.FindById pageId ctx.WebLog.Id with
| Some pg when canEdit pg.AuthorId ctx -> | Some pg when canEdit pg.AuthorId ctx ->
@ -117,7 +117,7 @@ let purgeRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx ->
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
/// Find the page and the requested revision /// 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 match! ctx.Data.Page.FindFullById (PageId pgId) ctx.WebLog.Id with
| Some pg -> | Some pg ->
let asOf = parseToUtc revDate let asOf = parseToUtc revDate
@ -150,8 +150,7 @@ let restoreRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun
do! ctx.Data.Page.Update do! ctx.Data.Page.Update
{ pg with { pg with
Revisions = { rev with AsOf = Noda.now () } 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" } do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" }
return! redirectToGet $"admin/page/{pgId}/revisions" next ctx return! redirectToGet $"admin/page/{pgId}/revisions" next ctx
| Some _, Some _ -> return! Error.notAuthorized 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 open MyWebLog
/// Parse a slug and page number from an "everything else" URL /// 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 fullPath = slugAndPage |> Seq.head
let slugPath = slugAndPage |> Seq.skip 1 |> Seq.head let slugPath = slugAndPage |> Seq.skip 1 |> Seq.head
let slugs, isFeed = 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]) | idx when idx + 2 = slugs.Length -> Some (int slugs[pageIdx + 1])
| _ -> None | _ -> None
let slugParts = if pageIdx > 0 then Array.truncate pageIdx slugs else slugs 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 /// The type of post list being prepared
[<Struct>]
type ListType = type ListType =
| AdminList | AdminList
| CategoryList | CategoryList
@ -55,7 +56,7 @@ let preparePostList webLog posts listType (url: string) pageNbr perPage (data: I
let post = List.head posts let post = List.head posts
let target = defaultArg post.PublishedOn post.UpdatedOn let target = defaultArg post.PublishedOn post.UpdatedOn
data.Post.FindSurroundingPosts webLog.Id target data.Post.FindSurroundingPosts webLog.Id target
| _ -> Task.FromResult (None, None) | _ -> Task.FromResult(None, None)
let newerLink = let newerLink =
match listType, pageNbr with match listType, pageNbr with
| SinglePost, _ -> newerPost |> Option.map (fun it -> string it.Permalink) | SinglePost, _ -> newerPost |> Option.map (fun it -> string it.Permalink)
@ -114,7 +115,7 @@ let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
} }
// GET /page/{pageNbr}/ // 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 redirectTo true (ctx.WebLog.RelativeUrl(Permalink $"page/{pageNbr}")) next ctx
// GET /category/{slug}/ // GET /category/{slug}/
@ -163,7 +164,7 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
| None -> return urlTag | None -> return urlTag
} }
if isFeed then 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 (defaultArg webLog.Rss.ItemsInFeed webLog.PostsPerPage) next ctx
else else
match! data.Post.FindPageOfTaggedPosts webLog.Id tag pageNbr webLog.PostsPerPage with 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 |> themedView "index" next ctx
// Other systems use hyphens for spaces; redirect if this is an old tag link // 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 match! data.Post.FindPageOfTaggedPosts webLog.Id spacedTag pageNbr 1 with
| posts when List.length posts > 0 -> | posts when List.length posts > 0 ->
let endUrl = if pageNbr = 1 then "" else $"page/{pageNbr}" 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 // POST /admin/post/permalinks
let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task { let savePermalinks : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<ManagePermalinksModel> () let! model = ctx.BindFormAsync<ManagePermalinksModel>()
let postId = PostId model.Id let postId = PostId model.Id
match! ctx.Data.Post.FindById postId ctx.WebLog.Id with match! ctx.Data.Post.FindById postId ctx.WebLog.Id with
| Some post when canEdit post.AuthorId ctx -> | Some post when canEdit post.AuthorId ctx ->
@ -317,7 +318,7 @@ let purgeRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
/// Find the post and the requested revision /// 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 match! ctx.Data.Post.FindFullById (PostId postId) ctx.WebLog.Id with
| Some post -> | Some post ->
let asOf = parseToUtc revDate let asOf = parseToUtc revDate
@ -350,8 +351,7 @@ let restoreRevision (postId, revDate) : HttpHandler = requireAccess Author >=> f
do! ctx.Data.Post.Update do! ctx.Data.Post.Update
{ post with { post with
Revisions = { rev with AsOf = Noda.now () } 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" } do! addMessage ctx { UserMessage.Success with Message = "Revision restored successfully" }
return! redirectToGet $"admin/post/{postId}/revisions" next ctx return! redirectToGet $"admin/post/{postId}/revisions" next ctx
| Some _, Some _ -> return! Error.notAuthorized 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 { Post.Empty with
Id = PostId.Create() Id = PostId.Create()
WebLogId = ctx.WebLog.Id WebLogId = ctx.WebLog.Id
AuthorId = ctx.UserId AuthorId = ctx.UserId }
} |> someTask |> someTask
else data.Post.FindFullById (PostId model.PostId) ctx.WebLog.Id else data.Post.FindFullById (PostId model.PostId) ctx.WebLog.Id
match! tryPost with match! tryPost with
| Some post when canEdit post.AuthorId ctx -> | Some post when canEdit post.AuthorId ctx ->
@ -396,8 +396,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
{ post with { post with
PublishedOn = Some dt PublishedOn = Some dt
UpdatedOn = 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 with PublishedOn = Some dt }
else post else post
do! (if model.PostId = "new" then data.Post.Add else data.Post.Update) updatedPost 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 open MyWebLog.ViewModels
/// Sequence where the first returned value is the proper handler for the link /// 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 webLog = ctx.WebLog
let data = ctx.Data let data = ctx.Data
let debug = debug "Routes.CatchAll" ctx let debug = debug "Routes.CatchAll" ctx
@ -80,7 +80,7 @@ module CatchAll =
} }
// GET {all-of-the-above} // 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 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 open Microsoft.AspNetCore.StaticFiles
/// A MIME type mapper instance to use when serving files from the database /// 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 /// A cache control header that instructs the browser to cache the result for no more than 30 days
let cacheForThirtyDays = let cacheForThirtyDays =
@ -24,7 +24,7 @@ module private Helpers =
let slash = Path.DirectorySeparatorChar let slash = Path.DirectorySeparatorChar
/// The base directory where uploads are stored, relative to the executable /// 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 ~~ // ~~ SERVING UPLOADS ~~
@ -35,10 +35,10 @@ open Microsoft.AspNetCore.Http
open NodaTime open NodaTime
/// Determine if the file has been modified since the date/time specified by the If-Modified-Since header /// 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 match ctx.Request.Headers.IfModifiedSince with
| it when it.Count < 1 -> None | 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) | _ -> Some (setStatusCode 304)
@ -53,29 +53,29 @@ let sendFile updatedOn path (data : byte[]) : HttpHandler = fun next ctx ->
let headers = ResponseHeaders ctx.Response.Headers let headers = ResponseHeaders ctx.Response.Headers
headers.ContentType <- (deriveMimeType >> MediaTypeHeaderValue) path headers.ContentType <- (deriveMimeType >> MediaTypeHeaderValue) path
headers.CacheControl <- cacheForThirtyDays headers.CacheControl <- cacheForThirtyDays
let stream = new MemoryStream (data) let stream = new MemoryStream(data)
streamData true stream None (Some (DateTimeOffset updatedOn)) next ctx streamData true stream None (Some (DateTimeOffset updatedOn)) next ctx
open MyWebLog open MyWebLog
// GET /upload/{web-log-slug}/{**path} // 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 webLog = ctx.WebLog
let parts = (urlParts |> Seq.skip 1 |> Seq.head).Split '/' let parts = (urlParts |> Seq.skip 1 |> Seq.head).Split '/'
let slug = Array.head parts let slug = Array.head parts
if slug = webLog.Slug then if slug = webLog.Slug then
// Static file middleware will not work in subdirectories; check for an actual file first // 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 if File.Exists fileName then
return! streamFile true fileName None None next ctx return! streamFile true fileName None None next ctx
else 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 match! ctx.Data.Upload.FindByPath path webLog.Id with
| Some upload -> | Some upload ->
match checkModified upload.UpdatedOn ctx with match checkModified upload.UpdatedOn ctx with
| Some threeOhFour -> return! threeOhFour next ctx | 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 | None -> return! Error.notFound next ctx
else else
return! Error.notFound next ctx return! Error.notFound next ctx
@ -87,28 +87,27 @@ open System.Text.RegularExpressions
open MyWebLog.ViewModels open MyWebLog.ViewModels
/// Turn a string into a lowercase URL-safe slug /// 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 // GET /admin/uploads
let list : HttpHandler = requireAccess Author >=> fun next ctx -> task { let list : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let webLog = ctx.WebLog let webLog = ctx.WebLog
let! dbUploads = ctx.Data.Upload.FindByWebLog webLog.Id let! dbUploads = ctx.Data.Upload.FindByWebLog webLog.Id
let diskUploads = let diskUploads =
let path = Path.Combine (uploadDir, webLog.Slug) let path = Path.Combine(uploadDir, webLog.Slug)
try try
Directory.EnumerateFiles (path, "*", SearchOption.AllDirectories) Directory.EnumerateFiles(path, "*", SearchOption.AllDirectories)
|> Seq.map (fun file -> |> Seq.map (fun file ->
let name = Path.GetFileName file let name = Path.GetFileName file
let create = 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 | dt when dt > DateTime.UnixEpoch -> Some dt
| _ -> None | _ -> None
{ DisplayUpload.Id = "" { DisplayUpload.Id = ""
Name = name Name = name
Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace (slash, '/') Path = file.Replace($"{path}{slash}", "").Replace(name, "").Replace(slash, '/')
UpdatedOn = create UpdatedOn = create
Source = string Disk Source = string Disk })
})
|> List.ofSeq |> List.ofSeq
with with
| :? DirectoryNotFoundException -> [] // This is fine | :? DirectoryNotFoundException -> [] // This is fine
@ -160,8 +159,7 @@ let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {
WebLogId = ctx.WebLog.Id WebLogId = ctx.WebLog.Id
Path = Permalink $"{year}/{month}/{fileName}" Path = Permalink $"{year}/{month}/{fileName}"
UpdatedOn = now UpdatedOn = now
Data = stream.ToArray() Data = stream.ToArray() }
}
do! ctx.Data.Upload.Add file do! ctx.Data.Upload.Add file
| Disk -> | Disk ->
let fullPath = Path.Combine(uploadDir, ctx.WebLog.Slug, year, month) 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 /// 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 path = Path.GetDirectoryName filePath
let mutable finished = false let mutable finished = false
while (not finished) && path > "" do 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 if Directory.EnumerateFileSystemEntries fullPath |> Seq.isEmpty then
Directory.Delete fullPath Directory.Delete fullPath
path <- String.Join(slash, path.Split slash |> Array.rev |> Array.skip 1 |> Array.rev) 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} // POST /admin/upload/delete/{**path}
let deleteFromDisk urlParts : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let deleteFromDisk urlParts : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let filePath = urlParts |> Seq.skip 1 |> Seq.head 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 if File.Exists path then
File.Delete path File.Delete path
removeEmptyDirectories ctx.WebLog filePath 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 /// Create a password hash a password for a given user
let createPasswordHash user password = let createPasswordHash user password =
PasswordHasher<WebLogUser>().HashPassword (user, password) PasswordHasher<WebLogUser>().HashPassword(user, password)
/// Verify whether a password is valid /// Verify whether a password is valid
let verifyPassword user password (ctx : HttpContext) = backgroundTask { let verifyPassword user password (ctx: HttpContext) = backgroundTask {
match user with match user with
| Some usr -> | Some usr ->
let hasher = PasswordHasher<WebLogUser> () let hasher = PasswordHasher<WebLogUser>()
match hasher.VerifyHashedPassword (usr, usr.PasswordHash, password) with match hasher.VerifyHashedPassword(usr, usr.PasswordHash, password) with
| PasswordVerificationResult.Success -> return Ok () | PasswordVerificationResult.Success -> return Ok ()
| PasswordVerificationResult.SuccessRehashNeeded -> | 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 Ok ()
| _ -> return Error "Log on attempt unsuccessful" | _ -> return Error "Log on attempt unsuccessful"
| None -> 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 do! addMessage ctx
{ UserMessage.Success with { UserMessage.Success with
Message = "Log on successful" Message = "Log on successful"
Detail = Some $"Welcome to {ctx.WebLog.Name}!" Detail = Some $"Welcome to {ctx.WebLog.Name}!" }
}
return! return!
match model.ReturnTo with 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 | None -> redirectToGet "admin/dashboard" next ctx
| Error msg -> | Error msg ->
do! addMessage ctx { UserMessage.Error with Message = 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 /// 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") hashForPage (if model.IsNew then "Add a New User" else "Edit User")
|> withAntiCsrf ctx |> withAntiCsrf ctx
|> addToHash ViewContext.Model model |> addToHash ViewContext.Model model
@ -141,15 +140,13 @@ let delete userId : HttpHandler = fun next ctx -> task {
| Ok _ -> | Ok _ ->
do! addMessage ctx do! addMessage ctx
{ UserMessage.Success with { UserMessage.Success with
Message = $"User {user.DisplayName} deleted successfully" Message = $"User {user.DisplayName} deleted successfully" }
}
return! all next ctx return! all next ctx
| Error msg -> | Error msg ->
do! addMessage ctx do! addMessage ctx
{ UserMessage.Error with { UserMessage.Error with
Message = $"User {user.DisplayName} was not deleted" Message = $"User {user.DisplayName} was not deleted"
Detail = Some msg Detail = Some msg }
}
return! all next ctx return! all next ctx
| None -> return! Error.notFound 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 // POST /admin/my-info
let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task { let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditMyInfoModel> () let! model = ctx.BindFormAsync<EditMyInfoModel>()
let data = ctx.Data let data = ctx.Data
match! data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with match! data.WebLogUser.FindById ctx.UserId ctx.WebLog.Id with
| Some user when model.NewPassword = model.NewPasswordConfirm -> | Some user when model.NewPassword = model.NewPasswordConfirm ->
@ -184,8 +181,7 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
FirstName = model.FirstName FirstName = model.FirstName
LastName = model.LastName LastName = model.LastName
PreferredName = model.PreferredName PreferredName = model.PreferredName
PasswordHash = pw PasswordHash = pw }
}
do! data.WebLogUser.Update user do! data.WebLogUser.Update user
let pwMsg = if model.NewPassword = "" then "" else " and updated your password" let pwMsg = if model.NewPassword = "" then "" else " and updated your password"
do! addMessage ctx { UserMessage.Success with Message = $"Saved your information{pwMsg} successfully" } 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 // POST /admin/settings/user/save
let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task { let save : HttpHandler = requireAccess WebLogAdmin >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditUserModel> () let! model = ctx.BindFormAsync<EditUserModel>()
let data = ctx.Data let data = ctx.Data
let tryUser = let tryUser =
if model.IsNew then if model.IsNew then
{ WebLogUser.Empty with { WebLogUser.Empty with
Id = WebLogUserId.Create() Id = WebLogUserId.Create()
WebLogId = ctx.WebLog.Id WebLogId = ctx.WebLog.Id
CreatedOn = Noda.now () CreatedOn = Noda.now () }
} |> someTask |> someTask
else data.WebLogUser.FindById (WebLogUserId model.Id) ctx.WebLog.Id else data.WebLogUser.FindById (WebLogUserId model.Id) ctx.WebLog.Id
match! tryUser with match! tryUser with
| Some user when model.Password = model.PasswordConfirm -> | 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! (if model.IsNew then data.WebLogUser.Add else data.WebLogUser.Update) toUpdate
do! addMessage ctx do! addMessage ctx
{ UserMessage.Success with { 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 return! all next ctx
| Some _ -> | Some _ ->
do! addMessage ctx { UserMessage.Error with Message = "The passwords did not match; nothing saved" } do! addMessage ctx { UserMessage.Error with Message = "The passwords did not match; nothing saved" }

150
src/MyWebLog/Maintenance.fs
View File

@ -7,9 +7,9 @@ open MyWebLog.Data
open NodaTime open NodaTime
/// Create the web log information /// 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 timeZone =
let local = TimeZoneInfo.Local.Id let local = TimeZoneInfo.Local.Id
@ -38,8 +38,7 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
Slug = slug Slug = slug
UrlBase = args[1] UrlBase = args[1]
DefaultPage = string homePageId DefaultPage = string homePageId
TimeZone = timeZone TimeZone = timeZone }
}
// Create the admin user // Create the admin user
let now = Noda.now () let now = Noda.now ()
@ -52,8 +51,7 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
LastName = "User" LastName = "User"
PreferredName = "Admin" PreferredName = "Admin"
AccessLevel = accessLevel AccessLevel = accessLevel
CreatedOn = now CreatedOn = now }
}
do! data.WebLogUser.Add { user with PasswordHash = Handlers.User.createPasswordHash user args[4] } do! data.WebLogUser.Add { user with PasswordHash = Handlers.User.createPasswordHash user args[4] }
// Create the default home page // Create the default home page
@ -69,10 +67,8 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
Text = "<p>This is your default home page.</p>" Text = "<p>This is your default home page.</p>"
Revisions = [ Revisions = [
{ AsOf = now { 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]}" printfn $"Successfully initialized database for {args[2]} with URL base {args[1]}"
match accessLevel with match accessLevel with
@ -91,8 +87,8 @@ let createWebLog args sp = task {
} }
/// Import prior permalinks from a text files with lines in the format "[old] [new]" /// Import prior permalinks from a text files with lines in the format "[old] [new]"
let private importPriorPermalinks urlBase file (sp : IServiceProvider) = task { let private importPriorPermalinks urlBase file (sp: IServiceProvider) = task {
let data = sp.GetRequiredService<IData> () let data = sp.GetRequiredService<IData>()
match! data.WebLog.FindByHost urlBase with match! data.WebLog.FindByHost urlBase with
| Some webLog -> | Some webLog ->
@ -129,7 +125,7 @@ let importLinks args sp = task {
open Microsoft.Extensions.Logging open Microsoft.Extensions.Logging
/// Load a theme from the given ZIP file /// 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 if args.Length = 2 then
let fileName = let fileName =
match args[1].LastIndexOf Path.DirectorySeparatorChar with match args[1].LastIndexOf Path.DirectorySeparatorChar with
@ -137,12 +133,12 @@ let loadTheme (args : string[]) (sp : IServiceProvider) = task {
| it -> args[1][(it + 1)..] | it -> args[1][(it + 1)..]
match Handlers.Admin.Theme.deriveIdFromFileName fileName with match Handlers.Admin.Theme.deriveIdFromFileName fileName with
| Ok themeId -> | Ok themeId ->
let data = sp.GetRequiredService<IData> () let data = sp.GetRequiredService<IData>()
use stream = File.Open (args[1], FileMode.Open) use stream = File.Open(args[1], FileMode.Open)
use copy = new MemoryStream () use copy = new MemoryStream()
do! stream.CopyToAsync copy do! stream.CopyToAsync copy
let! theme = Handlers.Admin.Theme.loadFromZip themeId copy data 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" let log = fac.CreateLogger "MyWebLog.Themes"
log.LogInformation $"{theme.Name} v{theme.Version} ({theme.Id}) loaded" log.LogInformation $"{theme.Name} v{theme.Version} ({theme.Id}) loaded"
| Error message -> eprintfn $"{message}" | Error message -> eprintfn $"{message}"
@ -159,103 +155,96 @@ module Backup =
/// A theme asset, with the data base-64 encoded /// A theme asset, with the data base-64 encoded
type EncodedAsset = type EncodedAsset =
{ /// The ID of the theme asset { /// The ID of the theme asset
Id : ThemeAssetId Id: ThemeAssetId
/// The updated date for this asset /// The updated date for this asset
UpdatedOn : Instant UpdatedOn: Instant
/// The data for this asset, base-64 encoded /// The data for this asset, base-64 encoded
Data : string Data: string }
}
/// Create an encoded theme asset from the original theme asset /// Create an encoded theme asset from the original theme asset
static member fromAsset (asset : ThemeAsset) = static member fromAsset (asset: ThemeAsset) =
{ Id = asset.Id { Id = asset.Id
UpdatedOn = asset.UpdatedOn UpdatedOn = asset.UpdatedOn
Data = Convert.ToBase64String asset.Data Data = Convert.ToBase64String asset.Data }
}
/// Create a theme asset from an encoded theme asset /// Create a theme asset from an encoded theme asset
static member toAsset (encoded : EncodedAsset) : ThemeAsset = static member toAsset (encoded: EncodedAsset) : ThemeAsset =
{ Id = encoded.Id { Id = encoded.Id
UpdatedOn = encoded.UpdatedOn UpdatedOn = encoded.UpdatedOn
Data = Convert.FromBase64String encoded.Data Data = Convert.FromBase64String encoded.Data }
}
/// An uploaded file, with the data base-64 encoded /// An uploaded file, with the data base-64 encoded
type EncodedUpload = type EncodedUpload =
{ /// The ID of the upload { /// The ID of the upload
Id : UploadId Id: UploadId
/// The ID of the web log to which the upload belongs /// The ID of the web log to which the upload belongs
WebLogId : WebLogId WebLogId: WebLogId
/// The path at which this upload is served /// The path at which this upload is served
Path : Permalink Path: Permalink
/// The date/time this upload was last updated (file time) /// The date/time this upload was last updated (file time)
UpdatedOn : Instant UpdatedOn: Instant
/// The data for the upload, base-64 encoded /// The data for the upload, base-64 encoded
Data : string Data: string }
}
/// Create an encoded uploaded file from the original uploaded file /// 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 { Id = upload.Id
WebLogId = upload.WebLogId WebLogId = upload.WebLogId
Path = upload.Path Path = upload.Path
UpdatedOn = upload.UpdatedOn UpdatedOn = upload.UpdatedOn
Data = Convert.ToBase64String upload.Data Data = Convert.ToBase64String upload.Data }
}
/// Create an uploaded file from an encoded uploaded file /// Create an uploaded file from an encoded uploaded file
static member toUpload (encoded : EncodedUpload) : Upload = static member toUpload (encoded: EncodedUpload) : Upload =
{ Id = encoded.Id { Id = encoded.Id
WebLogId = encoded.WebLogId WebLogId = encoded.WebLogId
Path = encoded.Path Path = encoded.Path
UpdatedOn = encoded.UpdatedOn UpdatedOn = encoded.UpdatedOn
Data = Convert.FromBase64String encoded.Data Data = Convert.FromBase64String encoded.Data }
}
/// A unified archive for a web log /// A unified archive for a web log
type Archive = type Archive =
{ /// The web log to which this archive belongs { /// The web log to which this archive belongs
WebLog : WebLog WebLog: WebLog
/// The users for this web log /// 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 /// 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 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 /// The categories for this web log
Categories : Category list Categories: Category list
/// The tag mappings for this web log /// 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) /// 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) /// 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 /// The uploaded files for this web log
Uploads : EncodedUpload list Uploads: EncodedUpload list }
}
/// Create a JSON serializer /// Create a JSON serializer
let private getSerializer prettyOutput = let private getSerializer prettyOutput =
let serializer = Json.configure (JsonSerializer.CreateDefault ()) let serializer = Json.configure (JsonSerializer.CreateDefault())
if prettyOutput then serializer.Formatting <- Formatting.Indented if prettyOutput then serializer.Formatting <- Formatting.Indented
serializer serializer
/// Display statistics for a backup archive /// 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 userCount = List.length archive.Users
let assetCount = List.length archive.Assets let assetCount = List.length archive.Assets
@ -280,7 +269,7 @@ module Backup =
printfn $""" - {uploadCount} uploaded file{plural uploadCount "" "s"}""" printfn $""" - {uploadCount} uploaded file{plural uploadCount "" "s"}"""
/// Create a backup archive /// 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 // Create the data structure
printfn "- Exporting theme..." printfn "- Exporting theme..."
let! theme = data.Theme.FindById webLog.ThemeId let! theme = data.Theme.FindById webLog.ThemeId
@ -312,25 +301,24 @@ module Backup =
TagMappings = tagMaps TagMappings = tagMaps
Pages = pages |> List.map (fun p -> { p with Revisions = List.truncate 1 p.Revisions }) 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 }) 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 // Write the structure to the backup file
if File.Exists fileName then File.Delete fileName if File.Exists fileName then File.Delete fileName
let serializer = getSerializer prettyOutput let serializer = getSerializer prettyOutput
use writer = new StreamWriter (fileName) use writer = new StreamWriter(fileName)
serializer.Serialize (writer, archive) serializer.Serialize(writer, archive)
writer.Close () writer.Close()
displayStats $"{fileName} (for <>NAME<>) contains:" webLog archive 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 { let! restore = task {
match! data.WebLog.FindById archive.WebLog.Id with match! data.WebLog.FindById archive.WebLog.Id with
| Some webLog when defaultArg newUrlBase webLog.UrlBase = webLog.UrlBase -> | Some webLog when defaultArg newUrlBase webLog.UrlBase = webLog.UrlBase ->
do! data.WebLog.Delete webLog.Id 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 _ -> | Some _ ->
// Err'body gets new IDs... // Err'body gets new IDs...
let newWebLogId = WebLogId.Create() let newWebLogId = WebLogId.Create()
@ -354,24 +342,18 @@ module Backup =
{ page with { page with
Id = newPageIds[page.Id] Id = newPageIds[page.Id]
WebLogId = newWebLogId WebLogId = newWebLogId
AuthorId = newUserIds[page.AuthorId] AuthorId = newUserIds[page.AuthorId] })
})
Posts = archive.Posts Posts = archive.Posts
|> List.map (fun post -> |> List.map (fun post ->
{ post with { post with
Id = newPostIds[post.Id] Id = newPostIds[post.Id]
WebLogId = newWebLogId WebLogId = newWebLogId
AuthorId = newUserIds[post.AuthorId] 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 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 -> | None ->
return return { archive with Archive.WebLog.UrlBase = defaultArg newUrlBase archive.WebLog.UrlBase }
{ archive with
WebLog = { archive.WebLog with UrlBase = defaultArg newUrlBase archive.WebLog.UrlBase }
}
} }
// Restore theme and assets (one at a time, as assets can be large) // 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 /// 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 let serializer = getSerializer false
use stream = new FileStream (fileName, FileMode.Open) use stream = new FileStream(fileName, FileMode.Open)
use reader = new StreamReader (stream) use reader = new StreamReader(stream)
use jsonReader = new JsonTextReader (reader) use jsonReader = new JsonTextReader(reader)
let archive = serializer.Deserialize<Archive> jsonReader let archive = serializer.Deserialize<Archive> jsonReader
let mutable doOverwrite = not promptForOverwrite let mutable doOverwrite = not promptForOverwrite
@ -428,7 +410,7 @@ module Backup =
printfn " theme in either case." printfn " theme in either case."
printfn "" printfn ""
printf "Continue? [Y/n] " printf "Continue? [Y/n] "
doOverwrite <- not ((Console.ReadKey ()).Key = ConsoleKey.N) doOverwrite <- not (Console.ReadKey().Key = ConsoleKey.N)
if doOverwrite then if doOverwrite then
do! doRestore archive newUrlBase data do! doRestore archive newUrlBase data
@ -437,9 +419,9 @@ module Backup =
} }
/// Generate a backup archive /// 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 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 match! data.WebLog.FindByHost args[1] with
| Some webLog -> | Some webLog ->
let fileName = let fileName =
@ -459,9 +441,9 @@ module Backup =
} }
/// Restore a backup archive /// 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 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 let newUrlBase = if args.Length = 3 then Some args[2] else None
do! restoreBackup args[1] newUrlBase (args[0] <> "do-restore") data do! restoreBackup args[1] newUrlBase (args[0] <> "do-restore") data
else else
@ -472,7 +454,7 @@ module Backup =
/// Upgrade a WebLogAdmin user to an Administrator user /// 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 match! data.WebLog.FindByHost urlBase with
| Some webLog -> | Some webLog ->
match! data.WebLogUser.FindByEmail email webLog.Id with 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 /// 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 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]" | _ -> eprintfn "Usage: myWebLog upgrade-user [web-log-url-base] [email-address]"
} }
/// Set a user's password /// 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 match! data.WebLog.FindByHost urlBase with
| Some webLog -> | Some webLog ->
match! data.WebLogUser.FindByEmail email webLog.Id with 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 /// 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 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]" | _ -> 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 open MyWebLog
/// Middleware to derive the current web log /// 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? /// Is the debug level enabled on the logger?
let isDebug = log.IsEnabled LogLevel.Debug let isDebug = log.IsEnabled LogLevel.Debug
member _.InvokeAsync (ctx : HttpContext) = task { member _.InvokeAsync(ctx: HttpContext) = task {
/// Create the full path of the request /// Create the full path of the request
let path = $"{ctx.Request.Scheme}://{ctx.Request.Host.Value}{ctx.Request.Path.Value}" let path = $"{ctx.Request.Scheme}://{ctx.Request.Host.Value}{ctx.Request.Path.Value}"
match WebLogCache.tryGet path with 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 /// 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 /// Shorthand for case-insensitive string equality
let ciEquals str1 str2 = 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 { member _.InvokeAsync(ctx: HttpContext) = task {
let path = ctx.Request.Path.Value.ToLower () let path = ctx.Request.Path.Value.ToLower()
let matched = let matched =
WebLogCache.redirectRules ctx.WebLog.Id WebLogCache.redirectRules ctx.WebLog.Id
|> List.tryPick (fun rule -> |> List.tryPick (fun rule ->
@ -42,9 +42,9 @@ type RedirectRuleMiddleware (next : RequestDelegate, log : ILogger<RedirectRuleM
| WebLogCache.CachedRedirectRule.Text (urlFrom, urlTo) -> | WebLogCache.CachedRedirectRule.Text (urlFrom, urlTo) ->
if ciEquals path urlFrom then Some urlTo else None if ciEquals path urlFrom then Some urlTo else None
| WebLogCache.CachedRedirectRule.RegEx (regExFrom, patternTo) -> | 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 match matched with
| Some url -> ctx.Response.Redirect (url, permanent = true) | Some url -> ctx.Response.Redirect(url, permanent = true)
| None -> return! next.Invoke ctx | None -> return! next.Invoke ctx
} }
@ -64,39 +64,39 @@ module DataImplementation =
open RethinkDb.Driver.Net open RethinkDb.Driver.Net
/// Create an NpgsqlDataSource from the connection string, configuring appropriately /// Create an NpgsqlDataSource from the connection string, configuring appropriately
let createNpgsqlDataSource (cfg : IConfiguration) = let createNpgsqlDataSource (cfg: IConfiguration) =
let builder = NpgsqlDataSourceBuilder (cfg.GetConnectionString "PostgreSQL") let builder = NpgsqlDataSourceBuilder(cfg.GetConnectionString "PostgreSQL")
let _ = builder.UseNodaTime () let _ = builder.UseNodaTime()
// let _ = builder.UseLoggerFactory(LoggerFactory.Create(fun it -> it.AddConsole () |> ignore)) // let _ = builder.UseLoggerFactory(LoggerFactory.Create(fun it -> it.AddConsole () |> ignore))
(builder.Build >> Configuration.useDataSource) () (builder.Build >> Configuration.useDataSource) ()
/// Get the configured data implementation /// Get the configured data implementation
let get (sp : IServiceProvider) : IData = let get (sp: IServiceProvider) : IData =
let config = sp.GetRequiredService<IConfiguration> () let config = sp.GetRequiredService<IConfiguration>()
let await it = (Async.AwaitTask >> Async.RunSynchronously) it let await it = (Async.AwaitTask >> Async.RunSynchronously) it
let connStr name = config.GetConnectionString name let connStr name = config.GetConnectionString name
let hasConnStr name = (connStr >> isNull >> not) name let hasConnStr name = (connStr >> isNull >> not) name
let createSQLite connStr : IData = let createSQLite connStr : IData =
let log = sp.GetRequiredService<ILogger<SQLiteData>> () let log = sp.GetRequiredService<ILogger<SQLiteData>>()
let conn = new SqliteConnection (connStr) let conn = new SqliteConnection(connStr)
log.LogInformation $"Using SQLite database {conn.DataSource}" log.LogInformation $"Using SQLite database {conn.DataSource}"
await (SQLiteData.setUpConnection conn) await (SQLiteData.setUpConnection conn)
SQLiteData (conn, log, Json.configure (JsonSerializer.CreateDefault ())) SQLiteData(conn, log, Json.configure (JsonSerializer.CreateDefault()))
if hasConnStr "SQLite" then if hasConnStr "SQLite" then
createSQLite (connStr "SQLite") createSQLite (connStr "SQLite")
elif hasConnStr "RethinkDB" then elif hasConnStr "RethinkDB" then
let log = sp.GetRequiredService<ILogger<RethinkDbData>> () let log = sp.GetRequiredService<ILogger<RethinkDbData>>()
let _ = Json.configure Converter.Serializer let _ = Json.configure Converter.Serializer
let rethinkCfg = DataConfig.FromUri (connStr "RethinkDB") let rethinkCfg = DataConfig.FromUri (connStr "RethinkDB")
let conn = await (rethinkCfg.CreateConnectionAsync log) let conn = await (rethinkCfg.CreateConnectionAsync log)
RethinkDbData (conn, rethinkCfg, log) RethinkDbData(conn, rethinkCfg, log)
elif hasConnStr "PostgreSQL" then elif hasConnStr "PostgreSQL" then
createNpgsqlDataSource config createNpgsqlDataSource config
use conn = Configuration.dataSource().CreateConnection () use conn = Configuration.dataSource().CreateConnection()
let log = sp.GetRequiredService<ILogger<PostgresData>> () let log = sp.GetRequiredService<ILogger<PostgresData>>()
log.LogInformation $"Using PostgreSQL database {conn.Database}" log.LogInformation $"Using PostgreSQL database {conn.Database}"
PostgresData (log, Json.configure (JsonSerializer.CreateDefault ())) PostgresData(log, Json.configure (JsonSerializer.CreateDefault()))
else else
createSQLite "Data Source=./myweblog.db;Cache=Shared" 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 "upgrade-user Upgrade a WebLogAdmin user to a full Administrator"
printfn " " printfn " "
printfn "For more information on a particular command, run it with no options." printfn "For more information on a particular command, run it with no options."
Task.FromResult () Task.FromResult()
open System.IO open System.IO
@ -146,16 +146,16 @@ let main args =
opts.ExpireTimeSpan <- TimeSpan.FromMinutes 60. opts.ExpireTimeSpan <- TimeSpan.FromMinutes 60.
opts.SlidingExpiration <- true opts.SlidingExpiration <- true
opts.AccessDeniedPath <- "/forbidden") opts.AccessDeniedPath <- "/forbidden")
let _ = builder.Services.AddLogging () let _ = builder.Services.AddLogging()
let _ = builder.Services.AddAuthorization () let _ = builder.Services.AddAuthorization()
let _ = builder.Services.AddAntiforgery () let _ = builder.Services.AddAntiforgery()
let sp = builder.Services.BuildServiceProvider () let sp = builder.Services.BuildServiceProvider()
let data = DataImplementation.get sp let data = DataImplementation.get sp
let _ = builder.Services.AddSingleton<JsonSerializer> data.Serializer let _ = builder.Services.AddSingleton<JsonSerializer> data.Serializer
task { task {
do! data.StartUp () do! data.StartUp()
do! WebLogCache.fill data do! WebLogCache.fill data
do! ThemeAssetCache.fill data do! ThemeAssetCache.fill data
} |> Async.AwaitTask |> Async.RunSynchronously } |> Async.AwaitTask |> Async.RunSynchronously
@ -166,30 +166,30 @@ let main args =
// A RethinkDB connection is designed to work as a singleton // A RethinkDB connection is designed to work as a singleton
let _ = builder.Services.AddSingleton<IData> data let _ = builder.Services.AddSingleton<IData> data
let _ = let _ =
builder.Services.AddDistributedRethinkDBCache (fun opts -> builder.Services.AddDistributedRethinkDBCache(fun opts ->
opts.TableName <- "Session" opts.TableName <- "Session"
opts.Connection <- rethink.Conn) opts.Connection <- rethink.Conn)
() ()
| :? SQLiteData as sql -> | :? SQLiteData as sql ->
// ADO.NET connections are designed to work as per-request instantiation // ADO.NET connections are designed to work as per-request instantiation
let cfg = sp.GetRequiredService<IConfiguration> () let cfg = sp.GetRequiredService<IConfiguration>()
let _ = let _ =
builder.Services.AddScoped<SqliteConnection> (fun sp -> builder.Services.AddScoped<SqliteConnection>(fun sp ->
let conn = new SqliteConnection (sql.Conn.ConnectionString) let conn = new SqliteConnection(sql.Conn.ConnectionString)
SQLiteData.setUpConnection conn |> Async.AwaitTask |> Async.RunSynchronously SQLiteData.setUpConnection conn |> Async.AwaitTask |> Async.RunSynchronously
conn) conn)
let _ = builder.Services.AddScoped<IData, SQLiteData> () |> ignore let _ = builder.Services.AddScoped<IData, SQLiteData>()
// Use SQLite for caching as well // Use SQLite for caching as well
let cachePath = defaultArg (Option.ofObj (cfg.GetConnectionString "SQLiteCachePath")) "./session.db" 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 -> | :? PostgresData as postgres ->
// ADO.NET Data Sources are designed to work as singletons // 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<IData> postgres
let _ = let _ =
builder.Services.AddSingleton<IDistributedCache> (fun _ -> builder.Services.AddSingleton<IDistributedCache>(fun _ ->
Postgres.DistributedCache () :> IDistributedCache) Postgres.DistributedCache() :> IDistributedCache)
() ()
| _ -> () | _ -> ()
@ -197,12 +197,12 @@ let main args =
opts.IdleTimeout <- TimeSpan.FromMinutes 60 opts.IdleTimeout <- TimeSpan.FromMinutes 60
opts.Cookie.HttpOnly <- true opts.Cookie.HttpOnly <- true
opts.Cookie.IsEssential <- true) opts.Cookie.IsEssential <- true)
let _ = builder.Services.AddGiraffe () let _ = builder.Services.AddGiraffe()
// Set up DotLiquid // Set up DotLiquid
DotLiquidBespoke.register () DotLiquidBespoke.register ()
let app = builder.Build () let app = builder.Build()
match args |> Array.tryHead with match args |> Array.tryHead with
| Some it when it = "init" -> Maintenance.createWebLog args app.Services | Some it when it = "init" -> Maintenance.createWebLog args app.Services
@ -219,25 +219,25 @@ let main args =
showHelp () showHelp ()
| None -> task { | None -> task {
// Load all themes in the application directory // 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 do! Maintenance.loadTheme [| ""; themeFile |] app.Services
let _ = app.UseForwardedHeaders () let _ = app.UseForwardedHeaders()
(app.Services.GetRequiredService<IConfiguration>().GetSection "CanonicalDomains").Value (app.Services.GetRequiredService<IConfiguration>().GetSection "CanonicalDomains").Value
|> (isNull >> not) |> (isNull >> not)
|> function true -> app.UseCanonicalDomains () |> ignore | false -> () |> function true -> app.UseCanonicalDomains() |> ignore | false -> ()
let _ = app.UseCookiePolicy (CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict)) let _ = app.UseCookiePolicy(CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict))
let _ = app.UseMiddleware<WebLogMiddleware> () let _ = app.UseMiddleware<WebLogMiddleware>()
let _ = app.UseMiddleware<RedirectRuleMiddleware> () let _ = app.UseMiddleware<RedirectRuleMiddleware>()
let _ = app.UseAuthentication () let _ = app.UseAuthentication()
let _ = app.UseStaticFiles () let _ = app.UseStaticFiles()
let _ = app.UseRouting () let _ = app.UseRouting()
let _ = app.UseSession () let _ = app.UseSession()
let _ = app.UseGiraffe Handlers.Routes.endpoint let _ = app.UseGiraffe Handlers.Routes.endpoint
app.Run () app.Run()
} }
|> Async.AwaitTask |> Async.RunSynchronously |> Async.AwaitTask |> Async.RunSynchronously