diff --git a/src/MyWebLog.Data/Converters.fs b/src/MyWebLog.Data/Converters.fs index fc303b5..d0ad6d5 100644 --- a/src/MyWebLog.Data/Converters.fs +++ b/src/MyWebLog.Data/Converters.fs @@ -130,133 +130,3 @@ module Json = // Handles DUs with no associated data, as well as option fields 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 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 (AuthorizationLevelMapping.toBson, AuthorizationLevelMapping.fromBson) - g.RegisterType (CategoryIdMapping.toBson, CategoryIdMapping.fromBson) - g.RegisterType (CommentIdMapping.toBson, CommentIdMapping.fromBson) - g.RegisterType (CommentStatusMapping.toBson, CommentStatusMapping.fromBson) - g.RegisterType (CustomFeedIdMapping.toBson, CustomFeedIdMapping.fromBson) - g.RegisterType (CustomFeedSourceMapping.toBson, CustomFeedSourceMapping.fromBson) - g.RegisterType (ExplicitRatingMapping.toBson, ExplicitRatingMapping.fromBson) - g.RegisterType (MarkupTextMapping.toBson, MarkupTextMapping.fromBson) - g.RegisterType (PermalinkMapping.toBson, PermalinkMapping.fromBson) - g.RegisterType (PageIdMapping.toBson, PageIdMapping.fromBson) - g.RegisterType (PostIdMapping.toBson, PostIdMapping.fromBson) - g.RegisterType (PostStatusMapping.toBson, PostStatusMapping.fromBson) - g.RegisterType (TagMapIdMapping.toBson, TagMapIdMapping.fromBson) - g.RegisterType (ThemeAssetIdMapping.toBson, ThemeAssetIdMapping.fromBson) - g.RegisterType (ThemeIdMapping.toBson, ThemeIdMapping.fromBson) - g.RegisterType (WebLogIdMapping.toBson, WebLogIdMapping.fromBson) - g.RegisterType (WebLogUserIdMapping.toBson, WebLogUserIdMapping.fromBson) - - g.RegisterType (OptionMapping.categoryIdToBson, OptionMapping.categoryIdFromBson) - g.RegisterType (OptionMapping.commentIdToBson, OptionMapping.commentIdFromBson) - g.RegisterType (OptionMapping.dateTimeToBson, OptionMapping.dateTimeFromBson) - g.RegisterType (OptionMapping.intToBson, OptionMapping.intFromBson) - g.RegisterType (OptionMapping.podcastOptionsToBson, OptionMapping.podcastOptionsFromBson) - g.RegisterType (OptionMapping.stringToBson, OptionMapping.stringFromBson) - \ No newline at end of file diff --git a/src/MyWebLog.Data/LiteDbData.fs b/src/MyWebLog.Data/LiteDbData.fs deleted file mode 100644 index f1b8182..0000000 --- a/src/MyWebLog.Data/LiteDbData.fs +++ /dev/null @@ -1,584 +0,0 @@ -namespace MyWebLog.Dataa - -open LiteDB -open MyWebLog -open System.Threading.Tasks -open MyWebLog.Data - -/// Functions to assist with retrieving data -[] -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" - Comment = db.GetCollection "Comment" - Page = db.GetCollection "Page" - Post = db.GetCollection "Post" - TagMap = db.GetCollection "TagMap" - Theme = db.GetCollection "Theme" - ThemeAsset = db.GetCollection "ThemeAsset" - WebLog = db.GetCollection "WebLog" - WebLogUser = db.GetCollection "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 () - } diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index 244c2ba..3935956 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -10,7 +10,6 @@ - @@ -25,7 +24,6 @@ - diff --git a/src/MyWebLog.Data/SQLiteData.fs b/src/MyWebLog.Data/SQLiteData.fs index e5d5a9f..3b44612 100644 --- a/src/MyWebLog.Data/SQLiteData.fs +++ b/src/MyWebLog.Data/SQLiteData.fs @@ -50,6 +50,9 @@ module private SqliteHelpers = /// Get a date/time value from a data reader 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 let getInt col (rdr : SqliteDataReader) = rdr.GetInt32 (rdr.GetOrdinal col) @@ -212,6 +215,20 @@ module private SqliteHelpers = customFeeds = [] } } + + /// 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 @@ -287,6 +304,20 @@ type SQLiteData (conn : SqliteConnection) = ] |> ignore 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 let addWebLogId (cmd : SqliteCommand) webLogId = cmd.Parameters.AddWithValue ("@webLogId", WebLogId.toString webLogId) |> ignore @@ -473,28 +504,30 @@ type SQLiteData (conn : SqliteConnection) = |> 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 - let updatePostTags postId oldTags newTags = backgroundTask { + let updatePostTags postId (oldTags : string list) newTags = backgroundTask { let toDelete, toAdd = diffLists oldTags newTags id if List.isEmpty toDelete && List.isEmpty toAdd then return () else 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" toDelete - |> List.map runCmd + |> List.map (runPostCategoryCommand postId cmd) |> Task.WhenAll |> ignore cmd.CommandText <- "INSERT INTO post_tag VALUES (@postId, @tag)" toAdd - |> List.map runCmd + |> List.map (runPostCategoryCommand postId cmd) |> Task.WhenAll |> ignore } @@ -592,6 +625,15 @@ type SQLiteData (conn : SqliteConnection) = 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 member _.Conn = conn @@ -1597,48 +1639,83 @@ type SQLiteData (conn : SqliteConnection) = new IWebLogUserData with member _.add user = backgroundTask { - let _ = Collection.WebLogUser.Insert user - do! checkpoint () + use cmd = conn.CreateCommand () + 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 = - Collection.WebLogUser.Find (fun wlu -> wlu.webLogId = webLogId && wlu.userName = email) - |> tryFirst + member _.findByEmail email webLogId = backgroundTask { + use cmd = conn.CreateCommand () + 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 = - Collection.WebLogUser.FindById (WebLogUserIdMapping.toBson userId) - // |> verifyWebLog webLogId (fun u -> u.webLogId) + member _.findById userId webLogId = backgroundTask { + use cmd = conn.CreateCommand () + cmd.CommandText <- "SELECT * FROM web_log_user WHERE id = @id" + cmd.Parameters.AddWithValue ("@id", WebLogUserId.toString userId) |> ignore + use! rdr = cmd.ExecuteReaderAsync () + return verifyWebLog webLogId (fun u -> u.webLogId) Map.toWebLogUser rdr + } - member _.findByWebLog webLogId = - Collection.WebLogUser.Find (fun wlu -> wlu.webLogId = webLogId) - |> toList + member _.findByWebLog webLogId = backgroundTask { + use cmd = conn.CreateCommand () + 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 = - 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 _.findNames webLogId userIds = backgroundTask { + use cmd = conn.CreateCommand () + cmd.CommandText <- "SELECT * FROM web_log_user WHERE web_log_id = @webLogId AND id IN (" + 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 { - let _ = Collection.WebLogUser.InsertBulk users - do! checkpoint () + member this.restore users = backgroundTask { + for user in users do + do! this.add user } member _.update user = backgroundTask { - let _ = Collection.WebLogUser.Update user - do! checkpoint () + use cmd = conn.CreateCommand () + 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 { - 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" if not exists then use cmd = conn.CreateCommand () @@ -1846,4 +1923,3 @@ type SQLiteData (conn : SqliteConnection) = url_value TEXT NOT NULL)""" do! write cmd } - diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index 0013704..b6789d3 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -1,4 +1,6 @@ open Microsoft.AspNetCore.Http +open Microsoft.Data.Sqlite +open Microsoft.Extensions.Configuration open Microsoft.Extensions.Logging open MyWebLog @@ -31,8 +33,6 @@ 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 @@ -46,10 +46,9 @@ module DataImplementation = let rethinkCfg = DataConfig.FromConfiguration (config.GetSection "RethinkDB") let conn = rethinkCfg.CreateConnectionAsync () |> Async.AwaitTask |> Async.RunSynchronously Some (upcast RethinkDbData (conn, rethinkCfg, sp.GetRequiredService> ())) - elif isNotNull (config.GetConnectionString "LiteDB") then - Bson.registerAll () - let db = new LiteDatabase (config.GetConnectionString "LiteDB") - Some (upcast LiteDbData db) + elif isNotNull (config.GetConnectionString "SQLite") then + let conn = new SqliteConnection (config.GetConnectionString "SQLite") + Some (upcast SQLiteData conn) else None @@ -86,19 +85,26 @@ let rec main args = do! WebLogCache.fill data do! ThemeAssetCache.fill data } |> Async.AwaitTask |> Async.RunSynchronously - builder.Services.AddSingleton data |> ignore // Define distributed cache implementation based on data implementation match data with | :? RethinkDbData as rethink -> + // A RethinkDB connection is designed to work as a singleton + builder.Services.AddSingleton data |> ignore builder.Services.AddDistributedRethinkDBCache (fun opts -> opts.TableName <- "Session" opts.Connection <- rethink.Conn) |> ignore - | :? LiteDbData -> + | :? SQLiteData -> + // ADO.NET connections are designed to work as per-request instantiation + builder.Services.AddScoped (fun sp -> + let cfg = sp.GetRequiredService () + new SqliteConnection (cfg.GetConnectionString "SQLite")) + |> ignore + builder.Services.AddScoped () |> ignore let log = sp.GetRequiredService () 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 | _ -> () | None -> @@ -108,8 +114,6 @@ let rec main args = opts.IdleTimeout <- TimeSpan.FromMinutes 60 opts.Cookie.HttpOnly <- true opts.Cookie.IsEssential <- true) - - // this needs to be after the session... maybe? let _ = builder.Services.AddGiraffe () // Set up DotLiquid