First cut of multi-db data
- Add data interface - Convert RethinkDB to interface implementation - Write LiteDB implementation / converters - Update all data access to use interface
This commit is contained in:
parent
6517d260cd
commit
476a3acd73
|
|
@ -1,130 +1,247 @@
|
||||||
/// JSON.NET converters for discriminated union types
|
/// Converters for discriminated union types
|
||||||
[<RequireQualifiedAccess>]
|
module MyWebLog.Converters
|
||||||
module MyWebLog.JsonConverters
|
|
||||||
|
|
||||||
open MyWebLog
|
open MyWebLog
|
||||||
open Newtonsoft.Json
|
|
||||||
open System
|
open System
|
||||||
|
|
||||||
type CategoryIdConverter () =
|
/// JSON.NET converters for discriminated union types
|
||||||
inherit JsonConverter<CategoryId> ()
|
module Json =
|
||||||
override _.WriteJson (writer : JsonWriter, value : CategoryId, _ : JsonSerializer) =
|
|
||||||
writer.WriteValue (CategoryId.toString value)
|
|
||||||
override _.ReadJson (reader : JsonReader, _ : Type, _ : CategoryId, _ : bool, _ : JsonSerializer) =
|
|
||||||
(string >> CategoryId) reader.Value
|
|
||||||
|
|
||||||
type CommentIdConverter () =
|
|
||||||
inherit JsonConverter<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 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 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 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 MarkupTextConverter () =
|
open Newtonsoft.Json
|
||||||
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 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 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 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 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 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 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 WebLogIdConverter () =
|
type CategoryIdConverter () =
|
||||||
inherit JsonConverter<WebLogId> ()
|
inherit JsonConverter<CategoryId> ()
|
||||||
override _.WriteJson (writer : JsonWriter, value : WebLogId, _ : JsonSerializer) =
|
override _.WriteJson (writer : JsonWriter, value : CategoryId, _ : JsonSerializer) =
|
||||||
writer.WriteValue (WebLogId.toString value)
|
writer.WriteValue (CategoryId.toString value)
|
||||||
override _.ReadJson (reader : JsonReader, _ : Type, _ : WebLogId, _ : bool, _ : JsonSerializer) =
|
override _.ReadJson (reader : JsonReader, _ : Type, _ : CategoryId, _ : bool, _ : JsonSerializer) =
|
||||||
(string >> WebLogId) reader.Value
|
(string >> CategoryId) reader.Value
|
||||||
|
|
||||||
type WebLogUserIdConverter () =
|
type CommentIdConverter () =
|
||||||
inherit JsonConverter<WebLogUserId> ()
|
inherit JsonConverter<CommentId> ()
|
||||||
override _.WriteJson (writer : JsonWriter, value : WebLogUserId, _ : JsonSerializer) =
|
override _.WriteJson (writer : JsonWriter, value : CommentId, _ : JsonSerializer) =
|
||||||
writer.WriteValue (WebLogUserId.toString value)
|
writer.WriteValue (CommentId.toString value)
|
||||||
override _.ReadJson (reader : JsonReader, _ : Type, _ : WebLogUserId, _ : bool, _ : JsonSerializer) =
|
override _.ReadJson (reader : JsonReader, _ : Type, _ : CommentId, _ : bool, _ : JsonSerializer) =
|
||||||
(string >> WebLogUserId) reader.Value
|
(string >> CommentId) reader.Value
|
||||||
|
|
||||||
open Microsoft.FSharpLu.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
|
||||||
|
|
||||||
/// All converters to use for data conversion
|
type CustomFeedSourceConverter () =
|
||||||
let all () : JsonConverter seq =
|
inherit JsonConverter<CustomFeedSource> ()
|
||||||
seq {
|
override _.WriteJson (writer : JsonWriter, value : CustomFeedSource, _ : JsonSerializer) =
|
||||||
// Our converters
|
writer.WriteValue (CustomFeedSource.toString value)
|
||||||
CategoryIdConverter ()
|
override _.ReadJson (reader : JsonReader, _ : Type, _ : CustomFeedSource, _ : bool, _ : JsonSerializer) =
|
||||||
CommentIdConverter ()
|
(string >> CustomFeedSource.parse) reader.Value
|
||||||
CustomFeedIdConverter ()
|
|
||||||
CustomFeedSourceConverter ()
|
type ExplicitRatingConverter () =
|
||||||
ExplicitRatingConverter ()
|
inherit JsonConverter<ExplicitRating> ()
|
||||||
MarkupTextConverter ()
|
override _.WriteJson (writer : JsonWriter, value : ExplicitRating, _ : JsonSerializer) =
|
||||||
PermalinkConverter ()
|
writer.WriteValue (ExplicitRating.toString value)
|
||||||
PageIdConverter ()
|
override _.ReadJson (reader : JsonReader, _ : Type, _ : ExplicitRating, _ : bool, _ : JsonSerializer) =
|
||||||
PostIdConverter ()
|
(string >> ExplicitRating.parse) reader.Value
|
||||||
TagMapIdConverter ()
|
|
||||||
ThemeAssetIdConverter ()
|
type MarkupTextConverter () =
|
||||||
ThemeIdConverter ()
|
inherit JsonConverter<MarkupText> ()
|
||||||
WebLogIdConverter ()
|
override _.WriteJson (writer : JsonWriter, value : MarkupText, _ : JsonSerializer) =
|
||||||
WebLogUserIdConverter ()
|
writer.WriteValue (MarkupText.toString value)
|
||||||
// Handles DUs with no associated data, as well as option fields
|
override _.ReadJson (reader : JsonReader, _ : Type, _ : MarkupText, _ : bool, _ : JsonSerializer) =
|
||||||
CompactUnionJsonConverter ()
|
(string >> MarkupText.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 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 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 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 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 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 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 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)
|
||||||
|
|
||||||
|
|
@ -1,915 +0,0 @@
|
||||||
[<RequireQualifiedAccess>]
|
|
||||||
module MyWebLog.Data
|
|
||||||
|
|
||||||
/// Table names
|
|
||||||
[<RequireQualifiedAccess>]
|
|
||||||
module Table =
|
|
||||||
|
|
||||||
/// The category table
|
|
||||||
let Category = "Category"
|
|
||||||
|
|
||||||
/// The comment table
|
|
||||||
let Comment = "Comment"
|
|
||||||
|
|
||||||
/// The page table
|
|
||||||
let Page = "Page"
|
|
||||||
|
|
||||||
/// The post table
|
|
||||||
let Post = "Post"
|
|
||||||
|
|
||||||
/// The tag map table
|
|
||||||
let TagMap = "TagMap"
|
|
||||||
|
|
||||||
/// The theme table
|
|
||||||
let Theme = "Theme"
|
|
||||||
|
|
||||||
/// The theme asset table
|
|
||||||
let ThemeAsset = "ThemeAsset"
|
|
||||||
|
|
||||||
/// The web log table
|
|
||||||
let WebLog = "WebLog"
|
|
||||||
|
|
||||||
/// The web log user table
|
|
||||||
let WebLogUser = "WebLogUser"
|
|
||||||
|
|
||||||
/// A list of all tables
|
|
||||||
let all = [ Category; Comment; Page; Post; TagMap; Theme; ThemeAsset; WebLog; WebLogUser ]
|
|
||||||
|
|
||||||
|
|
||||||
/// Functions to assist with retrieving data
|
|
||||||
[<AutoOpen>]
|
|
||||||
module Helpers =
|
|
||||||
|
|
||||||
open RethinkDb.Driver
|
|
||||||
open RethinkDb.Driver.Net
|
|
||||||
open System.Threading.Tasks
|
|
||||||
|
|
||||||
/// Shorthand for the ReQL starting point
|
|
||||||
let r = RethinkDB.R
|
|
||||||
|
|
||||||
/// Verify that the web log ID matches before returning an item
|
|
||||||
let verifyWebLog<'T> webLogId (prop : 'T -> WebLogId) (f : IConnection -> Task<'T option>) =
|
|
||||||
fun conn -> backgroundTask {
|
|
||||||
match! f conn with Some it when (prop it) = webLogId -> return Some it | _ -> return None
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Get the first item from a list, or None if the list is empty
|
|
||||||
let tryFirst<'T> (f : IConnection -> Task<'T list>) =
|
|
||||||
fun conn -> backgroundTask {
|
|
||||||
let! results = f conn
|
|
||||||
return results |> List.tryHead
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Cast a strongly-typed list to an object list
|
|
||||||
let objList<'T> (objects : 'T list) = objects |> List.map (fun it -> it :> obj)
|
|
||||||
|
|
||||||
|
|
||||||
open RethinkDb.Driver.FSharp
|
|
||||||
open Microsoft.Extensions.Logging
|
|
||||||
|
|
||||||
/// Start up checks to ensure the database, tables, and indexes exist
|
|
||||||
module Startup =
|
|
||||||
|
|
||||||
/// Ensure field indexes exist, as well as special indexes for selected tables
|
|
||||||
let private ensureIndexes (log : ILogger) conn table fields = backgroundTask {
|
|
||||||
let! indexes = rethink<string list> { withTable table; indexList; result; withRetryOnce conn }
|
|
||||||
for field in fields do
|
|
||||||
if not (indexes |> List.contains field) then
|
|
||||||
log.LogInformation $"Creating index {table}.{field}..."
|
|
||||||
do! rethink { withTable table; indexCreate field; write; withRetryOnce; ignoreResult conn }
|
|
||||||
// Post and page need index by web log ID and permalink
|
|
||||||
if [ Table.Page; Table.Post ] |> List.contains table then
|
|
||||||
if not (indexes |> List.contains "permalink") then
|
|
||||||
log.LogInformation $"Creating index {table}.permalink..."
|
|
||||||
do! rethink {
|
|
||||||
withTable table
|
|
||||||
indexCreate "permalink" (fun row -> r.Array (row["webLogId"], row["permalink"].Downcase ()) :> obj)
|
|
||||||
write; withRetryOnce; ignoreResult conn
|
|
||||||
}
|
|
||||||
// Prior permalinks are searched when a post or page permalink do not match the current URL
|
|
||||||
if not (indexes |> List.contains "priorPermalinks") then
|
|
||||||
log.LogInformation $"Creating index {table}.priorPermalinks..."
|
|
||||||
do! rethink {
|
|
||||||
withTable table
|
|
||||||
indexCreate "priorPermalinks" (fun row -> row["priorPermalinks"].Downcase () :> obj) [ Multi ]
|
|
||||||
write; withRetryOnce; ignoreResult conn
|
|
||||||
}
|
|
||||||
// Post needs indexes by category and tag (used for counting and retrieving posts)
|
|
||||||
if Table.Post = table then
|
|
||||||
for idx in [ "categoryIds"; "tags" ] do
|
|
||||||
if not (List.contains idx indexes) then
|
|
||||||
log.LogInformation $"Creating index {table}.{idx}..."
|
|
||||||
do! rethink {
|
|
||||||
withTable table
|
|
||||||
indexCreate idx [ Multi ]
|
|
||||||
write; withRetryOnce; ignoreResult conn
|
|
||||||
}
|
|
||||||
// Tag mapping needs an index by web log ID and both tag and URL values
|
|
||||||
if Table.TagMap = table then
|
|
||||||
if not (indexes |> List.contains "webLogAndTag") then
|
|
||||||
log.LogInformation $"Creating index {table}.webLogAndTag..."
|
|
||||||
do! rethink {
|
|
||||||
withTable table
|
|
||||||
indexCreate "webLogAndTag" (fun row -> r.Array (row["webLogId"], row["tag"]) :> obj)
|
|
||||||
write; withRetryOnce; ignoreResult conn
|
|
||||||
}
|
|
||||||
if not (indexes |> List.contains "webLogAndUrl") then
|
|
||||||
log.LogInformation $"Creating index {table}.webLogAndUrl..."
|
|
||||||
do! rethink {
|
|
||||||
withTable table
|
|
||||||
indexCreate "webLogAndUrl" (fun row -> r.Array (row["webLogId"], row["urlValue"]) :> obj)
|
|
||||||
write; withRetryOnce; ignoreResult conn
|
|
||||||
}
|
|
||||||
// Users log on with e-mail
|
|
||||||
if Table.WebLogUser = table && not (indexes |> List.contains "logOn") then
|
|
||||||
log.LogInformation $"Creating index {table}.logOn..."
|
|
||||||
do! rethink {
|
|
||||||
withTable table
|
|
||||||
indexCreate "logOn" (fun row -> r.Array (row["webLogId"], row["userName"]) :> obj)
|
|
||||||
write; withRetryOnce; ignoreResult conn
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Ensure all necessary tables and indexes exist
|
|
||||||
let ensureDb (config : DataConfig) (log : ILogger) conn = backgroundTask {
|
|
||||||
|
|
||||||
let! dbs = rethink<string list> { dbList; result; withRetryOnce conn }
|
|
||||||
if not (dbs |> List.contains config.Database) then
|
|
||||||
log.LogInformation($"Creating database {config.Database}...")
|
|
||||||
do! rethink { dbCreate config.Database; write; withRetryOnce; ignoreResult conn }
|
|
||||||
|
|
||||||
let! tables = rethink<string list> { tableList; result; withRetryOnce conn }
|
|
||||||
for tbl in Table.all do
|
|
||||||
if not (tables |> List.contains tbl) then
|
|
||||||
log.LogInformation($"Creating table {tbl}...")
|
|
||||||
do! rethink { tableCreate tbl; write; withRetryOnce; ignoreResult conn }
|
|
||||||
|
|
||||||
let makeIdx = ensureIndexes log conn
|
|
||||||
do! makeIdx Table.Category [ "webLogId" ]
|
|
||||||
do! makeIdx Table.Comment [ "postId" ]
|
|
||||||
do! makeIdx Table.Page [ "webLogId"; "authorId" ]
|
|
||||||
do! makeIdx Table.Post [ "webLogId"; "authorId" ]
|
|
||||||
do! makeIdx Table.TagMap []
|
|
||||||
do! makeIdx Table.WebLog [ "urlBase" ]
|
|
||||||
do! makeIdx Table.WebLogUser [ "webLogId" ]
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Functions to manipulate categories
|
|
||||||
module Category =
|
|
||||||
|
|
||||||
open System.Threading.Tasks
|
|
||||||
open MyWebLog.ViewModels
|
|
||||||
|
|
||||||
/// Add a category
|
|
||||||
let add (cat : Category) =
|
|
||||||
rethink {
|
|
||||||
withTable Table.Category
|
|
||||||
insert cat
|
|
||||||
write; withRetryDefault; ignoreResult
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Count all categories for a web log
|
|
||||||
let countAll (webLogId : WebLogId) =
|
|
||||||
rethink<int> {
|
|
||||||
withTable Table.Category
|
|
||||||
getAll [ webLogId ] (nameof webLogId)
|
|
||||||
count
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Count top-level categories for a web log
|
|
||||||
let countTopLevel (webLogId : WebLogId) =
|
|
||||||
rethink<int> {
|
|
||||||
withTable Table.Category
|
|
||||||
getAll [ webLogId ] (nameof webLogId)
|
|
||||||
filter "parentId" None
|
|
||||||
count
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Create a category hierarchy from the given list of categories
|
|
||||||
let rec private orderByHierarchy (cats : Category list) parentId slugBase parentNames = seq {
|
|
||||||
for cat in cats |> List.filter (fun c -> c.parentId = parentId) do
|
|
||||||
let fullSlug = (match slugBase with Some it -> $"{it}/" | None -> "") + cat.slug
|
|
||||||
{ id = CategoryId.toString cat.id
|
|
||||||
slug = fullSlug
|
|
||||||
name = cat.name
|
|
||||||
description = cat.description
|
|
||||||
parentNames = Array.ofList parentNames
|
|
||||||
// Post counts are filled on a second pass
|
|
||||||
postCount = 0
|
|
||||||
}
|
|
||||||
yield! orderByHierarchy cats (Some cat.id) (Some fullSlug) ([ cat.name ] |> List.append parentNames)
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Find all categories for a web log, sorted alphabetically, arranged in groups, in view model format
|
|
||||||
let findAllForView (webLogId : WebLogId) conn = backgroundTask {
|
|
||||||
let! cats = rethink<Category list> {
|
|
||||||
withTable Table.Category
|
|
||||||
getAll [ webLogId ] (nameof webLogId)
|
|
||||||
orderByFunc (fun it -> it["name"].Downcase () :> obj)
|
|
||||||
result; withRetryDefault conn
|
|
||||||
}
|
|
||||||
let ordered = orderByHierarchy cats None None []
|
|
||||||
let! counts =
|
|
||||||
ordered
|
|
||||||
|> Seq.map (fun it -> backgroundTask {
|
|
||||||
// Parent category post counts include posts in subcategories
|
|
||||||
let catIds =
|
|
||||||
ordered
|
|
||||||
|> Seq.filter (fun cat -> cat.parentNames |> Array.contains it.name)
|
|
||||||
|> Seq.map (fun cat -> cat.id :> obj)
|
|
||||||
|> Seq.append (Seq.singleton it.id)
|
|
||||||
|> List.ofSeq
|
|
||||||
let! count = rethink<int> {
|
|
||||||
withTable Table.Post
|
|
||||||
getAll catIds "categoryIds"
|
|
||||||
filter "status" Published
|
|
||||||
distinct
|
|
||||||
count
|
|
||||||
result; withRetryDefault conn
|
|
||||||
}
|
|
||||||
return it.id, count
|
|
||||||
})
|
|
||||||
|> Task.WhenAll
|
|
||||||
return
|
|
||||||
ordered
|
|
||||||
|> Seq.map (fun cat ->
|
|
||||||
{ cat with
|
|
||||||
postCount = counts
|
|
||||||
|> Array.tryFind (fun c -> fst c = cat.id)
|
|
||||||
|> Option.map snd
|
|
||||||
|> Option.defaultValue 0
|
|
||||||
})
|
|
||||||
|> Array.ofSeq
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Find a category by its ID
|
|
||||||
let findById (catId : CategoryId) webLogId =
|
|
||||||
rethink<Category> {
|
|
||||||
withTable Table.Category
|
|
||||||
get catId
|
|
||||||
resultOption; withRetryOptionDefault
|
|
||||||
}
|
|
||||||
|> verifyWebLog webLogId (fun c -> c.webLogId)
|
|
||||||
|
|
||||||
/// Delete a category, also removing it from any posts to which it is assigned
|
|
||||||
let delete catId webLogId conn = backgroundTask {
|
|
||||||
match! findById catId webLogId conn with
|
|
||||||
| Some _ ->
|
|
||||||
// Delete the category off all posts where it is assigned
|
|
||||||
do! rethink {
|
|
||||||
withTable Table.Post
|
|
||||||
getAll [ webLogId ] (nameof webLogId)
|
|
||||||
filter (fun row -> row["categoryIds"].Contains catId :> obj)
|
|
||||||
update (fun row -> r.HashMap ("categoryIds", r.Array(row["categoryIds"]).Remove catId) :> obj)
|
|
||||||
write; withRetryDefault; ignoreResult conn
|
|
||||||
}
|
|
||||||
// Delete the category itself
|
|
||||||
do! rethink {
|
|
||||||
withTable Table.Category
|
|
||||||
get catId
|
|
||||||
delete
|
|
||||||
write; withRetryDefault; ignoreResult conn
|
|
||||||
}
|
|
||||||
return true
|
|
||||||
| None -> return false
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Get a category ID -> name dictionary for the given category IDs
|
|
||||||
let findNames (webLogId : WebLogId) conn (catIds : CategoryId list) = backgroundTask {
|
|
||||||
let! cats = rethink<Category list> {
|
|
||||||
withTable Table.Category
|
|
||||||
getAll (objList catIds)
|
|
||||||
filter "webLogId" webLogId
|
|
||||||
result; withRetryDefault conn
|
|
||||||
}
|
|
||||||
return cats |> List.map (fun c -> { name = CategoryId.toString c.id; value = c.name})
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Update a category
|
|
||||||
let update (cat : Category) =
|
|
||||||
rethink {
|
|
||||||
withTable Table.Category
|
|
||||||
get cat.id
|
|
||||||
update [ "name", cat.name :> obj
|
|
||||||
"slug", cat.slug
|
|
||||||
"description", cat.description
|
|
||||||
"parentId", cat.parentId
|
|
||||||
]
|
|
||||||
write; withRetryDefault; ignoreResult
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
/// Functions to manipulate pages
|
|
||||||
module Page =
|
|
||||||
|
|
||||||
open RethinkDb.Driver.Model
|
|
||||||
|
|
||||||
/// Add a new page
|
|
||||||
let add (page : Page) =
|
|
||||||
rethink {
|
|
||||||
withTable Table.Page
|
|
||||||
insert page
|
|
||||||
write; withRetryDefault; ignoreResult
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Count all pages for a web log
|
|
||||||
let countAll (webLogId : WebLogId) =
|
|
||||||
rethink<int> {
|
|
||||||
withTable Table.Page
|
|
||||||
getAll [ webLogId ] (nameof webLogId)
|
|
||||||
count
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Count listed pages for a web log
|
|
||||||
let countListed (webLogId : WebLogId) =
|
|
||||||
rethink<int> {
|
|
||||||
withTable Table.Page
|
|
||||||
getAll [ webLogId ] (nameof webLogId)
|
|
||||||
filter "showInPageList" true
|
|
||||||
count
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Delete a page
|
|
||||||
let delete (pageId : PageId) (webLogId : WebLogId) conn = backgroundTask {
|
|
||||||
let! result =
|
|
||||||
rethink<Result> {
|
|
||||||
withTable Table.Page
|
|
||||||
getAll [ pageId ]
|
|
||||||
filter (fun row -> row["webLogId"].Eq webLogId :> obj)
|
|
||||||
delete
|
|
||||||
write; withRetryDefault conn
|
|
||||||
}
|
|
||||||
return result.Deleted > 0UL
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Retrieve all pages for a web log (excludes text, prior permalinks, and revisions)
|
|
||||||
let findAll (webLogId : WebLogId) =
|
|
||||||
rethink<Page list> {
|
|
||||||
withTable Table.Page
|
|
||||||
getAll [ webLogId ] (nameof webLogId)
|
|
||||||
without [ "text"; "priorPermalinks"; "revisions" ]
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Find a page by its ID (including prior permalinks and revisions)
|
|
||||||
let findByFullId (pageId : PageId) webLogId =
|
|
||||||
rethink<Page> {
|
|
||||||
withTable Table.Page
|
|
||||||
get pageId
|
|
||||||
resultOption; withRetryOptionDefault
|
|
||||||
}
|
|
||||||
|> verifyWebLog webLogId (fun it -> it.webLogId)
|
|
||||||
|
|
||||||
/// Find a page by its ID (excludes prior permalinks and revisions)
|
|
||||||
let findById (pageId : PageId) webLogId =
|
|
||||||
rethink<Page> {
|
|
||||||
withTable Table.Page
|
|
||||||
get pageId
|
|
||||||
without [ "priorPermalinks"; "revisions" ]
|
|
||||||
resultOption; withRetryOptionDefault
|
|
||||||
}
|
|
||||||
|> verifyWebLog webLogId (fun it -> it.webLogId)
|
|
||||||
|
|
||||||
/// Find a page by its permalink
|
|
||||||
let findByPermalink (permalink : Permalink) (webLogId : WebLogId) =
|
|
||||||
rethink<Page list> {
|
|
||||||
withTable Table.Page
|
|
||||||
getAll [ r.Array (webLogId, permalink) ] (nameof permalink)
|
|
||||||
without [ "priorPermalinks"; "revisions" ]
|
|
||||||
limit 1
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|> tryFirst
|
|
||||||
|
|
||||||
/// Find the current permalink for a page by a prior permalink
|
|
||||||
let findCurrentPermalink (permalinks : Permalink list) (webLogId : WebLogId) conn = backgroundTask {
|
|
||||||
let! result =
|
|
||||||
(rethink<Page list> {
|
|
||||||
withTable Table.Page
|
|
||||||
getAll (objList permalinks) "priorPermalinks"
|
|
||||||
filter "webLogId" webLogId
|
|
||||||
without [ "revisions"; "text" ]
|
|
||||||
limit 1
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|> tryFirst) conn
|
|
||||||
return result |> Option.map (fun pg -> pg.permalink)
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Find all pages in the page list for the given web log
|
|
||||||
let findListed (webLogId : WebLogId) =
|
|
||||||
rethink<Page list> {
|
|
||||||
withTable Table.Page
|
|
||||||
getAll [ webLogId ] (nameof webLogId)
|
|
||||||
filter [ "showInPageList", true :> obj ]
|
|
||||||
without [ "text"; "priorPermalinks"; "revisions" ]
|
|
||||||
orderBy "title"
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Find a list of pages (displayed in admin area)
|
|
||||||
let findPageOfPages (webLogId : WebLogId) pageNbr =
|
|
||||||
rethink<Page list> {
|
|
||||||
withTable Table.Page
|
|
||||||
getAll [ webLogId ] (nameof webLogId)
|
|
||||||
without [ "priorPermalinks"; "revisions" ]
|
|
||||||
orderByFunc (fun row -> row["title"].Downcase ())
|
|
||||||
skip ((pageNbr - 1) * 25)
|
|
||||||
limit 25
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Update a page
|
|
||||||
let update (page : Page) =
|
|
||||||
rethink {
|
|
||||||
withTable Table.Page
|
|
||||||
get page.id
|
|
||||||
update [
|
|
||||||
"title", page.title :> obj
|
|
||||||
"permalink", page.permalink
|
|
||||||
"updatedOn", page.updatedOn
|
|
||||||
"showInPageList", page.showInPageList
|
|
||||||
"template", page.template
|
|
||||||
"text", page.text
|
|
||||||
"priorPermalinks", page.priorPermalinks
|
|
||||||
"metadata", page.metadata
|
|
||||||
"revisions", page.revisions
|
|
||||||
]
|
|
||||||
write; withRetryDefault; ignoreResult
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Update prior permalinks for a page
|
|
||||||
let updatePriorPermalinks pageId webLogId (permalinks : Permalink list) conn = backgroundTask {
|
|
||||||
match! findById pageId webLogId conn with
|
|
||||||
| Some _ ->
|
|
||||||
do! rethink {
|
|
||||||
withTable Table.Page
|
|
||||||
get pageId
|
|
||||||
update [ "priorPermalinks", permalinks :> obj ]
|
|
||||||
write; withRetryDefault; ignoreResult conn
|
|
||||||
}
|
|
||||||
return true
|
|
||||||
| None -> return false
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
/// Functions to manipulate posts
|
|
||||||
module Post =
|
|
||||||
|
|
||||||
open System
|
|
||||||
open RethinkDb.Driver.Model
|
|
||||||
|
|
||||||
/// Add a post
|
|
||||||
let add (post : Post) =
|
|
||||||
rethink {
|
|
||||||
withTable Table.Post
|
|
||||||
insert post
|
|
||||||
write; withRetryDefault; ignoreResult
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Count posts for a web log by their status
|
|
||||||
let countByStatus (status : PostStatus) (webLogId : WebLogId) =
|
|
||||||
rethink<int> {
|
|
||||||
withTable Table.Post
|
|
||||||
getAll [ webLogId ] (nameof webLogId)
|
|
||||||
filter "status" status
|
|
||||||
count
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Delete a post
|
|
||||||
let delete (postId : PostId) (webLogId : WebLogId) conn = backgroundTask {
|
|
||||||
let! result =
|
|
||||||
rethink<Result> {
|
|
||||||
withTable Table.Post
|
|
||||||
getAll [ postId ]
|
|
||||||
filter (fun row -> row["webLogId"].Eq webLogId :> obj)
|
|
||||||
delete
|
|
||||||
write; withRetryDefault conn
|
|
||||||
}
|
|
||||||
return result.Deleted > 0UL
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Find a post by its permalink
|
|
||||||
let findByPermalink (permalink : Permalink) (webLogId : WebLogId) =
|
|
||||||
rethink<Post list> {
|
|
||||||
withTable Table.Post
|
|
||||||
getAll [ r.Array (webLogId, permalink) ] (nameof permalink)
|
|
||||||
without [ "priorPermalinks"; "revisions" ]
|
|
||||||
limit 1
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|> tryFirst
|
|
||||||
|
|
||||||
/// Find a post by its ID, including all revisions and prior permalinks
|
|
||||||
let findByFullId (postId : PostId) webLogId =
|
|
||||||
rethink<Post> {
|
|
||||||
withTable Table.Post
|
|
||||||
get postId
|
|
||||||
resultOption; withRetryOptionDefault
|
|
||||||
}
|
|
||||||
|> verifyWebLog webLogId (fun p -> p.webLogId)
|
|
||||||
|
|
||||||
/// Find the current permalink for a post by a prior permalink
|
|
||||||
let findCurrentPermalink (permalinks : Permalink list) (webLogId : WebLogId) conn = backgroundTask {
|
|
||||||
let! result =
|
|
||||||
(rethink<Post list> {
|
|
||||||
withTable Table.Post
|
|
||||||
getAll (objList permalinks) "priorPermalinks"
|
|
||||||
filter "webLogId" webLogId
|
|
||||||
without [ "revisions"; "text" ]
|
|
||||||
limit 1
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|> tryFirst) conn
|
|
||||||
return result |> Option.map (fun post -> post.permalink)
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Find posts to be displayed on a category list page
|
|
||||||
let findPageOfCategorizedPosts (webLogId : WebLogId) (catIds : CategoryId list) pageNbr postsPerPage =
|
|
||||||
rethink<Post list> {
|
|
||||||
withTable Table.Post
|
|
||||||
getAll (objList catIds) "categoryIds"
|
|
||||||
filter "webLogId" webLogId
|
|
||||||
filter "status" Published
|
|
||||||
without [ "priorPermalinks"; "revisions" ]
|
|
||||||
distinct
|
|
||||||
orderByDescending "publishedOn"
|
|
||||||
skip ((pageNbr - 1) * postsPerPage)
|
|
||||||
limit (postsPerPage + 1)
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Find posts to be displayed on an admin page
|
|
||||||
let findPageOfPosts (webLogId : WebLogId) (pageNbr : int) postsPerPage =
|
|
||||||
rethink<Post list> {
|
|
||||||
withTable Table.Post
|
|
||||||
getAll [ webLogId ] (nameof webLogId)
|
|
||||||
without [ "priorPermalinks"; "revisions" ]
|
|
||||||
orderByFuncDescending (fun row -> row["publishedOn"].Default_ "updatedOn" :> obj)
|
|
||||||
skip ((pageNbr - 1) * postsPerPage)
|
|
||||||
limit (postsPerPage + 1)
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Find posts to be displayed on a page
|
|
||||||
let findPageOfPublishedPosts (webLogId : WebLogId) pageNbr postsPerPage =
|
|
||||||
rethink<Post list> {
|
|
||||||
withTable Table.Post
|
|
||||||
getAll [ webLogId ] (nameof webLogId)
|
|
||||||
filter "status" Published
|
|
||||||
without [ "priorPermalinks"; "revisions" ]
|
|
||||||
orderByDescending "publishedOn"
|
|
||||||
skip ((pageNbr - 1) * postsPerPage)
|
|
||||||
limit (postsPerPage + 1)
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Find posts to be displayed on a tag list page
|
|
||||||
let findPageOfTaggedPosts (webLogId : WebLogId) (tag : string) pageNbr postsPerPage =
|
|
||||||
rethink<Post list> {
|
|
||||||
withTable Table.Post
|
|
||||||
getAll [ tag ] "tags"
|
|
||||||
filter "webLogId" webLogId
|
|
||||||
filter "status" Published
|
|
||||||
without [ "priorPermalinks"; "revisions" ]
|
|
||||||
orderByDescending "publishedOn"
|
|
||||||
skip ((pageNbr - 1) * postsPerPage)
|
|
||||||
limit (postsPerPage + 1)
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Find the next older and newer post for the given post
|
|
||||||
let findSurroundingPosts (webLogId : WebLogId) (publishedOn : DateTime) conn = backgroundTask {
|
|
||||||
let! older =
|
|
||||||
rethink<Post list> {
|
|
||||||
withTable Table.Post
|
|
||||||
getAll [ webLogId ] (nameof webLogId)
|
|
||||||
filter (fun row -> row["publishedOn"].Lt publishedOn :> obj)
|
|
||||||
orderByDescending "publishedOn"
|
|
||||||
limit 1
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|> tryFirst <| conn
|
|
||||||
let! newer =
|
|
||||||
rethink<Post list> {
|
|
||||||
withTable Table.Post
|
|
||||||
getAll [ webLogId ] (nameof webLogId)
|
|
||||||
filter (fun row -> row["publishedOn"].Gt publishedOn :> obj)
|
|
||||||
orderBy "publishedOn"
|
|
||||||
limit 1
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|> tryFirst <| conn
|
|
||||||
return older, newer
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Update a post (all fields are updated)
|
|
||||||
let update (post : Post) =
|
|
||||||
rethink {
|
|
||||||
withTable Table.Post
|
|
||||||
get post.id
|
|
||||||
replace post
|
|
||||||
write; withRetryDefault; ignoreResult
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Update prior permalinks for a post
|
|
||||||
let updatePriorPermalinks (postId : PostId) webLogId (permalinks : Permalink list) conn = backgroundTask {
|
|
||||||
match! (
|
|
||||||
rethink<Post> {
|
|
||||||
withTable Table.Post
|
|
||||||
get postId
|
|
||||||
without [ "revisions"; "priorPermalinks" ]
|
|
||||||
resultOption; withRetryOptionDefault
|
|
||||||
}
|
|
||||||
|> verifyWebLog webLogId (fun p -> p.webLogId)) conn with
|
|
||||||
| Some _ ->
|
|
||||||
do! rethink {
|
|
||||||
withTable Table.Post
|
|
||||||
get postId
|
|
||||||
update [ "priorPermalinks", permalinks :> obj ]
|
|
||||||
write; withRetryDefault; ignoreResult conn
|
|
||||||
}
|
|
||||||
return true
|
|
||||||
| None -> return false
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
/// Functions to manipulate tag mappings
|
|
||||||
module TagMap =
|
|
||||||
|
|
||||||
open RethinkDb.Driver.Model
|
|
||||||
|
|
||||||
/// Delete a tag mapping
|
|
||||||
let delete (tagMapId : TagMapId) (webLogId : WebLogId) conn = backgroundTask {
|
|
||||||
let! result =
|
|
||||||
rethink<Result> {
|
|
||||||
withTable Table.TagMap
|
|
||||||
getAll [ tagMapId ]
|
|
||||||
filter (fun row -> row["webLogId"].Eq webLogId :> obj)
|
|
||||||
delete
|
|
||||||
write; withRetryDefault conn
|
|
||||||
}
|
|
||||||
return result.Deleted > 0UL
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Find a tag map by its ID
|
|
||||||
let findById (tagMapId : TagMapId) webLogId =
|
|
||||||
rethink<TagMap> {
|
|
||||||
withTable Table.TagMap
|
|
||||||
get tagMapId
|
|
||||||
resultOption; withRetryOptionDefault
|
|
||||||
}
|
|
||||||
|> verifyWebLog webLogId (fun tm -> tm.webLogId)
|
|
||||||
|
|
||||||
/// Find a tag mapping via URL value for a given web log
|
|
||||||
let findByUrlValue (urlValue : string) (webLogId : WebLogId) =
|
|
||||||
rethink<TagMap list> {
|
|
||||||
withTable Table.TagMap
|
|
||||||
getAll [ r.Array (webLogId, urlValue) ] "webLogAndUrl"
|
|
||||||
limit 1
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|> tryFirst
|
|
||||||
|
|
||||||
/// Find all tag mappings for a web log
|
|
||||||
let findByWebLogId (webLogId : WebLogId) =
|
|
||||||
rethink<TagMap list> {
|
|
||||||
withTable Table.TagMap
|
|
||||||
between (r.Array (webLogId, r.Minval ())) (r.Array (webLogId, r.Maxval ())) [ Index "webLogAndTag" ]
|
|
||||||
orderBy "tag"
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Retrieve mappings for the specified tags
|
|
||||||
let findMappingForTags (tags : string list) (webLogId : WebLogId) =
|
|
||||||
rethink<TagMap list> {
|
|
||||||
withTable Table.TagMap
|
|
||||||
getAll (tags |> List.map (fun tag -> r.Array (webLogId, tag) :> obj)) "webLogAndTag"
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Save a tag mapping
|
|
||||||
let save (tagMap : TagMap) =
|
|
||||||
rethink {
|
|
||||||
withTable Table.TagMap
|
|
||||||
get tagMap.id
|
|
||||||
replace tagMap
|
|
||||||
write; withRetryDefault; ignoreResult
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
/// Functions to manipulate themes
|
|
||||||
module Theme =
|
|
||||||
|
|
||||||
/// Get all themes
|
|
||||||
let list =
|
|
||||||
rethink<Theme list> {
|
|
||||||
withTable Table.Theme
|
|
||||||
filter (fun row -> row["id"].Ne "admin" :> obj)
|
|
||||||
without [ "templates" ]
|
|
||||||
orderBy "id"
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Retrieve a theme by its ID
|
|
||||||
let findById (themeId : ThemeId) =
|
|
||||||
rethink<Theme> {
|
|
||||||
withTable Table.Theme
|
|
||||||
get themeId
|
|
||||||
resultOption; withRetryOptionDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Retrieve a theme by its ID, excluding the text of templates
|
|
||||||
let findByIdWithoutText (themeId : ThemeId) =
|
|
||||||
rethink<Theme> {
|
|
||||||
withTable Table.Theme
|
|
||||||
get themeId
|
|
||||||
merge (fun row -> r.HashMap ("templates", row["templates"].Without [| "text" |]))
|
|
||||||
resultOption; withRetryOptionDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Save a theme
|
|
||||||
let save (theme : Theme) =
|
|
||||||
rethink {
|
|
||||||
withTable Table.Theme
|
|
||||||
get theme.id
|
|
||||||
replace theme
|
|
||||||
write; withRetryDefault; ignoreResult
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
/// Functions to manipulate theme assets
|
|
||||||
module ThemeAsset =
|
|
||||||
|
|
||||||
open RethinkDb.Driver.Ast
|
|
||||||
|
|
||||||
/// Match the ID by its prefix (the theme ID)
|
|
||||||
let private matchById themeId =
|
|
||||||
let keyPrefix = $"^{ThemeId.toString themeId}/"
|
|
||||||
fun (row : ReqlExpr) -> row["id"].Match keyPrefix :> obj
|
|
||||||
|
|
||||||
/// List all theme assets (excludes data)
|
|
||||||
let all =
|
|
||||||
rethink<ThemeAsset list> {
|
|
||||||
withTable Table.ThemeAsset
|
|
||||||
without [ "data" ]
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Delete all assets for a theme
|
|
||||||
let deleteByTheme themeId =
|
|
||||||
rethink {
|
|
||||||
withTable Table.ThemeAsset
|
|
||||||
filter (matchById themeId)
|
|
||||||
delete
|
|
||||||
write; withRetryDefault; ignoreResult
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Find a theme asset by its ID
|
|
||||||
let findById (assetId : ThemeAssetId) =
|
|
||||||
rethink<ThemeAsset> {
|
|
||||||
withTable Table.ThemeAsset
|
|
||||||
get assetId
|
|
||||||
resultOption; withRetryOptionDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// List all assets for a theme (data excluded)
|
|
||||||
let findByThemeId (themeId : ThemeId) =
|
|
||||||
rethink<ThemeAsset list> {
|
|
||||||
withTable Table.ThemeAsset
|
|
||||||
filter (matchById themeId)
|
|
||||||
without [ "data" ]
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Save a theme asset
|
|
||||||
let save (asset : ThemeAsset) =
|
|
||||||
rethink {
|
|
||||||
withTable Table.ThemeAsset
|
|
||||||
get asset.id
|
|
||||||
replace asset
|
|
||||||
write; withRetryDefault; ignoreResult
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
/// Functions to manipulate web logs
|
|
||||||
module WebLog =
|
|
||||||
|
|
||||||
/// Add a web log
|
|
||||||
let add (webLog : WebLog) = rethink {
|
|
||||||
withTable Table.WebLog
|
|
||||||
insert webLog
|
|
||||||
write; withRetryOnce; ignoreResult
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Get all web logs
|
|
||||||
let all = rethink<WebLog list> {
|
|
||||||
withTable Table.WebLog
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Retrieve a web log by the URL base
|
|
||||||
let findByHost (url : string) =
|
|
||||||
rethink<WebLog list> {
|
|
||||||
withTable Table.WebLog
|
|
||||||
getAll [ url ] "urlBase"
|
|
||||||
limit 1
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|> tryFirst
|
|
||||||
|
|
||||||
/// Retrieve a web log by its ID
|
|
||||||
let findById (webLogId : WebLogId) =
|
|
||||||
rethink<WebLog> {
|
|
||||||
withTable Table.WebLog
|
|
||||||
get webLogId
|
|
||||||
resultOption; withRetryOptionDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Update RSS options for a web log
|
|
||||||
let updateRssOptions (webLog : WebLog) =
|
|
||||||
rethink {
|
|
||||||
withTable Table.WebLog
|
|
||||||
get webLog.id
|
|
||||||
update [ "rss", webLog.rss :> obj ]
|
|
||||||
write; withRetryDefault; ignoreResult
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Update web log settings (from settings page)
|
|
||||||
let updateSettings (webLog : WebLog) =
|
|
||||||
rethink {
|
|
||||||
withTable Table.WebLog
|
|
||||||
get webLog.id
|
|
||||||
update [
|
|
||||||
"name", webLog.name :> obj
|
|
||||||
"subtitle", webLog.subtitle
|
|
||||||
"defaultPage", webLog.defaultPage
|
|
||||||
"postsPerPage", webLog.postsPerPage
|
|
||||||
"timeZone", webLog.timeZone
|
|
||||||
"themePath", webLog.themePath
|
|
||||||
"autoHtmx", webLog.autoHtmx
|
|
||||||
]
|
|
||||||
write; withRetryDefault; ignoreResult
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
/// Functions to manipulate web log users
|
|
||||||
module WebLogUser =
|
|
||||||
|
|
||||||
/// Add a web log user
|
|
||||||
let add (user : WebLogUser) =
|
|
||||||
rethink {
|
|
||||||
withTable Table.WebLogUser
|
|
||||||
insert user
|
|
||||||
write; withRetryDefault; ignoreResult
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Find a user by their e-mail address
|
|
||||||
let findByEmail (email : string) (webLogId : WebLogId) =
|
|
||||||
rethink<WebLogUser list> {
|
|
||||||
withTable Table.WebLogUser
|
|
||||||
getAll [ r.Array (webLogId, email) ] "logOn"
|
|
||||||
limit 1
|
|
||||||
result; withRetryDefault
|
|
||||||
}
|
|
||||||
|> tryFirst
|
|
||||||
|
|
||||||
/// Find a user by their ID
|
|
||||||
let findById (userId : WebLogUserId) =
|
|
||||||
rethink<WebLogUser> {
|
|
||||||
withTable Table.WebLogUser
|
|
||||||
get userId
|
|
||||||
resultOption; withRetryOptionDefault
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Get a user ID -> name dictionary for the given user IDs
|
|
||||||
let findNames (webLogId : WebLogId) conn (userIds : WebLogUserId list) = backgroundTask {
|
|
||||||
let! users = rethink<WebLogUser list> {
|
|
||||||
withTable Table.WebLogUser
|
|
||||||
getAll (objList userIds)
|
|
||||||
filter "webLogId" webLogId
|
|
||||||
result; withRetryDefault conn
|
|
||||||
}
|
|
||||||
return users |> List.map (fun u -> { name = WebLogUserId.toString u.id; value = WebLogUser.displayName u })
|
|
||||||
}
|
|
||||||
|
|
||||||
/// Update a user
|
|
||||||
let update (user : WebLogUser) =
|
|
||||||
rethink {
|
|
||||||
withTable Table.WebLogUser
|
|
||||||
get user.id
|
|
||||||
update [
|
|
||||||
"firstName", user.firstName :> obj
|
|
||||||
"lastName", user.lastName
|
|
||||||
"preferredName", user.preferredName
|
|
||||||
"passwordHash", user.passwordHash
|
|
||||||
"salt", user.salt
|
|
||||||
]
|
|
||||||
write; withRetryDefault; ignoreResult
|
|
||||||
}
|
|
||||||
|
|
||||||
248
src/MyWebLog.Data/Interfaces.fs
Normal file
248
src/MyWebLog.Data/Interfaces.fs
Normal file
|
|
@ -0,0 +1,248 @@
|
||||||
|
namespace MyWebLog.Data
|
||||||
|
|
||||||
|
open System
|
||||||
|
open System.Threading.Tasks
|
||||||
|
open MyWebLog
|
||||||
|
open MyWebLog.ViewModels
|
||||||
|
|
||||||
|
/// Data functions to support manipulating categories
|
||||||
|
type ICategoryData =
|
||||||
|
|
||||||
|
/// Add a category
|
||||||
|
abstract member add : Category -> Task<unit>
|
||||||
|
|
||||||
|
/// Count all categories for the given web log
|
||||||
|
abstract member countAll : WebLogId -> Task<int>
|
||||||
|
|
||||||
|
/// Count all top-level categories for the given web log
|
||||||
|
abstract member countTopLevel : WebLogId -> Task<int>
|
||||||
|
|
||||||
|
/// Delete a category (also removes it from posts)
|
||||||
|
abstract member delete : CategoryId -> WebLogId -> Task<bool>
|
||||||
|
|
||||||
|
/// Find all categories for a web log, sorted alphabetically and grouped by hierarchy
|
||||||
|
abstract member findAllForView : WebLogId -> Task<DisplayCategory[]>
|
||||||
|
|
||||||
|
/// Find a category by its ID
|
||||||
|
abstract member findById : CategoryId -> WebLogId -> Task<Category option>
|
||||||
|
|
||||||
|
/// Update a category (slug, name, description, and parent ID)
|
||||||
|
abstract member update : Category -> Task<unit>
|
||||||
|
|
||||||
|
|
||||||
|
/// Data functions to support manipulating pages
|
||||||
|
type IPageData =
|
||||||
|
|
||||||
|
/// Add a page
|
||||||
|
abstract member add : Page -> Task<unit>
|
||||||
|
|
||||||
|
/// Get all pages for the web log (excluding text, revisions, and prior permalinks)
|
||||||
|
abstract member all : WebLogId -> Task<Page list>
|
||||||
|
|
||||||
|
/// Count all pages for the given web log
|
||||||
|
abstract member countAll : WebLogId -> Task<int>
|
||||||
|
|
||||||
|
/// Count pages marked as "show in page list" for the given web log
|
||||||
|
abstract member countListed : WebLogId -> Task<int>
|
||||||
|
|
||||||
|
/// Delete a page
|
||||||
|
abstract member delete : PageId -> WebLogId -> Task<bool>
|
||||||
|
|
||||||
|
/// Find a page by its ID (excluding revisions and prior permalinks)
|
||||||
|
abstract member findById : PageId -> WebLogId -> Task<Page option>
|
||||||
|
|
||||||
|
/// Find a page by its permalink (excluding revisions and prior permalinks)
|
||||||
|
abstract member findByPermalink : Permalink -> WebLogId -> Task<Page option>
|
||||||
|
|
||||||
|
/// Find the current permalink for a page from a list of prior permalinks
|
||||||
|
abstract member findCurrentPermalink : Permalink list -> WebLogId -> Task<Permalink option>
|
||||||
|
|
||||||
|
/// Find a page by its ID (including revisions and prior permalinks)
|
||||||
|
abstract member findFullById : PageId -> WebLogId -> Task<Page option>
|
||||||
|
|
||||||
|
/// Find pages marked as "show in page list" for the given web log (excluding text, revisions, and prior permalinks)
|
||||||
|
abstract member findListed : WebLogId -> Task<Page list>
|
||||||
|
|
||||||
|
/// Find a page of pages (displayed in admin section) (excluding revisions and prior permalinks)
|
||||||
|
abstract member findPageOfPages : WebLogId -> pageNbr : int -> Task<Page list>
|
||||||
|
|
||||||
|
/// Update a page
|
||||||
|
abstract member update : Page -> Task<unit>
|
||||||
|
|
||||||
|
/// Update the prior permalinks for the given page
|
||||||
|
abstract member updatePriorPermalinks : PageId -> WebLogId -> Permalink list -> Task<bool>
|
||||||
|
|
||||||
|
|
||||||
|
/// Data functions to support manipulating posts
|
||||||
|
type IPostData =
|
||||||
|
|
||||||
|
/// Add a post
|
||||||
|
abstract member add : Post -> Task<unit>
|
||||||
|
|
||||||
|
/// Count posts by their status
|
||||||
|
abstract member countByStatus : PostStatus -> WebLogId -> Task<int>
|
||||||
|
|
||||||
|
/// Delete a post
|
||||||
|
abstract member delete : PostId -> WebLogId -> Task<bool>
|
||||||
|
|
||||||
|
/// Find a post by its permalink (excluding revisions and prior permalinks)
|
||||||
|
abstract member findByPermalink : Permalink -> WebLogId -> Task<Post option>
|
||||||
|
|
||||||
|
/// Find the current permalink for a post from a list of prior permalinks
|
||||||
|
abstract member findCurrentPermalink : Permalink list -> WebLogId -> Task<Permalink option>
|
||||||
|
|
||||||
|
/// Find a post by its ID (including revisions and prior permalinks)
|
||||||
|
abstract member findFullById : PostId -> WebLogId -> Task<Post option>
|
||||||
|
|
||||||
|
/// Find posts to be displayed on a category list page (excluding revisions and prior permalinks)
|
||||||
|
abstract member findPageOfCategorizedPosts :
|
||||||
|
WebLogId -> CategoryId list -> pageNbr : int -> postsPerPage : int -> Task<Post list>
|
||||||
|
|
||||||
|
/// Find posts to be displayed on an admin page (excluding revisions and prior permalinks)
|
||||||
|
abstract member findPageOfPosts : WebLogId -> pageNbr : int -> postsPerPage : int -> Task<Post list>
|
||||||
|
|
||||||
|
/// Find posts to be displayed on a page (excluding revisions and prior permalinks)
|
||||||
|
abstract member findPageOfPublishedPosts : WebLogId -> pageNbr : int -> postsPerPage : int -> Task<Post list>
|
||||||
|
|
||||||
|
/// Find posts to be displayed on a tag list page (excluding revisions and prior permalinks)
|
||||||
|
abstract member findPageOfTaggedPosts :
|
||||||
|
WebLogId -> tag : string -> pageNbr : int -> postsPerPage : int -> Task<Post list>
|
||||||
|
|
||||||
|
/// Find the next older and newer post for the given published date/time (excluding revisions and prior permalinks)
|
||||||
|
abstract member findSurroundingPosts : WebLogId -> publishedOn : DateTime -> Task<Post option * Post option>
|
||||||
|
|
||||||
|
/// Update a post
|
||||||
|
abstract member update : Post -> Task<unit>
|
||||||
|
|
||||||
|
/// Update the prior permalinks for a post
|
||||||
|
abstract member updatePriorPermalinks : PostId -> WebLogId -> Permalink list -> Task<bool>
|
||||||
|
|
||||||
|
|
||||||
|
/// Functions to manipulate tag mappings
|
||||||
|
type ITagMapData =
|
||||||
|
|
||||||
|
/// Retrieve all tag mappings for the given web log
|
||||||
|
abstract member all : WebLogId -> Task<TagMap list>
|
||||||
|
|
||||||
|
/// Delete a tag mapping
|
||||||
|
abstract member delete : TagMapId -> WebLogId -> Task<bool>
|
||||||
|
|
||||||
|
/// Find a tag mapping by its ID
|
||||||
|
abstract member findById : TagMapId -> WebLogId -> Task<TagMap option>
|
||||||
|
|
||||||
|
/// Find a tag mapping by its URL value
|
||||||
|
abstract member findByUrlValue : string -> WebLogId -> Task<TagMap option>
|
||||||
|
|
||||||
|
/// Find tag mappings for the given tags
|
||||||
|
abstract member findMappingForTags : tags : string list -> WebLogId -> Task<TagMap list>
|
||||||
|
|
||||||
|
/// Save a tag mapping (insert or update)
|
||||||
|
abstract member save : TagMap -> Task<unit>
|
||||||
|
|
||||||
|
|
||||||
|
/// Functions to manipulate themes
|
||||||
|
type IThemeData =
|
||||||
|
|
||||||
|
/// Retrieve all themes (except "admin")
|
||||||
|
abstract member all : unit -> Task<Theme list>
|
||||||
|
|
||||||
|
/// Find a theme by its ID
|
||||||
|
abstract member findById : ThemeId -> Task<Theme option>
|
||||||
|
|
||||||
|
/// Find a theme by its ID (excluding the text of its templates)
|
||||||
|
abstract member findByIdWithoutText : ThemeId -> Task<Theme option>
|
||||||
|
|
||||||
|
/// Save a theme (insert or update)
|
||||||
|
abstract member save : Theme -> Task<unit>
|
||||||
|
|
||||||
|
|
||||||
|
/// Functions to manipulate theme assets
|
||||||
|
type IThemeAssetData =
|
||||||
|
|
||||||
|
/// Retrieve all theme assets (excluding data)
|
||||||
|
abstract member all : unit -> Task<ThemeAsset list>
|
||||||
|
|
||||||
|
/// Delete all theme assets for the given theme
|
||||||
|
abstract member deleteByTheme : ThemeId -> Task<unit>
|
||||||
|
|
||||||
|
/// Find a theme asset by its ID
|
||||||
|
abstract member findById : ThemeAssetId -> Task<ThemeAsset option>
|
||||||
|
|
||||||
|
/// Find all assets for the given theme (excludes data)
|
||||||
|
abstract member findByTheme : ThemeId -> Task<ThemeAsset list>
|
||||||
|
|
||||||
|
/// Save a theme asset (insert or update)
|
||||||
|
abstract member save : ThemeAsset -> Task<unit>
|
||||||
|
|
||||||
|
|
||||||
|
/// Functions to manipulate web logs
|
||||||
|
type IWebLogData =
|
||||||
|
|
||||||
|
/// Add a web log
|
||||||
|
abstract member add : WebLog -> Task<unit>
|
||||||
|
|
||||||
|
/// Retrieve all web logs
|
||||||
|
abstract member all : unit -> Task<WebLog list>
|
||||||
|
|
||||||
|
/// Find a web log by its host (URL base)
|
||||||
|
abstract member findByHost : string -> Task<WebLog option>
|
||||||
|
|
||||||
|
/// Find a web log by its ID
|
||||||
|
abstract member findById : WebLogId -> Task<WebLog option>
|
||||||
|
|
||||||
|
/// Update RSS options for a web log
|
||||||
|
abstract member updateRssOptions : WebLog -> Task<unit>
|
||||||
|
|
||||||
|
/// Update web log settings (from the settings page)
|
||||||
|
abstract member updateSettings : WebLog -> Task<unit>
|
||||||
|
|
||||||
|
|
||||||
|
/// Functions to manipulate web log users
|
||||||
|
type IWebLogUserData =
|
||||||
|
|
||||||
|
/// Add a web log user
|
||||||
|
abstract member add : WebLogUser -> Task<unit>
|
||||||
|
|
||||||
|
/// Find a web log user by their e-mail address
|
||||||
|
abstract member findByEmail : email : string -> WebLogId -> Task<WebLogUser option>
|
||||||
|
|
||||||
|
/// Find a web log user by their ID
|
||||||
|
abstract member findById : WebLogUserId -> WebLogId -> Task<WebLogUser option>
|
||||||
|
|
||||||
|
/// Get a user ID -> name dictionary for the given user IDs
|
||||||
|
abstract member findNames : WebLogId -> WebLogUserId list -> Task<MetaItem list>
|
||||||
|
|
||||||
|
/// Update a web log user
|
||||||
|
abstract member update : WebLogUser -> Task<unit>
|
||||||
|
|
||||||
|
|
||||||
|
/// Data interface required for a myWebLog data implementation
|
||||||
|
type IData =
|
||||||
|
|
||||||
|
/// Category data functions
|
||||||
|
abstract member Category : ICategoryData
|
||||||
|
|
||||||
|
/// Page data functions
|
||||||
|
abstract member Page : IPageData
|
||||||
|
|
||||||
|
/// Post data functions
|
||||||
|
abstract member Post : IPostData
|
||||||
|
|
||||||
|
/// Tag map data functions
|
||||||
|
abstract member TagMap : ITagMapData
|
||||||
|
|
||||||
|
/// Theme data functions
|
||||||
|
abstract member Theme : IThemeData
|
||||||
|
|
||||||
|
/// Theme asset data functions
|
||||||
|
abstract member ThemeAsset : IThemeAssetData
|
||||||
|
|
||||||
|
/// Web log data functions
|
||||||
|
abstract member WebLog : IWebLogData
|
||||||
|
|
||||||
|
/// Web log user data functions
|
||||||
|
abstract member WebLogUser : IWebLogUserData
|
||||||
|
|
||||||
|
/// Do any required start up data checks
|
||||||
|
abstract member startUp : unit -> Task<unit>
|
||||||
|
|
||||||
526
src/MyWebLog.Data/LiteDbData.fs
Normal file
526
src/MyWebLog.Data/LiteDbData.fs
Normal 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 ()
|
||||||
|
}
|
||||||
|
|
@ -10,6 +10,7 @@
|
||||||
</ItemGroup>
|
</ItemGroup>
|
||||||
|
|
||||||
<ItemGroup>
|
<ItemGroup>
|
||||||
|
<PackageReference Include="LiteDB" Version="5.0.11" />
|
||||||
<PackageReference Include="Microsoft.Extensions.Configuration.Abstractions" Version="6.0.0" />
|
<PackageReference Include="Microsoft.Extensions.Configuration.Abstractions" Version="6.0.0" />
|
||||||
<PackageReference Include="Microsoft.FSharpLu.Json" Version="0.11.7" />
|
<PackageReference Include="Microsoft.FSharpLu.Json" Version="0.11.7" />
|
||||||
<PackageReference Include="Newtonsoft.Json" Version="13.0.1" />
|
<PackageReference Include="Newtonsoft.Json" Version="13.0.1" />
|
||||||
|
|
@ -20,7 +21,10 @@
|
||||||
|
|
||||||
<ItemGroup>
|
<ItemGroup>
|
||||||
<Compile Include="Converters.fs" />
|
<Compile Include="Converters.fs" />
|
||||||
<Compile Include="Data.fs" />
|
<Compile Include="Interfaces.fs" />
|
||||||
|
<Compile Include="Utils.fs" />
|
||||||
|
<Compile Include="RethinkDbData.fs" />
|
||||||
|
<Compile Include="LiteDbData.fs" />
|
||||||
</ItemGroup>
|
</ItemGroup>
|
||||||
|
|
||||||
</Project>
|
</Project>
|
||||||
|
|
|
||||||
790
src/MyWebLog.Data/RethinkDbData.fs
Normal file
790
src/MyWebLog.Data/RethinkDbData.fs
Normal file
|
|
@ -0,0 +1,790 @@
|
||||||
|
namespace MyWebLog.Data
|
||||||
|
|
||||||
|
open System.Threading.Tasks
|
||||||
|
open MyWebLog
|
||||||
|
open RethinkDb.Driver
|
||||||
|
|
||||||
|
/// Functions to assist with retrieving data
|
||||||
|
[<AutoOpen>]
|
||||||
|
module private RethinkHelpers =
|
||||||
|
|
||||||
|
/// Table names
|
||||||
|
[<RequireQualifiedAccess>]
|
||||||
|
module Table =
|
||||||
|
|
||||||
|
/// The category table
|
||||||
|
let Category = "Category"
|
||||||
|
|
||||||
|
/// The comment table
|
||||||
|
let Comment = "Comment"
|
||||||
|
|
||||||
|
/// The page table
|
||||||
|
let Page = "Page"
|
||||||
|
|
||||||
|
/// The post table
|
||||||
|
let Post = "Post"
|
||||||
|
|
||||||
|
/// The tag map table
|
||||||
|
let TagMap = "TagMap"
|
||||||
|
|
||||||
|
/// The theme table
|
||||||
|
let Theme = "Theme"
|
||||||
|
|
||||||
|
/// The theme asset table
|
||||||
|
let ThemeAsset = "ThemeAsset"
|
||||||
|
|
||||||
|
/// The web log table
|
||||||
|
let WebLog = "WebLog"
|
||||||
|
|
||||||
|
/// The web log user table
|
||||||
|
let WebLogUser = "WebLogUser"
|
||||||
|
|
||||||
|
/// A list of all tables
|
||||||
|
let all = [ Category; Comment; Page; Post; TagMap; Theme; ThemeAsset; WebLog; WebLogUser ]
|
||||||
|
|
||||||
|
|
||||||
|
/// Shorthand for the ReQL starting point
|
||||||
|
let r = RethinkDB.R
|
||||||
|
|
||||||
|
/// Verify that the web log ID matches before returning an item
|
||||||
|
let verifyWebLog<'T> webLogId (prop : 'T -> WebLogId) (f : Net.IConnection -> Task<'T option>) =
|
||||||
|
fun conn -> backgroundTask {
|
||||||
|
match! f conn with Some it when (prop it) = webLogId -> return Some it | _ -> return None
|
||||||
|
}
|
||||||
|
|
||||||
|
/// Get the first item from a list, or None if the list is empty
|
||||||
|
let tryFirst<'T> (f : Net.IConnection -> Task<'T list>) =
|
||||||
|
fun conn -> backgroundTask {
|
||||||
|
let! results = f conn
|
||||||
|
return results |> List.tryHead
|
||||||
|
}
|
||||||
|
|
||||||
|
/// Cast a strongly-typed list to an object list
|
||||||
|
let objList<'T> (objects : 'T list) = objects |> List.map (fun it -> it :> obj)
|
||||||
|
|
||||||
|
|
||||||
|
open Microsoft.Extensions.Logging
|
||||||
|
open MyWebLog.ViewModels
|
||||||
|
open RethinkDb.Driver.FSharp
|
||||||
|
|
||||||
|
/// RethinkDB implementation of data functions for myWebLog
|
||||||
|
type RethinkDbData (conn : Net.IConnection, config : DataConfig, log : ILogger<RethinkDbData>) =
|
||||||
|
|
||||||
|
/// Match theme asset IDs by their prefix (the theme ID)
|
||||||
|
let matchAssetByThemeId themeId =
|
||||||
|
let keyPrefix = $"^{ThemeId.toString themeId}/"
|
||||||
|
fun (row : Ast.ReqlExpr) -> row["id"].Match keyPrefix :> obj
|
||||||
|
|
||||||
|
/// Ensure field indexes exist, as well as special indexes for selected tables
|
||||||
|
let ensureIndexes table fields = backgroundTask {
|
||||||
|
let! indexes = rethink<string list> { withTable table; indexList; result; withRetryOnce conn }
|
||||||
|
for field in fields do
|
||||||
|
if not (indexes |> List.contains field) then
|
||||||
|
log.LogInformation $"Creating index {table}.{field}..."
|
||||||
|
do! rethink { withTable table; indexCreate field; write; withRetryOnce; ignoreResult conn }
|
||||||
|
// Post and page need index by web log ID and permalink
|
||||||
|
if [ Table.Page; Table.Post ] |> List.contains table then
|
||||||
|
if not (indexes |> List.contains "permalink") then
|
||||||
|
log.LogInformation $"Creating index {table}.permalink..."
|
||||||
|
do! rethink {
|
||||||
|
withTable table
|
||||||
|
indexCreate "permalink" (fun row -> r.Array (row["webLogId"], row["permalink"].Downcase ()) :> obj)
|
||||||
|
write; withRetryOnce; ignoreResult conn
|
||||||
|
}
|
||||||
|
// Prior permalinks are searched when a post or page permalink do not match the current URL
|
||||||
|
if not (indexes |> List.contains "priorPermalinks") then
|
||||||
|
log.LogInformation $"Creating index {table}.priorPermalinks..."
|
||||||
|
do! rethink {
|
||||||
|
withTable table
|
||||||
|
indexCreate "priorPermalinks" (fun row -> row["priorPermalinks"].Downcase () :> obj) [ Multi ]
|
||||||
|
write; withRetryOnce; ignoreResult conn
|
||||||
|
}
|
||||||
|
// Post needs indexes by category and tag (used for counting and retrieving posts)
|
||||||
|
if Table.Post = table then
|
||||||
|
for idx in [ "categoryIds"; "tags" ] do
|
||||||
|
if not (List.contains idx indexes) then
|
||||||
|
log.LogInformation $"Creating index {table}.{idx}..."
|
||||||
|
do! rethink {
|
||||||
|
withTable table
|
||||||
|
indexCreate idx [ Multi ]
|
||||||
|
write; withRetryOnce; ignoreResult conn
|
||||||
|
}
|
||||||
|
// Tag mapping needs an index by web log ID and both tag and URL values
|
||||||
|
if Table.TagMap = table then
|
||||||
|
if not (indexes |> List.contains "webLogAndTag") then
|
||||||
|
log.LogInformation $"Creating index {table}.webLogAndTag..."
|
||||||
|
do! rethink {
|
||||||
|
withTable table
|
||||||
|
indexCreate "webLogAndTag" (fun row -> r.Array (row["webLogId"], row["tag"]) :> obj)
|
||||||
|
write; withRetryOnce; ignoreResult conn
|
||||||
|
}
|
||||||
|
if not (indexes |> List.contains "webLogAndUrl") then
|
||||||
|
log.LogInformation $"Creating index {table}.webLogAndUrl..."
|
||||||
|
do! rethink {
|
||||||
|
withTable table
|
||||||
|
indexCreate "webLogAndUrl" (fun row -> r.Array (row["webLogId"], row["urlValue"]) :> obj)
|
||||||
|
write; withRetryOnce; ignoreResult conn
|
||||||
|
}
|
||||||
|
// Users log on with e-mail
|
||||||
|
if Table.WebLogUser = table && not (indexes |> List.contains "logOn") then
|
||||||
|
log.LogInformation $"Creating index {table}.logOn..."
|
||||||
|
do! rethink {
|
||||||
|
withTable table
|
||||||
|
indexCreate "logOn" (fun row -> r.Array (row["webLogId"], row["userName"]) :> obj)
|
||||||
|
write; withRetryOnce; ignoreResult conn
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
/// The connection for this instance
|
||||||
|
member _.Conn = conn
|
||||||
|
|
||||||
|
interface IData with
|
||||||
|
|
||||||
|
member _.Category = {
|
||||||
|
new ICategoryData with
|
||||||
|
|
||||||
|
member _.add cat = rethink {
|
||||||
|
withTable Table.Category
|
||||||
|
insert cat
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.countAll webLogId = rethink<int> {
|
||||||
|
withTable Table.Category
|
||||||
|
getAll [ webLogId ] (nameof webLogId)
|
||||||
|
count
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.countTopLevel webLogId = rethink<int> {
|
||||||
|
withTable Table.Category
|
||||||
|
getAll [ webLogId ] (nameof webLogId)
|
||||||
|
filter "parentId" None
|
||||||
|
count
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findAllForView webLogId = backgroundTask {
|
||||||
|
let! cats = rethink<Category list> {
|
||||||
|
withTable Table.Category
|
||||||
|
getAll [ webLogId ] (nameof webLogId)
|
||||||
|
orderByFunc (fun it -> it["name"].Downcase () :> obj)
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
let ordered = Utils.orderByHierarchy cats None None []
|
||||||
|
let! counts =
|
||||||
|
ordered
|
||||||
|
|> Seq.map (fun it -> backgroundTask {
|
||||||
|
// Parent category post counts include posts in subcategories
|
||||||
|
let catIds =
|
||||||
|
ordered
|
||||||
|
|> Seq.filter (fun cat -> cat.parentNames |> Array.contains it.name)
|
||||||
|
|> Seq.map (fun cat -> cat.id :> obj)
|
||||||
|
|> Seq.append (Seq.singleton it.id)
|
||||||
|
|> List.ofSeq
|
||||||
|
let! count = rethink<int> {
|
||||||
|
withTable Table.Post
|
||||||
|
getAll catIds "categoryIds"
|
||||||
|
filter "status" Published
|
||||||
|
distinct
|
||||||
|
count
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
return it.id, count
|
||||||
|
})
|
||||||
|
|> Task.WhenAll
|
||||||
|
return
|
||||||
|
ordered
|
||||||
|
|> Seq.map (fun cat ->
|
||||||
|
{ cat with
|
||||||
|
postCount = counts
|
||||||
|
|> Array.tryFind (fun c -> fst c = cat.id)
|
||||||
|
|> Option.map snd
|
||||||
|
|> Option.defaultValue 0
|
||||||
|
})
|
||||||
|
|> Array.ofSeq
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findById catId webLogId =
|
||||||
|
rethink<Category> {
|
||||||
|
withTable Table.Category
|
||||||
|
get catId
|
||||||
|
resultOption; withRetryOptionDefault
|
||||||
|
}
|
||||||
|
|> verifyWebLog webLogId (fun c -> c.webLogId) <| conn
|
||||||
|
|
||||||
|
member this.delete catId webLogId = backgroundTask {
|
||||||
|
match! this.findById catId webLogId with
|
||||||
|
| Some _ ->
|
||||||
|
// Delete the category off all posts where it is assigned
|
||||||
|
do! rethink {
|
||||||
|
withTable Table.Post
|
||||||
|
getAll [ webLogId ] (nameof webLogId)
|
||||||
|
filter (fun row -> row["categoryIds"].Contains catId :> obj)
|
||||||
|
update (fun row -> r.HashMap ("categoryIds", r.Array(row["categoryIds"]).Remove catId) :> obj)
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
// Delete the category itself
|
||||||
|
do! rethink {
|
||||||
|
withTable Table.Category
|
||||||
|
get catId
|
||||||
|
delete
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
return true
|
||||||
|
| None -> return false
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.update cat = rethink {
|
||||||
|
withTable Table.Category
|
||||||
|
get cat.id
|
||||||
|
update [ "name", cat.name :> obj
|
||||||
|
"slug", cat.slug
|
||||||
|
"description", cat.description
|
||||||
|
"parentId", cat.parentId
|
||||||
|
]
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.Page = {
|
||||||
|
new IPageData with
|
||||||
|
|
||||||
|
member _.add page = rethink {
|
||||||
|
withTable Table.Page
|
||||||
|
insert page
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.all webLogId = rethink<Page list> {
|
||||||
|
withTable Table.Page
|
||||||
|
getAll [ webLogId ] (nameof webLogId)
|
||||||
|
without [ "text"; "revisions"; "priorPermalinks" ]
|
||||||
|
orderByFunc (fun row -> row["title"].Downcase () :> obj)
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.countAll webLogId = rethink<int> {
|
||||||
|
withTable Table.Page
|
||||||
|
getAll [ webLogId ] (nameof webLogId)
|
||||||
|
count
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.countListed webLogId = rethink<int> {
|
||||||
|
withTable Table.Page
|
||||||
|
getAll [ webLogId ] (nameof webLogId)
|
||||||
|
filter "showInPageList" true
|
||||||
|
count
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.delete pageId webLogId = backgroundTask {
|
||||||
|
let! result = rethink<Model.Result> {
|
||||||
|
withTable Table.Page
|
||||||
|
getAll [ pageId ]
|
||||||
|
filter (fun row -> row["webLogId"].Eq webLogId :> obj)
|
||||||
|
delete
|
||||||
|
write; withRetryDefault conn
|
||||||
|
}
|
||||||
|
return result.Deleted > 0UL
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findFullById pageId webLogId =
|
||||||
|
rethink<Page> {
|
||||||
|
withTable Table.Page
|
||||||
|
get pageId
|
||||||
|
resultOption; withRetryOptionDefault
|
||||||
|
}
|
||||||
|
|> verifyWebLog webLogId (fun it -> it.webLogId) <| conn
|
||||||
|
|
||||||
|
member _.findById pageId webLogId =
|
||||||
|
rethink<Page> {
|
||||||
|
withTable Table.Page
|
||||||
|
get pageId
|
||||||
|
without [ "priorPermalinks"; "revisions" ]
|
||||||
|
resultOption; withRetryOptionDefault
|
||||||
|
}
|
||||||
|
|> verifyWebLog webLogId (fun it -> it.webLogId) <| conn
|
||||||
|
|
||||||
|
member _.findByPermalink permalink webLogId =
|
||||||
|
rethink<Page list> {
|
||||||
|
withTable Table.Page
|
||||||
|
getAll [ r.Array (webLogId, permalink) ] (nameof permalink)
|
||||||
|
without [ "priorPermalinks"; "revisions" ]
|
||||||
|
limit 1
|
||||||
|
result; withRetryDefault
|
||||||
|
}
|
||||||
|
|> tryFirst <| conn
|
||||||
|
|
||||||
|
member _.findCurrentPermalink permalinks webLogId = backgroundTask {
|
||||||
|
let! result =
|
||||||
|
(rethink<Page list> {
|
||||||
|
withTable Table.Page
|
||||||
|
getAll (objList permalinks) "priorPermalinks"
|
||||||
|
filter "webLogId" webLogId
|
||||||
|
without [ "revisions"; "text" ]
|
||||||
|
limit 1
|
||||||
|
result; withRetryDefault
|
||||||
|
}
|
||||||
|
|> tryFirst) conn
|
||||||
|
return result |> Option.map (fun pg -> pg.permalink)
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findListed webLogId = rethink<Page list> {
|
||||||
|
withTable Table.Page
|
||||||
|
getAll [ webLogId ] (nameof webLogId)
|
||||||
|
filter [ "showInPageList", true :> obj ]
|
||||||
|
without [ "text"; "priorPermalinks"; "revisions" ]
|
||||||
|
orderBy "title"
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findPageOfPages webLogId pageNbr = rethink<Page list> {
|
||||||
|
withTable Table.Page
|
||||||
|
getAll [ webLogId ] (nameof webLogId)
|
||||||
|
without [ "priorPermalinks"; "revisions" ]
|
||||||
|
orderByFunc (fun row -> row["title"].Downcase ())
|
||||||
|
skip ((pageNbr - 1) * 25)
|
||||||
|
limit 25
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
/// Update a page
|
||||||
|
member _.update page = rethink {
|
||||||
|
withTable Table.Page
|
||||||
|
get page.id
|
||||||
|
update [
|
||||||
|
"title", page.title :> obj
|
||||||
|
"permalink", page.permalink
|
||||||
|
"updatedOn", page.updatedOn
|
||||||
|
"showInPageList", page.showInPageList
|
||||||
|
"template", page.template
|
||||||
|
"text", page.text
|
||||||
|
"priorPermalinks", page.priorPermalinks
|
||||||
|
"metadata", page.metadata
|
||||||
|
"revisions", page.revisions
|
||||||
|
]
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
|
||||||
|
/// Update prior permalinks for a page
|
||||||
|
member this.updatePriorPermalinks pageId webLogId permalinks = backgroundTask {
|
||||||
|
match! this.findById pageId webLogId with
|
||||||
|
| Some _ ->
|
||||||
|
do! rethink {
|
||||||
|
withTable Table.Page
|
||||||
|
get pageId
|
||||||
|
update [ "priorPermalinks", permalinks :> obj ]
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
return true
|
||||||
|
| None -> return false
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.Post = {
|
||||||
|
new IPostData with
|
||||||
|
|
||||||
|
member _.add post = rethink {
|
||||||
|
withTable Table.Post
|
||||||
|
insert post
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.countByStatus status webLogId = rethink<int> {
|
||||||
|
withTable Table.Post
|
||||||
|
getAll [ webLogId ] (nameof webLogId)
|
||||||
|
filter "status" status
|
||||||
|
count
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.delete postId webLogId = backgroundTask {
|
||||||
|
let! result = rethink<Model.Result> {
|
||||||
|
withTable Table.Post
|
||||||
|
getAll [ postId ]
|
||||||
|
filter (fun row -> row["webLogId"].Eq webLogId :> obj)
|
||||||
|
delete
|
||||||
|
write; withRetryDefault conn
|
||||||
|
}
|
||||||
|
return result.Deleted > 0UL
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findByPermalink permalink webLogId =
|
||||||
|
rethink<Post list> {
|
||||||
|
withTable Table.Post
|
||||||
|
getAll [ r.Array (webLogId, permalink) ] (nameof permalink)
|
||||||
|
without [ "priorPermalinks"; "revisions" ]
|
||||||
|
limit 1
|
||||||
|
result; withRetryDefault
|
||||||
|
}
|
||||||
|
|> tryFirst <| conn
|
||||||
|
|
||||||
|
member _.findFullById postId webLogId =
|
||||||
|
rethink<Post> {
|
||||||
|
withTable Table.Post
|
||||||
|
get postId
|
||||||
|
resultOption; withRetryOptionDefault
|
||||||
|
}
|
||||||
|
|> verifyWebLog webLogId (fun p -> p.webLogId) <| conn
|
||||||
|
|
||||||
|
member _.findCurrentPermalink permalinks webLogId = backgroundTask {
|
||||||
|
let! result =
|
||||||
|
(rethink<Post list> {
|
||||||
|
withTable Table.Post
|
||||||
|
getAll (objList permalinks) "priorPermalinks"
|
||||||
|
filter "webLogId" webLogId
|
||||||
|
without [ "revisions"; "text" ]
|
||||||
|
limit 1
|
||||||
|
result; withRetryDefault
|
||||||
|
}
|
||||||
|
|> tryFirst) conn
|
||||||
|
return result |> Option.map (fun post -> post.permalink)
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage = rethink<Post list> {
|
||||||
|
withTable Table.Post
|
||||||
|
getAll (objList categoryIds) "categoryIds"
|
||||||
|
filter "webLogId" webLogId
|
||||||
|
filter "status" Published
|
||||||
|
without [ "priorPermalinks"; "revisions" ]
|
||||||
|
distinct
|
||||||
|
orderByDescending "publishedOn"
|
||||||
|
skip ((pageNbr - 1) * postsPerPage)
|
||||||
|
limit (postsPerPage + 1)
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findPageOfPosts webLogId pageNbr postsPerPage = rethink<Post list> {
|
||||||
|
withTable Table.Post
|
||||||
|
getAll [ webLogId ] (nameof webLogId)
|
||||||
|
without [ "priorPermalinks"; "revisions" ]
|
||||||
|
orderByFuncDescending (fun row -> row["publishedOn"].Default_ "updatedOn" :> obj)
|
||||||
|
skip ((pageNbr - 1) * postsPerPage)
|
||||||
|
limit (postsPerPage + 1)
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findPageOfPublishedPosts webLogId pageNbr postsPerPage = rethink<Post list> {
|
||||||
|
withTable Table.Post
|
||||||
|
getAll [ webLogId ] (nameof webLogId)
|
||||||
|
filter "status" Published
|
||||||
|
without [ "priorPermalinks"; "revisions" ]
|
||||||
|
orderByDescending "publishedOn"
|
||||||
|
skip ((pageNbr - 1) * postsPerPage)
|
||||||
|
limit (postsPerPage + 1)
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findPageOfTaggedPosts webLogId tag pageNbr postsPerPage = rethink<Post list> {
|
||||||
|
withTable Table.Post
|
||||||
|
getAll [ tag ] "tags"
|
||||||
|
filter "webLogId" webLogId
|
||||||
|
filter "status" Published
|
||||||
|
without [ "priorPermalinks"; "revisions" ]
|
||||||
|
orderByDescending "publishedOn"
|
||||||
|
skip ((pageNbr - 1) * postsPerPage)
|
||||||
|
limit (postsPerPage + 1)
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findSurroundingPosts webLogId publishedOn = backgroundTask {
|
||||||
|
let! older =
|
||||||
|
rethink<Post list> {
|
||||||
|
withTable Table.Post
|
||||||
|
getAll [ webLogId ] (nameof webLogId)
|
||||||
|
filter (fun row -> row["publishedOn"].Lt publishedOn :> obj)
|
||||||
|
without [ "priorPermalinks"; "revisions" ]
|
||||||
|
orderByDescending "publishedOn"
|
||||||
|
limit 1
|
||||||
|
result; withRetryDefault
|
||||||
|
}
|
||||||
|
|> tryFirst <| conn
|
||||||
|
let! newer =
|
||||||
|
rethink<Post list> {
|
||||||
|
withTable Table.Post
|
||||||
|
getAll [ webLogId ] (nameof webLogId)
|
||||||
|
filter (fun row -> row["publishedOn"].Gt publishedOn :> obj)
|
||||||
|
without [ "priorPermalinks"; "revisions" ]
|
||||||
|
orderBy "publishedOn"
|
||||||
|
limit 1
|
||||||
|
result; withRetryDefault
|
||||||
|
}
|
||||||
|
|> tryFirst <| conn
|
||||||
|
return older, newer
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.update post = rethink {
|
||||||
|
withTable Table.Post
|
||||||
|
get post.id
|
||||||
|
replace post
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.updatePriorPermalinks postId webLogId permalinks = backgroundTask {
|
||||||
|
match! (
|
||||||
|
rethink<Post> {
|
||||||
|
withTable Table.Post
|
||||||
|
get postId
|
||||||
|
without [ "revisions"; "priorPermalinks" ]
|
||||||
|
resultOption; withRetryOptionDefault
|
||||||
|
}
|
||||||
|
|> verifyWebLog webLogId (fun p -> p.webLogId)) conn with
|
||||||
|
| Some _ ->
|
||||||
|
do! rethink {
|
||||||
|
withTable Table.Post
|
||||||
|
get postId
|
||||||
|
update [ "priorPermalinks", permalinks :> obj ]
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
return true
|
||||||
|
| None -> return false
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.TagMap = {
|
||||||
|
new ITagMapData with
|
||||||
|
|
||||||
|
member _.all webLogId = rethink<TagMap list> {
|
||||||
|
withTable Table.TagMap
|
||||||
|
between (r.Array (webLogId, r.Minval ())) (r.Array (webLogId, r.Maxval ())) [ Index "webLogAndTag" ]
|
||||||
|
orderBy "tag"
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.delete tagMapId webLogId = backgroundTask {
|
||||||
|
let! result = rethink<Model.Result> {
|
||||||
|
withTable Table.TagMap
|
||||||
|
getAll [ tagMapId ]
|
||||||
|
filter (fun row -> row["webLogId"].Eq webLogId :> obj)
|
||||||
|
delete
|
||||||
|
write; withRetryDefault conn
|
||||||
|
}
|
||||||
|
return result.Deleted > 0UL
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findById tagMapId webLogId =
|
||||||
|
rethink<TagMap> {
|
||||||
|
withTable Table.TagMap
|
||||||
|
get tagMapId
|
||||||
|
resultOption; withRetryOptionDefault
|
||||||
|
}
|
||||||
|
|> verifyWebLog webLogId (fun tm -> tm.webLogId) <| conn
|
||||||
|
|
||||||
|
member _.findByUrlValue urlValue webLogId =
|
||||||
|
rethink<TagMap list> {
|
||||||
|
withTable Table.TagMap
|
||||||
|
getAll [ r.Array (webLogId, urlValue) ] "webLogAndUrl"
|
||||||
|
limit 1
|
||||||
|
result; withRetryDefault
|
||||||
|
}
|
||||||
|
|> tryFirst <| conn
|
||||||
|
|
||||||
|
member _.findMappingForTags tags webLogId = rethink<TagMap list> {
|
||||||
|
withTable Table.TagMap
|
||||||
|
getAll (tags |> List.map (fun tag -> r.Array (webLogId, tag) :> obj)) "webLogAndTag"
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.save tagMap = rethink {
|
||||||
|
withTable Table.TagMap
|
||||||
|
get tagMap.id
|
||||||
|
replace tagMap
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.Theme = {
|
||||||
|
new IThemeData with
|
||||||
|
|
||||||
|
member _.all () = rethink<Theme list> {
|
||||||
|
withTable Table.Theme
|
||||||
|
filter (fun row -> row["id"].Ne "admin" :> obj)
|
||||||
|
without [ "templates" ]
|
||||||
|
orderBy "id"
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findById themeId = rethink<Theme> {
|
||||||
|
withTable Table.Theme
|
||||||
|
get themeId
|
||||||
|
resultOption; withRetryOptionDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findByIdWithoutText themeId = rethink<Theme> {
|
||||||
|
withTable Table.Theme
|
||||||
|
get themeId
|
||||||
|
merge (fun row -> r.HashMap ("templates", row["templates"].Without [| "text" |]))
|
||||||
|
resultOption; withRetryOptionDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.save theme = rethink {
|
||||||
|
withTable Table.Theme
|
||||||
|
get theme.id
|
||||||
|
replace theme
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.ThemeAsset = {
|
||||||
|
new IThemeAssetData with
|
||||||
|
|
||||||
|
member _.all () = rethink<ThemeAsset list> {
|
||||||
|
withTable Table.ThemeAsset
|
||||||
|
without [ "data" ]
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.deleteByTheme themeId = rethink {
|
||||||
|
withTable Table.ThemeAsset
|
||||||
|
filter (matchAssetByThemeId themeId)
|
||||||
|
delete
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findById assetId = rethink<ThemeAsset> {
|
||||||
|
withTable Table.ThemeAsset
|
||||||
|
get assetId
|
||||||
|
resultOption; withRetryOptionDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findByTheme themeId = rethink<ThemeAsset list> {
|
||||||
|
withTable Table.ThemeAsset
|
||||||
|
filter (matchAssetByThemeId themeId)
|
||||||
|
without [ "data" ]
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.save asset = rethink {
|
||||||
|
withTable Table.ThemeAsset
|
||||||
|
get asset.id
|
||||||
|
replace asset
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.WebLog = {
|
||||||
|
new IWebLogData with
|
||||||
|
|
||||||
|
member _.add webLog = rethink {
|
||||||
|
withTable Table.WebLog
|
||||||
|
insert webLog
|
||||||
|
write; withRetryOnce; ignoreResult conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.all () = rethink<WebLog list> {
|
||||||
|
withTable Table.WebLog
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findByHost url =
|
||||||
|
rethink<WebLog list> {
|
||||||
|
withTable Table.WebLog
|
||||||
|
getAll [ url ] "urlBase"
|
||||||
|
limit 1
|
||||||
|
result; withRetryDefault
|
||||||
|
}
|
||||||
|
|> tryFirst <| conn
|
||||||
|
|
||||||
|
member _.findById webLogId = rethink<WebLog> {
|
||||||
|
withTable Table.WebLog
|
||||||
|
get webLogId
|
||||||
|
resultOption; withRetryOptionDefault conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.updateRssOptions webLog = rethink {
|
||||||
|
withTable Table.WebLog
|
||||||
|
get webLog.id
|
||||||
|
update [ "rss", webLog.rss :> obj ]
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.updateSettings webLog = rethink {
|
||||||
|
withTable Table.WebLog
|
||||||
|
get webLog.id
|
||||||
|
update [
|
||||||
|
"name", webLog.name :> obj
|
||||||
|
"subtitle", webLog.subtitle
|
||||||
|
"defaultPage", webLog.defaultPage
|
||||||
|
"postsPerPage", webLog.postsPerPage
|
||||||
|
"timeZone", webLog.timeZone
|
||||||
|
"themePath", webLog.themePath
|
||||||
|
"autoHtmx", webLog.autoHtmx
|
||||||
|
]
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.WebLogUser = {
|
||||||
|
new IWebLogUserData with
|
||||||
|
|
||||||
|
member _.add user = rethink {
|
||||||
|
withTable Table.WebLogUser
|
||||||
|
insert user
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.findByEmail email webLogId =
|
||||||
|
rethink<WebLogUser list> {
|
||||||
|
withTable Table.WebLogUser
|
||||||
|
getAll [ r.Array (webLogId, email) ] "logOn"
|
||||||
|
limit 1
|
||||||
|
result; withRetryDefault
|
||||||
|
}
|
||||||
|
|> tryFirst <| conn
|
||||||
|
|
||||||
|
member _.findById userId webLogId =
|
||||||
|
rethink<WebLogUser> {
|
||||||
|
withTable Table.WebLogUser
|
||||||
|
get userId
|
||||||
|
resultOption; withRetryOptionDefault
|
||||||
|
}
|
||||||
|
|> verifyWebLog webLogId (fun u -> u.webLogId) <| conn
|
||||||
|
|
||||||
|
member _.findNames webLogId userIds = backgroundTask {
|
||||||
|
let! users = rethink<WebLogUser list> {
|
||||||
|
withTable Table.WebLogUser
|
||||||
|
getAll (objList userIds)
|
||||||
|
filter "webLogId" webLogId
|
||||||
|
result; withRetryDefault conn
|
||||||
|
}
|
||||||
|
return
|
||||||
|
users
|
||||||
|
|> List.map (fun u -> { name = WebLogUserId.toString u.id; value = WebLogUser.displayName u })
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.update user = rethink {
|
||||||
|
withTable Table.WebLogUser
|
||||||
|
get user.id
|
||||||
|
update [
|
||||||
|
"firstName", user.firstName :> obj
|
||||||
|
"lastName", user.lastName
|
||||||
|
"preferredName", user.preferredName
|
||||||
|
"passwordHash", user.passwordHash
|
||||||
|
"salt", user.salt
|
||||||
|
]
|
||||||
|
write; withRetryDefault; ignoreResult conn
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
member _.startUp () = backgroundTask {
|
||||||
|
let! dbs = rethink<string list> { dbList; result; withRetryOnce conn }
|
||||||
|
if not (dbs |> List.contains config.Database) then
|
||||||
|
log.LogInformation($"Creating database {config.Database}...")
|
||||||
|
do! rethink { dbCreate config.Database; write; withRetryOnce; ignoreResult conn }
|
||||||
|
|
||||||
|
let! tables = rethink<string list> { tableList; result; withRetryOnce conn }
|
||||||
|
for tbl in Table.all do
|
||||||
|
if not (tables |> List.contains tbl) then
|
||||||
|
log.LogInformation($"Creating table {tbl}...")
|
||||||
|
do! rethink { tableCreate tbl; write; withRetryOnce; ignoreResult conn }
|
||||||
|
|
||||||
|
do! ensureIndexes Table.Category [ "webLogId" ]
|
||||||
|
do! ensureIndexes Table.Comment [ "postId" ]
|
||||||
|
do! ensureIndexes Table.Page [ "webLogId"; "authorId" ]
|
||||||
|
do! ensureIndexes Table.Post [ "webLogId"; "authorId" ]
|
||||||
|
do! ensureIndexes Table.TagMap []
|
||||||
|
do! ensureIndexes Table.WebLog [ "urlBase" ]
|
||||||
|
do! ensureIndexes Table.WebLogUser [ "webLogId" ]
|
||||||
|
}
|
||||||
22
src/MyWebLog.Data/Utils.fs
Normal file
22
src/MyWebLog.Data/Utils.fs
Normal 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)
|
||||||
|
}
|
||||||
|
|
||||||
|
|
@ -1,20 +1,20 @@
|
||||||
namespace MyWebLog
|
namespace MyWebLog
|
||||||
|
|
||||||
open Microsoft.AspNetCore.Http
|
open Microsoft.AspNetCore.Http
|
||||||
|
open MyWebLog.Data
|
||||||
|
|
||||||
/// Extension properties on HTTP context for web log
|
/// Extension properties on HTTP context for web log
|
||||||
[<AutoOpen>]
|
[<AutoOpen>]
|
||||||
module Extensions =
|
module Extensions =
|
||||||
|
|
||||||
open Microsoft.Extensions.DependencyInjection
|
open Microsoft.Extensions.DependencyInjection
|
||||||
open RethinkDb.Driver.Net
|
|
||||||
|
|
||||||
type HttpContext with
|
type HttpContext with
|
||||||
/// The web log for the current request
|
/// The web log for the current request
|
||||||
member this.WebLog = this.Items["webLog"] :?> WebLog
|
member this.WebLog = this.Items["webLog"] :?> WebLog
|
||||||
|
|
||||||
/// The RethinkDB data connection
|
/// The data implementation
|
||||||
member this.Conn = this.RequestServices.GetRequiredService<IConnection> ()
|
member this.Data = this.RequestServices.GetRequiredService<IData> ()
|
||||||
|
|
||||||
|
|
||||||
open System.Collections.Concurrent
|
open System.Collections.Concurrent
|
||||||
|
|
@ -41,8 +41,8 @@ module WebLogCache =
|
||||||
_cache <- webLog :: (_cache |> List.filter (fun wl -> wl.id <> webLog.id))
|
_cache <- webLog :: (_cache |> List.filter (fun wl -> wl.id <> webLog.id))
|
||||||
|
|
||||||
/// Fill the web log cache from the database
|
/// Fill the web log cache from the database
|
||||||
let fill conn = backgroundTask {
|
let fill (data : IData) = backgroundTask {
|
||||||
let! webLogs = Data.WebLog.all conn
|
let! webLogs = data.WebLog.all ()
|
||||||
_cache <- webLogs
|
_cache <- webLogs
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -64,7 +64,7 @@ module PageListCache =
|
||||||
/// Update the pages for the current web log
|
/// Update the pages for the current web log
|
||||||
let update (ctx : HttpContext) = backgroundTask {
|
let update (ctx : HttpContext) = backgroundTask {
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let! pages = Data.Page.findListed webLog.id ctx.Conn
|
let! pages = ctx.Data.Page.findListed webLog.id
|
||||||
_cache[webLog.urlBase] <-
|
_cache[webLog.urlBase] <-
|
||||||
pages
|
pages
|
||||||
|> List.map (fun pg -> DisplayPage.fromPage webLog { pg with text = "" })
|
|> List.map (fun pg -> DisplayPage.fromPage webLog { pg with text = "" })
|
||||||
|
|
@ -88,7 +88,7 @@ module CategoryCache =
|
||||||
|
|
||||||
/// Update the cache with fresh data
|
/// Update the cache with fresh data
|
||||||
let update (ctx : HttpContext) = backgroundTask {
|
let update (ctx : HttpContext) = backgroundTask {
|
||||||
let! cats = Data.Category.findAllForView ctx.WebLog.id ctx.Conn
|
let! cats = ctx.Data.Category.findAllForView ctx.WebLog.id
|
||||||
_cache[ctx.WebLog.urlBase] <- cats
|
_cache[ctx.WebLog.urlBase] <- cats
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -107,12 +107,12 @@ module TemplateCache =
|
||||||
let private hasInclude = Regex ("""{% include_template \"(.*)\" %}""", RegexOptions.None, TimeSpan.FromSeconds 2)
|
let private hasInclude = Regex ("""{% include_template \"(.*)\" %}""", RegexOptions.None, TimeSpan.FromSeconds 2)
|
||||||
|
|
||||||
/// Get a template for the given theme and template name
|
/// Get a template for the given theme and template name
|
||||||
let get (themeId : string) (templateName : string) conn = backgroundTask {
|
let get (themeId : string) (templateName : string) (data : IData) = backgroundTask {
|
||||||
let templatePath = $"{themeId}/{templateName}"
|
let templatePath = $"{themeId}/{templateName}"
|
||||||
match _cache.ContainsKey templatePath with
|
match _cache.ContainsKey templatePath with
|
||||||
| true -> ()
|
| true -> ()
|
||||||
| false ->
|
| false ->
|
||||||
match! Data.Theme.findById (ThemeId themeId) conn with
|
match! data.Theme.findById (ThemeId themeId) with
|
||||||
| Some theme ->
|
| Some theme ->
|
||||||
let mutable text = (theme.templates |> List.find (fun t -> t.name = templateName)).text
|
let mutable text = (theme.templates |> List.find (fun t -> t.name = templateName)).text
|
||||||
while hasInclude.IsMatch text do
|
while hasInclude.IsMatch text do
|
||||||
|
|
@ -142,14 +142,14 @@ module ThemeAssetCache =
|
||||||
let get themeId = _cache[themeId]
|
let get themeId = _cache[themeId]
|
||||||
|
|
||||||
/// Refresh the list of assets for the given theme
|
/// Refresh the list of assets for the given theme
|
||||||
let refreshTheme themeId conn = backgroundTask {
|
let refreshTheme themeId (data : IData) = backgroundTask {
|
||||||
let! assets = Data.ThemeAsset.findByThemeId themeId conn
|
let! assets = data.ThemeAsset.findByTheme themeId
|
||||||
_cache[themeId] <- assets |> List.map (fun a -> match a.id with ThemeAssetId (_, path) -> path)
|
_cache[themeId] <- assets |> List.map (fun a -> match a.id with ThemeAssetId (_, path) -> path)
|
||||||
}
|
}
|
||||||
|
|
||||||
/// Fill the theme asset cache
|
/// Fill the theme asset cache
|
||||||
let fill conn = backgroundTask {
|
let fill (data : IData) = backgroundTask {
|
||||||
let! assets = Data.ThemeAsset.all conn
|
let! assets = data.ThemeAsset.all ()
|
||||||
for asset in assets do
|
for asset in assets do
|
||||||
let (ThemeAssetId (themeId, path)) = asset.id
|
let (ThemeAssetId (themeId, path)) = asset.id
|
||||||
if not (_cache.ContainsKey themeId) then _cache[themeId] <- []
|
if not (_cache.ContainsKey themeId) then _cache[themeId] <- []
|
||||||
|
|
|
||||||
|
|
@ -1,48 +1,35 @@
|
||||||
/// Handlers to manipulate admin functions
|
/// Handlers to manipulate admin functions
|
||||||
module MyWebLog.Handlers.Admin
|
module MyWebLog.Handlers.Admin
|
||||||
|
|
||||||
open System.Collections.Generic
|
|
||||||
open System.IO
|
|
||||||
|
|
||||||
/// The currently available themes
|
|
||||||
let private themes () =
|
|
||||||
Directory.EnumerateDirectories "themes"
|
|
||||||
|> Seq.map (fun it -> it.Split Path.DirectorySeparatorChar |> Array.last)
|
|
||||||
|> Seq.filter (fun it -> it <> "admin")
|
|
||||||
|> Seq.sort
|
|
||||||
|> Seq.map (fun it -> KeyValuePair.Create (it, it))
|
|
||||||
|> Array.ofSeq
|
|
||||||
|
|
||||||
open System.Threading.Tasks
|
open System.Threading.Tasks
|
||||||
open DotLiquid
|
open DotLiquid
|
||||||
open Giraffe
|
open Giraffe
|
||||||
open MyWebLog
|
open MyWebLog
|
||||||
open MyWebLog.ViewModels
|
open MyWebLog.ViewModels
|
||||||
open RethinkDb.Driver.Net
|
|
||||||
|
|
||||||
// GET /admin
|
// GET /admin
|
||||||
let dashboard : HttpHandler = fun next ctx -> task {
|
let dashboard : HttpHandler = fun next ctx -> task {
|
||||||
let webLogId = ctx.WebLog.id
|
let webLogId = ctx.WebLog.id
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
let getCount (f : WebLogId -> IConnection -> Task<int>) = f webLogId conn
|
let getCount (f : WebLogId -> Task<int>) = f webLogId
|
||||||
let! posts = Data.Post.countByStatus Published |> getCount
|
let! posts = data.Post.countByStatus Published |> getCount
|
||||||
let! drafts = Data.Post.countByStatus Draft |> getCount
|
let! drafts = data.Post.countByStatus Draft |> getCount
|
||||||
let! pages = Data.Page.countAll |> getCount
|
let! pages = data.Page.countAll |> getCount
|
||||||
let! listed = Data.Page.countListed |> getCount
|
let! listed = data.Page.countListed |> getCount
|
||||||
let! cats = Data.Category.countAll |> getCount
|
let! cats = data.Category.countAll |> getCount
|
||||||
let! topCats = Data.Category.countTopLevel |> getCount
|
let! topCats = data.Category.countTopLevel |> getCount
|
||||||
return!
|
return!
|
||||||
Hash.FromAnonymousObject
|
Hash.FromAnonymousObject {|
|
||||||
{| page_title = "Dashboard"
|
page_title = "Dashboard"
|
||||||
model =
|
model =
|
||||||
{ posts = posts
|
{ posts = posts
|
||||||
drafts = drafts
|
drafts = drafts
|
||||||
pages = pages
|
pages = pages
|
||||||
listedPages = listed
|
listedPages = listed
|
||||||
categories = cats
|
categories = cats
|
||||||
topLevelCategories = topCats
|
topLevelCategories = topCats
|
||||||
}
|
}
|
||||||
|}
|
|}
|
||||||
|> viewForTheme "admin" "dashboard" next ctx
|
|> viewForTheme "admin" "dashboard" next ctx
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -50,7 +37,7 @@ let dashboard : HttpHandler = fun next ctx -> task {
|
||||||
|
|
||||||
// GET /admin/categories
|
// GET /admin/categories
|
||||||
let listCategories : HttpHandler = fun next ctx -> task {
|
let listCategories : HttpHandler = fun next ctx -> task {
|
||||||
let! catListTemplate = TemplateCache.get "admin" "category-list-body" ctx.Conn
|
let! catListTemplate = TemplateCache.get "admin" "category-list-body" ctx.Data
|
||||||
let hash = Hash.FromAnonymousObject {|
|
let hash = Hash.FromAnonymousObject {|
|
||||||
web_log = ctx.WebLog
|
web_log = ctx.WebLog
|
||||||
categories = CategoryCache.get ctx
|
categories = CategoryCache.get ctx
|
||||||
|
|
@ -78,7 +65,7 @@ let editCategory catId : HttpHandler = fun next ctx -> task {
|
||||||
match catId with
|
match catId with
|
||||||
| "new" -> return Some ("Add a New Category", { Category.empty with id = CategoryId "new" })
|
| "new" -> return Some ("Add a New Category", { Category.empty with id = CategoryId "new" })
|
||||||
| _ ->
|
| _ ->
|
||||||
match! Data.Category.findById (CategoryId catId) ctx.WebLog.id ctx.Conn with
|
match! ctx.Data.Category.findById (CategoryId catId) ctx.WebLog.id with
|
||||||
| Some cat -> return Some ("Edit Category", cat)
|
| Some cat -> return Some ("Edit Category", cat)
|
||||||
| None -> return None
|
| None -> return None
|
||||||
}
|
}
|
||||||
|
|
@ -98,12 +85,12 @@ let editCategory catId : HttpHandler = fun next ctx -> task {
|
||||||
// POST /admin/category/save
|
// POST /admin/category/save
|
||||||
let saveCategory : HttpHandler = fun next ctx -> task {
|
let saveCategory : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
let! model = ctx.BindFormAsync<EditCategoryModel> ()
|
let! model = ctx.BindFormAsync<EditCategoryModel> ()
|
||||||
let! category = task {
|
let! category = task {
|
||||||
match model.categoryId with
|
match model.categoryId with
|
||||||
| "new" -> return Some { Category.empty with id = CategoryId.create (); webLogId = webLog.id }
|
| "new" -> return Some { Category.empty with id = CategoryId.create (); webLogId = webLog.id }
|
||||||
| catId -> return! Data.Category.findById (CategoryId catId) webLog.id conn
|
| catId -> return! data.Category.findById (CategoryId catId) webLog.id
|
||||||
}
|
}
|
||||||
match category with
|
match category with
|
||||||
| Some cat ->
|
| Some cat ->
|
||||||
|
|
@ -114,7 +101,7 @@ let saveCategory : HttpHandler = fun next ctx -> task {
|
||||||
description = if model.description = "" then None else Some model.description
|
description = if model.description = "" then None else Some model.description
|
||||||
parentId = if model.parentId = "" then None else Some (CategoryId model.parentId)
|
parentId = if model.parentId = "" then None else Some (CategoryId model.parentId)
|
||||||
}
|
}
|
||||||
do! (match model.categoryId with "new" -> Data.Category.add | _ -> Data.Category.update) cat conn
|
do! (match model.categoryId with "new" -> data.Category.add | _ -> data.Category.update) cat
|
||||||
do! CategoryCache.update ctx
|
do! CategoryCache.update ctx
|
||||||
do! addMessage ctx { UserMessage.success with message = "Category saved successfully" }
|
do! addMessage ctx { UserMessage.success with message = "Category saved successfully" }
|
||||||
return! listCategoriesBare next ctx
|
return! listCategoriesBare next ctx
|
||||||
|
|
@ -123,8 +110,7 @@ let saveCategory : HttpHandler = fun next ctx -> task {
|
||||||
|
|
||||||
// POST /admin/category/{id}/delete
|
// POST /admin/category/{id}/delete
|
||||||
let deleteCategory catId : HttpHandler = fun next ctx -> task {
|
let deleteCategory catId : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
match! ctx.Data.Category.delete (CategoryId catId) ctx.WebLog.id with
|
||||||
match! Data.Category.delete (CategoryId catId) webLog.id ctx.Conn with
|
|
||||||
| true ->
|
| true ->
|
||||||
do! CategoryCache.update ctx
|
do! CategoryCache.update ctx
|
||||||
do! addMessage ctx { UserMessage.success with message = "Category deleted successfully" }
|
do! addMessage ctx { UserMessage.success with message = "Category deleted successfully" }
|
||||||
|
|
@ -138,16 +124,16 @@ let deleteCategory catId : HttpHandler = fun next ctx -> task {
|
||||||
// GET /admin/pages/page/{pageNbr}
|
// GET /admin/pages/page/{pageNbr}
|
||||||
let listPages pageNbr : HttpHandler = fun next ctx -> task {
|
let listPages pageNbr : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let! pages = Data.Page.findPageOfPages webLog.id pageNbr ctx.Conn
|
let! pages = ctx.Data.Page.findPageOfPages webLog.id pageNbr
|
||||||
return!
|
return!
|
||||||
Hash.FromAnonymousObject
|
Hash.FromAnonymousObject {|
|
||||||
{| csrf = csrfToken ctx
|
csrf = csrfToken ctx
|
||||||
pages = pages |> List.map (DisplayPage.fromPageMinimal webLog)
|
pages = pages |> List.map (DisplayPage.fromPageMinimal webLog)
|
||||||
page_title = "Pages"
|
page_title = "Pages"
|
||||||
page_nbr = pageNbr
|
page_nbr = pageNbr
|
||||||
prev_page = if pageNbr = 2 then "" else $"/page/{pageNbr - 1}"
|
prev_page = if pageNbr = 2 then "" else $"/page/{pageNbr - 1}"
|
||||||
next_page = $"/page/{pageNbr + 1}"
|
next_page = $"/page/{pageNbr + 1}"
|
||||||
|}
|
|}
|
||||||
|> viewForTheme "admin" "page-list" next ctx
|
|> viewForTheme "admin" "page-list" next ctx
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -157,7 +143,7 @@ let editPage pgId : HttpHandler = fun next ctx -> task {
|
||||||
match pgId with
|
match pgId with
|
||||||
| "new" -> return Some ("Add a New Page", { Page.empty with id = PageId "new" })
|
| "new" -> return Some ("Add a New Page", { Page.empty with id = PageId "new" })
|
||||||
| _ ->
|
| _ ->
|
||||||
match! Data.Page.findByFullId (PageId pgId) ctx.WebLog.id ctx.Conn with
|
match! ctx.Data.Page.findFullById (PageId pgId) ctx.WebLog.id with
|
||||||
| Some page -> return Some ("Edit Page", page)
|
| Some page -> return Some ("Edit Page", page)
|
||||||
| None -> return None
|
| None -> return None
|
||||||
}
|
}
|
||||||
|
|
@ -180,7 +166,7 @@ let editPage pgId : HttpHandler = fun next ctx -> task {
|
||||||
|
|
||||||
// GET /admin/page/{id}/permalinks
|
// GET /admin/page/{id}/permalinks
|
||||||
let editPagePermalinks pgId : HttpHandler = fun next ctx -> task {
|
let editPagePermalinks pgId : HttpHandler = fun next ctx -> task {
|
||||||
match! Data.Page.findByFullId (PageId pgId) ctx.WebLog.id ctx.Conn with
|
match! ctx.Data.Page.findFullById (PageId pgId) ctx.WebLog.id with
|
||||||
| Some pg ->
|
| Some pg ->
|
||||||
return!
|
return!
|
||||||
Hash.FromAnonymousObject {|
|
Hash.FromAnonymousObject {|
|
||||||
|
|
@ -197,7 +183,7 @@ let savePagePermalinks : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
|
let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
|
||||||
let links = model.prior |> Array.map Permalink |> List.ofArray
|
let links = model.prior |> Array.map Permalink |> List.ofArray
|
||||||
match! Data.Page.updatePriorPermalinks (PageId model.id) webLog.id links ctx.Conn with
|
match! ctx.Data.Page.updatePriorPermalinks (PageId model.id) webLog.id links with
|
||||||
| true ->
|
| true ->
|
||||||
do! addMessage ctx { UserMessage.success with message = "Page permalinks saved successfully" }
|
do! addMessage ctx { UserMessage.success with message = "Page permalinks saved successfully" }
|
||||||
return! redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/page/{model.id}/permalinks")) next ctx
|
return! redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/page/{model.id}/permalinks")) next ctx
|
||||||
|
|
@ -207,7 +193,7 @@ let savePagePermalinks : HttpHandler = fun next ctx -> task {
|
||||||
// POST /admin/page/{id}/delete
|
// POST /admin/page/{id}/delete
|
||||||
let deletePage pgId : HttpHandler = fun next ctx -> task {
|
let deletePage pgId : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
match! Data.Page.delete (PageId pgId) webLog.id ctx.Conn with
|
match! ctx.Data.Page.delete (PageId pgId) webLog.id with
|
||||||
| true ->
|
| true ->
|
||||||
do! PageListCache.update ctx
|
do! PageListCache.update ctx
|
||||||
do! addMessage ctx { UserMessage.success with message = "Page deleted successfully" }
|
do! addMessage ctx { UserMessage.success with message = "Page deleted successfully" }
|
||||||
|
|
@ -223,7 +209,7 @@ open System
|
||||||
let savePage : HttpHandler = fun next ctx -> task {
|
let savePage : HttpHandler = fun next ctx -> task {
|
||||||
let! model = ctx.BindFormAsync<EditPageModel> ()
|
let! model = ctx.BindFormAsync<EditPageModel> ()
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
let now = DateTime.UtcNow
|
let now = DateTime.UtcNow
|
||||||
let! pg = task {
|
let! pg = task {
|
||||||
match model.pageId with
|
match model.pageId with
|
||||||
|
|
@ -235,7 +221,7 @@ let savePage : HttpHandler = fun next ctx -> task {
|
||||||
authorId = userId ctx
|
authorId = userId ctx
|
||||||
publishedOn = now
|
publishedOn = now
|
||||||
}
|
}
|
||||||
| pgId -> return! Data.Page.findByFullId (PageId pgId) webLog.id conn
|
| pgId -> return! data.Page.findFullById (PageId pgId) webLog.id
|
||||||
}
|
}
|
||||||
match pg with
|
match pg with
|
||||||
| Some page ->
|
| Some page ->
|
||||||
|
|
@ -264,7 +250,7 @@ let savePage : HttpHandler = fun next ctx -> task {
|
||||||
| Some r when r.text = revision.text -> page.revisions
|
| Some r when r.text = revision.text -> page.revisions
|
||||||
| _ -> revision :: page.revisions
|
| _ -> revision :: page.revisions
|
||||||
}
|
}
|
||||||
do! (if model.pageId = "new" then Data.Page.add else Data.Page.update) page conn
|
do! (if model.pageId = "new" then data.Page.add else data.Page.update) page
|
||||||
if updateList then do! PageListCache.update ctx
|
if updateList then do! PageListCache.update ctx
|
||||||
do! addMessage ctx { UserMessage.success with message = "Page saved successfully" }
|
do! addMessage ctx { UserMessage.success with message = "Page saved successfully" }
|
||||||
return!
|
return!
|
||||||
|
|
@ -278,7 +264,7 @@ open Microsoft.AspNetCore.Http
|
||||||
|
|
||||||
/// Get the hash necessary to render the tag mapping list
|
/// Get the hash necessary to render the tag mapping list
|
||||||
let private tagMappingHash (ctx : HttpContext) = task {
|
let private tagMappingHash (ctx : HttpContext) = task {
|
||||||
let! mappings = Data.TagMap.findByWebLogId ctx.WebLog.id ctx.Conn
|
let! mappings = ctx.Data.TagMap.all ctx.WebLog.id
|
||||||
return Hash.FromAnonymousObject {|
|
return Hash.FromAnonymousObject {|
|
||||||
web_log = ctx.WebLog
|
web_log = ctx.WebLog
|
||||||
csrf = csrfToken ctx
|
csrf = csrfToken ctx
|
||||||
|
|
@ -290,7 +276,7 @@ let private tagMappingHash (ctx : HttpContext) = task {
|
||||||
// GET /admin/settings/tag-mappings
|
// GET /admin/settings/tag-mappings
|
||||||
let tagMappings : HttpHandler = fun next ctx -> task {
|
let tagMappings : HttpHandler = fun next ctx -> task {
|
||||||
let! hash = tagMappingHash ctx
|
let! hash = tagMappingHash ctx
|
||||||
let! listTemplate = TemplateCache.get "admin" "tag-mapping-list-body" ctx.Conn
|
let! listTemplate = TemplateCache.get "admin" "tag-mapping-list-body" ctx.Data
|
||||||
|
|
||||||
hash.Add ("tag_mapping_list", listTemplate.Render hash)
|
hash.Add ("tag_mapping_list", listTemplate.Render hash)
|
||||||
hash.Add ("page_title", "Tag Mappings")
|
hash.Add ("page_title", "Tag Mappings")
|
||||||
|
|
@ -311,32 +297,31 @@ let editMapping tagMapId : HttpHandler = fun next ctx -> task {
|
||||||
if isNew then
|
if isNew then
|
||||||
Task.FromResult (Some { TagMap.empty with id = TagMapId "new" })
|
Task.FromResult (Some { TagMap.empty with id = TagMapId "new" })
|
||||||
else
|
else
|
||||||
Data.TagMap.findById (TagMapId tagMapId) ctx.WebLog.id ctx.Conn
|
ctx.Data.TagMap.findById (TagMapId tagMapId) ctx.WebLog.id
|
||||||
match! tagMap with
|
match! tagMap with
|
||||||
| Some tm ->
|
| Some tm ->
|
||||||
return!
|
return!
|
||||||
Hash.FromAnonymousObject
|
Hash.FromAnonymousObject {|
|
||||||
{| csrf = csrfToken ctx
|
csrf = csrfToken ctx
|
||||||
model = EditTagMapModel.fromMapping tm
|
model = EditTagMapModel.fromMapping tm
|
||||||
page_title = if isNew then "Add Tag Mapping" else $"Mapping for {tm.tag} Tag"
|
page_title = if isNew then "Add Tag Mapping" else $"Mapping for {tm.tag} Tag"
|
||||||
|}
|
|}
|
||||||
|> bareForTheme "admin" "tag-mapping-edit" next ctx
|
|> bareForTheme "admin" "tag-mapping-edit" next ctx
|
||||||
| None -> return! Error.notFound next ctx
|
| None -> return! Error.notFound next ctx
|
||||||
}
|
}
|
||||||
|
|
||||||
// POST /admin/settings/tag-mapping/save
|
// POST /admin/settings/tag-mapping/save
|
||||||
let saveMapping : HttpHandler = fun next ctx -> task {
|
let saveMapping : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
let data = ctx.Data
|
||||||
let conn = ctx.Conn
|
|
||||||
let! model = ctx.BindFormAsync<EditTagMapModel> ()
|
let! model = ctx.BindFormAsync<EditTagMapModel> ()
|
||||||
let tagMap =
|
let tagMap =
|
||||||
if model.id = "new" then
|
if model.id = "new" then
|
||||||
Task.FromResult (Some { TagMap.empty with id = TagMapId.create (); webLogId = webLog.id })
|
Task.FromResult (Some { TagMap.empty with id = TagMapId.create (); webLogId = ctx.WebLog.id })
|
||||||
else
|
else
|
||||||
Data.TagMap.findById (TagMapId model.id) webLog.id conn
|
data.TagMap.findById (TagMapId model.id) ctx.WebLog.id
|
||||||
match! tagMap with
|
match! tagMap with
|
||||||
| Some tm ->
|
| Some tm ->
|
||||||
do! Data.TagMap.save { tm with tag = model.tag.ToLower (); urlValue = model.urlValue.ToLower () } conn
|
do! data.TagMap.save { tm with tag = model.tag.ToLower (); urlValue = model.urlValue.ToLower () }
|
||||||
do! addMessage ctx { UserMessage.success with message = "Tag mapping saved successfully" }
|
do! addMessage ctx { UserMessage.success with message = "Tag mapping saved successfully" }
|
||||||
return! tagMappingsBare next ctx
|
return! tagMappingsBare next ctx
|
||||||
| None -> return! Error.notFound next ctx
|
| None -> return! Error.notFound next ctx
|
||||||
|
|
@ -344,8 +329,7 @@ let saveMapping : HttpHandler = fun next ctx -> task {
|
||||||
|
|
||||||
// POST /admin/settings/tag-mapping/{id}/delete
|
// POST /admin/settings/tag-mapping/{id}/delete
|
||||||
let deleteMapping tagMapId : HttpHandler = fun next ctx -> task {
|
let deleteMapping tagMapId : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
match! ctx.Data.TagMap.delete (TagMapId tagMapId) ctx.WebLog.id with
|
||||||
match! Data.TagMap.delete (TagMapId tagMapId) webLog.id ctx.Conn with
|
|
||||||
| true -> do! addMessage ctx { UserMessage.success with message = "Tag mapping deleted successfully" }
|
| true -> do! addMessage ctx { UserMessage.success with message = "Tag mapping deleted successfully" }
|
||||||
| false -> do! addMessage ctx { UserMessage.error with message = "Tag mapping not found; nothing deleted" }
|
| false -> do! addMessage ctx { UserMessage.error with message = "Tag mapping not found; nothing deleted" }
|
||||||
return! tagMappingsBare next ctx
|
return! tagMappingsBare next ctx
|
||||||
|
|
@ -353,8 +337,10 @@ let deleteMapping tagMapId : HttpHandler = fun next ctx -> task {
|
||||||
|
|
||||||
// -- THEMES --
|
// -- THEMES --
|
||||||
|
|
||||||
|
open System.IO
|
||||||
open System.IO.Compression
|
open System.IO.Compression
|
||||||
open System.Text.RegularExpressions
|
open System.Text.RegularExpressions
|
||||||
|
open MyWebLog.Data
|
||||||
|
|
||||||
// GET /admin/theme/update
|
// GET /admin/theme/update
|
||||||
let themeUpdatePage : HttpHandler = fun next ctx -> task {
|
let themeUpdatePage : HttpHandler = fun next ctx -> task {
|
||||||
|
|
@ -371,20 +357,20 @@ let private updateNameAndVersion (theme : Theme) (zip : ZipArchive) = background
|
||||||
let now () = DateTime.UtcNow.ToString "yyyyMMdd.HHmm"
|
let now () = DateTime.UtcNow.ToString "yyyyMMdd.HHmm"
|
||||||
match zip.Entries |> Seq.filter (fun it -> it.FullName = "version.txt") |> Seq.tryHead with
|
match zip.Entries |> Seq.filter (fun it -> it.FullName = "version.txt") |> Seq.tryHead with
|
||||||
| Some versionItem ->
|
| Some versionItem ->
|
||||||
use versionFile = new StreamReader(versionItem.Open ())
|
use versionFile = new StreamReader(versionItem.Open ())
|
||||||
let! versionText = versionFile.ReadToEndAsync ()
|
let! versionText = versionFile.ReadToEndAsync ()
|
||||||
let parts = versionText.Trim().Replace("\r", "").Split "\n"
|
let parts = versionText.Trim().Replace("\r", "").Split "\n"
|
||||||
let displayName = if parts[0] > "" then parts[0] else ThemeId.toString theme.id
|
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 version = if parts.Length > 1 && parts[1] > "" then parts[1] else now ()
|
||||||
return { theme with name = displayName; version = version }
|
return { theme with name = displayName; version = version }
|
||||||
| None ->
|
| None ->
|
||||||
return { theme with name = ThemeId.toString theme.id; version = now () }
|
return { theme with name = ThemeId.toString theme.id; version = now () }
|
||||||
}
|
}
|
||||||
|
|
||||||
/// Delete all theme assets, and remove templates from theme
|
/// Delete all theme assets, and remove templates from theme
|
||||||
let private checkForCleanLoad (theme : Theme) cleanLoad conn = backgroundTask {
|
let private checkForCleanLoad (theme : Theme) cleanLoad (data : IData) = backgroundTask {
|
||||||
if cleanLoad then
|
if cleanLoad then
|
||||||
do! Data.ThemeAsset.deleteByTheme theme.id conn
|
do! data.ThemeAsset.deleteByTheme theme.id
|
||||||
return { theme with templates = [] }
|
return { theme with templates = [] }
|
||||||
else
|
else
|
||||||
return theme
|
return theme
|
||||||
|
|
@ -409,38 +395,38 @@ let private updateTemplates (theme : Theme) (zip : ZipArchive) = backgroundTask
|
||||||
}
|
}
|
||||||
|
|
||||||
/// Update theme assets from the ZIP archive
|
/// Update theme assets from the ZIP archive
|
||||||
let private updateAssets themeId (zip : ZipArchive) conn = backgroundTask {
|
let private updateAssets themeId (zip : ZipArchive) (data : IData) = backgroundTask {
|
||||||
for asset in zip.Entries |> Seq.filter (fun it -> it.FullName.StartsWith "wwwroot") do
|
for asset in zip.Entries |> Seq.filter (fun it -> it.FullName.StartsWith "wwwroot") do
|
||||||
let assetName = asset.FullName.Replace ("wwwroot/", "")
|
let assetName = asset.FullName.Replace ("wwwroot/", "")
|
||||||
if assetName <> "" && not (assetName.EndsWith "/") then
|
if assetName <> "" && not (assetName.EndsWith "/") then
|
||||||
use stream = new MemoryStream ()
|
use stream = new MemoryStream ()
|
||||||
do! asset.Open().CopyToAsync stream
|
do! asset.Open().CopyToAsync stream
|
||||||
do! Data.ThemeAsset.save
|
do! data.ThemeAsset.save
|
||||||
{ id = ThemeAssetId (themeId, assetName)
|
{ id = ThemeAssetId (themeId, assetName)
|
||||||
updatedOn = asset.LastWriteTime.DateTime
|
updatedOn = asset.LastWriteTime.DateTime
|
||||||
data = stream.ToArray ()
|
data = stream.ToArray ()
|
||||||
} conn
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
/// Get the theme name from the file name given
|
/// Get the theme name from the file name given
|
||||||
let getThemeName (fileName : string) =
|
let getThemeName (fileName : string) =
|
||||||
let themeName = fileName.Split(".").[0].ToLowerInvariant().Replace (" ", "-")
|
let themeName = fileName.Split(".").[0].ToLowerInvariant().Replace (" ", "-")
|
||||||
if Regex.IsMatch (themeName, """^[a-z0-9\-]+$""") then Some themeName else None
|
if Regex.IsMatch (themeName, """^[a-z0-9\-]+$""") then Ok themeName else Error $"Theme name {fileName} is invalid"
|
||||||
|
|
||||||
/// Load a theme from the given stream, which should contain a ZIP archive
|
/// Load a theme from the given stream, which should contain a ZIP archive
|
||||||
let loadThemeFromZip themeName file clean conn = backgroundTask {
|
let loadThemeFromZip themeName file clean (data : IData) = backgroundTask {
|
||||||
use zip = new ZipArchive (file, ZipArchiveMode.Read)
|
use zip = new ZipArchive (file, ZipArchiveMode.Read)
|
||||||
let themeId = ThemeId themeName
|
let themeId = ThemeId themeName
|
||||||
let! theme = backgroundTask {
|
let! theme = backgroundTask {
|
||||||
match! Data.Theme.findById themeId conn with
|
match! data.Theme.findById themeId with
|
||||||
| Some t -> return t
|
| Some t -> return t
|
||||||
| None -> return { Theme.empty with id = themeId }
|
| None -> return { Theme.empty with id = themeId }
|
||||||
}
|
}
|
||||||
let! theme = updateNameAndVersion theme zip
|
let! theme = updateNameAndVersion theme zip
|
||||||
let! theme = checkForCleanLoad theme clean conn
|
let! theme = checkForCleanLoad theme clean data
|
||||||
let! theme = updateTemplates theme zip
|
let! theme = updateTemplates theme zip
|
||||||
do! updateAssets themeId zip conn
|
do! updateAssets themeId zip data
|
||||||
do! Data.Theme.save theme conn
|
do! data.Theme.save theme
|
||||||
}
|
}
|
||||||
|
|
||||||
// POST /admin/theme/update
|
// POST /admin/theme/update
|
||||||
|
|
@ -448,17 +434,19 @@ let updateTheme : HttpHandler = fun next ctx -> task {
|
||||||
if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then
|
if ctx.Request.HasFormContentType && ctx.Request.Form.Files.Count > 0 then
|
||||||
let themeFile = Seq.head ctx.Request.Form.Files
|
let themeFile = Seq.head ctx.Request.Form.Files
|
||||||
match getThemeName themeFile.FileName with
|
match getThemeName themeFile.FileName with
|
||||||
| Some themeName ->
|
| Ok themeName when themeName <> "admin" ->
|
||||||
// TODO: add restriction for admin theme based on role
|
let data = ctx.Data
|
||||||
let conn = ctx.Conn
|
|
||||||
use stream = new MemoryStream ()
|
use stream = new MemoryStream ()
|
||||||
do! themeFile.CopyToAsync stream
|
do! themeFile.CopyToAsync stream
|
||||||
do! loadThemeFromZip themeName stream true conn
|
do! loadThemeFromZip themeName stream true data
|
||||||
do! ThemeAssetCache.refreshTheme (ThemeId themeName) conn
|
do! ThemeAssetCache.refreshTheme (ThemeId themeName) data
|
||||||
do! addMessage ctx { UserMessage.success with message = "Theme updated successfully" }
|
do! addMessage ctx { UserMessage.success with message = "Theme updated successfully" }
|
||||||
return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/dashboard")) next ctx
|
return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/dashboard")) next ctx
|
||||||
| None ->
|
| Ok _ ->
|
||||||
do! addMessage ctx { UserMessage.error with message = $"Theme file name {themeFile.FileName} is invalid" }
|
do! addMessage ctx { UserMessage.error with message = "You may not replace the admin theme" }
|
||||||
|
return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/theme/update")) next ctx
|
||||||
|
| Error message ->
|
||||||
|
do! addMessage ctx { UserMessage.error with message = message }
|
||||||
return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/theme/update")) next ctx
|
return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/theme/update")) next ctx
|
||||||
else
|
else
|
||||||
return! RequestErrors.BAD_REQUEST "Bad request" next ctx
|
return! RequestErrors.BAD_REQUEST "Bad request" next ctx
|
||||||
|
|
@ -466,42 +454,46 @@ let updateTheme : HttpHandler = fun next ctx -> task {
|
||||||
|
|
||||||
// -- WEB LOG SETTINGS --
|
// -- WEB LOG SETTINGS --
|
||||||
|
|
||||||
|
open System.Collections.Generic
|
||||||
|
|
||||||
// GET /admin/settings
|
// GET /admin/settings
|
||||||
let settings : HttpHandler = fun next ctx -> task {
|
let settings : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let! allPages = Data.Page.findAll webLog.id ctx.Conn
|
let data = ctx.Data
|
||||||
let! themes = Data.Theme.list ctx.Conn
|
let! allPages = data.Page.all webLog.id
|
||||||
|
let! themes = data.Theme.all ()
|
||||||
return!
|
return!
|
||||||
Hash.FromAnonymousObject
|
Hash.FromAnonymousObject {|
|
||||||
{| csrf = csrfToken ctx
|
csrf = csrfToken ctx
|
||||||
model = SettingsModel.fromWebLog webLog
|
model = SettingsModel.fromWebLog webLog
|
||||||
pages =
|
pages =
|
||||||
seq {
|
seq {
|
||||||
KeyValuePair.Create ("posts", "- First Page of Posts -")
|
KeyValuePair.Create ("posts", "- First Page of Posts -")
|
||||||
yield! allPages
|
yield! allPages
|
||||||
|> List.sortBy (fun p -> p.title.ToLower ())
|
|> List.sortBy (fun p -> p.title.ToLower ())
|
||||||
|> List.map (fun p -> KeyValuePair.Create (PageId.toString p.id, p.title))
|
|> List.map (fun p -> KeyValuePair.Create (PageId.toString p.id, p.title))
|
||||||
}
|
}
|
||||||
|> Array.ofSeq
|
|> Array.ofSeq
|
||||||
themes = themes
|
themes = themes
|
||||||
|> Seq.ofList
|
|> Seq.ofList
|
||||||
|> Seq.map (fun it -> KeyValuePair.Create (ThemeId.toString it.id, $"{it.name} (v{it.version})"))
|
|> Seq.map (fun it ->
|
||||||
|> Array.ofSeq
|
KeyValuePair.Create (ThemeId.toString it.id, $"{it.name} (v{it.version})"))
|
||||||
web_log = webLog
|
|> Array.ofSeq
|
||||||
page_title = "Web Log Settings"
|
web_log = webLog
|
||||||
|}
|
page_title = "Web Log Settings"
|
||||||
|
|}
|
||||||
|> viewForTheme "admin" "settings" next ctx
|
|> viewForTheme "admin" "settings" next ctx
|
||||||
}
|
}
|
||||||
|
|
||||||
// POST /admin/settings
|
// POST /admin/settings
|
||||||
let saveSettings : HttpHandler = fun next ctx -> task {
|
let saveSettings : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
let! model = ctx.BindFormAsync<SettingsModel> ()
|
let! model = ctx.BindFormAsync<SettingsModel> ()
|
||||||
match! Data.WebLog.findById webLog.id conn with
|
match! data.WebLog.findById webLog.id with
|
||||||
| Some webLog ->
|
| Some webLog ->
|
||||||
let webLog = model.update webLog
|
let webLog = model.update webLog
|
||||||
do! Data.WebLog.updateSettings webLog conn
|
do! data.WebLog.updateSettings webLog
|
||||||
|
|
||||||
// Update cache
|
// Update cache
|
||||||
WebLogCache.set webLog
|
WebLogCache.set webLog
|
||||||
|
|
|
||||||
|
|
@ -46,18 +46,19 @@ let deriveFeedType (ctx : HttpContext) feedPath : (FeedType * int) option =
|
||||||
None
|
None
|
||||||
|
|
||||||
/// Determine the function to retrieve posts for the given feed
|
/// Determine the function to retrieve posts for the given feed
|
||||||
let private getFeedPosts (webLog : WebLog) feedType ctx =
|
let private getFeedPosts ctx feedType =
|
||||||
let childIds catId =
|
let childIds catId =
|
||||||
let cat = CategoryCache.get ctx |> Array.find (fun c -> c.id = CategoryId.toString catId)
|
let cat = CategoryCache.get ctx |> Array.find (fun c -> c.id = CategoryId.toString catId)
|
||||||
getCategoryIds cat.slug ctx
|
getCategoryIds cat.slug ctx
|
||||||
|
let data = ctx.Data
|
||||||
match feedType with
|
match feedType with
|
||||||
| StandardFeed _ -> Data.Post.findPageOfPublishedPosts webLog.id 1
|
| StandardFeed _ -> data.Post.findPageOfPublishedPosts ctx.WebLog.id 1
|
||||||
| CategoryFeed (catId, _) -> Data.Post.findPageOfCategorizedPosts webLog.id (childIds catId) 1
|
| CategoryFeed (catId, _) -> data.Post.findPageOfCategorizedPosts ctx.WebLog.id (childIds catId) 1
|
||||||
| TagFeed (tag, _) -> Data.Post.findPageOfTaggedPosts webLog.id tag 1
|
| TagFeed (tag, _) -> data.Post.findPageOfTaggedPosts ctx.WebLog.id tag 1
|
||||||
| Custom (feed, _) ->
|
| Custom (feed, _) ->
|
||||||
match feed.source with
|
match feed.source with
|
||||||
| Category catId -> Data.Post.findPageOfCategorizedPosts webLog.id (childIds catId) 1
|
| Category catId -> data.Post.findPageOfCategorizedPosts ctx.WebLog.id (childIds catId) 1
|
||||||
| Tag tag -> Data.Post.findPageOfTaggedPosts webLog.id tag 1
|
| Tag tag -> data.Post.findPageOfTaggedPosts ctx.WebLog.id tag 1
|
||||||
|
|
||||||
/// Strip HTML from a string
|
/// Strip HTML from a string
|
||||||
let private stripHtml text = WebUtility.HtmlDecode <| Regex.Replace (text, "<(.|\n)*?>", "")
|
let private stripHtml text = WebUtility.HtmlDecode <| Regex.Replace (text, "<(.|\n)*?>", "")
|
||||||
|
|
@ -304,9 +305,9 @@ let private setTitleAndDescription feedType (webLog : WebLog) (cats : DisplayCat
|
||||||
/// Create a feed with a known non-zero-length list of posts
|
/// Create a feed with a known non-zero-length list of posts
|
||||||
let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backgroundTask {
|
let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backgroundTask {
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
let! authors = getAuthors webLog posts conn
|
let! authors = getAuthors webLog posts data
|
||||||
let! tagMaps = getTagMappings webLog posts conn
|
let! tagMaps = getTagMappings webLog posts data
|
||||||
let cats = CategoryCache.get ctx
|
let cats = CategoryCache.get ctx
|
||||||
let podcast = match feedType with Custom (feed, _) when Option.isSome feed.podcast -> Some feed | _ -> None
|
let podcast = match feedType with Custom (feed, _) when Option.isSome feed.podcast -> Some feed | _ -> None
|
||||||
let self, link = selfAndLink webLog feedType ctx
|
let self, link = selfAndLink webLog feedType ctx
|
||||||
|
|
@ -351,7 +352,7 @@ let createFeed (feedType : FeedType) posts : HttpHandler = fun next ctx -> backg
|
||||||
|
|
||||||
// GET {any-prescribed-feed}
|
// GET {any-prescribed-feed}
|
||||||
let generate (feedType : FeedType) postCount : HttpHandler = fun next ctx -> backgroundTask {
|
let generate (feedType : FeedType) postCount : HttpHandler = fun next ctx -> backgroundTask {
|
||||||
match! getFeedPosts ctx.WebLog feedType ctx postCount ctx.Conn with
|
match! getFeedPosts ctx feedType postCount with
|
||||||
| posts when List.length posts > 0 -> return! createFeed feedType posts next ctx
|
| posts when List.length posts > 0 -> return! createFeed feedType posts next ctx
|
||||||
| _ -> return! Error.notFound next ctx
|
| _ -> return! Error.notFound next ctx
|
||||||
}
|
}
|
||||||
|
|
@ -378,12 +379,12 @@ let editSettings : HttpHandler = fun next ctx -> task {
|
||||||
|
|
||||||
// POST: /admin/rss/settings
|
// POST: /admin/rss/settings
|
||||||
let saveSettings : HttpHandler = fun next ctx -> task {
|
let saveSettings : HttpHandler = fun next ctx -> task {
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
let! model = ctx.BindFormAsync<EditRssModel> ()
|
let! model = ctx.BindFormAsync<EditRssModel> ()
|
||||||
match! Data.WebLog.findById ctx.WebLog.id conn with
|
match! data.WebLog.findById ctx.WebLog.id with
|
||||||
| Some webLog ->
|
| Some webLog ->
|
||||||
let webLog = { webLog with rss = model.updateOptions webLog.rss }
|
let webLog = { webLog with rss = model.updateOptions webLog.rss }
|
||||||
do! Data.WebLog.updateRssOptions webLog conn
|
do! data.WebLog.updateRssOptions webLog
|
||||||
WebLogCache.set webLog
|
WebLogCache.set webLog
|
||||||
do! addMessage ctx { UserMessage.success with message = "RSS settings updated successfully" }
|
do! addMessage ctx { UserMessage.success with message = "RSS settings updated successfully" }
|
||||||
return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/settings/rss")) next ctx
|
return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/settings/rss")) next ctx
|
||||||
|
|
@ -410,8 +411,8 @@ let editCustomFeed feedId : HttpHandler = fun next ctx -> task {
|
||||||
|
|
||||||
// POST: /admin/rss/save
|
// POST: /admin/rss/save
|
||||||
let saveCustomFeed : HttpHandler = fun next ctx -> task {
|
let saveCustomFeed : HttpHandler = fun next ctx -> task {
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
match! Data.WebLog.findById ctx.WebLog.id conn with
|
match! data.WebLog.findById ctx.WebLog.id with
|
||||||
| Some webLog ->
|
| Some webLog ->
|
||||||
let! model = ctx.BindFormAsync<EditCustomFeedModel> ()
|
let! model = ctx.BindFormAsync<EditCustomFeedModel> ()
|
||||||
let theFeed =
|
let theFeed =
|
||||||
|
|
@ -422,7 +423,7 @@ let saveCustomFeed : HttpHandler = fun next ctx -> task {
|
||||||
| Some feed ->
|
| Some feed ->
|
||||||
let feeds = model.updateFeed feed :: (webLog.rss.customFeeds |> List.filter (fun it -> it.id <> feed.id))
|
let feeds = model.updateFeed feed :: (webLog.rss.customFeeds |> List.filter (fun it -> it.id <> feed.id))
|
||||||
let webLog = { webLog with rss = { webLog.rss with customFeeds = feeds } }
|
let webLog = { webLog with rss = { webLog.rss with customFeeds = feeds } }
|
||||||
do! Data.WebLog.updateRssOptions webLog conn
|
do! data.WebLog.updateRssOptions webLog
|
||||||
WebLogCache.set webLog
|
WebLogCache.set webLog
|
||||||
do! addMessage ctx {
|
do! addMessage ctx {
|
||||||
UserMessage.success with
|
UserMessage.success with
|
||||||
|
|
@ -436,8 +437,8 @@ let saveCustomFeed : HttpHandler = fun next ctx -> task {
|
||||||
|
|
||||||
// POST /admin/rss/{id}/delete
|
// POST /admin/rss/{id}/delete
|
||||||
let deleteCustomFeed feedId : HttpHandler = fun next ctx -> task {
|
let deleteCustomFeed feedId : HttpHandler = fun next ctx -> task {
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
match! Data.WebLog.findById ctx.WebLog.id conn with
|
match! data.WebLog.findById ctx.WebLog.id with
|
||||||
| Some webLog ->
|
| Some webLog ->
|
||||||
let customId = CustomFeedId feedId
|
let customId = CustomFeedId feedId
|
||||||
if webLog.rss.customFeeds |> List.exists (fun f -> f.id = customId) then
|
if webLog.rss.customFeeds |> List.exists (fun f -> f.id = customId) then
|
||||||
|
|
@ -448,7 +449,7 @@ let deleteCustomFeed feedId : HttpHandler = fun next ctx -> task {
|
||||||
customFeeds = webLog.rss.customFeeds |> List.filter (fun f -> f.id <> customId)
|
customFeeds = webLog.rss.customFeeds |> List.filter (fun f -> f.id <> customId)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
do! Data.WebLog.updateRssOptions webLog conn
|
do! data.WebLog.updateRssOptions webLog
|
||||||
WebLogCache.set webLog
|
WebLogCache.set webLog
|
||||||
do! addMessage ctx { UserMessage.success with message = "Custom feed deleted successfully" }
|
do! addMessage ctx { UserMessage.success with message = "Custom feed deleted successfully" }
|
||||||
else
|
else
|
||||||
|
|
|
||||||
|
|
@ -108,12 +108,12 @@ let viewForTheme theme template next ctx = fun (hash : Hash) -> task {
|
||||||
// the net effect is a "layout" capability similar to Razor or Pug
|
// the net effect is a "layout" capability similar to Razor or Pug
|
||||||
|
|
||||||
// Render view content...
|
// Render view content...
|
||||||
let! contentTemplate = TemplateCache.get theme template ctx.Conn
|
let! contentTemplate = TemplateCache.get theme template ctx.Data
|
||||||
hash.Add ("content", contentTemplate.Render hash)
|
hash.Add ("content", contentTemplate.Render hash)
|
||||||
|
|
||||||
// ...then render that content with its layout
|
// ...then render that content with its layout
|
||||||
let isHtmx = ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh
|
let isHtmx = ctx.Request.IsHtmx && not ctx.Request.IsHtmxRefresh
|
||||||
let! layoutTemplate = TemplateCache.get theme (if isHtmx then "layout-partial" else "layout") ctx.Conn
|
let! layoutTemplate = TemplateCache.get theme (if isHtmx then "layout-partial" else "layout") ctx.Data
|
||||||
|
|
||||||
return! htmlString (layoutTemplate.Render hash) next ctx
|
return! htmlString (layoutTemplate.Render hash) next ctx
|
||||||
}
|
}
|
||||||
|
|
@ -123,10 +123,10 @@ let bareForTheme theme template next ctx = fun (hash : Hash) -> task {
|
||||||
do! populateHash hash ctx
|
do! populateHash hash ctx
|
||||||
|
|
||||||
// Bare templates are rendered with layout-bare
|
// Bare templates are rendered with layout-bare
|
||||||
let! contentTemplate = TemplateCache.get theme template ctx.Conn
|
let! contentTemplate = TemplateCache.get theme template ctx.Data
|
||||||
hash.Add ("content", contentTemplate.Render hash)
|
hash.Add ("content", contentTemplate.Render hash)
|
||||||
|
|
||||||
let! layoutTemplate = TemplateCache.get theme "layout-bare" ctx.Conn
|
let! layoutTemplate = TemplateCache.get theme "layout-bare" ctx.Data
|
||||||
|
|
||||||
// add messages as HTTP headers
|
// add messages as HTTP headers
|
||||||
let messages = hash["messages"] :?> UserMessage[]
|
let messages = hash["messages"] :?> UserMessage[]
|
||||||
|
|
@ -182,11 +182,11 @@ let validateCsrf : HttpHandler = fun next ctx -> task {
|
||||||
let requireUser : HttpHandler = requiresAuthentication Error.notAuthorized
|
let requireUser : HttpHandler = requiresAuthentication Error.notAuthorized
|
||||||
|
|
||||||
open System.Collections.Generic
|
open System.Collections.Generic
|
||||||
open System.IO
|
open MyWebLog.Data
|
||||||
|
|
||||||
/// Get the templates available for the current web log's theme (in a key/value pair list)
|
/// Get the templates available for the current web log's theme (in a key/value pair list)
|
||||||
let templatesForTheme (ctx : HttpContext) (typ : string) = backgroundTask {
|
let templatesForTheme (ctx : HttpContext) (typ : string) = backgroundTask {
|
||||||
match! Data.Theme.findByIdWithoutText (ThemeId ctx.WebLog.themePath) ctx.Conn with
|
match! ctx.Data.Theme.findByIdWithoutText (ThemeId ctx.WebLog.themePath) with
|
||||||
| Some theme ->
|
| Some theme ->
|
||||||
return seq {
|
return seq {
|
||||||
KeyValuePair.Create ("", $"- Default (single-{typ}) -")
|
KeyValuePair.Create ("", $"- Default (single-{typ}) -")
|
||||||
|
|
@ -201,19 +201,19 @@ let templatesForTheme (ctx : HttpContext) (typ : string) = backgroundTask {
|
||||||
}
|
}
|
||||||
|
|
||||||
/// Get all authors for a list of posts as metadata items
|
/// Get all authors for a list of posts as metadata items
|
||||||
let getAuthors (webLog : WebLog) (posts : Post list) conn =
|
let getAuthors (webLog : WebLog) (posts : Post list) (data : IData) =
|
||||||
posts
|
posts
|
||||||
|> List.map (fun p -> p.authorId)
|
|> List.map (fun p -> p.authorId)
|
||||||
|> List.distinct
|
|> List.distinct
|
||||||
|> Data.WebLogUser.findNames webLog.id conn
|
|> data.WebLogUser.findNames webLog.id
|
||||||
|
|
||||||
/// Get all tag mappings for a list of posts as metadata items
|
/// Get all tag mappings for a list of posts as metadata items
|
||||||
let getTagMappings (webLog : WebLog) (posts : Post list) =
|
let getTagMappings (webLog : WebLog) (posts : Post list) (data : IData) =
|
||||||
posts
|
posts
|
||||||
|> List.map (fun p -> p.tags)
|
|> List.map (fun p -> p.tags)
|
||||||
|> List.concat
|
|> List.concat
|
||||||
|> List.distinct
|
|> List.distinct
|
||||||
|> fun tags -> Data.TagMap.findMappingForTags tags webLog.id
|
|> fun tags -> data.TagMap.findMappingForTags tags webLog.id
|
||||||
|
|
||||||
/// Get all category IDs for the given slug (includes owned subcategories)
|
/// Get all category IDs for the given slug (includes owned subcategories)
|
||||||
let getCategoryIds slug ctx =
|
let getCategoryIds slug ctx =
|
||||||
|
|
|
||||||
|
|
@ -36,12 +36,13 @@ type ListType =
|
||||||
|
|
||||||
open System.Threading.Tasks
|
open System.Threading.Tasks
|
||||||
open DotLiquid
|
open DotLiquid
|
||||||
|
open MyWebLog.Data
|
||||||
open MyWebLog.ViewModels
|
open MyWebLog.ViewModels
|
||||||
|
|
||||||
/// Convert a list of posts into items ready to be displayed
|
/// Convert a list of posts into items ready to be displayed
|
||||||
let preparePostList webLog posts listType (url : string) pageNbr perPage ctx conn = task {
|
let preparePostList webLog posts listType (url : string) pageNbr perPage ctx (data : IData) = task {
|
||||||
let! authors = getAuthors webLog posts conn
|
let! authors = getAuthors webLog posts data
|
||||||
let! tagMappings = getTagMappings webLog posts conn
|
let! tagMappings = getTagMappings webLog posts data
|
||||||
let relUrl it = Some <| WebLog.relativeUrl webLog (Permalink it)
|
let relUrl it = Some <| WebLog.relativeUrl webLog (Permalink it)
|
||||||
let postItems =
|
let postItems =
|
||||||
posts
|
posts
|
||||||
|
|
@ -54,7 +55,7 @@ let preparePostList webLog posts listType (url : string) pageNbr perPage ctx con
|
||||||
| SinglePost ->
|
| SinglePost ->
|
||||||
let post = List.head posts
|
let post = List.head posts
|
||||||
let dateTime = defaultArg post.publishedOn post.updatedOn
|
let dateTime = defaultArg post.publishedOn post.updatedOn
|
||||||
Data.Post.findSurroundingPosts webLog.id dateTime conn
|
data.Post.findSurroundingPosts webLog.id dateTime
|
||||||
| _ -> Task.FromResult (None, None)
|
| _ -> Task.FromResult (None, None)
|
||||||
let newerLink =
|
let newerLink =
|
||||||
match listType, pageNbr with
|
match listType, pageNbr with
|
||||||
|
|
@ -98,9 +99,9 @@ open Giraffe
|
||||||
// GET /page/{pageNbr}
|
// GET /page/{pageNbr}
|
||||||
let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
|
let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
let! posts = Data.Post.findPageOfPublishedPosts webLog.id pageNbr webLog.postsPerPage conn
|
let! posts = data.Post.findPageOfPublishedPosts webLog.id pageNbr webLog.postsPerPage
|
||||||
let! hash = preparePostList webLog posts PostList "" pageNbr webLog.postsPerPage ctx conn
|
let! hash = preparePostList webLog posts PostList "" pageNbr webLog.postsPerPage ctx data
|
||||||
let title =
|
let title =
|
||||||
match pageNbr, webLog.defaultPage with
|
match pageNbr, webLog.defaultPage with
|
||||||
| 1, "posts" -> None
|
| 1, "posts" -> None
|
||||||
|
|
@ -119,7 +120,7 @@ let redirectToPageOfPosts (pageNbr : int) : HttpHandler = fun next ctx ->
|
||||||
// GET /category/{slug}/page/{pageNbr}
|
// GET /category/{slug}/page/{pageNbr}
|
||||||
let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task {
|
let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
match parseSlugAndPage webLog slugAndPage with
|
match parseSlugAndPage webLog slugAndPage with
|
||||||
| Some pageNbr, slug, isFeed ->
|
| Some pageNbr, slug, isFeed ->
|
||||||
match CategoryCache.get ctx |> Array.tryFind (fun cat -> cat.slug = slug) with
|
match CategoryCache.get ctx |> Array.tryFind (fun cat -> cat.slug = slug) with
|
||||||
|
|
@ -128,10 +129,10 @@ let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task {
|
||||||
(defaultArg webLog.rss.itemsInFeed webLog.postsPerPage) next ctx
|
(defaultArg webLog.rss.itemsInFeed webLog.postsPerPage) next ctx
|
||||||
| Some cat ->
|
| Some cat ->
|
||||||
// Category pages include posts in subcategories
|
// Category pages include posts in subcategories
|
||||||
match! Data.Post.findPageOfCategorizedPosts webLog.id (getCategoryIds slug ctx) pageNbr webLog.postsPerPage
|
match! data.Post.findPageOfCategorizedPosts webLog.id (getCategoryIds slug ctx) pageNbr webLog.postsPerPage
|
||||||
conn with
|
with
|
||||||
| posts when List.length posts > 0 ->
|
| posts when List.length posts > 0 ->
|
||||||
let! hash = preparePostList webLog posts CategoryList cat.slug pageNbr webLog.postsPerPage ctx conn
|
let! hash = preparePostList webLog posts CategoryList cat.slug pageNbr webLog.postsPerPage ctx data
|
||||||
let pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
|
let pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
|
||||||
hash.Add ("page_title", $"{cat.name}: Category Archive{pgTitle}")
|
hash.Add ("page_title", $"{cat.name}: Category Archive{pgTitle}")
|
||||||
hash.Add ("subtitle", defaultArg cat.description "")
|
hash.Add ("subtitle", defaultArg cat.description "")
|
||||||
|
|
@ -150,12 +151,12 @@ open System.Web
|
||||||
// GET /tag/{tag}/page/{pageNbr}
|
// GET /tag/{tag}/page/{pageNbr}
|
||||||
let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
|
let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
match parseSlugAndPage webLog slugAndPage with
|
match parseSlugAndPage webLog slugAndPage with
|
||||||
| Some pageNbr, rawTag, isFeed ->
|
| Some pageNbr, rawTag, isFeed ->
|
||||||
let urlTag = HttpUtility.UrlDecode rawTag
|
let urlTag = HttpUtility.UrlDecode rawTag
|
||||||
let! tag = backgroundTask {
|
let! tag = backgroundTask {
|
||||||
match! Data.TagMap.findByUrlValue urlTag webLog.id conn with
|
match! data.TagMap.findByUrlValue urlTag webLog.id with
|
||||||
| Some m -> return m.tag
|
| Some m -> return m.tag
|
||||||
| None -> return urlTag
|
| None -> return urlTag
|
||||||
}
|
}
|
||||||
|
|
@ -163,9 +164,9 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
|
||||||
return! Feed.generate (Feed.TagFeed (tag, $"tag/{rawTag}/{webLog.rss.feedName}"))
|
return! Feed.generate (Feed.TagFeed (tag, $"tag/{rawTag}/{webLog.rss.feedName}"))
|
||||||
(defaultArg webLog.rss.itemsInFeed webLog.postsPerPage) next ctx
|
(defaultArg webLog.rss.itemsInFeed webLog.postsPerPage) next ctx
|
||||||
else
|
else
|
||||||
match! Data.Post.findPageOfTaggedPosts webLog.id tag pageNbr webLog.postsPerPage conn with
|
match! data.Post.findPageOfTaggedPosts webLog.id tag pageNbr webLog.postsPerPage with
|
||||||
| posts when List.length posts > 0 ->
|
| posts when List.length posts > 0 ->
|
||||||
let! hash = preparePostList webLog posts TagList rawTag pageNbr webLog.postsPerPage ctx conn
|
let! hash = preparePostList webLog posts TagList rawTag pageNbr webLog.postsPerPage ctx data
|
||||||
let pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
|
let pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
|
||||||
hash.Add ("page_title", $"Posts Tagged “{tag}”{pgTitle}")
|
hash.Add ("page_title", $"Posts Tagged “{tag}”{pgTitle}")
|
||||||
hash.Add ("is_tag", true)
|
hash.Add ("is_tag", true)
|
||||||
|
|
@ -175,7 +176,7 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
|
||||||
// Other systems use hyphens for spaces; redirect if this is an old tag link
|
// Other systems use hyphens for spaces; redirect if this is an old tag link
|
||||||
| _ ->
|
| _ ->
|
||||||
let spacedTag = tag.Replace ("-", " ")
|
let spacedTag = tag.Replace ("-", " ")
|
||||||
match! Data.Post.findPageOfTaggedPosts webLog.id spacedTag pageNbr 1 conn with
|
match! data.Post.findPageOfTaggedPosts webLog.id spacedTag pageNbr 1 with
|
||||||
| posts when List.length posts > 0 ->
|
| posts when List.length posts > 0 ->
|
||||||
let endUrl = if pageNbr = 1 then "" else $"page/{pageNbr}"
|
let endUrl = if pageNbr = 1 then "" else $"page/{pageNbr}"
|
||||||
return!
|
return!
|
||||||
|
|
@ -192,7 +193,7 @@ let home : HttpHandler = fun next ctx -> task {
|
||||||
match webLog.defaultPage with
|
match webLog.defaultPage with
|
||||||
| "posts" -> return! pageOfPosts 1 next ctx
|
| "posts" -> return! pageOfPosts 1 next ctx
|
||||||
| pageId ->
|
| pageId ->
|
||||||
match! Data.Page.findById (PageId pageId) webLog.id ctx.Conn with
|
match! ctx.Data.Page.findById (PageId pageId) webLog.id with
|
||||||
| Some page ->
|
| Some page ->
|
||||||
return!
|
return!
|
||||||
Hash.FromAnonymousObject {|
|
Hash.FromAnonymousObject {|
|
||||||
|
|
@ -209,9 +210,9 @@ let home : HttpHandler = fun next ctx -> task {
|
||||||
// GET /admin/posts/page/{pageNbr}
|
// GET /admin/posts/page/{pageNbr}
|
||||||
let all pageNbr : HttpHandler = fun next ctx -> task {
|
let all pageNbr : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
let! posts = Data.Post.findPageOfPosts webLog.id pageNbr 25 conn
|
let! posts = data.Post.findPageOfPosts webLog.id pageNbr 25
|
||||||
let! hash = preparePostList webLog posts AdminList "" pageNbr 25 ctx conn
|
let! hash = preparePostList webLog posts AdminList "" pageNbr 25 ctx data
|
||||||
hash.Add ("page_title", "Posts")
|
hash.Add ("page_title", "Posts")
|
||||||
hash.Add ("csrf", csrfToken ctx)
|
hash.Add ("csrf", csrfToken ctx)
|
||||||
return! viewForTheme "admin" "post-list" next ctx hash
|
return! viewForTheme "admin" "post-list" next ctx hash
|
||||||
|
|
@ -220,18 +221,18 @@ let all pageNbr : HttpHandler = fun next ctx -> task {
|
||||||
// GET /admin/post/{id}/edit
|
// GET /admin/post/{id}/edit
|
||||||
let edit postId : HttpHandler = fun next ctx -> task {
|
let edit postId : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
let! result = task {
|
let! result = task {
|
||||||
match postId with
|
match postId with
|
||||||
| "new" -> return Some ("Write a New Post", { Post.empty with id = PostId "new" })
|
| "new" -> return Some ("Write a New Post", { Post.empty with id = PostId "new" })
|
||||||
| _ ->
|
| _ ->
|
||||||
match! Data.Post.findByFullId (PostId postId) webLog.id conn with
|
match! data.Post.findFullById (PostId postId) webLog.id with
|
||||||
| Some post -> return Some ("Edit Post", post)
|
| Some post -> return Some ("Edit Post", post)
|
||||||
| None -> return None
|
| None -> return None
|
||||||
}
|
}
|
||||||
match result with
|
match result with
|
||||||
| Some (title, post) ->
|
| Some (title, post) ->
|
||||||
let! cats = Data.Category.findAllForView webLog.id conn
|
let! cats = data.Category.findAllForView webLog.id
|
||||||
let! templates = templatesForTheme ctx "post"
|
let! templates = templatesForTheme ctx "post"
|
||||||
let model = EditPostModel.fromPost webLog post
|
let model = EditPostModel.fromPost webLog post
|
||||||
return!
|
return!
|
||||||
|
|
@ -250,7 +251,7 @@ let edit postId : HttpHandler = fun next ctx -> task {
|
||||||
|
|
||||||
// GET /admin/post/{id}/permalinks
|
// GET /admin/post/{id}/permalinks
|
||||||
let editPermalinks postId : HttpHandler = fun next ctx -> task {
|
let editPermalinks postId : HttpHandler = fun next ctx -> task {
|
||||||
match! Data.Post.findByFullId (PostId postId) ctx.WebLog.id ctx.Conn with
|
match! ctx.Data.Post.findFullById (PostId postId) ctx.WebLog.id with
|
||||||
| Some post ->
|
| Some post ->
|
||||||
return!
|
return!
|
||||||
Hash.FromAnonymousObject {|
|
Hash.FromAnonymousObject {|
|
||||||
|
|
@ -267,7 +268,7 @@ let savePermalinks : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
|
let! model = ctx.BindFormAsync<ManagePermalinksModel> ()
|
||||||
let links = model.prior |> Array.map Permalink |> List.ofArray
|
let links = model.prior |> Array.map Permalink |> List.ofArray
|
||||||
match! Data.Post.updatePriorPermalinks (PostId model.id) webLog.id links ctx.Conn with
|
match! ctx.Data.Post.updatePriorPermalinks (PostId model.id) webLog.id links with
|
||||||
| true ->
|
| true ->
|
||||||
do! addMessage ctx { UserMessage.success with message = "Post permalinks saved successfully" }
|
do! addMessage ctx { UserMessage.success with message = "Post permalinks saved successfully" }
|
||||||
return! redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/post/{model.id}/permalinks")) next ctx
|
return! redirectToGet (WebLog.relativeUrl webLog (Permalink $"admin/post/{model.id}/permalinks")) next ctx
|
||||||
|
|
@ -277,7 +278,7 @@ let savePermalinks : HttpHandler = fun next ctx -> task {
|
||||||
// POST /admin/post/{id}/delete
|
// POST /admin/post/{id}/delete
|
||||||
let delete postId : HttpHandler = fun next ctx -> task {
|
let delete postId : HttpHandler = fun next ctx -> task {
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
match! Data.Post.delete (PostId postId) webLog.id ctx.Conn with
|
match! ctx.Data.Post.delete (PostId postId) webLog.id with
|
||||||
| true -> do! addMessage ctx { UserMessage.success with message = "Post deleted successfully" }
|
| true -> do! addMessage ctx { UserMessage.success with message = "Post deleted successfully" }
|
||||||
| false -> do! addMessage ctx { UserMessage.error with message = "Post not found; nothing deleted" }
|
| false -> do! addMessage ctx { UserMessage.error with message = "Post not found; nothing deleted" }
|
||||||
return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/posts")) next ctx
|
return! redirectToGet (WebLog.relativeUrl webLog (Permalink "admin/posts")) next ctx
|
||||||
|
|
@ -289,7 +290,7 @@ let delete postId : HttpHandler = fun next ctx -> task {
|
||||||
let save : HttpHandler = fun next ctx -> task {
|
let save : HttpHandler = fun next ctx -> task {
|
||||||
let! model = ctx.BindFormAsync<EditPostModel> ()
|
let! model = ctx.BindFormAsync<EditPostModel> ()
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
let now = DateTime.UtcNow
|
let now = DateTime.UtcNow
|
||||||
let! pst = task {
|
let! pst = task {
|
||||||
match model.postId with
|
match model.postId with
|
||||||
|
|
@ -300,7 +301,7 @@ let save : HttpHandler = fun next ctx -> task {
|
||||||
webLogId = webLog.id
|
webLogId = webLog.id
|
||||||
authorId = userId ctx
|
authorId = userId ctx
|
||||||
}
|
}
|
||||||
| postId -> return! Data.Post.findByFullId (PostId postId) webLog.id conn
|
| postId -> return! data.Post.findFullById (PostId postId) webLog.id
|
||||||
}
|
}
|
||||||
match pst with
|
match pst with
|
||||||
| Some post ->
|
| Some post ->
|
||||||
|
|
@ -349,7 +350,7 @@ let save : HttpHandler = fun next ctx -> task {
|
||||||
}
|
}
|
||||||
| false -> { post with publishedOn = Some dt }
|
| false -> { post with publishedOn = Some dt }
|
||||||
| false -> post
|
| false -> post
|
||||||
do! (if model.postId = "new" then Data.Post.add else Data.Post.update) post conn
|
do! (if model.postId = "new" then data.Post.add else data.Post.update) post
|
||||||
// If the post was published or its categories changed, refresh the category cache
|
// If the post was published or its categories changed, refresh the category cache
|
||||||
if model.doPublish
|
if model.doPublish
|
||||||
|| not (pst.Value.categoryIds
|
|| not (pst.Value.categoryIds
|
||||||
|
|
|
||||||
|
|
@ -14,7 +14,7 @@ module CatchAll =
|
||||||
/// Sequence where the first returned value is the proper handler for the link
|
/// Sequence where the first returned value is the proper handler for the link
|
||||||
let private deriveAction (ctx : HttpContext) : HttpHandler seq =
|
let private deriveAction (ctx : HttpContext) : HttpHandler seq =
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
let debug = debug "Routes.CatchAll" ctx
|
let debug = debug "Routes.CatchAll" ctx
|
||||||
let textLink =
|
let textLink =
|
||||||
let _, extra = WebLog.hostAndPath webLog
|
let _, extra = WebLog.hostAndPath webLog
|
||||||
|
|
@ -27,15 +27,15 @@ module CatchAll =
|
||||||
if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.empty)
|
if textLink = "" then yield redirectTo true (WebLog.relativeUrl webLog Permalink.empty)
|
||||||
let permalink = Permalink (textLink.Substring 1)
|
let permalink = Permalink (textLink.Substring 1)
|
||||||
// Current post
|
// Current post
|
||||||
match Data.Post.findByPermalink permalink webLog.id conn |> await with
|
match data.Post.findByPermalink permalink webLog.id |> await with
|
||||||
| Some post ->
|
| Some post ->
|
||||||
debug (fun () -> $"Found post by permalink")
|
debug (fun () -> $"Found post by permalink")
|
||||||
let model = Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 ctx conn |> await
|
let model = Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 ctx data |> await
|
||||||
model.Add ("page_title", post.title)
|
model.Add ("page_title", post.title)
|
||||||
yield fun next ctx -> themedView (defaultArg post.template "single-post") next ctx model
|
yield fun next ctx -> themedView (defaultArg post.template "single-post") next ctx model
|
||||||
| None -> ()
|
| None -> ()
|
||||||
// Current page
|
// Current page
|
||||||
match Data.Page.findByPermalink permalink webLog.id conn |> await with
|
match data.Page.findByPermalink permalink webLog.id |> await with
|
||||||
| Some page ->
|
| Some page ->
|
||||||
debug (fun () -> $"Found page by permalink")
|
debug (fun () -> $"Found page by permalink")
|
||||||
yield fun next ctx ->
|
yield fun next ctx ->
|
||||||
|
|
@ -56,25 +56,25 @@ module CatchAll =
|
||||||
// Post differing only by trailing slash
|
// Post differing only by trailing slash
|
||||||
let altLink =
|
let altLink =
|
||||||
Permalink (if textLink.EndsWith "/" then textLink[1..textLink.Length - 2] else $"{textLink[1..]}/")
|
Permalink (if textLink.EndsWith "/" then textLink[1..textLink.Length - 2] else $"{textLink[1..]}/")
|
||||||
match Data.Post.findByPermalink altLink webLog.id conn |> await with
|
match data.Post.findByPermalink altLink webLog.id |> await with
|
||||||
| Some post ->
|
| Some post ->
|
||||||
debug (fun () -> $"Found post by trailing-slash-agnostic permalink")
|
debug (fun () -> $"Found post by trailing-slash-agnostic permalink")
|
||||||
yield redirectTo true (WebLog.relativeUrl webLog post.permalink)
|
yield redirectTo true (WebLog.relativeUrl webLog post.permalink)
|
||||||
| None -> ()
|
| None -> ()
|
||||||
// Page differing only by trailing slash
|
// Page differing only by trailing slash
|
||||||
match Data.Page.findByPermalink altLink webLog.id conn |> await with
|
match data.Page.findByPermalink altLink webLog.id |> await with
|
||||||
| Some page ->
|
| Some page ->
|
||||||
debug (fun () -> $"Found page by trailing-slash-agnostic permalink")
|
debug (fun () -> $"Found page by trailing-slash-agnostic permalink")
|
||||||
yield redirectTo true (WebLog.relativeUrl webLog page.permalink)
|
yield redirectTo true (WebLog.relativeUrl webLog page.permalink)
|
||||||
| None -> ()
|
| None -> ()
|
||||||
// Prior post
|
// Prior post
|
||||||
match Data.Post.findCurrentPermalink [ permalink; altLink ] webLog.id conn |> await with
|
match data.Post.findCurrentPermalink [ permalink; altLink ] webLog.id |> await with
|
||||||
| Some link ->
|
| Some link ->
|
||||||
debug (fun () -> $"Found post by prior permalink")
|
debug (fun () -> $"Found post by prior permalink")
|
||||||
yield redirectTo true (WebLog.relativeUrl webLog link)
|
yield redirectTo true (WebLog.relativeUrl webLog link)
|
||||||
| None -> ()
|
| None -> ()
|
||||||
// Prior page
|
// Prior page
|
||||||
match Data.Page.findCurrentPermalink [ permalink; altLink ] webLog.id conn |> await with
|
match data.Page.findCurrentPermalink [ permalink; altLink ] webLog.id |> await with
|
||||||
| Some link ->
|
| Some link ->
|
||||||
debug (fun () -> $"Found page by prior permalink")
|
debug (fun () -> $"Found page by prior permalink")
|
||||||
yield redirectTo true (WebLog.relativeUrl webLog link)
|
yield redirectTo true (WebLog.relativeUrl webLog link)
|
||||||
|
|
@ -114,7 +114,7 @@ module Asset =
|
||||||
// GET /theme/{theme}/{**path}
|
// GET /theme/{theme}/{**path}
|
||||||
let serveAsset (urlParts : string seq) : HttpHandler = fun next ctx -> task {
|
let serveAsset (urlParts : string seq) : HttpHandler = fun next ctx -> task {
|
||||||
let path = urlParts |> Seq.skip 1 |> Seq.head
|
let path = urlParts |> Seq.skip 1 |> Seq.head
|
||||||
match! Data.ThemeAsset.findById (ThemeAssetId.ofString path) ctx.Conn with
|
match! ctx.Data.ThemeAsset.findById (ThemeAssetId.ofString path) with
|
||||||
| Some asset ->
|
| Some asset ->
|
||||||
match checkModified asset ctx with
|
match checkModified asset ctx with
|
||||||
| Some threeOhFour -> return! threeOhFour next ctx
|
| Some threeOhFour -> return! threeOhFour next ctx
|
||||||
|
|
|
||||||
|
|
@ -42,7 +42,7 @@ open MyWebLog
|
||||||
let doLogOn : HttpHandler = fun next ctx -> task {
|
let doLogOn : HttpHandler = fun next ctx -> task {
|
||||||
let! model = ctx.BindFormAsync<LogOnModel> ()
|
let! model = ctx.BindFormAsync<LogOnModel> ()
|
||||||
let webLog = ctx.WebLog
|
let webLog = ctx.WebLog
|
||||||
match! Data.WebLogUser.findByEmail model.emailAddress webLog.id ctx.Conn with
|
match! ctx.Data.WebLogUser.findByEmail model.emailAddress webLog.id with
|
||||||
| Some user when user.passwordHash = hashedPassword model.password user.userName user.salt ->
|
| Some user when user.passwordHash = hashedPassword model.password user.userName user.salt ->
|
||||||
let claims = seq {
|
let claims = seq {
|
||||||
Claim (ClaimTypes.NameIdentifier, WebLogUserId.toString user.id)
|
Claim (ClaimTypes.NameIdentifier, WebLogUserId.toString user.id)
|
||||||
|
|
@ -79,7 +79,7 @@ let private showEdit (hash : Hash) : HttpHandler = fun next ctx -> task {
|
||||||
|
|
||||||
// GET /admin/user/edit
|
// GET /admin/user/edit
|
||||||
let edit : HttpHandler = fun next ctx -> task {
|
let edit : HttpHandler = fun next ctx -> task {
|
||||||
match! Data.WebLogUser.findById (userId ctx) ctx.Conn with
|
match! ctx.Data.WebLogUser.findById (userId ctx) ctx.WebLog.id with
|
||||||
| Some user -> return! showEdit (Hash.FromAnonymousObject {| model = EditUserModel.fromUser user |}) next ctx
|
| Some user -> return! showEdit (Hash.FromAnonymousObject {| model = EditUserModel.fromUser user |}) next ctx
|
||||||
| None -> return! Error.notFound next ctx
|
| None -> return! Error.notFound next ctx
|
||||||
}
|
}
|
||||||
|
|
@ -88,8 +88,8 @@ let edit : HttpHandler = fun next ctx -> task {
|
||||||
let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
|
let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
|
||||||
let! model = ctx.BindFormAsync<EditUserModel> ()
|
let! model = ctx.BindFormAsync<EditUserModel> ()
|
||||||
if model.newPassword = model.newPasswordConfirm then
|
if model.newPassword = model.newPasswordConfirm then
|
||||||
let conn = ctx.Conn
|
let data = ctx.Data
|
||||||
match! Data.WebLogUser.findById (userId ctx) conn with
|
match! data.WebLogUser.findById (userId ctx) ctx.WebLog.id with
|
||||||
| Some user ->
|
| Some user ->
|
||||||
let pw, salt =
|
let pw, salt =
|
||||||
if model.newPassword = "" then
|
if model.newPassword = "" then
|
||||||
|
|
@ -105,7 +105,7 @@ let save : HttpHandler = requireUser >=> validateCsrf >=> fun next ctx -> task {
|
||||||
passwordHash = pw
|
passwordHash = pw
|
||||||
salt = salt
|
salt = salt
|
||||||
}
|
}
|
||||||
do! Data.WebLogUser.update user conn
|
do! data.WebLogUser.update user
|
||||||
let pwMsg = if model.newPassword = "" then "" else " and updated your password"
|
let pwMsg = if model.newPassword = "" then "" else " and updated your password"
|
||||||
do! addMessage ctx { UserMessage.success with message = $"Saved your information{pwMsg} successfully" }
|
do! addMessage ctx { UserMessage.success with message = $"Saved your information{pwMsg} successfully" }
|
||||||
return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/user/edit")) next ctx
|
return! redirectToGet (WebLog.relativeUrl ctx.WebLog (Permalink "admin/user/edit")) next ctx
|
||||||
|
|
|
||||||
|
|
@ -3,13 +3,12 @@ module MyWebLog.Maintenance
|
||||||
open System
|
open System
|
||||||
open System.IO
|
open System.IO
|
||||||
open Microsoft.Extensions.DependencyInjection
|
open Microsoft.Extensions.DependencyInjection
|
||||||
open RethinkDb.Driver.FSharp
|
open MyWebLog.Data
|
||||||
open RethinkDb.Driver.Net
|
|
||||||
|
|
||||||
/// Create the web log information
|
/// Create the web log information
|
||||||
let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
|
let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
|
||||||
|
|
||||||
let conn = sp.GetRequiredService<IConnection> ()
|
let data = sp.GetRequiredService<IData> ()
|
||||||
|
|
||||||
let timeZone =
|
let timeZone =
|
||||||
let local = TimeZoneInfo.Local.Id
|
let local = TimeZoneInfo.Local.Id
|
||||||
|
|
@ -25,19 +24,19 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
|
||||||
let userId = WebLogUserId.create ()
|
let userId = WebLogUserId.create ()
|
||||||
let homePageId = PageId.create ()
|
let homePageId = PageId.create ()
|
||||||
|
|
||||||
do! Data.WebLog.add
|
do! data.WebLog.add
|
||||||
{ WebLog.empty with
|
{ WebLog.empty with
|
||||||
id = webLogId
|
id = webLogId
|
||||||
name = args[2]
|
name = args[2]
|
||||||
urlBase = args[1]
|
urlBase = args[1]
|
||||||
defaultPage = PageId.toString homePageId
|
defaultPage = PageId.toString homePageId
|
||||||
timeZone = timeZone
|
timeZone = timeZone
|
||||||
} conn
|
}
|
||||||
|
|
||||||
// Create the admin user
|
// Create the admin user
|
||||||
let salt = Guid.NewGuid ()
|
let salt = Guid.NewGuid ()
|
||||||
|
|
||||||
do! Data.WebLogUser.add
|
do! data.WebLogUser.add
|
||||||
{ WebLogUser.empty with
|
{ WebLogUser.empty with
|
||||||
id = userId
|
id = userId
|
||||||
webLogId = webLogId
|
webLogId = webLogId
|
||||||
|
|
@ -48,10 +47,10 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
|
||||||
passwordHash = Handlers.User.hashedPassword args[4] args[3] salt
|
passwordHash = Handlers.User.hashedPassword args[4] args[3] salt
|
||||||
salt = salt
|
salt = salt
|
||||||
authorizationLevel = Administrator
|
authorizationLevel = Administrator
|
||||||
} conn
|
}
|
||||||
|
|
||||||
// Create the default home page
|
// Create the default home page
|
||||||
do! Data.Page.add
|
do! data.Page.add
|
||||||
{ Page.empty with
|
{ Page.empty with
|
||||||
id = homePageId
|
id = homePageId
|
||||||
webLogId = webLogId
|
webLogId = webLogId
|
||||||
|
|
@ -66,7 +65,7 @@ let private doCreateWebLog (args : string[]) (sp : IServiceProvider) = task {
|
||||||
text = Html "<p>This is your default home page.</p>"
|
text = Html "<p>This is your default home page.</p>"
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
} conn
|
}
|
||||||
|
|
||||||
printfn $"Successfully initialized database for {args[2]} with URL base {args[1]}"
|
printfn $"Successfully initialized database for {args[2]} with URL base {args[1]}"
|
||||||
}
|
}
|
||||||
|
|
@ -80,9 +79,9 @@ let createWebLog args sp = task {
|
||||||
|
|
||||||
/// Import prior permalinks from a text files with lines in the format "[old] [new]"
|
/// Import prior permalinks from a text files with lines in the format "[old] [new]"
|
||||||
let importPriorPermalinks urlBase file (sp : IServiceProvider) = task {
|
let importPriorPermalinks urlBase file (sp : IServiceProvider) = task {
|
||||||
let conn = sp.GetRequiredService<IConnection> ()
|
let data = sp.GetRequiredService<IData> ()
|
||||||
|
|
||||||
match! Data.WebLog.findByHost urlBase conn with
|
match! data.WebLog.findByHost urlBase with
|
||||||
| Some webLog ->
|
| Some webLog ->
|
||||||
|
|
||||||
let mapping =
|
let mapping =
|
||||||
|
|
@ -93,23 +92,15 @@ let importPriorPermalinks urlBase file (sp : IServiceProvider) = task {
|
||||||
Permalink parts[0], Permalink parts[1])
|
Permalink parts[0], Permalink parts[1])
|
||||||
|
|
||||||
for old, current in mapping do
|
for old, current in mapping do
|
||||||
match! Data.Post.findByPermalink current webLog.id conn with
|
match! data.Post.findByPermalink current webLog.id with
|
||||||
| Some post ->
|
| Some post ->
|
||||||
let! withLinks = rethink<Post> {
|
let! withLinks = data.Post.findFullById post.id post.webLogId
|
||||||
withTable Data.Table.Post
|
let! _ = data.Post.updatePriorPermalinks post.id post.webLogId
|
||||||
get post.id
|
(old :: withLinks.Value.priorPermalinks)
|
||||||
result conn
|
|
||||||
}
|
|
||||||
do! rethink {
|
|
||||||
withTable Data.Table.Post
|
|
||||||
get post.id
|
|
||||||
update [ "priorPermalinks", old :: withLinks.priorPermalinks :> obj]
|
|
||||||
write; ignoreResult conn
|
|
||||||
}
|
|
||||||
printfn $"{Permalink.toString old} -> {Permalink.toString current}"
|
printfn $"{Permalink.toString old} -> {Permalink.toString current}"
|
||||||
| None -> printfn $"Cannot find current post for {Permalink.toString current}"
|
| None -> printfn $"Cannot find current post for {Permalink.toString current}"
|
||||||
printfn "Done!"
|
printfn "Done!"
|
||||||
| None -> printfn $"No web log found at {urlBase}"
|
| None -> eprintfn $"No web log found at {urlBase}"
|
||||||
}
|
}
|
||||||
|
|
||||||
/// Import permalinks if all is well
|
/// Import permalinks if all is well
|
||||||
|
|
@ -127,17 +118,70 @@ let loadTheme (args : string[]) (sp : IServiceProvider) = task {
|
||||||
| -1 -> args[1]
|
| -1 -> args[1]
|
||||||
| it -> args[1][(it + 1)..]
|
| it -> args[1][(it + 1)..]
|
||||||
match Handlers.Admin.getThemeName fileName with
|
match Handlers.Admin.getThemeName fileName with
|
||||||
| Some themeName ->
|
| Ok themeName ->
|
||||||
let conn = sp.GetRequiredService<IConnection> ()
|
let data = sp.GetRequiredService<IData> ()
|
||||||
let clean = if args.Length > 2 then bool.Parse args[2] else true
|
let clean = if args.Length > 2 then bool.Parse args[2] else true
|
||||||
use stream = File.Open (args[1], FileMode.Open)
|
use stream = File.Open (args[1], FileMode.Open)
|
||||||
use copy = new MemoryStream ()
|
use copy = new MemoryStream ()
|
||||||
do! stream.CopyToAsync copy
|
do! stream.CopyToAsync copy
|
||||||
do! Handlers.Admin.loadThemeFromZip themeName copy clean conn
|
do! Handlers.Admin.loadThemeFromZip themeName copy clean data
|
||||||
printfn $"Theme {themeName} loaded successfully"
|
printfn $"Theme {themeName} loaded successfully"
|
||||||
| None ->
|
| Error message -> eprintfn $"{message}"
|
||||||
printfn $"Theme file name {args[1]} is invalid"
|
|
||||||
else
|
else
|
||||||
printfn "Usage: MyWebLog load-theme [theme-zip-file-name] [*clean-load]"
|
printfn "Usage: MyWebLog load-theme [theme-zip-file-name] [*clean-load]"
|
||||||
printfn " * optional, defaults to true"
|
printfn " * optional, defaults to true"
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/// Back up a web log's data
|
||||||
|
module Backup =
|
||||||
|
|
||||||
|
/// A theme asset, with the data base-64 encoded
|
||||||
|
type EncodedAsset =
|
||||||
|
{ /// The ID of the theme asset
|
||||||
|
id : ThemeAssetId
|
||||||
|
|
||||||
|
/// The updated date for this asset
|
||||||
|
updatedOn : DateTime
|
||||||
|
|
||||||
|
/// The data for this asset, base-64 encoded
|
||||||
|
data : string
|
||||||
|
}
|
||||||
|
|
||||||
|
/// Create an encoded theme asset from the original theme asset
|
||||||
|
static member fromAsset (asset : ThemeAsset) =
|
||||||
|
{ id = asset.id
|
||||||
|
updatedOn = asset.updatedOn
|
||||||
|
data = Convert.ToBase64String asset.data
|
||||||
|
}
|
||||||
|
|
||||||
|
/// A unified archive for a web log
|
||||||
|
type Archive =
|
||||||
|
{ /// The web log to which this archive belongs
|
||||||
|
webLog : WebLog
|
||||||
|
|
||||||
|
/// The users for this web log
|
||||||
|
users : WebLogUser list
|
||||||
|
|
||||||
|
/// The theme used by this web log at the time the archive was made
|
||||||
|
theme : Theme
|
||||||
|
|
||||||
|
/// Assets for the theme used by this web log at the time the archive was made
|
||||||
|
assets : EncodedAsset list
|
||||||
|
|
||||||
|
/// The categories for this web log
|
||||||
|
categories : Category list
|
||||||
|
|
||||||
|
/// The tag mappings for this web log
|
||||||
|
tagMappings : TagMap list
|
||||||
|
|
||||||
|
/// The pages for this web log (containing only the most recent revision)
|
||||||
|
pages : Page list
|
||||||
|
|
||||||
|
/// The posts for this web log (containing only the most recent revision)
|
||||||
|
posts : Post list
|
||||||
|
}
|
||||||
|
|
||||||
|
let inline await f = (Async.AwaitTask >> Async.RunSynchronously) f
|
||||||
|
|
||||||
|
// TODO: finish implementation; paused for LiteDB data capability development, will work with both
|
||||||
|
|
||||||
|
|
@ -23,17 +23,43 @@ type WebLogMiddleware (next : RequestDelegate, log : ILogger<WebLogMiddleware>)
|
||||||
ctx.Response.StatusCode <- 404
|
ctx.Response.StatusCode <- 404
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
open System
|
open System
|
||||||
|
open Microsoft.Extensions.DependencyInjection
|
||||||
|
open MyWebLog.Data
|
||||||
|
|
||||||
|
/// Logic to obtain a data connection and implementation based on configured values
|
||||||
|
module DataImplementation =
|
||||||
|
|
||||||
|
open LiteDB
|
||||||
|
open Microsoft.Extensions.Configuration
|
||||||
|
open MyWebLog.Converters
|
||||||
|
open RethinkDb.Driver.FSharp
|
||||||
|
open RethinkDb.Driver.Net
|
||||||
|
|
||||||
|
/// Get the configured data implementation
|
||||||
|
let get (sp : IServiceProvider) : IData option =
|
||||||
|
let config = sp.GetRequiredService<IConfiguration> ()
|
||||||
|
let isNotNull it = (isNull >> not) it
|
||||||
|
if isNotNull (config.GetSection "RethinkDB") then
|
||||||
|
Json.all () |> Seq.iter Converter.Serializer.Converters.Add
|
||||||
|
let rethinkCfg = DataConfig.FromConfiguration (config.GetSection "RethinkDB")
|
||||||
|
let conn = rethinkCfg.CreateConnectionAsync () |> Async.AwaitTask |> Async.RunSynchronously
|
||||||
|
Some (upcast RethinkDbData (conn, rethinkCfg, sp.GetRequiredService<ILogger<RethinkDbData>> ()))
|
||||||
|
elif isNotNull (config.GetConnectionString "LiteDB") then
|
||||||
|
Bson.registerAll ()
|
||||||
|
let db = new LiteDatabase (config.GetConnectionString "LiteDB")
|
||||||
|
Some (upcast LiteDbData db)
|
||||||
|
else
|
||||||
|
None
|
||||||
|
|
||||||
|
|
||||||
open Giraffe
|
open Giraffe
|
||||||
open Giraffe.EndpointRouting
|
open Giraffe.EndpointRouting
|
||||||
open Microsoft.AspNetCore.Authentication.Cookies
|
open Microsoft.AspNetCore.Authentication.Cookies
|
||||||
open Microsoft.AspNetCore.Builder
|
open Microsoft.AspNetCore.Builder
|
||||||
open Microsoft.AspNetCore.HttpOverrides
|
open Microsoft.AspNetCore.HttpOverrides
|
||||||
open Microsoft.Extensions.Configuration
|
|
||||||
open Microsoft.Extensions.DependencyInjection
|
|
||||||
open RethinkDB.DistributedCache
|
open RethinkDB.DistributedCache
|
||||||
open RethinkDb.Driver.FSharp
|
|
||||||
open RethinkDb.Driver.Net
|
|
||||||
|
|
||||||
[<EntryPoint>]
|
[<EntryPoint>]
|
||||||
let main args =
|
let main args =
|
||||||
|
|
@ -52,25 +78,32 @@ let main args =
|
||||||
let _ = builder.Services.AddAuthorization ()
|
let _ = builder.Services.AddAuthorization ()
|
||||||
let _ = builder.Services.AddAntiforgery ()
|
let _ = builder.Services.AddAntiforgery ()
|
||||||
|
|
||||||
// Configure RethinkDB's connection
|
let sp = builder.Services.BuildServiceProvider ()
|
||||||
JsonConverters.all () |> Seq.iter Converter.Serializer.Converters.Add
|
match DataImplementation.get sp with
|
||||||
let sp = builder.Services.BuildServiceProvider ()
|
| Some data ->
|
||||||
let config = sp.GetRequiredService<IConfiguration> ()
|
|
||||||
let loggerFac = sp.GetRequiredService<ILoggerFactory> ()
|
|
||||||
let rethinkCfg = DataConfig.FromConfiguration (config.GetSection "RethinkDB")
|
|
||||||
let conn =
|
|
||||||
task {
|
task {
|
||||||
let! conn = rethinkCfg.CreateConnectionAsync ()
|
do! data.startUp ()
|
||||||
do! Data.Startup.ensureDb rethinkCfg (loggerFac.CreateLogger (nameof Data.Startup)) conn
|
do! WebLogCache.fill data
|
||||||
do! WebLogCache.fill conn
|
do! ThemeAssetCache.fill data
|
||||||
do! ThemeAssetCache.fill conn
|
|
||||||
return conn
|
|
||||||
} |> Async.AwaitTask |> Async.RunSynchronously
|
} |> Async.AwaitTask |> Async.RunSynchronously
|
||||||
let _ = builder.Services.AddSingleton<IConnection> conn
|
builder.Services.AddSingleton<IData> data |> ignore
|
||||||
|
|
||||||
|
// 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 ->
|
let _ = builder.Services.AddSession(fun opts ->
|
||||||
opts.IdleTimeout <- TimeSpan.FromMinutes 60
|
opts.IdleTimeout <- TimeSpan.FromMinutes 60
|
||||||
opts.Cookie.HttpOnly <- true
|
opts.Cookie.HttpOnly <- true
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user