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

V2 #1

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

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

@ -130,133 +130,3 @@ module Json =
// Handles DUs with no associated data, as well as option fields // Handles DUs with no associated data, as well as option fields
CompactUnionJsonConverter () CompactUnionJsonConverter ()
} }
// We *like* the implicit conversion of string to BsonValue
#nowarn "3391"
/// BSON converters for use with LiteDB
module Bson =
open LiteDB
module AuthorizationLevelMapping =
let fromBson (value : BsonValue) = AuthorizationLevel.parse value.AsString
let toBson (value : AuthorizationLevel) : BsonValue = AuthorizationLevel.toString value
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 CommentStatusMapping =
let fromBson (value : BsonValue) = CommentStatus.parse value.AsString
let toBson (value : CommentStatus) : BsonValue = CommentStatus.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 (BsonMapper.Global.ToObject<PodcastOptions> value.AsDocument)
let podcastOptionsToBson (value : PodcastOptions option) : BsonValue =
match value with Some opts -> BsonMapper.Global.ToDocument 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 PostStatusMapping =
let fromBson (value : BsonValue) = PostStatus.parse value.AsString
let toBson (value : PostStatus) : BsonValue = PostStatus.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<AuthorizationLevel> (AuthorizationLevelMapping.toBson, AuthorizationLevelMapping.fromBson)
g.RegisterType<CategoryId> (CategoryIdMapping.toBson, CategoryIdMapping.fromBson)
g.RegisterType<CommentId> (CommentIdMapping.toBson, CommentIdMapping.fromBson)
g.RegisterType<CommentStatus> (CommentStatusMapping.toBson, CommentStatusMapping.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<PostStatus> (PostStatusMapping.toBson, PostStatusMapping.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)

584
src/MyWebLog.Data/LiteDbData.fs
View File

@ -1,584 +0,0 @@
namespace MyWebLog.Dataa
open LiteDB
open MyWebLog
open System.Threading.Tasks
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 _.findByWebLog webLogId =
Collection.Category.Find (fun c -> c.webLogId = webLogId)
|> toList
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 _.restore cats = backgroundTask {
let _ = Collection.Category.InsertBulk cats
do! checkpoint ()
}
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 _.findFullByWebLog webLogId =
Collection.Page.Find (fun p -> p.webLogId = webLogId)
|> toList
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
member _.restore pages = backgroundTask {
let _ = Collection.Page.InsertBulk pages
do! checkpoint ()
}
member _.update page = backgroundTask {
let _ = Collection.Page.Update page
do! checkpoint ()
}
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 _.findFullByWebLog webLogId =
Collection.Post.Find (fun p -> p.webLogId = webLogId)
|> toList
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 _.restore posts = backgroundTask {
let _ = Collection.Post.InsertBulk posts
do! checkpoint ()
}
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 _.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 _.findByWebLog webLogId =
Collection.TagMap.Find (fun tm -> tm.webLogId = webLogId)
|> Seq.sortBy (fun tm -> tm.tag)
|> toList
member _.findMappingForTags tags webLogId =
Collection.TagMap.Find (fun tm -> tm.webLogId = webLogId && tags |> List.contains tm.tag)
|> toList
member _.restore tagMaps = backgroundTask {
let _ = Collection.TagMap.InsertBulk tagMaps
do! checkpoint ()
}
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 {
(ThemeId.toString
>> sprintf "$.id LIKE '%s%%'"
>> BsonExpression.Create
>> Collection.ThemeAsset.DeleteMany) themeId
|> ignore
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 _.findByThemeWithData themeId =
Collection.ThemeAsset.Find (fun ta ->
(ThemeAssetId.toString ta.id).StartsWith (ThemeId.toString themeId))
|> 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 _.delete webLogId = backgroundTask {
let forWebLog = BsonExpression.Create $"$.webLogId = '{WebLogId.toString webLogId}'"
let _ = Collection.Comment.DeleteMany forWebLog
let _ = Collection.Post.DeleteMany forWebLog
let _ = Collection.Page.DeleteMany forWebLog
let _ = Collection.Category.DeleteMany forWebLog
let _ = Collection.TagMap.DeleteMany forWebLog
let _ = Collection.WebLogUser.DeleteMany forWebLog
let _ = Collection.WebLog.Delete (WebLogIdMapping.toBson webLogId)
do! checkpoint ()
}
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 _.findByWebLog webLogId =
Collection.WebLogUser.Find (fun wlu -> wlu.webLogId = webLogId)
|> toList
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 _.restore users = backgroundTask {
let _ = Collection.WebLogUser.InsertBulk users
do! checkpoint ()
}
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 ()
}

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

@ -10,7 +10,6 @@
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
<PackageReference Include="LiteDB" Version="5.0.12" />
<PackageReference Include="Microsoft.Data.Sqlite" Version="6.0.6" /> <PackageReference Include="Microsoft.Data.Sqlite" Version="6.0.6" />
<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" />
@ -25,7 +24,6 @@
<Compile Include="Interfaces.fs" /> <Compile Include="Interfaces.fs" />
<Compile Include="Utils.fs" /> <Compile Include="Utils.fs" />
<Compile Include="RethinkDbData.fs" /> <Compile Include="RethinkDbData.fs" />
<Compile Include="LiteDbData.fs" />
<Compile Include="SQLiteData.fs" /> <Compile Include="SQLiteData.fs" />
</ItemGroup> </ItemGroup>

154
src/MyWebLog.Data/SQLiteData.fs
View File

@ -50,6 +50,9 @@ module private SqliteHelpers =
/// Get a date/time value from a data reader /// Get a date/time value from a data reader
let getDateTime col (rdr : SqliteDataReader) = rdr.GetDateTime (rdr.GetOrdinal col) let getDateTime col (rdr : SqliteDataReader) = rdr.GetDateTime (rdr.GetOrdinal col)
/// Get a Guid value from a data reader
let getGuid col (rdr : SqliteDataReader) = rdr.GetGuid (rdr.GetOrdinal col)
/// Get an int value from a data reader /// Get an int value from a data reader
let getInt col (rdr : SqliteDataReader) = rdr.GetInt32 (rdr.GetOrdinal col) let getInt col (rdr : SqliteDataReader) = rdr.GetInt32 (rdr.GetOrdinal col)
@ -213,6 +216,20 @@ module private SqliteHelpers =
} }
} }
/// Create a web log user from the current row in the given data reader
let toWebLogUser (rdr : SqliteDataReader) : WebLogUser =
{ id = WebLogUserId (getString "id" rdr)
webLogId = WebLogId (getString "webLogId" rdr)
userName = getString "user_name" rdr
firstName = getString "first_name" rdr
lastName = getString "last_name" rdr
preferredName = getString "preferred_name" rdr
passwordHash = getString "password_hash" rdr
salt = getGuid "salt" rdr
url = tryString "url" rdr
authorizationLevel = AuthorizationLevel.parse (getString "authorization_level" rdr)
}
/// SQLite myWebLog data implementation /// SQLite myWebLog data implementation
type SQLiteData (conn : SqliteConnection) = type SQLiteData (conn : SqliteConnection) =
@ -287,6 +304,20 @@ type SQLiteData (conn : SqliteConnection) =
] |> ignore ] |> ignore
addWebLogRssParameters cmd webLog addWebLogRssParameters cmd webLog
/// Add parameters for web log user INSERT or UPDATE statements
let addWebLogUserParameters (cmd : SqliteCommand) (user : WebLogUser) =
[ cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString user.id)
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString user.webLogId)
cmd.Parameters.AddWithValue ("@userName", user.userName)
cmd.Parameters.AddWithValue ("@firstName", user.firstName)
cmd.Parameters.AddWithValue ("@lastName", user.lastName)
cmd.Parameters.AddWithValue ("@preferredName", user.preferredName)
cmd.Parameters.AddWithValue ("@passwordHash", user.passwordHash)
cmd.Parameters.AddWithValue ("@salt", user.salt)
cmd.Parameters.AddWithValue ("@url", match user.url with Some u -> u :> obj | None -> DBNull.Value)
cmd.Parameters.AddWithValue ("@authorizationLevel", AuthorizationLevel.toString user.authorizationLevel)
] |> ignore
/// Add a web log ID parameter /// Add a web log ID parameter
let addWebLogId (cmd : SqliteCommand) webLogId = let addWebLogId (cmd : SqliteCommand) webLogId =
cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) |> ignore cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) |> ignore
@ -473,28 +504,30 @@ type SQLiteData (conn : SqliteConnection) =
|> ignore |> ignore
} }
/// Run a command for the given post and tag
let runPostCategoryCommand postId (cmd : SqliteCommand) (tag : string) = backgroundTask {
cmd.Parameters.Clear ()
[ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId)
cmd.Parameters.AddWithValue ("@tag", tag)
] |> ignore
do! write cmd
}
/// Update a post's assigned categories /// Update a post's assigned categories
let updatePostTags postId oldTags newTags = backgroundTask { let updatePostTags postId (oldTags : string list) newTags = backgroundTask {
let toDelete, toAdd = diffLists oldTags newTags id let toDelete, toAdd = diffLists oldTags newTags id
if List.isEmpty toDelete && List.isEmpty toAdd then if List.isEmpty toDelete && List.isEmpty toAdd then
return () return ()
else else
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
let runCmd tag = backgroundTask {
cmd.Parameters.Clear ()
[ cmd.Parameters.AddWithValue ("@postId", PostId.toString postId)
cmd.Parameters.AddWithValue ("@tag", tag)
] |> ignore
do! write cmd
}
cmd.CommandText <- "DELETE FROM post_tag WHERE post_id = @postId AND tag = @tag" cmd.CommandText <- "DELETE FROM post_tag WHERE post_id = @postId AND tag = @tag"
toDelete toDelete
|> List.map runCmd |> List.map (runPostCategoryCommand postId cmd)
|> Task.WhenAll |> Task.WhenAll
|> ignore |> ignore
cmd.CommandText <- "INSERT INTO post_tag VALUES (@postId, @tag)" cmd.CommandText <- "INSERT INTO post_tag VALUES (@postId, @tag)"
toAdd toAdd
|> List.map runCmd |> List.map (runPostCategoryCommand postId cmd)
|> Task.WhenAll |> Task.WhenAll
|> ignore |> ignore
} }
@ -592,6 +625,15 @@ type SQLiteData (conn : SqliteConnection) =
return { webLog with rss = { webLog.rss with customFeeds = toList Map.toCustomFeed rdr } } return { webLog with rss = { webLog.rss with customFeeds = toList Map.toCustomFeed rdr } }
} }
/// Determine if the given table exists
let tableExists (table : string) = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT COUNT(*) FROM sqlite_master WHERE type = 'table' AND name = @table"
cmd.Parameters.AddWithValue ("@table", table) |> ignore
let! count = cmd.ExecuteScalarAsync ()
return (count :?> int) = 1
}
/// The connection for this instance /// The connection for this instance
member _.Conn = conn member _.Conn = conn
@ -1597,48 +1639,83 @@ type SQLiteData (conn : SqliteConnection) =
new IWebLogUserData with new IWebLogUserData with
member _.add user = backgroundTask { member _.add user = backgroundTask {
let _ = Collection.WebLogUser.Insert user use cmd = conn.CreateCommand ()
do! checkpoint () cmd.CommandText <-
"""INSERT INTO web_log_user
VALUES (@id, @webLogId, @userName, @firstName, @lastName, @preferredName, @passwordHash,
@salt, @url, @authorizationLevel)"""
addWebLogUserParameters cmd user
do! write cmd
} }
member _.findByEmail email webLogId = member _.findByEmail email webLogId = backgroundTask {
Collection.WebLogUser.Find (fun wlu -> wlu.webLogId = webLogId && wlu.userName = email) use cmd = conn.CreateCommand ()
|> tryFirst cmd.CommandText <-
"SELECT * FROM web_log_user WHERE web_log_id = @webLogId AND user_name = @userName"
addWebLogId cmd webLogId
cmd.Parameters.AddWithValue ("@userName", email) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return if rdr.Read () then Some (Map.toWebLogUser rdr) else None
}
member _.findById userId webLogId = member _.findById userId webLogId = backgroundTask {
Collection.WebLogUser.FindById (WebLogUserIdMapping.toBson userId) use cmd = conn.CreateCommand ()
// |> verifyWebLog webLogId (fun u -> u.webLogId) cmd.CommandText <- "SELECT * FROM web_log_user WHERE id = @id"
cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString userId) |> ignore
use! rdr = cmd.ExecuteReaderAsync ()
return verifyWebLog<WebLogUser> webLogId (fun u -> u.webLogId) Map.toWebLogUser rdr
}
member _.findByWebLog webLogId = member _.findByWebLog webLogId = backgroundTask {
Collection.WebLogUser.Find (fun wlu -> wlu.webLogId = webLogId) use cmd = conn.CreateCommand ()
|> toList cmd.CommandText <- "SELECT * FROM web_log_user WHERE web_log_id = @webLogId"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
return toList Map.toWebLogUser rdr
}
member _.findNames webLogId userIds = member _.findNames webLogId userIds = backgroundTask {
Collection.WebLogUser.Find (fun wlu -> userIds |> List.contains wlu.id) use cmd = conn.CreateCommand ()
|> Seq.map (fun u -> { name = WebLogUserId.toString u.id; value = WebLogUser.displayName u }) cmd.CommandText <- "SELECT * FROM web_log_user WHERE web_log_id = @webLogId AND id IN ("
|> toList userIds
|> List.iteri (fun idx userId ->
if idx > 0 then cmd.CommandText <- $"{cmd.CommandText}, "
cmd.CommandText <- $"{cmd.CommandText}@id{idx}"
cmd.Parameters.AddWithValue ($"@id{idx}", WebLogUserId.toString userId) |> ignore)
cmd.CommandText <- $"{cmd.CommandText})"
addWebLogId cmd webLogId
use! rdr = cmd.ExecuteReaderAsync ()
return
toList Map.toWebLogUser rdr
|> List.map (fun u -> { name = WebLogUserId.toString u.id; value = WebLogUser.displayName u })
}
member _.restore users = backgroundTask { member this.restore users = backgroundTask {
let _ = Collection.WebLogUser.InsertBulk users for user in users do
do! checkpoint () do! this.add user
} }
member _.update user = backgroundTask { member _.update user = backgroundTask {
let _ = Collection.WebLogUser.Update user use cmd = conn.CreateCommand ()
do! checkpoint () cmd.CommandText <-
"""UPDATE web_log_user
SET user_name = @userName,
first_name = @firstName,
last_name = @lastName,
preferred_name = @preferredName,
password_hash = @passwordHash,
salt = @salt,
url = @url,
authorization_level = @authorizationLevel
WHERE id = @id
AND web_log_id = @webLogId"""
addWebLogUserParameters cmd user
do! write cmd
} }
} }
member _.startUp () = backgroundTask { member _.startUp () = backgroundTask {
let tableExists table = backgroundTask {
use cmd = conn.CreateCommand ()
cmd.CommandText <- "SELECT COUNT(*) FROM sqlite_master WHERE type = 'table' AND name = @table"
cmd.Parameters.AddWithValue ("@table", table) |> ignore
let! count = cmd.ExecuteScalarAsync ()
return (count :?> int) = 1
}
let! exists = tableExists "theme" let! exists = tableExists "theme"
if not exists then if not exists then
use cmd = conn.CreateCommand () use cmd = conn.CreateCommand ()
@ -1846,4 +1923,3 @@ type SQLiteData (conn : SqliteConnection) =
url_value TEXT NOT NULL)""" url_value TEXT NOT NULL)"""
do! write cmd do! write cmd
} }

26
src/MyWebLog/Program.fs
View File

@ -1,4 +1,6 @@
open Microsoft.AspNetCore.Http open Microsoft.AspNetCore.Http
open Microsoft.Data.Sqlite
open Microsoft.Extensions.Configuration
open Microsoft.Extensions.Logging open Microsoft.Extensions.Logging
open MyWebLog open MyWebLog
@ -31,8 +33,6 @@ open MyWebLog.Data
/// Logic to obtain a data connection and implementation based on configured values /// Logic to obtain a data connection and implementation based on configured values
module DataImplementation = module DataImplementation =
open LiteDB
open Microsoft.Extensions.Configuration
open MyWebLog.Converters open MyWebLog.Converters
open RethinkDb.Driver.FSharp open RethinkDb.Driver.FSharp
open RethinkDb.Driver.Net open RethinkDb.Driver.Net
@ -46,10 +46,9 @@ module DataImplementation =
let rethinkCfg = DataConfig.FromConfiguration (config.GetSection "RethinkDB") let rethinkCfg = DataConfig.FromConfiguration (config.GetSection "RethinkDB")
let conn = rethinkCfg.CreateConnectionAsync () |> Async.AwaitTask |> Async.RunSynchronously let conn = rethinkCfg.CreateConnectionAsync () |> Async.AwaitTask |> Async.RunSynchronously
Some (upcast RethinkDbData (conn, rethinkCfg, sp.GetRequiredService<ILogger<RethinkDbData>> ())) Some (upcast RethinkDbData (conn, rethinkCfg, sp.GetRequiredService<ILogger<RethinkDbData>> ()))
elif isNotNull (config.GetConnectionString "LiteDB") then elif isNotNull (config.GetConnectionString "SQLite") then
Bson.registerAll () let conn = new SqliteConnection (config.GetConnectionString "SQLite")
let db = new LiteDatabase (config.GetConnectionString "LiteDB") Some (upcast SQLiteData conn)
Some (upcast LiteDbData db)
else else
None None
@ -86,19 +85,26 @@ let rec main args =
do! WebLogCache.fill data do! WebLogCache.fill data
do! ThemeAssetCache.fill data do! ThemeAssetCache.fill data
} |> Async.AwaitTask |> Async.RunSynchronously } |> Async.AwaitTask |> Async.RunSynchronously
builder.Services.AddSingleton<IData> data |> ignore
// Define distributed cache implementation based on data implementation // Define distributed cache implementation based on data implementation
match data with match data with
| :? RethinkDbData as rethink -> | :? RethinkDbData as rethink ->
// A RethinkDB connection is designed to work as a singleton
builder.Services.AddSingleton<IData> data |> ignore
builder.Services.AddDistributedRethinkDBCache (fun opts -> builder.Services.AddDistributedRethinkDBCache (fun opts ->
opts.TableName <- "Session" opts.TableName <- "Session"
opts.Connection <- rethink.Conn) opts.Connection <- rethink.Conn)
|> ignore |> ignore
| :? LiteDbData -> | :? SQLiteData ->
// ADO.NET connections are designed to work as per-request instantiation
builder.Services.AddScoped<SqliteConnection> (fun sp ->
let cfg = sp.GetRequiredService<IConfiguration> ()
new SqliteConnection (cfg.GetConnectionString "SQLite"))
|> ignore
builder.Services.AddScoped<IData, SQLiteData> () |> ignore
let log = sp.GetRequiredService<ILoggerFactory> () let log = sp.GetRequiredService<ILoggerFactory> ()
let logger = log.CreateLogger "MyWebLog.StartUp" let logger = log.CreateLogger "MyWebLog.StartUp"
logger.LogWarning "Session caching is not yet implemented via LiteDB; using memory cache for sessions" logger.LogWarning "Session caching is not yet implemented via SQLite; using memory cache for sessions"
builder.Services.AddDistributedMemoryCache () |> ignore builder.Services.AddDistributedMemoryCache () |> ignore
| _ -> () | _ -> ()
| None -> | None ->
@ -108,8 +114,6 @@ let rec main args =
opts.IdleTimeout <- TimeSpan.FromMinutes 60 opts.IdleTimeout <- TimeSpan.FromMinutes 60
opts.Cookie.HttpOnly <- true opts.Cookie.HttpOnly <- true
opts.Cookie.IsEssential <- true) opts.Cookie.IsEssential <- true)
// this needs to be after the session... maybe?
let _ = builder.Services.AddGiraffe () let _ = builder.Services.AddGiraffe ()
// Set up DotLiquid // Set up DotLiquid