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

First cut of multi-db data

Browse Source 
- Add data interface
- Convert RethinkDB to interface implementation
- Write LiteDB implementation / converters
- Update all data access to use interface
This commit is contained in:
Daniel J. Summers 2022-06-12 23:13:12 -04:00
parent 6517d260cd
commit 476a3acd73
16 changed files with 2149 additions and 1286 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

125
src/MyWebLog.Data/Converters.fs
View File

@ -1,11 +1,14 @@
/// JSON.NET converters for discriminated union types /// Converters for discriminated union types
[<RequireQualifiedAccess>] module MyWebLog.Converters
module MyWebLog.JsonConverters
open MyWebLog open MyWebLog
open Newtonsoft.Json
open System open System
/// JSON.NET converters for discriminated union types
module Json =
open Newtonsoft.Json
type CategoryIdConverter () = type CategoryIdConverter () =
inherit JsonConverter<CategoryId> () inherit JsonConverter<CategoryId> ()
override _.WriteJson (writer : JsonWriter, value : CategoryId, _ : JsonSerializer) = override _.WriteJson (writer : JsonWriter, value : CategoryId, _ : JsonSerializer) =
@ -128,3 +131,117 @@ let all () : JsonConverter seq =
CompactUnionJsonConverter () CompactUnionJsonConverter ()
} }
// We *like* the implicit conversion of string to BsonValue
#nowarn "3391"
/// BSON converters for use with LiteDB
module Bson =
open LiteDB
module CategoryIdMapping =
let fromBson (value : BsonValue) = CategoryId value.AsString
let toBson (value : CategoryId) : BsonValue = CategoryId.toString value
module CommentIdMapping =
let fromBson (value : BsonValue) = CommentId value.AsString
let toBson (value : CommentId) : BsonValue = CommentId.toString value
module CustomFeedIdMapping =
let fromBson (value : BsonValue) = CustomFeedId value.AsString
let toBson (value : CustomFeedId) : BsonValue = CustomFeedId.toString value
module CustomFeedSourceMapping =
let fromBson (value : BsonValue) = CustomFeedSource.parse value.AsString
let toBson (value : CustomFeedSource) : BsonValue = CustomFeedSource.toString value
module ExplicitRatingMapping =
let fromBson (value : BsonValue) = ExplicitRating.parse value.AsString
let toBson (value : ExplicitRating) : BsonValue = ExplicitRating.toString value
module MarkupTextMapping =
let fromBson (value : BsonValue) = MarkupText.parse value.AsString
let toBson (value : MarkupText) : BsonValue = MarkupText.toString value
module OptionMapping =
let categoryIdFromBson (value : BsonValue) = if value.IsNull then None else Some (CategoryId value.AsString)
let categoryIdToBson (value : CategoryId option) : BsonValue =
match value with Some (CategoryId catId) -> catId | None -> BsonValue.Null
let commentIdFromBson (value : BsonValue) = if value.IsNull then None else Some (CommentId value.AsString)
let commentIdToBson (value : CommentId option) : BsonValue =
match value with Some (CommentId comId) -> comId | None -> BsonValue.Null
let dateTimeFromBson (value : BsonValue) = if value.IsNull then None else Some value.AsDateTime
let dateTimeToBson (value : DateTime option) : BsonValue =
match value with Some dateTime -> dateTime | None -> BsonValue.Null
let intFromBson (value : BsonValue) = if value.IsNull then None else Some value.AsInt32
let intToBson (value : int option) : BsonValue = match value with Some nbr -> nbr | None -> BsonValue.Null
let podcastOptionsFromBson (value : BsonValue) =
if value.IsNull then None else Some (value.RawValue :?> PodcastOptions)
let podcastOptionsToBson (value : PodcastOptions option) : BsonValue =
match value with Some opts -> BsonValue opts | None -> BsonValue.Null
let stringFromBson (value : BsonValue) = if value.IsNull then None else Some value.AsString
let stringToBson (value : string option) : BsonValue = match value with Some str -> str | None -> BsonValue.Null
module PermalinkMapping =
let fromBson (value : BsonValue) = Permalink value.AsString
let toBson (value : Permalink) : BsonValue = Permalink.toString value
module PageIdMapping =
let fromBson (value : BsonValue) = PageId value.AsString
let toBson (value : PageId) : BsonValue = PageId.toString value
module PostIdMapping =
let fromBson (value : BsonValue) = PostId value.AsString
let toBson (value : PostId) : BsonValue = PostId.toString value
module TagMapIdMapping =
let fromBson (value : BsonValue) = TagMapId value.AsString
let toBson (value : TagMapId) : BsonValue = TagMapId.toString value
module ThemeAssetIdMapping =
let fromBson (value : BsonValue) = ThemeAssetId.ofString value.AsString
let toBson (value : ThemeAssetId) : BsonValue = ThemeAssetId.toString value
module ThemeIdMapping =
let fromBson (value : BsonValue) = ThemeId value.AsString
let toBson (value : ThemeId) : BsonValue = ThemeId.toString value
module WebLogIdMapping =
let fromBson (value : BsonValue) = WebLogId value.AsString
let toBson (value : WebLogId) : BsonValue = WebLogId.toString value
module WebLogUserIdMapping =
let fromBson (value : BsonValue) = WebLogUserId value.AsString
let toBson (value : WebLogUserId) : BsonValue = WebLogUserId.toString value
/// Register all BSON mappings
let registerAll () =
let g = BsonMapper.Global
g.RegisterType<CategoryId> (CategoryIdMapping.toBson, CategoryIdMapping.fromBson)
g.RegisterType<CommentId> (CommentIdMapping.toBson, CommentIdMapping.fromBson)
g.RegisterType<CustomFeedId> (CustomFeedIdMapping.toBson, CustomFeedIdMapping.fromBson)
g.RegisterType<CustomFeedSource> (CustomFeedSourceMapping.toBson, CustomFeedSourceMapping.fromBson)
g.RegisterType<ExplicitRating> (ExplicitRatingMapping.toBson, ExplicitRatingMapping.fromBson)
g.RegisterType<MarkupText> (MarkupTextMapping.toBson, MarkupTextMapping.fromBson)
g.RegisterType<Permalink> (PermalinkMapping.toBson, PermalinkMapping.fromBson)
g.RegisterType<PageId> (PageIdMapping.toBson, PageIdMapping.fromBson)
g.RegisterType<PostId> (PostIdMapping.toBson, PostIdMapping.fromBson)
g.RegisterType<TagMapId> (TagMapIdMapping.toBson, TagMapIdMapping.fromBson)
g.RegisterType<ThemeAssetId> (ThemeAssetIdMapping.toBson, ThemeAssetIdMapping.fromBson)
g.RegisterType<ThemeId> (ThemeIdMapping.toBson, ThemeIdMapping.fromBson)
g.RegisterType<WebLogId> (WebLogIdMapping.toBson, WebLogIdMapping.fromBson)
g.RegisterType<WebLogUserId> (WebLogUserIdMapping.toBson, WebLogUserIdMapping.fromBson)
g.RegisterType<CategoryId option> (OptionMapping.categoryIdToBson, OptionMapping.categoryIdFromBson)
g.RegisterType<CommentId option> (OptionMapping.commentIdToBson, OptionMapping.commentIdFromBson)
g.RegisterType<DateTime option> (OptionMapping.dateTimeToBson, OptionMapping.dateTimeFromBson)
g.RegisterType<int option> (OptionMapping.intToBson, OptionMapping.intFromBson)
g.RegisterType<PodcastOptions option> (OptionMapping.podcastOptionsToBson, OptionMapping.podcastOptionsFromBson)
g.RegisterType<string option> (OptionMapping.stringToBson, OptionMapping.stringFromBson)

915
src/MyWebLog.Data/Data.fs
View File

@ -1,915 +0,0 @@
[<RequireQualifiedAccess>]
module MyWebLog.Data
/// Table names
[<RequireQualifiedAccess>]
module Table =
/// The category table
let Category = "Category"
/// The comment table
let Comment = "Comment"
/// The page table
let Page = "Page"
/// The post table
let Post = "Post"
/// The tag map table
let TagMap = "TagMap"
/// The theme table
let Theme = "Theme"
/// The theme asset table
let ThemeAsset = "ThemeAsset"
/// The web log table
let WebLog = "WebLog"
/// The web log user table
let WebLogUser = "WebLogUser"
/// A list of all tables
let all = [ Category; Comment; Page; Post; TagMap; Theme; ThemeAsset; WebLog; WebLogUser ]
/// Functions to assist with retrieving data
[<AutoOpen>]
module Helpers =
open RethinkDb.Driver
open RethinkDb.Driver.Net
open System.Threading.Tasks
/// Shorthand for the ReQL starting point
let r = RethinkDB.R
/// Verify that the web log ID matches before returning an item
let verifyWebLog<'T> webLogId (prop : 'T -> WebLogId) (f : IConnection -> Task<'T option>) =
fun conn -> backgroundTask {
match! f conn with Some it when (prop it) = webLogId -> return Some it | _ -> return None
}
/// Get the first item from a list, or None if the list is empty
let tryFirst<'T> (f : IConnection -> Task<'T list>) =
fun conn -> backgroundTask {
let! results = f conn
return results |> List.tryHead
}
/// Cast a strongly-typed list to an object list
let objList<'T> (objects : 'T list) = objects |> List.map (fun it -> it :> obj)
open RethinkDb.Driver.FSharp
open Microsoft.Extensions.Logging
/// Start up checks to ensure the database, tables, and indexes exist
module Startup =
/// Ensure field indexes exist, as well as special indexes for selected tables
let private ensureIndexes (log : ILogger) conn table fields = backgroundTask {
let! indexes = rethink<string list> { withTable table; indexList; result; withRetryOnce conn }
for field in fields do
if not (indexes |> List.contains field) then
log.LogInformation $"Creating index {table}.{field}..."
do! rethink { withTable table; indexCreate field; write; withRetryOnce; ignoreResult conn }
// Post and page need index by web log ID and permalink
if [ Table.Page; Table.Post ] |> List.contains table then
if not (indexes |> List.contains "permalink") then
log.LogInformation $"Creating index {table}.permalink..."
do! rethink {
withTable table
indexCreate "permalink" (fun row -> r.Array (row["webLogId"], row["permalink"].Downcase ()) :> obj)
write; withRetryOnce; ignoreResult conn
}
// Prior permalinks are searched when a post or page permalink do not match the current URL
if not (indexes |> List.contains "priorPermalinks") then
log.LogInformation $"Creating index {table}.priorPermalinks..."
do! rethink {
withTable table
indexCreate "priorPermalinks" (fun row -> row["priorPermalinks"].Downcase () :> obj) [ Multi ]
write; withRetryOnce; ignoreResult conn
}
// Post needs indexes by category and tag (used for counting and retrieving posts)
if Table.Post = table then
for idx in [ "categoryIds"; "tags" ] do
if not (List.contains idx indexes) then
log.LogInformation $"Creating index {table}.{idx}..."
do! rethink {
withTable table
indexCreate idx [ Multi ]
write; withRetryOnce; ignoreResult conn
}
// Tag mapping needs an index by web log ID and both tag and URL values
if Table.TagMap = table then
if not (indexes |> List.contains "webLogAndTag") then
log.LogInformation $"Creating index {table}.webLogAndTag..."
do! rethink {
withTable table
indexCreate "webLogAndTag" (fun row -> r.Array (row["webLogId"], row["tag"]) :> obj)
write; withRetryOnce; ignoreResult conn
}
if not (indexes |> List.contains "webLogAndUrl") then
log.LogInformation $"Creating index {table}.webLogAndUrl..."
do! rethink {
withTable table
indexCreate "webLogAndUrl" (fun row -> r.Array (row["webLogId"], row["urlValue"]) :> obj)
write; withRetryOnce; ignoreResult conn
}
// Users log on with e-mail
if Table.WebLogUser = table && not (indexes |> List.contains "logOn") then
log.LogInformation $"Creating index {table}.logOn..."
do! rethink {
withTable table
indexCreate "logOn" (fun row -> r.Array (row["webLogId"], row["userName"]) :> obj)
write; withRetryOnce; ignoreResult conn
}
}
/// Ensure all necessary tables and indexes exist
let ensureDb (config : DataConfig) (log : ILogger) conn = backgroundTask {
let! dbs = rethink<string list> { dbList; result; withRetryOnce conn }
if not (dbs |> List.contains config.Database) then
log.LogInformation($"Creating database {config.Database}...")
do! rethink { dbCreate config.Database; write; withRetryOnce; ignoreResult conn }
let! tables = rethink<string list> { tableList; result; withRetryOnce conn }
for tbl in Table.all do
if not (tables |> List.contains tbl) then
log.LogInformation($"Creating table {tbl}...")
do! rethink { tableCreate tbl; write; withRetryOnce; ignoreResult conn }
let makeIdx = ensureIndexes log conn
do! makeIdx Table.Category [ "webLogId" ]
do! makeIdx Table.Comment [ "postId" ]
do! makeIdx Table.Page [ "webLogId"; "authorId" ]
do! makeIdx Table.Post [ "webLogId"; "authorId" ]
do! makeIdx Table.TagMap []
do! makeIdx Table.WebLog [ "urlBase" ]
do! makeIdx Table.WebLogUser [ "webLogId" ]
}
/// Functions to manipulate categories
module Category =
open System.Threading.Tasks
open MyWebLog.ViewModels
/// Add a category
let add (cat : Category) =
rethink {
withTable Table.Category
insert cat
write; withRetryDefault; ignoreResult
}
/// Count all categories for a web log
let countAll (webLogId : WebLogId) =
rethink<int> {
withTable Table.Category
getAll [ webLogId ] (nameof webLogId)
count
result; withRetryDefault
}
/// Count top-level categories for a web log
let countTopLevel (webLogId : WebLogId) =
rethink<int> {
withTable Table.Category
getAll [ webLogId ] (nameof webLogId)
filter "parentId" None
count
result; withRetryDefault
}
/// Create a category hierarchy from the given list of categories
let rec private orderByHierarchy (cats : Category list) parentId slugBase parentNames = seq {
for cat in cats |> List.filter (fun c -> c.parentId = parentId) do
let fullSlug = (match slugBase with Some it -> $"{it}/" | None -> "") + cat.slug
{ id = CategoryId.toString cat.id
slug = fullSlug
name = cat.name
description = cat.description
parentNames = Array.ofList parentNames
// Post counts are filled on a second pass
postCount = 0
}
yield! orderByHierarchy cats (Some cat.id) (Some fullSlug) ([ cat.name ] |> List.append parentNames)
}
/// Find all categories for a web log, sorted alphabetically, arranged in groups, in view model format
let findAllForView (webLogId : WebLogId) conn = backgroundTask {
let! cats = rethink<Category list> {
withTable Table.Category
getAll [ webLogId ] (nameof webLogId)
orderByFunc (fun it -> it["name"].Downcase () :> obj)
result; withRetryDefault conn
}
let ordered = orderByHierarchy cats None None []
let! counts =
ordered
|> Seq.map (fun it -> backgroundTask {
// Parent category post counts include posts in subcategories
let catIds =
ordered
|> Seq.filter (fun cat -> cat.parentNames |> Array.contains it.name)
|> Seq.map (fun cat -> cat.id :> obj)
|> Seq.append (Seq.singleton it.id)
|> List.ofSeq
let! count = rethink<int> {
withTable Table.Post
getAll catIds "categoryIds"
filter "status" Published
distinct
count
result; withRetryDefault conn
}
return it.id, count
})
|> Task.WhenAll
return
ordered
|> Seq.map (fun cat ->
{ cat with
postCount = counts
|> Array.tryFind (fun c -> fst c = cat.id)
|> Option.map snd
|> Option.defaultValue 0
})
|> Array.ofSeq
}
/// Find a category by its ID
let findById (catId : CategoryId) webLogId =
rethink<Category> {
withTable Table.Category
get catId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun c -> c.webLogId)
/// Delete a category, also removing it from any posts to which it is assigned
let delete catId webLogId conn = backgroundTask {
match! findById catId webLogId conn with
| Some _ ->
// Delete the category off all posts where it is assigned
do! rethink {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
filter (fun row -> row["categoryIds"].Contains catId :> obj)
update (fun row -> r.HashMap ("categoryIds", r.Array(row["categoryIds"]).Remove catId) :> obj)
write; withRetryDefault; ignoreResult conn
}
// Delete the category itself
do! rethink {
withTable Table.Category
get catId
delete
write; withRetryDefault; ignoreResult conn
}
return true
| None -> return false
}
/// Get a category ID -> name dictionary for the given category IDs
let findNames (webLogId : WebLogId) conn (catIds : CategoryId list) = backgroundTask {
let! cats = rethink<Category list> {
withTable Table.Category
getAll (objList catIds)
filter "webLogId" webLogId
result; withRetryDefault conn
}
return cats |> List.map (fun c -> { name = CategoryId.toString c.id; value = c.name})
}
/// Update a category
let update (cat : Category) =
rethink {
withTable Table.Category
get cat.id
update [ "name", cat.name :> obj
"slug", cat.slug
"description", cat.description
"parentId", cat.parentId
]
write; withRetryDefault; ignoreResult
}
/// Functions to manipulate pages
module Page =
open RethinkDb.Driver.Model
/// Add a new page
let add (page : Page) =
rethink {
withTable Table.Page
insert page
write; withRetryDefault; ignoreResult
}
/// Count all pages for a web log
let countAll (webLogId : WebLogId) =
rethink<int> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
count
result; withRetryDefault
}
/// Count listed pages for a web log
let countListed (webLogId : WebLogId) =
rethink<int> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
filter "showInPageList" true
count
result; withRetryDefault
}
/// Delete a page
let delete (pageId : PageId) (webLogId : WebLogId) conn = backgroundTask {
let! result =
rethink<Result> {
withTable Table.Page
getAll [ pageId ]
filter (fun row -> row["webLogId"].Eq webLogId :> obj)
delete
write; withRetryDefault conn
}
return result.Deleted > 0UL
}
/// Retrieve all pages for a web log (excludes text, prior permalinks, and revisions)
let findAll (webLogId : WebLogId) =
rethink<Page list> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
without [ "text"; "priorPermalinks"; "revisions" ]
result; withRetryDefault
}
/// Find a page by its ID (including prior permalinks and revisions)
let findByFullId (pageId : PageId) webLogId =
rethink<Page> {
withTable Table.Page
get pageId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun it -> it.webLogId)
/// Find a page by its ID (excludes prior permalinks and revisions)
let findById (pageId : PageId) webLogId =
rethink<Page> {
withTable Table.Page
get pageId
without [ "priorPermalinks"; "revisions" ]
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun it -> it.webLogId)
/// Find a page by its permalink
let findByPermalink (permalink : Permalink) (webLogId : WebLogId) =
rethink<Page list> {
withTable Table.Page
getAll [ r.Array (webLogId, permalink) ] (nameof permalink)
without [ "priorPermalinks"; "revisions" ]
limit 1
result; withRetryDefault
}
|> tryFirst
/// Find the current permalink for a page by a prior permalink
let findCurrentPermalink (permalinks : Permalink list) (webLogId : WebLogId) conn = backgroundTask {
let! result =
(rethink<Page list> {
withTable Table.Page
getAll (objList permalinks) "priorPermalinks"
filter "webLogId" webLogId
without [ "revisions"; "text" ]
limit 1
result; withRetryDefault
}
|> tryFirst) conn
return result |> Option.map (fun pg -> pg.permalink)
}
/// Find all pages in the page list for the given web log
let findListed (webLogId : WebLogId) =
rethink<Page list> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
filter [ "showInPageList", true :> obj ]
without [ "text"; "priorPermalinks"; "revisions" ]
orderBy "title"
result; withRetryDefault
}
/// Find a list of pages (displayed in admin area)
let findPageOfPages (webLogId : WebLogId) pageNbr =
rethink<Page list> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
without [ "priorPermalinks"; "revisions" ]
orderByFunc (fun row -> row["title"].Downcase ())
skip ((pageNbr - 1) * 25)
limit 25
result; withRetryDefault
}
/// Update a page
let update (page : Page) =
rethink {
withTable Table.Page
get page.id
update [
"title", page.title :> obj
"permalink", page.permalink
"updatedOn", page.updatedOn
"showInPageList", page.showInPageList
"template", page.template
"text", page.text
"priorPermalinks", page.priorPermalinks
"metadata", page.metadata
"revisions", page.revisions
]
write; withRetryDefault; ignoreResult
}
/// Update prior permalinks for a page
let updatePriorPermalinks pageId webLogId (permalinks : Permalink list) conn = backgroundTask {
match! findById pageId webLogId conn with
| Some _ ->
do! rethink {
withTable Table.Page
get pageId
update [ "priorPermalinks", permalinks :> obj ]
write; withRetryDefault; ignoreResult conn
}
return true
| None -> return false
}
/// Functions to manipulate posts
module Post =
open System
open RethinkDb.Driver.Model
/// Add a post
let add (post : Post) =
rethink {
withTable Table.Post
insert post
write; withRetryDefault; ignoreResult
}
/// Count posts for a web log by their status
let countByStatus (status : PostStatus) (webLogId : WebLogId) =
rethink<int> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
filter "status" status
count
result; withRetryDefault
}
/// Delete a post
let delete (postId : PostId) (webLogId : WebLogId) conn = backgroundTask {
let! result =
rethink<Result> {
withTable Table.Post
getAll [ postId ]
filter (fun row -> row["webLogId"].Eq webLogId :> obj)
delete
write; withRetryDefault conn
}
return result.Deleted > 0UL
}
/// Find a post by its permalink
let findByPermalink (permalink : Permalink) (webLogId : WebLogId) =
rethink<Post list> {
withTable Table.Post
getAll [ r.Array (webLogId, permalink) ] (nameof permalink)
without [ "priorPermalinks"; "revisions" ]
limit 1
result; withRetryDefault
}
|> tryFirst
/// Find a post by its ID, including all revisions and prior permalinks
let findByFullId (postId : PostId) webLogId =
rethink<Post> {
withTable Table.Post
get postId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun p -> p.webLogId)
/// Find the current permalink for a post by a prior permalink
let findCurrentPermalink (permalinks : Permalink list) (webLogId : WebLogId) conn = backgroundTask {
let! result =
(rethink<Post list> {
withTable Table.Post
getAll (objList permalinks) "priorPermalinks"
filter "webLogId" webLogId
without [ "revisions"; "text" ]
limit 1
result; withRetryDefault
}
|> tryFirst) conn
return result |> Option.map (fun post -> post.permalink)
}
/// Find posts to be displayed on a category list page
let findPageOfCategorizedPosts (webLogId : WebLogId) (catIds : CategoryId list) pageNbr postsPerPage =
rethink<Post list> {
withTable Table.Post
getAll (objList catIds) "categoryIds"
filter "webLogId" webLogId
filter "status" Published
without [ "priorPermalinks"; "revisions" ]
distinct
orderByDescending "publishedOn"
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault
}
/// Find posts to be displayed on an admin page
let findPageOfPosts (webLogId : WebLogId) (pageNbr : int) postsPerPage =
rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
without [ "priorPermalinks"; "revisions" ]
orderByFuncDescending (fun row -> row["publishedOn"].Default_ "updatedOn" :> obj)
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault
}
/// Find posts to be displayed on a page
let findPageOfPublishedPosts (webLogId : WebLogId) pageNbr postsPerPage =
rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
filter "status" Published
without [ "priorPermalinks"; "revisions" ]
orderByDescending "publishedOn"
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault
}
/// Find posts to be displayed on a tag list page
let findPageOfTaggedPosts (webLogId : WebLogId) (tag : string) pageNbr postsPerPage =
rethink<Post list> {
withTable Table.Post
getAll [ tag ] "tags"
filter "webLogId" webLogId
filter "status" Published
without [ "priorPermalinks"; "revisions" ]
orderByDescending "publishedOn"
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault
}
/// Find the next older and newer post for the given post
let findSurroundingPosts (webLogId : WebLogId) (publishedOn : DateTime) conn = backgroundTask {
let! older =
rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
filter (fun row -> row["publishedOn"].Lt publishedOn :> obj)
orderByDescending "publishedOn"
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
let! newer =
rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
filter (fun row -> row["publishedOn"].Gt publishedOn :> obj)
orderBy "publishedOn"
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
return older, newer
}
/// Update a post (all fields are updated)
let update (post : Post) =
rethink {
withTable Table.Post
get post.id
replace post
write; withRetryDefault; ignoreResult
}
/// Update prior permalinks for a post
let updatePriorPermalinks (postId : PostId) webLogId (permalinks : Permalink list) conn = backgroundTask {
match! (
rethink<Post> {
withTable Table.Post
get postId
without [ "revisions"; "priorPermalinks" ]
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun p -> p.webLogId)) conn with
| Some _ ->
do! rethink {
withTable Table.Post
get postId
update [ "priorPermalinks", permalinks :> obj ]
write; withRetryDefault; ignoreResult conn
}
return true
| None -> return false
}
/// Functions to manipulate tag mappings
module TagMap =
open RethinkDb.Driver.Model
/// Delete a tag mapping
let delete (tagMapId : TagMapId) (webLogId : WebLogId) conn = backgroundTask {
let! result =
rethink<Result> {
withTable Table.TagMap
getAll [ tagMapId ]
filter (fun row -> row["webLogId"].Eq webLogId :> obj)
delete
write; withRetryDefault conn
}
return result.Deleted > 0UL
}
/// Find a tag map by its ID
let findById (tagMapId : TagMapId) webLogId =
rethink<TagMap> {
withTable Table.TagMap
get tagMapId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun tm -> tm.webLogId)
/// Find a tag mapping via URL value for a given web log
let findByUrlValue (urlValue : string) (webLogId : WebLogId) =
rethink<TagMap list> {
withTable Table.TagMap
getAll [ r.Array (webLogId, urlValue) ] "webLogAndUrl"
limit 1
result; withRetryDefault
}
|> tryFirst
/// Find all tag mappings for a web log
let findByWebLogId (webLogId : WebLogId) =
rethink<TagMap list> {
withTable Table.TagMap
between (r.Array (webLogId, r.Minval ())) (r.Array (webLogId, r.Maxval ())) [ Index "webLogAndTag" ]
orderBy "tag"
result; withRetryDefault
}
/// Retrieve mappings for the specified tags
let findMappingForTags (tags : string list) (webLogId : WebLogId) =
rethink<TagMap list> {
withTable Table.TagMap
getAll (tags |> List.map (fun tag -> r.Array (webLogId, tag) :> obj)) "webLogAndTag"
result; withRetryDefault
}
/// Save a tag mapping
let save (tagMap : TagMap) =
rethink {
withTable Table.TagMap
get tagMap.id
replace tagMap
write; withRetryDefault; ignoreResult
}
/// Functions to manipulate themes
module Theme =
/// Get all themes
let list =
rethink<Theme list> {
withTable Table.Theme
filter (fun row -> row["id"].Ne "admin" :> obj)
without [ "templates" ]
orderBy "id"
result; withRetryDefault
}
/// Retrieve a theme by its ID
let findById (themeId : ThemeId) =
rethink<Theme> {
withTable Table.Theme
get themeId
resultOption; withRetryOptionDefault
}
/// Retrieve a theme by its ID, excluding the text of templates
let findByIdWithoutText (themeId : ThemeId) =
rethink<Theme> {
withTable Table.Theme
get themeId
merge (fun row -> r.HashMap ("templates", row["templates"].Without [| "text" |]))
resultOption; withRetryOptionDefault
}
/// Save a theme
let save (theme : Theme) =
rethink {
withTable Table.Theme
get theme.id
replace theme
write; withRetryDefault; ignoreResult
}
/// Functions to manipulate theme assets
module ThemeAsset =
open RethinkDb.Driver.Ast
/// Match the ID by its prefix (the theme ID)
let private matchById themeId =
let keyPrefix = $"^{ThemeId.toString themeId}/"
fun (row : ReqlExpr) -> row["id"].Match keyPrefix :> obj
/// List all theme assets (excludes data)
let all =
rethink<ThemeAsset list> {
withTable Table.ThemeAsset
without [ "data" ]
result; withRetryDefault
}
/// Delete all assets for a theme
let deleteByTheme themeId =
rethink {
withTable Table.ThemeAsset
filter (matchById themeId)
delete
write; withRetryDefault; ignoreResult
}
/// Find a theme asset by its ID
let findById (assetId : ThemeAssetId) =
rethink<ThemeAsset> {
withTable Table.ThemeAsset
get assetId
resultOption; withRetryOptionDefault
}
/// List all assets for a theme (data excluded)
let findByThemeId (themeId : ThemeId) =
rethink<ThemeAsset list> {
withTable Table.ThemeAsset
filter (matchById themeId)
without [ "data" ]
result; withRetryDefault
}
/// Save a theme asset
let save (asset : ThemeAsset) =
rethink {
withTable Table.ThemeAsset
get asset.id
replace asset
write; withRetryDefault; ignoreResult
}
/// Functions to manipulate web logs
module WebLog =
/// Add a web log
let add (webLog : WebLog) = rethink {
withTable Table.WebLog
insert webLog
write; withRetryOnce; ignoreResult
}
/// Get all web logs
let all = rethink<WebLog list> {
withTable Table.WebLog
result; withRetryDefault
}
/// Retrieve a web log by the URL base
let findByHost (url : string) =
rethink<WebLog list> {
withTable Table.WebLog
getAll [ url ] "urlBase"
limit 1
result; withRetryDefault
}
|> tryFirst
/// Retrieve a web log by its ID
let findById (webLogId : WebLogId) =
rethink<WebLog> {
withTable Table.WebLog
get webLogId
resultOption; withRetryOptionDefault
}
/// Update RSS options for a web log
let updateRssOptions (webLog : WebLog) =
rethink {
withTable Table.WebLog
get webLog.id
update [ "rss", webLog.rss :> obj ]
write; withRetryDefault; ignoreResult
}
/// Update web log settings (from settings page)
let updateSettings (webLog : WebLog) =
rethink {
withTable Table.WebLog
get webLog.id
update [
"name", webLog.name :> obj
"subtitle", webLog.subtitle
"defaultPage", webLog.defaultPage
"postsPerPage", webLog.postsPerPage
"timeZone", webLog.timeZone
"themePath", webLog.themePath
"autoHtmx", webLog.autoHtmx
]
write; withRetryDefault; ignoreResult
}
/// Functions to manipulate web log users
module WebLogUser =
/// Add a web log user
let add (user : WebLogUser) =
rethink {
withTable Table.WebLogUser
insert user
write; withRetryDefault; ignoreResult
}
/// Find a user by their e-mail address
let findByEmail (email : string) (webLogId : WebLogId) =
rethink<WebLogUser list> {
withTable Table.WebLogUser
getAll [ r.Array (webLogId, email) ] "logOn"
limit 1
result; withRetryDefault
}
|> tryFirst
/// Find a user by their ID
let findById (userId : WebLogUserId) =
rethink<WebLogUser> {
withTable Table.WebLogUser
get userId
resultOption; withRetryOptionDefault
}
/// Get a user ID -> name dictionary for the given user IDs
let findNames (webLogId : WebLogId) conn (userIds : WebLogUserId list) = backgroundTask {
let! users = rethink<WebLogUser list> {
withTable Table.WebLogUser
getAll (objList userIds)
filter "webLogId" webLogId
result; withRetryDefault conn
}
return users |> List.map (fun u -> { name = WebLogUserId.toString u.id; value = WebLogUser.displayName u })
}
/// Update a user
let update (user : WebLogUser) =
rethink {
withTable Table.WebLogUser
get user.id
update [
"firstName", user.firstName :> obj
"lastName", user.lastName
"preferredName", user.preferredName
"passwordHash", user.passwordHash
"salt", user.salt
]
write; withRetryDefault; ignoreResult
}

248
src/MyWebLog.Data/Interfaces.fs Normal file
View File

@ -0,0 +1,248 @@
namespace MyWebLog.Data
open System
open System.Threading.Tasks
open MyWebLog
open MyWebLog.ViewModels
/// Data functions to support manipulating categories
type ICategoryData =
/// Add a category
abstract member add : Category -> Task<unit>
/// Count all categories for the given web log
abstract member countAll : WebLogId -> Task<int>
/// Count all top-level categories for the given web log
abstract member countTopLevel : WebLogId -> Task<int>
/// Delete a category (also removes it from posts)
abstract member delete : CategoryId -> WebLogId -> Task<bool>
/// Find all categories for a web log, sorted alphabetically and grouped by hierarchy
abstract member findAllForView : WebLogId -> Task<DisplayCategory[]>
/// Find a category by its ID
abstract member findById : CategoryId -> WebLogId -> Task<Category option>
/// Update a category (slug, name, description, and parent ID)
abstract member update : Category -> Task<unit>
/// Data functions to support manipulating pages
type IPageData =
/// Add a page
abstract member add : Page -> Task<unit>
/// Get all pages for the web log (excluding text, revisions, and prior permalinks)
abstract member all : WebLogId -> Task<Page list>
/// Count all pages for the given web log
abstract member countAll : WebLogId -> Task<int>
/// Count pages marked as "show in page list" for the given web log
abstract member countListed : WebLogId -> Task<int>
/// Delete a page
abstract member delete : PageId -> WebLogId -> Task<bool>
/// Find a page by its ID (excluding revisions and prior permalinks)
abstract member findById : PageId -> WebLogId -> Task<Page option>
/// Find a page by its permalink (excluding revisions and prior permalinks)
abstract member findByPermalink : Permalink -> WebLogId -> Task<Page option>
/// Find the current permalink for a page from a list of prior permalinks
abstract member findCurrentPermalink : Permalink list -> WebLogId -> Task<Permalink option>
/// Find a page by its ID (including revisions and prior permalinks)
abstract member findFullById : PageId -> WebLogId -> Task<Page option>
/// Find pages marked as "show in page list" for the given web log (excluding text, revisions, and prior permalinks)
abstract member findListed : WebLogId -> Task<Page list>
/// Find a page of pages (displayed in admin section) (excluding revisions and prior permalinks)
abstract member findPageOfPages : WebLogId -> pageNbr : int -> Task<Page list>
/// Update a page
abstract member update : Page -> Task<unit>
/// Update the prior permalinks for the given page
abstract member updatePriorPermalinks : PageId -> WebLogId -> Permalink list -> Task<bool>
/// Data functions to support manipulating posts
type IPostData =
/// Add a post
abstract member add : Post -> Task<unit>
/// Count posts by their status
abstract member countByStatus : PostStatus -> WebLogId -> Task<int>
/// Delete a post
abstract member delete : PostId -> WebLogId -> Task<bool>
/// Find a post by its permalink (excluding revisions and prior permalinks)
abstract member findByPermalink : Permalink -> WebLogId -> Task<Post option>
/// Find the current permalink for a post from a list of prior permalinks
abstract member findCurrentPermalink : Permalink list -> WebLogId -> Task<Permalink option>
/// Find a post by its ID (including revisions and prior permalinks)
abstract member findFullById : PostId -> WebLogId -> Task<Post option>
/// Find posts to be displayed on a category list page (excluding revisions and prior permalinks)
abstract member findPageOfCategorizedPosts :
WebLogId -> CategoryId list -> pageNbr : int -> postsPerPage : int -> Task<Post list>
/// Find posts to be displayed on an admin page (excluding revisions and prior permalinks)
abstract member findPageOfPosts : WebLogId -> pageNbr : int -> postsPerPage : int -> Task<Post list>
/// Find posts to be displayed on a page (excluding revisions and prior permalinks)
abstract member findPageOfPublishedPosts : WebLogId -> pageNbr : int -> postsPerPage : int -> Task<Post list>
/// Find posts to be displayed on a tag list page (excluding revisions and prior permalinks)
abstract member findPageOfTaggedPosts :
WebLogId -> tag : string -> pageNbr : int -> postsPerPage : int -> Task<Post list>
/// Find the next older and newer post for the given published date/time (excluding revisions and prior permalinks)
abstract member findSurroundingPosts : WebLogId -> publishedOn : DateTime -> Task<Post option * Post option>
/// Update a post
abstract member update : Post -> Task<unit>
/// Update the prior permalinks for a post
abstract member updatePriorPermalinks : PostId -> WebLogId -> Permalink list -> Task<bool>
/// Functions to manipulate tag mappings
type ITagMapData =
/// Retrieve all tag mappings for the given web log
abstract member all : WebLogId -> Task<TagMap list>
/// Delete a tag mapping
abstract member delete : TagMapId -> WebLogId -> Task<bool>
/// Find a tag mapping by its ID
abstract member findById : TagMapId -> WebLogId -> Task<TagMap option>
/// Find a tag mapping by its URL value
abstract member findByUrlValue : string -> WebLogId -> Task<TagMap option>
/// Find tag mappings for the given tags
abstract member findMappingForTags : tags : string list -> WebLogId -> Task<TagMap list>
/// Save a tag mapping (insert or update)
abstract member save : TagMap -> Task<unit>
/// Functions to manipulate themes
type IThemeData =
/// Retrieve all themes (except "admin")
abstract member all : unit -> Task<Theme list>
/// Find a theme by its ID
abstract member findById : ThemeId -> Task<Theme option>
/// Find a theme by its ID (excluding the text of its templates)
abstract member findByIdWithoutText : ThemeId -> Task<Theme option>
/// Save a theme (insert or update)
abstract member save : Theme -> Task<unit>
/// Functions to manipulate theme assets
type IThemeAssetData =
/// Retrieve all theme assets (excluding data)
abstract member all : unit -> Task<ThemeAsset list>
/// Delete all theme assets for the given theme
abstract member deleteByTheme : ThemeId -> Task<unit>
/// Find a theme asset by its ID
abstract member findById : ThemeAssetId -> Task<ThemeAsset option>
/// Find all assets for the given theme (excludes data)
abstract member findByTheme : ThemeId -> Task<ThemeAsset list>
/// Save a theme asset (insert or update)
abstract member save : ThemeAsset -> Task<unit>
/// Functions to manipulate web logs
type IWebLogData =
/// Add a web log
abstract member add : WebLog -> Task<unit>
/// Retrieve all web logs
abstract member all : unit -> Task<WebLog list>
/// Find a web log by its host (URL base)
abstract member findByHost : string -> Task<WebLog option>
/// Find a web log by its ID
abstract member findById : WebLogId -> Task<WebLog option>
/// Update RSS options for a web log
abstract member updateRssOptions : WebLog -> Task<unit>
/// Update web log settings (from the settings page)
abstract member updateSettings : WebLog -> Task<unit>
/// Functions to manipulate web log users
type IWebLogUserData =
/// Add a web log user
abstract member add : WebLogUser -> Task<unit>
/// Find a web log user by their e-mail address
abstract member findByEmail : email : string -> WebLogId -> Task<WebLogUser option>
/// Find a web log user by their ID
abstract member findById : WebLogUserId -> WebLogId -> Task<WebLogUser option>
/// Get a user ID -> name dictionary for the given user IDs
abstract member findNames : WebLogId -> WebLogUserId list -> Task<MetaItem list>
/// Update a web log user
abstract member update : WebLogUser -> Task<unit>
/// Data interface required for a myWebLog data implementation
type IData =
/// Category data functions
abstract member Category : ICategoryData
/// Page data functions
abstract member Page : IPageData
/// Post data functions
abstract member Post : IPostData
/// Tag map data functions
abstract member TagMap : ITagMapData
/// Theme data functions
abstract member Theme : IThemeData
/// Theme asset data functions
abstract member ThemeAsset : IThemeAssetData
/// Web log data functions
abstract member WebLog : IWebLogData
/// Web log user data functions
abstract member WebLogUser : IWebLogUserData
/// Do any required start up data checks
abstract member startUp : unit -> Task<unit>

526
src/MyWebLog.Data/LiteDbData.fs Normal file
View File

@ -0,0 +1,526 @@
namespace MyWebLog.Data
open LiteDB
open MyWebLog
open System.Threading.Tasks
open MyWebLog.Converters
open MyWebLog.Data
/// Functions to assist with retrieving data
[<AutoOpen>]
module private LiteHelpers =
/// Convert a "can't be null" object to an option if it's null (thanks, CLIMutable!)
let toOption<'T> (it : 'T) =
match Option.ofObj (box it) with Some _ -> Some it | None -> None
|> Task.FromResult
/// Verify that the web log ID matches before returning an item
let verifyWebLog<'T> webLogId (prop : 'T -> WebLogId) (it : 'T) = backgroundTask {
match! toOption it with
| Some item when prop item = webLogId -> return Some it
| Some _
| None -> return None
}
/// Get the first item from a list, or None if the list is empty
let tryFirst<'T> (items : 'T seq) =
items |> Seq.tryHead |> Task.FromResult
/// Convert a sequence to a list, wrapped in a task
let toList items =
items |> List.ofSeq |> Task.FromResult
/// Convert a sequence to a paged list, wrapped in a task
let toPagedList pageNbr postsPerPage items =
items |> Seq.skip ((pageNbr - 1) * postsPerPage) |> Seq.truncate (postsPerPage + 1) |> toList
open MyWebLog.Converters.Bson
open MyWebLog.ViewModels
/// LiteDB implementation of data functions for myWebLog
type LiteDbData (db : LiteDatabase) =
/// Shorthand for accessing the collections in the LiteDB database
let Collection = {|
Category = db.GetCollection<Category> "Category"
Comment = db.GetCollection<Comment> "Comment"
Page = db.GetCollection<Page> "Page"
Post = db.GetCollection<Post> "Post"
TagMap = db.GetCollection<TagMap> "TagMap"
Theme = db.GetCollection<Theme> "Theme"
ThemeAsset = db.GetCollection<ThemeAsset> "ThemeAsset"
WebLog = db.GetCollection<WebLog> "WebLog"
WebLogUser = db.GetCollection<WebLogUser> "WebLogUser"
|}
/// Create a category hierarchy from the given list of categories
let rec orderByHierarchy (cats : Category list) parentId slugBase parentNames = seq {
for cat in cats |> List.filter (fun c -> c.parentId = parentId) do
let fullSlug = (match slugBase with Some it -> $"{it}/" | None -> "") + cat.slug
{ id = CategoryId.toString cat.id
slug = fullSlug
name = cat.name
description = cat.description
parentNames = Array.ofList parentNames
// Post counts are filled on a second pass
postCount = 0
}
yield! orderByHierarchy cats (Some cat.id) (Some fullSlug) ([ cat.name ] |> List.append parentNames)
}
/// Async wrapper on LiteDB's checkpoint operation
let checkpoint () = backgroundTask {
db.Checkpoint ()
}
/// Return a page with no revisions or prior permalinks
let pageWithoutRevisions (page : Page) =
{ page with revisions = []; priorPermalinks = [] }
/// Return a page with no revisions, prior permalinks, or text
let pageWithoutText page =
{ pageWithoutRevisions page with text = "" }
/// Sort function for pages
let pageSort (page : Page) =
page.title.ToLowerInvariant ()
/// Return a post with no revisions or prior permalinks
let postWithoutRevisions (post : Post) =
{ post with revisions = []; priorPermalinks = [] }
/// Return a post with no revisions, prior permalinks, or text
let postWithoutText post =
{ postWithoutRevisions post with text = "" }
/// The database for this instance
member _.Db = db
interface IData with
member _.Category = {
new ICategoryData with
member _.add cat = backgroundTask {
let _ = Collection.Category.Insert cat
do! checkpoint ()
}
member _.countAll webLogId =
Collection.Category.Count(fun cat -> cat.webLogId = webLogId)
|> Task.FromResult
member _.countTopLevel webLogId =
Collection.Category.Count(fun cat -> cat.webLogId = webLogId && Option.isNone cat.parentId)
|> Task.FromResult
member _.findAllForView webLogId = backgroundTask {
let cats =
Collection.Category.Find (fun cat -> cat.webLogId = webLogId)
|> Seq.sortBy (fun cat -> cat.name.ToLowerInvariant ())
|> List.ofSeq
let ordered = orderByHierarchy cats None None []
let! counts =
ordered
|> Seq.map (fun it -> backgroundTask {
// Parent category post counts include posts in subcategories
let catIds =
ordered
|> Seq.filter (fun cat -> cat.parentNames |> Array.contains it.name)
|> Seq.map (fun cat -> cat.id :> obj)
|> Seq.append (Seq.singleton it.id)
|> List.ofSeq
let count =
Collection.Post.Count (fun p ->
p.webLogId = webLogId
&& p.status = Published
&& p.categoryIds |> List.exists (fun cId -> catIds |> List.contains cId))
return it.id, count
})
|> Task.WhenAll
return
ordered
|> Seq.map (fun cat ->
{ cat with
postCount = counts
|> Array.tryFind (fun c -> fst c = cat.id)
|> Option.map snd
|> Option.defaultValue 0
})
|> Array.ofSeq
}
member _.findById catId webLogId =
Collection.Category.FindById (CategoryIdMapping.toBson catId)
|> verifyWebLog webLogId (fun c -> c.webLogId)
member this.delete catId webLogId = backgroundTask {
match! this.findById catId webLogId with
| Some _ ->
// Delete the category off all posts where it is assigned
Collection.Post.Find (fun p -> p.webLogId = webLogId && p.categoryIds |> List.contains catId)
|> Seq.map (fun p ->
{ p with categoryIds = p.categoryIds |> List.filter (fun cId -> cId <> catId) })
|> Collection.Post.Update
|> ignore
// Delete the category itself
let _ = Collection.Category.Delete (CategoryIdMapping.toBson catId)
do! checkpoint ()
return true
| None -> return false
}
member _.update cat = backgroundTask {
let _ = Collection.Category.Update cat
do! checkpoint ()
}
}
member _.Page = {
new IPageData with
member _.add page = backgroundTask {
let _ = Collection.Page.Insert page
do! checkpoint ()
}
member _.all webLogId =
Collection.Page.Find (fun p -> p.webLogId = webLogId)
|> Seq.map pageWithoutText
|> Seq.sortBy pageSort
|> toList
member _.countAll webLogId =
Collection.Page.Count (fun p -> p.webLogId = webLogId)
|> Task.FromResult
member _.countListed webLogId =
Collection.Page.Count (fun p -> p.webLogId = webLogId && p.showInPageList)
|> Task.FromResult
member _.findFullById pageId webLogId =
Collection.Page.FindById (PageIdMapping.toBson pageId)
|> verifyWebLog webLogId (fun it -> it.webLogId)
member this.findById pageId webLogId = backgroundTask {
let! page = this.findFullById pageId webLogId
return page |> Option.map pageWithoutRevisions
}
member this.delete pageId webLogId = backgroundTask {
match! this.findById pageId webLogId with
| Some _ ->
let _ = Collection.Page.Delete (PageIdMapping.toBson pageId)
do! checkpoint ()
return true
| None -> return false
}
member _.findByPermalink permalink webLogId = backgroundTask {
let! page =
Collection.Page.Find (fun p -> p.webLogId = webLogId && p.permalink = permalink)
|> tryFirst
return page |> Option.map pageWithoutRevisions
}
member _.findCurrentPermalink permalinks webLogId = backgroundTask {
let! result =
Collection.Page.Find (fun p ->
p.webLogId = webLogId
&& p.priorPermalinks |> List.exists (fun link -> permalinks |> List.contains link))
|> tryFirst
return result |> Option.map (fun pg -> pg.permalink)
}
member _.findListed webLogId =
Collection.Page.Find (fun p -> p.webLogId = webLogId && p.showInPageList)
|> Seq.map pageWithoutText
|> Seq.sortBy pageSort
|> toList
member _.findPageOfPages webLogId pageNbr =
Collection.Page.Find (fun p -> p.webLogId = webLogId)
|> Seq.map pageWithoutRevisions
|> Seq.sortBy pageSort
|> toPagedList pageNbr 25
/// Update a page
member _.update page = backgroundTask {
let _ = Collection.Page.Update page
do! checkpoint ()
}
/// Update prior permalinks for a page
member this.updatePriorPermalinks pageId webLogId permalinks = backgroundTask {
match! this.findFullById pageId webLogId with
| Some page ->
do! this.update { page with priorPermalinks = permalinks }
return true
| None -> return false
}
}
member _.Post = {
new IPostData with
member _.add post = backgroundTask {
let _ = Collection.Post.Insert post
do! checkpoint ()
}
member _.countByStatus status webLogId =
Collection.Post.Count (fun p -> p.webLogId = webLogId && p.status = status)
|> Task.FromResult
member _.findByPermalink permalink webLogId =
Collection.Post.Find (fun p -> p.webLogId = webLogId && p.permalink = permalink)
|> tryFirst
member _.findFullById postId webLogId =
Collection.Post.FindById (PostIdMapping.toBson postId)
|> verifyWebLog webLogId (fun p -> p.webLogId)
member this.delete postId webLogId = backgroundTask {
match! this.findFullById postId webLogId with
| Some _ ->
let _ = Collection.Post.Delete (PostIdMapping.toBson postId)
do! checkpoint ()
return true
| None -> return false
}
member _.findCurrentPermalink permalinks webLogId = backgroundTask {
let! result =
Collection.Post.Find (fun p ->
p.webLogId = webLogId
&& p.priorPermalinks |> List.exists (fun link -> permalinks |> List.contains link))
|> tryFirst
return result |> Option.map (fun post -> post.permalink)
}
member _.findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage =
Collection.Post.Find (fun p ->
p.webLogId = webLogId
&& p.status = Published
&& p.categoryIds |> List.exists (fun cId -> categoryIds |> List.contains cId))
|> Seq.map postWithoutRevisions
|> Seq.sortByDescending (fun p -> p.publishedOn)
|> toPagedList pageNbr postsPerPage
member _.findPageOfPosts webLogId pageNbr postsPerPage =
Collection.Post.Find (fun p -> p.webLogId = webLogId)
|> Seq.map postWithoutText
|> Seq.sortByDescending (fun p -> defaultArg p.publishedOn p.updatedOn)
|> toPagedList pageNbr postsPerPage
member _.findPageOfPublishedPosts webLogId pageNbr postsPerPage =
Collection.Post.Find (fun p -> p.webLogId = webLogId && p.status = Published)
|> Seq.map postWithoutRevisions
|> Seq.sortByDescending (fun p -> p.publishedOn)
|> toPagedList pageNbr postsPerPage
member _.findPageOfTaggedPosts webLogId tag pageNbr postsPerPage =
Collection.Post.Find (fun p ->
p.webLogId = webLogId && p.status = Published && p.tags |> List.contains tag)
|> Seq.map postWithoutRevisions
|> Seq.sortByDescending (fun p -> p.publishedOn)
|> toPagedList pageNbr postsPerPage
member _.findSurroundingPosts webLogId publishedOn = backgroundTask {
let! older =
Collection.Post.Find (fun p ->
p.webLogId = webLogId && p.status = Published && p.publishedOn.Value < publishedOn)
|> Seq.map postWithoutText
|> Seq.sortByDescending (fun p -> p.publishedOn)
|> tryFirst
let! newer =
Collection.Post.Find (fun p ->
p.webLogId = webLogId && p.status = Published && p.publishedOn.Value > publishedOn)
|> Seq.map postWithoutText
|> Seq.sortBy (fun p -> p.publishedOn)
|> tryFirst
return older, newer
}
member _.update post = backgroundTask {
let _ = Collection.Post.Update post
do! checkpoint ()
}
member this.updatePriorPermalinks postId webLogId permalinks = backgroundTask {
match! this.findFullById postId webLogId with
| Some post ->
do! this.update { post with priorPermalinks = permalinks }
return true
| None -> return false
}
}
member _.TagMap = {
new ITagMapData with
member _.all webLogId =
Collection.TagMap.Find (fun tm -> tm.webLogId = webLogId)
|> Seq.sortBy (fun tm -> tm.tag)
|> toList
member _.findById tagMapId webLogId =
Collection.TagMap.FindById (TagMapIdMapping.toBson tagMapId)
|> verifyWebLog webLogId (fun tm -> tm.webLogId)
member this.delete tagMapId webLogId = backgroundTask {
match! this.findById tagMapId webLogId with
| Some _ ->
let _ = Collection.TagMap.Delete (TagMapIdMapping.toBson tagMapId)
do! checkpoint ()
return true
| None -> return false
}
member _.findByUrlValue urlValue webLogId =
Collection.TagMap.Find (fun tm -> tm.webLogId = webLogId && tm.urlValue = urlValue)
|> tryFirst
member _.findMappingForTags tags webLogId =
Collection.TagMap.Find (fun tm -> tm.webLogId = webLogId && tags |> List.contains tm.tag)
|> toList
member _.save tagMap = backgroundTask {
let _ = Collection.TagMap.Upsert tagMap
do! checkpoint ()
}
}
member _.Theme = {
new IThemeData with
member _.all () =
Collection.Theme.Find (fun t -> t.id <> ThemeId "admin")
|> Seq.map (fun t -> { t with templates = [] })
|> Seq.sortBy (fun t -> t.id)
|> toList
member _.findById themeId =
Collection.Theme.FindById (ThemeIdMapping.toBson themeId)
|> toOption
member this.findByIdWithoutText themeId = backgroundTask {
match! this.findById themeId with
| Some theme ->
return Some {
theme with templates = theme.templates |> List.map (fun t -> { t with text = "" })
}
| None -> return None
}
member _.save theme = backgroundTask {
let _ = Collection.Theme.Upsert theme
do! checkpoint ()
}
}
member _.ThemeAsset = {
new IThemeAssetData with
member _.all () =
Collection.ThemeAsset.FindAll ()
|> Seq.map (fun ta -> { ta with data = [||] })
|> toList
member _.deleteByTheme themeId = backgroundTask {
let _ = Collection.ThemeAsset.DeleteMany (fun ta ->
(ThemeAssetId.toString ta.id).StartsWith (ThemeId.toString themeId))
do! checkpoint ()
}
member _.findById assetId =
Collection.ThemeAsset.FindById (ThemeAssetIdMapping.toBson assetId)
|> toOption
member _.findByTheme themeId =
Collection.ThemeAsset.Find (fun ta ->
(ThemeAssetId.toString ta.id).StartsWith (ThemeId.toString themeId))
|> Seq.map (fun ta -> { ta with data = [||] })
|> toList
member _.save asset = backgroundTask {
let _ = Collection.ThemeAsset.Upsert asset
do! checkpoint ()
}
}
member _.WebLog = {
new IWebLogData with
member _.add webLog = backgroundTask {
let _ = Collection.WebLog.Insert webLog
do! checkpoint ()
}
member _.all () =
Collection.WebLog.FindAll ()
|> toList
member _.findByHost url =
Collection.WebLog.Find (fun wl -> wl.urlBase = url)
|> tryFirst
member _.findById webLogId =
Collection.WebLog.FindById (WebLogIdMapping.toBson webLogId)
|> toOption
member _.updateSettings webLog = backgroundTask {
let _ = Collection.WebLog.Update webLog
do! checkpoint ()
}
member this.updateRssOptions webLog = backgroundTask {
match! this.findById webLog.id with
| Some wl -> do! this.updateSettings { wl with rss = webLog.rss }
| None -> ()
}
}
member _.WebLogUser = {
new IWebLogUserData with
member _.add user = backgroundTask {
let _ = Collection.WebLogUser.Insert user
do! checkpoint ()
}
member _.findByEmail email webLogId =
Collection.WebLogUser.Find (fun wlu -> wlu.webLogId = webLogId && wlu.userName = email)
|> tryFirst
member _.findById userId webLogId =
Collection.WebLogUser.FindById (WebLogUserIdMapping.toBson userId)
|> verifyWebLog webLogId (fun u -> u.webLogId)
member _.findNames webLogId userIds =
Collection.WebLogUser.Find (fun wlu -> userIds |> List.contains wlu.id)
|> Seq.map (fun u -> { name = WebLogUserId.toString u.id; value = WebLogUser.displayName u })
|> toList
member _.update user = backgroundTask {
let _ = Collection.WebLogUser.Update user
do! checkpoint ()
}
}
member _.startUp () = backgroundTask {
let _ = Collection.Category.EnsureIndex (fun c -> c.webLogId)
let _ = Collection.Comment.EnsureIndex (fun c -> c.postId)
let _ = Collection.Page.EnsureIndex (fun p -> p.webLogId)
let _ = Collection.Page.EnsureIndex (fun p -> p.authorId)
let _ = Collection.Post.EnsureIndex (fun p -> p.webLogId)
let _ = Collection.Post.EnsureIndex (fun p -> p.authorId)
let _ = Collection.TagMap.EnsureIndex (fun tm -> tm.webLogId)
let _ = Collection.WebLog.EnsureIndex (fun wl -> wl.urlBase)
let _ = Collection.WebLogUser.EnsureIndex (fun wlu -> wlu.webLogId)
do! checkpoint ()
}

6
src/MyWebLog.Data/MyWebLog.Data.fsproj
View File

@ -10,6 +10,7 @@
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
<PackageReference Include="LiteDB" Version="5.0.11" />
<PackageReference Include="Microsoft.Extensions.Configuration.Abstractions" Version="6.0.0" /> <PackageReference Include="Microsoft.Extensions.Configuration.Abstractions" Version="6.0.0" />
<PackageReference Include="Microsoft.FSharpLu.Json" Version="0.11.7" /> <PackageReference Include="Microsoft.FSharpLu.Json" Version="0.11.7" />
<PackageReference Include="Newtonsoft.Json" Version="13.0.1" /> <PackageReference Include="Newtonsoft.Json" Version="13.0.1" />
@ -20,7 +21,10 @@
<ItemGroup> <ItemGroup>
<Compile Include="Converters.fs" /> <Compile Include="Converters.fs" />
<Compile Include="Data.fs" /> <Compile Include="Interfaces.fs" />
<Compile Include="Utils.fs" />
<Compile Include="RethinkDbData.fs" />
<Compile Include="LiteDbData.fs" />
</ItemGroup> </ItemGroup>
</Project> </Project>

790
src/MyWebLog.Data/RethinkDbData.fs Normal file
View File

@ -0,0 +1,790 @@
namespace MyWebLog.Data
open System.Threading.Tasks
open MyWebLog
open RethinkDb.Driver
/// Functions to assist with retrieving data
[<AutoOpen>]
module private RethinkHelpers =
/// Table names
[<RequireQualifiedAccess>]
module Table =
/// The category table
let Category = "Category"
/// The comment table
let Comment = "Comment"
/// The page table
let Page = "Page"
/// The post table
let Post = "Post"
/// The tag map table
let TagMap = "TagMap"
/// The theme table
let Theme = "Theme"
/// The theme asset table
let ThemeAsset = "ThemeAsset"
/// The web log table
let WebLog = "WebLog"
/// The web log user table
let WebLogUser = "WebLogUser"
/// A list of all tables
let all = [ Category; Comment; Page; Post; TagMap; Theme; ThemeAsset; WebLog; WebLogUser ]
/// Shorthand for the ReQL starting point
let r = RethinkDB.R
/// Verify that the web log ID matches before returning an item
let verifyWebLog<'T> webLogId (prop : 'T -> WebLogId) (f : Net.IConnection -> Task<'T option>) =
fun conn -> backgroundTask {
match! f conn with Some it when (prop it) = webLogId -> return Some it | _ -> return None
}
/// Get the first item from a list, or None if the list is empty
let tryFirst<'T> (f : Net.IConnection -> Task<'T list>) =
fun conn -> backgroundTask {
let! results = f conn
return results |> List.tryHead
}
/// Cast a strongly-typed list to an object list
let objList<'T> (objects : 'T list) = objects |> List.map (fun it -> it :> obj)
open Microsoft.Extensions.Logging
open MyWebLog.ViewModels
open RethinkDb.Driver.FSharp
/// RethinkDB implementation of data functions for myWebLog
type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<RethinkDbData>) =
/// Match theme asset IDs by their prefix (the theme ID)
let matchAssetByThemeId themeId =
let keyPrefix = $"^{ThemeId.toString themeId}/"
fun (row : Ast.ReqlExpr) -> row["id"].Match keyPrefix :> obj
/// Ensure field indexes exist, as well as special indexes for selected tables
let ensureIndexes table fields = backgroundTask {
let! indexes = rethink<string list> { withTable table; indexList; result; withRetryOnce conn }
for field in fields do
if not (indexes |> List.contains field) then
log.LogInformation $"Creating index {table}.{field}..."
do! rethink { withTable table; indexCreate field; write; withRetryOnce; ignoreResult conn }
// Post and page need index by web log ID and permalink
if [ Table.Page; Table.Post ] |> List.contains table then
if not (indexes |> List.contains "permalink") then
log.LogInformation $"Creating index {table}.permalink..."
do! rethink {
withTable table
indexCreate "permalink" (fun row -> r.Array (row["webLogId"], row["permalink"].Downcase ()) :> obj)
write; withRetryOnce; ignoreResult conn
}
// Prior permalinks are searched when a post or page permalink do not match the current URL
if not (indexes |> List.contains "priorPermalinks") then
log.LogInformation $"Creating index {table}.priorPermalinks..."
do! rethink {
withTable table
indexCreate "priorPermalinks" (fun row -> row["priorPermalinks"].Downcase () :> obj) [ Multi ]
write; withRetryOnce; ignoreResult conn
}
// Post needs indexes by category and tag (used for counting and retrieving posts)
if Table.Post = table then
for idx in [ "categoryIds"; "tags" ] do
if not (List.contains idx indexes) then
log.LogInformation $"Creating index {table}.{idx}..."
do! rethink {
withTable table
indexCreate idx [ Multi ]
write; withRetryOnce; ignoreResult conn
}
// Tag mapping needs an index by web log ID and both tag and URL values
if Table.TagMap = table then
if not (indexes |> List.contains "webLogAndTag") then
log.LogInformation $"Creating index {table}.webLogAndTag..."
do! rethink {
withTable table
indexCreate "webLogAndTag" (fun row -> r.Array (row["webLogId"], row["tag"]) :> obj)
write; withRetryOnce; ignoreResult conn
}
if not (indexes |> List.contains "webLogAndUrl") then
log.LogInformation $"Creating index {table}.webLogAndUrl..."
do! rethink {
withTable table
indexCreate "webLogAndUrl" (fun row -> r.Array (row["webLogId"], row["urlValue"]) :> obj)
write; withRetryOnce; ignoreResult conn
}
// Users log on with e-mail
if Table.WebLogUser = table && not (indexes |> List.contains "logOn") then
log.LogInformation $"Creating index {table}.logOn..."
do! rethink {
withTable table
indexCreate "logOn" (fun row -> r.Array (row["webLogId"], row["userName"]) :> obj)
write; withRetryOnce; ignoreResult conn
}
}
/// The connection for this instance
member _.Conn = conn
interface IData with
member _.Category = {
new ICategoryData with
member _.add cat = rethink {
withTable Table.Category
insert cat
write; withRetryDefault; ignoreResult conn
}
member _.countAll webLogId = rethink<int> {
withTable Table.Category
getAll [ webLogId ] (nameof webLogId)
count
result; withRetryDefault conn
}
member _.countTopLevel webLogId = rethink<int> {
withTable Table.Category
getAll [ webLogId ] (nameof webLogId)
filter "parentId" None
count
result; withRetryDefault conn
}
member _.findAllForView webLogId = backgroundTask {
let! cats = rethink<Category list> {
withTable Table.Category
getAll [ webLogId ] (nameof webLogId)
orderByFunc (fun it -> it["name"].Downcase () :> obj)
result; withRetryDefault conn
}
let ordered = Utils.orderByHierarchy cats None None []
let! counts =
ordered
|> Seq.map (fun it -> backgroundTask {
// Parent category post counts include posts in subcategories
let catIds =
ordered
|> Seq.filter (fun cat -> cat.parentNames |> Array.contains it.name)
|> Seq.map (fun cat -> cat.id :> obj)
|> Seq.append (Seq.singleton it.id)
|> List.ofSeq
let! count = rethink<int> {
withTable Table.Post
getAll catIds "categoryIds"
filter "status" Published
distinct
count
result; withRetryDefault conn
}
return it.id, count
})
|> Task.WhenAll
return
ordered
|> Seq.map (fun cat ->
{ cat with
postCount = counts
|> Array.tryFind (fun c -> fst c = cat.id)
|> Option.map snd
|> Option.defaultValue 0
})
|> Array.ofSeq
}
member _.findById catId webLogId =
rethink<Category> {
withTable Table.Category
get catId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun c -> c.webLogId) <| conn
member this.delete catId webLogId = backgroundTask {
match! this.findById catId webLogId with
| Some _ ->
// Delete the category off all posts where it is assigned
do! rethink {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
filter (fun row -> row["categoryIds"].Contains catId :> obj)
update (fun row -> r.HashMap ("categoryIds", r.Array(row["categoryIds"]).Remove catId) :> obj)
write; withRetryDefault; ignoreResult conn
}
// Delete the category itself
do! rethink {
withTable Table.Category
get catId
delete
write; withRetryDefault; ignoreResult conn
}
return true
| None -> return false
}
member _.update cat = rethink {
withTable Table.Category
get cat.id
update [ "name", cat.name :> obj
"slug", cat.slug
"description", cat.description
"parentId", cat.parentId
]
write; withRetryDefault; ignoreResult conn
}
}
member _.Page = {
new IPageData with
member _.add page = rethink {
withTable Table.Page
insert page
write; withRetryDefault; ignoreResult conn
}
member _.all webLogId = rethink<Page list> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
without [ "text"; "revisions"; "priorPermalinks" ]
orderByFunc (fun row -> row["title"].Downcase () :> obj)
result; withRetryDefault conn
}
member _.countAll webLogId = rethink<int> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
count
result; withRetryDefault conn
}
member _.countListed webLogId = rethink<int> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
filter "showInPageList" true
count
result; withRetryDefault conn
}
member _.delete pageId webLogId = backgroundTask {
let! result = rethink<Model.Result> {
withTable Table.Page
getAll [ pageId ]
filter (fun row -> row["webLogId"].Eq webLogId :> obj)
delete
write; withRetryDefault conn
}
return result.Deleted > 0UL
}
member _.findFullById pageId webLogId =
rethink<Page> {
withTable Table.Page
get pageId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun it -> it.webLogId) <| conn
member _.findById pageId webLogId =
rethink<Page> {
withTable Table.Page
get pageId
without [ "priorPermalinks"; "revisions" ]
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun it -> it.webLogId) <| conn
member _.findByPermalink permalink webLogId =
rethink<Page list> {
withTable Table.Page
getAll [ r.Array (webLogId, permalink) ] (nameof permalink)
without [ "priorPermalinks"; "revisions" ]
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
member _.findCurrentPermalink permalinks webLogId = backgroundTask {
let! result =
(rethink<Page list> {
withTable Table.Page
getAll (objList permalinks) "priorPermalinks"
filter "webLogId" webLogId
without [ "revisions"; "text" ]
limit 1
result; withRetryDefault
}
|> tryFirst) conn
return result |> Option.map (fun pg -> pg.permalink)
}
member _.findListed webLogId = rethink<Page list> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
filter [ "showInPageList", true :> obj ]
without [ "text"; "priorPermalinks"; "revisions" ]
orderBy "title"
result; withRetryDefault conn
}
member _.findPageOfPages webLogId pageNbr = rethink<Page list> {
withTable Table.Page
getAll [ webLogId ] (nameof webLogId)
without [ "priorPermalinks"; "revisions" ]
orderByFunc (fun row -> row["title"].Downcase ())
skip ((pageNbr - 1) * 25)
limit 25
result; withRetryDefault conn
}
/// Update a page
member _.update page = rethink {
withTable Table.Page
get page.id
update [
"title", page.title :> obj
"permalink", page.permalink
"updatedOn", page.updatedOn
"showInPageList", page.showInPageList
"template", page.template
"text", page.text
"priorPermalinks", page.priorPermalinks
"metadata", page.metadata
"revisions", page.revisions
]
write; withRetryDefault; ignoreResult conn
}
/// Update prior permalinks for a page
member this.updatePriorPermalinks pageId webLogId permalinks = backgroundTask {
match! this.findById pageId webLogId with
| Some _ ->
do! rethink {
withTable Table.Page
get pageId
update [ "priorPermalinks", permalinks :> obj ]
write; withRetryDefault; ignoreResult conn
}
return true
| None -> return false
}
}
member _.Post = {
new IPostData with
member _.add post = rethink {
withTable Table.Post
insert post
write; withRetryDefault; ignoreResult conn
}
member _.countByStatus status webLogId = rethink<int> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
filter "status" status
count
result; withRetryDefault conn
}
member _.delete postId webLogId = backgroundTask {
let! result = rethink<Model.Result> {
withTable Table.Post
getAll [ postId ]
filter (fun row -> row["webLogId"].Eq webLogId :> obj)
delete
write; withRetryDefault conn
}
return result.Deleted > 0UL
}
member _.findByPermalink permalink webLogId =
rethink<Post list> {
withTable Table.Post
getAll [ r.Array (webLogId, permalink) ] (nameof permalink)
without [ "priorPermalinks"; "revisions" ]
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
member _.findFullById postId webLogId =
rethink<Post> {
withTable Table.Post
get postId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun p -> p.webLogId) <| conn
member _.findCurrentPermalink permalinks webLogId = backgroundTask {
let! result =
(rethink<Post list> {
withTable Table.Post
getAll (objList permalinks) "priorPermalinks"
filter "webLogId" webLogId
without [ "revisions"; "text" ]
limit 1
result; withRetryDefault
}
|> tryFirst) conn
return result |> Option.map (fun post -> post.permalink)
}
member _.findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage = rethink<Post list> {
withTable Table.Post
getAll (objList categoryIds) "categoryIds"
filter "webLogId" webLogId
filter "status" Published
without [ "priorPermalinks"; "revisions" ]
distinct
orderByDescending "publishedOn"
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault conn
}
member _.findPageOfPosts webLogId pageNbr postsPerPage = rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
without [ "priorPermalinks"; "revisions" ]
orderByFuncDescending (fun row -> row["publishedOn"].Default_ "updatedOn" :> obj)
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault conn
}
member _.findPageOfPublishedPosts webLogId pageNbr postsPerPage = rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
filter "status" Published
without [ "priorPermalinks"; "revisions" ]
orderByDescending "publishedOn"
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault conn
}
member _.findPageOfTaggedPosts webLogId tag pageNbr postsPerPage = rethink<Post list> {
withTable Table.Post
getAll [ tag ] "tags"
filter "webLogId" webLogId
filter "status" Published
without [ "priorPermalinks"; "revisions" ]
orderByDescending "publishedOn"
skip ((pageNbr - 1) * postsPerPage)
limit (postsPerPage + 1)
result; withRetryDefault conn
}
member _.findSurroundingPosts webLogId publishedOn = backgroundTask {
let! older =
rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
filter (fun row -> row["publishedOn"].Lt publishedOn :> obj)
without [ "priorPermalinks"; "revisions" ]
orderByDescending "publishedOn"
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
let! newer =
rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof webLogId)
filter (fun row -> row["publishedOn"].Gt publishedOn :> obj)
without [ "priorPermalinks"; "revisions" ]
orderBy "publishedOn"
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
return older, newer
}
member _.update post = rethink {
withTable Table.Post
get post.id
replace post
write; withRetryDefault; ignoreResult conn
}
member _.updatePriorPermalinks postId webLogId permalinks = backgroundTask {
match! (
rethink<Post> {
withTable Table.Post
get postId
without [ "revisions"; "priorPermalinks" ]
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun p -> p.webLogId)) conn with
| Some _ ->
do! rethink {
withTable Table.Post
get postId
update [ "priorPermalinks", permalinks :> obj ]
write; withRetryDefault; ignoreResult conn
}
return true
| None -> return false
}
}
member _.TagMap = {
new ITagMapData with
member _.all webLogId = rethink<TagMap list> {
withTable Table.TagMap
between (r.Array (webLogId, r.Minval ())) (r.Array (webLogId, r.Maxval ())) [ Index "webLogAndTag" ]
orderBy "tag"
result; withRetryDefault conn
}
member _.delete tagMapId webLogId = backgroundTask {
let! result = rethink<Model.Result> {
withTable Table.TagMap
getAll [ tagMapId ]
filter (fun row -> row["webLogId"].Eq webLogId :> obj)
delete
write; withRetryDefault conn
}
return result.Deleted > 0UL
}
member _.findById tagMapId webLogId =
rethink<TagMap> {
withTable Table.TagMap
get tagMapId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun tm -> tm.webLogId) <| conn
member _.findByUrlValue urlValue webLogId =
rethink<TagMap list> {
withTable Table.TagMap
getAll [ r.Array (webLogId, urlValue) ] "webLogAndUrl"
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
member _.findMappingForTags tags webLogId = rethink<TagMap list> {
withTable Table.TagMap
getAll (tags |> List.map (fun tag -> r.Array (webLogId, tag) :> obj)) "webLogAndTag"
result; withRetryDefault conn
}
member _.save tagMap = rethink {
withTable Table.TagMap
get tagMap.id
replace tagMap
write; withRetryDefault; ignoreResult conn
}
}
member _.Theme = {
new IThemeData with
member _.all () = rethink<Theme list> {
withTable Table.Theme
filter (fun row -> row["id"].Ne "admin" :> obj)
without [ "templates" ]
orderBy "id"
result; withRetryDefault conn
}
member _.findById themeId = rethink<Theme> {
withTable Table.Theme
get themeId
resultOption; withRetryOptionDefault conn
}
member _.findByIdWithoutText themeId = rethink<Theme> {
withTable Table.Theme
get themeId
merge (fun row -> r.HashMap ("templates", row["templates"].Without [| "text" |]))
resultOption; withRetryOptionDefault conn
}
member _.save theme = rethink {
withTable Table.Theme
get theme.id
replace theme
write; withRetryDefault; ignoreResult conn
}
}
member _.ThemeAsset = {
new IThemeAssetData with
member _.all () = rethink<ThemeAsset list> {
withTable Table.ThemeAsset
without [ "data" ]
result; withRetryDefault conn
}
member _.deleteByTheme themeId = rethink {
withTable Table.ThemeAsset
filter (matchAssetByThemeId themeId)
delete
write; withRetryDefault; ignoreResult conn
}
member _.findById assetId = rethink<ThemeAsset> {
withTable Table.ThemeAsset
get assetId
resultOption; withRetryOptionDefault conn
}
member _.findByTheme themeId = rethink<ThemeAsset list> {
withTable Table.ThemeAsset
filter (matchAssetByThemeId themeId)
without [ "data" ]
result; withRetryDefault conn
}
member _.save asset = rethink {
withTable Table.ThemeAsset
get asset.id
replace asset
write; withRetryDefault; ignoreResult conn
}
}
member _.WebLog = {
new IWebLogData with
member _.add webLog = rethink {
withTable Table.WebLog
insert webLog
write; withRetryOnce; ignoreResult conn
}
member _.all () = rethink<WebLog list> {
withTable Table.WebLog
result; withRetryDefault conn
}
member _.findByHost url =
rethink<WebLog list> {
withTable Table.WebLog
getAll [ url ] "urlBase"
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
member _.findById webLogId = rethink<WebLog> {
withTable Table.WebLog
get webLogId
resultOption; withRetryOptionDefault conn
}
member _.updateRssOptions webLog = rethink {
withTable Table.WebLog
get webLog.id
update [ "rss", webLog.rss :> obj ]
write; withRetryDefault; ignoreResult conn
}
member _.updateSettings webLog = rethink {
withTable Table.WebLog
get webLog.id
update [
"name", webLog.name :> obj
"subtitle", webLog.subtitle
"defaultPage", webLog.defaultPage
"postsPerPage", webLog.postsPerPage
"timeZone", webLog.timeZone
"themePath", webLog.themePath
"autoHtmx", webLog.autoHtmx
]
write; withRetryDefault; ignoreResult conn
}
}
member _.WebLogUser = {
new IWebLogUserData with
member _.add user = rethink {
withTable Table.WebLogUser
insert user
write; withRetryDefault; ignoreResult conn
}
member _.findByEmail email webLogId =
rethink<WebLogUser list> {
withTable Table.WebLogUser
getAll [ r.Array (webLogId, email) ] "logOn"
limit 1
result; withRetryDefault
}
|> tryFirst <| conn
member _.findById userId webLogId =
rethink<WebLogUser> {
withTable Table.WebLogUser
get userId
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId (fun u -> u.webLogId) <| conn
member _.findNames webLogId userIds = backgroundTask {
let! users = rethink<WebLogUser list> {
withTable Table.WebLogUser
getAll (objList userIds)
filter "webLogId" webLogId
result; withRetryDefault conn
}
return
users
|> List.map (fun u -> { name = WebLogUserId.toString u.id; value = WebLogUser.displayName u })
}
member _.update user = rethink {
withTable Table.WebLogUser
get user.id
update [
"firstName", user.firstName :> obj
"lastName", user.lastName
"preferredName", user.preferredName
"passwordHash", user.passwordHash
"salt", user.salt
]
write; withRetryDefault; ignoreResult conn
}
}
member _.startUp () = backgroundTask {
let! dbs = rethink<string list> { dbList; result; withRetryOnce conn }
if not (dbs |> List.contains config.Database) then
log.LogInformation($"Creating database {config.Database}...")
do! rethink { dbCreate config.Database; write; withRetryOnce; ignoreResult conn }
let! tables = rethink<string list> { tableList; result; withRetryOnce conn }
for tbl in Table.all do
if not (tables |> List.contains tbl) then
log.LogInformation($"Creating table {tbl}...")
do! rethink { tableCreate tbl; write; withRetryOnce; ignoreResult conn }
do! ensureIndexes Table.Category [ "webLogId" ]
do! ensureIndexes Table.Comment [ "postId" ]
do! ensureIndexes Table.Page [ "webLogId"; "authorId" ]
do! ensureIndexes Table.Post [ "webLogId"; "authorId" ]
do! ensureIndexes Table.TagMap []
do! ensureIndexes Table.WebLog [ "urlBase" ]
do! ensureIndexes Table.WebLogUser [ "webLogId" ]
}

22
src/MyWebLog.Data/Utils.fs Normal file
View File

@ -0,0 +1,22 @@
/// Utility functions for manipulating data
[<RequireQualifiedAccess>]
module internal MyWebLog.Data.Utils
open MyWebLog
open MyWebLog.ViewModels
/// Create a category hierarchy from the given list of categories
let rec orderByHierarchy (cats : Category list) parentId slugBase parentNames = seq {
for cat in cats |> List.filter (fun c -> c.parentId = parentId) do
let fullSlug = (match slugBase with Some it -> $"{it}/" | None -> "") + cat.slug
{ id = CategoryId.toString cat.id
slug = fullSlug
name = cat.name
description = cat.description
parentNames = Array.ofList parentNames
// Post counts are filled on a second pass
postCount = 0
}
yield! orderByHierarchy cats (Some cat.id) (Some fullSlug) ([ cat.name ] |> List.append parentNames)
}

26
src/MyWebLog/Caches.fs
View File

@ -1,20 +1,20 @@
namespace MyWebLog namespace MyWebLog
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
open MyWebLog.Data
/// Extension properties on HTTP context for web log /// Extension properties on HTTP context for web log
[<AutoOpen>] [<AutoOpen>]
module Extensions = module Extensions =
open Microsoft.Extensions.DependencyInjection open Microsoft.Extensions.DependencyInjection
open RethinkDb.Driver.Net
type HttpContext with type HttpContext with
/// The web log for the current request /// The web log for the current request
member this.WebLog = this.Items["webLog"] :?> WebLog member this.WebLog = this.Items["webLog"] :?> WebLog
/// The RethinkDB data connection /// The data implementation
member this.Conn = this.RequestServices.GetRequiredService<IConnection> () member this.Data = this.RequestServices.GetRequiredService<IData> ()
open System.Collections.Concurrent open System.Collections.Concurrent
@ -41,8 +41,8 @@ module WebLogCache =
_cache <- webLog :: (_cache |> List.filter (fun wl -> wl.id <> webLog.id)) _cache <- webLog :: (_cache |> List.filter (fun wl -> wl.id <> webLog.id))
/// Fill the web log cache from the database /// Fill the web log cache from the database
let fill conn = backgroundTask { let fill (data : IData) = backgroundTask {
let! webLogs = Data.WebLog.all conn let! webLogs = data.WebLog.all ()
_cache <- webLogs _cache <- webLogs
} }
@ -64,7 +64,7 @@ module PageListCache =
/// 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 webLog = ctx.WebLog let webLog = ctx.WebLog
let! pages = Data.Page.findListed webLog.id ctx.Conn let! pages = ctx.Data.Page.findListed webLog.id
_cache[webLog.urlBase] <- _cache[webLog.urlBase] <-
pages pages
|> List.map (fun pg -> DisplayPage.fromPage webLog { pg with text = "" }) |> List.map (fun pg -> DisplayPage.fromPage webLog { pg with text = "" })
@ -88,7 +88,7 @@ module CategoryCache =
/// Update the cache with fresh data /// Update the cache with fresh data
let update (ctx : HttpContext) = backgroundTask { let update (ctx : HttpContext) = backgroundTask {
let! cats = Data.Category.findAllForView ctx.WebLog.id ctx.Conn let! cats = ctx.Data.Category.findAllForView ctx.WebLog.id
_cache[ctx.WebLog.urlBase] <- cats _cache[ctx.WebLog.urlBase] <- cats
} }
@ -107,12 +107,12 @@ module TemplateCache =
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 : string) (templateName : string) conn = backgroundTask { let get (themeId : string) (templateName : string) (data : IData) = backgroundTask {
let templatePath = $"{themeId}/{templateName}" let templatePath = $"{themeId}/{templateName}"
match _cache.ContainsKey templatePath with match _cache.ContainsKey templatePath with
| true -> () | true -> ()
| false -> | false ->
match! Data.Theme.findById (ThemeId themeId) conn with match! data.Theme.findById (ThemeId themeId) with
| Some theme -> | Some theme ->
let mutable text = (theme.templates |> List.find (fun t -> t.name = templateName)).text let mutable text = (theme.templates |> List.find (fun t -> t.name = templateName)).text
while hasInclude.IsMatch text do while hasInclude.IsMatch text do
@ -142,14 +142,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 conn = backgroundTask { let refreshTheme themeId (data : IData) = backgroundTask {
let! assets = Data.ThemeAsset.findByThemeId themeId conn 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 conn = backgroundTask { let fill (data : IData) = backgroundTask {
let! assets = Data.ThemeAsset.all conn 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] <- []

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

@ -1,39 +1,26 @@
/// Handlers to manipulate admin functions /// Handlers to manipulate admin functions
module MyWebLog.Handlers.Admin module MyWebLog.Handlers.Admin
open System.Collections.Generic
open System.IO
/// The currently available themes
let private themes () =
Directory.EnumerateDirectories "themes"
|> Seq.map (fun it -> it.Split Path.DirectorySeparatorChar |> Array.last)
|> Seq.filter (fun it -> it <> "admin")
|> Seq.sort
|> Seq.map (fun it -> KeyValuePair.Create (it, it))
|> Array.ofSeq
open System.Threading.Tasks open System.Threading.Tasks
open DotLiquid open DotLiquid
open Giraffe open Giraffe
open MyWebLog open MyWebLog
open MyWebLog.ViewModels open MyWebLog.ViewModels
open RethinkDb.Driver.Net
// GET /admin // GET /admin
let dashboard : HttpHandler = fun next ctx -> task { let dashboard : HttpHandler = fun next ctx -> task {
let webLogId = ctx.WebLog.id let webLogId = ctx.WebLog.id
let conn = ctx.Conn let data = ctx.Data
let getCount (f : WebLogId -> IConnection -> Task<int>) = f webLogId conn let getCount (f : WebLogId -> Task<int>) = f webLogId
let! posts = Data.Post.countByStatus Published |> getCount let! posts = data.Post.countByStatus Published |> getCount
let! drafts = Data.Post.countByStatus Draft |> getCount let! drafts = data.Post.countByStatus Draft |> getCount
let! pages = Data.Page.countAll |> getCount let! pages = data.Page.countAll |> getCount
let! listed = Data.Page.countListed |> getCount let! listed = data.Page.countListed |> getCount
let! cats = Data.Category.countAll |> getCount let! cats = data.Category.countAll |> getCount
let! topCats = Data.Category.countTopLevel |> getCount let! topCats = data.Category.countTopLevel |> getCount
return! return!
Hash.FromAnonymousObject Hash.FromAnonymousObject {|
{| page_title = "Dashboard" page_title = "Dashboard"
model = model =
{ posts = posts { posts = posts
drafts = drafts drafts = drafts
@ -50,7 +37,7 @@ let dashboard : HttpHandler = fun next ctx -> task {
// GET /admin/categories // GET /admin/categories
let listCategories : HttpHandler = fun next ctx -> task { let listCategories : HttpHandler = fun next ctx -> task {
let! catListTemplate = TemplateCache.get "admin" "category-list-body" ctx.Conn let! catListTemplate = TemplateCache.get "admin" "category-list-body" ctx.Data
let hash = Hash.FromAnonymousObject {| let hash = Hash.FromAnonymousObject {|
web_log = ctx.WebLog web_log = ctx.WebLog
categories = CategoryCache.get ctx categories = CategoryCache.get ctx
@ -78,7 +65,7 @@ let editCategory catId : HttpHandler = fun next ctx -> 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! Data.Category.findById (CategoryId catId) ctx.WebLog.id ctx.Conn 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
} }
@ -98,12 +85,12 @@ let editCategory catId : HttpHandler = fun next ctx -> task {
// POST /admin/category/save // POST /admin/category/save
let saveCategory : HttpHandler = fun next ctx -> task { let saveCategory : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog let webLog = ctx.WebLog
let conn = ctx.Conn let data = ctx.Data
let! model = ctx.BindFormAsync<EditCategoryModel> () let! model = ctx.BindFormAsync<EditCategoryModel> ()
let! category = task { let! category = task {
match model.categoryId with match model.categoryId with
| "new" -> return Some { Category.empty with id = CategoryId.create (); webLogId = webLog.id } | "new" -> return Some { Category.empty with id = CategoryId.create (); webLogId = webLog.id }
| catId -> return! Data.Category.findById (CategoryId catId) webLog.id conn | catId -> return! data.Category.findById (CategoryId catId) webLog.id
} }
match category with match category with
| Some cat -> | Some cat ->
@ -114,7 +101,7 @@ let saveCategory : HttpHandler = fun next ctx -> task {
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! (match model.categoryId with "new" -> Data.Category.add | _ -> Data.Category.update) cat conn do! (match model.categoryId with "new" -> data.Category.add | _ -> data.Category.update) cat
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" }
return! listCategoriesBare next ctx return! listCategoriesBare next ctx
@ -123,8 +110,7 @@ let saveCategory : HttpHandler = fun next ctx -> task {
// POST /admin/category/{id}/delete // POST /admin/category/{id}/delete
let deleteCategory catId : HttpHandler = fun next ctx -> task { let deleteCategory catId : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog match! ctx.Data.Category.delete (CategoryId catId) ctx.WebLog.id with
match! Data.Category.delete (CategoryId catId) webLog.id ctx.Conn with
| true -> | true ->
do! CategoryCache.update ctx do! CategoryCache.update ctx
do! addMessage ctx { UserMessage.success with message = "Category deleted successfully" } do! addMessage ctx { UserMessage.success with message = "Category deleted successfully" }
@ -138,10 +124,10 @@ let deleteCategory catId : HttpHandler = fun next ctx -> task {
// GET /admin/pages/page/{pageNbr} // GET /admin/pages/page/{pageNbr}
let listPages pageNbr : HttpHandler = fun next ctx -> task { let listPages pageNbr : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog let webLog = ctx.WebLog
let! pages = Data.Page.findPageOfPages webLog.id pageNbr ctx.Conn let! pages = ctx.Data.Page.findPageOfPages webLog.id pageNbr
return! return!
Hash.FromAnonymousObject Hash.FromAnonymousObject {|
{| csrf = csrfToken ctx csrf = csrfToken ctx
pages = pages |> List.map (DisplayPage.fromPageMinimal webLog) pages = pages |> List.map (DisplayPage.fromPageMinimal webLog)
page_title = "Pages" page_title = "Pages"
page_nbr = pageNbr page_nbr = pageNbr
@ -157,7 +143,7 @@ let editPage pgId : HttpHandler = fun next ctx -> task {
match pgId with match pgId with
| "new" -> return Some ("Add a New Page", { Page.empty with id = PageId "new" }) | "new" -> return Some ("Add a New Page", { Page.empty with id = PageId "new" })
| _ -> | _ ->
match! Data.Page.findByFullId (PageId pgId) ctx.WebLog.id ctx.Conn with match! ctx.Data.Page.findFullById (PageId pgId) ctx.WebLog.id with
| Some page -> return Some ("Edit Page", page) | Some page -> return Some ("Edit Page", page)
| None -> return None | None -> return None
} }
@ -180,7 +166,7 @@ let editPage pgId : HttpHandler = fun next ctx -> task {
// GET /admin/page/{id}/permalinks // GET /admin/page/{id}/permalinks
let editPagePermalinks pgId : HttpHandler = fun next ctx -> task { let editPagePermalinks pgId : HttpHandler = fun next ctx -> task {
match! Data.Page.findByFullId (PageId pgId) ctx.WebLog.id ctx.Conn with match! ctx.Data.Page.findFullById (PageId pgId) ctx.WebLog.id with
| Some pg -> | Some pg ->
return! return!
Hash.FromAnonymousObject {| Hash.FromAnonymousObject {|
@ -197,7 +183,7 @@ let savePagePermalinks : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog let webLog = ctx.WebLog
let! model = ctx.BindFormAsync<ManagePermalinksModel> () let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
let links = model.prior |> Array.map Permalink |> List.ofArray let links = model.prior |> Array.map Permalink |> List.ofArray
match! Data.Page.updatePriorPermalinks (PageId model.id) webLog.id links ctx.Conn with match! ctx.Data.Page.updatePriorPermalinks (PageId model.id) webLog.id links with
| true -> | true ->
do! addMessage ctx { UserMessage.success with message = "Page permalinks saved successfully" } do! addMessage ctx { UserMessage.success with message = "Page permalinks saved successfully" }
return! redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/page/{model.id}/permalinks")) next ctx return! redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/page/{model.id}/permalinks")) next ctx
@ -207,7 +193,7 @@ let savePagePermalinks : HttpHandler = fun next ctx -> task {
// POST /admin/page/{id}/delete // POST /admin/page/{id}/delete
let deletePage pgId : HttpHandler = fun next ctx -> task { let deletePage pgId : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog let webLog = ctx.WebLog
match! Data.Page.delete (PageId pgId) webLog.id ctx.Conn with match! ctx.Data.Page.delete (PageId pgId) webLog.id with
| true -> | true ->
do! PageListCache.update ctx do! PageListCache.update ctx
do! addMessage ctx { UserMessage.success with message = "Page deleted successfully" } do! addMessage ctx { UserMessage.success with message = "Page deleted successfully" }
@ -223,7 +209,7 @@ open System
let savePage : HttpHandler = fun next ctx -> task { let savePage : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPageModel> () let! model = ctx.BindFormAsync<EditPageModel> ()
let webLog = ctx.WebLog let webLog = ctx.WebLog
let conn = ctx.Conn let data = ctx.Data
let now = DateTime.UtcNow let now = DateTime.UtcNow
let! pg = task { let! pg = task {
match model.pageId with match model.pageId with
@ -235,7 +221,7 @@ let savePage : HttpHandler = fun next ctx -> task {
authorId = userId ctx authorId = userId ctx
publishedOn = now publishedOn = now
} }
| pgId -> return! Data.Page.findByFullId (PageId pgId) webLog.id conn | pgId -> return! data.Page.findFullById (PageId pgId) webLog.id
} }
match pg with match pg with
| Some page -> | Some page ->
@ -264,7 +250,7 @@ let savePage : HttpHandler = fun next ctx -> task {
| Some r when r.text = revision.text -> page.revisions | Some r when r.text = revision.text -> page.revisions
| _ -> revision :: page.revisions | _ -> revision :: page.revisions
} }
do! (if model.pageId = "new" then Data.Page.add else Data.Page.update) page conn do! (if model.pageId = "new" then data.Page.add else data.Page.update) page
if updateList then do! PageListCache.update ctx if updateList then do! PageListCache.update ctx
do! addMessage ctx { UserMessage.success with message = "Page saved successfully" } do! addMessage ctx { UserMessage.success with message = "Page saved successfully" }
return! return!
@ -278,7 +264,7 @@ open Microsoft.AspNetCore.Http
/// Get the hash necessary to render the tag mapping list /// Get the hash necessary to render the tag mapping list
let private tagMappingHash (ctx : HttpContext) = task { let private tagMappingHash (ctx : HttpContext) = task {
let! mappings = Data.TagMap.findByWebLogId ctx.WebLog.id ctx.Conn let! mappings = ctx.Data.TagMap.all ctx.WebLog.id
return Hash.FromAnonymousObject {| return Hash.FromAnonymousObject {|
web_log = ctx.WebLog web_log = ctx.WebLog
csrf = csrfToken ctx csrf = csrfToken ctx
@ -290,7 +276,7 @@ let private tagMappingHash (ctx : HttpContext) = task {
// GET /admin/settings/tag-mappings // GET /admin/settings/tag-mappings
let tagMappings : HttpHandler = fun next ctx -> task { let tagMappings : HttpHandler = fun next ctx -> task {
let! hash = tagMappingHash ctx let! hash = tagMappingHash ctx
let! listTemplate = TemplateCache.get "admin" "tag-mapping-list-body" ctx.Conn let! listTemplate = TemplateCache.get "admin" "tag-mapping-list-body" ctx.Data
hash.Add ("tag_mapping_list", listTemplate.Render hash) hash.Add ("tag_mapping_list", listTemplate.Render hash)
hash.Add ("page_title", "Tag Mappings") hash.Add ("page_title", "Tag Mappings")
@ -311,12 +297,12 @@ let editMapping tagMapId : HttpHandler = fun next ctx -> task {
if isNew then if isNew then
Task.FromResult (Some { TagMap.empty with id = TagMapId "new" }) Task.FromResult (Some { TagMap.empty with id = TagMapId "new" })
else else
Data.TagMap.findById (TagMapId tagMapId) ctx.WebLog.id ctx.Conn ctx.Data.TagMap.findById (TagMapId tagMapId) ctx.WebLog.id
match! tagMap with match! tagMap with
| Some tm -> | Some tm ->
return! return!
Hash.FromAnonymousObject Hash.FromAnonymousObject {|
{| csrf = csrfToken ctx csrf = csrfToken ctx
model = EditTagMapModel.fromMapping tm model = EditTagMapModel.fromMapping tm
page_title = if isNew then "Add Tag Mapping" else $"Mapping for {tm.tag} Tag" page_title = if isNew then "Add Tag Mapping" else $"Mapping for {tm.tag} Tag"
|} |}
@ -326,17 +312,16 @@ let editMapping tagMapId : HttpHandler = fun next ctx -> task {
// POST /admin/settings/tag-mapping/save // POST /admin/settings/tag-mapping/save
let saveMapping : HttpHandler = fun next ctx -> task { let saveMapping : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog let data = ctx.Data
let conn = ctx.Conn
let! model = ctx.BindFormAsync<EditTagMapModel> () let! model = ctx.BindFormAsync<EditTagMapModel> ()
let tagMap = let tagMap =
if model.id = "new" then if model.id = "new" then
Task.FromResult (Some { TagMap.empty with id = TagMapId.create (); webLogId = webLog.id }) Task.FromResult (Some { TagMap.empty with id = TagMapId.create (); webLogId = ctx.WebLog.id })
else else
Data.TagMap.findById (TagMapId model.id) webLog.id conn data.TagMap.findById (TagMapId model.id) ctx.WebLog.id
match! tagMap with match! tagMap with
| Some tm -> | Some tm ->
do! Data.TagMap.save { tm with tag = model.tag.ToLower (); urlValue = model.urlValue.ToLower () } conn do! data.TagMap.save { tm with tag = model.tag.ToLower (); urlValue = model.urlValue.ToLower () }
do! addMessage ctx { UserMessage.success with message = "Tag mapping saved successfully" } do! addMessage ctx { UserMessage.success with message = "Tag mapping saved successfully" }
return! tagMappingsBare next ctx return! tagMappingsBare next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
@ -344,8 +329,7 @@ let saveMapping : HttpHandler = fun next ctx -> task {
// POST /admin/settings/tag-mapping/{id}/delete // POST /admin/settings/tag-mapping/{id}/delete
let deleteMapping tagMapId : HttpHandler = fun next ctx -> task { let deleteMapping tagMapId : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog match! ctx.Data.TagMap.delete (TagMapId tagMapId) ctx.WebLog.id with
match! Data.TagMap.delete (TagMapId tagMapId) webLog.id ctx.Conn with
| true -> do! addMessage ctx { UserMessage.success with message = "Tag mapping deleted successfully" } | true -> do! addMessage ctx { UserMessage.success with message = "Tag mapping deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with message = "Tag mapping not found; nothing deleted" } | false -> do! addMessage ctx { UserMessage.error with message = "Tag mapping not found; nothing deleted" }
return! tagMappingsBare next ctx return! tagMappingsBare next ctx
@ -353,8 +337,10 @@ let deleteMapping tagMapId : HttpHandler = fun next ctx -> task {
// -- THEMES -- // -- THEMES --
open System.IO
open System.IO.Compression open System.IO.Compression
open System.Text.RegularExpressions open System.Text.RegularExpressions
open MyWebLog.Data
// GET /admin/theme/update // GET /admin/theme/update
let themeUpdatePage : HttpHandler = fun next ctx -> task { let themeUpdatePage : HttpHandler = fun next ctx -> task {
@ -382,9 +368,9 @@ let private updateNameAndVersion (theme : Theme) (zip : ZipArchive) = background
} }
/// Delete all theme assets, and remove templates from theme /// Delete all theme assets, and remove templates from theme
let private checkForCleanLoad (theme : Theme) cleanLoad conn = backgroundTask { let private checkForCleanLoad (theme : Theme) cleanLoad (data : IData) = backgroundTask {
if cleanLoad then if cleanLoad then
do! Data.ThemeAsset.deleteByTheme theme.id conn do! data.ThemeAsset.deleteByTheme theme.id
return { theme with templates = [] } return { theme with templates = [] }
else else
return theme return theme
@ -409,38 +395,38 @@ let private updateTemplates (theme : Theme) (zip : ZipArchive) = backgroundTask
} }
/// Update theme assets from the ZIP archive /// Update theme assets from the ZIP archive
let private updateAssets themeId (zip : ZipArchive) conn = 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 (fun it -> it.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 = asset.LastWriteTime.DateTime updatedOn = asset.LastWriteTime.DateTime
data = stream.ToArray () data = stream.ToArray ()
} conn }
} }
/// Get the theme name from the file name given /// Get the theme name from the file name given
let getThemeName (fileName : string) = let getThemeName (fileName : string) =
let themeName = fileName.Split(".").[0].ToLowerInvariant().Replace (" ", "-") let themeName = fileName.Split(".").[0].ToLowerInvariant().Replace (" ", "-")
if Regex.IsMatch (themeName, """^[a-z0-9\-]+$""") then Some themeName else None if Regex.IsMatch (themeName, """^[a-z0-9\-]+$""") then Ok themeName else Error $"Theme name {fileName} is invalid"
/// 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 loadThemeFromZip themeName file clean conn = backgroundTask { let loadThemeFromZip themeName file clean (data : IData) = backgroundTask {
use zip = new ZipArchive (file, ZipArchiveMode.Read) use zip = new ZipArchive (file, ZipArchiveMode.Read)
let themeId = ThemeId themeName let themeId = ThemeId themeName
let! theme = backgroundTask { let! theme = backgroundTask {
match! Data.Theme.findById themeId conn with match! data.Theme.findById themeId with
| Some t -> return t | Some t -> return t
| None -> return { Theme.empty with id = themeId } | None -> return { Theme.empty with id = themeId }
} }
let! theme = updateNameAndVersion theme zip let! theme = updateNameAndVersion theme zip
let! theme = checkForCleanLoad theme clean conn let! theme = checkForCleanLoad theme clean data
let! theme = updateTemplates theme zip let! theme = updateTemplates theme zip
do! updateAssets themeId zip conn do! updateAssets themeId zip data
do! Data.Theme.save theme conn do! data.Theme.save theme
} }
// POST /admin/theme/update // POST /admin/theme/update
@ -448,17 +434,19 @@ let updateTheme : HttpHandler = fun next ctx -> task {
if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then
let themeFile = Seq.head ctx.Request.Form.Files let themeFile = Seq.head ctx.Request.Form.Files
match getThemeName themeFile.FileName with match getThemeName themeFile.FileName with
| Some themeName -> | Ok themeName when themeName <> "admin" ->
// TODO: add restriction for admin theme based on role let data = ctx.Data
let conn = ctx.Conn
use stream = new MemoryStream () use stream = new MemoryStream ()
do! themeFile.CopyToAsync stream do! themeFile.CopyToAsync stream
do! loadThemeFromZip themeName stream true conn do! loadThemeFromZip themeName stream true data
do! ThemeAssetCache.refreshTheme (ThemeId themeName) conn do! ThemeAssetCache.refreshTheme (ThemeId themeName) data
do! addMessage ctx { UserMessage.success with message = "Theme updated successfully" } do! addMessage ctx { UserMessage.success with message = "Theme updated successfully" }
return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/dashboard")) next ctx return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/dashboard")) next ctx
| None -> | Ok _ ->
do! addMessage ctx { UserMessage.error with message = $"Theme file name {themeFile.FileName} is invalid" } do! addMessage ctx { UserMessage.error with message = "You may not replace the admin theme" }
return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/theme/update")) next ctx
| Error message ->
do! addMessage ctx { UserMessage.error with message = message }
return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/theme/update")) next ctx return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/theme/update")) next ctx
else else
return! RequestErrors.BAD_REQUEST "Bad request" next ctx return! RequestErrors.BAD_REQUEST "Bad request" next ctx
@ -466,14 +454,17 @@ let updateTheme : HttpHandler = fun next ctx -> task {
// -- WEB LOG SETTINGS -- // -- WEB LOG SETTINGS --
open System.Collections.Generic
// GET /admin/settings // GET /admin/settings
let settings : HttpHandler = fun next ctx -> task { let settings : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog let webLog = ctx.WebLog
let! allPages = Data.Page.findAll webLog.id ctx.Conn let data = ctx.Data
let! themes = Data.Theme.list ctx.Conn let! allPages = data.Page.all webLog.id
let! themes = data.Theme.all ()
return! return!
Hash.FromAnonymousObject Hash.FromAnonymousObject {|
{| csrf = csrfToken ctx csrf = csrfToken ctx
model = SettingsModel.fromWebLog webLog model = SettingsModel.fromWebLog webLog
pages = pages =
seq { seq {
@ -485,7 +476,8 @@ let settings : HttpHandler = fun next ctx -> task {
|> Array.ofSeq |> Array.ofSeq
themes = themes themes = themes
|> Seq.ofList |> Seq.ofList
|> Seq.map (fun it -> KeyValuePair.Create (ThemeId.toString it.id, $"{it.name} (v{it.version})")) |> Seq.map (fun it ->
KeyValuePair.Create (ThemeId.toString it.id, $"{it.name} (v{it.version})"))
|> Array.ofSeq |> Array.ofSeq
web_log = webLog web_log = webLog
page_title = "Web Log Settings" page_title = "Web Log Settings"
@ -496,12 +488,12 @@ let settings : HttpHandler = fun next ctx -> task {
// POST /admin/settings // POST /admin/settings
let saveSettings : HttpHandler = fun next ctx -> task { let saveSettings : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog let webLog = ctx.WebLog
let conn = ctx.Conn let data = ctx.Data
let! model = ctx.BindFormAsync<SettingsModel> () let! model = ctx.BindFormAsync<SettingsModel> ()
match! Data.WebLog.findById webLog.id conn with match! data.WebLog.findById webLog.id with
| Some webLog -> | Some webLog ->
let webLog = model.update webLog let webLog = model.update webLog
do! Data.WebLog.updateSettings webLog conn do! data.WebLog.updateSettings webLog
// Update cache // Update cache
WebLogCache.set webLog WebLogCache.set webLog

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

@ -46,18 +46,19 @@ let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option =
None None
/// Determine the function to retrieve posts for the given feed /// Determine the function to retrieve posts for the given feed
let private getFeedPosts (webLog : WebLog) feedType ctx = let private getFeedPosts ctx feedType =
let childIds catId = let childIds catId =
let cat = CategoryCache.get ctx |> Array.find (fun c -> c.id = CategoryId.toString catId) let cat = CategoryCache.get ctx |> Array.find (fun c -> c.id = CategoryId.toString catId)
getCategoryIds cat.slug ctx getCategoryIds cat.slug ctx
let data = ctx.Data
match feedType with match feedType with
| StandardFeed _ -> Data.Post.findPageOfPublishedPosts webLog.id 1 | StandardFeed _ -> data.Post.findPageOfPublishedPosts ctx.WebLog.id 1
| CategoryFeed (catId, _) -> Data.Post.findPageOfCategorizedPosts webLog.id (childIds catId) 1 | CategoryFeed (catId, _) -> data.Post.findPageOfCategorizedPosts ctx.WebLog.id (childIds catId) 1
| TagFeed (tag, _) -> Data.Post.findPageOfTaggedPosts webLog.id tag 1 | TagFeed (tag, _) -> data.Post.findPageOfTaggedPosts ctx.WebLog.id tag 1
| Custom (feed, _) -> | Custom (feed, _) ->
match feed.source with match feed.source with
| Category catId -> Data.Post.findPageOfCategorizedPosts webLog.id (childIds catId) 1 | Category catId -> data.Post.findPageOfCategorizedPosts ctx.WebLog.id (childIds catId) 1
| Tag tag -> Data.Post.findPageOfTaggedPosts 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)*?>", "")
@ -304,9 +305,9 @@ let private setTitleAndDescription feedType (webLog : WebLog) (cats : DisplayCat
/// Create a feed with a known non-zero-length list of posts /// Create a feed with a known non-zero-length list of posts
let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backgroundTask { let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backgroundTask {
let webLog = ctx.WebLog let webLog = ctx.WebLog
let conn = ctx.Conn let data = ctx.Data
let! authors = getAuthors webLog posts conn let! authors = getAuthors webLog posts data
let! tagMaps = getTagMappings webLog posts conn let! tagMaps = getTagMappings webLog posts data
let cats = CategoryCache.get ctx let cats = CategoryCache.get ctx
let podcast = match feedType with Custom (feed, _) when Option.isSome feed.podcast -> Some feed | _ -> None let podcast = match feedType with Custom (feed, _) when Option.isSome feed.podcast -> Some feed | _ -> None
let self, link = selfAndLink webLog feedType ctx let self, link = selfAndLink webLog feedType ctx
@ -351,7 +352,7 @@ let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backg
// GET {any-prescribed-feed} // GET {any-prescribed-feed}
let generate (feedType : FeedType) postCount : HttpHandler = fun next ctx -> backgroundTask { let generate (feedType : FeedType) postCount : HttpHandler = fun next ctx -> backgroundTask {
match! getFeedPosts ctx.WebLog feedType ctx postCount ctx.Conn with match! getFeedPosts ctx feedType postCount with
| posts when List.length posts > 0 -> return! createFeed feedType posts next ctx | posts when List.length posts > 0 -> return! createFeed feedType posts next ctx
| _ -> return! Error.notFound next ctx | _ -> return! Error.notFound next ctx
} }
@ -378,12 +379,12 @@ let editSettings : HttpHandler = fun next ctx -> task {
// POST: /admin/rss/settings // POST: /admin/rss/settings
let saveSettings : HttpHandler = fun next ctx -> task { let saveSettings : HttpHandler = fun next ctx -> task {
let conn = ctx.Conn let data = ctx.Data
let! model = ctx.BindFormAsync<EditRssModel> () let! model = ctx.BindFormAsync<EditRssModel> ()
match! Data.WebLog.findById ctx.WebLog.id conn 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 }
do! Data.WebLog.updateRssOptions webLog conn do! data.WebLog.updateRssOptions webLog
WebLogCache.set webLog WebLogCache.set webLog
do! addMessage ctx { UserMessage.success with message = "RSS settings updated successfully" } do! addMessage ctx { UserMessage.success with message = "RSS settings updated successfully" }
return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/settings/rss")) next ctx return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/settings/rss")) next ctx
@ -410,8 +411,8 @@ let editCustomFeed feedId : HttpHandler = fun next ctx -> task {
// POST: /admin/rss/save // POST: /admin/rss/save
let saveCustomFeed : HttpHandler = fun next ctx -> task { let saveCustomFeed : HttpHandler = fun next ctx -> task {
let conn = ctx.Conn let data = ctx.Data
match! Data.WebLog.findById ctx.WebLog.id conn 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 =
@ -422,7 +423,7 @@ let saveCustomFeed : HttpHandler = fun next ctx -> task {
| 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 = { webLog.rss with customFeeds = feeds } }
do! Data.WebLog.updateRssOptions webLog conn do! data.WebLog.updateRssOptions webLog
WebLogCache.set webLog WebLogCache.set webLog
do! addMessage ctx { do! addMessage ctx {
UserMessage.success with UserMessage.success with
@ -436,8 +437,8 @@ let saveCustomFeed : HttpHandler = fun next ctx -> task {
// POST /admin/rss/{id}/delete // POST /admin/rss/{id}/delete
let deleteCustomFeed feedId : HttpHandler = fun next ctx -> task { let deleteCustomFeed feedId : HttpHandler = fun next ctx -> task {
let conn = ctx.Conn let data = ctx.Data
match! Data.WebLog.findById ctx.WebLog.id conn with match! data.WebLog.findById ctx.WebLog.id with
| 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
@ -448,7 +449,7 @@ let deleteCustomFeed feedId : HttpHandler = fun next ctx -> task {
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 conn 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" }
else else

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

@ -108,12 +108,12 @@ let viewForTheme theme template next ctx = fun (hash : Hash) -> task {
// the net effect is a "layout" capability similar to Razor or Pug // the net effect is a "layout" capability similar to Razor or Pug
// Render view content... // Render view content...
let! contentTemplate = TemplateCache.get theme template ctx.Conn let! contentTemplate = TemplateCache.get theme template ctx.Data
hash.Add ("content", contentTemplate.Render hash) hash.Add ("content", contentTemplate.Render hash)
// ...then render that content with its layout // ...then render that content with its layout
let isHtmx = ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh let isHtmx = ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh
let! layoutTemplate = TemplateCache.get theme (if isHtmx then "layout-partial" else "layout") ctx.Conn let! layoutTemplate = TemplateCache.get theme (if isHtmx then "layout-partial" else "layout") ctx.Data
return! htmlString (layoutTemplate.Render hash) next ctx return! htmlString (layoutTemplate.Render hash) next ctx
} }
@ -123,10 +123,10 @@ let bareForTheme theme template next ctx = fun (hash : Hash) -> task {
do! populateHash hash ctx do! populateHash hash ctx
// Bare templates are rendered with layout-bare // Bare templates are rendered with layout-bare
let! contentTemplate = TemplateCache.get theme template ctx.Conn let! contentTemplate = TemplateCache.get theme template ctx.Data
hash.Add ("content", contentTemplate.Render hash) hash.Add ("content", contentTemplate.Render hash)
let! layoutTemplate = TemplateCache.get theme "layout-bare" ctx.Conn let! layoutTemplate = TemplateCache.get theme "layout-bare" ctx.Data
// add messages as HTTP headers // add messages as HTTP headers
let messages = hash["messages"] :?> UserMessage[] let messages = hash["messages"] :?> UserMessage[]
@ -182,11 +182,11 @@ let validateCsrf : HttpHandler = fun next ctx -> task {
let requireUser : HttpHandler = requiresAuthentication Error.notAuthorized let requireUser : HttpHandler = requiresAuthentication Error.notAuthorized
open System.Collections.Generic open System.Collections.Generic
open System.IO 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! Data.Theme.findByIdWithoutText (ThemeId ctx.WebLog.themePath) ctx.Conn with match! ctx.Data.Theme.findByIdWithoutText (ThemeId ctx.WebLog.themePath) with
| Some theme -> | Some theme ->
return seq { return seq {
KeyValuePair.Create ("", $"- Default (single-{typ}) -") KeyValuePair.Create ("", $"- Default (single-{typ}) -")
@ -201,19 +201,19 @@ let templatesForTheme (ctx : HttpContext) (typ : string) = backgroundTask {
} }
/// 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) conn = let getAuthors (webLog : WebLog) (posts : Post list) (data : IData) =
posts posts
|> List.map (fun p -> p.authorId) |> List.map (fun p -> p.authorId)
|> List.distinct |> List.distinct
|> Data.WebLogUser.findNames webLog.id conn |> 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) = let getTagMappings (webLog : WebLog) (posts : Post list) (data : IData) =
posts posts
|> List.map (fun p -> p.tags) |> List.map (fun p -> p.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
/// Get all category IDs for the given slug (includes owned subcategories) /// Get all category IDs for the given slug (includes owned subcategories)
let getCategoryIds slug ctx = let getCategoryIds slug ctx =

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

@ -36,12 +36,13 @@ type ListType =
open System.Threading.Tasks open System.Threading.Tasks
open DotLiquid open DotLiquid
open MyWebLog.Data
open MyWebLog.ViewModels open MyWebLog.ViewModels
/// Convert a list of posts into items ready to be displayed /// Convert a list of posts into items ready to be displayed
let preparePostList webLog posts listType (url : string) pageNbr perPage ctx conn = task { let preparePostList webLog posts listType (url : string) pageNbr perPage ctx (data : IData) = task {
let! authors = getAuthors webLog posts conn let! authors = getAuthors webLog posts data
let! tagMappings = getTagMappings webLog posts conn let! tagMappings = getTagMappings webLog posts data
let relUrl it = Some <| WebLog.relativeUrl webLog (Permalink it) let relUrl it = Some <| WebLog.relativeUrl webLog (Permalink it)
let postItems = let postItems =
posts posts
@ -54,7 +55,7 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage ctx con
| SinglePost -> | SinglePost ->
let post = List.head posts let post = List.head posts
let dateTime = defaultArg post.publishedOn post.updatedOn let dateTime = defaultArg post.publishedOn post.updatedOn
Data.Post.findSurroundingPosts webLog.id dateTime conn data.Post.findSurroundingPosts webLog.id dateTime
| _ -> Task.FromResult (None, None) | _ -> Task.FromResult (None, None)
let newerLink = let newerLink =
match listType, pageNbr with match listType, pageNbr with
@ -98,9 +99,9 @@ open Giraffe
// GET /page/{pageNbr} // GET /page/{pageNbr}
let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task { let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog let webLog = ctx.WebLog
let conn = ctx.Conn let data = ctx.Data
let! posts = Data.Post.findPageOfPublishedPosts webLog.id pageNbr webLog.postsPerPage conn let! posts = data.Post.findPageOfPublishedPosts webLog.id pageNbr webLog.postsPerPage
let! hash = preparePostList webLog posts PostList "" pageNbr webLog.postsPerPage ctx conn let! hash = preparePostList webLog posts PostList "" pageNbr webLog.postsPerPage ctx data
let title = let title =
match pageNbr, webLog.defaultPage with match pageNbr, webLog.defaultPage with
| 1, "posts" -> None | 1, "posts" -> None
@ -119,7 +120,7 @@ let redirectToPageOfPosts (pageNbr : int) : HttpHandler = fun next ctx ->
// GET /category/{slug}/page/{pageNbr} // GET /category/{slug}/page/{pageNbr}
let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task { let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog let webLog = ctx.WebLog
let conn = ctx.Conn let data = ctx.Data
match parseSlugAndPage webLog slugAndPage with match parseSlugAndPage webLog slugAndPage with
| Some pageNbr, slug, isFeed -> | Some pageNbr, slug, isFeed ->
match CategoryCache.get ctx |> Array.tryFind (fun cat -> cat.slug = slug) with match CategoryCache.get ctx |> Array.tryFind (fun cat -> cat.slug = slug) with
@ -128,10 +129,10 @@ let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task {
(defaultArg webLog.rss.itemsInFeed webLog.postsPerPage) next ctx (defaultArg webLog.rss.itemsInFeed webLog.postsPerPage) next ctx
| Some cat -> | Some cat ->
// Category pages include posts in subcategories // Category pages include posts in subcategories
match! Data.Post.findPageOfCategorizedPosts webLog.id (getCategoryIds slug ctx) pageNbr webLog.postsPerPage match! data.Post.findPageOfCategorizedPosts webLog.id (getCategoryIds slug ctx) pageNbr webLog.postsPerPage
conn with with
| posts when List.length posts > 0 -> | posts when List.length posts > 0 ->
let! hash = preparePostList webLog posts CategoryList cat.slug pageNbr webLog.postsPerPage ctx conn let! hash = preparePostList webLog posts CategoryList cat.slug pageNbr webLog.postsPerPage ctx data
let pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>""" let pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
hash.Add ("page_title", $"{cat.name}: Category Archive{pgTitle}") hash.Add ("page_title", $"{cat.name}: Category Archive{pgTitle}")
hash.Add ("subtitle", defaultArg cat.description "") hash.Add ("subtitle", defaultArg cat.description "")
@ -150,12 +151,12 @@ open System.Web
// GET /tag/{tag}/page/{pageNbr} // GET /tag/{tag}/page/{pageNbr}
let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task { let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog let webLog = ctx.WebLog
let conn = ctx.Conn let data = ctx.Data
match parseSlugAndPage webLog slugAndPage with match parseSlugAndPage webLog slugAndPage with
| Some pageNbr, rawTag, isFeed -> | Some pageNbr, rawTag, isFeed ->
let urlTag = HttpUtility.UrlDecode rawTag let urlTag = HttpUtility.UrlDecode rawTag
let! tag = backgroundTask { let! tag = backgroundTask {
match! Data.TagMap.findByUrlValue urlTag webLog.id conn with match! data.TagMap.findByUrlValue urlTag webLog.id with
| Some m -> return m.tag | Some m -> return m.tag
| None -> return urlTag | None -> return urlTag
} }
@ -163,9 +164,9 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
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 conn with match! data.Post.findPageOfTaggedPosts webLog.id tag pageNbr webLog.postsPerPage with
| posts when List.length posts > 0 -> | posts when List.length posts > 0 ->
let! hash = preparePostList webLog posts TagList rawTag pageNbr webLog.postsPerPage ctx conn let! hash = preparePostList webLog posts TagList rawTag pageNbr webLog.postsPerPage ctx data
let pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>""" let pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
hash.Add ("page_title", $"Posts Tagged &ldquo;{tag}&rdquo;{pgTitle}") hash.Add ("page_title", $"Posts Tagged &ldquo;{tag}&rdquo;{pgTitle}")
hash.Add ("is_tag", true) hash.Add ("is_tag", true)
@ -175,7 +176,7 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
// 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 conn 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}"
return! return!
@ -192,7 +193,7 @@ let home : HttpHandler = fun next ctx -> task {
match webLog.defaultPage with match webLog.defaultPage with
| "posts" -> return! pageOfPosts 1 next ctx | "posts" -> return! pageOfPosts 1 next ctx
| pageId -> | pageId ->
match! Data.Page.findById (PageId pageId) webLog.id ctx.Conn with match! ctx.Data.Page.findById (PageId pageId) webLog.id with
| Some page -> | Some page ->
return! return!
Hash.FromAnonymousObject {| Hash.FromAnonymousObject {|
@ -209,9 +210,9 @@ let home : HttpHandler = fun next ctx -> task {
// GET /admin/posts/page/{pageNbr} // GET /admin/posts/page/{pageNbr}
let all pageNbr : HttpHandler = fun next ctx -> task { let all pageNbr : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog let webLog = ctx.WebLog
let conn = ctx.Conn let data = ctx.Data
let! posts = Data.Post.findPageOfPosts webLog.id pageNbr 25 conn let! posts = data.Post.findPageOfPosts webLog.id pageNbr 25
let! hash = preparePostList webLog posts AdminList "" pageNbr 25 ctx conn let! hash = preparePostList webLog posts AdminList "" pageNbr 25 ctx data
hash.Add ("page_title", "Posts") hash.Add ("page_title", "Posts")
hash.Add ("csrf", csrfToken ctx) hash.Add ("csrf", csrfToken ctx)
return! viewForTheme "admin" "post-list" next ctx hash return! viewForTheme "admin" "post-list" next ctx hash
@ -220,18 +221,18 @@ let all pageNbr : HttpHandler = fun next ctx -> task {
// GET /admin/post/{id}/edit // GET /admin/post/{id}/edit
let edit postId : HttpHandler = fun next ctx -> task { let edit postId : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog let webLog = ctx.WebLog
let conn = ctx.Conn let data = ctx.Data
let! result = task { let! result = task {
match postId with match postId with
| "new" -> return Some ("Write a New Post", { Post.empty with id = PostId "new" }) | "new" -> return Some ("Write a New Post", { Post.empty with id = PostId "new" })
| _ -> | _ ->
match! Data.Post.findByFullId (PostId postId) webLog.id conn with match! data.Post.findFullById (PostId postId) webLog.id with
| Some post -> return Some ("Edit Post", post) | Some post -> return Some ("Edit Post", post)
| None -> return None | None -> return None
} }
match result with match result with
| Some (title, post) -> | Some (title, post) ->
let! cats = Data.Category.findAllForView webLog.id conn let! cats = data.Category.findAllForView webLog.id
let! templates = templatesForTheme ctx "post" let! templates = templatesForTheme ctx "post"
let model = EditPostModel.fromPost webLog post let model = EditPostModel.fromPost webLog post
return! return!
@ -250,7 +251,7 @@ let edit postId : HttpHandler = fun next ctx -> task {
// GET /admin/post/{id}/permalinks // GET /admin/post/{id}/permalinks
let editPermalinks postId : HttpHandler = fun next ctx -> task { let editPermalinks postId : HttpHandler = fun next ctx -> task {
match! Data.Post.findByFullId (PostId postId) ctx.WebLog.id ctx.Conn with match! ctx.Data.Post.findFullById (PostId postId) ctx.WebLog.id with
| Some post -> | Some post ->
return! return!
Hash.FromAnonymousObject {| Hash.FromAnonymousObject {|
@ -267,7 +268,7 @@ let savePermalinks : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog let webLog = ctx.WebLog
let! model = ctx.BindFormAsync<ManagePermalinksModel> () let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
let links = model.prior |> Array.map Permalink |> List.ofArray let links = model.prior |> Array.map Permalink |> List.ofArray
match! Data.Post.updatePriorPermalinks (PostId model.id) webLog.id links ctx.Conn with match! ctx.Data.Post.updatePriorPermalinks (PostId model.id) webLog.id links with
| true -> | true ->
do! addMessage ctx { UserMessage.success with message = "Post permalinks saved successfully" } do! addMessage ctx { UserMessage.success with message = "Post permalinks saved successfully" }
return! redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/post/{model.id}/permalinks")) next ctx return! redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/post/{model.id}/permalinks")) next ctx
@ -277,7 +278,7 @@ let savePermalinks : HttpHandler = fun next ctx -> task {
// POST /admin/post/{id}/delete // POST /admin/post/{id}/delete
let delete postId : HttpHandler = fun next ctx -> task { let delete postId : HttpHandler = fun next ctx -> task {
let webLog = ctx.WebLog let webLog = ctx.WebLog
match! Data.Post.delete (PostId postId) webLog.id ctx.Conn with match! ctx.Data.Post.delete (PostId postId) webLog.id with
| true -> do! addMessage ctx { UserMessage.success with message = "Post deleted successfully" } | true -> do! addMessage ctx { UserMessage.success with message = "Post deleted successfully" }
| false -> do! addMessage ctx { UserMessage.error with message = "Post not found; nothing deleted" } | false -> do! addMessage ctx { UserMessage.error with message = "Post not found; nothing deleted" }
return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/posts")) next ctx return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/posts")) next ctx
@ -289,7 +290,7 @@ let delete postId : HttpHandler = fun next ctx -> task {
let save : HttpHandler = fun next ctx -> task { let save : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<EditPostModel> () let! model = ctx.BindFormAsync<EditPostModel> ()
let webLog = ctx.WebLog let webLog = ctx.WebLog
let conn = ctx.Conn let data = ctx.Data
let now = DateTime.UtcNow let now = DateTime.UtcNow
let! pst = task { let! pst = task {
match model.postId with match model.postId with
@ -300,7 +301,7 @@ let save : HttpHandler = fun next ctx -> task {
webLogId = webLog.id webLogId = webLog.id
authorId = userId ctx authorId = userId ctx
} }
| postId -> return! Data.Post.findByFullId (PostId postId) webLog.id conn | postId -> return! data.Post.findFullById (PostId postId) webLog.id
} }
match pst with match pst with
| Some post -> | Some post ->
@ -349,7 +350,7 @@ let save : HttpHandler = fun next ctx -> task {
} }
| false -> { post with publishedOn = Some dt } | false -> { post with publishedOn = Some dt }
| false -> post | false -> post
do! (if model.postId = "new" then Data.Post.add else Data.Post.update) post conn do! (if model.postId = "new" then data.Post.add else data.Post.update) post
// If the post was published or its categories changed, refresh the category cache // If the post was published or its categories changed, refresh the category cache
if model.doPublish if model.doPublish
|| not (pst.Value.categoryIds || not (pst.Value.categoryIds

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

@ -14,7 +14,7 @@ module CatchAll =
/// 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 conn = ctx.Conn let data = ctx.Data
let debug = debug "Routes.CatchAll" ctx let debug = debug "Routes.CatchAll" ctx
let textLink = let textLink =
let _, extra = WebLog.hostAndPath webLog let _, extra = WebLog.hostAndPath webLog
@ -27,15 +27,15 @@ module CatchAll =
if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.empty) if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.empty)
let permalink = Permalink (textLink.Substring 1) let permalink = Permalink (textLink.Substring 1)
// Current post // Current post
match Data.Post.findByPermalink permalink webLog.id conn |> await with match data.Post.findByPermalink permalink webLog.id |> await with
| Some post -> | Some post ->
debug (fun () -> $"Found post by permalink") debug (fun () -> $"Found post by permalink")
let model = Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 ctx conn |> await let model = Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 ctx data |> await
model.Add ("page_title", post.title) model.Add ("page_title", post.title)
yield fun next ctx -> themedView (defaultArg post.template "single-post") next ctx model yield fun next ctx -> themedView (defaultArg post.template "single-post") next ctx model
| None -> () | None -> ()
// Current page // Current page
match Data.Page.findByPermalink permalink webLog.id conn |> await with match data.Page.findByPermalink permalink webLog.id |> await with
| Some page -> | Some page ->
debug (fun () -> $"Found page by permalink") debug (fun () -> $"Found page by permalink")
yield fun next ctx -> yield fun next ctx ->
@ -56,25 +56,25 @@ module CatchAll =
// Post differing only by trailing slash // Post differing only by trailing slash
let altLink = let altLink =
Permalink (if textLink.EndsWith "/" then textLink[1..textLink.Length - 2] else $"{textLink[1..]}/") Permalink (if textLink.EndsWith "/" then textLink[1..textLink.Length - 2] else $"{textLink[1..]}/")
match Data.Post.findByPermalink altLink webLog.id conn |> await with match data.Post.findByPermalink altLink webLog.id |> await with
| Some post -> | Some post ->
debug (fun () -> $"Found post by trailing-slash-agnostic permalink") debug (fun () -> $"Found post by trailing-slash-agnostic permalink")
yield redirectTo true (WebLog.relativeUrl webLog post.permalink) yield redirectTo true (WebLog.relativeUrl webLog post.permalink)
| None -> () | None -> ()
// Page differing only by trailing slash // Page differing only by trailing slash
match Data.Page.findByPermalink altLink webLog.id conn |> await with match data.Page.findByPermalink altLink webLog.id |> await with
| Some page -> | Some page ->
debug (fun () -> $"Found page by trailing-slash-agnostic permalink") debug (fun () -> $"Found page by trailing-slash-agnostic permalink")
yield redirectTo true (WebLog.relativeUrl webLog page.permalink) yield redirectTo true (WebLog.relativeUrl webLog page.permalink)
| None -> () | None -> ()
// Prior post // Prior post
match Data.Post.findCurrentPermalink [ permalink; altLink ] webLog.id conn |> await with match data.Post.findCurrentPermalink [ permalink; altLink ] webLog.id |> await with
| Some link -> | Some link ->
debug (fun () -> $"Found post by prior permalink") debug (fun () -> $"Found post by prior permalink")
yield redirectTo true (WebLog.relativeUrl webLog link) yield redirectTo true (WebLog.relativeUrl webLog link)
| None -> () | None -> ()
// Prior page // Prior page
match Data.Page.findCurrentPermalink [ permalink; altLink ] webLog.id conn |> await with match data.Page.findCurrentPermalink [ permalink; altLink ] webLog.id |> await with
| Some link -> | Some link ->
debug (fun () -> $"Found page by prior permalink") debug (fun () -> $"Found page by prior permalink")
yield redirectTo true (WebLog.relativeUrl webLog link) yield redirectTo true (WebLog.relativeUrl webLog link)
@ -114,7 +114,7 @@ module Asset =
// GET /theme/{theme}/{**path} // GET /theme/{theme}/{**path}
let serveAsset (urlParts : string seq) : HttpHandler = fun next ctx -> task { let serveAsset (urlParts : string seq) : HttpHandler = fun next ctx -> task {
let path = urlParts |> Seq.skip 1 |> Seq.head let path = urlParts |> Seq.skip 1 |> Seq.head
match! Data.ThemeAsset.findById (ThemeAssetId.ofString path) ctx.Conn with match! ctx.Data.ThemeAsset.findById (ThemeAssetId.ofString path) with
| Some asset -> | Some asset ->
match checkModified asset ctx with match checkModified asset ctx with
| Some threeOhFour -> return! threeOhFour next ctx | Some threeOhFour -> return! threeOhFour next ctx

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

@ -42,7 +42,7 @@ open MyWebLog
let doLogOn : HttpHandler = fun next ctx -> task { let doLogOn : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<LogOnModel> () let! model = ctx.BindFormAsync<LogOnModel> ()
let webLog = ctx.WebLog let webLog = ctx.WebLog
match! Data.WebLogUser.findByEmail model.emailAddress webLog.id ctx.Conn with match! ctx.Data.WebLogUser.findByEmail model.emailAddress webLog.id with
| Some user when user.passwordHash = hashedPassword model.password user.userName user.salt -> | Some user when user.passwordHash = hashedPassword model.password user.userName user.salt ->
let claims = seq { let claims = seq {
Claim (ClaimTypes.NameIdentifier, WebLogUserId.toString user.id) Claim (ClaimTypes.NameIdentifier, WebLogUserId.toString user.id)
@ -79,7 +79,7 @@ let private showEdit (hash : Hash) : HttpHandler = fun next ctx -> task {
// GET /admin/user/edit // GET /admin/user/edit
let edit : HttpHandler = fun next ctx -> task { let edit : HttpHandler = fun next ctx -> task {
match! Data.WebLogUser.findById (userId ctx) ctx.Conn with match! ctx.Data.WebLogUser.findById (userId ctx) ctx.WebLog.id with
| Some user -> return! showEdit (Hash.FromAnonymousObject {| model = EditUserModel.fromUser user |}) next ctx | Some user -> return! showEdit (Hash.FromAnonymousObject {| model = EditUserModel.fromUser user |}) next ctx
| None -> return! Error.notFound next ctx | None -> return! Error.notFound next ctx
} }
@ -88,8 +88,8 @@ let edit : HttpHandler = fun next ctx -> task {
let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
let! model = ctx.BindFormAsync<EditUserModel> () let! model = ctx.BindFormAsync<EditUserModel> ()
if model.newPassword = model.newPasswordConfirm then if model.newPassword = model.newPasswordConfirm then
let conn = ctx.Conn let data = ctx.Data
match! Data.WebLogUser.findById (userId ctx) conn with match! data.WebLogUser.findById (userId ctx) ctx.WebLog.id with
| Some user -> | Some user ->
let pw, salt = let pw, salt =
if model.newPassword = "" then if model.newPassword = "" then
@ -105,7 +105,7 @@ let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
passwordHash = pw passwordHash = pw
salt = salt salt = salt
} }
do! Data.WebLogUser.update user conn 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" }
return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/user/edit")) next ctx return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/user/edit")) next ctx

102
src/MyWebLog/Maintenance.fs
View File

@ -3,13 +3,12 @@ module MyWebLog.Maintenance
open System open System
open System.IO open System.IO
open Microsoft.Extensions.DependencyInjection open Microsoft.Extensions.DependencyInjection
open RethinkDb.Driver.FSharp open MyWebLog.Data
open RethinkDb.Driver.Net
/// 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 conn = sp.GetRequiredService<IConnection> () let data = sp.GetRequiredService<IData> ()
let timeZone = let timeZone =
let local = TimeZoneInfo.Local.Id let local = TimeZoneInfo.Local.Id
@ -25,19 +24,19 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
let userId = WebLogUserId.create () let userId = WebLogUserId.create ()
let homePageId = PageId.create () let homePageId = PageId.create ()
do! Data.WebLog.add do! data.WebLog.add
{ WebLog.empty with { WebLog.empty with
id = webLogId id = webLogId
name = args[2] name = args[2]
urlBase = args[1] urlBase = args[1]
defaultPage = PageId.toString homePageId defaultPage = PageId.toString homePageId
timeZone = timeZone timeZone = timeZone
} conn }
// Create the admin user // Create the admin user
let salt = Guid.NewGuid () let salt = Guid.NewGuid ()
do! Data.WebLogUser.add do! data.WebLogUser.add
{ WebLogUser.empty with { WebLogUser.empty with
id = userId id = userId
webLogId = webLogId webLogId = webLogId
@ -48,10 +47,10 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
passwordHash = Handlers.User.hashedPassword args[4] args[3] salt passwordHash = Handlers.User.hashedPassword args[4] args[3] salt
salt = salt salt = salt
authorizationLevel = Administrator authorizationLevel = Administrator
} conn }
// Create the default home page // Create the default home page
do! Data.Page.add do! data.Page.add
{ Page.empty with { Page.empty with
id = homePageId id = homePageId
webLogId = webLogId webLogId = webLogId
@ -66,7 +65,7 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
text = Html "<p>This is your default home page.</p>" text = Html "<p>This is your default home page.</p>"
} }
] ]
} conn }
printfn $"Successfully initialized database for {args[2]} with URL base {args[1]}" printfn $"Successfully initialized database for {args[2]} with URL base {args[1]}"
} }
@ -80,9 +79,9 @@ 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 importPriorPermalinks urlBase file (sp : IServiceProvider) = task { let importPriorPermalinks urlBase file (sp : IServiceProvider) = task {
let conn = sp.GetRequiredService<IConnection> () let data = sp.GetRequiredService<IData> ()
match! Data.WebLog.findByHost urlBase conn with match! data.WebLog.findByHost urlBase with
| Some webLog -> | Some webLog ->
let mapping = let mapping =
@ -93,23 +92,15 @@ let importPriorPermalinks urlBase file (sp : IServiceProvider) = task {
Permalink parts[0], Permalink parts[1]) Permalink parts[0], Permalink parts[1])
for old, current in mapping do for old, current in mapping do
match! Data.Post.findByPermalink current webLog.id conn with match! data.Post.findByPermalink current webLog.id with
| Some post -> | Some post ->
let! withLinks = rethink<Post> { let! withLinks = data.Post.findFullById post.id post.webLogId
withTable Data.Table.Post let! _ = data.Post.updatePriorPermalinks post.id post.webLogId
get post.id (old :: withLinks.Value.priorPermalinks)
result conn
}
do! rethink {
withTable Data.Table.Post
get post.id
update [ "priorPermalinks", old :: withLinks.priorPermalinks :> obj]
write; ignoreResult conn
}
printfn $"{Permalink.toString old} -> {Permalink.toString current}" printfn $"{Permalink.toString old} -> {Permalink.toString current}"
| None -> printfn $"Cannot find current post for {Permalink.toString current}" | None -> printfn $"Cannot find current post for {Permalink.toString current}"
printfn "Done!" printfn "Done!"
| None -> printfn $"No web log found at {urlBase}" | None -> eprintfn $"No web log found at {urlBase}"
} }
/// Import permalinks if all is well /// Import permalinks if all is well
@ -127,17 +118,70 @@ let loadTheme (args : string[]) (sp : IServiceProvider) = task {
| -1 -> args[1] | -1 -> args[1]
| it -> args[1][(it + 1)..] | it -> args[1][(it + 1)..]
match Handlers.Admin.getThemeName fileName with match Handlers.Admin.getThemeName fileName with
| Some themeName -> | Ok themeName ->
let conn = sp.GetRequiredService<IConnection> () let data = sp.GetRequiredService<IData> ()
let clean = if args.Length > 2 then bool.Parse args[2] else true let clean = if args.Length > 2 then bool.Parse args[2] else true
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
do! Handlers.Admin.loadThemeFromZip themeName copy clean conn do! Handlers.Admin.loadThemeFromZip themeName copy clean data
printfn $"Theme {themeName} loaded successfully" printfn $"Theme {themeName} loaded successfully"
| None -> | Error message -> eprintfn $"{message}"
printfn $"Theme file name {args[1]} is invalid"
else else
printfn "Usage: MyWebLog load-theme [theme-zip-file-name] [*clean-load]" printfn "Usage: MyWebLog load-theme [theme-zip-file-name] [*clean-load]"
printfn " * optional, defaults to true" printfn " * optional, defaults to true"
} }
/// Back up a web log's data
module Backup =
/// A theme asset, with the data base-64 encoded
type EncodedAsset =
{ /// The ID of the theme asset
id : ThemeAssetId
/// The updated date for this asset
updatedOn : DateTime
/// The data for this asset, base-64 encoded
data : string
}
/// Create an encoded theme asset from the original theme asset
static member fromAsset (asset : ThemeAsset) =
{ id = asset.id
updatedOn = asset.updatedOn
data = Convert.ToBase64String asset.data
}
/// A unified archive for a web log
type Archive =
{ /// The web log to which this archive belongs
webLog : WebLog
/// The users for this web log
users : WebLogUser list
/// The theme used by this web log at the time the archive was made
theme : Theme
/// Assets for the theme used by this web log at the time the archive was made
assets : EncodedAsset list
/// The categories for this web log
categories : Category list
/// The tag mappings for this web log
tagMappings : TagMap list
/// The pages for this web log (containing only the most recent revision)
pages : Page list
/// The posts for this web log (containing only the most recent revision)
posts : Post list
}
let inline await f = (Async.AwaitTask >> Async.RunSynchronously) f
// TODO: finish implementation; paused for LiteDB data capability development, will work with both

69
src/MyWebLog/Program.fs
View File

@ -23,17 +23,43 @@ type WebLogMiddleware (next : RequestDelegate, log : ILogger<WebLogMiddleware>)
ctx.Response.StatusCode <- 404 ctx.Response.StatusCode <- 404
} }
open System open System
open Microsoft.Extensions.DependencyInjection
open MyWebLog.Data
/// Logic to obtain a data connection and implementation based on configured values
module DataImplementation =
open LiteDB
open Microsoft.Extensions.Configuration
open MyWebLog.Converters
open RethinkDb.Driver.FSharp
open RethinkDb.Driver.Net
/// Get the configured data implementation
let get (sp : IServiceProvider) : IData option =
let config = sp.GetRequiredService<IConfiguration> ()
let isNotNull it = (isNull >> not) it
if isNotNull (config.GetSection "RethinkDB") then
Json.all () |> Seq.iter Converter.Serializer.Converters.Add
let rethinkCfg = DataConfig.FromConfiguration (config.GetSection "RethinkDB")
let conn = rethinkCfg.CreateConnectionAsync () |> Async.AwaitTask |> Async.RunSynchronously
Some (upcast RethinkDbData (conn, rethinkCfg, sp.GetRequiredService<ILogger<RethinkDbData>> ()))
elif isNotNull (config.GetConnectionString "LiteDB") then
Bson.registerAll ()
let db = new LiteDatabase (config.GetConnectionString "LiteDB")
Some (upcast LiteDbData db)
else
None
open Giraffe open Giraffe
open Giraffe.EndpointRouting open Giraffe.EndpointRouting
open Microsoft.AspNetCore.Authentication.Cookies open Microsoft.AspNetCore.Authentication.Cookies
open Microsoft.AspNetCore.Builder open Microsoft.AspNetCore.Builder
open Microsoft.AspNetCore.HttpOverrides open Microsoft.AspNetCore.HttpOverrides
open Microsoft.Extensions.Configuration
open Microsoft.Extensions.DependencyInjection
open RethinkDB.DistributedCache open RethinkDB.DistributedCache
open RethinkDb.Driver.FSharp
open RethinkDb.Driver.Net
[<EntryPoint>] [<EntryPoint>]
let main args = let main args =
@ -52,25 +78,32 @@ let main args =
let _ = builder.Services.AddAuthorization () let _ = builder.Services.AddAuthorization ()
let _ = builder.Services.AddAntiforgery () let _ = builder.Services.AddAntiforgery ()
// Configure RethinkDB's connection
JsonConverters.all () |> Seq.iter Converter.Serializer.Converters.Add
let sp = builder.Services.BuildServiceProvider () let sp = builder.Services.BuildServiceProvider ()
let config = sp.GetRequiredService<IConfiguration> () match DataImplementation.get sp with
let loggerFac = sp.GetRequiredService<ILoggerFactory> () | Some data ->
let rethinkCfg = DataConfig.FromConfiguration (config.GetSection "RethinkDB")
let conn =
task { task {
let! conn = rethinkCfg.CreateConnectionAsync () do! data.startUp ()
do! Data.Startup.ensureDb rethinkCfg (loggerFac.CreateLogger (nameof Data.Startup)) conn do! WebLogCache.fill data
do! WebLogCache.fill conn do! ThemeAssetCache.fill data
do! ThemeAssetCache.fill conn
return conn
} |> Async.AwaitTask |> Async.RunSynchronously } |> Async.AwaitTask |> Async.RunSynchronously
let _ = builder.Services.AddSingleton<IConnection> conn builder.Services.AddSingleton<IData> data |> ignore
let _ = builder.Services.AddDistributedRethinkDBCache (fun opts -> // Define distributed cache implementation based on data implementation
match data with
| :? RethinkDbData as rethink ->
builder.Services.AddDistributedRethinkDBCache (fun opts ->
opts.TableName <- "Session" opts.TableName <- "Session"
opts.Connection <- conn) opts.Connection <- rethink.Conn)
|> ignore
| :? LiteDbData ->
let log = sp.GetRequiredService<ILoggerFactory> ()
let logger = log.CreateLogger "MyWebLog.StartUp"
logger.LogWarning "Session caching is not yet implemented via LiteDB; using memory cache for sessions"
builder.Services.AddDistributedMemoryCache () |> ignore
| _ -> ()
| None ->
invalidOp "There is no data configuration present; please add a RethinkDB section or LiteDB connection string"
let _ = builder.Services.AddSession(fun opts -> let _ = builder.Services.AddSession(fun opts ->
opts.IdleTimeout <- TimeSpan.FromMinutes 60 opts.IdleTimeout <- TimeSpan.FromMinutes 60
opts.Cookie.HttpOnly <- true opts.Cookie.HttpOnly <- true