Move OpenGraph property generation to models (#52)

- Add auto-OpenGraph field to web log
- Only generate properties for posts/pages without them if this flag is set
- Set flag to yes on v3 database migration
- Add JSON converter for OpenGraph type
- Add tests for models
This commit is contained in:
Daniel J. Summers 2025-07-10 23:03:16 -04:00
parent 210dd41cee
commit 3ad6b5a521
17 changed files with 799 additions and 293 deletions

View File

@ -65,6 +65,14 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: MarkupText, _: bool, _: JsonSerializer) =
(string >> MarkupText.Parse) reader.Value
/// <summary>Converter for the <see cref="OpenGraphType" /> type</summary>
type OpenGraphTypeConverter() =
inherit JsonConverter<OpenGraphType>()
override _.WriteJson(writer: JsonWriter, value: OpenGraphType, _: JsonSerializer) =
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: OpenGraphType, _: bool, _: JsonSerializer) =
(string >> OpenGraphType.Parse) reader.Value
/// <summary>Converter for the <see cref="Permalink" /> type</summary>
type PermalinkConverter() =
inherit JsonConverter<Permalink>()
@ -159,6 +167,7 @@ module Json =
CustomFeedSourceConverter()
ExplicitRatingConverter()
MarkupTextConverter()
OpenGraphTypeConverter()
PermalinkConverter()
PageIdConverter()
PodcastMediumConverter()

View File

@ -10,17 +10,17 @@ open Npgsql.FSharp
/// Data implementation for PostgreSQL
type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
/// Create any needed tables
let ensureTables () = backgroundTask {
// Set up the PostgreSQL document store
Configuration.useSerializer (Utils.createDocumentSerializer ser)
let! tables =
Custom.list
"SELECT tablename FROM pg_tables WHERE schemaname = 'public'" [] (fun row -> row.string "tablename")
let needsTable table = not (List.contains table tables)
let sql = seq {
// Theme tables
if needsTable Table.Theme then
@ -33,25 +33,25 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
updated_on TIMESTAMPTZ NOT NULL,
data BYTEA NOT NULL,
PRIMARY KEY (theme_id, path))"
// Web log table
if needsTable Table.WebLog then
Query.Definition.ensureTable Table.WebLog
Query.Definition.ensureKey Table.WebLog PostgreSQL
Query.Definition.ensureDocumentIndex Table.WebLog Optimized
// Category table
if needsTable Table.Category then
Query.Definition.ensureTable Table.Category
Query.Definition.ensureKey Table.Category PostgreSQL
Query.Definition.ensureDocumentIndex Table.Category Optimized
// Web log user table
if needsTable Table.WebLogUser then
Query.Definition.ensureTable Table.WebLogUser
Query.Definition.ensureKey Table.WebLogUser PostgreSQL
Query.Definition.ensureDocumentIndex Table.WebLogUser Optimized
// Page tables
if needsTable Table.Page then
Query.Definition.ensureTable Table.Page
@ -65,7 +65,7 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
as_of TIMESTAMPTZ NOT NULL,
revision_text TEXT NOT NULL,
PRIMARY KEY (page_id, as_of))"
// Post tables
if needsTable Table.Post then
Query.Definition.ensureTable Table.Post
@ -90,13 +90,13 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
Query.Definition.ensureTable Table.PostComment
Query.Definition.ensureKey Table.PostComment PostgreSQL
Query.Definition.ensureIndexOn Table.PostComment "post" [ nameof Comment.Empty.PostId ] PostgreSQL
// Tag map table
if needsTable Table.TagMap then
Query.Definition.ensureTable Table.TagMap
Query.Definition.ensureKey Table.TagMap PostgreSQL
Query.Definition.ensureDocumentIndex Table.TagMap Optimized
// Uploaded file table
if needsTable Table.Upload then
$"CREATE TABLE {Table.Upload} (
@ -107,13 +107,13 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
data BYTEA NOT NULL)"
$"CREATE INDEX idx_upload_web_log ON {Table.Upload} (web_log_id)"
$"CREATE INDEX idx_upload_path ON {Table.Upload} (web_log_id, path)"
// Database version table
if needsTable Table.DbVersion then
$"CREATE TABLE {Table.DbVersion} (id TEXT NOT NULL PRIMARY KEY)"
$"INSERT INTO {Table.DbVersion} VALUES ('{Utils.Migration.currentDbVersion}')"
}
Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync
@ -128,13 +128,13 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
|> Async.RunSynchronously
|> ignore
}
/// Set a specific database version
let setDbVersion version = backgroundTask {
do! Custom.nonQuery $"DELETE FROM db_version; INSERT INTO db_version VALUES ('%s{version}')" []
return version
}
/// Migrate from v2-rc2 to v2 (manual migration required)
let migrateV2Rc2ToV2 () = backgroundTask {
let! webLogs =
@ -152,11 +152,11 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
let tables =
[ Table.Category; Table.Page; Table.Post; Table.PostComment; Table.TagMap; Table.Theme; Table.WebLog
Table.WebLogUser ]
Utils.Migration.logStep log migration "Adding unique indexes on ID fields"
do! Custom.nonQuery
(tables |> List.map (fun it -> Query.Definition.ensureKey it PostgreSQL) |> String.concat "; ") []
Utils.Migration.logStep log migration "Removing constraints"
let fkToDrop =
[ "page_revision", "page_revision_page_id_fkey"
@ -176,17 +176,17 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
|> List.map (fun (tbl, fk) -> $"ALTER TABLE {tbl} DROP CONSTRAINT {fk}")
|> String.concat "; ")
[]
Utils.Migration.logStep log migration "Dropping old indexes"
let toDrop =
[ "idx_category"; "page_author_idx"; "page_permalink_idx"; "page_web_log_idx"; "post_author_idx"
"post_category_idx"; "post_permalink_idx"; "post_status_idx"; "post_tag_idx"; "post_web_log_idx"
"post_comment_post_idx"; "idx_tag_map"; "idx_web_log"; "idx_web_log_user" ]
do! Custom.nonQuery (toDrop |> List.map (sprintf "DROP INDEX %s") |> String.concat "; ") []
Utils.Migration.logStep log migration "Dropping old ID columns"
do! Custom.nonQuery (tables |> List.map (sprintf "ALTER TABLE %s DROP COLUMN id") |> String.concat "; ") []
Utils.Migration.logStep log migration "Adding new indexes"
let newIdx =
[ yield! tables |> List.map (fun it -> Query.Definition.ensureKey it PostgreSQL)
@ -209,7 +209,7 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
$"CREATE INDEX idx_post_tag ON {Table.Post} USING GIN ((data['{nameof Post.Empty.Tags}']))"
Query.Definition.ensureIndexOn Table.PostComment "post" [ nameof Comment.Empty.PostId ] PostgreSQL ]
do! Custom.nonQuery (newIdx |> String.concat "; ") []
Utils.Migration.logStep log migration "Setting database to version 2.1.1"
return! setDbVersion "v2.1.1"
}
@ -224,33 +224,45 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
return! setDbVersion "v2.2"
}
/// Migrate from v2.2 to v3
let migrateV2point2ToV3 () = backgroundTask {
Utils.Migration.logStep log "v2.2 to v3" "Adding auto-OpenGraph flag to all web logs"
do! Patch.byFields Table.WebLog Any [ Field.Exists (nameof WebLog.Empty.Id) ] {| AutoOpenGraph = true |}
Utils.Migration.logStep log "v2.2 to v3" "Setting database version to v3"
return! setDbVersion "v3"
}
/// Do required data migration between versions
let migrate version = backgroundTask {
let mutable v = defaultArg version ""
if v = "v2-rc2" then
if v = "v2-rc2" then
let! webLogs =
Custom.list
$"SELECT url_base, slug FROM {Table.WebLog}" []
(fun row -> row.string "url_base", row.string "slug")
Utils.Migration.backupAndRestoreRequired log "v2-rc2" "v2" webLogs
if v = "v2" then
let! ver = migrateV2ToV2point1point1 ()
v <- ver
if v = "v2.1.1" then
let! ver = migrateV2point1point1ToV2point2 ()
v <- ver
if v = "v2.2" then
let! ver = migrateV2point2ToV3 ()
v <- ver
if v <> Utils.Migration.currentDbVersion then
log.LogWarning $"Unknown database version; assuming {Utils.Migration.currentDbVersion}"
let! _ = setDbVersion Utils.Migration.currentDbVersion
()
}
interface IData with
member _.Category = PostgresCategoryData log
member _.Page = PostgresPageData log
member _.Post = PostgresPostData log
@ -260,13 +272,13 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
member _.Upload = PostgresUploadData log
member _.WebLog = PostgresWebLogData log
member _.WebLogUser = PostgresWebLogUserData log
member _.Serializer = ser
member _.StartUp () = backgroundTask {
log.LogTrace "PostgresData.StartUp"
do! ensureTables ()
let! version = Custom.single "SELECT id FROM db_version" [] (fun row -> row.string "id")
do! migrate version
}

View File

@ -6,38 +6,38 @@ open RethinkDb.Driver
/// Functions to assist with retrieving data
module private RethinkHelpers =
/// Table names
[<RequireQualifiedAccess>]
module Table =
/// The category table
let Category = "Category"
/// The comment table
let Comment = "Comment"
/// The database version table
let DbVersion = "DbVersion"
/// 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 uploaded file table
let Upload = "Upload"
/// The web log table
let WebLog = "WebLog"
@ -47,24 +47,24 @@ module private RethinkHelpers =
/// A list of all tables
let all = [ Category; Comment; DbVersion; Page; Post; TagMap; Theme; ThemeAsset; Upload; WebLog; WebLogUser ]
/// Index names for indexes not on a data item's name
[<RequireQualifiedAccess>]
module Index =
/// An index by web log ID and e-mail address
let LogOn = "LogOn"
/// An index by web log ID and uploaded file path
let WebLogAndPath = "WebLogAndPath"
/// An index by web log ID and mapped tag
let WebLogAndTag = "WebLogAndTag"
/// An index by web log ID and tag URL value
let WebLogAndUrl = "WebLogAndUrl"
/// Shorthand for the ReQL starting point
let r = RethinkDB.R
@ -73,14 +73,14 @@ module private RethinkHelpers =
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)
@ -93,16 +93,16 @@ open RethinkHelpers
/// 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}/"
fun (row: Ast.ReqlExpr) -> row[nameof ThemeAsset.Empty.Id].Match keyPrefix :> obj
/// Function to exclude template text from themes
let withoutTemplateText (row: Ast.ReqlExpr) : obj =
{| Templates = row[nameof Theme.Empty.Templates].Merge(r.HashMap(nameof ThemeTemplate.Empty.Text, "")) |}
/// 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 }
@ -180,13 +180,13 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
}
do! rethink { withTable table; indexWait; result; withRetryDefault; ignoreResult conn }
}
/// The batch size for restoration methods
let restoreBatchSize = 100
/// A value to use when files need to be retrieved without their data
let emptyFile = r.Binary(Array.Empty<byte>())
/// Delete assets for the given theme ID
let deleteAssetsByTheme themeId = rethink {
withTable Table.ThemeAsset
@ -194,7 +194,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
delete
write; withRetryDefault; ignoreResult conn
}
/// Set a specific database version
let setDbVersion (version: string) = backgroundTask {
do! rethink {
@ -208,7 +208,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
write; withRetryOnce; ignoreResult conn
}
}
/// Migrate from v2-rc1 to v2-rc2
let migrateV2Rc1ToV2Rc2 () = backgroundTask {
let logStep = Utils.Migration.logStep log "v2-rc1 to v2-rc2"
@ -233,11 +233,11 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
update [ nameof WebLog.Empty.RedirectRules, [] :> obj ]
write; withRetryOnce; ignoreResult conn
}
Utils.Migration.logStep log "v2 to v2.1" "Setting database version to v2.1"
do! setDbVersion "v2.1"
}
/// Migrate from v2.1 to v2.1.1
let migrateV2point1ToV2point1point1 () = backgroundTask {
Utils.Migration.logStep log "v2.1 to v2.1.1" "Setting database version; no migration required"
@ -256,10 +256,22 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
do! setDbVersion "v2.2"
}
/// Migrate from v2.2 to v3
let migrateV2point2ToV3 () = backgroundTask {
Utils.Migration.logStep log "v2.2 to v3" "Adding auto-OpenGraph flag to all web logs"
do! rethink {
withTable Table.WebLog
update [ nameof WebLog.Empty.AutoOpenGraph, true :> obj ]
write; withRetryOnce; ignoreResult conn
}
Utils.Migration.logStep log "v2.2 to v3" "Setting database version to v3"
do! setDbVersion "v3"
}
/// Migrate data between versions
let migrate version = backgroundTask {
let mutable v = defaultArg version ""
if v = "v2-rc1" then
do! migrateV2Rc1ToV2Rc2 ()
v <- "v2-rc2"
@ -267,38 +279,42 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
if v = "v2-rc2" then
do! migrateV2Rc2ToV2 ()
v <- "v2"
if v = "v2" then
do! migrateV2ToV2point1 ()
v <- "v2.1"
if v = "v2.1" then
do! migrateV2point1ToV2point1point1 ()
v <- "v2.1.1"
if v = "v2.1.1" then
do! migrateV2point1point1ToV2point2 ()
v <- "v2.2"
if v = "v2.2" then
do! migrateV2point2ToV3 ()
v <- "v3"
if v <> Utils.Migration.currentDbVersion then
log.LogWarning $"Unknown database version; assuming {Utils.Migration.currentDbVersion}"
do! setDbVersion Utils.Migration.currentDbVersion
}
/// 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 Category.Empty.WebLogId)
@ -313,7 +329,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
count
result; withRetryDefault conn
}
member _.FindAllForView webLogId = backgroundTask {
let! cats = rethink<Category list> {
withTable Table.Category
@ -353,7 +369,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
|> Option.defaultValue 0 })
|> Array.ofSeq
}
member _.FindById catId webLogId =
rethink<Category> {
withTable Table.Category
@ -361,13 +377,13 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId _.WebLogId <| conn
member _.FindByWebLog webLogId = rethink<Category list> {
withTable Table.Category
getAll [ webLogId ] (nameof Category.Empty.WebLogId)
result; withRetryDefault conn
}
member this.Delete catId webLogId = backgroundTask {
match! this.FindById catId webLogId with
| Some cat ->
@ -394,7 +410,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
{| CategoryIds =
row[nameof Post.Empty.CategoryIds].CoerceTo("array")
.SetDifference(r.Array(catId)) |} :> obj)
write; withRetryDefault; ignoreResult conn
write; withRetryDefault; ignoreResult conn
}
// Delete the category itself
do! rethink {
@ -406,7 +422,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
return if children = 0 then CategoryDeleted else ReassignedChildCategories
| None -> return CategoryNotFound
}
member _.Restore cats = backgroundTask {
for batch in cats |> List.chunkBySize restoreBatchSize do
do! rethink {
@ -415,7 +431,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
write; withRetryOnce; ignoreResult conn
}
}
member _.Update cat = rethink {
withTable Table.Category
get cat.Id
@ -427,10 +443,10 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
write; withRetryDefault; ignoreResult conn
}
}
member _.Page = {
new IPageData with
member _.Add page = rethink {
withTable Table.Page
insert page
@ -447,7 +463,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
orderByFunc (fun row -> row[nameof Page.Empty.Title].Downcase() :> obj)
result; withRetryDefault conn
}
member _.CountAll webLogId = rethink<int> {
withTable Table.Page
getAll [ webLogId ] (nameof Page.Empty.WebLogId)
@ -473,7 +489,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
}
return result.Deleted > 0UL
}
member _.FindById pageId webLogId =
rethink<Page list> {
withTable Table.Page
@ -495,7 +511,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
result; withRetryDefault
}
|> tryFirst <| conn
member _.FindCurrentPermalink permalinks webLogId = backgroundTask {
let! result =
(rethink<Page list> {
@ -509,7 +525,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
|> tryFirst) conn
return result |> Option.map _.Permalink
}
member _.FindFullById pageId webLogId =
rethink<Page> {
withTable Table.Page
@ -517,13 +533,13 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId _.WebLogId <| conn
member _.FindFullByWebLog webLogId = rethink<Page> {
withTable Table.Page
getAll [ webLogId ] (nameof Page.Empty.WebLogId)
resultCursor; withRetryCursorDefault; toList conn
}
member _.FindListed webLogId = rethink<Page list> {
withTable Table.Page
getAll [ webLogId ] (nameof Page.Empty.WebLogId)
@ -546,7 +562,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
limit 25
result; withRetryDefault conn
}
member _.Restore pages = backgroundTask {
for batch in pages |> List.chunkBySize restoreBatchSize do
do! rethink {
@ -555,7 +571,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
write; withRetryOnce; ignoreResult conn
}
}
member _.Update page = rethink {
withTable Table.Page
get page.Id
@ -572,7 +588,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
]
write; withRetryDefault; ignoreResult conn
}
member this.UpdatePriorPermalinks pageId webLogId permalinks = backgroundTask {
match! this.FindById pageId webLogId with
| Some _ ->
@ -586,16 +602,16 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
| 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 Post.Empty.WebLogId)
@ -614,7 +630,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
}
return result.Deleted > 0UL
}
member _.FindById postId webLogId =
rethink<Post list> {
withTable Table.Post
@ -625,7 +641,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
result; withRetryDefault
}
|> tryFirst <| conn
member _.FindByPermalink permalink webLogId =
rethink<Post list> {
withTable Table.Post
@ -636,7 +652,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
result; withRetryDefault
}
|> tryFirst <| conn
member _.FindFullById postId webLogId =
rethink<Post> {
withTable Table.Post
@ -658,13 +674,13 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
|> tryFirst) conn
return result |> Option.map _.Permalink
}
member _.FindFullByWebLog webLogId = rethink<Post> {
withTable Table.Post
getAll [ webLogId ] (nameof Post.Empty.WebLogId)
resultCursor; withRetryCursorDefault; toList conn
}
member _.FindPageOfCategorizedPosts webLogId categoryIds pageNbr postsPerPage = rethink<Post list> {
withTable Table.Post
getAll (objList categoryIds) (nameof Post.Empty.CategoryIds)
@ -678,7 +694,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
limit (postsPerPage + 1)
result; withRetryDefault conn
}
member _.FindPageOfPosts webLogId pageNbr postsPerPage = rethink<Post list> {
withTable Table.Post
getAll [ webLogId ] (nameof Post.Empty.WebLogId)
@ -703,7 +719,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
limit (postsPerPage + 1)
result; withRetryDefault conn
}
member _.FindPageOfTaggedPosts webLogId tag pageNbr postsPerPage = rethink<Post list> {
withTable Table.Post
getAll [ tag ] (nameof Post.Empty.Tags)
@ -716,7 +732,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
limit (postsPerPage + 1)
result; withRetryDefault conn
}
member _.FindSurroundingPosts webLogId publishedOn = backgroundTask {
let! older =
rethink<Post list> {
@ -744,7 +760,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
|> tryFirst <| conn
return older, newer
}
member _.Restore pages = backgroundTask {
for batch in pages |> List.chunkBySize restoreBatchSize do
do! rethink {
@ -753,7 +769,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
write; withRetryOnce; ignoreResult conn
}
}
member this.Update post = backgroundTask {
match! this.FindById post.Id post.WebLogId with
| Some _ ->
@ -779,10 +795,10 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
| None -> return false
}
}
member _.TagMap = {
new ITagMapData with
member _.Delete tagMapId webLogId = backgroundTask {
let! result = rethink<Model.Result> {
withTable Table.TagMap
@ -793,7 +809,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
}
return result.Deleted > 0UL
}
member _.FindById tagMapId webLogId =
rethink<TagMap> {
withTable Table.TagMap
@ -801,7 +817,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId _.WebLogId <| conn
member _.FindByUrlValue urlValue webLogId =
rethink<TagMap list> {
withTable Table.TagMap
@ -810,7 +826,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
result; withRetryDefault
}
|> tryFirst <| conn
member _.FindByWebLog webLogId = rethink<TagMap list> {
withTable Table.TagMap
between [| webLogId :> obj; r.Minval() |] [| webLogId :> obj; r.Maxval() |]
@ -818,13 +834,13 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
orderBy (nameof TagMap.Empty.Tag)
result; withRetryDefault conn
}
member _.FindMappingForTags tags webLogId = rethink<TagMap list> {
withTable Table.TagMap
getAll (tags |> List.map (fun tag -> [| webLogId :> obj; tag |] :> obj)) Index.WebLogAndTag
result; withRetryDefault conn
}
member _.Restore tagMaps = backgroundTask {
for batch in tagMaps |> List.chunkBySize restoreBatchSize do
do! rethink {
@ -833,7 +849,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
write; withRetryOnce; ignoreResult conn
}
}
member _.Save tagMap = rethink {
withTable Table.TagMap
get tagMap.Id
@ -841,10 +857,10 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
write; withRetryDefault; ignoreResult conn
}
}
member _.Theme = {
new IThemeData with
member _.All () = rethink<Theme list> {
withTable Table.Theme
filter (fun row -> row[nameof Theme.Empty.Id].Ne "admin" :> obj)
@ -852,7 +868,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
orderBy (nameof Theme.Empty.Id)
result; withRetryDefault conn
}
member _.Exists themeId = backgroundTask {
let! count = rethink<int> {
withTable Table.Theme
@ -862,13 +878,13 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
}
return count > 0
}
member _.FindById themeId = rethink<Theme> {
withTable Table.Theme
get themeId
resultOption; withRetryOptionDefault conn
}
member _.FindByIdWithoutText themeId =
rethink<Theme list> {
withTable Table.Theme
@ -877,7 +893,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
result; withRetryDefault
}
|> tryFirst <| conn
member this.Delete themeId = backgroundTask {
match! this.FindByIdWithoutText themeId with
| Some _ ->
@ -891,7 +907,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
return true
| None -> return false
}
member _.Save theme = rethink {
withTable Table.Theme
get theme.Id
@ -899,37 +915,37 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
write; withRetryDefault; ignoreResult conn
}
}
member _.ThemeAsset = {
new IThemeAssetData with
member _.All () = rethink<ThemeAsset list> {
withTable Table.ThemeAsset
merge (r.HashMap(nameof ThemeAsset.Empty.Data, emptyFile))
result; withRetryDefault conn
}
member _.DeleteByTheme themeId = deleteAssetsByTheme themeId
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)
merge (r.HashMap(nameof ThemeAsset.Empty.Data, emptyFile))
result; withRetryDefault conn
}
member _.FindByThemeWithData themeId = rethink<ThemeAsset> {
withTable Table.ThemeAsset
filter (matchAssetByThemeId themeId)
resultCursor; withRetryCursorDefault; toList conn
}
member _.Save asset = rethink {
withTable Table.ThemeAsset
get asset.Id
@ -937,16 +953,16 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
write; withRetryDefault; ignoreResult conn
}
}
member _.Upload = {
new IUploadData with
member _.Add upload = rethink {
withTable Table.Upload
insert upload
write; withRetryDefault; ignoreResult conn
}
member _.Delete uploadId webLogId = backgroundTask {
let! upload =
rethink<Upload> {
@ -966,7 +982,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
return Ok (string up.Path)
| None -> return Result.Error $"Upload ID {uploadId} not found"
}
member _.FindByPath path webLogId =
rethink<Upload> {
withTable Table.Upload
@ -974,7 +990,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
resultCursor; withRetryCursorDefault; toList
}
|> tryFirst <| conn
member _.FindByWebLog webLogId = rethink<Upload> {
withTable Table.Upload
between [| webLogId :> obj; r.Minval() |] [| webLogId :> obj; r.Maxval() |]
@ -982,14 +998,14 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
merge (r.HashMap(nameof Upload.Empty.Data, emptyFile))
resultCursor; withRetryCursorDefault; toList conn
}
member _.FindByWebLogWithData webLogId = rethink<Upload> {
withTable Table.Upload
between [| webLogId :> obj; r.Minval() |] [| webLogId :> obj; r.Maxval() |]
[ Index Index.WebLogAndPath ]
resultCursor; withRetryCursorDefault; toList conn
}
member _.Restore uploads = backgroundTask {
// Files can be large; we'll do 5 at a time
for batch in uploads |> List.chunkBySize 5 do
@ -1000,21 +1016,21 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
}
}
}
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 _.Delete webLogId = backgroundTask {
// Comments should be deleted by post IDs
let! thePostIds = rethink<{| Id: string |} list> {
@ -1061,7 +1077,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
write; withRetryOnce; ignoreResult conn
}
}
member _.FindByHost url =
rethink<WebLog list> {
withTable Table.WebLog
@ -1076,21 +1092,21 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
get webLogId
resultOption; withRetryOptionDefault conn
}
member _.UpdateRedirectRules webLog = rethink {
withTable Table.WebLog
get webLog.Id
update [ nameof WebLog.Empty.RedirectRules, webLog.RedirectRules :> obj ]
write; withRetryDefault; ignoreResult conn
}
member _.UpdateRssOptions webLog = rethink {
withTable Table.WebLog
get webLog.Id
update [ nameof WebLog.Empty.Rss, webLog.Rss :> obj ]
write; withRetryDefault; ignoreResult conn
}
member _.UpdateSettings webLog = rethink {
withTable Table.WebLog
get webLog.Id
@ -1108,16 +1124,16 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
write; withRetryDefault; ignoreResult conn
}
}
member _.WebLogUser = {
new IWebLogUserData with
member _.Add user = rethink {
withTable Table.WebLogUser
insert user
write; withRetryDefault; ignoreResult conn
}
member _.FindById userId webLogId =
rethink<WebLogUser> {
withTable Table.WebLogUser
@ -1125,7 +1141,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
resultOption; withRetryOptionDefault
}
|> verifyWebLog webLogId _.WebLogId <| conn
member this.Delete userId webLogId = backgroundTask {
match! this.FindById userId webLogId with
| Some _ ->
@ -1155,7 +1171,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
return Ok true
| None -> return Result.Error "User does not exist"
}
member _.FindByEmail email webLogId =
rethink<WebLogUser list> {
withTable Table.WebLogUser
@ -1164,14 +1180,14 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
result; withRetryDefault
}
|> tryFirst <| conn
member _.FindByWebLog webLogId = rethink<WebLogUser list> {
withTable Table.WebLogUser
getAll [ webLogId ] (nameof WebLogUser.Empty.WebLogId)
orderByFunc (fun row -> row[nameof WebLogUser.Empty.PreferredName].Downcase())
result; withRetryDefault conn
}
member _.FindNames webLogId userIds = backgroundTask {
let! users = rethink<WebLogUser list> {
withTable Table.WebLogUser
@ -1181,7 +1197,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
}
return users |> List.map (fun u -> { Name = string u.Id; Value = u.DisplayName })
}
member _.Restore users = backgroundTask {
for batch in users |> List.chunkBySize restoreBatchSize do
do! rethink {
@ -1190,7 +1206,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
write; withRetryOnce; ignoreResult conn
}
}
member this.SetLastSeen userId webLogId = backgroundTask {
match! this.FindById userId webLogId with
| Some _ ->
@ -1202,7 +1218,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
}
| None -> ()
}
member _.Update user = rethink {
withTable Table.WebLogUser
get user.Id
@ -1218,30 +1234,37 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
write; withRetryDefault; ignoreResult conn
}
}
member _.Serializer =
Net.Converter.Serializer
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 [ PrimaryKey "Id" ]; write; withRetryOnce; ignoreResult conn }
if not (List.contains Table.DbVersion tables) then
// Version table added in v2-rc2; this will flag that migration to be run
if List.isEmpty tables then
// New install; set version to current version
do! rethink {
withTable Table.DbVersion
insert {| Id = Utils.Migration.currentDbVersion |}
write; withRetryOnce; ignoreResult conn
}
elif not (List.contains Table.DbVersion tables) then
// Other tables, but not version, added in v2-rc2; this will flag that migration to be run
do! rethink {
withTable Table.DbVersion
insert {| Id = "v2-rc1" |}
write; withRetryOnce; ignoreResult conn
}
do! ensureIndexes Table.Category [ nameof Category.Empty.WebLogId ]
do! ensureIndexes Table.Comment [ nameof Comment.Empty.PostId ]
do! ensureIndexes Table.Page [ nameof Page.Empty.WebLogId; nameof Page.Empty.AuthorId ]
@ -1250,7 +1273,7 @@ type RethinkDbData(conn: Net.IConnection, config: DataConfig, log: ILogger<Rethi
do! ensureIndexes Table.Upload []
do! ensureIndexes Table.WebLog [ nameof WebLog.Empty.UrlBase ]
do! ensureIndexes Table.WebLogUser [ nameof WebLogUser.Empty.WebLogId ]
let! version = rethink<{| Id: string |} list> {
withTable Table.DbVersion
limit 1

View File

@ -12,24 +12,24 @@ open NodaTime
/// SQLite myWebLog data implementation
type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSerializer) =
/// Create tables (and their associated indexes) if they do not exist
let ensureTables () = backgroundTask {
Configuration.useSerializer (Utils.createDocumentSerializer ser)
let! tables = conn.customList "SELECT name FROM sqlite_master WHERE type = 'table'" [] _.GetString(0)
let needsTable table =
not (List.contains table tables)
let creatingTable = "Creating {Table} table..."
// Theme tables
if needsTable Table.Theme then
log.LogInformation(creatingTable, Table.Theme)
do! conn.ensureTable Table.Theme
if needsTable Table.ThemeAsset then
log.LogInformation(creatingTable, Table.ThemeAsset)
do! conn.customNonQuery
@ -39,32 +39,32 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
updated_on TEXT NOT NULL,
data BLOB NOT NULL,
PRIMARY KEY (theme_id, path))" []
// Web log table
if needsTable Table.WebLog then
log.LogInformation(creatingTable, Table.WebLog)
do! conn.ensureTable Table.WebLog
// Category table
if needsTable Table.Category then
log.LogInformation(creatingTable, Table.Category)
do! conn.ensureTable Table.Category
do! conn.ensureFieldIndex Table.Category "web_log" [ nameof Category.Empty.WebLogId ]
// Web log user table
if needsTable Table.WebLogUser then
log.LogInformation(creatingTable, Table.WebLogUser)
do! conn.ensureTable Table.WebLogUser
do! conn.ensureFieldIndex
Table.WebLogUser "email" [ nameof WebLogUser.Empty.WebLogId; nameof WebLogUser.Empty.Email ]
// Page tables
if needsTable Table.Page then
log.LogInformation(creatingTable, Table.Page)
do! conn.ensureTable Table.Page
do! conn.ensureFieldIndex Table.Page "author" [ nameof Page.Empty.AuthorId ]
do! conn.ensureFieldIndex Table.Page "permalink" [ nameof Page.Empty.WebLogId; nameof Page.Empty.Permalink ]
if needsTable Table.PageRevision then
log.LogInformation(creatingTable, Table.PageRevision)
do! conn.customNonQuery
@ -73,7 +73,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
as_of TEXT NOT NULL,
revision_text TEXT NOT NULL,
PRIMARY KEY (page_id, as_of))" []
// Post tables
if needsTable Table.Post then
log.LogInformation(creatingTable, Table.Post)
@ -85,7 +85,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
"status"
[ nameof Post.Empty.WebLogId; nameof Post.Empty.Status; nameof Post.Empty.UpdatedOn ]
// TODO: index categories by post?
if needsTable Table.PostRevision then
log.LogInformation(creatingTable, Table.PostRevision)
do! conn.customNonQuery
@ -94,18 +94,18 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
as_of TEXT NOT NULL,
revision_text TEXT NOT NULL,
PRIMARY KEY (post_id, as_of))" []
if needsTable Table.PostComment then
log.LogInformation(creatingTable, Table.PostComment)
do! conn.ensureTable Table.PostComment
do! conn.ensureFieldIndex Table.PostComment "post" [ nameof Comment.Empty.PostId ]
// Tag map table
if needsTable Table.TagMap then
log.LogInformation(creatingTable, Table.TagMap)
do! conn.ensureTable Table.TagMap
do! conn.ensureFieldIndex Table.TagMap "url" [ nameof TagMap.Empty.WebLogId; nameof TagMap.Empty.UrlValue ]
// Uploaded file table
if needsTable Table.Upload then
log.LogInformation(creatingTable, Table.Upload)
@ -117,7 +117,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
updated_on TEXT NOT NULL,
data BLOB NOT NULL);
CREATE INDEX idx_{Table.Upload}_path ON {Table.Upload} (web_log_id, path)" []
// Database version table
if needsTable Table.DbVersion then
log.LogInformation(creatingTable, Table.DbVersion)
@ -125,11 +125,11 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
$"CREATE TABLE {Table.DbVersion} (id TEXT PRIMARY KEY);
INSERT INTO {Table.DbVersion} VALUES ('{Utils.Migration.currentDbVersion}')" []
}
/// Set the database version to the specified version
let setDbVersion version =
conn.customNonQuery $"DELETE FROM {Table.DbVersion}; INSERT INTO {Table.DbVersion} VALUES ('%s{version}')" []
/// Implement the changes between v2-rc1 and v2-rc2
let migrateV2Rc1ToV2Rc2 () = backgroundTask {
let logStep = Utils.Migration.logStep log "v2-rc1 to v2-rc2"
@ -223,7 +223,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
|> Option.map (Utils.deserialize<Chapter list> ser)
ChapterFile = Map.tryString "chapter_file" epRdr
ChapterType = Map.tryString "chapter_type" epRdr
ChapterWaypoints = None
ChapterWaypoints = None
TranscriptUrl = Map.tryString "transcript_url" epRdr
TranscriptType = Map.tryString "transcript_type" epRdr
TranscriptLang = Map.tryString "transcript_lang" epRdr
@ -241,7 +241,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
cmd.Parameters.AddWithValue("@id", string postId) ] |> ignore
let _ = cmd.ExecuteNonQuery()
cmd.Parameters.Clear())
logStep "Migrating dates/times"
let inst (dt: DateTime) =
DateTime(dt.Ticks, DateTimeKind.Utc)
@ -408,10 +408,10 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
let _ = cmd.ExecuteNonQuery()
())
cmd.Parameters.Clear()
conn.Close()
conn.Open()
logStep "Dropping old tables and columns"
cmd.CommandText <-
"ALTER TABLE web_log_user DROP COLUMN salt;
@ -420,11 +420,11 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
DROP TABLE page_meta;
DROP TABLE web_log_feed_podcast"
do! write cmd
logStep "Setting database version to v2-rc2"
do! setDbVersion "v2-rc2"
}
/// Migrate from v2-rc2 to v2
let migrateV2Rc2ToV2 () = backgroundTask {
Utils.Migration.logStep log "v2-rc2 to v2" "Setting database version; no migration required"
@ -443,7 +443,7 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
Utils.Migration.logStep log "v2.1 to v2.1.1" "Setting database version; no migration required"
do! setDbVersion "v2.1.1"
}
/// Migrate from v2.1.1 to v2.2
let migrateV2point1point1ToV2point2 () = backgroundTask {
Utils.Migration.logStep log "v2.1.1 to v2.2" "Setting e-mail to lowercase"
@ -452,6 +452,14 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
do! setDbVersion "v2.2"
}
/// Migrate from v2.2 to v3
let migrateV2point2ToV3 () = backgroundTask {
Utils.Migration.logStep log "v2.2 to v3" "Adding auto-OpenGraph flag to all web logs"
do! Patch.byFields Table.WebLog Any [ Field.Exists (nameof WebLog.Empty.Id) ] {| AutoOpenGraph = true |}
Utils.Migration.logStep log "v2.2 to v3" "Setting database version to v3"
do! setDbVersion "v3"
}
/// Migrate data among versions (up only)
let migrate version = backgroundTask {
let mutable v = defaultArg version ""
@ -459,33 +467,37 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
if v = "v2-rc1" then
do! migrateV2Rc1ToV2Rc2 ()
v <- "v2-rc2"
if v = "v2-rc2" then
do! migrateV2Rc2ToV2 ()
v <- "v2"
if v = "v2" then
do! migrateV2ToV2point1 ()
v <- "v2.1"
if v = "v2.1" then
do! migrateV2point1ToV2point1point1 ()
v <- "v2.1.1"
if v = "v2.1.1" then
do! migrateV2point1point1ToV2point2 ()
v <- "v2.2"
if v = "v2.2" then
do! migrateV2point2ToV3 ()
v <- "v3"
if v <> Utils.Migration.currentDbVersion then
log.LogWarning $"Unknown database version; assuming {Utils.Migration.currentDbVersion}"
do! setDbVersion Utils.Migration.currentDbVersion
}
/// The connection for this instance
member _.Conn = conn
interface IData with
member _.Category = SQLiteCategoryData (conn, ser, log)
member _.Page = SQLitePageData (conn, log)
member _.Post = SQLitePostData (conn, log)
@ -495,9 +507,9 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
member _.Upload = SQLiteUploadData (conn, log)
member _.WebLog = SQLiteWebLogData (conn, log)
member _.WebLogUser = SQLiteWebLogUserData (conn, log)
member _.Serializer = ser
member _.StartUp () = backgroundTask {
do! ensureTables ()
let! version = conn.customSingle<string> $"SELECT id FROM {Table.DbVersion}" [] _.GetString(0)

View File

@ -79,7 +79,7 @@ module Migration =
open Microsoft.Extensions.Logging
/// <summary>The current database version</summary>
let currentDbVersion = "v2.2"
let currentDbVersion = "v3"
/// <summary>Log a migration step</summary>
/// <param name="log">The logger to which the message should be logged</param>

View File

@ -348,6 +348,9 @@ type WebLog = {
/// <summary>Redirect rules for this weblog</summary>
RedirectRules: RedirectRule list
/// <summary>Whether to automatically apply OpenGraph properties to all pages / posts</summary>
AutoOpenGraph: bool
} with
/// <summary>An empty web log</summary>
@ -364,7 +367,8 @@ type WebLog = {
Rss = RssOptions.Empty
AutoHtmx = false
Uploads = Database
RedirectRules = [] }
RedirectRules = []
AutoOpenGraph = true }
/// <summary>
/// Any extra path where this web log is hosted (blank if web log is hosted at the root of the domain)

View File

@ -19,6 +19,17 @@ module private Helpers =
/// <summary>Pipeline with most extensions enabled</summary>
let markdownPipeline = MarkdownPipelineBuilder().UseSmartyPants().UseAdvancedExtensions().UseColorCode().Build()
/// <summary>Derive a MIME type from the given URL and candidates</summary>
/// <param name="url">The URL from which the MIME type should be derived</param>
/// <param name="candidates">The candidates for the MIME type derivation</param>
/// <returns><c>Some</c> with the type if it was derived, <c>None</c> otherwise</returns>
let deriveMimeType (url: string) (candidates: System.Collections.Generic.IDictionary<string, string>) =
match url.LastIndexOf '.' with
| extIdx when extIdx >= 0 ->
let ext = url[extIdx + 1..]
if candidates.ContainsKey ext then Some candidates[ext] else None
| _ -> None
/// <summary>Functions to support NodaTime manipulation</summary>
module Noda =
@ -401,6 +412,15 @@ type OpenGraphAudio = {
SecureUrl = None
Type = None }
/// <summary>MIME types we can derive from the file extension</summary>
static member private DeriveTypes =
[ "aac", "audio/aac"
"mp3", "audio/mpeg"
"oga", "audio/ogg"
"wav", "audio/wav"
"weba", "audio/webm" ]
|> dict
/// <summary>The <c>meta</c> properties for this image</summary>
member this.Properties = seq {
yield ("og:audio", this.Url)
@ -411,8 +431,9 @@ type OpenGraphAudio = {
match this.Type with
| Some typ -> yield ("og:audio:type", typ)
| None ->
// TODO: derive mime type from extension
()
match deriveMimeType this.Url OpenGraphAudio.DeriveTypes with
| Some it -> yield "og:audio:type", it
| None -> ()
}
@ -447,21 +468,36 @@ type OpenGraphImage = {
Height = None
Alt = None }
/// <summary>MIME types we can derive from the file extension</summary>
static member private DeriveTypes =
[ "bmp", "image/bmp"
"gif", "image/gif"
"ico", "image/vnd.microsoft.icon"
"jpeg", "image/jpeg"
"jpg", "image/jpeg"
"png", "image/png"
"svg", "image/svg+xml"
"tif", "image/tiff"
"tiff", "image/tiff"
"webp", "image/webp" ]
|> dict
/// <summary>The <c>meta</c> properties for this image</summary>
member this.Properties = seq {
yield ("og:image", this.Url)
yield "og:image", this.Url
match this.SecureUrl with
| Some url -> yield ("og:image:secure_url", url)
| None when this.Url.StartsWith "https:" -> yield ("og:image:secure_url", this.Url)
| Some url -> yield "og:image:secure_url", url
| None when this.Url.StartsWith "https:" -> yield "og:image:secure_url", this.Url
| None -> ()
match this.Type with
| Some typ -> yield ("og:image:type", typ)
| Some typ -> yield "og:image:type", typ
| None ->
// TODO: derive mime type based on common image extensions
()
match this.Width with Some width -> yield ("og:image:width", string width) | None -> ()
match this.Height with Some height -> yield ("og:image:height", string height) | None -> ()
match this.Alt with Some alt -> yield ("og:image:alt", alt) | None -> ()
match deriveMimeType this.Url OpenGraphImage.DeriveTypes with
| Some it -> yield "og:image:type", it
| None -> ()
match this.Width with Some width -> yield "og:image:width", string width | None -> ()
match this.Height with Some height -> yield "og:image:height", string height | None -> ()
match this.Alt with Some alt -> yield "og:image:alt", alt | None -> ()
}
@ -492,20 +528,30 @@ type OpenGraphVideo = {
Width = None
Height = None }
/// <summary>MIME types we can derive from the file extension</summary>
static member private DeriveTypes =
[ "avi", "video/x-msvideo"
"mp4", "video/mp4"
"mpeg", "video/mpeg"
"ogv", "video/ogg"
"webm", "video/webm" ]
|> dict
/// <summary>The <c>meta</c> properties for this video</summary>
member this.Properties = seq {
yield ("og:video", this.Url)
yield "og:video", this.Url
match this.SecureUrl with
| Some url -> yield ("og:video:secure_url", url)
| None when this.Url.StartsWith "https:" -> yield ("og:video:secure_url", this.Url)
| Some url -> yield "og:video:secure_url", url
| None when this.Url.StartsWith "https:" -> yield "og:video:secure_url", this.Url
| None -> ()
match this.Type with
| Some typ -> yield ("og:video:type", typ)
| Some typ -> yield "og:video:type", typ
| None ->
// TODO: derive mime type based on common video extensions
()
match this.Width with Some width -> yield ("og:video:width", string width) | None -> ()
match this.Height with Some height -> yield ("og:video:height", string height) | None -> ()
match deriveMimeType this.Url OpenGraphVideo.DeriveTypes with
| Some it -> yield "og:video:type", it
| None -> ()
match this.Width with Some width -> yield "og:video:width", string width | None -> ()
match this.Height with Some height -> yield "og:video:height", string height | None -> ()
}
@ -567,7 +613,6 @@ type OpenGraphType =
/// <summary>Properties for OpenGraph</summary>
[<CLIMutable>]
type OpenGraphProperties = {
/// <summary>The type of object represented</summary>
Type: OpenGraphType
@ -594,7 +639,34 @@ type OpenGraphProperties = {
/// <summary>Free-form items</summary>
Other: MetaItem list option
}
} with
/// <summary>An empty set of OpenGraph properties</summary>
static member Empty =
{ Type = Article
Image = OpenGraphImage.Empty
Audio = None
Description = None
Determiner = None
Locale = None
LocaleAlternate = None
Video = None
Other = None }
/// <summary>The <c>meta</c> properties for this page or post</summary>
member this.Properties = seq {
yield "og:type", string this.Type
yield! this.Image.Properties
match this.Description with Some desc -> yield "og:description", desc | None -> ()
match this.Determiner with Some det -> yield "og:determiner", det | None -> ()
match this.Locale with Some loc -> yield "og:locale", loc | None -> ()
match this.LocaleAlternate with
| Some alt -> yield! alt |> List.map (fun it -> "og:locale:alternate", it)
| None -> ()
match this.Audio with Some audio -> yield! audio.Properties | None -> ()
match this.Video with Some video -> yield! video.Properties | None -> ()
match this.Other with Some oth -> yield! oth |> List.map (fun it -> it.Name, it.Value) | None -> ()
}
/// <summary>A permanent link</summary>

View File

@ -1249,36 +1249,41 @@ type SettingsModel = {
/// <summary>The default location for uploads</summary>
Uploads: string
/// <summary>Whether to automatically apply OpenGraph properties to all pages and posts</summary>
AutoOpenGraph: bool
} with
/// <summary>Create a settings model from a web log</summary>
/// <param name="webLog">The web log from which this model should be created</param>
/// <returns>A populated <c>SettingsModel</c> instance</returns>
static member FromWebLog(webLog: WebLog) =
{ Name = webLog.Name
Slug = webLog.Slug
Subtitle = defaultArg webLog.Subtitle ""
DefaultPage = webLog.DefaultPage
PostsPerPage = webLog.PostsPerPage
TimeZone = webLog.TimeZone
ThemeId = string webLog.ThemeId
AutoHtmx = webLog.AutoHtmx
Uploads = string webLog.Uploads }
{ Name = webLog.Name
Slug = webLog.Slug
Subtitle = defaultArg webLog.Subtitle ""
DefaultPage = webLog.DefaultPage
PostsPerPage = webLog.PostsPerPage
TimeZone = webLog.TimeZone
ThemeId = string webLog.ThemeId
AutoHtmx = webLog.AutoHtmx
Uploads = string webLog.Uploads
AutoOpenGraph = webLog.AutoOpenGraph }
/// <summary>Update a web log with settings from the form</summary>
/// <param name="webLog">The web log to be updated</param>
/// <returns>The web log, updated with the value from this model</returns>
member this.Update(webLog: WebLog) =
{ webLog with
Name = this.Name
Slug = this.Slug
Subtitle = if this.Subtitle = "" then None else Some this.Subtitle
DefaultPage = this.DefaultPage
PostsPerPage = this.PostsPerPage
TimeZone = this.TimeZone
ThemeId = ThemeId this.ThemeId
AutoHtmx = this.AutoHtmx
Uploads = UploadDestination.Parse this.Uploads }
Name = this.Name
Slug = this.Slug
Subtitle = if this.Subtitle = "" then None else Some this.Subtitle
DefaultPage = this.DefaultPage
PostsPerPage = this.PostsPerPage
TimeZone = this.TimeZone
ThemeId = ThemeId this.ThemeId
AutoHtmx = this.AutoHtmx
Uploads = UploadDestination.Parse this.Uploads
AutoOpenGraph = this.AutoOpenGraph }
/// <summary>View model for uploading a file</summary>

View File

@ -90,7 +90,7 @@ let explicitRatingConverterTests = testList "ExplicitRatingConverter" [
}
]
/// Unit tests for the MarkupText type
/// Unit tests for the MarkupTextConverter type
let markupTextConverterTests = testList "MarkupTextConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(MarkupTextConverter())
@ -104,6 +104,20 @@ let markupTextConverterTests = testList "MarkupTextConverter" [
}
]
/// Unit tests for the OpenGraphTypeConverter type
let openGraphTypeConverterTests = testList "OpenGraphTypeConverter" [
let opts = JsonSerializerSettings()
opts.Converters.Add(OpenGraphTypeConverter())
test "succeeds when serializing" {
let after = JsonConvert.SerializeObject(VideoTvShow, opts)
Expect.equal after "\"video.tv_show\"" "OpenGraph type serialized incorrectly"
}
test "succeeds when deserializing" {
let after = JsonConvert.DeserializeObject<OpenGraphType>("\"book\"", opts)
Expect.equal after Book "OpenGraph type deserialized incorrectly"
}
]
/// Unit tests for the PermalinkConverter type
let permalinkConverterTests = testList "PermalinkConverter" [
let opts = JsonSerializerSettings()
@ -257,6 +271,7 @@ let configureTests = test "Json.configure succeeds" {
Expect.hasCountOf ser.Converters 1u (has typeof<CustomFeedSourceConverter>) "Custom feed source converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<ExplicitRatingConverter>) "Explicit rating converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<MarkupTextConverter>) "Markup text converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<OpenGraphTypeConverter>) "OpenGraph type converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<PermalinkConverter>) "Permalink converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<PageIdConverter>) "Page ID converter not found"
Expect.hasCountOf ser.Converters 1u (has typeof<PodcastMediumConverter>) "Podcast medium converter not found"
@ -282,6 +297,7 @@ let all = testList "Converters" [
customFeedSourceConverterTests
explicitRatingConverterTests
markupTextConverterTests
openGraphTypeConverterTests
permalinkConverterTests
pageIdConverterTests
podcastMediumConverterTests

View File

@ -1,6 +1,6 @@
/// <summary>
/// Integration tests for <see cref="IPageData" /> implementations
/// </summary>
/// </summary>
module PageDataTests
open System
@ -35,8 +35,9 @@ let ``Add succeeds`` (data: IData) = task {
Text = "<h1>A new page</h1>"
Metadata = [ { Name = "Meta Item"; Value = "Meta Value" } ]
PriorPermalinks = [ Permalink "2024/the-new-page.htm" ]
Revisions = [ { AsOf = Noda.epoch + Duration.FromDays 3; Text = Html "<h1>A new page</h1>" } ] }
do! data.Page.Add page
Revisions = [ { AsOf = Noda.epoch + Duration.FromDays 3; Text = Html "<h1>A new page</h1>" } ]
OpenGraph = Some { OpenGraphProperties.Empty with Type = Book } }
do! data.Page.Add page
let! stored = data.Page.FindFullById (PageId "added-page") (WebLogId "test")
Expect.isSome stored "The page should have been added"
let pg = stored.Value
@ -53,6 +54,7 @@ let ``Add succeeds`` (data: IData) = task {
Expect.equal pg.Metadata page.Metadata "Metadata not saved properly"
Expect.equal pg.PriorPermalinks page.PriorPermalinks "Prior permalinks not saved properly"
Expect.equal pg.Revisions page.Revisions "Revisions not saved properly"
Expect.equal pg.OpenGraph page.OpenGraph "OpenGraph properties not saved properly"
}
let ``All succeeds`` (data: IData) = task {

View File

@ -1,6 +1,6 @@
/// <summary>
/// Integration tests for <see cref="IPostData" /> implementations
/// </summary>
/// </summary>
module PostDataTests
open System
@ -54,7 +54,7 @@ let ``Add succeeds`` (data: IData) = task {
{ Id = PostId "a-new-post"
WebLogId = WebLogId "test"
AuthorId = WebLogUserId "test-author"
Status = Published
Status = Published
Title = "A New Test Post"
Permalink = Permalink "2020/test-post.html"
PublishedOn = Some (Noda.epoch + Duration.FromMinutes 1L)
@ -66,7 +66,8 @@ let ``Add succeeds`` (data: IData) = task {
Episode = Some { Episode.Empty with Media = "test-ep.mp3" }
Metadata = [ { Name = "Meta"; Value = "Data" } ]
PriorPermalinks = [ Permalink "2020/test-post-a.html" ]
Revisions = [ { AsOf = Noda.epoch + Duration.FromMinutes 1L; Text = Html "<p>Test text here" } ] }
Revisions = [ { AsOf = Noda.epoch + Duration.FromMinutes 1L; Text = Html "<p>Test text here" } ]
OpenGraph = Some { OpenGraphProperties.Empty with Type = VideoMovie } }
do! data.Post.Add post
let! stored = data.Post.FindFullById post.Id post.WebLogId
Expect.isSome stored "The added post should have been retrieved"
@ -87,6 +88,7 @@ let ``Add succeeds`` (data: IData) = task {
Expect.equal it.Metadata post.Metadata "Metadata items not saved properly"
Expect.equal it.PriorPermalinks post.PriorPermalinks "Prior permalinks not saved properly"
Expect.equal it.Revisions post.Revisions "Revisions not saved properly"
Expect.equal it.OpenGraph post.OpenGraph "OpenGraph properties not saved correctly"
}
let ``CountByStatus succeeds`` (data: IData) = task {

View File

@ -1,6 +1,6 @@
/// <summary>
/// Integration tests for <see cref="IWebLogData" /> implementations
/// </summary>
/// </summary>
module WebLogDataTests
open System
@ -25,14 +25,15 @@ let ``Add succeeds`` (data: IData) = task {
Rss =
{ IsFeedEnabled = true
FeedName = "my-feed.xml"
ItemsInFeed = None
ItemsInFeed = None
IsCategoryEnabled = false
IsTagEnabled = false
Copyright = Some "go for it"
CustomFeeds = [] }
AutoHtmx = true
Uploads = Disk
RedirectRules = [ { From = "/here"; To = "/there"; IsRegex = false } ] }
RedirectRules = [ { From = "/here"; To = "/there"; IsRegex = false } ]
AutoOpenGraph = false }
let! webLog = data.WebLog.FindById (WebLogId "new-weblog")
Expect.isSome webLog "The web log should have been returned"
let it = webLog.Value
@ -48,6 +49,7 @@ let ``Add succeeds`` (data: IData) = task {
Expect.isTrue it.AutoHtmx "Auto htmx flag is incorrect"
Expect.equal it.Uploads Disk "Upload destination is incorrect"
Expect.equal it.RedirectRules [ { From = "/here"; To = "/there"; IsRegex = false } ] "Redirect rules are incorrect"
Expect.isFalse it.AutoOpenGraph "Auto OpenGraph flag is incorrect"
let rss = it.Rss
Expect.isTrue rss.IsFeedEnabled "Is feed enabled flag is incorrect"
Expect.equal rss.FeedName "my-feed.xml" "Feed name is incorrect"

View File

@ -257,6 +257,346 @@ let markupTextTests = testList "MarkupText" [
]
]
/// Unit tests for the OpenGraphAudio type
let openGraphAudioTests = testList "OpenGraphAudio" [
testList "Properties" [
test "succeeds with minimum required" {
let props = Array.ofSeq { OpenGraphAudio.Empty with Url = "http://test.this" }.Properties
Expect.hasLength props 1 "There should be one property"
Expect.equal props[0] ("og:audio", "http://test.this") "The URL was not written correctly"
}
test "succeeds with secure URL" {
let props = Array.ofSeq { OpenGraphAudio.Empty with Url = "https://test.this" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[0] ("og:audio", "https://test.this") "The URL was not written correctly"
Expect.equal
props[1] ("og:audio:secure_url", "https://test.this") "The Secure URL was not written correctly"
}
test "succeeds with all properties filled" {
let props =
{ Url = "http://test.this"
SecureUrl = Some "https://test.other"
Type = Some "audio/mpeg" }.Properties
|> Array.ofSeq
Expect.hasLength props 3 "There should be three properties"
Expect.equal props[0] ("og:audio", "http://test.this") "The URL was not written correctly"
Expect.equal
props[1] ("og:audio:secure_url", "https://test.other") "The Secure URL was not written correctly"
Expect.equal props[2] ("og:audio:type", "audio/mpeg") "The MIME type was not written correctly"
}
test "succeeds when deriving AAC" {
let props = Array.ofSeq { OpenGraphAudio.Empty with Url = "/this/cool.file.aac" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:audio:type", "audio/aac") "The MIME type for AAC was not derived correctly"
}
test "succeeds when deriving MP3" {
let props = Array.ofSeq { OpenGraphAudio.Empty with Url = "/an.other/song.mp3" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:audio:type", "audio/mpeg") "The MIME type for MP3 was not derived correctly"
}
test "succeeds when deriving OGA" {
let props = Array.ofSeq { OpenGraphAudio.Empty with Url = "/talks/speex.oga" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:audio:type", "audio/ogg") "The MIME type for OGA was not derived correctly"
}
test "succeeds when deriving WAV" {
let props = Array.ofSeq { OpenGraphAudio.Empty with Url = "/some/old.school.wav" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:audio:type", "audio/wav") "The MIME type for WAV was not derived correctly"
}
test "succeeds when deriving WEBA" {
let props = Array.ofSeq { OpenGraphAudio.Empty with Url = "/new/format/file.weba" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:audio:type", "audio/webm") "The MIME type for WEBA was not derived correctly"
}
test "succeeds when type cannot be derived" {
let props = Array.ofSeq { OpenGraphAudio.Empty with Url = "/profile.jpg" }.Properties
Expect.hasLength props 1 "There should be one property (only URL; no type derived)"
}
]
]
/// Tests for the OpenGraphImage type
let openGraphImageTests = testList "OpenGraphImage" [
testList "Properties" [
test "succeeds with minimum required" {
let props = Array.ofSeq { OpenGraphImage.Empty with Url = "http://test.url" }.Properties
Expect.hasLength props 1 "There should be one property"
Expect.equal props[0] ("og:image", "http://test.url") "The URL was not written correctly"
}
test "succeeds with secure URL" {
let props = Array.ofSeq { OpenGraphImage.Empty with Url = "https://secure.url" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[0] ("og:image", "https://secure.url") "The URL was not written correctly"
Expect.equal
props[1] ("og:image:secure_url", "https://secure.url") "The Secure URL was not written correctly"
}
test "succeeds with all properties filled" {
let props =
{ Url = "http://test.this"
SecureUrl = Some "https://test.other"
Type = Some "image/jpeg"
Width = Some 400
Height = Some 600
Alt = Some "This ought to be good" }.Properties
|> Array.ofSeq
Expect.hasLength props 6 "There should be six properties"
Expect.equal props[0] ("og:image", "http://test.this") "The URL was not written correctly"
Expect.equal
props[1] ("og:image:secure_url", "https://test.other") "The Secure URL was not written correctly"
Expect.equal props[2] ("og:image:type", "image/jpeg") "The MIME type was not written correctly"
Expect.equal props[3] ("og:image:width", "400") "The width was not written correctly"
Expect.equal props[4] ("og:image:height", "600") "The height was not written correctly"
Expect.equal props[5] ("og:image:alt", "This ought to be good") "The alt text was not written correctly"
}
test "succeeds when deriving BMP" {
let props = Array.ofSeq { OpenGraphImage.Empty with Url = "/old/windows.bmp" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:image:type", "image/bmp") "The MIME type for BMP was not derived correctly"
}
test "succeeds when deriving GIF" {
let props = Array.ofSeq { OpenGraphImage.Empty with Url = "/its.a.soft.g.gif" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:image:type", "image/gif") "The MIME type for GIF was not derived correctly"
}
test "succeeds when deriving ICO" {
let props = Array.ofSeq { OpenGraphImage.Empty with Url = "/favicon.ico" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal
props[1] ("og:image:type", "image/vnd.microsoft.icon") "The MIME type for ICO was not derived correctly"
}
test "succeeds when deriving JPEG" {
let props = Array.ofSeq { OpenGraphImage.Empty with Url = "/big/name/photo.jpeg" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:image:type", "image/jpeg") "The MIME type for JPEG was not derived correctly"
}
test "succeeds when deriving PNG" {
let props = Array.ofSeq { OpenGraphImage.Empty with Url = "/some/nice/graphic.png" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:image:type", "image/png") "The MIME type for PNG was not derived correctly"
}
test "succeeds when deriving SVG" {
let props = Array.ofSeq { OpenGraphImage.Empty with Url = "/fancy-new-vector.svg" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:image:type", "image/svg+xml") "The MIME type for SVG was not derived correctly"
}
test "succeeds when deriving TIF" {
let props = Array.ofSeq { OpenGraphImage.Empty with Url = "/tagged/file.tif" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:image:type", "image/tiff") "The MIME type for TIF was not derived correctly"
}
test "succeeds when deriving TIFF" {
let props = Array.ofSeq { OpenGraphImage.Empty with Url = "/tagged/file.two.tiff" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:image:type", "image/tiff") "The MIME type for TIFF was not derived correctly"
}
test "succeeds when deriving WEBP" {
let props = Array.ofSeq { OpenGraphImage.Empty with Url = "/modern/photo.webp" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:image:type", "image/webp") "The MIME type for WEBP was not derived correctly"
}
test "succeeds when type cannot be derived" {
let props = Array.ofSeq { OpenGraphImage.Empty with Url = "/intro.mp3" }.Properties
Expect.hasLength props 1 "There should be one property (only URL; no type derived)"
}
]
]
/// Unit tests for the OpenGraphVideo type
let openGraphVideoTests = testList "OpenGraphVideo" [
testList "Properties" [
test "succeeds with minimum required" {
let props = Array.ofSeq { OpenGraphVideo.Empty with Url = "http://url.test" }.Properties
Expect.hasLength props 1 "There should be one property"
Expect.equal props[0] ("og:video", "http://url.test") "The URL was not written correctly"
}
test "succeeds with secure URL" {
let props = Array.ofSeq { OpenGraphVideo.Empty with Url = "https://url.secure" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[0] ("og:video", "https://url.secure") "The URL was not written correctly"
Expect.equal
props[1] ("og:video:secure_url", "https://url.secure") "The Secure URL was not written correctly"
}
test "succeeds with all properties filled" {
let props =
{ Url = "http://test.this"
SecureUrl = Some "https://test.other"
Type = Some "video/mpeg"
Width = Some 1200
Height = Some 900 }.Properties
|> Array.ofSeq
Expect.hasLength props 5 "There should be five properties"
Expect.equal props[0] ("og:video", "http://test.this") "The URL was not written correctly"
Expect.equal
props[1] ("og:video:secure_url", "https://test.other") "The Secure URL was not written correctly"
Expect.equal props[2] ("og:video:type", "video/mpeg") "The MIME type was not written correctly"
Expect.equal props[3] ("og:video:width", "1200") "The width was not written correctly"
Expect.equal props[4] ("og:video:height", "900") "The height was not written correctly"
}
test "succeeds when deriving AVI" {
let props = Array.ofSeq { OpenGraphVideo.Empty with Url = "/my.video.avi" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:video:type", "video/x-msvideo") "The MIME type for AVI was not derived correctly"
}
test "succeeds when deriving MP4" {
let props = Array.ofSeq { OpenGraphVideo.Empty with Url = "/chapters/1/01.mp4" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:video:type", "video/mp4") "The MIME type for MP4 was not derived correctly"
}
test "succeeds when deriving MPEG" {
let props = Array.ofSeq { OpenGraphVideo.Empty with Url = "/viral/video.mpeg" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:video:type", "video/mpeg") "The MIME type for MPEG was not derived correctly"
}
test "succeeds when deriving OGV" {
let props = Array.ofSeq { OpenGraphVideo.Empty with Url = "/open/video/example.ogv" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:video:type", "video/ogg") "The MIME type for OGV was not derived correctly"
}
test "succeeds when deriving WEBM" {
let props = Array.ofSeq { OpenGraphVideo.Empty with Url = "/images/hero.webm" }.Properties
Expect.hasLength props 2 "There should be two properties"
Expect.equal props[1] ("og:video:type", "video/webm") "The MIME type for WEBM was not derived correctly"
}
test "succeeds when type cannot be derived" {
let props = Array.ofSeq { OpenGraphVideo.Empty with Url = "/favicon.ico" }.Properties
Expect.hasLength props 1 "There should be one property (only URL; no type derived)"
}
]
]
/// Unit tests for the OpenGraphType type
let openGraphTypeTests = testList "OpenGraphType" [
testList "Parse" [
test "succeeds for \"article\"" {
Expect.equal (OpenGraphType.Parse "article") Article "\"article\" not parsed correctly"
}
test "succeeds for \"book\"" {
Expect.equal (OpenGraphType.Parse "book") Book "\"book\" not parsed correctly"
}
test "succeeds for \"music.album\"" {
Expect.equal (OpenGraphType.Parse "music.album") MusicAlbum "\"music.album\" not parsed correctly"
}
test "succeeds for \"music.playlist\"" {
Expect.equal (OpenGraphType.Parse "music.playlist") MusicPlaylist "\"music.playlist\" not parsed correctly"
}
test "succeeds for \"music.radio_station\"" {
Expect.equal
(OpenGraphType.Parse "music.radio_station")
MusicRadioStation
"\"music.radio_station\" not parsed correctly"
}
test "succeeds for \"music.song\"" {
Expect.equal (OpenGraphType.Parse "music.song") MusicSong "\"music.song\" not parsed correctly"
}
test "succeeds for \"payment.link\"" {
Expect.equal (OpenGraphType.Parse "payment.link") PaymentLink "\"payment.link\" not parsed correctly"
}
test "succeeds for \"profile\"" {
Expect.equal (OpenGraphType.Parse "profile") Profile "\"profile\" not parsed correctly"
}
test "succeeds for \"video.episode\"" {
Expect.equal (OpenGraphType.Parse "video.episode") VideoEpisode "\"video.episode\" not parsed correctly"
}
test "succeeds for \"video.movie\"" {
Expect.equal (OpenGraphType.Parse "video.movie") VideoMovie "\"video.movie\" not parsed correctly"
}
test "succeeds for \"video.other\"" {
Expect.equal (OpenGraphType.Parse "video.other") VideoOther "\"video.other\" not parsed correctly"
}
test "succeeds for \"video.tv_show\"" {
Expect.equal (OpenGraphType.Parse "video.tv_show") VideoTvShow "\"video.tv_show\" not parsed correctly"
}
test "succeeds for \"website\"" {
Expect.equal (OpenGraphType.Parse "website") Website "\"website\" not parsed correctly"
}
test "fails for invalid type" {
Expect.throwsT<ArgumentException>
(fun () -> ignore (OpenGraphType.Parse "anthology")) "Invalid value should have raised an exception"
}
]
testList "ToString" [
test "succeeds for Article" {
Expect.equal (string Article) "article" "Article string incorrect"
}
test "succeeds for Book" {
Expect.equal (string Book) "book" "Book string incorrect"
}
test "succeeds for MusicAlbum" {
Expect.equal (string MusicAlbum) "music.album" "MusicAlbum string incorrect"
}
test "succeeds for MusicPlaylist" {
Expect.equal (string MusicPlaylist) "music.playlist" "MusicPlaylist string incorrect"
}
test "succeeds for MusicRadioStation" {
Expect.equal (string MusicRadioStation) "music.radio_station" "MusicRadioStation string incorrect"
}
test "succeeds for MusicSong" {
Expect.equal (string MusicSong) "music.song" "MusicSong string incorrect"
}
test "succeeds for PaymentLink" {
Expect.equal (string PaymentLink) "payment.link" "PaymentLink string incorrect"
}
test "succeeds for Profile" {
Expect.equal (string Profile) "profile" "Profile string incorrect"
}
test "succeeds for VideoEpisode" {
Expect.equal (string VideoEpisode) "video.episode" "VideoEpisode string incorrect"
}
test "succeeds for VideoMovie" {
Expect.equal (string VideoMovie) "video.movie" "VideoMovie string incorrect"
}
test "succeeds for VideoOther" {
Expect.equal (string VideoOther) "video.other" "VideoOther string incorrect"
}
test "succeeds for VideoTvShow" {
Expect.equal (string VideoTvShow) "video.tv_show" "VideoTvShow string incorrect"
}
test "succeeds for Website" {
Expect.equal (string Website) "website" "Website string incorrect"
}
]
]
/// Unit tests for the OpenGraphProperties type
let openGraphPropertiesTests = testList "OpenGraphProperties" [
testList "Properties" [
test "succeeds with minimal values" {
let props =
{ OpenGraphProperties.Empty with
Image = { OpenGraphImage.Empty with Url = "http://this.aint.nothing" } }.Properties
|> Array.ofSeq
Expect.hasLength props 2 "There should have been two properties"
Expect.equal props[0] ("og:type", "article") "Type not written correctly"
Expect.equal props[1] ("og:image", "http://this.aint.nothing") "Image URL not written correctly"
}
test "succeeds with all values" {
let props =
{ Type = Book
Image = { OpenGraphImage.Empty with Url = "http://this.image.file" }
Audio = Some { OpenGraphAudio.Empty with Url = "http://this.audio.file" }
Description = Some "This is a unit test"
Determiner = Some "a"
Locale = Some "en_US"
LocaleAlternate = Some [ "en_UK"; "es_MX" ]
Video = Some { OpenGraphVideo.Empty with Url = "http://this.video.file" }
Other = Some [ { Name = "book.publisher"; Value = "Yep" } ] }.Properties
|> Array.ofSeq
Expect.hasLength props 10 "There should have been ten properties"
Expect.equal props[0] ("og:type", "book") "Type not written correctly"
Expect.equal props[1] ("og:image", "http://this.image.file") "Image URL not written correctly"
Expect.equal props[2] ("og:description", "This is a unit test") "Description not written correctly"
Expect.equal props[3] ("og:determiner", "a") "Determiner not written correctly"
Expect.equal props[4] ("og:locale", "en_US") "Locale not written correctly"
Expect.equal props[5] ("og:locale:alternate", "en_UK") "1st Alternate Locale not written correctly"
Expect.equal props[6] ("og:locale:alternate", "es_MX") "2nd Alternate Locale not written correctly"
Expect.equal props[7] ("og:audio", "http://this.audio.file") "Audio URL not written correctly"
Expect.equal props[8] ("og:video", "http://this.video.file") "Video URL not written correctly"
Expect.equal props[9] ("book.publisher", "Yep") "Other property not written correctly"
}
]
]
/// Unit tests for the PodcastMedium type
let podcastMediumTests = testList "PodcastMedium" [
testList "Parse" [
@ -407,6 +747,11 @@ let all = testList "SupportTypes" [
explicitRatingTests
episodeTests
markupTextTests
openGraphAudioTests
openGraphImageTests
openGraphVideoTests
openGraphTypeTests
openGraphPropertiesTests
podcastMediumTests
postStatusTests
customFeedSourceTests

View File

@ -233,7 +233,7 @@ let testFullPost =
ImageUrl = Some "uploads/podcast-cover.jpg"
Subtitle = Some "Narration"
Explicit = Some Clean
Chapters = None
Chapters = None
ChapterFile = Some "uploads/1970/01/chapters.txt"
ChapterType = Some "chapters"
ChapterWaypoints = Some true
@ -666,7 +666,7 @@ let editPostModelTests = testList "EditPostModel" [
{ testFullPost.Episode.Value with
Chapters = Some []
ChapterFile = None
ChapterType = None } }
ChapterType = None } }
Expect.equal model.ChapterSource "internal" "ChapterSource not filled properly"
}
]
@ -677,7 +677,7 @@ let editPostModelTests = testList "EditPostModel" [
model.Source <- "HTML"
model.Text <- "<p>An updated post!</p>"
model.Tags <- "Zebras, Aardvarks, , Turkeys"
model.Template <- "updated"
model.Template <- "updated"
model.CategoryIds <- [| "cat-x"; "cat-y" |]
model.MetaNames <- [| "Zed Meta"; "A Meta" |]
model.MetaValues <- [| "A Value"; "Zed Value" |]
@ -688,7 +688,7 @@ let editPostModelTests = testList "EditPostModel" [
model.ImageUrl <- "updated-cover.png"
model.Subtitle <- "Talking"
model.Explicit <- "no"
model.ChapterSource <- "external"
model.ChapterSource <- "external"
model.ChapterFile <- "updated-chapters.txt"
model.ChapterType <- "indexes"
model.TranscriptUrl <- "updated-transcript.txt"
@ -696,7 +696,7 @@ let editPostModelTests = testList "EditPostModel" [
model.TranscriptLang <- "ES-mx"
model.SeasonNumber <- 4
model.SeasonDescription <- "Season Fo"
model.EpisodeNumber <- "432.1"
model.EpisodeNumber <- "432.1"
model.EpisodeDescription <- "Four Three Two pt One"
model
testList "UpdatePost" [
@ -760,7 +760,7 @@ let editPostModelTests = testList "EditPostModel" [
minModel.SeasonNumber <- 0
minModel.SeasonDescription <- ""
minModel.EpisodeNumber <- ""
minModel.EpisodeDescription <- ""
minModel.EpisodeDescription <- ""
let post = minModel.UpdatePost testFullPost (Noda.epoch + Duration.FromDays 500)
Expect.isSome post.Episode "There should have been a podcast episode"
let ep = post.Episode.Value
@ -785,7 +785,7 @@ let editPostModelTests = testList "EditPostModel" [
}
test "succeeds for a podcast episode with internal chapters" {
let minModel = updatedModel ()
minModel.ChapterSource <- "internal"
minModel.ChapterSource <- "internal"
minModel.ChapterFile <- ""
minModel.ChapterType <- ""
let post = minModel.UpdatePost testFullPost (Noda.epoch + Duration.FromDays 500)
@ -977,7 +977,7 @@ let editUserModelTests = testList "EditUserModel" [
let model =
{ Id = "test-user"
AccessLevel = "WebLogAdmin"
Email = "again@example.com"
Email = "again@example.com"
Url = ""
FirstName = "Another"
LastName = "One"
@ -1115,10 +1115,10 @@ let postListItemTests = testList "PostListItem" [
{ Post.Empty with
Id = PostId "full-post"
AuthorId = WebLogUserId "me"
Status = Published
Status = Published
Title = "Finished Product"
Permalink = Permalink "2021/post.html"
PublishedOn = Some (Noda.epoch + Duration.FromHours 12)
PublishedOn = Some (Noda.epoch + Duration.FromHours 12)
UpdatedOn = Noda.epoch + Duration.FromHours 13
Text = """<a href="/other-post.html">Click</a>"""
CategoryIds = [ CategoryId "z"; CategoryId "y" ]
@ -1157,13 +1157,14 @@ let settingsModelTests = testList "SettingsModel" [
let model =
SettingsModel.FromWebLog
{ WebLog.Empty with
Name = "The Web Log"
Slug = "the-web-log"
DefaultPage = "this-one"
PostsPerPage = 18
TimeZone = "America/Denver"
ThemeId = ThemeId "my-theme"
AutoHtmx = true }
Name = "The Web Log"
Slug = "the-web-log"
DefaultPage = "this-one"
PostsPerPage = 18
TimeZone = "America/Denver"
ThemeId = ThemeId "my-theme"
AutoHtmx = true
AutoOpenGraph = false }
Expect.equal model.Name "The Web Log" "Name not filled properly"
Expect.equal model.Slug "the-web-log" "Slug not filled properly"
Expect.equal model.Subtitle "" "Subtitle not filled properly"
@ -1173,6 +1174,7 @@ let settingsModelTests = testList "SettingsModel" [
Expect.equal model.ThemeId "my-theme" "ThemeId not filled properly"
Expect.isTrue model.AutoHtmx "AutoHtmx should have been set"
Expect.equal model.Uploads "Database" "Uploads not filled properly"
Expect.isFalse model.AutoOpenGraph "AutoOpenGraph should have been unset"
}
test "succeeds with a subtitle" {
let model = SettingsModel.FromWebLog { WebLog.Empty with Subtitle = Some "sub here!" }
@ -1182,15 +1184,16 @@ let settingsModelTests = testList "SettingsModel" [
testList "Update" [
test "succeeds with no subtitle" {
let webLog =
{ Name = "Interesting"
Slug = "some-stuff"
Subtitle = ""
DefaultPage = "that-one"
PostsPerPage = 8
TimeZone = "America/Chicago"
ThemeId = "test-theme"
AutoHtmx = true
Uploads = "Disk" }.Update WebLog.Empty
{ Name = "Interesting"
Slug = "some-stuff"
Subtitle = ""
DefaultPage = "that-one"
PostsPerPage = 8
TimeZone = "America/Chicago"
ThemeId = "test-theme"
AutoHtmx = true
Uploads = "Disk"
AutoOpenGraph = false }.Update WebLog.Empty
Expect.equal webLog.Name "Interesting" "Name not filled properly"
Expect.equal webLog.Slug "some-stuff" "Slug not filled properly"
Expect.isNone webLog.Subtitle "Subtitle should not have had a value"
@ -1200,6 +1203,7 @@ let settingsModelTests = testList "SettingsModel" [
Expect.equal webLog.ThemeId (ThemeId "test-theme") "ThemeId not filled properly"
Expect.isTrue webLog.AutoHtmx "AutoHtmx should have been set"
Expect.equal webLog.Uploads Disk "Uploads not filled properly"
Expect.isFalse webLog.AutoOpenGraph "AutoOpenGraph should have been unset"
}
test "succeeds with a subtitle" {
let webLog = { SettingsModel.FromWebLog WebLog.Empty with Subtitle = "Sub" }.Update WebLog.Empty

View File

@ -10,20 +10,19 @@ let sqliteOnly = (RethinkDbDataTests.env "SQLITE_ONLY" "0") = "1"
let postgresOnly = (RethinkDbDataTests.env "PG_ONLY" "0") = "1"
/// Whether any of the data tests are being isolated
let dbOnly = rethinkOnly || sqliteOnly || postgresOnly
/// Whether to only run the unit tests (skip database/integration tests)
let unitOnly = (RethinkDbDataTests.env "UNIT_ONLY" "0") = "1"
let allDatabases = not (rethinkOnly || sqliteOnly || postgresOnly)
let allTests = testList "MyWebLog" [
if not dbOnly then testList "Domain" [ SupportTypesTests.all; DataTypesTests.all; ViewModelsTests.all ]
if not unitOnly then
testList "Data" [
if not dbOnly then ConvertersTests.all
if not dbOnly then UtilsTests.all
if not dbOnly || (dbOnly && rethinkOnly) then RethinkDbDataTests.all
if not dbOnly || (dbOnly && sqliteOnly) then SQLiteDataTests.all
if not dbOnly || (dbOnly && postgresOnly) then PostgresDataTests.all
// Skip unit tests if running an isolated database test
if allDatabases then
testList "Domain" [ SupportTypesTests.all; DataTypesTests.all; ViewModelsTests.all ]
testList "Data (Unit)" [ ConvertersTests.all; UtilsTests.all ]
// Whether to skip integration tests
if RethinkDbDataTests.env "UNIT_ONLY" "0" <> "1" then
testList "Data (Integration)" [
if allDatabases || rethinkOnly then RethinkDbDataTests.all
if allDatabases || sqliteOnly then SQLiteDataTests.all
if allDatabases || postgresOnly then PostgresDataTests.all
]
]

View File

@ -192,7 +192,12 @@ let parser =
let attrEnc = System.Web.HttpUtility.HtmlAttributeEncode
// OpenGraph tags
if app.IsPage || app.IsPost then
let doOpenGraph =
(app.WebLog.AutoOpenGraph && (app.IsPage || app.IsPost))
|| (app.IsPage && Option.isSome app.Page.OpenGraph)
|| (app.IsPost && Option.isSome app.Posts.Posts[0].OpenGraph)
if doOpenGraph then
let writeOgProp (name, value) =
writer.WriteLine $"""{s}<meta property=%s{name} content="{attrEnc value}">"""
writeOgProp ("og:title", if app.IsPage then app.Page.Title else app.Posts.Posts[0].Title)
@ -202,20 +207,7 @@ let parser =
|> app.WebLog.AbsoluteUrl
|> function url -> writeOgProp ("og:url", url)
match if app.IsPage then app.Page.OpenGraph else app.Posts.Posts[0].OpenGraph with
| Some props ->
writeOgProp ("og:type", string props.Type)
props.Image.Properties |> Seq.iter writeOgProp
match props.Description with Some desc -> writeOgProp ("og:description", desc) | None -> ()
match props.Determiner with Some det -> writeOgProp ("og:determiner", det) | None -> ()
match props.Locale with Some loc -> writeOgProp ("og:locale", loc) | None -> ()
match props.LocaleAlternate with
| Some alt -> alt |> List.iter (fun it -> writeOgProp ("og:locale:alternate", it))
| None -> ()
match props.Audio with Some audio -> audio.Properties |> Seq.iter writeOgProp | None -> ()
match props.Video with Some video -> video.Properties |> Seq.iter writeOgProp | None -> ()
match props.Other with
| Some oth -> oth |> List.iter (fun it -> writeOgProp (it.Name, it.Value))
| None -> ()
| Some props -> props.Properties |> Seq.iter writeOgProp
| None -> ()
writer.WriteLine $"""{s}<meta name=generator content="{app.Generator}">"""

View File

@ -795,6 +795,13 @@ let webLogSettings
selectField [] (nameof model.Uploads) "Default Upload Destination" model.Uploads uploads
string string []
]
div [ _class "col-12 col-md-6 offset-md-3 col-xl-4 offset-xl-4" ] [
checkboxSwitch [] (nameof model.AutoOpenGraph) "Auto-Add OpenGraph Properties"
model.AutoOpenGraph []
span [ _class "form-text fst-italic" ] [
raw "Adds title, site name, and permalink to all pages and posts"
]
]
]
div [ _class "row pb-3" ] [
div [ _class "col text-center" ] [