From 476a3acd736e985d3d5864637d4164bf17f29070 Mon Sep 17 00:00:00 2001 From: "Daniel J. Summers" Date: Sun, 12 Jun 2022 23:13:12 -0400 Subject: [PATCH] First cut of multi-db data - Add data interface - Convert RethinkDB to interface implementation - Write LiteDB implementation / converters - Update all data access to use interface --- src/MyWebLog.Data/Converters.fs | 357 ++++++---- src/MyWebLog.Data/Data.fs | 915 ------------------------- src/MyWebLog.Data/Interfaces.fs | 248 +++++++ src/MyWebLog.Data/LiteDbData.fs | 526 ++++++++++++++ src/MyWebLog.Data/MyWebLog.Data.fsproj | 6 +- src/MyWebLog.Data/RethinkDbData.fs | 790 +++++++++++++++++++++ src/MyWebLog.Data/Utils.fs | 22 + src/MyWebLog/Caches.fs | 26 +- src/MyWebLog/Handlers/Admin.fs | 222 +++--- src/MyWebLog/Handlers/Feed.fs | 39 +- src/MyWebLog/Handlers/Helpers.fs | 20 +- src/MyWebLog/Handlers/Post.fs | 59 +- src/MyWebLog/Handlers/Routes.fs | 18 +- src/MyWebLog/Handlers/User.fs | 10 +- src/MyWebLog/Maintenance.fs | 104 ++- src/MyWebLog/Program.fs | 73 +- 16 files changed, 2149 insertions(+), 1286 deletions(-) delete mode 100644 src/MyWebLog.Data/Data.fs create mode 100644 src/MyWebLog.Data/Interfaces.fs create mode 100644 src/MyWebLog.Data/LiteDbData.fs create mode 100644 src/MyWebLog.Data/RethinkDbData.fs create mode 100644 src/MyWebLog.Data/Utils.fs diff --git a/src/MyWebLog.Data/Converters.fs b/src/MyWebLog.Data/Converters.fs index e776c1a..9a2ca9a 100644 --- a/src/MyWebLog.Data/Converters.fs +++ b/src/MyWebLog.Data/Converters.fs @@ -1,130 +1,247 @@ -/// JSON.NET converters for discriminated union types -[] -module MyWebLog.JsonConverters +/// Converters for discriminated union types +module MyWebLog.Converters open MyWebLog -open Newtonsoft.Json open System -type CategoryIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : CategoryId, _ : JsonSerializer) = - writer.WriteValue (CategoryId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : CategoryId, _ : bool, _ : JsonSerializer) = - (string >> CategoryId) reader.Value - -type CommentIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : CommentId, _ : JsonSerializer) = - writer.WriteValue (CommentId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : CommentId, _ : bool, _ : JsonSerializer) = - (string >> CommentId) reader.Value - -type CustomFeedIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : CustomFeedId, _ : JsonSerializer) = - writer.WriteValue (CustomFeedId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : CustomFeedId, _ : bool, _ : JsonSerializer) = - (string >> CustomFeedId) reader.Value - -type CustomFeedSourceConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : CustomFeedSource, _ : JsonSerializer) = - writer.WriteValue (CustomFeedSource.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : CustomFeedSource, _ : bool, _ : JsonSerializer) = - (string >> CustomFeedSource.parse) reader.Value - -type ExplicitRatingConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : ExplicitRating, _ : JsonSerializer) = - writer.WriteValue (ExplicitRating.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : ExplicitRating, _ : bool, _ : JsonSerializer) = - (string >> ExplicitRating.parse) reader.Value +/// JSON.NET converters for discriminated union types +module Json = -type MarkupTextConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : MarkupText, _ : JsonSerializer) = - writer.WriteValue (MarkupText.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : MarkupText, _ : bool, _ : JsonSerializer) = - (string >> MarkupText.parse) reader.Value - -type PermalinkConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : Permalink, _ : JsonSerializer) = - writer.WriteValue (Permalink.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : Permalink, _ : bool, _ : JsonSerializer) = - (string >> Permalink) reader.Value - -type PageIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : PageId, _ : JsonSerializer) = - writer.WriteValue (PageId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : PageId, _ : bool, _ : JsonSerializer) = - (string >> PageId) reader.Value - -type PostIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : PostId, _ : JsonSerializer) = - writer.WriteValue (PostId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : PostId, _ : bool, _ : JsonSerializer) = - (string >> PostId) reader.Value - -type TagMapIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : TagMapId, _ : JsonSerializer) = - writer.WriteValue (TagMapId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : TagMapId, _ : bool, _ : JsonSerializer) = - (string >> TagMapId) reader.Value - -type ThemeAssetIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : ThemeAssetId, _ : JsonSerializer) = - writer.WriteValue (ThemeAssetId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : ThemeAssetId, _ : bool, _ : JsonSerializer) = - (string >> ThemeAssetId.ofString) reader.Value - -type ThemeIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : ThemeId, _ : JsonSerializer) = - writer.WriteValue (ThemeId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : ThemeId, _ : bool, _ : JsonSerializer) = - (string >> ThemeId) reader.Value + open Newtonsoft.Json -type WebLogIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : WebLogId, _ : JsonSerializer) = - writer.WriteValue (WebLogId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : WebLogId, _ : bool, _ : JsonSerializer) = - (string >> WebLogId) reader.Value + type CategoryIdConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : CategoryId, _ : JsonSerializer) = + writer.WriteValue (CategoryId.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : CategoryId, _ : bool, _ : JsonSerializer) = + (string >> CategoryId) reader.Value -type WebLogUserIdConverter () = - inherit JsonConverter () - override _.WriteJson (writer : JsonWriter, value : WebLogUserId, _ : JsonSerializer) = - writer.WriteValue (WebLogUserId.toString value) - override _.ReadJson (reader : JsonReader, _ : Type, _ : WebLogUserId, _ : bool, _ : JsonSerializer) = - (string >> WebLogUserId) reader.Value + type CommentIdConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : CommentId, _ : JsonSerializer) = + writer.WriteValue (CommentId.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : CommentId, _ : bool, _ : JsonSerializer) = + (string >> CommentId) reader.Value -open Microsoft.FSharpLu.Json + type CustomFeedIdConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : CustomFeedId, _ : JsonSerializer) = + writer.WriteValue (CustomFeedId.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : CustomFeedId, _ : bool, _ : JsonSerializer) = + (string >> CustomFeedId) reader.Value -/// All converters to use for data conversion -let all () : JsonConverter seq = - seq { - // Our converters - CategoryIdConverter () - CommentIdConverter () - CustomFeedIdConverter () - CustomFeedSourceConverter () - ExplicitRatingConverter () - MarkupTextConverter () - PermalinkConverter () - PageIdConverter () - PostIdConverter () - TagMapIdConverter () - ThemeAssetIdConverter () - ThemeIdConverter () - WebLogIdConverter () - WebLogUserIdConverter () - // Handles DUs with no associated data, as well as option fields - CompactUnionJsonConverter () - } + type CustomFeedSourceConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : CustomFeedSource, _ : JsonSerializer) = + writer.WriteValue (CustomFeedSource.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : CustomFeedSource, _ : bool, _ : JsonSerializer) = + (string >> CustomFeedSource.parse) reader.Value + + type ExplicitRatingConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : ExplicitRating, _ : JsonSerializer) = + writer.WriteValue (ExplicitRating.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : ExplicitRating, _ : bool, _ : JsonSerializer) = + (string >> ExplicitRating.parse) reader.Value + + type MarkupTextConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : MarkupText, _ : JsonSerializer) = + writer.WriteValue (MarkupText.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : MarkupText, _ : bool, _ : JsonSerializer) = + (string >> MarkupText.parse) reader.Value + + type PermalinkConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : Permalink, _ : JsonSerializer) = + writer.WriteValue (Permalink.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : Permalink, _ : bool, _ : JsonSerializer) = + (string >> Permalink) reader.Value + type PageIdConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : PageId, _ : JsonSerializer) = + writer.WriteValue (PageId.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : PageId, _ : bool, _ : JsonSerializer) = + (string >> PageId) reader.Value + + type PostIdConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : PostId, _ : JsonSerializer) = + writer.WriteValue (PostId.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : PostId, _ : bool, _ : JsonSerializer) = + (string >> PostId) reader.Value + + type TagMapIdConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : TagMapId, _ : JsonSerializer) = + writer.WriteValue (TagMapId.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : TagMapId, _ : bool, _ : JsonSerializer) = + (string >> TagMapId) reader.Value + + type ThemeAssetIdConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : ThemeAssetId, _ : JsonSerializer) = + writer.WriteValue (ThemeAssetId.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : ThemeAssetId, _ : bool, _ : JsonSerializer) = + (string >> ThemeAssetId.ofString) reader.Value + + type ThemeIdConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : ThemeId, _ : JsonSerializer) = + writer.WriteValue (ThemeId.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : ThemeId, _ : bool, _ : JsonSerializer) = + (string >> ThemeId) reader.Value + + type WebLogIdConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : WebLogId, _ : JsonSerializer) = + writer.WriteValue (WebLogId.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : WebLogId, _ : bool, _ : JsonSerializer) = + (string >> WebLogId) reader.Value + + type WebLogUserIdConverter () = + inherit JsonConverter () + override _.WriteJson (writer : JsonWriter, value : WebLogUserId, _ : JsonSerializer) = + writer.WriteValue (WebLogUserId.toString value) + override _.ReadJson (reader : JsonReader, _ : Type, _ : WebLogUserId, _ : bool, _ : JsonSerializer) = + (string >> WebLogUserId) reader.Value + + open Microsoft.FSharpLu.Json + + /// All converters to use for data conversion + let all () : JsonConverter seq = + seq { + // Our converters + CategoryIdConverter () + CommentIdConverter () + CustomFeedIdConverter () + CustomFeedSourceConverter () + ExplicitRatingConverter () + MarkupTextConverter () + PermalinkConverter () + PageIdConverter () + PostIdConverter () + TagMapIdConverter () + ThemeAssetIdConverter () + ThemeIdConverter () + WebLogIdConverter () + WebLogUserIdConverter () + // 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 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 (CategoryIdMapping.toBson, CategoryIdMapping.fromBson) + g.RegisterType (CommentIdMapping.toBson, CommentIdMapping.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 (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/Data.fs b/src/MyWebLog.Data/Data.fs deleted file mode 100644 index 0a8401e..0000000 --- a/src/MyWebLog.Data/Data.fs +++ /dev/null @@ -1,915 +0,0 @@ -[] -module MyWebLog.Data - -/// Table names -[] -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 -[] -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 { 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 { 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 { 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 { - withTable Table.Category - getAll [ webLogId ] (nameof webLogId) - count - result; withRetryDefault - } - - /// Count top-level categories for a web log - let countTopLevel (webLogId : WebLogId) = - rethink { - 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 { - 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 { - 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 { - 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 { - 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 { - withTable Table.Page - getAll [ webLogId ] (nameof webLogId) - count - result; withRetryDefault - } - - /// Count listed pages for a web log - let countListed (webLogId : WebLogId) = - rethink { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - 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 { - withTable Table.Theme - get themeId - resultOption; withRetryOptionDefault - } - - /// Retrieve a theme by its ID, excluding the text of templates - let findByIdWithoutText (themeId : ThemeId) = - rethink { - 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 { - 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 { - withTable Table.ThemeAsset - get assetId - resultOption; withRetryOptionDefault - } - - /// List all assets for a theme (data excluded) - let findByThemeId (themeId : ThemeId) = - rethink { - 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 { - withTable Table.WebLog - result; withRetryDefault - } - - /// Retrieve a web log by the URL base - let findByHost (url : string) = - rethink { - withTable Table.WebLog - getAll [ url ] "urlBase" - limit 1 - result; withRetryDefault - } - |> tryFirst - - /// Retrieve a web log by its ID - let findById (webLogId : WebLogId) = - rethink { - 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 { - 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 { - 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 { - 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 - } - \ No newline at end of file diff --git a/src/MyWebLog.Data/Interfaces.fs b/src/MyWebLog.Data/Interfaces.fs new file mode 100644 index 0000000..747e1dc --- /dev/null +++ b/src/MyWebLog.Data/Interfaces.fs @@ -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 + + /// Count all categories for the given web log + abstract member countAll : WebLogId -> Task + + /// Count all top-level categories for the given web log + abstract member countTopLevel : WebLogId -> Task + + /// Delete a category (also removes it from posts) + abstract member delete : CategoryId -> WebLogId -> Task + + /// Find all categories for a web log, sorted alphabetically and grouped by hierarchy + abstract member findAllForView : WebLogId -> Task + + /// Find a category by its ID + abstract member findById : CategoryId -> WebLogId -> Task + + /// Update a category (slug, name, description, and parent ID) + abstract member update : Category -> Task + + +/// Data functions to support manipulating pages +type IPageData = + + /// Add a page + abstract member add : Page -> Task + + /// Get all pages for the web log (excluding text, revisions, and prior permalinks) + abstract member all : WebLogId -> Task + + /// Count all pages for the given web log + abstract member countAll : WebLogId -> Task + + /// Count pages marked as "show in page list" for the given web log + abstract member countListed : WebLogId -> Task + + /// Delete a page + abstract member delete : PageId -> WebLogId -> Task + + /// Find a page by its ID (excluding revisions and prior permalinks) + abstract member findById : PageId -> WebLogId -> Task + + /// Find a page by its permalink (excluding revisions and prior permalinks) + abstract member findByPermalink : Permalink -> WebLogId -> Task + + /// Find the current permalink for a page from a list of prior permalinks + abstract member findCurrentPermalink : Permalink list -> WebLogId -> Task + + /// Find a page by its ID (including revisions and prior permalinks) + abstract member findFullById : PageId -> WebLogId -> Task + + /// Find pages marked as "show in page list" for the given web log (excluding text, revisions, and prior permalinks) + abstract member findListed : WebLogId -> Task + + /// Find a page of pages (displayed in admin section) (excluding revisions and prior permalinks) + abstract member findPageOfPages : WebLogId -> pageNbr : int -> Task + + /// Update a page + abstract member update : Page -> Task + + /// Update the prior permalinks for the given page + abstract member updatePriorPermalinks : PageId -> WebLogId -> Permalink list -> Task + + +/// Data functions to support manipulating posts +type IPostData = + + /// Add a post + abstract member add : Post -> Task + + /// Count posts by their status + abstract member countByStatus : PostStatus -> WebLogId -> Task + + /// Delete a post + abstract member delete : PostId -> WebLogId -> Task + + /// Find a post by its permalink (excluding revisions and prior permalinks) + abstract member findByPermalink : Permalink -> WebLogId -> Task + + /// Find the current permalink for a post from a list of prior permalinks + abstract member findCurrentPermalink : Permalink list -> WebLogId -> Task + + /// Find a post by its ID (including revisions and prior permalinks) + abstract member findFullById : PostId -> WebLogId -> Task + + /// 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 + + /// Find posts to be displayed on an admin page (excluding revisions and prior permalinks) + abstract member findPageOfPosts : WebLogId -> pageNbr : int -> postsPerPage : int -> Task + + /// Find posts to be displayed on a page (excluding revisions and prior permalinks) + abstract member findPageOfPublishedPosts : WebLogId -> pageNbr : int -> postsPerPage : int -> Task + + /// 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 + + /// 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 + + /// Update a post + abstract member update : Post -> Task + + /// Update the prior permalinks for a post + abstract member updatePriorPermalinks : PostId -> WebLogId -> Permalink list -> Task + + +/// Functions to manipulate tag mappings +type ITagMapData = + + /// Retrieve all tag mappings for the given web log + abstract member all : WebLogId -> Task + + /// Delete a tag mapping + abstract member delete : TagMapId -> WebLogId -> Task + + /// Find a tag mapping by its ID + abstract member findById : TagMapId -> WebLogId -> Task + + /// Find a tag mapping by its URL value + abstract member findByUrlValue : string -> WebLogId -> Task + + /// Find tag mappings for the given tags + abstract member findMappingForTags : tags : string list -> WebLogId -> Task + + /// Save a tag mapping (insert or update) + abstract member save : TagMap -> Task + + +/// Functions to manipulate themes +type IThemeData = + + /// Retrieve all themes (except "admin") + abstract member all : unit -> Task + + /// Find a theme by its ID + abstract member findById : ThemeId -> Task + + /// Find a theme by its ID (excluding the text of its templates) + abstract member findByIdWithoutText : ThemeId -> Task + + /// Save a theme (insert or update) + abstract member save : Theme -> Task + + +/// Functions to manipulate theme assets +type IThemeAssetData = + + /// Retrieve all theme assets (excluding data) + abstract member all : unit -> Task + + /// Delete all theme assets for the given theme + abstract member deleteByTheme : ThemeId -> Task + + /// Find a theme asset by its ID + abstract member findById : ThemeAssetId -> Task + + /// Find all assets for the given theme (excludes data) + abstract member findByTheme : ThemeId -> Task + + /// Save a theme asset (insert or update) + abstract member save : ThemeAsset -> Task + + +/// Functions to manipulate web logs +type IWebLogData = + + /// Add a web log + abstract member add : WebLog -> Task + + /// Retrieve all web logs + abstract member all : unit -> Task + + /// Find a web log by its host (URL base) + abstract member findByHost : string -> Task + + /// Find a web log by its ID + abstract member findById : WebLogId -> Task + + /// Update RSS options for a web log + abstract member updateRssOptions : WebLog -> Task + + /// Update web log settings (from the settings page) + abstract member updateSettings : WebLog -> Task + + +/// Functions to manipulate web log users +type IWebLogUserData = + + /// Add a web log user + abstract member add : WebLogUser -> Task + + /// Find a web log user by their e-mail address + abstract member findByEmail : email : string -> WebLogId -> Task + + /// Find a web log user by their ID + abstract member findById : WebLogUserId -> WebLogId -> Task + + /// Get a user ID -> name dictionary for the given user IDs + abstract member findNames : WebLogId -> WebLogUserId list -> Task + + /// Update a web log user + abstract member update : WebLogUser -> Task + + +/// 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 + \ No newline at end of file diff --git a/src/MyWebLog.Data/LiteDbData.fs b/src/MyWebLog.Data/LiteDbData.fs new file mode 100644 index 0000000..3b65e65 --- /dev/null +++ b/src/MyWebLog.Data/LiteDbData.fs @@ -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 +[] +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 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 () + } diff --git a/src/MyWebLog.Data/MyWebLog.Data.fsproj b/src/MyWebLog.Data/MyWebLog.Data.fsproj index 5a868b4..d9579ee 100644 --- a/src/MyWebLog.Data/MyWebLog.Data.fsproj +++ b/src/MyWebLog.Data/MyWebLog.Data.fsproj @@ -10,6 +10,7 @@ + @@ -20,7 +21,10 @@ - + + + + diff --git a/src/MyWebLog.Data/RethinkDbData.fs b/src/MyWebLog.Data/RethinkDbData.fs new file mode 100644 index 0000000..1877c24 --- /dev/null +++ b/src/MyWebLog.Data/RethinkDbData.fs @@ -0,0 +1,790 @@ +namespace MyWebLog.Data + +open System.Threading.Tasks +open MyWebLog +open RethinkDb.Driver + +/// Functions to assist with retrieving data +[] +module private RethinkHelpers = + + /// Table names + [] + 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) = + + /// 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 { 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 { + withTable Table.Category + getAll [ webLogId ] (nameof webLogId) + count + result; withRetryDefault conn + } + + member _.countTopLevel webLogId = rethink { + withTable Table.Category + getAll [ webLogId ] (nameof webLogId) + filter "parentId" None + count + result; withRetryDefault conn + } + + member _.findAllForView webLogId = backgroundTask { + let! cats = rethink { + 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 { + 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 { + 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 { + 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 { + withTable Table.Page + getAll [ webLogId ] (nameof webLogId) + count + result; withRetryDefault conn + } + + member _.countListed webLogId = rethink { + withTable Table.Page + getAll [ webLogId ] (nameof webLogId) + filter "showInPageList" true + count + result; withRetryDefault conn + } + + member _.delete pageId webLogId = backgroundTask { + let! result = rethink { + 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 { + withTable Table.Page + get pageId + resultOption; withRetryOptionDefault + } + |> verifyWebLog webLogId (fun it -> it.webLogId) <| conn + + member _.findById pageId webLogId = + rethink { + withTable Table.Page + get pageId + without [ "priorPermalinks"; "revisions" ] + resultOption; withRetryOptionDefault + } + |> verifyWebLog webLogId (fun it -> it.webLogId) <| conn + + member _.findByPermalink permalink webLogId = + rethink { + 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 { + 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 { + 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 { + 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 { + withTable Table.Post + getAll [ webLogId ] (nameof webLogId) + filter "status" status + count + result; withRetryDefault conn + } + + member _.delete postId webLogId = backgroundTask { + let! result = rethink { + 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 { + withTable Table.Post + getAll [ r.Array (webLogId, permalink) ] (nameof permalink) + without [ "priorPermalinks"; "revisions" ] + limit 1 + result; withRetryDefault + } + |> tryFirst <| conn + + member _.findFullById postId webLogId = + rethink { + withTable Table.Post + get postId + resultOption; withRetryOptionDefault + } + |> verifyWebLog webLogId (fun p -> p.webLogId) <| conn + + member _.findCurrentPermalink permalinks webLogId = backgroundTask { + let! result = + (rethink { + 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 { + 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 { + 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 { + 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 { + 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 { + 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 { + 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 { + 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 { + 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 { + 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 { + withTable Table.TagMap + get tagMapId + resultOption; withRetryOptionDefault + } + |> verifyWebLog webLogId (fun tm -> tm.webLogId) <| conn + + member _.findByUrlValue urlValue webLogId = + rethink { + withTable Table.TagMap + getAll [ r.Array (webLogId, urlValue) ] "webLogAndUrl" + limit 1 + result; withRetryDefault + } + |> tryFirst <| conn + + member _.findMappingForTags tags webLogId = rethink { + 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 { + withTable Table.Theme + filter (fun row -> row["id"].Ne "admin" :> obj) + without [ "templates" ] + orderBy "id" + result; withRetryDefault conn + } + + member _.findById themeId = rethink { + withTable Table.Theme + get themeId + resultOption; withRetryOptionDefault conn + } + + member _.findByIdWithoutText themeId = rethink { + 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 { + 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 { + withTable Table.ThemeAsset + get assetId + resultOption; withRetryOptionDefault conn + } + + member _.findByTheme themeId = rethink { + 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 { + withTable Table.WebLog + result; withRetryDefault conn + } + + member _.findByHost url = + rethink { + withTable Table.WebLog + getAll [ url ] "urlBase" + limit 1 + result; withRetryDefault + } + |> tryFirst <| conn + + member _.findById webLogId = rethink { + 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 { + withTable Table.WebLogUser + getAll [ r.Array (webLogId, email) ] "logOn" + limit 1 + result; withRetryDefault + } + |> tryFirst <| conn + + member _.findById userId webLogId = + rethink { + withTable Table.WebLogUser + get userId + resultOption; withRetryOptionDefault + } + |> verifyWebLog webLogId (fun u -> u.webLogId) <| conn + + member _.findNames webLogId userIds = backgroundTask { + let! users = rethink { + 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 { 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 { 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" ] + } diff --git a/src/MyWebLog.Data/Utils.fs b/src/MyWebLog.Data/Utils.fs new file mode 100644 index 0000000..e435067 --- /dev/null +++ b/src/MyWebLog.Data/Utils.fs @@ -0,0 +1,22 @@ +/// Utility functions for manipulating data +[] +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) +} + diff --git a/src/MyWebLog/Caches.fs b/src/MyWebLog/Caches.fs index dc93aa7..c391216 100644 --- a/src/MyWebLog/Caches.fs +++ b/src/MyWebLog/Caches.fs @@ -1,20 +1,20 @@ namespace MyWebLog open Microsoft.AspNetCore.Http +open MyWebLog.Data /// Extension properties on HTTP context for web log [] module Extensions = open Microsoft.Extensions.DependencyInjection - open RethinkDb.Driver.Net type HttpContext with /// The web log for the current request member this.WebLog = this.Items["webLog"] :?> WebLog - /// The RethinkDB data connection - member this.Conn = this.RequestServices.GetRequiredService () + /// The data implementation + member this.Data = this.RequestServices.GetRequiredService () open System.Collections.Concurrent @@ -41,8 +41,8 @@ module WebLogCache = _cache <- webLog :: (_cache |> List.filter (fun wl -> wl.id <> webLog.id)) /// Fill the web log cache from the database - let fill conn = backgroundTask { - let! webLogs = Data.WebLog.all conn + let fill (data : IData) = backgroundTask { + let! webLogs = data.WebLog.all () _cache <- webLogs } @@ -64,7 +64,7 @@ module PageListCache = /// Update the pages for the current web log let update (ctx : HttpContext) = backgroundTask { let webLog = ctx.WebLog - let! pages = Data.Page.findListed webLog.id ctx.Conn + let! pages = ctx.Data.Page.findListed webLog.id _cache[webLog.urlBase] <- pages |> List.map (fun pg -> DisplayPage.fromPage webLog { pg with text = "" }) @@ -88,7 +88,7 @@ module CategoryCache = /// Update the cache with fresh data 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 } @@ -107,12 +107,12 @@ module TemplateCache = let private hasInclude = Regex ("""{% include_template \"(.*)\" %}""", RegexOptions.None, TimeSpan.FromSeconds 2) /// 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}" match _cache.ContainsKey templatePath with | true -> () | false -> - match! Data.Theme.findById (ThemeId themeId) conn with + match! data.Theme.findById (ThemeId themeId) with | Some theme -> let mutable text = (theme.templates |> List.find (fun t -> t.name = templateName)).text while hasInclude.IsMatch text do @@ -142,14 +142,14 @@ module ThemeAssetCache = let get themeId = _cache[themeId] /// Refresh the list of assets for the given theme - let refreshTheme themeId conn = backgroundTask { - let! assets = Data.ThemeAsset.findByThemeId themeId conn + let refreshTheme themeId (data : IData) = backgroundTask { + let! assets = data.ThemeAsset.findByTheme themeId _cache[themeId] <- assets |> List.map (fun a -> match a.id with ThemeAssetId (_, path) -> path) } /// Fill the theme asset cache - let fill conn = backgroundTask { - let! assets = Data.ThemeAsset.all conn + let fill (data : IData) = backgroundTask { + let! assets = data.ThemeAsset.all () for asset in assets do let (ThemeAssetId (themeId, path)) = asset.id if not (_cache.ContainsKey themeId) then _cache[themeId] <- [] diff --git a/src/MyWebLog/Handlers/Admin.fs b/src/MyWebLog/Handlers/Admin.fs index a458398..2e7ba7c 100644 --- a/src/MyWebLog/Handlers/Admin.fs +++ b/src/MyWebLog/Handlers/Admin.fs @@ -1,48 +1,35 @@ /// Handlers to manipulate admin functions 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 DotLiquid open Giraffe open MyWebLog open MyWebLog.ViewModels -open RethinkDb.Driver.Net // GET /admin let dashboard : HttpHandler = fun next ctx -> task { let webLogId = ctx.WebLog.id - let conn = ctx.Conn - let getCount (f : WebLogId -> IConnection -> Task) = f webLogId conn - let! posts = Data.Post.countByStatus Published |> getCount - let! drafts = Data.Post.countByStatus Draft |> getCount - let! pages = Data.Page.countAll |> getCount - let! listed = Data.Page.countListed |> getCount - let! cats = Data.Category.countAll |> getCount - let! topCats = Data.Category.countTopLevel |> getCount + let data = ctx.Data + let getCount (f : WebLogId -> Task) = f webLogId + let! posts = data.Post.countByStatus Published |> getCount + let! drafts = data.Post.countByStatus Draft |> getCount + let! pages = data.Page.countAll |> getCount + let! listed = data.Page.countListed |> getCount + let! cats = data.Category.countAll |> getCount + let! topCats = data.Category.countTopLevel |> getCount return! - Hash.FromAnonymousObject - {| page_title = "Dashboard" - model = - { posts = posts - drafts = drafts - pages = pages - listedPages = listed - categories = cats - topLevelCategories = topCats - } - |} + Hash.FromAnonymousObject {| + page_title = "Dashboard" + model = + { posts = posts + drafts = drafts + pages = pages + listedPages = listed + categories = cats + topLevelCategories = topCats + } + |} |> viewForTheme "admin" "dashboard" next ctx } @@ -50,7 +37,7 @@ let dashboard : HttpHandler = fun next ctx -> task { // GET /admin/categories 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 {| web_log = ctx.WebLog categories = CategoryCache.get ctx @@ -78,7 +65,7 @@ let editCategory catId : HttpHandler = fun next ctx -> task { match catId with | "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) | None -> return None } @@ -98,12 +85,12 @@ let editCategory catId : HttpHandler = fun next ctx -> task { // POST /admin/category/save let saveCategory : HttpHandler = fun next ctx -> task { let webLog = ctx.WebLog - let conn = ctx.Conn + let data = ctx.Data let! model = ctx.BindFormAsync () let! category = task { match model.categoryId with | "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 | Some cat -> @@ -114,7 +101,7 @@ let saveCategory : HttpHandler = fun next ctx -> task { description = if model.description = "" then None else Some model.description 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! addMessage ctx { UserMessage.success with message = "Category saved successfully" } return! listCategoriesBare next ctx @@ -123,8 +110,7 @@ let saveCategory : HttpHandler = fun next ctx -> task { // POST /admin/category/{id}/delete let deleteCategory catId : HttpHandler = fun next ctx -> task { - let webLog = ctx.WebLog - match! Data.Category.delete (CategoryId catId) webLog.id ctx.Conn with + match! ctx.Data.Category.delete (CategoryId catId) ctx.WebLog.id with | true -> do! CategoryCache.update ctx do! addMessage ctx { UserMessage.success with message = "Category deleted successfully" } @@ -138,16 +124,16 @@ let deleteCategory catId : HttpHandler = fun next ctx -> task { // GET /admin/pages/page/{pageNbr} let listPages pageNbr : HttpHandler = fun next ctx -> task { let webLog = ctx.WebLog - let! pages = Data.Page.findPageOfPages webLog.id pageNbr ctx.Conn + let! pages = ctx.Data.Page.findPageOfPages webLog.id pageNbr return! - Hash.FromAnonymousObject - {| csrf = csrfToken ctx - pages = pages |> List.map (DisplayPage.fromPageMinimal webLog) - page_title = "Pages" - page_nbr = pageNbr - prev_page = if pageNbr = 2 then "" else $"/page/{pageNbr - 1}" - next_page = $"/page/{pageNbr + 1}" - |} + Hash.FromAnonymousObject {| + csrf = csrfToken ctx + pages = pages |> List.map (DisplayPage.fromPageMinimal webLog) + page_title = "Pages" + page_nbr = pageNbr + prev_page = if pageNbr = 2 then "" else $"/page/{pageNbr - 1}" + next_page = $"/page/{pageNbr + 1}" + |} |> viewForTheme "admin" "page-list" next ctx } @@ -157,7 +143,7 @@ let editPage pgId : HttpHandler = fun next ctx -> task { match pgId with | "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) | None -> return None } @@ -180,7 +166,7 @@ let editPage pgId : HttpHandler = fun next ctx -> task { // GET /admin/page/{id}/permalinks 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 -> return! Hash.FromAnonymousObject {| @@ -197,7 +183,7 @@ let savePagePermalinks : HttpHandler = fun next ctx -> task { let webLog = ctx.WebLog let! model = ctx.BindFormAsync () 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 -> do! addMessage ctx { UserMessage.success with message = "Page permalinks saved successfully" } 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 let deletePage pgId : HttpHandler = fun next ctx -> task { 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 -> do! PageListCache.update ctx do! addMessage ctx { UserMessage.success with message = "Page deleted successfully" } @@ -223,7 +209,7 @@ open System let savePage : HttpHandler = fun next ctx -> task { let! model = ctx.BindFormAsync () let webLog = ctx.WebLog - let conn = ctx.Conn + let data = ctx.Data let now = DateTime.UtcNow let! pg = task { match model.pageId with @@ -235,7 +221,7 @@ let savePage : HttpHandler = fun next ctx -> task { authorId = userId ctx publishedOn = now } - | pgId -> return! Data.Page.findByFullId (PageId pgId) webLog.id conn + | pgId -> return! data.Page.findFullById (PageId pgId) webLog.id } match pg with | Some page -> @@ -264,7 +250,7 @@ let savePage : HttpHandler = fun next ctx -> task { | Some r when r.text = revision.text -> 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 do! addMessage ctx { UserMessage.success with message = "Page saved successfully" } return! @@ -278,7 +264,7 @@ open Microsoft.AspNetCore.Http /// Get the hash necessary to render the tag mapping list 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 {| web_log = ctx.WebLog csrf = csrfToken ctx @@ -290,7 +276,7 @@ let private tagMappingHash (ctx : HttpContext) = task { // GET /admin/settings/tag-mappings let tagMappings : HttpHandler = fun next ctx -> task { 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 ("page_title", "Tag Mappings") @@ -311,32 +297,31 @@ let editMapping tagMapId : HttpHandler = fun next ctx -> task { if isNew then Task.FromResult (Some { TagMap.empty with id = TagMapId "new" }) else - Data.TagMap.findById (TagMapId tagMapId) ctx.WebLog.id ctx.Conn + ctx.Data.TagMap.findById (TagMapId tagMapId) ctx.WebLog.id match! tagMap with | Some tm -> return! - Hash.FromAnonymousObject - {| csrf = csrfToken ctx - model = EditTagMapModel.fromMapping tm - page_title = if isNew then "Add Tag Mapping" else $"Mapping for {tm.tag} Tag" - |} + Hash.FromAnonymousObject {| + csrf = csrfToken ctx + model = EditTagMapModel.fromMapping tm + page_title = if isNew then "Add Tag Mapping" else $"Mapping for {tm.tag} Tag" + |} |> bareForTheme "admin" "tag-mapping-edit" next ctx | None -> return! Error.notFound next ctx } // POST /admin/settings/tag-mapping/save let saveMapping : HttpHandler = fun next ctx -> task { - let webLog = ctx.WebLog - let conn = ctx.Conn + let data = ctx.Data let! model = ctx.BindFormAsync () let tagMap = 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 - Data.TagMap.findById (TagMapId model.id) webLog.id conn + data.TagMap.findById (TagMapId model.id) ctx.WebLog.id match! tagMap with | 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" } return! tagMappingsBare 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 let deleteMapping tagMapId : HttpHandler = fun next ctx -> task { - let webLog = ctx.WebLog - match! Data.TagMap.delete (TagMapId tagMapId) webLog.id ctx.Conn with + match! ctx.Data.TagMap.delete (TagMapId tagMapId) ctx.WebLog.id with | 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" } return! tagMappingsBare next ctx @@ -353,8 +337,10 @@ let deleteMapping tagMapId : HttpHandler = fun next ctx -> task { // -- THEMES -- +open System.IO open System.IO.Compression open System.Text.RegularExpressions +open MyWebLog.Data // GET /admin/theme/update let themeUpdatePage : HttpHandler = fun next ctx -> task { @@ -371,20 +357,20 @@ let private updateNameAndVersion (theme : Theme) (zip : ZipArchive) = background let now () = DateTime.UtcNow.ToString "yyyyMMdd.HHmm" match zip.Entries |> Seq.filter (fun it -> it.FullName = "version.txt") |> Seq.tryHead with | Some versionItem -> - use versionFile = new StreamReader(versionItem.Open ()) + use versionFile = new StreamReader(versionItem.Open ()) let! versionText = versionFile.ReadToEndAsync () - let parts = versionText.Trim().Replace("\r", "").Split "\n" - let displayName = if parts[0] > "" then parts[0] else ThemeId.toString theme.id - let version = if parts.Length > 1 && parts[1] > "" then parts[1] else now () + let parts = versionText.Trim().Replace("\r", "").Split "\n" + let displayName = if parts[0] > "" then parts[0] else ThemeId.toString theme.id + let version = if parts.Length > 1 && parts[1] > "" then parts[1] else now () return { theme with name = displayName; version = version } | None -> return { theme with name = ThemeId.toString theme.id; version = now () } } /// 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 - do! Data.ThemeAsset.deleteByTheme theme.id conn + do! data.ThemeAsset.deleteByTheme theme.id return { theme with templates = [] } else return theme @@ -409,38 +395,38 @@ let private updateTemplates (theme : Theme) (zip : ZipArchive) = backgroundTask } /// 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 let assetName = asset.FullName.Replace ("wwwroot/", "") if assetName <> "" && not (assetName.EndsWith "/") then use stream = new MemoryStream () do! asset.Open().CopyToAsync stream - do! Data.ThemeAsset.save + do! data.ThemeAsset.save { id = ThemeAssetId (themeId, assetName) updatedOn = asset.LastWriteTime.DateTime data = stream.ToArray () - } conn + } } /// Get the theme name from the file name given let getThemeName (fileName : string) = 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 -let loadThemeFromZip themeName file clean conn = backgroundTask { +let loadThemeFromZip themeName file clean (data : IData) = backgroundTask { use zip = new ZipArchive (file, ZipArchiveMode.Read) let themeId = ThemeId themeName let! theme = backgroundTask { - match! Data.Theme.findById themeId conn with + match! data.Theme.findById themeId with | Some t -> return t | None -> return { Theme.empty with id = themeId } } let! theme = updateNameAndVersion theme zip - let! theme = checkForCleanLoad theme clean conn + let! theme = checkForCleanLoad theme clean data let! theme = updateTemplates theme zip - do! updateAssets themeId zip conn - do! Data.Theme.save theme conn + do! updateAssets themeId zip data + do! data.Theme.save theme } // 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 let themeFile = Seq.head ctx.Request.Form.Files match getThemeName themeFile.FileName with - | Some themeName -> - // TODO: add restriction for admin theme based on role - let conn = ctx.Conn + | Ok themeName when themeName <> "admin" -> + let data = ctx.Data use stream = new MemoryStream () do! themeFile.CopyToAsync stream - do! loadThemeFromZip themeName stream true conn - do! ThemeAssetCache.refreshTheme (ThemeId themeName) conn + do! loadThemeFromZip themeName stream true data + do! ThemeAssetCache.refreshTheme (ThemeId themeName) data do! addMessage ctx { UserMessage.success with message = "Theme updated successfully" } return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/dashboard")) next ctx - | None -> - do! addMessage ctx { UserMessage.error with message = $"Theme file name {themeFile.FileName} is invalid" } + | Ok _ -> + 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 else return! RequestErrors.BAD_REQUEST "Bad request" next ctx @@ -466,42 +454,46 @@ let updateTheme : HttpHandler = fun next ctx -> task { // -- WEB LOG SETTINGS -- +open System.Collections.Generic + // GET /admin/settings let settings : HttpHandler = fun next ctx -> task { let webLog = ctx.WebLog - let! allPages = Data.Page.findAll webLog.id ctx.Conn - let! themes = Data.Theme.list ctx.Conn + let data = ctx.Data + let! allPages = data.Page.all webLog.id + let! themes = data.Theme.all () return! - Hash.FromAnonymousObject - {| csrf = csrfToken ctx - model = SettingsModel.fromWebLog webLog - pages = - seq { - KeyValuePair.Create ("posts", "- First Page of Posts -") - yield! allPages - |> List.sortBy (fun p -> p.title.ToLower ()) - |> List.map (fun p -> KeyValuePair.Create (PageId.toString p.id, p.title)) - } - |> Array.ofSeq - themes = themes - |> Seq.ofList - |> Seq.map (fun it -> KeyValuePair.Create (ThemeId.toString it.id, $"{it.name} (v{it.version})")) - |> Array.ofSeq - web_log = webLog - page_title = "Web Log Settings" - |} + Hash.FromAnonymousObject {| + csrf = csrfToken ctx + model = SettingsModel.fromWebLog webLog + pages = + seq { + KeyValuePair.Create ("posts", "- First Page of Posts -") + yield! allPages + |> List.sortBy (fun p -> p.title.ToLower ()) + |> List.map (fun p -> KeyValuePair.Create (PageId.toString p.id, p.title)) + } + |> Array.ofSeq + themes = themes + |> Seq.ofList + |> Seq.map (fun it -> + KeyValuePair.Create (ThemeId.toString it.id, $"{it.name} (v{it.version})")) + |> Array.ofSeq + web_log = webLog + page_title = "Web Log Settings" + |} |> viewForTheme "admin" "settings" next ctx } // POST /admin/settings let saveSettings : HttpHandler = fun next ctx -> task { let webLog = ctx.WebLog - let conn = ctx.Conn + let data = ctx.Data let! model = ctx.BindFormAsync () - match! Data.WebLog.findById webLog.id conn with + match! data.WebLog.findById webLog.id with | Some webLog -> let webLog = model.update webLog - do! Data.WebLog.updateSettings webLog conn + do! data.WebLog.updateSettings webLog // Update cache WebLogCache.set webLog diff --git a/src/MyWebLog/Handlers/Feed.fs b/src/MyWebLog/Handlers/Feed.fs index 076c22a..4745ed2 100644 --- a/src/MyWebLog/Handlers/Feed.fs +++ b/src/MyWebLog/Handlers/Feed.fs @@ -46,18 +46,19 @@ let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option = None /// 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 cat = CategoryCache.get ctx |> Array.find (fun c -> c.id = CategoryId.toString catId) getCategoryIds cat.slug ctx + let data = ctx.Data match feedType with - | StandardFeed _ -> Data.Post.findPageOfPublishedPosts webLog.id 1 - | CategoryFeed (catId, _) -> Data.Post.findPageOfCategorizedPosts webLog.id (childIds catId) 1 - | TagFeed (tag, _) -> Data.Post.findPageOfTaggedPosts webLog.id tag 1 + | StandardFeed _ -> data.Post.findPageOfPublishedPosts ctx.WebLog.id 1 + | CategoryFeed (catId, _) -> data.Post.findPageOfCategorizedPosts ctx.WebLog.id (childIds catId) 1 + | TagFeed (tag, _) -> data.Post.findPageOfTaggedPosts ctx.WebLog.id tag 1 | Custom (feed, _) -> match feed.source with - | Category catId -> Data.Post.findPageOfCategorizedPosts webLog.id (childIds catId) 1 - | Tag tag -> Data.Post.findPageOfTaggedPosts webLog.id tag 1 + | Category catId -> data.Post.findPageOfCategorizedPosts ctx.WebLog.id (childIds catId) 1 + | Tag tag -> data.Post.findPageOfTaggedPosts ctx.WebLog.id tag 1 /// Strip HTML from a string let private stripHtml text = WebUtility.HtmlDecode <| Regex.Replace (text, "<(.|\n)*?>", "") @@ -304,9 +305,9 @@ let private setTitleAndDescription feedType (webLog : WebLog) (cats : DisplayCat /// Create a feed with a known non-zero-length list of posts let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backgroundTask { let webLog = ctx.WebLog - let conn = ctx.Conn - let! authors = getAuthors webLog posts conn - let! tagMaps = getTagMappings webLog posts conn + let data = ctx.Data + let! authors = getAuthors webLog posts data + let! tagMaps = getTagMappings webLog posts data let cats = CategoryCache.get ctx let podcast = match feedType with Custom (feed, _) when Option.isSome feed.podcast -> Some feed | _ -> None 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} 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 | _ -> return! Error.notFound next ctx } @@ -378,12 +379,12 @@ let editSettings : HttpHandler = fun next ctx -> task { // POST: /admin/rss/settings let saveSettings : HttpHandler = fun next ctx -> task { - let conn = ctx.Conn + let data = ctx.Data let! model = ctx.BindFormAsync () - match! Data.WebLog.findById ctx.WebLog.id conn with + match! data.WebLog.findById ctx.WebLog.id with | Some webLog -> let webLog = { webLog with rss = model.updateOptions webLog.rss } - do! Data.WebLog.updateRssOptions webLog conn + do! data.WebLog.updateRssOptions webLog WebLogCache.set webLog do! addMessage ctx { UserMessage.success with message = "RSS settings updated successfully" } 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 let saveCustomFeed : HttpHandler = fun next ctx -> task { - let conn = ctx.Conn - match! Data.WebLog.findById ctx.WebLog.id conn with + let data = ctx.Data + match! data.WebLog.findById ctx.WebLog.id with | Some webLog -> let! model = ctx.BindFormAsync () let theFeed = @@ -422,7 +423,7 @@ let saveCustomFeed : HttpHandler = fun next ctx -> task { | Some feed -> let feeds = model.updateFeed feed :: (webLog.rss.customFeeds |> List.filter (fun it -> it.id <> feed.id)) let webLog = { webLog with rss = { webLog.rss with customFeeds = feeds } } - do! Data.WebLog.updateRssOptions webLog conn + do! data.WebLog.updateRssOptions webLog WebLogCache.set webLog do! addMessage ctx { UserMessage.success with @@ -436,8 +437,8 @@ let saveCustomFeed : HttpHandler = fun next ctx -> task { // POST /admin/rss/{id}/delete let deleteCustomFeed feedId : HttpHandler = fun next ctx -> task { - let conn = ctx.Conn - match! Data.WebLog.findById ctx.WebLog.id conn with + let data = ctx.Data + match! data.WebLog.findById ctx.WebLog.id with | Some webLog -> let customId = CustomFeedId feedId 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) } } - do! Data.WebLog.updateRssOptions webLog conn + do! data.WebLog.updateRssOptions webLog WebLogCache.set webLog do! addMessage ctx { UserMessage.success with message = "Custom feed deleted successfully" } else diff --git a/src/MyWebLog/Handlers/Helpers.fs b/src/MyWebLog/Handlers/Helpers.fs index 36b2330..35e6d9b 100644 --- a/src/MyWebLog/Handlers/Helpers.fs +++ b/src/MyWebLog/Handlers/Helpers.fs @@ -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 // 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) // ...then render that content with its layout 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 } @@ -123,10 +123,10 @@ let bareForTheme theme template next ctx = fun (hash : Hash) -> task { do! populateHash hash ctx // 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) - let! layoutTemplate = TemplateCache.get theme "layout-bare" ctx.Conn + let! layoutTemplate = TemplateCache.get theme "layout-bare" ctx.Data // add messages as HTTP headers let messages = hash["messages"] :?> UserMessage[] @@ -182,11 +182,11 @@ let validateCsrf : HttpHandler = fun next ctx -> task { let requireUser : HttpHandler = requiresAuthentication Error.notAuthorized 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) 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 -> return seq { 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 -let getAuthors (webLog : WebLog) (posts : Post list) conn = +let getAuthors (webLog : WebLog) (posts : Post list) (data : IData) = posts |> List.map (fun p -> p.authorId) |> 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 -let getTagMappings (webLog : WebLog) (posts : Post list) = +let getTagMappings (webLog : WebLog) (posts : Post list) (data : IData) = posts |> List.map (fun p -> p.tags) |> List.concat |> 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) let getCategoryIds slug ctx = diff --git a/src/MyWebLog/Handlers/Post.fs b/src/MyWebLog/Handlers/Post.fs index 2b3078e..6a6ba9e 100644 --- a/src/MyWebLog/Handlers/Post.fs +++ b/src/MyWebLog/Handlers/Post.fs @@ -36,12 +36,13 @@ type ListType = open System.Threading.Tasks open DotLiquid +open MyWebLog.Data open MyWebLog.ViewModels /// Convert a list of posts into items ready to be displayed -let preparePostList webLog posts listType (url : string) pageNbr perPage ctx conn = task { - let! authors = getAuthors webLog posts conn - let! tagMappings = getTagMappings webLog posts conn +let preparePostList webLog posts listType (url : string) pageNbr perPage ctx (data : IData) = task { + let! authors = getAuthors webLog posts data + let! tagMappings = getTagMappings webLog posts data let relUrl it = Some <| WebLog.relativeUrl webLog (Permalink it) let postItems = posts @@ -54,7 +55,7 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage ctx con | SinglePost -> let post = List.head posts let dateTime = defaultArg post.publishedOn post.updatedOn - Data.Post.findSurroundingPosts webLog.id dateTime conn + data.Post.findSurroundingPosts webLog.id dateTime | _ -> Task.FromResult (None, None) let newerLink = match listType, pageNbr with @@ -98,9 +99,9 @@ open Giraffe // GET /page/{pageNbr} let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task { let webLog = ctx.WebLog - let conn = ctx.Conn - let! posts = Data.Post.findPageOfPublishedPosts webLog.id pageNbr webLog.postsPerPage conn - let! hash = preparePostList webLog posts PostList "" pageNbr webLog.postsPerPage ctx conn + let data = ctx.Data + let! posts = data.Post.findPageOfPublishedPosts webLog.id pageNbr webLog.postsPerPage + let! hash = preparePostList webLog posts PostList "" pageNbr webLog.postsPerPage ctx data let title = match pageNbr, webLog.defaultPage with | 1, "posts" -> None @@ -119,7 +120,7 @@ let redirectToPageOfPosts (pageNbr : int) : HttpHandler = fun next ctx -> // GET /category/{slug}/page/{pageNbr} let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task { let webLog = ctx.WebLog - let conn = ctx.Conn + let data = ctx.Data match parseSlugAndPage webLog slugAndPage with | Some pageNbr, slug, isFeed -> 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 | Some cat -> // Category pages include posts in subcategories - match! Data.Post.findPageOfCategorizedPosts webLog.id (getCategoryIds slug ctx) pageNbr webLog.postsPerPage - conn with + match! data.Post.findPageOfCategorizedPosts webLog.id (getCategoryIds slug ctx) pageNbr webLog.postsPerPage + with | 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 $""" (Page {pageNbr})""" hash.Add ("page_title", $"{cat.name}: Category Archive{pgTitle}") hash.Add ("subtitle", defaultArg cat.description "") @@ -150,12 +151,12 @@ open System.Web // GET /tag/{tag}/page/{pageNbr} let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task { let webLog = ctx.WebLog - let conn = ctx.Conn + let data = ctx.Data match parseSlugAndPage webLog slugAndPage with | Some pageNbr, rawTag, isFeed -> let urlTag = HttpUtility.UrlDecode rawTag 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 | 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}")) (defaultArg webLog.rss.itemsInFeed webLog.postsPerPage) next ctx 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 -> - 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 $""" (Page {pageNbr})""" hash.Add ("page_title", $"Posts Tagged “{tag}”{pgTitle}") 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 | _ -> 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 -> let endUrl = if pageNbr = 1 then "" else $"page/{pageNbr}" return! @@ -192,7 +193,7 @@ let home : HttpHandler = fun next ctx -> task { match webLog.defaultPage with | "posts" -> return! pageOfPosts 1 next ctx | pageId -> - match! Data.Page.findById (PageId pageId) webLog.id ctx.Conn with + match! ctx.Data.Page.findById (PageId pageId) webLog.id with | Some page -> return! Hash.FromAnonymousObject {| @@ -209,9 +210,9 @@ let home : HttpHandler = fun next ctx -> task { // GET /admin/posts/page/{pageNbr} let all pageNbr : HttpHandler = fun next ctx -> task { let webLog = ctx.WebLog - let conn = ctx.Conn - let! posts = Data.Post.findPageOfPosts webLog.id pageNbr 25 conn - let! hash = preparePostList webLog posts AdminList "" pageNbr 25 ctx conn + let data = ctx.Data + let! posts = data.Post.findPageOfPosts webLog.id pageNbr 25 + let! hash = preparePostList webLog posts AdminList "" pageNbr 25 ctx data hash.Add ("page_title", "Posts") hash.Add ("csrf", csrfToken ctx) 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 let edit postId : HttpHandler = fun next ctx -> task { let webLog = ctx.WebLog - let conn = ctx.Conn + let data = ctx.Data let! result = task { match postId with | "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) | None -> return None } match result with | Some (title, post) -> - let! cats = Data.Category.findAllForView webLog.id conn + let! cats = data.Category.findAllForView webLog.id let! templates = templatesForTheme ctx "post" let model = EditPostModel.fromPost webLog post return! @@ -250,7 +251,7 @@ let edit postId : HttpHandler = fun next ctx -> task { // GET /admin/post/{id}/permalinks 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 -> return! Hash.FromAnonymousObject {| @@ -267,7 +268,7 @@ let savePermalinks : HttpHandler = fun next ctx -> task { let webLog = ctx.WebLog let! model = ctx.BindFormAsync () 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 -> do! addMessage ctx { UserMessage.success with message = "Post permalinks saved successfully" } 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 let delete postId : HttpHandler = fun next ctx -> task { 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" } | false -> do! addMessage ctx { UserMessage.error with message = "Post not found; nothing deleted" } 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! model = ctx.BindFormAsync () let webLog = ctx.WebLog - let conn = ctx.Conn + let data = ctx.Data let now = DateTime.UtcNow let! pst = task { match model.postId with @@ -300,7 +301,7 @@ let save : HttpHandler = fun next ctx -> task { webLogId = webLog.id 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 | Some post -> @@ -349,7 +350,7 @@ let save : HttpHandler = fun next ctx -> task { } | false -> { post with publishedOn = Some dt } | 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 model.doPublish || not (pst.Value.categoryIds diff --git a/src/MyWebLog/Handlers/Routes.fs b/src/MyWebLog/Handlers/Routes.fs index 379df98..0bbbcb7 100644 --- a/src/MyWebLog/Handlers/Routes.fs +++ b/src/MyWebLog/Handlers/Routes.fs @@ -14,7 +14,7 @@ module CatchAll = /// Sequence where the first returned value is the proper handler for the link let private deriveAction (ctx : HttpContext) : HttpHandler seq = let webLog = ctx.WebLog - let conn = ctx.Conn + let data = ctx.Data let debug = debug "Routes.CatchAll" ctx let textLink = let _, extra = WebLog.hostAndPath webLog @@ -27,15 +27,15 @@ module CatchAll = if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.empty) let permalink = Permalink (textLink.Substring 1) // Current post - match Data.Post.findByPermalink permalink webLog.id conn |> await with + match data.Post.findByPermalink permalink webLog.id |> await with | Some post -> 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) yield fun next ctx -> themedView (defaultArg post.template "single-post") next ctx model | None -> () // Current page - match Data.Page.findByPermalink permalink webLog.id conn |> await with + match data.Page.findByPermalink permalink webLog.id |> await with | Some page -> debug (fun () -> $"Found page by permalink") yield fun next ctx -> @@ -56,25 +56,25 @@ module CatchAll = // Post differing only by trailing slash let altLink = 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 -> debug (fun () -> $"Found post by trailing-slash-agnostic permalink") yield redirectTo true (WebLog.relativeUrl webLog post.permalink) | None -> () // 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 -> debug (fun () -> $"Found page by trailing-slash-agnostic permalink") yield redirectTo true (WebLog.relativeUrl webLog page.permalink) | None -> () // 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 -> debug (fun () -> $"Found post by prior permalink") yield redirectTo true (WebLog.relativeUrl webLog link) | None -> () // 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 -> debug (fun () -> $"Found page by prior permalink") yield redirectTo true (WebLog.relativeUrl webLog link) @@ -114,7 +114,7 @@ module Asset = // GET /theme/{theme}/{**path} let serveAsset (urlParts : string seq) : HttpHandler = fun next ctx -> task { 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 -> match checkModified asset ctx with | Some threeOhFour -> return! threeOhFour next ctx diff --git a/src/MyWebLog/Handlers/User.fs b/src/MyWebLog/Handlers/User.fs index cf040d6..ed08809 100644 --- a/src/MyWebLog/Handlers/User.fs +++ b/src/MyWebLog/Handlers/User.fs @@ -42,7 +42,7 @@ open MyWebLog let doLogOn : HttpHandler = fun next ctx -> task { let! model = ctx.BindFormAsync () 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 -> let claims = seq { 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 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 | 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! model = ctx.BindFormAsync () if model.newPassword = model.newPasswordConfirm then - let conn = ctx.Conn - match! Data.WebLogUser.findById (userId ctx) conn with + let data = ctx.Data + match! data.WebLogUser.findById (userId ctx) ctx.WebLog.id with | Some user -> let pw, salt = if model.newPassword = "" then @@ -105,7 +105,7 @@ let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task { passwordHash = pw salt = salt } - do! Data.WebLogUser.update user conn + do! data.WebLogUser.update user let pwMsg = if model.newPassword = "" then "" else " and updated your password" do! addMessage ctx { UserMessage.success with message = $"Saved your information{pwMsg} successfully" } return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/user/edit")) next ctx diff --git a/src/MyWebLog/Maintenance.fs b/src/MyWebLog/Maintenance.fs index db656ac..440cba7 100644 --- a/src/MyWebLog/Maintenance.fs +++ b/src/MyWebLog/Maintenance.fs @@ -3,13 +3,12 @@ module MyWebLog.Maintenance open System open System.IO open Microsoft.Extensions.DependencyInjection -open RethinkDb.Driver.FSharp -open RethinkDb.Driver.Net +open MyWebLog.Data /// Create the web log information let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { - let conn = sp.GetRequiredService () + let data = sp.GetRequiredService () let timeZone = let local = TimeZoneInfo.Local.Id @@ -25,19 +24,19 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { let userId = WebLogUserId.create () let homePageId = PageId.create () - do! Data.WebLog.add + do! data.WebLog.add { WebLog.empty with id = webLogId name = args[2] urlBase = args[1] defaultPage = PageId.toString homePageId timeZone = timeZone - } conn + } // Create the admin user let salt = Guid.NewGuid () - do! Data.WebLogUser.add + do! data.WebLogUser.add { WebLogUser.empty with id = userId webLogId = webLogId @@ -48,10 +47,10 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { passwordHash = Handlers.User.hashedPassword args[4] args[3] salt salt = salt authorizationLevel = Administrator - } conn + } // Create the default home page - do! Data.Page.add + do! data.Page.add { Page.empty with id = homePageId webLogId = webLogId @@ -66,7 +65,7 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task { text = Html "

This is your default home page.

" } ] - } conn + } 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]" let importPriorPermalinks urlBase file (sp : IServiceProvider) = task { - let conn = sp.GetRequiredService () + let data = sp.GetRequiredService () - match! Data.WebLog.findByHost urlBase conn with + match! data.WebLog.findByHost urlBase with | Some webLog -> let mapping = @@ -93,23 +92,15 @@ let importPriorPermalinks urlBase file (sp : IServiceProvider) = task { Permalink parts[0], Permalink parts[1]) 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 -> - let! withLinks = rethink { - withTable Data.Table.Post - get post.id - result conn - } - do! rethink { - withTable Data.Table.Post - get post.id - update [ "priorPermalinks", old :: withLinks.priorPermalinks :> obj] - write; ignoreResult conn - } + let! withLinks = data.Post.findFullById post.id post.webLogId + let! _ = data.Post.updatePriorPermalinks post.id post.webLogId + (old :: withLinks.Value.priorPermalinks) printfn $"{Permalink.toString old} -> {Permalink.toString current}" | None -> printfn $"Cannot find current post for {Permalink.toString current}" printfn "Done!" - | None -> printfn $"No web log found at {urlBase}" + | None -> eprintfn $"No web log found at {urlBase}" } /// Import permalinks if all is well @@ -127,17 +118,70 @@ let loadTheme (args : string[]) (sp : IServiceProvider) = task { | -1 -> args[1] | it -> args[1][(it + 1)..] match Handlers.Admin.getThemeName fileName with - | Some themeName -> - let conn = sp.GetRequiredService () + | Ok themeName -> + let data = sp.GetRequiredService () let clean = if args.Length > 2 then bool.Parse args[2] else true use stream = File.Open (args[1], FileMode.Open) - use copy = new MemoryStream () + use copy = new MemoryStream () 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" - | None -> - printfn $"Theme file name {args[1]} is invalid" + | Error message -> eprintfn $"{message}" else printfn "Usage: MyWebLog load-theme [theme-zip-file-name] [*clean-load]" 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 + \ No newline at end of file diff --git a/src/MyWebLog/Program.fs b/src/MyWebLog/Program.fs index bd0fcb5..7e039ee 100644 --- a/src/MyWebLog/Program.fs +++ b/src/MyWebLog/Program.fs @@ -23,17 +23,43 @@ type WebLogMiddleware (next : RequestDelegate, log : ILogger) ctx.Response.StatusCode <- 404 } + 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 () + 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> ())) + 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.EndpointRouting open Microsoft.AspNetCore.Authentication.Cookies open Microsoft.AspNetCore.Builder open Microsoft.AspNetCore.HttpOverrides -open Microsoft.Extensions.Configuration -open Microsoft.Extensions.DependencyInjection open RethinkDB.DistributedCache -open RethinkDb.Driver.FSharp -open RethinkDb.Driver.Net [] let main args = @@ -52,25 +78,32 @@ let main args = let _ = builder.Services.AddAuthorization () let _ = builder.Services.AddAntiforgery () - // Configure RethinkDB's connection - JsonConverters.all () |> Seq.iter Converter.Serializer.Converters.Add - let sp = builder.Services.BuildServiceProvider () - let config = sp.GetRequiredService () - let loggerFac = sp.GetRequiredService () - let rethinkCfg = DataConfig.FromConfiguration (config.GetSection "RethinkDB") - let conn = + let sp = builder.Services.BuildServiceProvider () + match DataImplementation.get sp with + | Some data -> task { - let! conn = rethinkCfg.CreateConnectionAsync () - do! Data.Startup.ensureDb rethinkCfg (loggerFac.CreateLogger (nameof Data.Startup)) conn - do! WebLogCache.fill conn - do! ThemeAssetCache.fill conn - return conn + do! data.startUp () + do! WebLogCache.fill data + do! ThemeAssetCache.fill data } |> Async.AwaitTask |> Async.RunSynchronously - let _ = builder.Services.AddSingleton conn + builder.Services.AddSingleton data |> ignore + + // Define distributed cache implementation based on data implementation + match data with + | :? RethinkDbData as rethink -> + builder.Services.AddDistributedRethinkDBCache (fun opts -> + opts.TableName <- "Session" + opts.Connection <- rethink.Conn) + |> ignore + | :? LiteDbData -> + 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" + builder.Services.AddDistributedMemoryCache () |> ignore + | _ -> () + | None -> + invalidOp "There is no data configuration present; please add a RethinkDB section or LiteDB connection string" - let _ = builder.Services.AddDistributedRethinkDBCache (fun opts -> - opts.TableName <- "Session" - opts.Connection <- conn) let _ = builder.Services.AddSession(fun opts -> opts.IdleTimeout <- TimeSpan.FromMinutes 60 opts.Cookie.HttpOnly <- true