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