V2 #1

Merged
danieljsummers merged 102 commits from v2 into main 2022-06-23 00:35:12 +00:00
16 changed files with 2149 additions and 1286 deletions
Showing only changes of commit 476a3acd73 - Show all commits

View File

@ -1,130 +1,247 @@
/// JSON.NET converters for discriminated union types
[<RequireQualifiedAccess>]
module MyWebLog.JsonConverters
/// Converters for discriminated union types
module MyWebLog.Converters
open MyWebLog
open Newtonsoft.Json
open System
type CategoryIdConverter () =
inherit JsonConverter<CategoryId> ()
override _.WriteJson (writer : JsonWriter, value : CategoryId, _ : JsonSerializer) =
writer.WriteValue (CategoryId.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : CategoryId, _ : bool, _ : JsonSerializer) =
(string >> CategoryId) reader.Value
/// JSON.NET converters for discriminated union types
module Json =
type CommentIdConverter () =
inherit JsonConverter<CommentId> ()
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 Newtonsoft.Json
type CustomFeedIdConverter () =
inherit JsonConverter<CustomFeedId> ()
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 CategoryIdConverter () =
inherit JsonConverter<CategoryId> ()
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 CustomFeedSourceConverter () =
inherit JsonConverter<CustomFeedSource> ()
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 CommentIdConverter () =
inherit JsonConverter<CommentId> ()
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 ExplicitRatingConverter () =
inherit JsonConverter<ExplicitRating> ()
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 CustomFeedIdConverter () =
inherit JsonConverter<CustomFeedId> ()
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 MarkupTextConverter () =
inherit JsonConverter<MarkupText> ()
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 CustomFeedSourceConverter () =
inherit JsonConverter<CustomFeedSource> ()
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 PermalinkConverter () =
inherit JsonConverter<Permalink> ()
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 ExplicitRatingConverter () =
inherit JsonConverter<ExplicitRating> ()
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 PageIdConverter () =
inherit JsonConverter<PageId> ()
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 MarkupTextConverter () =
inherit JsonConverter<MarkupText> ()
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 PostIdConverter () =
inherit JsonConverter<PostId> ()
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 PermalinkConverter () =
inherit JsonConverter<Permalink> ()
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 TagMapIdConverter () =
inherit JsonConverter<TagMapId> ()
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 PageIdConverter () =
inherit JsonConverter<PageId> ()
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 ThemeAssetIdConverter () =
inherit JsonConverter<ThemeAssetId> ()
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 PostIdConverter () =
inherit JsonConverter<PostId> ()
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 ThemeIdConverter () =
inherit JsonConverter<ThemeId> ()
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 TagMapIdConverter () =
inherit JsonConverter<TagMapId> ()
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 WebLogIdConverter () =
inherit JsonConverter<WebLogId> ()
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 ThemeAssetIdConverter () =
inherit JsonConverter<ThemeAssetId> ()
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 WebLogUserIdConverter () =
inherit JsonConverter<WebLogUserId> ()
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 ThemeIdConverter () =
inherit JsonConverter<ThemeId> ()
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 Microsoft.FSharpLu.Json
type WebLogIdConverter () =
inherit JsonConverter<WebLogId> ()
override _.WriteJson (writer : JsonWriter, value : WebLogId, _ : JsonSerializer) =
writer.WriteValue (WebLogId.toString value)
override _.ReadJson (reader : JsonReader, _ : Type, _ : WebLogId, _ : bool, _ : JsonSerializer) =
(string >> WebLogId) 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 WebLogUserIdConverter () =
inherit JsonConverter<WebLogUserId> ()
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<CategoryId> (CategoryIdMapping.toBson, CategoryIdMapping.fromBson)
g.RegisterType<CommentId> (CommentIdMapping.toBson, CommentIdMapping.fromBson)
g.RegisterType<CustomFeedId> (CustomFeedIdMapping.toBson, CustomFeedIdMapping.fromBson)
g.RegisterType<CustomFeedSource> (CustomFeedSourceMapping.toBson, CustomFeedSourceMapping.fromBson)
g.RegisterType<ExplicitRating> (ExplicitRatingMapping.toBson, ExplicitRatingMapping.fromBson)
g.RegisterType<MarkupText> (MarkupTextMapping.toBson, MarkupTextMapping.fromBson)
g.RegisterType<Permalink> (PermalinkMapping.toBson, PermalinkMapping.fromBson)
g.RegisterType<PageId> (PageIdMapping.toBson, PageIdMapping.fromBson)
g.RegisterType<PostId> (PostIdMapping.toBson, PostIdMapping.fromBson)
g.RegisterType<TagMapId> (TagMapIdMapping.toBson, TagMapIdMapping.fromBson)
g.RegisterType<ThemeAssetId> (ThemeAssetIdMapping.toBson, ThemeAssetIdMapping.fromBson)
g.RegisterType<ThemeId> (ThemeIdMapping.toBson, ThemeIdMapping.fromBson)
g.RegisterType<WebLogId> (WebLogIdMapping.toBson, WebLogIdMapping.fromBson)
g.RegisterType<WebLogUserId> (WebLogUserIdMapping.toBson, WebLogUserIdMapping.fromBson)
g.RegisterType<CategoryId option> (OptionMapping.categoryIdToBson, OptionMapping.categoryIdFromBson)
g.RegisterType<CommentId option> (OptionMapping.commentIdToBson, OptionMapping.commentIdFromBson)
g.RegisterType<DateTime option> (OptionMapping.dateTimeToBson, OptionMapping.dateTimeFromBson)
g.RegisterType<int option> (OptionMapping.intToBson, OptionMapping.intFromBson)
g.RegisterType<PodcastOptions option> (OptionMapping.podcastOptionsToBson, OptionMapping.podcastOptionsFromBson)
g.RegisterType<string option> (OptionMapping.stringToBson, OptionMapping.stringFromBson)

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -1,20 +1,20 @@
namespace MyWebLog
open Microsoft.AspNetCore.Http
open MyWebLog.Data
/// Extension properties on HTTP context for web log
[<AutoOpen>]
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<IConnection> ()
/// The data implementation
member this.Data = this.RequestServices.GetRequiredService<IData> ()
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] <- []

View File

@ -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<int>) = 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<int>) = 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<EditCategoryModel> ()
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<ManagePermalinksModel> ()
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<EditPageModel> ()
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<EditTagMapModel> ()
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<SettingsModel> ()
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

View File

@ -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<EditRssModel> ()
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<EditCustomFeedModel> ()
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

View File

@ -108,12 +108,12 @@ let viewForTheme theme template next ctx = fun (hash : Hash) -> task {
// the net effect is a "layout" capability similar to Razor or Pug
// 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 =

View File

@ -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 $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
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 $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
hash.Add ("page_title", $"Posts Tagged &ldquo;{tag}&rdquo;{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<ManagePermalinksModel> ()
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<EditPostModel> ()
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

View File

@ -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

View File

@ -42,7 +42,7 @@ open MyWebLog
let doLogOn : HttpHandler = fun next ctx -> task {
let! model = ctx.BindFormAsync<LogOnModel> ()
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<EditUserModel> ()
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

View File

@ -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<IConnection> ()
let data = sp.GetRequiredService<IData> ()
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 "<p>This is your default home page.</p>"
}
]
} 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<IConnection> ()
let data = sp.GetRequiredService<IData> ()
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<Post> {
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<IConnection> ()
| Ok themeName ->
let data = sp.GetRequiredService<IData> ()
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

View File

@ -23,17 +23,43 @@ type WebLogMiddleware (next : RequestDelegate, log : ILogger<WebLogMiddleware>)
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<IConfiguration> ()
let isNotNull it = (isNull >> not) it
if isNotNull (config.GetSection "RethinkDB") then
Json.all () |> Seq.iter Converter.Serializer.Converters.Add
let rethinkCfg = DataConfig.FromConfiguration (config.GetSection "RethinkDB")
let conn = rethinkCfg.CreateConnectionAsync () |> Async.AwaitTask |> Async.RunSynchronously
Some (upcast RethinkDbData (conn, rethinkCfg, sp.GetRequiredService<ILogger<RethinkDbData>> ()))
elif isNotNull (config.GetConnectionString "LiteDB") then
Bson.registerAll ()
let db = new LiteDatabase (config.GetConnectionString "LiteDB")
Some (upcast LiteDbData db)
else
None
open Giraffe
open Giraffe.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
[<EntryPoint>]
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<IConfiguration> ()
let loggerFac = sp.GetRequiredService<ILoggerFactory> ()
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<IConnection> conn
builder.Services.AddSingleton<IData> 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<ILoggerFactory> ()
let logger = log.CreateLogger "MyWebLog.StartUp"
logger.LogWarning "Session caching is not yet implemented via LiteDB; using memory cache for sessions"
builder.Services.AddDistributedMemoryCache () |> ignore
| _ -> ()
| None ->
invalidOp "There is no data configuration present; please add a RethinkDB section or LiteDB connection string"
let _ = builder.Services.AddDistributedRethinkDBCache (fun opts ->
opts.TableName <- "Session"
opts.Connection <- conn)
let _ = builder.Services.AddSession(fun opts ->
opts.IdleTimeout <- TimeSpan.FromMinutes 60
opts.Cookie.HttpOnly <- true