Compare commits

..

10 Commits

Author SHA1 Message Date
dc30716b83 Update deps; WIP on comments 2025-01-23 22:11:12 -05:00
88841fd3f8 Update to .NET 8/9; minor tweaks 2024-12-23 21:16:34 -05:00
870f87cb17 Update for v4-rc5 of doc library 2024-09-18 19:54:45 -04:00
0032d15c0a Update for doc lib v4-rc4 2024-09-17 08:05:30 -04:00
95be82cc84 WIP on Fluid model/filters 2024-08-26 21:42:47 -04:00
d047035173 WIP: conversion to Fluid (#47) 2024-08-24 20:47:23 -04:00
cc3e41ddc5 Incorporate doc lib v4 ordering 2024-08-22 23:00:25 -04:00
d4c0e4e26c Tweak PostgreSQL calls 2024-08-19 22:45:14 -04:00
fbc4e891bd Integrate v4 document library for SQLite
- Eliminate warnings for PostgreSQL
2024-08-19 22:23:22 -04:00
cd450a05e5 Update to new doc library
Still need to remove deprecated calls
2024-08-19 20:30:33 -04:00
44 changed files with 2448 additions and 1981 deletions

View File

@ -23,7 +23,7 @@ let version =
let appVersion = generator.Replace("\"Generator\": \"", "")
let appVersion = appVersion.Substring (0, appVersion.IndexOf "\"")
appVersion.Split ' ' |> Array.last
/// Zip a theme distributed with myWebLog
let zipTheme (name : string) (_ : TargetParameter) =
let path = $"src/{name}-theme"
@ -33,9 +33,9 @@ let zipTheme (name : string) (_ : TargetParameter) =
|> Zip.zipSpec $"{releasePath}/{name}-theme.zip"
/// Frameworks supported by this build
let frameworks = [ "net6.0"; "net8.0" ]
let frameworks = [ "net8.0"; "net9.0" ]
/// Publish the project for the given runtime ID
/// Publish the project for the given runtime ID
let publishFor rid (_ : TargetParameter) =
frameworks
|> List.iter (fun fwk ->
@ -65,7 +65,7 @@ let packageFor rid (_ : TargetParameter) =
Target.create "Clean" (fun _ ->
!! "src/**/bin"
++ "src/**/obj"
|> Shell.cleanDirs
|> Shell.cleanDirs
Shell.cleanDir releasePath
)
@ -87,7 +87,7 @@ Target.create "RepackageLinux" (fun _ ->
frameworks
|> List.iter (fun fwk ->
let zipArchive = $"{releasePath}/myWebLog-{version}.{fwk}.linux-x64.zip"
let sh command args =
let sh command args =
CreateProcess.fromRawCommand command args
|> CreateProcess.redirectOutput
|> Proc.run

View File

@ -1,9 +1,11 @@
<Project>
<PropertyGroup>
<TargetFrameworks>net6.0;net8.0</TargetFrameworks>
<TargetFrameworks>net8.0;net9.0</TargetFrameworks>
<DebugType>embedded</DebugType>
<AssemblyVersion>2.2.0.0</AssemblyVersion>
<FileVersion>2.2.0.0</FileVersion>
<Version>2.2.0</Version>
<GenerateDocumentationFile>true</GenerateDocumentationFile>
<AssemblyVersion>3.0.0.0</AssemblyVersion>
<FileVersion>3.0.0.0</FileVersion>
<Version>3.0.0</Version>
<VersionSuffix>beta1</VersionSuffix>
</PropertyGroup>
</Project>

View File

@ -1,14 +1,15 @@
/// Converters for discriminated union types
/// <summary>Converters for discriminated union types</summary>
module MyWebLog.Converters
open MyWebLog
open System
/// JSON.NET converters for discriminated union types
/// <summary>JSON.NET converters for discriminated union types</summary>
module Json =
open Newtonsoft.Json
/// <summary>Converter for the <see cref="CategoryId" /> type</summary>
type CategoryIdConverter() =
inherit JsonConverter<CategoryId>()
override _.WriteJson(writer: JsonWriter, value: CategoryId, _: JsonSerializer) =
@ -16,6 +17,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: CategoryId, _: bool, _: JsonSerializer) =
(string >> CategoryId) reader.Value
/// <summary>Converter for the <see cref="CommentId" /> type</summary>
type CommentIdConverter() =
inherit JsonConverter<CommentId>()
override _.WriteJson(writer: JsonWriter, value: CommentId, _: JsonSerializer) =
@ -23,6 +25,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: CommentId, _: bool, _: JsonSerializer) =
(string >> CommentId) reader.Value
/// <summary>Converter for the <see cref="CommentStatus" /> type</summary>
type CommentStatusConverter() =
inherit JsonConverter<CommentStatus>()
override _.WriteJson(writer: JsonWriter, value: CommentStatus, _: JsonSerializer) =
@ -30,6 +33,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: CommentStatus, _: bool, _: JsonSerializer) =
(string >> CommentStatus.Parse) reader.Value
/// <summary>Converter for the <see cref="CustomFeedId" /> type</summary>
type CustomFeedIdConverter() =
inherit JsonConverter<CustomFeedId>()
override _.WriteJson(writer: JsonWriter, value: CustomFeedId, _: JsonSerializer) =
@ -37,27 +41,31 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: CustomFeedId, _: bool, _: JsonSerializer) =
(string >> CustomFeedId) reader.Value
/// <summary>Converter for the <see cref="CustomFeedSource" /> type</summary>
type CustomFeedSourceConverter() =
inherit JsonConverter<CustomFeedSource>()
override _.WriteJson(writer: JsonWriter, value: CustomFeedSource, _: JsonSerializer) =
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: CustomFeedSource, _: bool, _: JsonSerializer) =
(string >> CustomFeedSource.Parse) reader.Value
/// <summary>Converter for the <see cref="ExplicitRating" /> type</summary>
type ExplicitRatingConverter() =
inherit JsonConverter<ExplicitRating>()
override _.WriteJson(writer: JsonWriter, value: ExplicitRating, _: JsonSerializer) =
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: ExplicitRating, _: bool, _: JsonSerializer) =
(string >> ExplicitRating.Parse) reader.Value
/// <summary>Converter for the <see cref="MarkupText" /> type</summary>
type MarkupTextConverter() =
inherit JsonConverter<MarkupText>()
override _.WriteJson(writer: JsonWriter, value: MarkupText, _: JsonSerializer) =
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: MarkupText, _: bool, _: JsonSerializer) =
(string >> MarkupText.Parse) reader.Value
/// <summary>Converter for the <see cref="Permalink" /> type</summary>
type PermalinkConverter() =
inherit JsonConverter<Permalink>()
override _.WriteJson(writer: JsonWriter, value: Permalink, _: JsonSerializer) =
@ -65,6 +73,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: Permalink, _: bool, _: JsonSerializer) =
(string >> Permalink) reader.Value
/// <summary>Converter for the <see cref="PageId" /> type</summary>
type PageIdConverter() =
inherit JsonConverter<PageId>()
override _.WriteJson(writer: JsonWriter, value: PageId, _: JsonSerializer) =
@ -72,6 +81,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: PageId, _: bool, _: JsonSerializer) =
(string >> PageId) reader.Value
/// <summary>Converter for the <see cref="PodcastMedium" /> type</summary>
type PodcastMediumConverter() =
inherit JsonConverter<PodcastMedium>()
override _.WriteJson(writer: JsonWriter, value: PodcastMedium, _: JsonSerializer) =
@ -79,6 +89,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: PodcastMedium, _: bool, _: JsonSerializer) =
(string >> PodcastMedium.Parse) reader.Value
/// <summary>Converter for the <see cref="PostId" /> type</summary>
type PostIdConverter() =
inherit JsonConverter<PostId>()
override _.WriteJson(writer: JsonWriter, value: PostId, _: JsonSerializer) =
@ -86,6 +97,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: PostId, _: bool, _: JsonSerializer) =
(string >> PostId) reader.Value
/// <summary>Converter for the <see cref="TagMapId" /> type</summary>
type TagMapIdConverter() =
inherit JsonConverter<TagMapId>()
override _.WriteJson(writer: JsonWriter, value: TagMapId, _: JsonSerializer) =
@ -93,6 +105,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: TagMapId, _: bool, _: JsonSerializer) =
(string >> TagMapId) reader.Value
/// <summary>Converter for the <see cref="ThemeAssetId" /> type</summary>
type ThemeAssetIdConverter() =
inherit JsonConverter<ThemeAssetId>()
override _.WriteJson(writer: JsonWriter, value: ThemeAssetId, _: JsonSerializer) =
@ -100,20 +113,23 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: ThemeAssetId, _: bool, _: JsonSerializer) =
(string >> ThemeAssetId.Parse) reader.Value
/// <summary>Converter for the <see cref="ThemeId" /> type</summary>
type ThemeIdConverter() =
inherit JsonConverter<ThemeId>()
override _.WriteJson(writer: JsonWriter, value: ThemeId, _: JsonSerializer) =
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: ThemeId, _: bool, _: JsonSerializer) =
(string >> ThemeId) reader.Value
/// <summary>Converter for the <see cref="UploadId" /> type</summary>
type UploadIdConverter() =
inherit JsonConverter<UploadId>()
override _.WriteJson(writer: JsonWriter, value: UploadId, _: JsonSerializer) =
writer.WriteValue(string value)
override _.ReadJson(reader: JsonReader, _: Type, _: UploadId, _: bool, _: JsonSerializer) =
(string >> UploadId) reader.Value
/// <summary>Converter for the <see cref="WebLogId" /> type</summary>
type WebLogIdConverter() =
inherit JsonConverter<WebLogId>()
override _.WriteJson(writer: JsonWriter, value: WebLogId, _: JsonSerializer) =
@ -121,6 +137,7 @@ module Json =
override _.ReadJson(reader: JsonReader, _: Type, _: WebLogId, _: bool, _: JsonSerializer) =
(string >> WebLogId) reader.Value
/// <summary>Converter for the <see cref="WebLogUserId" /> type</summary>
type WebLogUserIdConverter() =
inherit JsonConverter<WebLogUserId> ()
override _.WriteJson(writer: JsonWriter, value: WebLogUserId, _: JsonSerializer) =
@ -131,9 +148,9 @@ module Json =
open Microsoft.FSharpLu.Json
open NodaTime
open NodaTime.Serialization.JsonNet
/// Configure a serializer to use these converters
let configure (ser : JsonSerializer) =
/// <summary>Configure a serializer to use these converters (and other settings)</summary>
let configure (ser: JsonSerializer) =
// Our converters
[ CategoryIdConverter() :> JsonConverter
CommentIdConverter()
@ -160,12 +177,14 @@ module Json =
ser.NullValueHandling <- NullValueHandling.Ignore
ser.MissingMemberHandling <- MissingMemberHandling.Ignore
ser
/// Serializer settings extracted from a JsonSerializer (a property sure would be nice...)
let mutable private serializerSettings : JsonSerializerSettings option = None
/// Extract settings from the serializer to be used in JsonConvert calls
let settings (ser : JsonSerializer) =
/// <summary>Extract settings from the serializer to be used in <c>JsonConvert</c> calls</summary>
/// <param name="ser">The serializer from which settings will be extracted if required</param>
/// <returns>The serializer settings to use for <c>JsonConvert</c> calls</returns>
let settings (ser: JsonSerializer) =
if Option.isNone serializerSettings then
serializerSettings <- JsonSerializerSettings (
ConstructorHandling = ser.ConstructorHandling,

View File

@ -5,17 +5,17 @@
</ItemGroup>
<ItemGroup>
<PackageReference Include="BitBadger.Documents.Postgres" Version="3.1.0" />
<PackageReference Include="BitBadger.Documents.Sqlite" Version="3.1.0" />
<PackageReference Include="Microsoft.Data.Sqlite" Version="8.0.6" />
<PackageReference Include="Microsoft.Extensions.Caching.Abstractions" Version="8.0.0" />
<PackageReference Include="Microsoft.Extensions.Configuration.Abstractions" Version="8.0.0" />
<PackageReference Include="BitBadger.Documents.Postgres" Version="4.0.1" />
<PackageReference Include="BitBadger.Documents.Sqlite" Version="4.0.1" />
<PackageReference Include="Microsoft.Data.Sqlite" Version="9.0.1" />
<PackageReference Include="Microsoft.Extensions.Caching.Abstractions" Version="9.0.1" />
<PackageReference Include="Microsoft.Extensions.Configuration.Abstractions" Version="9.0.1" />
<PackageReference Include="Microsoft.FSharpLu.Json" Version="0.11.7" />
<PackageReference Include="NodaTime.Serialization.JsonNet" Version="3.1.0" />
<PackageReference Include="Npgsql.NodaTime" Version="8.0.3" />
<PackageReference Include="NodaTime.Serialization.JsonNet" Version="3.2.0" />
<PackageReference Include="Npgsql.NodaTime" Version="9.0.2" />
<PackageReference Include="RethinkDb.Driver" Version="2.3.150" />
<PackageReference Include="RethinkDb.Driver.FSharp" Version="0.9.0-beta-07" />
<PackageReference Update="FSharp.Core" Version="8.0.300" />
<PackageReference Update="FSharp.Core" Version="9.0.101" />
</ItemGroup>
<ItemGroup>

View File

@ -19,38 +19,41 @@ type PostgresCategoryData(log: ILogger) =
let countTopLevel webLogId =
log.LogTrace "Category.countTopLevel"
Custom.scalar
$"""{Query.Count.byContains Table.Category}
AND {Query.whereByField (Field.NEX (nameof Category.Empty.ParentId)) ""}"""
$"""{Query.byContains (Query.count Table.Category)}
AND {Query.whereByFields Any [ Field.NotExists (nameof Category.Empty.ParentId) ]}"""
[ webLogContains webLogId ]
toCount
/// Find all categories for the given web log
let findByWebLog webLogId =
log.LogTrace "Category.findByWebLog"
Find.byContains<Category> Table.Category (webLogDoc webLogId)
/// Retrieve all categories for the given web log in a DotLiquid-friendly format
let findAllForView webLogId = backgroundTask {
log.LogTrace "Category.findAllForView"
let! cats =
Custom.list
$"{selectWithCriteria Table.Category} ORDER BY LOWER(data ->> '{nameof Category.Empty.Name}')"
[ webLogContains webLogId ]
fromData<Category>
let ordered = Utils.orderByHierarchy cats None None []
let counts =
let! cats = findByWebLog webLogId
let ordered = Utils.orderByHierarchy (cats |> List.sortBy _.Name.ToLowerInvariant()) None None []
let counts =
ordered
|> Seq.map (fun it ->
// Parent category post counts include posts in subcategories
let catIdSql, catIdParams =
let catIdField =
ordered
|> Seq.filter (fun cat -> cat.ParentNames |> Array.contains it.Name)
|> Seq.map _.Id
|> Seq.append (Seq.singleton it.Id)
|> List.ofSeq
|> arrayContains (nameof Post.Empty.CategoryIds) id
|> Field.InArray (nameof Post.Empty.CategoryIds) Table.Post
let query =
(Query.statementWhere
(Query.count Table.Post)
$"""{Query.whereDataContains "@criteria"} AND {Query.whereByFields All [ catIdField ]}""")
.Replace("(*)", $"(DISTINCT data->>'{nameof Post.Empty.Id}')")
let postCount =
Custom.scalar
$"""SELECT COUNT(DISTINCT data ->> '{nameof Post.Empty.Id}') AS it
FROM {Table.Post}
WHERE {Query.whereDataContains "@criteria"}
AND {catIdSql}"""
[ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}; catIdParams ]
query
(addFieldParams
[ catIdField ] [ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |} ])
toCount
|> Async.AwaitTask
|> Async.RunSynchronously
@ -71,11 +74,6 @@ type PostgresCategoryData(log: ILogger) =
log.LogTrace "Category.findById"
Document.findByIdAndWebLog<CategoryId, Category> Table.Category catId webLogId
/// Find all categories for the given web log
let findByWebLog webLogId =
log.LogTrace "Category.findByWebLog"
Document.findByWebLog<Category> Table.Category webLogId
/// Delete a category
let delete catId webLogId = backgroundTask {
log.LogTrace "Category.delete"
@ -87,14 +85,14 @@ type PostgresCategoryData(log: ILogger) =
if hasChildren then
let childQuery, childParams =
if cat.ParentId.IsSome then
Query.Patch.byId Table.Category,
Query.byId (Query.patch Table.Category) "",
children
|> List.map (fun child -> [ idParam child.Id; jsonParam "@data" {| ParentId = cat.ParentId |} ])
else
Query.RemoveFields.byId Table.Category,
Query.byId (Query.removeFields Table.Category) "",
children
|> List.map (fun child ->
[ idParam child.Id; fieldNameParam [ nameof Category.Empty.ParentId ] ])
[ idParam child.Id; fieldNameParams [ nameof Category.Empty.ParentId ] ])
let! _ =
Configuration.dataSource ()
|> Sql.fromDataSource
@ -103,7 +101,7 @@ type PostgresCategoryData(log: ILogger) =
// Delete the category off all posts where it is assigned
let! posts =
Custom.list
$"SELECT data FROM {Table.Post} WHERE data -> '{nameof Post.Empty.CategoryIds}' @> @id"
$"SELECT data FROM {Table.Post} WHERE data->'{nameof Post.Empty.CategoryIds}' @> @id"
[ jsonParam "@id" [| string catId |] ]
fromData<Post>
if not (List.isEmpty posts) then
@ -111,7 +109,7 @@ type PostgresCategoryData(log: ILogger) =
Configuration.dataSource ()
|> Sql.fromDataSource
|> Sql.executeTransactionAsync
[ Query.Patch.byId Table.Post,
[ Query.byId (Query.patch Table.Post) "",
posts
|> List.map (fun post ->
[ idParam post.Id

View File

@ -83,28 +83,7 @@ let webLogContains webLogId =
/// A SQL string to select data from a table with the given JSON document contains criteria
let selectWithCriteria tableName =
$"""{Query.selectFromTable tableName} WHERE {Query.whereDataContains "@criteria"}"""
/// Create the SQL and parameters for an IN clause
let inClause<'T> colNameAndPrefix paramName (items: 'T list) =
if List.isEmpty items then "", []
else
let mutable idx = 0
items
|> List.skip 1
|> List.fold (fun (itemS, itemP) it ->
idx <- idx + 1
$"{itemS}, @%s{paramName}{idx}", ($"@%s{paramName}{idx}", Sql.string (string it)) :: itemP)
(Seq.ofList items
|> Seq.map (fun it ->
$"%s{colNameAndPrefix} IN (@%s{paramName}0", [ $"@%s{paramName}0", Sql.string (string it) ])
|> Seq.head)
|> function sql, ps -> $"{sql})", ps
/// Create the SQL and parameters for match-any array query
let arrayContains<'T> name (valueFunc: 'T -> string) (items: 'T list) =
$"data['{name}'] ?| @{name}Values",
($"@{name}Values", Sql.stringArray (items |> List.map valueFunc |> Array.ofList))
Query.byContains (Query.find tableName)
/// Get the first result of the given query
let tryHead<'T> (query: Task<'T list>) = backgroundTask {
@ -162,13 +141,9 @@ module Document =
/// Find a document by its ID for the given web log
let findByIdAndWebLog<'TKey, 'TDoc> table (key: 'TKey) webLogId =
Custom.single
$"""{Query.selectFromTable table} WHERE {Query.whereById "@id"} AND {Query.whereDataContains "@criteria"}"""
$"""{Query.find table} WHERE {Query.whereById "@id"} AND {Query.whereDataContains "@criteria"}"""
[ "@id", Sql.string (string key); webLogContains webLogId ]
fromData<'TDoc>
/// Find documents for the given web log
let findByWebLog<'TDoc> table webLogId : Task<'TDoc list> =
Find.byContains table (webLogDoc webLogId)
/// Functions to support revisions
@ -186,7 +161,7 @@ module Revisions =
Custom.list
$"""SELECT pr.*
FROM %s{revTable} pr
INNER JOIN %s{entityTable} p ON p.data ->> '{nameof Post.Empty.Id}' = pr.{entityTable}_id
INNER JOIN %s{entityTable} p ON p.data->>'{nameof Post.Empty.Id}' = pr.{entityTable}_id
WHERE p.{Query.whereDataContains "@criteria"}
ORDER BY as_of DESC"""
[ webLogContains webLogId ]

View File

@ -33,6 +33,10 @@ type PostgresPageData(log: ILogger) =
log.LogTrace "Page.pageExists"
Document.existsByWebLog Table.Page pageId webLogId
/// The query to get all pages ordered by title
let sortedPages =
selectWithCriteria Table.Page + Query.orderBy [ Field.Named $"i:{nameof Page.Empty.Title}" ] PostgreSQL
// IMPLEMENTATION FUNCTIONS
/// Add a page
@ -47,7 +51,7 @@ type PostgresPageData(log: ILogger) =
let all webLogId =
log.LogTrace "Page.all"
Custom.list
$"{selectWithCriteria Table.Page} ORDER BY LOWER(data ->> '{nameof Page.Empty.Title}')"
sortedPages
[ webLogContains webLogId ]
(fun row -> { fromData<Page> row with Text = ""; Metadata = []; PriorPermalinks = [] })
@ -86,8 +90,8 @@ type PostgresPageData(log: ILogger) =
match! pageExists pageId webLogId with
| true ->
do! Custom.nonQuery
$"""DELETE FROM {Table.PageRevision} WHERE page_id = @id;
DELETE FROM {Table.Page} WHERE {Query.whereById "@id"}"""
$"""{Query.delete Table.PageRevision} WHERE page_id = @id;
{Query.delete Table.Page} WHERE {Query.whereById "@id"}"""
[ idParam pageId ]
return true
| false -> return false
@ -107,21 +111,19 @@ type PostgresPageData(log: ILogger) =
log.LogTrace "Page.findCurrentPermalink"
if List.isEmpty permalinks then return None
else
let linkSql, linkParam = arrayContains (nameof Page.Empty.PriorPermalinks) string permalinks
return!
Custom.single
$"""SELECT data ->> '{nameof Page.Empty.Permalink}' AS permalink
FROM page
WHERE {Query.whereDataContains "@criteria"}
AND {linkSql}"""
[ webLogContains webLogId; linkParam ]
Map.toPermalink
let linkField = Field.InArray (nameof Page.Empty.PriorPermalinks) Table.Page (List.map string permalinks)
let query =
(Query.statementWhere
(Query.find Table.Page)
$"""{Query.whereDataContains "@criteria"} AND {Query.whereByFields All [ linkField ]}""")
.Replace("SELECT data", $"SELECT data->>'{nameof Page.Empty.Permalink}' AS permalink")
return! Custom.single query (addFieldParams [ linkField ] [ webLogContains webLogId ]) Map.toPermalink
}
/// Get all complete pages for the given web log
let findFullByWebLog webLogId = backgroundTask {
log.LogTrace "Page.findFullByWebLog"
let! pages = Document.findByWebLog<Page> Table.Page webLogId
let! pages = Find.byContains<Page> Table.Page (webLogDoc webLogId)
let! revisions = Revisions.findByWebLog Table.PageRevision Table.Page PageId webLogId
return
pages
@ -133,17 +135,13 @@ type PostgresPageData(log: ILogger) =
let findListed webLogId =
log.LogTrace "Page.findListed"
Custom.list
$"{selectWithCriteria Table.Page} ORDER BY LOWER(data ->> '{nameof Page.Empty.Title}')"
[ jsonParam "@criteria" {| webLogDoc webLogId with IsInPageList = true |} ]
pageWithoutText
sortedPages [ jsonParam "@criteria" {| webLogDoc webLogId with IsInPageList = true |} ] pageWithoutText
/// Get a page of pages for the given web log (without revisions)
let findPageOfPages webLogId pageNbr =
log.LogTrace "Page.findPageOfPages"
Custom.list
$"{selectWithCriteria Table.Page}
ORDER BY LOWER(data->>'{nameof Page.Empty.Title}')
LIMIT @pageSize OFFSET @toSkip"
$"{sortedPages} LIMIT @pageSize OFFSET @toSkip"
[ webLogContains webLogId; "@pageSize", Sql.int 26; "@toSkip", Sql.int ((pageNbr - 1) * 25) ]
(fun row -> { fromData<Page> row with Metadata = []; PriorPermalinks = [] })

View File

@ -84,9 +84,9 @@ type PostgresPostData(log: ILogger) =
match! postExists postId webLogId with
| true ->
do! Custom.nonQuery
$"""DELETE FROM {Table.PostComment} WHERE {Query.whereDataContains "@criteria"};
DELETE FROM {Table.PostRevision} WHERE post_id = @id;
DELETE FROM {Table.Post} WHERE {Query.whereById "@id"}"""
$"""{Query.delete Table.PostComment} WHERE {Query.whereDataContains "@criteria"};
{Query.delete Table.PostRevision} WHERE post_id = @id;
{Query.delete Table.Post} WHERE {Query.whereById "@id"}"""
[ idParam postId; jsonParam "@criteria" {| PostId = postId |} ]
return true
| false -> return false
@ -97,21 +97,19 @@ type PostgresPostData(log: ILogger) =
log.LogTrace "Post.findCurrentPermalink"
if List.isEmpty permalinks then return None
else
let linkSql, linkParam = arrayContains (nameof Post.Empty.PriorPermalinks) string permalinks
return!
Custom.single
$"""SELECT data ->> '{nameof Post.Empty.Permalink}' AS permalink
FROM {Table.Post}
WHERE {Query.whereDataContains "@criteria"}
AND {linkSql}"""
[ webLogContains webLogId; linkParam ]
Map.toPermalink
let linkField = Field.InArray (nameof Post.Empty.PriorPermalinks) Table.Post (List.map string permalinks)
let query =
(Query.statementWhere
(Query.find Table.Post)
$"""{Query.whereDataContains "@criteria"} AND {Query.whereByFields All [ linkField ]}""")
.Replace("SELECT data", $"SELECT data->>'{nameof Post.Empty.Permalink}' AS permalink")
return! Custom.single query (addFieldParams [ linkField ] [ webLogContains webLogId ]) Map.toPermalink
}
/// Get all complete posts for the given web log
let findFullByWebLog webLogId = backgroundTask {
log.LogTrace "Post.findFullByWebLog"
let! posts = Document.findByWebLog<Post> Table.Post webLogId
let! posts = Find.byContains<Post> Table.Post (webLogDoc webLogId)
let! revisions = Revisions.findByWebLog Table.PostRevision Table.Post PostId webLogId
return
posts
@ -122,23 +120,26 @@ type PostgresPostData(log: ILogger) =
/// Get a page of categorized posts for the given web log (excludes revisions)
let findPageOfCategorizedPosts webLogId (categoryIds: CategoryId list) pageNbr postsPerPage =
log.LogTrace "Post.findPageOfCategorizedPosts"
let catSql, catParam = arrayContains (nameof Post.Empty.CategoryIds) string categoryIds
let catIdField = Field.InArray (nameof Post.Empty.CategoryIds) Table.Post (List.map string categoryIds)
Custom.list
$"{selectWithCriteria Table.Post}
AND {catSql}
ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
[ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}; catParam ]
$"""{selectWithCriteria Table.Post}
AND {Query.whereByFields All [ catIdField ]}
{Query.orderBy [ Field.Named $"{nameof Post.Empty.PublishedOn} DESC" ] PostgreSQL}
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
(addFieldParams [ catIdField] [ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |} ])
postWithoutLinks
/// Get a page of posts for the given web log (excludes text and revisions)
let findPageOfPosts webLogId pageNbr postsPerPage =
log.LogTrace "Post.findPageOfPosts"
let order =
Query.orderBy
[ Field.Named $"{nameof Post.Empty.PublishedOn} DESC NULLS FIRST"
Field.Named (nameof Post.Empty.UpdatedOn) ]
PostgreSQL
Custom.list
$"{selectWithCriteria Table.Post}
ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC NULLS FIRST,
data ->> '{nameof Post.Empty.UpdatedOn}'
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
$"{selectWithCriteria Table.Post}{order}
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
[ webLogContains webLogId ]
postWithoutText
@ -146,9 +147,9 @@ type PostgresPostData(log: ILogger) =
let findPageOfPublishedPosts webLogId pageNbr postsPerPage =
log.LogTrace "Post.findPageOfPublishedPosts"
Custom.list
$"{selectWithCriteria Table.Post}
ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
$"""{selectWithCriteria Table.Post}
{Query.orderBy [ Field.Named $"{nameof Post.Empty.PublishedOn} DESC" ] PostgreSQL}
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
[ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |} ]
postWithoutLinks
@ -156,10 +157,10 @@ type PostgresPostData(log: ILogger) =
let findPageOfTaggedPosts webLogId (tag: string) pageNbr postsPerPage =
log.LogTrace "Post.findPageOfTaggedPosts"
Custom.list
$"{selectWithCriteria Table.Post}
AND data['{nameof Post.Empty.Tags}'] @> @tag
ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
$"""{selectWithCriteria Table.Post}
AND data['{nameof Post.Empty.Tags}'] @> @tag
{Query.orderBy [ Field.Named $"{nameof Post.Empty.PublishedOn} DESC" ] PostgreSQL}
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
[ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}; jsonParam "@tag" [| tag |] ]
postWithoutLinks
@ -170,10 +171,10 @@ type PostgresPostData(log: ILogger) =
[ jsonParam "@criteria" {| webLogDoc webLogId with Status = Published |}
"@publishedOn", Sql.timestamptz (publishedOn.ToDateTimeOffset()) ]
let query op direction =
$"{selectWithCriteria Table.Post}
AND (data ->> '{nameof Post.Empty.PublishedOn}')::timestamp with time zone %s{op} @publishedOn
ORDER BY data ->> '{nameof Post.Empty.PublishedOn}' %s{direction}
LIMIT 1"
$"""{selectWithCriteria Table.Post}
AND (data->>'{nameof Post.Empty.PublishedOn}')::timestamp with time zone %s{op} @publishedOn
{Query.orderBy [ Field.Named $"{nameof Post.Empty.PublishedOn} %s{direction}" ] PostgreSQL}
LIMIT 1"""
let! older = Custom.list (query "<" "DESC") (queryParams ()) postWithoutLinks
let! newer = Custom.list (query ">" "") (queryParams ()) postWithoutLinks
return List.tryHead older, List.tryHead newer

View File

@ -33,18 +33,15 @@ type PostgresTagMapData(log: ILogger) =
/// Get all tag mappings for the given web log
let findByWebLog webLogId =
log.LogTrace "TagMap.findByWebLog"
Custom.list
$"{selectWithCriteria Table.TagMap} ORDER BY data ->> 'tag'"
[ webLogContains webLogId ]
fromData<TagMap>
Find.byContainsOrdered<TagMap> Table.TagMap (webLogDoc webLogId) [ Field.Named (nameof TagMap.Empty.Tag) ]
/// Find any tag mappings in a list of tags for the given web log
let findMappingForTags tags webLogId =
let findMappingForTags (tags: string list) webLogId =
log.LogTrace "TagMap.findMappingForTags"
let tagSql, tagParam = arrayContains (nameof TagMap.Empty.Tag) id tags
let tagField = Field.InArray (nameof TagMap.Empty.Tag) Table.TagMap tags
Custom.list
$"{selectWithCriteria Table.TagMap} AND {tagSql}"
[ webLogContains webLogId; tagParam ]
$"{selectWithCriteria Table.TagMap} AND {Query.whereByFields All [ tagField ]}"
(addFieldParams [ tagField ] [ webLogContains webLogId ])
fromData<TagMap>
/// Save a tag mapping

View File

@ -17,11 +17,11 @@ type PostgresThemeData(log: ILogger) =
/// Retrieve all themes (except 'admin'; excludes template text)
let all () =
log.LogTrace "Theme.all"
let fields = [ Field.NotEqual (nameof Theme.Empty.Id) "admin" ]
Custom.list
$"{Query.selectFromTable Table.Theme}
WHERE data ->> '{nameof Theme.Empty.Id}' <> 'admin'
ORDER BY data ->> '{nameof Theme.Empty.Id}'"
[]
(Query.byFields (Query.find Table.Theme) Any fields
+ Query.orderBy [ Field.Named (nameof Theme.Empty.Id) ] PostgreSQL)
(addFieldParams fields [])
withoutTemplateText
/// Does a given theme exist?
@ -37,7 +37,7 @@ type PostgresThemeData(log: ILogger) =
/// Find a theme by its ID (excludes the text of templates)
let findByIdWithoutText (themeId: ThemeId) =
log.LogTrace "Theme.findByIdWithoutText"
Custom.single (Query.Find.byId Table.Theme) [ idParam themeId ] withoutTemplateText
Custom.single (Query.byId (Query.find Table.Theme) (string themeId)) [ idParam themeId ] withoutTemplateText
/// Delete a theme by its ID
let delete themeId = backgroundTask {
@ -45,8 +45,8 @@ type PostgresThemeData(log: ILogger) =
match! exists themeId with
| true ->
do! Custom.nonQuery
$"""DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id;
DELETE FROM {Table.Theme} WHERE {Query.whereById "@id"}"""
$"""{Query.delete Table.ThemeAsset} WHERE theme_id = @id;
{Query.delete Table.Theme} WHERE {Query.whereById "@id"}"""
[ idParam themeId ]
return true
| false -> return false
@ -77,7 +77,7 @@ type PostgresThemeAssetData(log: ILogger) =
/// Delete all assets for the given theme
let deleteByTheme (themeId: ThemeId) =
log.LogTrace "ThemeAsset.deleteByTheme"
Custom.nonQuery $"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id" [ idParam themeId ]
Custom.nonQuery $"{Query.delete Table.ThemeAsset} WHERE theme_id = @id" [ idParam themeId ]
/// Find a theme asset by its ID
let findById assetId =

View File

@ -23,22 +23,22 @@ type PostgresWebLogData(log: ILogger) =
let delete webLogId =
log.LogTrace "WebLog.delete"
Custom.nonQuery
$"""DELETE FROM {Table.PostComment}
WHERE data ->> '{nameof Comment.Empty.PostId}'
IN (SELECT data ->> '{nameof Post.Empty.Id}'
FROM {Table.Post}
WHERE {Query.whereDataContains "@criteria"});
DELETE FROM {Table.PostRevision}
WHERE post_id IN (SELECT data ->> 'Id' FROM {Table.Post} WHERE {Query.whereDataContains "@criteria"});
DELETE FROM {Table.PageRevision}
WHERE page_id IN (SELECT data ->> 'Id' FROM {Table.Page} WHERE {Query.whereDataContains "@criteria"});
{Query.Delete.byContains Table.Post};
{Query.Delete.byContains Table.Page};
{Query.Delete.byContains Table.Category};
{Query.Delete.byContains Table.TagMap};
{Query.Delete.byContains Table.WebLogUser};
DELETE FROM {Table.Upload} WHERE web_log_id = @webLogId;
DELETE FROM {Table.WebLog} WHERE {Query.whereById "@webLogId"}"""
$"""{Query.delete Table.PostComment}
WHERE data->>'{nameof Comment.Empty.PostId}'
IN (SELECT data->>'{nameof Post.Empty.Id}'
FROM {Table.Post}
WHERE {Query.whereDataContains "@criteria"});
{Query.delete Table.PostRevision}
WHERE post_id IN (SELECT data->>'Id' FROM {Table.Post} WHERE {Query.whereDataContains "@criteria"});
{Query.delete Table.PageRevision}
WHERE page_id IN (SELECT data->>'Id' FROM {Table.Page} WHERE {Query.whereDataContains "@criteria"});
{Query.byContains (Query.delete Table.Post)};
{Query.byContains (Query.delete Table.Page)};
{Query.byContains (Query.delete Table.Category)};
{Query.byContains (Query.delete Table.TagMap)};
{Query.byContains (Query.delete Table.WebLogUser)};
{Query.delete Table.Upload} WHERE web_log_id = @webLogId;
{Query.delete Table.WebLog} WHERE data->>'Id' = @webLogId"""
[ webLogIdParam webLogId; webLogContains webLogId ]
/// Find a web log by its host (URL base)

View File

@ -49,19 +49,17 @@ type PostgresWebLogUserData(log: ILogger) =
/// Get all users for the given web log
let findByWebLog webLogId =
log.LogTrace "WebLogUser.findByWebLog"
Custom.list
$"{selectWithCriteria Table.WebLogUser} ORDER BY LOWER(data ->> '{nameof WebLogUser.Empty.PreferredName}')"
[ webLogContains webLogId ]
fromData<WebLogUser>
Find.byContainsOrdered<WebLogUser>
Table.WebLogUser (webLogDoc webLogId) [ Field.Named $"i:{nameof WebLogUser.Empty.PreferredName}" ]
/// Find the names of users by their IDs for the given web log
let findNames webLogId (userIds: WebLogUserId list) = backgroundTask {
log.LogTrace "WebLogUser.findNames"
let idSql, idParams = inClause $"AND data ->> '{nameof WebLogUser.Empty.Id}'" "id" userIds
let idField = Field.In (nameof WebLogUser.Empty.Id) (List.map string userIds)
let! users =
Custom.list
$"{selectWithCriteria Table.WebLogUser} {idSql}"
(webLogContains webLogId :: idParams)
$"{selectWithCriteria Table.WebLogUser} AND {Query.whereByFields All [ idField ]}"
(addFieldParams [ idField ] [ webLogContains webLogId ])
fromData<WebLogUser>
return users |> List.map (fun u -> { Name = string u.Id; Value = u.DisplayName })
}

View File

@ -25,7 +25,7 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
// Theme tables
if needsTable Table.Theme then
Query.Definition.ensureTable Table.Theme
Query.Definition.ensureKey Table.Theme
Query.Definition.ensureKey Table.Theme PostgreSQL
if needsTable Table.ThemeAsset then
$"CREATE TABLE {Table.ThemeAsset} (
theme_id TEXT NOT NULL,
@ -37,28 +37,28 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
// Web log table
if needsTable Table.WebLog then
Query.Definition.ensureTable Table.WebLog
Query.Definition.ensureKey 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
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
Query.Definition.ensureKey Table.WebLogUser PostgreSQL
Query.Definition.ensureDocumentIndex Table.WebLogUser Optimized
// Page tables
if needsTable Table.Page then
Query.Definition.ensureTable Table.Page
Query.Definition.ensureKey Table.Page
Query.Definition.ensureIndexOn Table.Page "author" [ nameof Page.Empty.AuthorId ]
Query.Definition.ensureKey Table.Page PostgreSQL
Query.Definition.ensureIndexOn Table.Page "author" [ nameof Page.Empty.AuthorId ] PostgreSQL
Query.Definition.ensureIndexOn
Table.Page "permalink" [ nameof Page.Empty.WebLogId; nameof Page.Empty.Permalink ]
Table.Page "permalink" [ nameof Page.Empty.WebLogId; nameof Page.Empty.Permalink ] PostgreSQL
if needsTable Table.PageRevision then
$"CREATE TABLE {Table.PageRevision} (
page_id TEXT NOT NULL,
@ -69,14 +69,15 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
// Post tables
if needsTable Table.Post then
Query.Definition.ensureTable Table.Post
Query.Definition.ensureKey Table.Post
Query.Definition.ensureIndexOn Table.Post "author" [ nameof Post.Empty.AuthorId ]
Query.Definition.ensureKey Table.Post PostgreSQL
Query.Definition.ensureIndexOn Table.Post "author" [ nameof Post.Empty.AuthorId ] PostgreSQL
Query.Definition.ensureIndexOn
Table.Post "permalink" [ nameof Post.Empty.WebLogId; nameof Post.Empty.Permalink ]
Table.Post "permalink" [ nameof Post.Empty.WebLogId; nameof Post.Empty.Permalink ] PostgreSQL
Query.Definition.ensureIndexOn
Table.Post
"status"
[ nameof Post.Empty.WebLogId; nameof Post.Empty.Status; nameof Post.Empty.UpdatedOn ]
PostgreSQL
$"CREATE INDEX idx_post_category ON {Table.Post} USING GIN ((data['{nameof Post.Empty.CategoryIds}']))"
$"CREATE INDEX idx_post_tag ON {Table.Post} USING GIN ((data['{nameof Post.Empty.Tags}']))"
if needsTable Table.PostRevision then
@ -87,13 +88,13 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
PRIMARY KEY (post_id, as_of))"
if needsTable Table.PostComment then
Query.Definition.ensureTable Table.PostComment
Query.Definition.ensureKey Table.PostComment
Query.Definition.ensureIndexOn Table.PostComment "post" [ nameof Comment.Empty.PostId ]
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
Query.Definition.ensureKey Table.TagMap PostgreSQL
Query.Definition.ensureDocumentIndex Table.TagMap Optimized
// Uploaded file table
@ -153,7 +154,8 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
Table.WebLogUser ]
Utils.Migration.logStep log migration "Adding unique indexes on ID fields"
do! Custom.nonQuery (tables |> List.map Query.Definition.ensureKey |> String.concat "; ") []
do! Custom.nonQuery
(tables |> List.map (fun it -> Query.Definition.ensureKey it PostgreSQL) |> String.concat "; ") []
Utils.Migration.logStep log migration "Removing constraints"
let fkToDrop =
@ -187,24 +189,25 @@ type PostgresData(log: ILogger<PostgresData>, ser: JsonSerializer) =
Utils.Migration.logStep log migration "Adding new indexes"
let newIdx =
[ yield! tables |> List.map Query.Definition.ensureKey
[ yield! tables |> List.map (fun it -> Query.Definition.ensureKey it PostgreSQL)
Query.Definition.ensureDocumentIndex Table.Category Optimized
Query.Definition.ensureDocumentIndex Table.TagMap Optimized
Query.Definition.ensureDocumentIndex Table.WebLog Optimized
Query.Definition.ensureDocumentIndex Table.WebLogUser Optimized
Query.Definition.ensureIndexOn Table.Page "author" [ nameof Page.Empty.AuthorId ]
Query.Definition.ensureIndexOn Table.Page "author" [ nameof Page.Empty.AuthorId ] PostgreSQL
Query.Definition.ensureIndexOn
Table.Page "permalink" [ nameof Page.Empty.WebLogId; nameof Page.Empty.Permalink ]
Query.Definition.ensureIndexOn Table.Post "author" [ nameof Post.Empty.AuthorId ]
Table.Page "permalink" [ nameof Page.Empty.WebLogId; nameof Page.Empty.Permalink ] PostgreSQL
Query.Definition.ensureIndexOn Table.Post "author" [ nameof Post.Empty.AuthorId ] PostgreSQL
Query.Definition.ensureIndexOn
Table.Post "permalink" [ nameof Post.Empty.WebLogId; nameof Post.Empty.Permalink ]
Table.Post "permalink" [ nameof Post.Empty.WebLogId; nameof Post.Empty.Permalink ] PostgreSQL
Query.Definition.ensureIndexOn
Table.Post
"status"
[ nameof Post.Empty.WebLogId; nameof Post.Empty.Status; nameof Post.Empty.UpdatedOn ]
PostgreSQL
$"CREATE INDEX idx_post_category ON {Table.Post} USING GIN ((data['{nameof Post.Empty.CategoryIds}']))"
$"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 ] ]
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"

View File

@ -16,22 +16,23 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge
let parentIdField = nameof Category.Empty.ParentId
/// Count all categories for the given web log
let countAll webLogId =
let countAll webLogId = backgroundTask {
log.LogTrace "Category.countAll"
Document.countByWebLog Table.Category webLogId conn
let! count = conn.countByFields Table.Category Any [ webLogField webLogId ]
return int count
}
/// Count all top-level categories for the given web log
let countTopLevel webLogId =
let countTopLevel webLogId = backgroundTask {
log.LogTrace "Category.countTopLevel"
conn.customScalar
$"{Document.Query.countByWebLog Table.Category} AND data ->> '{parentIdField}' IS NULL"
[ webLogParam webLogId ]
(toCount >> int)
let! count = conn.countByFields Table.Category All [ webLogField webLogId; Field.NotExists parentIdField ]
return int count
}
/// Find all categories for the given web log
let findByWebLog webLogId =
log.LogTrace "Category.findByWebLog"
Document.findByWebLog<Category> Table.Category webLogId conn
conn.findByFields<Category> Table.Category Any [ webLogField webLogId ]
/// Retrieve all categories for the given web log in a DotLiquid-friendly format
let findAllForView webLogId = backgroundTask {
@ -42,20 +43,18 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge
ordered
|> Seq.map (fun it -> backgroundTask {
// Parent category post counts include posts in subcategories
let catSql, catParams =
let childField =
ordered
|> Seq.filter (fun cat -> cat.ParentNames |> Array.contains it.Name)
|> Seq.map _.Id
|> Seq.append (Seq.singleton it.Id)
|> List.ofSeq
|> inJsonArray Table.Post (nameof Post.Empty.CategoryIds) "catId"
let query = $"""
SELECT COUNT(DISTINCT data ->> '{nameof Post.Empty.Id}')
FROM {Table.Post}
WHERE {Document.Query.whereByWebLog}
AND {Query.whereByField (Field.EQ (nameof Post.Empty.Status) "") $"'{string Published}'"}
AND {catSql}"""
let! postCount = conn.customScalar query (webLogParam webLogId :: catParams) toCount
|> Field.InArray (nameof Post.Empty.CategoryIds) Table.Post
let fields =
[ webLogField webLogId; Field.Equal (nameof Post.Empty.Status) (string Published); childField ]
let query =
(Query.statementWhere (Query.count Table.Post) (Query.whereByFields All fields))
.Replace("(*)", $"(DISTINCT data->>'{nameof Post.Empty.Id}')")
let! postCount = conn.customScalar query (addFieldParams fields []) toCount
return it.Id, int postCount
})
|> Task.WhenAll
@ -69,9 +68,9 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge
}
/// Find a category by its ID for the given web log
let findById catId webLogId =
let findById (catId: CategoryId) webLogId =
log.LogTrace "Category.findById"
Document.findByIdAndWebLog<CategoryId, Category> Table.Category catId webLogId conn
conn.findFirstByFields<Category> Table.Category All [ idField catId; webLogField webLogId ]
/// Delete a category
let delete catId webLogId = backgroundTask {
@ -79,24 +78,22 @@ type SQLiteCategoryData(conn: SqliteConnection, ser: JsonSerializer, log: ILogge
match! findById catId webLogId with
| Some cat ->
// Reassign any children to the category's parent category
let! children = conn.countByField Table.Category (Field.EQ parentIdField (string catId))
let! children = conn.countByFields Table.Category Any [ Field.Equal parentIdField (string catId) ]
if children > 0L then
let parent = Field.EQ parentIdField (string catId)
let parent = [ Field.Equal parentIdField (string catId) ]
match cat.ParentId with
| Some _ -> do! conn.patchByField Table.Category parent {| ParentId = cat.ParentId |}
| None -> do! conn.removeFieldsByField Table.Category parent [ parentIdField ]
| Some _ -> do! conn.patchByFields Table.Category Any parent {| ParentId = cat.ParentId |}
| None -> do! conn.removeFieldsByFields Table.Category Any parent [ parentIdField ]
// Delete the category off all posts where it is assigned, and the category itself
let catIdField = nameof Post.Empty.CategoryIds
let fields = [ webLogField webLogId; Field.InArray catIdField Table.Post [ string catId ] ]
let query =
(Query.statementWhere (Query.find Table.Post) (Query.whereByFields All fields))
.Replace("SELECT data", $"SELECT data->>'{nameof Post.Empty.Id}', data->'{catIdField}'")
let! posts =
conn.customList
$"SELECT data ->> '{nameof Post.Empty.Id}', data -> '{catIdField}'
FROM {Table.Post}
WHERE {Document.Query.whereByWebLog}
AND EXISTS
(SELECT 1
FROM json_each({Table.Post}.data -> '{catIdField}')
WHERE json_each.value = @id)"
[ idParam catId; webLogParam webLogId ]
query
(addFieldParams fields [])
(fun rdr -> rdr.GetString 0, Utils.deserialize<string list> ser (rdr.GetString 1))
for postId, cats in posts do
do! conn.patchById

View File

@ -5,55 +5,55 @@ module MyWebLog.Data.SQLite.SQLiteHelpers
/// The table names used in the SQLite implementation
[<RequireQualifiedAccess>]
module Table =
/// Categories
[<Literal>]
let Category = "category"
/// Database Version
[<Literal>]
let DbVersion = "db_version"
/// Pages
[<Literal>]
let Page = "page"
/// Page Revisions
[<Literal>]
let PageRevision = "page_revision"
/// Posts
[<Literal>]
let Post = "post"
/// Post Comments
[<Literal>]
let PostComment = "post_comment"
/// Post Revisions
[<Literal>]
let PostRevision = "post_revision"
/// Tag/URL Mappings
[<Literal>]
let TagMap = "tag_map"
/// Themes
[<Literal>]
let Theme = "theme"
/// Theme Assets
[<Literal>]
let ThemeAsset = "theme_asset"
/// Uploads
[<Literal>]
let Upload = "upload"
/// Web Logs
[<Literal>]
let WebLog = "web_log"
/// Users
[<Literal>]
let WebLogUser = "web_log_user"
@ -82,111 +82,78 @@ let instantParam =
let maybeInstant =
Option.map instantParam >> maybe
/// Create the SQL and parameters for an EXISTS applied to a JSON array
let inJsonArray<'T> table jsonField paramName (items: 'T list) =
if List.isEmpty items then "", []
else
let mutable idx = 0
items
|> List.skip 1
|> List.fold (fun (itemS, itemP) it ->
idx <- idx + 1
$"{itemS}, @%s{paramName}{idx}", (SqliteParameter($"@%s{paramName}{idx}", string it) :: itemP))
(Seq.ofList items
|> Seq.map (fun it -> $"(@%s{paramName}0", [ SqliteParameter($"@%s{paramName}0", string it) ])
|> Seq.head)
|> function
sql, ps ->
$"EXISTS (SELECT 1 FROM json_each(%s{table}.data, '$.%s{jsonField}') WHERE value IN {sql}))", ps
/// Create the SQL and parameters for an IN clause
let inClause<'T> colNameAndPrefix paramName (valueFunc: 'T -> string) (items: 'T list) =
if List.isEmpty items then "", []
else
let mutable idx = 0
items
|> List.skip 1
|> List.fold (fun (itemS, itemP) it ->
idx <- idx + 1
$"{itemS}, @%s{paramName}{idx}", (SqliteParameter ($"@%s{paramName}{idx}", valueFunc it) :: itemP))
(Seq.ofList items
|> Seq.map (fun it ->
$"%s{colNameAndPrefix} IN (@%s{paramName}0", [ SqliteParameter ($"@%s{paramName}0", valueFunc it) ])
|> Seq.head)
|> function sql, ps -> $"{sql})", ps
/// Functions to map domain items from a data reader
module Map =
open System.IO
/// Get a boolean value from a data reader
let getBoolean col (rdr: SqliteDataReader) = rdr.GetBoolean(rdr.GetOrdinal col)
/// Get a date/time value from a data reader
let getDateTime col (rdr: SqliteDataReader) = rdr.GetDateTime(rdr.GetOrdinal col)
/// Get a Guid value from a data reader
let getGuid col (rdr: SqliteDataReader) = rdr.GetGuid(rdr.GetOrdinal col)
/// Get an int value from a data reader
let getInt col (rdr: SqliteDataReader) = rdr.GetInt32(rdr.GetOrdinal col)
/// Get a long (64-bit int) value from a data reader
let getLong col (rdr: SqliteDataReader) = rdr.GetInt64(rdr.GetOrdinal col)
/// Get a BLOB stream value from a data reader
let getStream col (rdr: SqliteDataReader) = rdr.GetStream(rdr.GetOrdinal col)
/// Get a string value from a data reader
let getString col (rdr: SqliteDataReader) = rdr.GetString(rdr.GetOrdinal col)
/// Parse an Instant from the given value
let parseInstant value =
match InstantPattern.General.Parse value with
| it when it.Success -> it.Value
| it -> raise it.Exception
/// Get an Instant value from a data reader
let getInstant col rdr =
getString col rdr |> parseInstant
/// Get a timespan value from a data reader
let getTimeSpan col (rdr: SqliteDataReader) = rdr.GetTimeSpan(rdr.GetOrdinal col)
/// Get a possibly null boolean value from a data reader
let tryBoolean col (rdr: SqliteDataReader) =
if rdr.IsDBNull(rdr.GetOrdinal col) then None else Some (getBoolean col rdr)
/// Get a possibly null date/time value from a data reader
let tryDateTime col (rdr: SqliteDataReader) =
if rdr.IsDBNull(rdr.GetOrdinal col) then None else Some (getDateTime col rdr)
/// Get a possibly null Guid value from a data reader
let tryGuid col (rdr: SqliteDataReader) =
if rdr.IsDBNull(rdr.GetOrdinal col) then None else Some (getGuid col rdr)
/// Get a possibly null int value from a data reader
let tryInt col (rdr: SqliteDataReader) =
if rdr.IsDBNull(rdr.GetOrdinal col) then None else Some (getInt col rdr)
/// Get a possibly null string value from a data reader
let tryString col (rdr: SqliteDataReader) =
if rdr.IsDBNull(rdr.GetOrdinal col) then None else Some (getString col rdr)
/// Get a possibly null timespan value from a data reader
let tryTimeSpan col (rdr: SqliteDataReader) =
if rdr.IsDBNull(rdr.GetOrdinal col) then None else Some (getTimeSpan col rdr)
/// Create a permalink from the current row in the given data reader
let toPermalink rdr = getString "permalink" rdr |> Permalink
/// Create a revision from the current row in the given data reader
let toRevision rdr : Revision =
{ AsOf = getInstant "as_of" rdr
Text = getString "revision_text" rdr |> MarkupText.Parse }
/// Create a theme asset from the current row in the given data reader
let toThemeAsset includeData rdr : ThemeAsset =
let assetData =
@ -200,7 +167,7 @@ module Map =
{ Id = ThemeAssetId (ThemeId (getString "theme_id" rdr), getString "path" rdr)
UpdatedOn = getInstant "updated_on" rdr
Data = assetData }
/// Create an uploaded file from the current row in the given data reader
let toUpload includeData rdr : Upload =
let data =
@ -218,90 +185,57 @@ module Map =
Data = data }
open BitBadger.Documents
/// Create a named parameter
let sqlParam name (value: obj) =
SqliteParameter(name, value)
/// Create a web log ID parameter
let webLogParam (webLogId: WebLogId) =
sqlParam "@webLogId" (string webLogId)
/// Create a field for an ID value
let idField<'T> (idValue: 'T) =
{ Field.Equal "Id" (string idValue) with ParameterName = Some "@id" }
/// Create a web log field
let webLogField (webLogId: WebLogId) =
{ Field.Equal "WebLogId" (string webLogId) with ParameterName = Some "@webLogId" }
open BitBadger.Documents
open BitBadger.Documents.Sqlite
open BitBadger.Documents.Sqlite.WithConn
/// Functions for manipulating documents
module Document =
/// Queries to assist with document manipulation
module Query =
/// Fragment to add a web log ID condition to a WHERE clause (parameter @webLogId)
let whereByWebLog =
Query.whereByField (Field.EQ "WebLogId" "") "@webLogId"
/// A SELECT query to count documents for a given web log ID
let countByWebLog table =
$"{Query.Count.all table} WHERE {whereByWebLog}"
/// A query to select from a table by the document's ID and its web log ID
let selectByIdAndWebLog table =
$"{Query.Find.byId table} AND {whereByWebLog}"
/// A query to select from a table by its web log ID
let selectByWebLog table =
$"{Query.selectFromTable table} WHERE {whereByWebLog}"
/// Count documents for the given web log ID
let countByWebLog table (webLogId: WebLogId) conn = backgroundTask {
let! count = Count.byField table (Field.EQ "WebLogId" (string webLogId)) conn
return int count
}
/// Find a document by its ID and web log ID
let findByIdAndWebLog<'TKey, 'TDoc> table (key: 'TKey) webLogId conn =
Custom.single (Query.selectByIdAndWebLog table) [ idParam key; webLogParam webLogId ] fromData<'TDoc> conn
/// Find documents for the given web log
let findByWebLog<'TDoc> table (webLogId: WebLogId) conn =
Find.byField<'TDoc> table (Field.EQ "WebLogId" (string webLogId)) conn
/// Functions to support revisions
module Revisions =
/// Find all revisions for the given entity
let findByEntityId<'TKey> revTable entityTable (key: 'TKey) conn =
Custom.list
let findByEntityId<'TKey> revTable entityTable (key: 'TKey) (conn: SqliteConnection) =
conn.customList
$"SELECT as_of, revision_text FROM %s{revTable} WHERE %s{entityTable}_id = @id ORDER BY as_of DESC"
[ idParam key ]
Map.toRevision
conn
/// Find all revisions for all posts for the given web log
let findByWebLog<'TKey> revTable entityTable (keyFunc: string -> 'TKey) webLogId conn =
Custom.list
let findByWebLog<'TKey> revTable entityTable (keyFunc: string -> 'TKey) webLogId (conn: SqliteConnection) =
conn.customList
$"SELECT pr.*
FROM %s{revTable} pr
INNER JOIN %s{entityTable} p ON p.data ->> 'Id' = pr.{entityTable}_id
WHERE p.{Document.Query.whereByWebLog}
INNER JOIN %s{entityTable} p ON p.data->>'Id' = pr.{entityTable}_id
WHERE p.{Query.whereByFields Any [ webLogField webLogId ]}
ORDER BY as_of DESC"
[ webLogParam webLogId ]
(fun rdr -> keyFunc (Map.getString $"{entityTable}_id" rdr), Map.toRevision rdr)
conn
/// Update a page or post's revisions
let update<'TKey> revTable entityTable (key: 'TKey) oldRevs newRevs conn = backgroundTask {
let update<'TKey> revTable entityTable (key: 'TKey) oldRevs newRevs (conn: SqliteConnection) = backgroundTask {
let toDelete, toAdd = Utils.diffRevisions oldRevs newRevs
for delRev in toDelete do
do! Custom.nonQuery
do! conn.customNonQuery
$"DELETE FROM %s{revTable} WHERE %s{entityTable}_id = @id AND as_of = @asOf"
[ idParam key; sqlParam "@asOf" (instantParam delRev.AsOf) ]
conn
for addRev in toAdd do
do! Custom.nonQuery
do! conn.customNonQuery
$"INSERT INTO {revTable} VALUES (@id, @asOf, @text)"
[ idParam key; sqlParam "asOf" (instantParam addRev.AsOf); sqlParam "@text" (string addRev.Text) ]
conn
}

View File

@ -17,8 +17,10 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) =
/// The JSON field name for the "is in page list" flag
let pgListName = nameof Page.Empty.IsInPageList
/// The JSON field for the title of the page
let titleField = $"data ->> '{nameof Page.Empty.Title}'"
/// Query to return pages sorted by title
let sortedPages fields =
Query.byFields (Query.find Table.Page) All fields
+ Query.orderBy [ Field.Named $"i:{nameof Page.Empty.Title}" ] SQLite
// SUPPORT FUNCTIONS
@ -50,36 +52,38 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) =
/// Get all pages for a web log (without text, metadata, revisions, or prior permalinks)
let all webLogId =
log.LogTrace "Page.all"
let field = [ webLogField webLogId ]
conn.customList
$"{Query.selectFromTable Table.Page} WHERE {Document.Query.whereByWebLog} ORDER BY LOWER({titleField})"
[ webLogParam webLogId ]
(sortedPages field)
(addFieldParams field [])
(fun rdr -> { fromData<Page> rdr with Text = ""; Metadata = []; PriorPermalinks = [] })
/// Count all pages for the given web log
let countAll webLogId =
let countAll webLogId = backgroundTask {
log.LogTrace "Page.countAll"
Document.countByWebLog Table.Page webLogId conn
let! count = conn.countByFields Table.Page Any [ webLogField webLogId ]
return int count
}
/// Count all pages shown in the page list for the given web log
let countListed webLogId =
let countListed webLogId = backgroundTask {
log.LogTrace "Page.countListed"
conn.customScalar
$"""{Document.Query.countByWebLog Table.Page} AND {Query.whereByField (Field.EQ pgListName "") "true"}"""
[ webLogParam webLogId ]
(toCount >> int)
let! count = conn.countByFields Table.Page All [ webLogField webLogId; Field.Equal pgListName true ]
return int count
}
/// Find a page by its ID (without revisions and prior permalinks)
let findById pageId webLogId = backgroundTask {
let findById (pageId: PageId) webLogId = backgroundTask {
log.LogTrace "Page.findById"
match! Document.findByIdAndWebLog<PageId, Page> Table.Page pageId webLogId conn with
match! conn.findFirstByFields<Page> Table.Page All [ idField pageId; webLogField webLogId ] with
| Some page -> return Some { page with PriorPermalinks = [] }
| None -> return None
}
/// Find a complete page by its ID
let findFullById pageId webLogId = backgroundTask {
let findFullById (pageId: PageId) webLogId = backgroundTask {
log.LogTrace "Page.findFullById"
match! Document.findByIdAndWebLog<PageId, Page> Table.Page pageId webLogId conn with
match! conn.findFirstByFields<Page> Table.Page All [ idField pageId; webLogField webLogId ] with
| Some page ->
let! page = appendPageRevisions page
return Some page
@ -93,7 +97,8 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) =
match! findById pageId webLogId with
| Some _ ->
do! conn.customNonQuery
$"DELETE FROM {Table.PageRevision} WHERE page_id = @id; {Query.Delete.byId Table.Page}"
$"{Query.delete Table.PageRevision} WHERE page_id = @id;
{Query.byId (Query.delete Table.Page) (string pageId)}"
[ idParam pageId ]
return true
| None -> return false
@ -102,27 +107,25 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) =
/// Find a page by its permalink for the given web log
let findByPermalink (permalink: Permalink) webLogId =
log.LogTrace "Page.findByPermalink"
let linkParam = Field.EQ linkName (string permalink)
let fields = [ webLogField webLogId; Field.Equal linkName (string permalink) ]
conn.customSingle
$"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField linkParam "@link"}"""
(addFieldParam "@link" linkParam [ webLogParam webLogId ])
pageWithoutLinks
(Query.byFields (Query.find Table.Page) All fields) (addFieldParams fields []) pageWithoutLinks
/// Find the current permalink within a set of potential prior permalinks for the given web log
let findCurrentPermalink (permalinks: Permalink list) webLogId =
log.LogTrace "Page.findCurrentPermalink"
let linkSql, linkParams = inJsonArray Table.Page (nameof Page.Empty.PriorPermalinks) "link" permalinks
conn.customSingle
$"SELECT data ->> '{linkName}' AS permalink
FROM {Table.Page}
WHERE {Document.Query.whereByWebLog} AND {linkSql}"
(webLogParam webLogId :: linkParams)
Map.toPermalink
let fields =
[ webLogField webLogId
Field.InArray (nameof Page.Empty.PriorPermalinks) Table.Page (List.map string permalinks) ]
let query =
(Query.statementWhere (Query.find Table.Page) (Query.whereByFields All fields))
.Replace("SELECT data", $"SELECT data->>'{linkName}' AS permalink")
conn.customSingle query (addFieldParams fields []) Map.toPermalink
/// Get all complete pages for the given web log
let findFullByWebLog webLogId = backgroundTask {
log.LogTrace "Page.findFullByWebLog"
let! pages = Document.findByWebLog<Page> Table.Page webLogId conn
let! pages = conn.findByFields<Page> Table.Page Any [ webLogField webLogId ]
let! withRevs = pages |> List.map appendPageRevisions |> Task.WhenAll
return List.ofArray withRevs
}
@ -130,18 +133,17 @@ type SQLitePageData(conn: SqliteConnection, log: ILogger) =
/// Get all listed pages for the given web log (without revisions or text)
let findListed webLogId =
log.LogTrace "Page.findListed"
let fields = [ webLogField webLogId; Field.Equal pgListName true ]
conn.customList
$"""{Document.Query.selectByWebLog Table.Page} AND {Query.whereByField (Field.EQ pgListName "") "true"}
ORDER BY LOWER({titleField})"""
[ webLogParam webLogId ]
(fun rdr -> { fromData<Page> rdr with Text = "" })
(sortedPages fields) (addFieldParams fields []) (fun rdr -> { fromData<Page> rdr with Text = "" })
/// Get a page of pages for the given web log (without revisions)
let findPageOfPages webLogId pageNbr =
log.LogTrace "Page.findPageOfPages"
let field = [ webLogField webLogId ]
conn.customList
$"{Document.Query.selectByWebLog Table.Page} ORDER BY LOWER({titleField}) LIMIT @pageSize OFFSET @toSkip"
[ webLogParam webLogId; SqliteParameter("@pageSize", 26); SqliteParameter("@toSkip", (pageNbr - 1) * 25) ]
$"{sortedPages field} LIMIT @pageSize OFFSET @toSkip"
(addFieldParams field [ sqlParam "@pageSize" 26; sqlParam "@toSkip" ((pageNbr - 1) * 25) ])
(fun rdr -> { pageWithoutLinks rdr with Metadata = [] })
/// Update a page

View File

@ -16,7 +16,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) =
let linkName = nameof Post.Empty.Permalink
/// The JSON field for when the post was published
let publishField = $"data ->> '{nameof Post.Empty.PublishedOn}'"
let publishName = nameof Post.Empty.PublishedOn
/// The name of the JSON field for the post's status
let statName = nameof Post.Empty.Status
@ -31,7 +31,10 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) =
}
/// The SELECT statement to retrieve posts with a web log ID parameter
let postByWebLog = Document.Query.selectByWebLog Table.Post
let postByWebLog =
Query.statementWhere
(Query.find Table.Post)
(Query.whereByFields Any [ { Field.Equal "WebLogId" "" with ParameterName = Some "@webLogId" } ])
/// Return a post with no revisions or prior permalinks
let postWithoutLinks rdr =
@ -43,7 +46,7 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) =
/// The SELECT statement to retrieve published posts with a web log ID parameter
let publishedPostByWebLog =
$"""{postByWebLog} AND {Query.whereByField (Field.EQ statName "") $"'{string Published}'"}"""
$"{postByWebLog} AND data->>'{statName}' = '{string Published}'"
/// Update a post's revisions
let updatePostRevisions (postId: PostId) oldRevs newRevs =
@ -60,18 +63,16 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) =
}
/// Count posts in a status for the given web log
let countByStatus (status: PostStatus) webLogId =
let countByStatus (status: PostStatus) webLogId = backgroundTask {
log.LogTrace "Post.countByStatus"
let statParam = Field.EQ statName (string status)
conn.customScalar
$"""{Document.Query.countByWebLog Table.Post} AND {Query.whereByField statParam "@status"}"""
(addFieldParam "@status" statParam [ webLogParam webLogId ])
(toCount >> int)
let! count = conn.countByFields Table.Post All [ webLogField webLogId; Field.Equal statName (string status) ]
return int count
}
/// Find a post by its ID for the given web log (excluding revisions)
let findById postId webLogId = backgroundTask {
let findById (postId: PostId) webLogId = backgroundTask {
log.LogTrace "Post.findById"
match! Document.findByIdAndWebLog<PostId, Post> Table.Post postId webLogId conn with
match! conn.findFirstByFields<Post> Table.Post All [ idField postId; webLogField webLogId ] with
| Some post -> return Some { post with PriorPermalinks = [] }
| None -> return None
}
@ -79,16 +80,14 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) =
/// Find a post by its permalink for the given web log (excluding revisions)
let findByPermalink (permalink: Permalink) webLogId =
log.LogTrace "Post.findByPermalink"
let linkParam = Field.EQ linkName (string permalink)
let fields = [ webLogField webLogId; Field.Equal linkName (string permalink) ]
conn.customSingle
$"""{Document.Query.selectByWebLog Table.Post} AND {Query.whereByField linkParam "@link"}"""
(addFieldParam "@link" linkParam [ webLogParam webLogId ])
postWithoutLinks
(Query.byFields (Query.find Table.Post) All fields) (addFieldParams fields []) postWithoutLinks
/// Find a complete post by its ID for the given web log
let findFullById postId webLogId = backgroundTask {
log.LogTrace "Post.findFullById"
match! Document.findByIdAndWebLog<PostId, Post> Table.Post postId webLogId conn with
match! conn.findFirstByFields<Post> Table.Post All [ idField postId; webLogField webLogId ] with
| Some post ->
let! post = appendPostRevisions post
return Some post
@ -101,10 +100,12 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) =
match! findById postId webLogId with
| Some _ ->
do! conn.customNonQuery
$"""DELETE FROM {Table.PostRevision} WHERE post_id = @id;
DELETE FROM {Table.PostComment}
WHERE {Query.whereByField (Field.EQ (nameof Comment.Empty.PostId) "") "@id"};
{Query.Delete.byId Table.Post}"""
$"""{Query.delete Table.PostRevision} WHERE post_id = @id;
{Query.byFields
(Query.delete Table.PostComment)
Any
[ { Field.EQ (nameof Comment.Empty.PostId) postId with ParameterName = Some "@id" }]};
{Query.byId (Query.delete Table.Post) (string postId)}"""
[ idParam postId ]
return true
| None -> return false
@ -113,18 +114,18 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) =
/// Find the current permalink from a list of potential prior permalinks for the given web log
let findCurrentPermalink (permalinks: Permalink list) webLogId =
log.LogTrace "Post.findCurrentPermalink"
let linkSql, linkParams = inJsonArray Table.Post (nameof Post.Empty.PriorPermalinks) "link" permalinks
conn.customSingle
$"SELECT data ->> '{linkName}' AS permalink
FROM {Table.Post}
WHERE {Document.Query.whereByWebLog} AND {linkSql}"
(webLogParam webLogId :: linkParams)
Map.toPermalink
let fields =
[ webLogField webLogId
Field.InArray (nameof Post.Empty.PriorPermalinks) Table.Post (List.map string permalinks) ]
let query =
(Query.statementWhere (Query.find Table.Post) (Query.whereByFields All fields))
.Replace("SELECT data", $"SELECT data->>'{linkName}' AS permalink")
conn.customSingle query (addFieldParams fields []) Map.toPermalink
/// Get all complete posts for the given web log
let findFullByWebLog webLogId = backgroundTask {
log.LogTrace "Post.findFullByWebLog"
let! posts = Document.findByWebLog<Post> Table.Post webLogId conn
let! posts = conn.findByFields<Post> Table.Post Any [ webLogField webLogId ]
let! withRevs = posts |> List.map appendPostRevisions |> Task.WhenAll
return List.ofArray withRevs
}
@ -132,21 +133,22 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) =
/// Get a page of categorized posts for the given web log (excludes revisions)
let findPageOfCategorizedPosts webLogId (categoryIds: CategoryId list) pageNbr postsPerPage =
log.LogTrace "Post.findPageOfCategorizedPosts"
let catSql, catParams = inJsonArray Table.Post (nameof Post.Empty.CategoryIds) "catId" categoryIds
let catIdField = Field.InArray (nameof Post.Empty.CategoryIds) Table.Post (List.map string categoryIds)
conn.customList
$"{publishedPostByWebLog} AND {catSql}
ORDER BY {publishField} DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
(webLogParam webLogId :: catParams)
$"""{publishedPostByWebLog} AND {Query.whereByFields Any [ catIdField ]}
{Query.orderBy [ Field.Named $"{publishName} DESC" ] SQLite}
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
(addFieldParams [ webLogField webLogId; catIdField ] [])
postWithoutLinks
/// Get a page of posts for the given web log (excludes text and revisions)
let findPageOfPosts webLogId pageNbr postsPerPage =
log.LogTrace "Post.findPageOfPosts"
let order =
Query.orderBy
[ Field.Named $"{publishName} DESC NULLS FIRST"; Field.Named (nameof Post.Empty.UpdatedOn) ] SQLite
conn.customList
$"{postByWebLog}
ORDER BY {publishField} DESC NULLS FIRST, data ->> '{nameof Post.Empty.UpdatedOn}'
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
$"{postByWebLog}{order} LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
[ webLogParam webLogId ]
postWithoutText
@ -154,36 +156,39 @@ type SQLitePostData(conn: SqliteConnection, log: ILogger) =
let findPageOfPublishedPosts webLogId pageNbr postsPerPage =
log.LogTrace "Post.findPageOfPublishedPosts"
conn.customList
$"{publishedPostByWebLog}
ORDER BY {publishField} DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
$"""{publishedPostByWebLog}
{Query.orderBy [ Field.Named $"{publishName} DESC" ] SQLite}
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
[ webLogParam webLogId ]
postWithoutLinks
/// Get a page of tagged posts for the given web log (excludes revisions)
let findPageOfTaggedPosts webLogId (tag : string) pageNbr postsPerPage =
log.LogTrace "Post.findPageOfTaggedPosts"
let tagSql, tagParams = inJsonArray Table.Post (nameof Post.Empty.Tags) "tag" [ tag ]
let tagField = Field.InArray (nameof Post.Empty.Tags) Table.Post [ tag ]
conn.customList
$"{publishedPostByWebLog} AND {tagSql}
ORDER BY {publishField} DESC
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"
(webLogParam webLogId :: tagParams)
$"""{publishedPostByWebLog} AND {Query.whereByFields Any [ tagField ]}
{Query.orderBy [ Field.Named $"{publishName} DESC" ] SQLite}
LIMIT {postsPerPage + 1} OFFSET {(pageNbr - 1) * postsPerPage}"""
(addFieldParams [ webLogField webLogId; tagField ] [])
postWithoutLinks
/// Find the next newest and oldest post from a publish date for the given web log
let findSurroundingPosts webLogId (publishedOn : Instant) = backgroundTask {
log.LogTrace "Post.findSurroundingPosts"
let! older =
let adjacent op order =
let fields = [
webLogField webLogId
Field.Equal (nameof Post.Empty.Status) (string Published)
(if op = "<" then Field.Less else Field.Greater) publishName (instantParam publishedOn)
]
conn.customSingle
$"{publishedPostByWebLog} AND {publishField} < @publishedOn ORDER BY {publishField} DESC LIMIT 1"
[ webLogParam webLogId; SqliteParameter("@publishedOn", instantParam publishedOn) ]
postWithoutLinks
let! newer =
conn.customSingle
$"{publishedPostByWebLog} AND {publishField} > @publishedOn ORDER BY {publishField} LIMIT 1"
[ webLogParam webLogId; SqliteParameter("@publishedOn", instantParam publishedOn) ]
(Query.byFields (Query.find Table.Post) All fields
+ Query.orderBy [ Field.Named (publishName + order) ] SQLite + " LIMIT 1")
(addFieldParams fields [])
postWithoutLinks
let! older = adjacent "<" " DESC"
let! newer = adjacent ">" ""
return older, newer
}

View File

@ -11,9 +11,9 @@ open MyWebLog.Data
type SQLiteTagMapData(conn: SqliteConnection, log: ILogger) =
/// Find a tag mapping by its ID for the given web log
let findById tagMapId webLogId =
let findById (tagMapId: TagMapId) webLogId =
log.LogTrace "TagMap.findById"
Document.findByIdAndWebLog<TagMapId, TagMap> Table.TagMap tagMapId webLogId conn
conn.findFirstByFields<TagMap> Table.TagMap All [ idField tagMapId; webLogField webLogId ]
/// Delete a tag mapping for the given web log
let delete tagMapId webLogId = backgroundTask {
@ -28,25 +28,18 @@ type SQLiteTagMapData(conn: SqliteConnection, log: ILogger) =
/// Find a tag mapping by its URL value for the given web log
let findByUrlValue (urlValue: string) webLogId =
log.LogTrace "TagMap.findByUrlValue"
let urlParam = Field.EQ (nameof TagMap.Empty.UrlValue) urlValue
conn.customSingle
$"""{Document.Query.selectByWebLog Table.TagMap} AND {Query.whereByField urlParam "@urlValue"}"""
(addFieldParam "@urlValue" urlParam [ webLogParam webLogId ])
fromData<TagMap>
conn.findFirstByFields<TagMap>
Table.TagMap All [ webLogField webLogId; Field.Equal (nameof TagMap.Empty.UrlValue) urlValue ]
/// Get all tag mappings for the given web log
let findByWebLog webLogId =
log.LogTrace "TagMap.findByWebLog"
Document.findByWebLog<TagMap> Table.TagMap webLogId conn
conn.findByFields<TagMap> Table.TagMap Any [ webLogField webLogId ]
/// Find any tag mappings in a list of tags for the given web log
let findMappingForTags (tags: string list) webLogId =
log.LogTrace "TagMap.findMappingForTags"
let mapSql, mapParams = inClause $"AND data ->> '{nameof TagMap.Empty.Tag}'" "tag" id tags
conn.customList
$"{Document.Query.selectByWebLog Table.TagMap} {mapSql}"
(webLogParam webLogId :: mapParams)
fromData<TagMap>
conn.findByFields<TagMap> Table.TagMap All [ webLogField webLogId; Field.In (nameof TagMap.Empty.Tag) tags ]
/// Save a tag mapping
let save (tagMap: TagMap) =

View File

@ -10,8 +10,8 @@ open MyWebLog.Data
/// SQLite myWebLog theme data implementation
type SQLiteThemeData(conn : SqliteConnection, log: ILogger) =
/// The JSON field for the theme ID
let idField = $"data ->> '{nameof Theme.Empty.Id}'"
/// The name of the theme ID field
let idName = nameof Theme.Empty.Id
/// Convert a document to a theme with no template text
let withoutTemplateText (rdr: SqliteDataReader) =
@ -25,9 +25,10 @@ type SQLiteThemeData(conn : SqliteConnection, log: ILogger) =
/// Retrieve all themes (except 'admin'; excludes template text)
let all () =
log.LogTrace "Theme.all"
let fields = [ Field.NE idName "admin" ]
conn.customList
$"{Query.selectFromTable Table.Theme} WHERE {idField} <> 'admin' ORDER BY {idField}"
[]
(Query.byFields (Query.find Table.Theme) Any fields + Query.orderBy [ Field.Named idName ] SQLite)
(addFieldParams fields [])
withoutTemplateText
/// Does a given theme exist?
@ -43,7 +44,7 @@ type SQLiteThemeData(conn : SqliteConnection, log: ILogger) =
/// Find a theme by its ID (excludes the text of templates)
let findByIdWithoutText (themeId: ThemeId) =
log.LogTrace "Theme.findByIdWithoutText"
conn.customSingle (Query.Find.byId Table.Theme) [ idParam themeId ] withoutTemplateText
conn.customSingle (Query.byId (Query.find Table.Theme) (string themeId)) [ idParam themeId ] withoutTemplateText
/// Delete a theme by its ID
let delete themeId = backgroundTask {
@ -51,7 +52,8 @@ type SQLiteThemeData(conn : SqliteConnection, log: ILogger) =
match! findByIdWithoutText themeId with
| Some _ ->
do! conn.customNonQuery
$"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id; {Query.Delete.byId Table.Theme}"
$"{Query.delete Table.ThemeAsset} WHERE theme_id = @id;
{Query.byId (Query.delete Table.Theme) (string themeId)}"
[ idParam themeId ]
return true
| None -> return false
@ -89,7 +91,7 @@ type SQLiteThemeAssetData(conn : SqliteConnection, log: ILogger) =
/// Delete all assets for the given theme
let deleteByTheme (themeId: ThemeId) =
log.LogTrace "ThemeAsset.deleteByTheme"
conn.customNonQuery $"DELETE FROM {Table.ThemeAsset} WHERE theme_id = @id" [ idParam themeId ]
conn.customNonQuery $"{Query.delete Table.ThemeAsset} WHERE theme_id = @id" [ idParam themeId ]
/// Find a theme asset by its ID
let findById assetId =

View File

@ -23,25 +23,26 @@ type SQLiteWebLogData(conn: SqliteConnection, log: ILogger) =
/// Delete a web log by its ID
let delete webLogId =
log.LogTrace "WebLog.delete"
let webLogMatches = Query.whereByField (Field.EQ "WebLogId" "") "@webLogId"
let subQuery table = $"(SELECT data ->> 'Id' FROM {table} WHERE {webLogMatches})"
let webLogMatches =
Query.whereByFields Any [ { Field.Equal "WebLogId" "" with ParameterName = Some "@webLogId" } ]
let subQuery table = $"(SELECT data->>'Id' FROM {table} WHERE {webLogMatches})"
Custom.nonQuery
$"""DELETE FROM {Table.PostComment} WHERE data ->> 'PostId' IN {subQuery Table.Post};
DELETE FROM {Table.PostRevision} WHERE post_id IN {subQuery Table.Post};
DELETE FROM {Table.PageRevision} WHERE page_id IN {subQuery Table.Page};
DELETE FROM {Table.Post} WHERE {webLogMatches};
DELETE FROM {Table.Page} WHERE {webLogMatches};
DELETE FROM {Table.Category} WHERE {webLogMatches};
DELETE FROM {Table.TagMap} WHERE {webLogMatches};
DELETE FROM {Table.Upload} WHERE web_log_id = @webLogId;
DELETE FROM {Table.WebLogUser} WHERE {webLogMatches};
DELETE FROM {Table.WebLog} WHERE {Query.whereById "@webLogId"}"""
$"""{Query.delete Table.PostComment} WHERE data ->> 'PostId' IN {subQuery Table.Post};
{Query.delete Table.PostRevision} WHERE post_id IN {subQuery Table.Post};
{Query.delete Table.PageRevision} WHERE page_id IN {subQuery Table.Page};
{Query.delete Table.Post} WHERE {webLogMatches};
{Query.delete Table.Page} WHERE {webLogMatches};
{Query.delete Table.Category} WHERE {webLogMatches};
{Query.delete Table.TagMap} WHERE {webLogMatches};
{Query.delete Table.Upload} WHERE web_log_id = @webLogId;
{Query.delete Table.WebLogUser} WHERE {webLogMatches};
{Query.delete Table.WebLog} WHERE {Query.whereById "@webLogId"}"""
[ webLogParam webLogId ]
/// Find a web log by its host (URL base)
let findByHost (url: string) =
log.LogTrace "WebLog.findByHost"
conn.findFirstByField<WebLog> Table.WebLog (Field.EQ (nameof WebLog.Empty.UrlBase) url)
conn.findFirstByFields<WebLog> Table.WebLog Any [ Field.Equal (nameof WebLog.Empty.UrlBase) url ]
/// Find a web log by its ID
let findById webLogId =

View File

@ -16,17 +16,18 @@ type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) =
conn.insert<WebLogUser> Table.WebLogUser user
/// Find a user by their ID for the given web log
let findById userId webLogId =
let findById (userId: WebLogUserId) webLogId =
log.LogTrace "WebLogUser.findById"
Document.findByIdAndWebLog<WebLogUserId, WebLogUser> Table.WebLogUser userId webLogId conn
conn.findFirstByFields<WebLogUser> Table.WebLogUser All [ idField userId; webLogField webLogId ]
/// Delete a user if they have no posts or pages
let delete userId webLogId = backgroundTask {
log.LogTrace "WebLogUser.delete"
match! findById userId webLogId with
| Some _ ->
let! pageCount = conn.countByField Table.Page (Field.EQ (nameof Page.Empty.AuthorId) (string userId))
let! postCount = conn.countByField Table.Post (Field.EQ (nameof Post.Empty.AuthorId) (string userId))
let author = [ Field.Equal (nameof Page.Empty.AuthorId) (string userId) ]
let! pageCount = conn.countByFields Table.Page Any author
let! postCount = conn.countByFields Table.Post Any author
if pageCount + postCount > 0 then
return Error "User has pages or posts; cannot delete"
else
@ -38,27 +39,24 @@ type SQLiteWebLogUserData(conn: SqliteConnection, log: ILogger) =
/// Find a user by their e-mail address for the given web log
let findByEmail (email: string) webLogId =
log.LogTrace "WebLogUser.findByEmail"
let emailParam = Field.EQ (nameof WebLogUser.Empty.Email) email
conn.customSingle
$"""{Document.Query.selectByWebLog Table.WebLogUser}
AND {Query.whereByField emailParam "@email"}"""
(addFieldParam "@email" emailParam [ webLogParam webLogId ])
fromData<WebLogUser>
conn.findFirstByFields
Table.WebLogUser All [ webLogField webLogId; Field.Equal (nameof WebLogUser.Empty.Email) email ]
/// Get all users for the given web log
let findByWebLog webLogId = backgroundTask {
log.LogTrace "WebLogUser.findByWebLog"
let! users = Document.findByWebLog<WebLogUser> Table.WebLogUser webLogId conn
let! users = conn.findByFields<WebLogUser> Table.WebLogUser Any [ webLogField webLogId ]
return users |> List.sortBy _.PreferredName.ToLowerInvariant()
}
/// Find the names of users by their IDs for the given web log
let findNames webLogId (userIds: WebLogUserId list) =
log.LogTrace "WebLogUser.findNames"
let nameSql, nameParams = inClause $"AND data ->> '{nameof WebLogUser.Empty.Id}'" "id" string userIds
let fields = [ webLogField webLogId; Field.In (nameof WebLogUser.Empty.Id) (List.map string userIds) ]
let query = Query.statementWhere (Query.find Table.WebLogUser) (Query.whereByFields All fields)
conn.customList
$"{Document.Query.selectByWebLog Table.WebLogUser} {nameSql}"
(webLogParam webLogId :: nameParams)
query
(addFieldParams fields [])
(fun rdr ->
let user = fromData<WebLogUser> rdr
{ Name = string user.Id; Value = user.DisplayName })

View File

@ -1,7 +1,6 @@
namespace MyWebLog.Data
open System
open System.Threading.Tasks
open BitBadger.Documents
open BitBadger.Documents.Sqlite
open Microsoft.Data.Sqlite
@ -24,98 +23,107 @@ type SQLiteData(conn: SqliteConnection, log: ILogger<SQLiteData>, ser: JsonSeria
let needsTable table =
not (List.contains table tables)
let jsonTable table =
$"{Query.Definition.ensureTable table}; {Query.Definition.ensureKey table}"
let creatingTable = "Creating {Table} table..."
let tasks =
seq {
// Theme tables
if needsTable Table.Theme then jsonTable Table.Theme
if needsTable Table.ThemeAsset then
// 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
$"CREATE TABLE {Table.ThemeAsset} (
theme_id TEXT NOT NULL,
path TEXT NOT NULL,
updated_on TEXT NOT NULL,
data BLOB NOT NULL,
PRIMARY KEY (theme_id, path))"
// Web log table
if needsTable Table.WebLog then jsonTable Table.WebLog
// Category table
if needsTable Table.Category then
$"""{jsonTable Table.Category};
{Query.Definition.ensureIndexOn Table.Category "web_log" [ nameof Category.Empty.WebLogId ]}"""
// Web log user table
if needsTable Table.WebLogUser then
$"""{jsonTable Table.WebLogUser};
{Query.Definition.ensureIndexOn
Table.WebLogUser
"email"
[ nameof WebLogUser.Empty.WebLogId; nameof WebLogUser.Empty.Email ]}"""
// Page tables
if needsTable Table.Page then
$"""{jsonTable Table.Page};
{Query.Definition.ensureIndexOn Table.Page "author" [ nameof Page.Empty.AuthorId ]};
{Query.Definition.ensureIndexOn
Table.Page "permalink" [ nameof Page.Empty.WebLogId; nameof Page.Empty.Permalink ]}"""
if needsTable Table.PageRevision then
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
$"CREATE TABLE {Table.PageRevision} (
page_id TEXT NOT NULL,
as_of TEXT NOT NULL,
revision_text TEXT NOT NULL,
PRIMARY KEY (page_id, as_of))"
// Post tables
if needsTable Table.Post then
$"""{jsonTable Table.Post};
{Query.Definition.ensureIndexOn Table.Post "author" [ nameof Post.Empty.AuthorId ]};
{Query.Definition.ensureIndexOn
Table.Post "permalink" [ nameof Post.Empty.WebLogId; nameof Post.Empty.Permalink ]};
{Query.Definition.ensureIndexOn
Table.Post
"status"
[ nameof Post.Empty.WebLogId; nameof Post.Empty.Status; nameof Post.Empty.UpdatedOn ]}"""
// TODO: index categories by post?
if needsTable Table.PostRevision then
PRIMARY KEY (page_id, as_of))" []
// Post tables
if needsTable Table.Post then
log.LogInformation(creatingTable, Table.Post)
do! conn.ensureTable Table.Post
do! conn.ensureFieldIndex Table.Post "author" [ nameof Post.Empty.AuthorId ]
do! conn.ensureFieldIndex Table.Post "permalink" [ nameof Post.Empty.WebLogId; nameof Post.Empty.Permalink ]
do! conn.ensureFieldIndex
Table.Post
"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
$"CREATE TABLE {Table.PostRevision} (
post_id TEXT NOT NULL,
as_of TEXT NOT NULL,
revision_text TEXT NOT NULL,
PRIMARY KEY (post_id, as_of))"
if needsTable Table.PostComment then
$"""{jsonTable Table.PostComment};
{Query.Definition.ensureIndexOn Table.PostComment "post" [ nameof Comment.Empty.PostId ]}"""
// Tag map table
if needsTable Table.TagMap then
$"""{jsonTable Table.TagMap};
{Query.Definition.ensureIndexOn
Table.TagMap "url" [ nameof TagMap.Empty.WebLogId; nameof TagMap.Empty.UrlValue ]}"""
// Uploaded file table
if needsTable Table.Upload then
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)
do! conn.customNonQuery
$"CREATE TABLE {Table.Upload} (
id TEXT PRIMARY KEY,
web_log_id TEXT NOT NULL,
path TEXT NOT NULL,
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
$"CREATE TABLE {Table.DbVersion} (id TEXT PRIMARY KEY);
INSERT INTO {Table.DbVersion} VALUES ('{Utils.Migration.currentDbVersion}')"
}
|> Seq.map (fun sql ->
log.LogInformation $"""Creating {(sql.Replace("IF NOT EXISTS ", "").Split ' ')[2]} table..."""
conn.customNonQuery sql [])
CREATE INDEX idx_{Table.Upload}_path ON {Table.Upload} (web_log_id, path)" []
let! _ = Task.WhenAll tasks
()
// Database version table
if needsTable Table.DbVersion then
log.LogInformation(creatingTable, Table.DbVersion)
do! conn.customNonQuery
$"CREATE TABLE {Table.DbVersion} (id TEXT PRIMARY KEY);
INSERT INTO {Table.DbVersion} VALUES ('{Utils.Migration.currentDbVersion}')" []
}
/// Set the database version to the specified version

View File

@ -1,11 +1,16 @@
/// Utility functions for manipulating data
/// <summary>Utility functions for manipulating data</summary>
[<RequireQualifiedAccess>]
module internal MyWebLog.Data.Utils
open MyWebLog
open MyWebLog.ViewModels
/// Create a category hierarchy from the given list of categories
/// <summary>Create a category hierarchy from the given list of categories</summary>
/// <param name="cats">The categories from which the list should be generated</param>
/// <param name="parentId">The ID of the parent category for this list</param>
/// <param name="slugBase">The base URL to use in slugs for categories at this level</param>
/// <param name="parentNames">The names of parent categories for this level</param>
/// <returns>An array of <c>DisplayCategory</c> instances sorted alphabetically by parent category</returns>
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
@ -19,48 +24,75 @@ let rec orderByHierarchy (cats: Category list) parentId slugBase parentNames = s
yield! orderByHierarchy cats (Some cat.Id) (Some fullSlug) ([ cat.Name ] |> List.append parentNames)
}
/// Get lists of items removed from and added to the given lists
/// <summary>Get lists of items removed from and added to the given lists</summary>
/// <typeparam name="T">The type of items in the list</typeparam>
/// <typeparam name="U">The return type of the comparision function</typeparam>
/// <param name="oldItems">The prior list</param>
/// <param name="newItems">The current list</param>
/// <param name="f">The function to use when comparing items in the list</param>
/// <returns>A tuple with <c>fst</c> being added items and <c>snd</c> being removed items</returns>
let diffLists<'T, 'U when 'U: equality> oldItems newItems (f: 'T -> 'U) =
let diff compList = fun item -> not (compList |> List.exists (fun other -> f item = f other))
List.filter (diff newItems) oldItems, List.filter (diff oldItems) newItems
/// Find the revisions added and removed
/// <summary>Find the revisions added and removed</summary>
/// <param name="oldRevs">The previous revisions</param>
/// <param name="newRevs">The current revisions</param>
/// <returns>A tuple with <c>fst</c> being added revisions and <c>snd</c> being removed revisions</returns>
let diffRevisions (oldRevs: Revision list) newRevs =
diffLists oldRevs newRevs (fun rev -> $"{rev.AsOf.ToUnixTimeTicks()}|{rev.Text}")
open MyWebLog.Converters
open Newtonsoft.Json
/// Serialize an object to JSON
/// <summary>Serialize an object to JSON</summary>
/// <typeparam name="T">The type of the item being serialized</typeparam>
/// <param name="ser">The JSON serializer whose settings should be used</param>
/// <param name="item">The item to be serialized</param>
/// <returns>A string with the given object serialized to JSON</returns>
let serialize<'T> ser (item: 'T) =
JsonConvert.SerializeObject(item, Json.settings ser)
/// Deserialize a JSON string
/// <summary>Deserialize a JSON string</summary>
/// <typeparam name="T">The type of the item being deserialized</typeparam>
/// <param name="ser">The JSON serializer whose settings should be used</param>
/// <param name="value">The string with the JSON representation of the item</param>
/// <returns>The item deserialized from JSON</returns>
let deserialize<'T> (ser: JsonSerializer) value =
JsonConvert.DeserializeObject<'T>(value, Json.settings ser)
open BitBadger.Documents
/// Create a document serializer using the given JsonSerializer
/// <summary>Create a document serializer using the given JsonSerializer</summary>
/// <param name="ser">The JSON.NET serializer on which the document serializer should be based</param>
/// <returns>A document serializer instance</returns>
let createDocumentSerializer ser =
{ new IDocumentSerializer with
member _.Serialize<'T>(it: 'T) : string = serialize ser it
member _.Deserialize<'T>(it: string) : 'T = deserialize ser it
}
/// Data migration utilities
/// <summary>Data migration utilities</summary>
module Migration =
open Microsoft.Extensions.Logging
/// The current database version
/// <summary>The current database version</summary>
let currentDbVersion = "v2.2"
/// Log a migration step
/// <summary>Log a migration step</summary>
/// <param name="log">The logger to which the message should be logged</param>
/// <param name="migration">The migration being run</param>
/// <param name="message">The log message</param>
let logStep<'T> (log: ILogger<'T>) migration message =
log.LogInformation $"Migrating %s{migration}: %s{message}"
/// Notify the user that a backup/restore
/// <summary>Notify the user that a backup/restore is required to migrate</summary>
/// <param name="log">The logger to which the message should be logged</param>
/// <param name="oldVersion">The old (current) version of the database</param>
/// <param name="newVersion">The new (application) version required</param>
/// <param name="webLogs">All web logs contained in the database</param>
let backupAndRestoreRequired log oldVersion newVersion webLogs =
logStep log $"%s{oldVersion} to %s{newVersion}" "Requires Using Action"
@ -74,7 +106,6 @@ module Migration =
yield! webLogs |> List.map (fun (url, slug) -> $"./myWebLog backup %s{url} {oldVersion}.%s{slug}.json") ]
|> String.concat "\n"
|> log.LogWarning
log.LogCritical "myWebLog will now exit"
exit 1 |> ignore

View File

@ -3,29 +3,29 @@
open MyWebLog
open NodaTime
/// A category under which a post may be identified
/// <summary>A category under which a post may be identified</summary>
[<CLIMutable; NoComparison; NoEquality>]
type Category = {
/// The ID of the category
/// <summary>The ID of the category</summary>
Id: CategoryId
/// The ID of the web log to which the category belongs
/// <summary>The ID of the web log to which the category belongs</summary>
WebLogId: WebLogId
/// The displayed name
/// <summary>The displayed name</summary>
Name: string
/// The slug (used in category URLs)
/// <summary>The slug (used in category URLs)</summary>
Slug: string
/// A longer description of the category
/// <summary>A longer description of the category</summary>
Description: string option
/// The parent ID of this category (if a subcategory)
/// <summary>The parent ID of this category (if a subcategory)</summary>
ParentId: CategoryId option
} with
/// An empty category
/// <summary>An empty category</summary>
static member Empty =
{ Id = CategoryId.Empty
WebLogId = WebLogId.Empty
@ -35,38 +35,38 @@ type Category = {
ParentId = None }
/// A comment on a post
/// <summary>A comment on a post</summary>
[<CLIMutable; NoComparison; NoEquality>]
type Comment = {
/// The ID of the comment
/// <summary>The ID of the comment</summary>
Id: CommentId
/// The ID of the post to which this comment applies
/// <summary>The ID of the post to which this comment applies</summary>
PostId: PostId
/// The ID of the comment to which this comment is a reply
/// <summary>The ID of the comment to which this comment is a reply</summary>
InReplyToId: CommentId option
/// The name of the commentor
/// <summary>The name of the commentor</summary>
Name: string
/// The e-mail address of the commentor
/// <summary>The e-mail address of the commentor</summary>
Email: string
/// The URL of the commentor's personal website
/// <summary>The URL of the commentor's personal website</summary>
Url: string option
/// The status of the comment
/// <summary>The status of the comment</summary>
Status: CommentStatus
/// When the comment was posted
/// <summary>When the comment was posted</summary>
PostedOn: Instant
/// The text of the comment
/// <summary>The text of the comment</summary>
Text: string
} with
/// An empty comment
/// <summary>An empty comment</summary>
static member Empty =
{ Id = CommentId.Empty
PostId = PostId.Empty
@ -79,50 +79,50 @@ type Comment = {
Text = "" }
/// A page (text not associated with a date/time)
/// <summary>A page (text not associated with a date/time)</summary>
[<CLIMutable; NoComparison; NoEquality>]
type Page = {
/// The ID of this page
/// <summary>The ID of this page</summary>
Id: PageId
/// The ID of the web log to which this page belongs
/// <summary>The ID of the web log to which this page belongs</summary>
WebLogId: WebLogId
/// The ID of the author of this page
/// <summary>The ID of the author of this page</summary>
AuthorId: WebLogUserId
/// The title of the page
/// <summary>The title of the page</summary>
Title: string
/// The link at which this page is displayed
/// <summary>The link at which this page is displayed</summary>
Permalink: Permalink
/// When this page was published
/// <summary>When this page was published</summary>
PublishedOn: Instant
/// When this page was last updated
/// <summary>When this page was last updated</summary>
UpdatedOn: Instant
/// Whether this page shows as part of the web log's navigation
/// <summary>Whether this page shows as part of the web log's navigation</summary>
IsInPageList: bool
/// The template to use when rendering this page
/// <summary>The template to use when rendering this page</summary>
Template: string option
/// The current text of the page
/// <summary>The current text of the page</summary>
Text: string
/// Metadata for this page
/// <summary>Metadata for this page</summary>
Metadata: MetaItem list
/// Permalinks at which this page may have been previously served (useful for migrated content)
/// <summary>Permalinks at which this page may have been previously served (useful for migrated content)</summary>
PriorPermalinks: Permalink list
/// Revisions of this page
/// <summary>Revisions of this page</summary>
Revisions: Revision list
} with
/// An empty page
/// <summary>An empty page</summary>
static member Empty =
{ Id = PageId.Empty
WebLogId = WebLogId.Empty
@ -139,59 +139,59 @@ type Page = {
Revisions = [] }
/// A web log post
/// <summary>A web log post</summary>
[<CLIMutable; NoComparison; NoEquality>]
type Post = {
/// The ID of this post
/// <summary>The ID of this post</summary>
Id: PostId
/// The ID of the web log to which this post belongs
/// <summary>The ID of the web log to which this post belongs</summary>
WebLogId: WebLogId
/// The ID of the author of this post
/// <summary>The ID of the author of this post</summary>
AuthorId: WebLogUserId
/// The status
/// <summary>The status</summary>
Status: PostStatus
/// The title
/// <summary>The title</summary>
Title: string
/// The link at which the post resides
/// <summary>The link at which the post resides</summary>
Permalink: Permalink
/// The instant on which the post was originally published
/// <summary>The instant on which the post was originally published</summary>
PublishedOn: Instant option
/// The instant on which the post was last updated
/// <summary>The instant on which the post was last updated</summary>
UpdatedOn: Instant
/// The template to use in displaying the post
/// <summary>The template to use in displaying the post</summary>
Template: string option
/// The text of the post in HTML (ready to display) format
/// <summary>The text of the post in HTML (ready to display) format</summary>
Text: string
/// The Ids of the categories to which this is assigned
/// <summary>The Ids of the categories to which this is assigned</summary>
CategoryIds: CategoryId list
/// The tags for the post
/// <summary>The tags for the post</summary>
Tags: string list
/// Podcast episode information for this post
/// <summary>Podcast episode information for this post</summary>
Episode: Episode option
/// Metadata for the post
/// <summary>Metadata for the post</summary>
Metadata: MetaItem list
/// Permalinks at which this post may have been previously served (useful for migrated content)
/// <summary>Permalinks at which this post may have been previously served (useful for migrated content)</summary>
PriorPermalinks: Permalink list
/// The revisions for this post
/// <summary>The revisions for this post</summary>
Revisions: Revision list
} with
/// An empty post
/// <summary>An empty post</summary>
static member Empty =
{ Id = PostId.Empty
WebLogId = WebLogId.Empty
@ -211,136 +211,138 @@ type Post = {
Revisions = [] }
/// <summary>
/// A mapping between a tag and its URL value, used to translate restricted characters (ex. "#1" -> "number-1")
/// </summary>
[<CLIMutable; NoComparison; NoEquality>]
type TagMap = {
/// The ID of this tag mapping
/// <summary>The ID of this tag mapping</summary>
Id: TagMapId
/// The ID of the web log to which this tag mapping belongs
/// <summary>The ID of the web log to which this tag mapping belongs</summary>
WebLogId: WebLogId
/// The tag which should be mapped to a different value in links
/// <summary>The tag which should be mapped to a different value in links</summary>
Tag: string
/// The value by which the tag should be linked
/// <summary>The value by which the tag should be linked</summary>
UrlValue: string
} with
/// An empty tag mapping
/// <summary>An empty tag mapping</summary>
static member Empty =
{ Id = TagMapId.Empty; WebLogId = WebLogId.Empty; Tag = ""; UrlValue = "" }
/// A theme
/// <summary>A theme</summary>
[<CLIMutable; NoComparison; NoEquality>]
type Theme = {
/// The ID / path of the theme
/// <summary>The ID / path of the theme</summary>
Id: ThemeId
/// A long name of the theme
/// <summary>A long name of the theme</summary>
Name: string
/// The version of the theme
/// <summary>The version of the theme</summary>
Version: string
/// The templates for this theme
/// <summary>The templates for this theme</summary>
Templates: ThemeTemplate list
} with
/// An empty theme
/// <summary>An empty theme</summary>
static member Empty =
{ Id = ThemeId.Empty; Name = ""; Version = ""; Templates = [] }
/// A theme asset (a file served as part of a theme, at /themes/[theme]/[asset-path])
/// <summary>A theme asset (a file served as part of a theme, at /themes/[theme]/[asset-path])</summary>
[<CLIMutable; NoComparison; NoEquality>]
type ThemeAsset = {
/// The ID of the asset (consists of theme and path)
/// <summary>The ID of the asset (consists of theme and path)</summary>
Id: ThemeAssetId
/// The updated date (set from the file date from the ZIP archive)
/// <summary>The updated date (set from the file date from the ZIP archive)</summary>
UpdatedOn: Instant
/// The data for the asset
/// <summary>The data for the asset</summary>
Data: byte array
} with
/// An empty theme asset
/// <summary>An empty theme asset</summary>
static member Empty =
{ Id = ThemeAssetId.Empty; UpdatedOn = Noda.epoch; Data = [||] }
/// An uploaded file
/// <summary>An uploaded file</summary>
[<CLIMutable; NoComparison; NoEquality>]
type Upload = {
/// The ID of the upload
/// <summary>The ID of the upload</summary>
Id: UploadId
/// The ID of the web log to which this upload belongs
/// <summary>The ID of the web log to which this upload belongs</summary>
WebLogId: WebLogId
/// The link at which this upload is served
/// <summary>The link at which this upload is served</summary>
Path: Permalink
/// The updated date/time for this upload
/// <summary>The updated date/time for this upload</summary>
UpdatedOn: Instant
/// The data for the upload
/// <summary>The data for the upload</summary>
Data: byte array
} with
/// An empty upload
/// <summary>An empty upload</summary>
static member Empty =
{ Id = UploadId.Empty; WebLogId = WebLogId.Empty; Path = Permalink.Empty; UpdatedOn = Noda.epoch; Data = [||] }
open Newtonsoft.Json
/// A web log
/// <summary>A web log</summary>
[<CLIMutable; NoComparison; NoEquality>]
type WebLog = {
/// The ID of the web log
/// <summary>The ID of the web log</summary>
Id: WebLogId
/// The name of the web log
/// <summary>The name of the web log</summary>
Name: string
/// The slug of the web log
/// <summary>The slug of the web log</summary>
Slug: string
/// A subtitle for the web log
/// <summary>A subtitle for the web log</summary>
Subtitle: string option
/// The default page ("posts" or a page Id)
/// <summary>The default page ("posts" or a page Id)</summary>
DefaultPage: string
/// The number of posts to display on pages of posts
/// <summary>The number of posts to display on pages of posts</summary>
PostsPerPage: int
/// The ID of the theme (also the path within /themes)
/// <summary>The ID of the theme (also the path within /themes)</summary>
ThemeId: ThemeId
/// The URL base
/// <summary>The URL base</summary>
UrlBase: string
/// The time zone in which dates/times should be displayed
/// <summary>The time zone in which dates/times should be displayed</summary>
TimeZone: string
/// The RSS options for this web log
/// <summary>The RSS options for this web log</summary>
Rss: RssOptions
/// Whether to automatically load htmx
/// <summary>Whether to automatically load htmx</summary>
AutoHtmx: bool
/// Where uploads are placed
/// <summary>Where uploads are placed</summary>
Uploads: UploadDestination
/// Redirect rules for this weblog
/// <summary>Redirect rules for this weblog</summary>
RedirectRules: RedirectRule list
} with
/// An empty web log
/// <summary>An empty web log</summary>
static member Empty =
{ Id = WebLogId.Empty
Name = ""
@ -355,8 +357,10 @@ type WebLog = {
AutoHtmx = false
Uploads = Database
RedirectRules = [] }
/// <summary>
/// Any extra path where this web log is hosted (blank if web log is hosted at the root of the domain)
/// </summary>
[<JsonIgnore>]
member this.ExtraPath =
let pathParts = this.UrlBase.Split "://"
@ -365,16 +369,22 @@ type WebLog = {
else
let path = pathParts[1].Split "/"
if path.Length > 1 then $"""/{path |> Array.skip 1 |> String.concat "/"}""" else ""
/// Generate an absolute URL for the given link
/// <summary>Generate an absolute URL for the given link</summary>
/// <param name="permalink">The permalink for which an absolute URL should be generated</param>
/// <returns>An absolute URL for the given link</returns>
member this.AbsoluteUrl(permalink: Permalink) =
$"{this.UrlBase}/{permalink}"
/// Generate a relative URL for the given link
/// <summary>Generate a relative URL for the given link</summary>
/// <param name="permalink">The permalink for which a relative URL should be generated</param>
/// <returns>A relative URL for the given link</returns>
member this.RelativeUrl(permalink: Permalink) =
$"{this.ExtraPath}/{permalink}"
/// Convert an Instant (UTC reference) to the web log's local date/time
/// <summary>Convert an Instant (UTC reference) to the web log's local date/time</summary>
/// <param name="date">The UTC <c>Instant</c> to be converted</param>
/// <returns>The local date/time for this web log</returns>
member this.LocalTime(date: Instant) =
DateTimeZoneProviders.Tzdb.GetZoneOrNull this.TimeZone
|> Option.ofObj
@ -382,44 +392,44 @@ type WebLog = {
|> Option.defaultValue (date.ToDateTimeUtc())
/// A user of the web log
/// <summary>A user of the web log</summary>
[<CLIMutable; NoComparison; NoEquality>]
type WebLogUser = {
/// The ID of the user
/// <summary>The ID of the user</summary>
Id: WebLogUserId
/// The ID of the web log to which this user belongs
/// <summary>The ID of the web log to which this user belongs</summary>
WebLogId: WebLogId
/// The user name (e-mail address)
/// <summary>The user name (e-mail address)</summary>
Email: string
/// The user's first name
/// <summary>The user's first name</summary>
FirstName: string
/// The user's last name
/// <summary>The user's last name</summary>
LastName: string
/// The user's preferred name
/// <summary>The user's preferred name</summary>
PreferredName: string
/// The hash of the user's password
/// <summary>The hash of the user's password</summary>
PasswordHash: string
/// The URL of the user's personal site
/// <summary>The URL of the user's personal site</summary>
Url: string option
/// The user's access level
/// <summary>The user's access level</summary>
AccessLevel: AccessLevel
/// When the user was created
/// <summary>When the user was created</summary>
CreatedOn: Instant
/// When the user last logged on
/// <summary>When the user last logged on</summary>
LastSeenOn: Instant option
} with
/// An empty web log user
/// <summary>An empty web log user</summary>
static member Empty =
{ Id = WebLogUserId.Empty
WebLogId = WebLogId.Empty
@ -432,8 +442,8 @@ type WebLogUser = {
AccessLevel = Author
CreatedOn = Noda.epoch
LastSeenOn = None }
/// Get the user's displayed name
/// <summary>Get the user's displayed name</summary>
[<JsonIgnore>]
member this.DisplayName =
(seq { (match this.PreferredName with "" -> this.FirstName | n -> n); " "; this.LastName }

View File

@ -7,11 +7,11 @@
</ItemGroup>
<ItemGroup>
<PackageReference Include="Markdig" Version="0.37.0" />
<PackageReference Include="Markdown.ColorCode" Version="2.2.2" />
<PackageReference Include="Markdig" Version="0.40.0" />
<PackageReference Include="Markdown.ColorCode" Version="2.3.0" />
<PackageReference Include="Newtonsoft.Json" Version="13.0.3" />
<PackageReference Include="NodaTime" Version="3.1.11" />
<PackageReference Update="FSharp.Core" Version="8.0.300" />
<PackageReference Include="NodaTime" Version="3.2.1" />
<PackageReference Update="FSharp.Core" Version="9.0.101" />
</ItemGroup>
</Project>

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@ -28,7 +28,7 @@
<ItemGroup>
<PackageReference Include="Expecto" Version="10.2.1" />
<PackageReference Include="ThrowawayDb.Postgres" Version="1.4.0" />
<PackageReference Update="FSharp.Core" Version="8.0.300" />
<PackageReference Update="FSharp.Core" Version="9.0.101" />
</ItemGroup>
<ItemGroup>

View File

@ -3,30 +3,30 @@
open Microsoft.AspNetCore.Http
open MyWebLog.Data
/// Extension properties on HTTP context for web log
/// <summary>Extension properties on HTTP context for web log</summary>
[<AutoOpen>]
module Extensions =
open System.Security.Claims
open Microsoft.AspNetCore.Antiforgery
open Microsoft.Extensions.Configuration
open Microsoft.Extensions.DependencyInjection
/// Hold variable for the configured generator string
let mutable private generatorString: string option = None
type HttpContext with
/// The anti-CSRF service
/// <summary>The anti-CSRF service</summary>
member this.AntiForgery = this.RequestServices.GetRequiredService<IAntiforgery>()
/// The cross-site request forgery token set for this request
/// <summary>The cross-site request forgery token set for this request</summary>
member this.CsrfTokenSet = this.AntiForgery.GetAndStoreTokens this
/// The data implementation
/// <summary>The data implementation</summary>
member this.Data = this.RequestServices.GetRequiredService<IData>()
/// The generator string
/// <summary>The generator string</summary>
member this.Generator =
match generatorString with
| Some gen -> gen
@ -38,20 +38,22 @@ module Extensions =
| None -> Some "generator not configured"
generatorString.Value
/// The access level for the current user
/// <summary>The access level for the current user</summary>
member this.UserAccessLevel =
this.User.Claims
|> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.Role)
|> Option.map (fun claim -> AccessLevel.Parse claim.Value)
/// The user ID for the current request
/// <summary>The user ID for the current request</summary>
member this.UserId =
WebLogUserId (this.User.Claims |> Seq.find (fun c -> c.Type = ClaimTypes.NameIdentifier)).Value
/// The web log for the current request
/// <summary>The web log for the current request</summary>
member this.WebLog = this.Items["webLog"] :?> WebLog
/// Does the current user have the requested level of access?
/// <summary>Does the current user have the required level of access?</summary>
/// <param name="level">The required level of access</param>
/// <returns>True if the user has the required access, false if not</returns>
member this.HasAccessLevel level =
defaultArg (this.UserAccessLevel |> Option.map _.HasAccess(level)) false
@ -64,30 +66,33 @@ open System.Collections.Concurrent
/// <remarks>This is filled by the middleware via the first request for each host, and can be updated via the web log
/// settings update page</remarks>
module WebLogCache =
open System.Text.RegularExpressions
/// A redirect rule that caches compiled regular expression rules
/// <summary>A redirect rule that caches compiled regular expression rules</summary>
type CachedRedirectRule =
/// A straight text match rule
| Text of string * string
/// A regular expression match rule
| RegEx of Regex * string
/// <summary>A straight text match rule</summary>
| Text of string * string
/// <summary>A regular expression match rule</summary>
| RegEx of Regex * string
/// The cache of web log details
let mutable private _cache : WebLog list = []
let mutable private _cache: WebLog list = []
/// Redirect rules with compiled regular expressions
let mutable private _redirectCache = ConcurrentDictionary<WebLogId, CachedRedirectRule list> ()
let mutable private _redirectCache = ConcurrentDictionary<WebLogId, CachedRedirectRule list>()
/// Try to get the web log for the current request (longest matching URL base wins)
let tryGet (path : string) =
/// <summary>Try to get the web log for the current request (longest matching URL base wins)</summary>
/// <param name="path">The path for the current request</param>
/// <returns>Some with the web log matching the URL, or None if none is found</returns>
let tryGet (path: string) =
_cache
|> List.filter (fun wl -> path.StartsWith wl.UrlBase)
|> List.sortByDescending _.UrlBase.Length
|> List.tryHead
/// Cache the web log for a particular host
/// <summary>Cache the web log for a particular host</summary>
/// <param name="webLog">The web log to be cached</param>
let set webLog =
_cache <- webLog :: (_cache |> List.filter (fun wl -> wl.Id <> webLog.Id))
_redirectCache[webLog.Id] <-
@ -100,166 +105,124 @@ module WebLogCache =
RegEx(Regex(pattern, RegexOptions.Compiled ||| RegexOptions.IgnoreCase), urlTo)
else
Text(relUrl it.From, urlTo))
/// Get all cached web logs
/// <summary>Get all cached web logs</summary>
/// <returns>All cached web logs</returns>
let all () =
_cache
/// Fill the web log cache from the database
/// <summary>Fill the web log cache from the database</summary>
/// <param name="data">The data implementation from which web logs will be retrieved</param>
let fill (data: IData) = backgroundTask {
let! webLogs = data.WebLog.All()
webLogs |> List.iter set
}
/// Get the cached redirect rules for the given web log
/// <summary>Get the cached redirect rules for the given web log</summary>
/// <param name="webLogId">The ID of the web log for which rules should be retrieved</param>
/// <returns>The redirect rules for the given web log ID</returns>
let redirectRules webLogId =
_redirectCache[webLogId]
/// Is the given theme in use by any web logs?
/// <summary>Is the given theme in use by any web logs?</summary>
/// <param name="themeId">The ID of the theme whose use should be checked</param>
/// <returns>True if any web logs are using the given theme, false if not</returns>
let isThemeInUse themeId =
_cache |> List.exists (fun wl -> wl.ThemeId = themeId)
/// A cache of page information needed to display the page list in templates
/// <summary>A cache of page information needed to display the page list in templates</summary>
module PageListCache =
open MyWebLog.ViewModels
/// Cache of displayed pages
let private _cache = ConcurrentDictionary<WebLogId, DisplayPage array> ()
let private _cache = ConcurrentDictionary<WebLogId, DisplayPage array>()
/// Fill the page list for the given web log
let private fillPages (webLog: WebLog) pages =
_cache[webLog.Id] <-
pages
|> List.map (fun pg -> DisplayPage.FromPage webLog { pg with Text = "" })
|> Array.ofList
/// Are there pages cached for this web log?
/// <summary>Are there pages cached for this web log?</summary>
/// <param name="ctx">The <c>HttpContext</c> for the current request</param>
/// <returns>True if the current web log has any pages cached, false if not</returns>
let exists (ctx: HttpContext) = _cache.ContainsKey ctx.WebLog.Id
/// Get the pages for the web log for this request
/// <summary>Get the pages for the web log for this request</summary>
/// <param name="ctx">The <c>HttpContext</c> for the current request</param>
/// <returns>The page list for the current web log</returns>
let get (ctx: HttpContext) = _cache[ctx.WebLog.Id]
/// Update the pages for the current web log
let update (ctx: HttpContext) = backgroundTask {
let! pages = ctx.Data.Page.FindListed ctx.WebLog.Id
fillPages ctx.WebLog pages
}
/// Refresh the pages for the given web log
/// <summary>Refresh the pages for the given web log</summary>
/// <param name="webLog">The web log for which pages should be refreshed</param>
/// <param name="data">The data implementation from which pages should be retrieved</param>
let refresh (webLog: WebLog) (data: IData) = backgroundTask {
let! pages = data.Page.FindListed webLog.Id
fillPages webLog pages
}
/// <summary>Update the pages for the current web log</summary>
/// <param name="ctx">The <c>HttpContext</c> for the current request</param>
let update (ctx: HttpContext) =
refresh ctx.WebLog ctx.Data
/// Cache of all categories, indexed by web log
/// <summary>Cache of all categories, indexed by web log</summary>
module CategoryCache =
open MyWebLog.ViewModels
/// The cache itself
let private _cache = ConcurrentDictionary<WebLogId, DisplayCategory array> ()
/// Are there categories cached for this web log?
let private _cache = ConcurrentDictionary<WebLogId, DisplayCategory array>()
/// <summary>Are there categories cached for this web log?</summary>
/// <param name="ctx">The <c>HttpContext</c> for the current request</param>
/// <returns>True if the current web logs has any categories cached, false if not</returns>
let exists (ctx: HttpContext) = _cache.ContainsKey ctx.WebLog.Id
/// Get the categories for the web log for this request
/// <summary>Get the categories for the web log for this request</summary>
/// <param name="ctx">The <c>HttpContext</c> for the current request</param>
/// <returns>The categories for the current web log</returns>
let get (ctx: HttpContext) = _cache[ctx.WebLog.Id]
/// Update the cache with fresh data
let update (ctx: HttpContext) = backgroundTask {
let! cats = ctx.Data.Category.FindAllForView ctx.WebLog.Id
_cache[ctx.WebLog.Id] <- cats
}
/// Refresh the category cache for the given web log
/// <summary>Refresh the category cache for the given web log</summary>
/// <param name="webLogId">The ID of the web log for which the cache should be refreshed</param>
/// <param name="data">The data implementation from which categories should be retrieved</param>
let refresh webLogId (data: IData) = backgroundTask {
let! cats = data.Category.FindAllForView webLogId
_cache[webLogId] <- cats
}
/// Cache for parsed templates
module TemplateCache =
open System
open System.Text.RegularExpressions
open DotLiquid
/// Cache of parsed templates
let private _cache = ConcurrentDictionary<string, Template> ()
/// Custom include parameter pattern
let private hasInclude = Regex("""{% include_template \"(.*)\" %}""", RegexOptions.None, TimeSpan.FromSeconds 2)
/// Get a template for the given theme and template name
let get (themeId: ThemeId) (templateName: string) (data: IData) = backgroundTask {
let templatePath = $"{themeId}/{templateName}"
match _cache.ContainsKey templatePath with
| true -> return Ok _cache[templatePath]
| false ->
match! data.Theme.FindById themeId with
| Some theme ->
match theme.Templates |> List.tryFind (fun t -> t.Name = templateName) with
| Some template ->
let mutable text = template.Text
let mutable childNotFound = ""
while hasInclude.IsMatch text do
let child = hasInclude.Match text
let childText =
match theme.Templates |> List.tryFind (fun t -> t.Name = child.Groups[1].Value) with
| Some childTemplate -> childTemplate.Text
| None ->
childNotFound <-
if childNotFound = "" then child.Groups[1].Value
else $"{childNotFound}; {child.Groups[1].Value}"
""
text <- text.Replace(child.Value, childText)
if childNotFound <> "" then
let s = if childNotFound.IndexOf ";" >= 0 then "s" else ""
return Error $"Could not find the child template{s} {childNotFound} required by {templateName}"
else
_cache[templatePath] <- Template.Parse(text, SyntaxCompatibility.DotLiquid22)
return Ok _cache[templatePath]
| None ->
return Error $"Theme ID {themeId} does not have a template named {templateName}"
| None -> return Error $"Theme ID {themeId} does not exist"
}
/// Get all theme/template names currently cached
let allNames () =
_cache.Keys |> Seq.sort |> Seq.toList
/// Invalidate all template cache entries for the given theme ID
let invalidateTheme (themeId: ThemeId) =
let keyPrefix = string themeId
_cache.Keys
|> Seq.filter _.StartsWith(keyPrefix)
|> List.ofSeq
|> List.iter (fun key -> match _cache.TryRemove key with _, _ -> ())
/// Remove all entries from the template cache
let empty () =
_cache.Clear()
/// <summary>Update the cache with fresh data for the current web log</summary>
/// <param name="ctx">The <c>HttpContext</c> for the current request</param>
let update (ctx: HttpContext) =
refresh ctx.WebLog.Id ctx.Data
/// A cache of asset names by themes
/// <summary>A cache of asset names by themes</summary>
module ThemeAssetCache =
/// A list of asset names for each theme
let private _cache = ConcurrentDictionary<ThemeId, string list> ()
/// Retrieve the assets for the given theme ID
let private _cache = ConcurrentDictionary<ThemeId, string list>()
/// <summary>Retrieve the assets for the given theme ID</summary>
/// <param name="themeId">The ID of the theme whose assets should be returned</param>
/// <returns>The assets for the given theme</returns>
let get themeId = _cache[themeId]
/// Refresh the list of assets for the given theme
/// <summary>Refresh the list of assets for the given theme</summary>
/// <param name="themeId">The ID of the theme whose assets should be refreshed</param>
/// <param name="data">The data implementation from which assets should be retrieved</param>
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
/// <summary>Fill the theme asset cache</summary>
/// <param name="data">The data implementation from which assets should be retrieved</param>
let fill (data: IData) = backgroundTask {
let! assets = data.ThemeAsset.All()
for asset in assets do

View File

@ -28,13 +28,13 @@ module Dashboard =
ListedPages = listed
Categories = cats
TopLevelCategories = topCats }
return! adminPage "Dashboard" false next ctx (Views.WebLog.dashboard model)
return! adminPage "Dashboard" next ctx (Views.WebLog.dashboard model)
}
// GET /admin/administration
let admin : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
let! themes = ctx.Data.Theme.All()
return! adminPage "myWebLog Administration" true next ctx (Views.Admin.dashboard themes)
return! adminPage "myWebLog Administration" next ctx (Views.Admin.dashboard themes)
}
/// Redirect the user to the admin dashboard
@ -71,7 +71,7 @@ module Cache =
let refreshTheme themeId : HttpHandler = requireAccess Administrator >=> fun next ctx -> task {
let data = ctx.Data
if themeId = "all" then
TemplateCache.empty ()
Template.Cache.empty ()
do! ThemeAssetCache.fill data
do! addMessage ctx
{ UserMessage.Success with
@ -79,7 +79,7 @@ module Cache =
else
match! data.Theme.FindById(ThemeId themeId) with
| Some theme ->
TemplateCache.invalidateTheme theme.Id
Template.Cache.invalidateTheme theme.Id
do! ThemeAssetCache.refreshTheme theme.Id data
do! addMessage ctx
{ UserMessage.Success with
@ -98,7 +98,7 @@ module Category =
// GET /admin/categories
let all : HttpHandler = fun next ctx ->
let response = fun next ctx ->
adminPage "Categories" true next ctx (Views.WebLog.categoryList (ctx.Request.Query.ContainsKey "new"))
adminPage "Categories" next ctx (Views.WebLog.categoryList (ctx.Request.Query.ContainsKey "new"))
(withHxPushUrl (ctx.WebLog.RelativeUrl (Permalink "admin/categories")) >=> response) next ctx
// GET /admin/category/{id}/edit
@ -115,7 +115,7 @@ module Category =
| Some (title, cat) ->
return!
Views.WebLog.categoryEdit (EditCategoryModel.FromCategory cat)
|> adminBarePage title true next ctx
|> adminBarePage title next ctx
| None -> return! Error.notFound next ctx
}
@ -167,7 +167,7 @@ module RedirectRules =
// GET /admin/settings/redirect-rules
let all : HttpHandler = fun next ctx ->
adminPage "Redirect Rules" true next ctx (Views.WebLog.redirectList ctx.WebLog.RedirectRules)
adminPage "Redirect Rules" next ctx (Views.WebLog.redirectList ctx.WebLog.RedirectRules)
// GET /admin/settings/redirect-rules/[index]
let edit idx : HttpHandler = fun next ctx ->
@ -182,7 +182,7 @@ module RedirectRules =
Some
("Edit", (Views.WebLog.redirectEdit (EditRedirectRuleModel.FromRule idx (List.item idx rules))))
match titleAndView with
| Some (title, view) -> adminBarePage $"{title} Redirect Rule" true next ctx view
| Some (title, view) -> adminBarePage $"{title} Redirect Rule" next ctx view
| None -> Error.notFound next ctx
/// Update the web log's redirect rules in the database, the request web log, and the web log cache
@ -247,7 +247,7 @@ module TagMapping =
// GET /admin/settings/tag-mappings
let all : HttpHandler = fun next ctx -> task {
let! mappings = ctx.Data.TagMap.FindByWebLog ctx.WebLog.Id
return! adminBarePage "Tag Mapping List" true next ctx (Views.WebLog.tagMapList mappings)
return! adminBarePage "Tag Mapping List" next ctx (Views.WebLog.tagMapList mappings)
}
// GET /admin/settings/tag-mapping/{id}/edit
@ -260,7 +260,7 @@ module TagMapping =
| Some tm ->
return!
Views.WebLog.tagMapEdit (EditTagMapModel.FromMapping tm)
|> adminBarePage (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag") true next ctx
|> adminBarePage (if isNew then "Add Tag Mapping" else $"Mapping for {tm.Tag} Tag") next ctx
| None -> return! Error.notFound next ctx
}
@ -302,12 +302,12 @@ module Theme =
let! themes = ctx.Data.Theme.All ()
return!
Views.Admin.themeList (List.map (DisplayTheme.FromTheme WebLogCache.isThemeInUse) themes)
|> adminBarePage "Themes" true next ctx
|> adminBarePage "Themes" next ctx
}
// GET /admin/theme/new
let add : HttpHandler = requireAccess Administrator >=> fun next ctx ->
adminBarePage "Upload a Theme File" true next ctx Views.Admin.themeUpload
adminBarePage "Upload a Theme File" next ctx Views.Admin.themeUpload
/// Update the name and version for a theme based on the version.txt file, if present
let private updateNameAndVersion (theme: Theme) (zip: ZipArchive) = backgroundTask {
@ -398,7 +398,7 @@ module Theme =
do! themeFile.CopyToAsync stream
let! _ = loadFromZip themeId stream data
do! ThemeAssetCache.refreshTheme themeId data
TemplateCache.invalidateTheme themeId
Template.Cache.invalidateTheme themeId
// Ensure the themes directory exists
let themeDir = Path.Combine(".", "themes")
if not (Directory.Exists themeDir) then Directory.CreateDirectory themeDir |> ignore
@ -464,7 +464,7 @@ module WebLog =
return!
Views.WebLog.webLogSettings
(SettingsModel.FromWebLog ctx.WebLog) themes pages uploads (EditRssModel.FromRssOptions ctx.WebLog.Rss)
|> adminPage "Web Log Settings" true next ctx
|> adminPage "Web Log Settings" next ctx
}
// POST /admin/settings

View File

@ -453,7 +453,7 @@ let editCustomFeed feedId : HttpHandler = requireAccess WebLogAdmin >=> fun next
{ Name = string Blog; Value = "Blog" }
]
Views.WebLog.feedEdit (EditCustomFeedModel.FromFeed f) ratings mediums
|> adminPage $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed""" true next ctx
|> adminPage $"""{if feedId = "new" then "Add" else "Edit"} Custom RSS Feed""" next ctx
| None -> Error.notFound next ctx
// POST /admin/settings/rss/save

View File

@ -19,113 +19,9 @@ type ISession with
| item -> Some (JsonSerializer.Deserialize<'T> item)
/// Keys used in the myWebLog-standard DotLiquid hash
module ViewContext =
/// The anti cross-site request forgery (CSRF) token set to use for form submissions
[<Literal>]
let AntiCsrfTokens = "csrf"
/// The unified application view context
[<Literal>]
let AppViewContext = "app"
/// The categories for this web log
[<Literal>]
let Categories = "categories"
/// The main content of the view
[<Literal>]
let Content = "content"
/// The current page URL
[<Literal>]
let CurrentPage = "current_page"
/// The generator string for the current version of myWebLog
[<Literal>]
let Generator = "generator"
/// The HTML to load htmx from the unpkg CDN
[<Literal>]
let HtmxScript = "htmx_script"
/// Whether the current user has Administrator privileges
[<Literal>]
let IsAdministrator = "is_administrator"
/// Whether the current user has Author (or above) privileges
[<Literal>]
let IsAuthor = "is_author"
/// Whether the current view is displaying a category archive page
[<Literal>]
let IsCategory = "is_category"
/// Whether the current view is displaying the first page of a category archive
[<Literal>]
let IsCategoryHome = "is_category_home"
/// Whether the current user has Editor (or above) privileges
[<Literal>]
let IsEditor = "is_editor"
/// Whether the current view is the home page for the web log
[<Literal>]
let IsHome = "is_home"
/// Whether there is a user logged on
[<Literal>]
let IsLoggedOn = "is_logged_on"
/// Whether the current view is displaying a page
[<Literal>]
let IsPage = "is_page"
/// Whether the current view is displaying a post
[<Literal>]
let IsPost = "is_post"
/// Whether the current view is a tag archive page
[<Literal>]
let IsTag = "is_tag"
/// Whether the current view is the first page of a tag archive
[<Literal>]
let IsTagHome = "is_tag_home"
/// Whether the current user has Web Log Admin (or above) privileges
[<Literal>]
let IsWebLogAdmin = "is_web_log_admin"
/// Messages to be displayed to the user
[<Literal>]
let Messages = "messages"
/// The view model / form for the page
[<Literal>]
let Model = "model"
/// The listed pages for the web log
[<Literal>]
let PageList = "page_list"
/// The title of the page being displayed
[<Literal>]
let PageTitle = "page_title"
/// The slug for category or tag archive pages
[<Literal>]
let Slug = "slug"
/// The ID of the current user
[<Literal>]
let UserId = "user_id"
/// The current web log
[<Literal>]
let WebLog = "web_log"
/// Messages to be displayed to the user
[<Literal>]
let MESSAGES = "messages"
/// The HTTP item key for loading the session
let private sessionLoadedKey = "session-loaded"
@ -147,36 +43,25 @@ open MyWebLog.ViewModels
/// Add a message to the user's session
let addMessage (ctx: HttpContext) message = task {
do! loadSession ctx
let msg = match ctx.Session.TryGet<UserMessage list> ViewContext.Messages with Some it -> it | None -> []
ctx.Session.Set(ViewContext.Messages, message :: msg)
let msg = match ctx.Session.TryGet<UserMessage list> MESSAGES with Some it -> it | None -> []
ctx.Session.Set(MESSAGES, message :: msg)
}
/// Get any messages from the user's session, removing them in the process
let messages (ctx: HttpContext) = task {
do! loadSession ctx
match ctx.Session.TryGet<UserMessage list> ViewContext.Messages with
match ctx.Session.TryGet<UserMessage list> MESSAGES with
| Some msg ->
ctx.Session.Remove ViewContext.Messages
ctx.Session.Remove MESSAGES
return msg |> (List.rev >> Array.ofList)
| None -> return [||]
}
open MyWebLog
open DotLiquid
/// Shorthand for creating a DotLiquid hash from an anonymous object
let makeHash (values: obj) =
Hash.FromAnonymousObject values
/// Create a hash with the page title filled
let hashForPage (title: string) =
makeHash {| page_title = title |}
/// Add a key to the hash, returning the modified hash
// (note that the hash itself is mutated; this is only used to make it pipeable)
let addToHash key (value: obj) (hash: Hash) =
if hash.ContainsKey key then hash[key] <- value else hash.Add(key, value)
hash
/// Create a view context with the page title filled
let viewCtxForPage title =
{ AppViewContext.Empty with PageTitle = title }
open System.Security.Claims
open Giraffe
@ -194,54 +79,31 @@ let private getCurrentMessages ctx = task {
}
/// Generate the view context for a response
let private generateViewContext pageTitle messages includeCsrf (ctx: HttpContext) =
{ WebLog = ctx.WebLog
UserId = ctx.User.Claims
|> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.NameIdentifier)
|> Option.map (fun claim -> WebLogUserId claim.Value)
PageTitle = pageTitle
Csrf = if includeCsrf then Some ctx.CsrfTokenSet else None
PageList = PageListCache.get ctx
Categories = CategoryCache.get ctx
CurrentPage = ctx.Request.Path.Value[1..]
Messages = messages
Generator = ctx.Generator
HtmxScript = htmxScript
IsAuthor = ctx.HasAccessLevel Author
IsEditor = ctx.HasAccessLevel Editor
IsWebLogAdmin = ctx.HasAccessLevel WebLogAdmin
IsAdministrator = ctx.HasAccessLevel Administrator }
let private generateViewContext messages viewCtx (ctx: HttpContext) =
{ viewCtx with
WebLog = ctx.WebLog
UserId = ctx.User.Claims
|> Seq.tryFind (fun claim -> claim.Type = ClaimTypes.NameIdentifier)
|> Option.map (fun claim -> WebLogUserId claim.Value)
Csrf = Some ctx.CsrfTokenSet
PageList = PageListCache.get ctx
Categories = CategoryCache.get ctx
CurrentPage = ctx.Request.Path.Value[1..]
Messages = messages
Generator = ctx.Generator
HtmxScript = htmxScript
IsAuthor = ctx.HasAccessLevel Author
IsEditor = ctx.HasAccessLevel Editor
IsWebLogAdmin = ctx.HasAccessLevel WebLogAdmin
IsAdministrator = ctx.HasAccessLevel Administrator }
/// Populate the DotLiquid hash with standard information
let addViewContext ctx (hash: Hash) = task {
/// Update the view context with standard information (if it has not been done yet) or updated messages
let updateViewContext ctx viewCtx = task {
let! messages = getCurrentMessages ctx
if hash.ContainsKey ViewContext.AppViewContext then
let oldApp = hash[ViewContext.AppViewContext] :?> AppViewContext
let newApp = { oldApp with Messages = Array.concat [ oldApp.Messages; messages ] }
return
hash
|> addToHash ViewContext.AppViewContext newApp
|> addToHash ViewContext.Messages newApp.Messages
if viewCtx.Generator = "" then
return generateViewContext messages viewCtx ctx
else
let app =
generateViewContext (string hash[ViewContext.PageTitle]) messages
(hash.ContainsKey ViewContext.AntiCsrfTokens) ctx
return
hash
|> addToHash ViewContext.UserId (app.UserId |> Option.map string |> Option.defaultValue "")
|> addToHash ViewContext.WebLog app.WebLog
|> addToHash ViewContext.PageList app.PageList
|> addToHash ViewContext.Categories app.Categories
|> addToHash ViewContext.CurrentPage app.CurrentPage
|> addToHash ViewContext.Messages app.Messages
|> addToHash ViewContext.Generator app.Generator
|> addToHash ViewContext.HtmxScript app.HtmxScript
|> addToHash ViewContext.IsLoggedOn app.IsLoggedOn
|> addToHash ViewContext.IsAuthor app.IsAuthor
|> addToHash ViewContext.IsEditor app.IsEditor
|> addToHash ViewContext.IsWebLogAdmin app.IsWebLogAdmin
|> addToHash ViewContext.IsAdministrator app.IsAdministrator
return { viewCtx with Messages = Array.concat [ viewCtx.Messages; messages ] }
}
/// Is the request from htmx?
@ -269,6 +131,7 @@ let redirectToGet url : HttpHandler = fun _ ctx -> task {
}
/// The MIME type for podcast episode JSON chapters
[<Literal>]
let JSON_CHAPTERS = "application/json+chapters"
@ -311,65 +174,65 @@ module Error =
else ServerErrors.INTERNAL_ERROR message earlyReturn ctx)
/// Render a view for the specified theme, using the specified template, layout, and hash
let viewForTheme themeId template next ctx (hash: Hash) = task {
let! hash = addViewContext ctx hash
/// Render a view for the specified theme, using the specified template, layout, and context
let viewForTheme themeId template next ctx (viewCtx: AppViewContext) = task {
let! updated = updateViewContext ctx viewCtx
// NOTE: DotLiquid does not support {% render %} or {% include %} in its templates, so we will do a 2-pass render;
// the net effect is a "layout" capability similar to Razor or Pug
// NOTE: Although Fluid's view engine support implements layouts and sections, it also relies on the filesystem.
// As we are loading templates from memory or a database, we do a 2-pass render; the first for the content,
// the second for the overall page.
// Render view content...
match! TemplateCache.get themeId template ctx.Data with
match! Template.Cache.get themeId template ctx.Data with
| Ok contentTemplate ->
let _ = addToHash ViewContext.Content (contentTemplate.Render hash) hash
let forLayout = { updated with Content = Template.render contentTemplate updated ctx.Data }
// ...then render that content with its layout
match! TemplateCache.get themeId (if isHtmx ctx then "layout-partial" else "layout") ctx.Data with
| Ok layoutTemplate -> return! htmlString (layoutTemplate.Render hash) next ctx
match! Template.Cache.get themeId (if isHtmx ctx then "layout-partial" else "layout") ctx.Data with
| Ok layoutTemplate -> return! htmlString (Template.render layoutTemplate forLayout ctx.Data) next ctx
| Error message -> return! Error.server message next ctx
| Error message -> return! Error.server message next ctx
}
/// Render a bare view for the specified theme, using the specified template and hash
let bareForTheme themeId template next ctx (hash: Hash) = task {
let! hash = addViewContext ctx hash
/// Render a bare view for the specified theme, using the specified template and context
let bareForTheme themeId template next ctx viewCtx = task {
let! updated = updateViewContext ctx viewCtx
let withContent = task {
if hash.ContainsKey ViewContext.Content then return Ok hash
if updated.Content = "" then
match! Template.Cache.get themeId template ctx.Data with
| Ok contentTemplate -> return Ok { updated with Content = Template.render contentTemplate updated ctx.Data }
| Error message -> return Error message
else
match! TemplateCache.get themeId template ctx.Data with
| Ok contentTemplate -> return Ok(addToHash ViewContext.Content (contentTemplate.Render hash) hash)
| Error message -> return Error message
return Ok viewCtx
}
match! withContent with
| Ok completeHash ->
| Ok completeCtx ->
// Bare templates are rendered with layout-bare
match! TemplateCache.get themeId "layout-bare" ctx.Data with
match! Template.Cache.get themeId "layout-bare" ctx.Data with
| Ok layoutTemplate ->
return!
(messagesToHeaders (hash[ViewContext.Messages] :?> UserMessage array)
>=> htmlString (layoutTemplate.Render completeHash))
(messagesToHeaders completeCtx.Messages >=> htmlString (Template.render layoutTemplate completeCtx ctx.Data))
next ctx
| Error message -> return! Error.server message next ctx
| Error message -> return! Error.server message next ctx
}
/// Return a view for the web log's default theme
let themedView template next ctx hash = task {
let! hash = addViewContext ctx hash
return! viewForTheme (hash[ViewContext.WebLog] :?> WebLog).ThemeId template next ctx hash
let themedView template next (ctx: HttpContext) viewCtx = task {
return! viewForTheme ctx.WebLog.ThemeId template next ctx viewCtx
}
/// Display a page for an admin endpoint
let adminPage pageTitle includeCsrf next ctx (content: AppViewContext -> XmlNode list) = task {
let adminPage pageTitle next ctx (content: AppViewContext -> XmlNode list) = task {
let! messages = getCurrentMessages ctx
let appCtx = generateViewContext pageTitle messages includeCsrf ctx
let appCtx = generateViewContext messages (viewCtxForPage pageTitle) ctx
let layout = if isHtmx ctx then Layout.partial else Layout.full
return! htmlString (layout content appCtx |> RenderView.AsString.htmlDocument) next ctx
}
/// Display a bare page for an admin endpoint
let adminBarePage pageTitle includeCsrf next ctx (content: AppViewContext -> XmlNode list) = task {
let adminBarePage pageTitle next ctx (content: AppViewContext -> XmlNode list) = task {
let! messages = getCurrentMessages ctx
let appCtx = generateViewContext pageTitle messages includeCsrf ctx
let appCtx = generateViewContext messages (viewCtxForPage pageTitle) ctx
return!
( messagesToHeaders appCtx.Messages
>=> htmlString (Layout.bare content appCtx |> RenderView.AsString.htmlDocument)) next ctx

View File

@ -17,7 +17,7 @@ let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task {
|> List.ofSeq
return!
Views.Page.pageList displayPages pageNbr (pages.Length > 25)
|> adminPage "Pages" true next ctx
|> adminPage "Pages" next ctx
}
// GET /admin/page/{id}/edit
@ -34,7 +34,7 @@ let edit pgId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
| Some (title, page) when canEdit page.AuthorId ctx ->
let model = EditPageModel.FromPage page
let! templates = templatesForTheme ctx "page"
return! adminPage title true next ctx (Views.Page.pageEdit model templates)
return! adminPage title next ctx (Views.Page.pageEdit model templates)
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@ -56,7 +56,7 @@ let editPermalinks pgId : HttpHandler = requireAccess Author >=> fun next ctx ->
return!
ManagePermalinksModel.FromPage pg
|> Views.Helpers.managePermalinks
|> adminPage "Manage Prior Permalinks" true next ctx
|> adminPage "Manage Prior Permalinks" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@ -84,7 +84,7 @@ let editRevisions pgId : HttpHandler = requireAccess Author >=> fun next ctx ->
return!
ManageRevisionsModel.FromPage pg
|> Views.Helpers.manageRevisions
|> adminPage "Manage Page Revisions" true next ctx
|> adminPage "Manage Page Revisions" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@ -115,7 +115,7 @@ let private findPageRevision pgId revDate (ctx: HttpContext) = task {
let previewRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPageRevision pgId revDate ctx with
| Some pg, Some rev when canEdit pg.AuthorId ctx ->
return! adminBarePage "" false next ctx (Views.Helpers.commonPreview rev)
return! adminBarePage "" next ctx (Views.Helpers.commonPreview rev)
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _ | _, None -> return! Error.notFound next ctx
}
@ -141,7 +141,7 @@ let deleteRevision (pgId, revDate) : HttpHandler = requireAccess Author >=> fun
| Some pg, Some rev when canEdit pg.AuthorId ctx ->
do! ctx.Data.Page.Update { pg with Revisions = pg.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) }
do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" }
return! adminBarePage "" false next ctx (fun _ -> [])
return! adminBarePage "" next ctx (fun _ -> [])
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx

View File

@ -4,6 +4,7 @@ module MyWebLog.Handlers.Post
open System
open System.Collections.Generic
open MyWebLog
open MyWebLog.Views
/// Parse a slug and page number from an "everything else" URL
let private parseSlugAndPage webLog (slugAndPage: string seq) =
@ -87,30 +88,29 @@ let preparePostList webLog posts listType (url: string) pageNbr perPage (data: I
OlderName = olderPost |> Option.map _.Title
}
return
makeHash {||}
|> addToHash ViewContext.Model model
|> addToHash "tag_mappings" tagMappings
|> addToHash ViewContext.IsPost (match listType with SinglePost -> true | _ -> false)
{ AppViewContext.Empty with
Payload = model
TagMappings = Array.ofList tagMappings
IsPost = (match listType with SinglePost -> true | _ -> false) }
}
open Giraffe
// GET /page/{pageNbr}
let pageOfPosts pageNbr : HttpHandler = fun next ctx -> task {
let count = ctx.WebLog.PostsPerPage
let data = ctx.Data
let! posts = data.Post.FindPageOfPublishedPosts ctx.WebLog.Id pageNbr count
let! hash = preparePostList ctx.WebLog posts PostList "" pageNbr count data
let title =
let count = ctx.WebLog.PostsPerPage
let data = ctx.Data
let! posts = data.Post.FindPageOfPublishedPosts ctx.WebLog.Id pageNbr count
let! viewCtx = preparePostList ctx.WebLog posts PostList "" pageNbr count data
let title =
match pageNbr, ctx.WebLog.DefaultPage with
| 1, "posts" -> None
| _, "posts" -> Some $"Page {pageNbr}"
| _, _ -> Some $"Page {pageNbr} &laquo; Posts"
return!
match title with Some ttl -> addToHash ViewContext.PageTitle ttl hash | None -> hash
|> function
| hash ->
if pageNbr = 1 && ctx.WebLog.DefaultPage = "posts" then addToHash ViewContext.IsHome true hash else hash
{ viewCtx with
PageTitle = defaultArg title viewCtx.PageTitle
IsHome = pageNbr = 1 && ctx.WebLog.DefaultPage = "posts" }
|> themedView "index" next ctx
}
@ -134,14 +134,15 @@ let pageOfCategorizedPosts slugAndPage : HttpHandler = fun next ctx -> task {
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 data
let! viewCtx = preparePostList webLog posts CategoryList cat.Slug pageNbr webLog.PostsPerPage data
let pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
return!
addToHash ViewContext.PageTitle $"{cat.Name}: Category Archive{pgTitle}" hash
|> addToHash "subtitle" (defaultArg cat.Description "")
|> addToHash ViewContext.IsCategory true
|> addToHash ViewContext.IsCategoryHome (pageNbr = 1)
|> addToHash ViewContext.Slug slug
{ viewCtx with
PageTitle = $"{cat.Name}: Category Archive{pgTitle}"
Subtitle = cat.Description
IsCategory = true
IsCategoryHome = (pageNbr = 1)
Slug = Some slug }
|> themedView "index" next ctx
| _ -> return! Error.notFound next ctx
| None -> return! Error.notFound next ctx
@ -169,13 +170,14 @@ let pageOfTaggedPosts slugAndPage : HttpHandler = fun next ctx -> task {
else
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 data
let pgTitle = if pageNbr = 1 then "" else $""" <small class="archive-pg-nbr">(Page {pageNbr})</small>"""
let! viewCtx = preparePostList webLog posts TagList rawTag pageNbr webLog.PostsPerPage data
let pgTitle = if pageNbr = 1 then "" else $" <small class=\"archive-pg-nbr\">(Page {pageNbr})</small>"
return!
addToHash ViewContext.PageTitle $"Posts Tagged &ldquo;{tag}&rdquo;{pgTitle}" hash
|> addToHash ViewContext.IsTag true
|> addToHash ViewContext.IsTagHome (pageNbr = 1)
|> addToHash ViewContext.Slug rawTag
{ viewCtx with
PageTitle = $"Posts Tagged &ldquo;{tag}&rdquo;{pgTitle}"
IsTag = true
IsTagHome = (pageNbr = 1)
Slug = Some rawTag }
|> themedView "index" next ctx
// Other systems use hyphens for spaces; redirect if this is an old tag link
| _ ->
@ -200,9 +202,9 @@ let home : HttpHandler = fun next ctx -> task {
match! ctx.Data.Page.FindById (PageId pageId) webLog.Id with
| Some page ->
return!
hashForPage page.Title
|> addToHash "page" (DisplayPage.FromPage webLog page)
|> addToHash ViewContext.IsHome true
{ viewCtxForPage page.Title with
Payload = DisplayPage.FromPage webLog page
IsHome = true }
|> themedView (defaultArg page.Template "single-page") next ctx
| None -> return! Error.notFound next ctx
}
@ -251,10 +253,10 @@ let chapters (post: Post) : HttpHandler = fun next ctx ->
// GET /admin/posts
// GET /admin/posts/page/{pageNbr}
let all pageNbr : HttpHandler = requireAccess Author >=> fun next ctx -> task {
let data = ctx.Data
let! posts = data.Post.FindPageOfPosts ctx.WebLog.Id pageNbr 25
let! hash = preparePostList ctx.WebLog posts AdminList "" pageNbr 25 data
return! adminPage "Posts" true next ctx (Views.Post.list (hash[ViewContext.Model] :?> PostDisplay))
let data = ctx.Data
let! posts = data.Post.FindPageOfPosts ctx.WebLog.Id pageNbr 25
let! viewCtx = preparePostList ctx.WebLog posts AdminList "" pageNbr 25 data
return! adminPage "Posts" next ctx (Post.list viewCtx.Posts)
}
// GET /admin/post/{id}/edit
@ -278,7 +280,7 @@ let edit postId : HttpHandler = requireAccess Author >=> fun next ctx -> task {
{ Name = string No; Value = "No" }
{ Name = string Clean; Value = "Clean" }
]
return! adminPage title true next ctx (Views.Post.postEdit model templates ratings)
return! adminPage title next ctx (Post.postEdit model templates ratings)
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@ -298,8 +300,8 @@ let editPermalinks postId : HttpHandler = requireAccess Author >=> fun next ctx
| Some post when canEdit post.AuthorId ctx ->
return!
ManagePermalinksModel.FromPost post
|> Views.Helpers.managePermalinks
|> adminPage "Manage Prior Permalinks" true next ctx
|> managePermalinks
|> adminPage "Manage Prior Permalinks" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@ -326,8 +328,8 @@ let editRevisions postId : HttpHandler = requireAccess Author >=> fun next ctx -
| Some post when canEdit post.AuthorId ctx ->
return!
ManageRevisionsModel.FromPost post
|> Views.Helpers.manageRevisions
|> adminPage "Manage Post Revisions" true next ctx
|> manageRevisions
|> adminPage "Manage Post Revisions" next ctx
| Some _ -> return! Error.notAuthorized next ctx
| None -> return! Error.notFound next ctx
}
@ -359,7 +361,7 @@ let private findPostRevision postId revDate (ctx: HttpContext) = task {
let previewRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fun next ctx -> task {
match! findPostRevision postId revDate ctx with
| Some post, Some rev when canEdit post.AuthorId ctx ->
return! adminBarePage "" false next ctx (Views.Helpers.commonPreview rev)
return! adminBarePage "" next ctx (commonPreview rev)
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _ | _, None -> return! Error.notFound next ctx
}
@ -385,7 +387,7 @@ let deleteRevision (postId, revDate) : HttpHandler = requireAccess Author >=> fu
| Some post, Some rev when canEdit post.AuthorId ctx ->
do! ctx.Data.Post.Update { post with Revisions = post.Revisions |> List.filter (fun r -> r.AsOf <> rev.AsOf) }
do! addMessage ctx { UserMessage.Success with Message = "Revision deleted successfully" }
return! adminBarePage "" false next ctx (fun _ -> [])
return! adminBarePage "" next ctx (fun _ -> [])
| Some _, Some _ -> return! Error.notAuthorized next ctx
| None, _
| _, None -> return! Error.notFound next ctx
@ -399,8 +401,8 @@ let manageChapters postId : HttpHandler = requireAccess Author >=> fun next ctx
&& Option.isSome post.Episode.Value.Chapters
&& canEdit post.AuthorId ctx ->
return!
Views.Post.chapters false (ManageChaptersModel.Create post)
|> adminPage "Manage Chapters" true next ctx
Post.chapters false (ManageChaptersModel.Create post)
|> adminPage "Manage Chapters" next ctx
| Some _ | None -> return! Error.notFound next ctx
}
@ -419,8 +421,8 @@ let editChapter (postId, index) : HttpHandler = requireAccess Author >=> fun nex
match chapter with
| Some chap ->
return!
Views.Post.chapterEdit (EditChapterModel.FromChapter post.Id index chap)
|> adminBarePage (if index = -1 then "Add a Chapter" else "Edit Chapter") true next ctx
Post.chapterEdit (EditChapterModel.FromChapter post.Id index chap)
|> adminBarePage (if index = -1 then "Add a Chapter" else "Edit Chapter") next ctx
| None -> return! Error.notFound next ctx
| Some _ | None -> return! Error.notFound next ctx
}
@ -447,8 +449,8 @@ let saveChapter (postId, index) : HttpHandler = requireAccess Author >=> fun nex
do! data.Post.Update updatedPost
do! addMessage ctx { UserMessage.Success with Message = "Chapter saved successfully" }
return!
Views.Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost)
|> adminBarePage "Manage Chapters" true next ctx
Post.chapterList form.AddAnother (ManageChaptersModel.Create updatedPost)
|> adminBarePage "Manage Chapters" next ctx
with
| ex -> return! Error.server ex.Message next ctx
else return! Error.notFound next ctx
@ -471,8 +473,8 @@ let deleteChapter (postId, index) : HttpHandler = requireAccess Author >=> fun n
do! data.Post.Update updatedPost
do! addMessage ctx { UserMessage.Success with Message = "Chapter deleted successfully" }
return!
Views.Post.chapterList false (ManageChaptersModel.Create updatedPost)
|> adminPage "Manage Chapters" true next ctx
Post.chapterList false (ManageChaptersModel.Create updatedPost)
|> adminPage "Manage Chapters" next ctx
else return! Error.notFound next ctx
| Some _ | None -> return! Error.notFound next ctx
}

View File

@ -34,9 +34,8 @@ module CatchAll =
yield Post.chapters post
else
yield fun next ctx ->
Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 data
|> await
|> addToHash ViewContext.PageTitle post.Title
{ await (Post.preparePostList webLog [ post ] Post.ListType.SinglePost "" 1 1 data) with
PageTitle = post.Title }
|> themedView (defaultArg post.Template "single-post") next ctx
| None -> ()
// Current page
@ -44,9 +43,9 @@ module CatchAll =
| Some page ->
debug (fun () -> "Found page by permalink")
yield fun next ctx ->
hashForPage page.Title
|> addToHash "page" (DisplayPage.FromPage webLog page)
|> addToHash ViewContext.IsPage true
{ viewCtxForPage page.Title with
Payload = DisplayPage.FromPage webLog page
IsPage = true }
|> themedView (defaultArg page.Template "single-page") next ctx
| None -> ()
// RSS feed

View File

@ -120,12 +120,12 @@ let list : HttpHandler = requireAccess Author >=> fun next ctx -> task {
|> Seq.append diskUploads
|> Seq.sortByDescending (fun file -> file.UpdatedOn, file.Path)
|> Views.WebLog.uploadList
|> adminPage "Uploaded Files" true next ctx
|> adminPage "Uploaded Files" next ctx
}
// GET /admin/upload/new
let showNew : HttpHandler = requireAccess Author >=> fun next ctx ->
adminPage "Upload a File" true next ctx Views.WebLog.uploadNew
adminPage "Upload a File" next ctx Views.WebLog.uploadNew
// POST /admin/upload/save
let save : HttpHandler = requireAccess Author >=> fun next ctx -> task {

View File

@ -35,7 +35,7 @@ let logOn returnUrl : HttpHandler = fun next ctx ->
match returnUrl with
| Some _ -> returnUrl
| None -> if ctx.Request.Query.ContainsKey "returnUrl" then Some ctx.Request.Query["returnUrl"].[0] else None
adminPage "Log On" true next ctx (Views.User.logOn { LogOnModel.Empty with ReturnTo = returnTo })
adminPage "Log On" next ctx (Views.User.logOn { LogOnModel.Empty with ReturnTo = returnTo })
open System.Security.Claims
@ -91,12 +91,12 @@ let private goAway : HttpHandler = RequestErrors.BAD_REQUEST "really?"
// GET /admin/settings/users
let all : HttpHandler = fun next ctx -> task {
let! users = ctx.Data.WebLogUser.FindByWebLog ctx.WebLog.Id
return! adminBarePage "User Administration" true next ctx (Views.User.userList users)
return! adminBarePage "User Administration" next ctx (Views.User.userList users)
}
/// Show the edit user page
let private showEdit (model: EditUserModel) : HttpHandler = fun next ctx ->
adminBarePage (if model.IsNew then "Add a New User" else "Edit User") true next ctx (Views.User.edit model)
adminBarePage (if model.IsNew then "Add a New User" else "Edit User") next ctx (Views.User.edit model)
// GET /admin/settings/user/{id}/edit
let edit usrId : HttpHandler = fun next ctx -> task {
@ -139,7 +139,7 @@ let myInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
| Some user ->
return!
Views.User.myInfo (EditMyInfoModel.FromUser user) user
|> adminPage "Edit Your Information" true next ctx
|> adminPage "Edit Your Information" next ctx
| None -> return! Error.notFound next ctx
}
@ -164,7 +164,7 @@ let saveMyInfo : HttpHandler = requireAccess Author >=> fun next ctx -> task {
do! addMessage ctx { UserMessage.Error with Message = "Passwords did not match; no updates made" }
return!
Views.User.myInfo { model with NewPassword = ""; NewPasswordConfirm = "" } user
|> adminPage "Edit Your Information" true next ctx
|> adminPage "Edit Your Information" next ctx
| None -> return! Error.notFound next ctx
}

View File

@ -9,6 +9,8 @@
<ItemGroup>
<Content Include="appsettings*.json" CopyToOutputDirectory="Always" />
<Compile Include="Caches.fs" />
<Compile Include="ViewContext.fs" />
<Compile Include="Template.fs" />
<Compile Include="Views\Helpers.fs" />
<Compile Include="Views\Admin.fs" />
<Compile Include="Views\Page.fs" />
@ -29,15 +31,16 @@
</ItemGroup>
<ItemGroup>
<PackageReference Include="BitBadger.AspNetCore.CanonicalDomains" Version="1.0.0" />
<PackageReference Include="BitBadger.AspNetCore.CanonicalDomains" Version="1.1.0" />
<PackageReference Include="DotLiquid" Version="2.2.692" />
<PackageReference Include="Giraffe" Version="6.4.0" />
<PackageReference Include="Giraffe.Htmx" Version="2.0.0" />
<PackageReference Include="Giraffe.ViewEngine.Htmx" Version="2.0.0" />
<PackageReference Include="NeoSmart.Caching.Sqlite.AspNetCore" Version="8.0.0" />
<PackageReference Include="Fluid.Core" Version="2.19.0" />
<PackageReference Include="Giraffe" Version="7.0.2" />
<PackageReference Include="Giraffe.Htmx" Version="2.0.4" />
<PackageReference Include="Giraffe.ViewEngine.Htmx" Version="2.0.4" />
<PackageReference Include="NeoSmart.Caching.Sqlite.AspNetCore" Version="9.0.0" />
<PackageReference Include="RethinkDB.DistributedCache" Version="1.0.0-rc1" />
<PackageReference Include="System.ServiceModel.Syndication" Version="8.0.0" />
<PackageReference Update="FSharp.Core" Version="8.0.300" />
<PackageReference Include="System.ServiceModel.Syndication" Version="9.0.1" />
<PackageReference Update="FSharp.Core" Version="9.0.101" />
</ItemGroup>
<ItemGroup>

View File

@ -6,10 +6,10 @@ open MyWebLog
/// Middleware to derive the current web log
type WebLogMiddleware(next: RequestDelegate, log: ILogger<WebLogMiddleware>) =
/// Is the debug level enabled on the logger?
let isDebug = log.IsEnabled LogLevel.Debug
member _.InvokeAsync(ctx: HttpContext) = task {
/// Create the full path of the request
let path = $"{ctx.Request.Scheme}://{ctx.Request.Host.Value}{ctx.Request.Path.Value}"
@ -27,12 +27,12 @@ type WebLogMiddleware(next: RequestDelegate, log: ILogger<WebLogMiddleware>) =
/// Middleware to check redirects for the current web log
type RedirectRuleMiddleware(next: RequestDelegate, log: ILogger<RedirectRuleMiddleware>) =
type RedirectRuleMiddleware(next: RequestDelegate, _log: ILogger<RedirectRuleMiddleware>) =
/// Shorthand for case-insensitive string equality
let ciEquals str1 str2 =
System.String.Equals(str1, str2, System.StringComparison.InvariantCultureIgnoreCase)
member _.InvokeAsync(ctx: HttpContext) = task {
let path = ctx.Request.Path.Value.ToLower()
let matched =
@ -59,11 +59,11 @@ open Npgsql
/// Logic to obtain a data connection and implementation based on configured values
module DataImplementation =
open MyWebLog.Converters
open RethinkDb.Driver.FSharp
open RethinkDb.Driver.Net
/// Create an NpgsqlDataSource from the connection string, configuring appropriately
let createNpgsqlDataSource (cfg: IConfiguration) =
let builder = NpgsqlDataSourceBuilder(cfg.GetConnectionString "PostgreSQL")
@ -83,12 +83,12 @@ module DataImplementation =
let conn = Sqlite.Configuration.dbConn ()
log.LogInformation $"Using SQLite database {conn.DataSource}"
SQLiteData(conn, log, Json.configure (JsonSerializer.CreateDefault()))
if hasConnStr "SQLite" then
createSQLite (connStr "SQLite")
elif hasConnStr "RethinkDB" then
let log = sp.GetRequiredService<ILogger<RethinkDbData>>()
let _ = Json.configure Converter.Serializer
let _ = Json.configure Converter.Serializer
let rethinkCfg = DataConfig.FromUri (connStr "RethinkDB")
let conn = await (rethinkCfg.CreateConnectionAsync log)
RethinkDbData(conn, rethinkCfg, log)
@ -131,7 +131,7 @@ open Microsoft.AspNetCore.Authentication.Cookies
open Microsoft.AspNetCore.Builder
open Microsoft.AspNetCore.HttpOverrides
open Microsoft.Extensions.Caching.Distributed
open NeoSmart.Caching.Sqlite.AspNetCore
open NeoSmart.Caching.Sqlite
open RethinkDB.DistributedCache
[<EntryPoint>]
@ -140,7 +140,7 @@ let main args =
let builder = WebApplication.CreateBuilder(args)
let _ = builder.Services.Configure<ForwardedHeadersOptions>(fun (opts : ForwardedHeadersOptions) ->
opts.ForwardedHeaders <- ForwardedHeaders.XForwardedFor ||| ForwardedHeaders.XForwardedProto)
let _ =
let _ =
builder.Services
.AddAuthentication(CookieAuthenticationDefaults.AuthenticationScheme)
.AddCookie(fun opts ->
@ -150,17 +150,17 @@ let main args =
let _ = builder.Services.AddLogging()
let _ = builder.Services.AddAuthorization()
let _ = builder.Services.AddAntiforgery()
let sp = builder.Services.BuildServiceProvider()
let data = DataImplementation.get sp
let _ = builder.Services.AddSingleton<JsonSerializer> data.Serializer
task {
do! data.StartUp()
do! WebLogCache.fill data
do! ThemeAssetCache.fill data
} |> Async.AwaitTask |> Async.RunSynchronously
// Define distributed cache implementation based on data implementation
match data with
| :? RethinkDbData as rethink ->
@ -189,18 +189,18 @@ let main args =
Postgres.DistributedCache() :> IDistributedCache)
()
| _ -> ()
let _ = builder.Services.AddSession(fun opts ->
opts.IdleTimeout <- TimeSpan.FromMinutes 60
opts.IdleTimeout <- TimeSpan.FromMinutes 60.
opts.Cookie.HttpOnly <- true
opts.Cookie.IsEssential <- true)
let _ = builder.Services.AddGiraffe()
// Set up DotLiquid
DotLiquidBespoke.register ()
let app = builder.Build()
match args |> Array.tryHead with
| Some it when it = "init" -> Maintenance.createWebLog args app.Services
| Some it when it = "import-links" -> Maintenance.importLinks args app.Services
@ -222,13 +222,13 @@ let main args =
if Directory.Exists themePath then
for themeFile in Directory.EnumerateFiles(themePath, "*-theme.zip") do
do! Maintenance.loadTheme [| ""; themeFile |] app.Services
let _ = app.UseForwardedHeaders()
(app.Services.GetRequiredService<IConfiguration>().GetSection "CanonicalDomains").Value
|> (isNull >> not)
|> function true -> app.UseCanonicalDomains() |> ignore | false -> ()
let _ = app.UseCookiePolicy(CookiePolicyOptions (MinimumSameSitePolicy = SameSiteMode.Strict))
let _ = app.UseMiddleware<WebLogMiddleware>()
let _ = app.UseMiddleware<RedirectRuleMiddleware>()
@ -241,5 +241,5 @@ let main args =
app.Run()
}
|> Async.AwaitTask |> Async.RunSynchronously
0 // Exit code

357
src/MyWebLog/Template.fs Normal file
View File

@ -0,0 +1,357 @@
/// <summary>Logic to work with Fluid templates</summary>
module MyWebLog.Template
open System
open System.Collections.Generic
open System.IO
open System.Text
open Fluid
open Fluid.Values
open Giraffe.ViewEngine
open Microsoft.AspNetCore.Antiforgery
open Microsoft.Extensions.FileProviders
open MyWebLog
open MyWebLog.ViewModels
/// Alias for ValueTask
type VTask<'T> = System.Threading.Tasks.ValueTask<'T>
/// <summary>Extensions on Fluid's TemplateContext object</summary>
type TemplateContext with
/// <summary>Get the model of the context as an <tt>AppViewContext</tt> instance</summary>
member this.App =
this.Model.ToObjectValue() :?> AppViewContext
/// <summary>Helper functions for filters and tags</summary>
[<AutoOpen>]
module private Helpers =
/// <summary>Does an asset exist for the current theme?</summary>
/// <param name="fileName">The name of the asset</param>
/// <param name="webLog">The current web log</param>
/// <returns>True if the theme has the requested asset name, false if not</returns>
let assetExists fileName (webLog: WebLog) =
ThemeAssetCache.get webLog.ThemeId |> List.exists (fun it -> it = fileName)
/// <summary>Obtain the link from known types</summary>
/// <param name="item">The <tt>FluidValue</tt> for the given parameter</param>
/// <param name="linkFunc">The function to extract the value of the link into a string</param>
/// <returns>The link as a string, or JavaScript to show an alert if a link cannot be determined</returns>
let permalink (item: FluidValue) (linkFunc: Permalink -> string) =
match item.Type with
| FluidValues.String -> Some (item.ToStringValue())
| FluidValues.Object ->
match item.ToObjectValue() with
| :? DisplayPage as page -> Some page.Permalink
| :? PostListItem as post -> Some post.Permalink
| :? Permalink as link -> Some (string link)
| _ -> None
| _ -> None
|> function
| Some link -> linkFunc (Permalink link)
| None -> $"alert('unknown item type {item.Type}')"
/// <summary>Generate a link for theme asset (image, stylesheet, script, etc.)</summary>
/// <param name="input">The name of the theme asset</param>
/// <param name="ctx">The template context for the current template rendering</param>
/// <returns>A relative URL for the given theme asset</returns>
let themeAsset (input: FluidValue) (ctx: TemplateContext) =
let app = ctx.App
app.WebLog.RelativeUrl(Permalink $"themes/{app.WebLog.ThemeId}/{input.ToStringValue()}")
/// <summary>Fluid template options customized with myWebLog filters</summary>
/// <returns>A <tt>TemplateOptions</tt> instance with all myWebLog filters and types registered</returns>
let options () =
let sValue = StringValue >> VTask<FluidValue>
let it = TemplateOptions.Default
it.MemberAccessStrategy.MemberNameStrategy <- MemberNameStrategies.SnakeCase
[ // Domain types
typeof<CustomFeed>; typeof<Episode>; typeof<Episode option>; typeof<MetaItem>; typeof<Page>; typeof<RssOptions>
typeof<TagMap>; typeof<WebLog>
// View models
typeof<AppViewContext>; typeof<DisplayCategory>; typeof<DisplayPage>; typeof<EditPageModel>; typeof<PostDisplay>
typeof<PostListItem>; typeof<UserMessage>
// Framework types
typeof<AntiforgeryTokenSet>; typeof<DateTime option>; typeof<int option>; typeof<KeyValuePair>
typeof<MetaItem list>; typeof<string list>; typeof<string option>; typeof<TagMap list> ]
|> List.iter it.MemberAccessStrategy.Register
// A filter to generate an absolute link
it.Filters.AddFilter("absolute_link", fun input _ ctx -> sValue (permalink input ctx.App.WebLog.AbsoluteUrl))
// A filter to generate a link with posts categorized under the given category
it.Filters.AddFilter("category_link",
fun input _ ctx ->
match input.ToObjectValue() with
| :? DisplayCategory as cat -> Some cat.Slug
| :? string as slug -> Some slug
| _ -> None
|> function
| Some slug -> ctx.App.WebLog.RelativeUrl(Permalink $"category/{slug}/")
| None -> $"alert('unknown category object type {input.Type}')"
|> sValue)
// A filter to generate a link that will edit a page
it.Filters.AddFilter("edit_page_link",
fun input _ ctx ->
match input.ToObjectValue() with
| :? DisplayPage as page -> Some page.Id
| :? string as theId -> Some theId
| _ -> None
|> function
| Some pageId -> ctx.App.WebLog.RelativeUrl(Permalink $"admin/page/{pageId}/edit")
| None -> $"alert('unknown page object type {input.Type}')"
|> sValue)
// A filter to generate a link that will edit a post
it.Filters.AddFilter("edit_post_link",
fun input _ ctx ->
match input.ToObjectValue() with
| :? PostListItem as post -> Some post.Id
| :? string as theId -> Some theId
| _ -> None
|> function
| Some postId -> ctx.App.WebLog.RelativeUrl(Permalink $"admin/post/{postId}/edit")
| None -> $"alert('unknown post object type {input.Type}')"
|> sValue)
// A filter to generate nav links, highlighting the active link (starts-with match)
it.Filters.AddFilter("nav_link",
fun input args ctx ->
let app = ctx.App
let extraPath = app.WebLog.ExtraPath
let path = if extraPath = "" then "" else $"{extraPath[1..]}/"
let url = input.ToStringValue()
seq {
"<li class=nav-item><a class=\"nav-link"
if app.CurrentPage.StartsWith $"{path}{url}" then " active"
"\" href=\""
app.WebLog.RelativeUrl(Permalink url)
"\">"
args.At(0).ToStringValue()
"</a>"
}
|> String.concat ""
|> sValue)
// A filter to generate a relative link
it.Filters.AddFilter("relative_link", fun input _ ctx -> sValue (permalink input ctx.App.WebLog.RelativeUrl))
// A filter to generate a link with posts tagged with the given tag
it.Filters.AddFilter("tag_link",
fun input _ ctx ->
let tag = input.ToStringValue()
ctx.App.TagMappings
|> Array.tryFind (fun it -> it.Tag = tag)
|> function
| Some tagMap -> tagMap.UrlValue
| None -> tag.Replace(" ", "+")
|> function tagUrl -> ctx.App.WebLog.RelativeUrl(Permalink $"tag/{tagUrl}/")
|> sValue)
// A filter to generate a link for theme asset (image, stylesheet, script, etc.)
it.Filters.AddFilter("theme_asset", fun input _ ctx -> sValue (themeAsset input ctx))
// A filter to retrieve the value of a meta item from a list
// (shorter than `{% assign item = list | where: "Name", [name] | first %}{{ item.value }}`)
it.Filters.AddFilter("value",
fun input args ctx ->
let name = args.At(0).ToStringValue()
let picker (value: FluidValue) =
let item = value.ToObjectValue() :?> MetaItem
if item.Name = name then Some item.Value else None
(input :?> ArrayValue).Values
|> Seq.tryPick picker
|> Option.defaultValue $"-- {name} not found --"
|> sValue)
it
/// <summary>Fluid parser customized with myWebLog filters and tags</summary>
let parser =
// spacer
let s = " "
// Required return for tag delegates
let ok () =
VTask<Fluid.Ast.Completion> Fluid.Ast.Completion.Normal
let it = FluidParser()
// Create various items in the page header based on the state of the page being generated
it.RegisterEmptyTag("page_head",
fun writer encoder context ->
let app = context.App
// let getBool name =
// defaultArg (context.Environments[0].[name] |> Option.ofObj |> Option.map Convert.ToBoolean) false
writer.WriteLine $"""{s}<meta name=generator content="{app.Generator}">"""
// Theme assets
if assetExists "style.css" app.WebLog then
themeAsset (StringValue "style.css") context
|> sprintf "%s<link rel=stylesheet href=\"%s\">" s
|> writer.WriteLine
if assetExists "favicon.ico" app.WebLog then
themeAsset (StringValue "favicon.ico") context
|> sprintf "%s<link rel=icon href=\"%s\">" s
|> writer.WriteLine
// RSS feeds and canonical URLs
let feedLink title url =
let escTitle = System.Web.HttpUtility.HtmlAttributeEncode title
let relUrl = app.WebLog.RelativeUrl(Permalink url)
$"""{s}<link rel=alternate type="application/rss+xml" title="{escTitle}" href="{relUrl}">"""
if app.WebLog.Rss.IsFeedEnabled && app.IsHome then
writer.WriteLine(feedLink app.WebLog.Name app.WebLog.Rss.FeedName)
writer.WriteLine $"""{s}<link rel=canonical href="{app.WebLog.AbsoluteUrl Permalink.Empty}">"""
if app.WebLog.Rss.IsCategoryEnabled && app.IsCategoryHome then
let slug = context.AmbientValues["slug"] :?> string
writer.WriteLine(feedLink app.WebLog.Name $"category/{slug}/{app.WebLog.Rss.FeedName}")
if app.WebLog.Rss.IsTagEnabled && app.IsTagHome then
let slug = context.AmbientValues["slug"] :?> string
writer.WriteLine(feedLink app.WebLog.Name $"tag/{slug}/{app.WebLog.Rss.FeedName}")
if app.IsPost then
let post = (* context.Environments[0].["model"] *) obj() :?> PostDisplay
let url = app.WebLog.AbsoluteUrl(Permalink post.Posts[0].Permalink)
writer.WriteLine $"""{s}<link rel=canonical href="{url}">"""
if app.IsPage then
let page = (* context.Environments[0].["page"] *) obj() :?> DisplayPage
let url = app.WebLog.AbsoluteUrl(Permalink page.Permalink)
writer.WriteLine $"""{s}<link rel=canonical href="{url}">"""
ok ())
// Create various items in the page footer based on the state of the page being generated
it.RegisterEmptyTag("page_foot",
fun writer encoder context ->
let webLog = context.App.WebLog
if webLog.AutoHtmx then
writer.WriteLine $"{s}{RenderView.AsString.htmlNode Htmx.Script.minified}"
if assetExists "script.js" webLog then
themeAsset (StringValue "script.js") context
|> sprintf "%s<script src=\"%s\"></script>" s
|> writer.WriteLine
ok ())
// Create links for a user to log on or off, and a dashboard link if they are logged off
it.RegisterEmptyTag("user_links",
fun writer encoder ctx ->
let app = ctx.App
let link it = app.WebLog.RelativeUrl(Permalink it)
seq {
"""<ul class="navbar-nav flex-grow-1 justify-content-end">"""
match app.IsLoggedOn with
| true ->
$"""<li class=nav-item><a class=nav-link href="{link "admin/dashboard"}">Dashboard</a>"""
$"""<li class=nav-item><a class=nav-link href="{link "user/log-off"}">Log Off</a>"""
| false ->
$"""<li class=nav-item><a class=nav-link href="{link "user/log-on"}">Log On</a>"""
"</ul>"
}
|> Seq.iter writer.WriteLine
ok())
it
open MyWebLog.Data
/// <summary>Cache for parsed templates</summary>
module Cache =
open System.Collections.Concurrent
/// Cache of parsed templates
let private _cache = ConcurrentDictionary<string, IFluidTemplate> ()
/// <summary>Get a template for the given theme and template name</summary>
/// <param name="themeId">The ID of the theme for which a template should be retrieved</param>
/// <param name="templateName">The name of the template to retrieve</param>
/// <param name="data">The data implementation from which the template should be retrieved (if not cached)</param>
/// <returns>
/// An <tt>Ok</tt> result with the template if it is found and valid, an <tt>Error</tt> result if not
/// </returns>
let get (themeId: ThemeId) (templateName: string) (data: IData) = backgroundTask {
let templatePath = $"{themeId}/{templateName}"
match _cache.ContainsKey templatePath with
| true -> return Ok _cache[templatePath]
| false ->
match! data.Theme.FindById themeId with
| Some theme ->
match theme.Templates |> List.tryFind (fun t -> t.Name = templateName) with
| Some template ->
_cache[templatePath] <- parser.Parse(template.Text)
return Ok _cache[templatePath]
| None ->
return Error $"Theme ID {themeId} does not have a template named {templateName}"
| None -> return Error $"Theme ID {themeId} does not exist"
}
/// <summary>Get all theme/template names currently cached</summary>
/// <returns>All theme/template names current cached</returns>
let allNames () =
_cache.Keys |> Seq.sort |> Seq.toList
/// <summary>Invalidate all template cache entries for the given theme ID</summary>
/// <param name="themeId">The ID of the theme whose cache should be invalidated</param>
let invalidateTheme (themeId: ThemeId) =
let keyPrefix = string themeId
_cache.Keys
|> Seq.filter _.StartsWith(keyPrefix)
|> List.ofSeq
|> List.iter (fun key -> match _cache.TryRemove key with _, _ -> ())
/// <summary>Remove all entries from the template cache</summary>
let empty () =
_cache.Clear()
/// <summary>A file provider to retrieve files by theme</summary>
type ThemeFileProvider(themeId: ThemeId, data: IData) =
interface IFileProvider with
member _.GetDirectoryContents _ =
raise <| NotImplementedException "The theme file provider does not support directory listings"
member _.GetFileInfo path =
match data.Theme.FindById themeId |> Async.AwaitTask |> Async.RunSynchronously with
| Some theme ->
match theme.Templates |> List.tryFind (fun t -> t.Name = path) with
| Some template ->
{ new IFileInfo with
member _.Exists = true
member _.IsDirectory = false
member _.LastModified = DateTimeOffset.Now
member _.Length = int64 template.Text.Length
member _.Name = template.Name.Split '/' |> Array.last
member _.PhysicalPath = null
member _.CreateReadStream() =
new MemoryStream(Encoding.UTF8.GetBytes template.Text) }
| None -> NotFoundFileInfo path
| None -> NotFoundFileInfo path
member _.Watch _ =
raise <| NotImplementedException "The theme file provider does not support watching for changes"
/// <summary>Render a template to a string</summary>
/// <param name="template">The template to be rendered</param>
/// <param name="viewCtx">The app context for rendering this template</param>
/// <param name="data">The data implementation to use if required</param>
/// <returns>The rendered template as a string</returns>
let render (template: IFluidTemplate) (viewCtx: AppViewContext) data =
let opts = options ()
opts.FileProvider <- ThemeFileProvider(viewCtx.WebLog.ThemeId, data)
template.Render(TemplateContext(viewCtx, opts, true))

128
src/MyWebLog/ViewContext.fs Normal file
View File

@ -0,0 +1,128 @@
/// <summary>View rendering context for myWebLog</summary>
[<AutoOpen>]
module MyWebLog.ViewContext
open Microsoft.AspNetCore.Antiforgery
open MyWebLog.ViewModels
/// <summary>The rendering context for this application</summary>
[<NoComparison; NoEquality>]
type AppViewContext = {
/// <summary>The web log for this request</summary>
WebLog: WebLog
/// <summary>The ID of the current user</summary>
UserId: WebLogUserId option
/// <summary>The title of the page being rendered</summary>
PageTitle: string
/// <summary>The subtitle for the page</summary>
Subtitle: string option
/// <summary>The anti-Cross Site Request Forgery (CSRF) token set to use when rendering a form</summary>
Csrf: AntiforgeryTokenSet option
/// <summary>The page list for the web log</summary>
PageList: DisplayPage array
/// <summary>Categories and post counts for the web log</summary>
Categories: DisplayCategory array
/// <summary>Tag mappings</summary>
TagMappings: TagMap array
/// <summary>The URL of the page being rendered</summary>
CurrentPage: string
/// <summary>User messages</summary>
Messages: UserMessage array
/// <summary>The generator string for the rendered page</summary>
Generator: string
/// <summary>The payload for this page (see other properties that wrap this one)</summary>
Payload: obj
/// <summary>The content of a page (wrapped when rendering the layout)</summary>
Content: string
/// <summary>A string to load the minified htmx script</summary>
HtmxScript: string
/// <summary>Whether the current user is an author</summary>
IsAuthor: bool
/// <summary>Whether the current user is an editor (implies author)</summary>
IsEditor: bool
/// <summary>Whether the current user is a web log administrator (implies author and editor)</summary>
IsWebLogAdmin: bool
/// <summary>Whether the current user is an installation administrator (implies all web log rights)</summary>
IsAdministrator: bool
/// <summary>Whether the current page is the home page of the web log</summary>
IsHome: bool
/// <summary>Whether the current page is a category archive page</summary>
IsCategory: bool
/// <summary>Whether the current page is a category archive home page</summary>
IsCategoryHome: bool
/// <summary>Whether the current page is a tag archive page</summary>
IsTag: bool
/// <summary>Whether the current page is a tag archive home page</summary>
IsTagHome: bool
/// <summary>Whether the current page is a single post</summary>
IsPost: bool
/// <summary>Whether the current page is a static page</summary>
IsPage: bool
/// <summary>The slug for a category or tag</summary>
Slug: string option
} with
/// <summary>Whether there is a user logged on</summary>
member this.IsLoggedOn = Option.isSome this.UserId
/// <summary>The payload for this page as a <c>DisplayPage</c></summary>
member this.Page =
this.Payload :?> DisplayPage
/// <summary>The payload for this page as a <c>PostDisplay</c></summary>
member this.Posts =
this.Payload :?> PostDisplay
/// <summary>An empty view context</summary>
static member Empty =
{ WebLog = WebLog.Empty
UserId = None
PageTitle = ""
Subtitle = None
Csrf = None
PageList = [||]
Categories = [||]
TagMappings = [||]
CurrentPage = ""
Messages = [||]
Generator = ""
Payload = obj ()
Content = ""
HtmxScript = ""
IsAuthor = false
IsEditor = false
IsWebLogAdmin = false
IsAdministrator = false
IsHome = false
IsCategory = false
IsCategoryHome = false
IsTag = false
IsTagHome = false
IsPost = false
IsPage = false
Slug = None }

View File

@ -6,9 +6,12 @@ open Giraffe.ViewEngine.Htmx
open MyWebLog
open MyWebLog.ViewModels
/// The administrator dashboard
/// <summary>The administrator dashboard</summary>
/// <param name="themes">The themes to display</param>
/// <param name="app">The view context</param>
/// <returns>The admin dashboard view</returns>
let dashboard (themes: Theme list) app = [
let templates = TemplateCache.allNames ()
let templates = Template.Cache.allNames ()
let cacheBaseUrl = relUrl app "admin/cache/"
let webLogCacheUrl = $"{cacheBaseUrl}web-log/"
let themeCacheUrl = $"{cacheBaseUrl}theme/"
@ -55,7 +58,7 @@ let dashboard (themes: Theme list) app = [
]
div [ _class "row" ] [
div [ _class "col-12 col-lg-6 pb-3" ] [
div [ _class "card" ] [
div [ _class "card" ] [
header [ _class "card-header text-white bg-secondary" ] [ raw "Web Logs" ]
div [ _class "card-body pb-0" ] [
h6 [ _class "card-subtitle text-muted pb-3" ] [

View File

@ -1,7 +1,7 @@
/// <summary>Helpers available for all myWebLog views</summary>
[<AutoOpen>]
module MyWebLog.Views.Helpers
open Microsoft.AspNetCore.Antiforgery
open Giraffe.ViewEngine
open Giraffe.ViewEngine.Accessibility
open Giraffe.ViewEngine.Htmx
@ -10,78 +10,35 @@ open MyWebLog.ViewModels
open NodaTime
open NodaTime.Text
/// The rendering context for this application
[<NoComparison; NoEquality>]
type AppViewContext = {
/// The web log for this request
WebLog: WebLog
/// The ID of the current user
UserId: WebLogUserId option
/// The title of the page being rendered
PageTitle: string
/// The anti-Cross Site Request Forgery (CSRF) token set to use when rendering a form
Csrf: AntiforgeryTokenSet option
/// The page list for the web log
PageList: DisplayPage array
/// Categories and post counts for the web log
Categories: DisplayCategory array
/// The URL of the page being rendered
CurrentPage: string
/// User messages
Messages: UserMessage array
/// The generator string for the rendered page
Generator: string
/// A string to load the minified htmx script
HtmxScript: string
/// Whether the current user is an author
IsAuthor: bool
/// Whether the current user is an editor (implies author)
IsEditor: bool
/// Whether the current user is a web log administrator (implies author and editor)
IsWebLogAdmin: bool
/// Whether the current user is an installation administrator (implies all web log rights)
IsAdministrator: bool
} with
/// Whether there is a user logged on
member this.IsLoggedOn = Option.isSome this.UserId
/// Create a relative URL for the current web log
/// <summary>Create a relative URL for the current web log</summary>
/// <param name="app">The app view context for the current view</param>
/// <returns>A function that, given a string, will construct a relative URL</returns>
let relUrl app =
Permalink >> app.WebLog.RelativeUrl
/// Add a hidden input with the anti-Cross Site Request Forgery (CSRF) token
/// <summary>Create a hidden input with the anti-Cross Site Request Forgery (CSRF) token</summary>
/// <param name="app">The app view context for the current view</param>
/// <returns>A hidden input with the CSRF token value</returns>
let antiCsrf app =
input [ _type "hidden"; _name app.Csrf.Value.FormFieldName; _value app.Csrf.Value.RequestToken ]
/// Shorthand for encoded text in a template
/// <summary>Shorthand for encoded text in a template</summary>
let txt = encodedText
/// Shorthand for raw text in a template
/// <summary>Shorthand for raw text in a template</summary>
let raw = rawText
/// Rel attribute to prevent opener information from being provided to the new window
/// <summary><c>rel</c> attribute to prevent opener information from being provided to the new window</summary>
let _relNoOpener = _rel "noopener"
/// The pattern for a long date
/// <summary>The pattern for a long date</summary>
let longDatePattern =
ZonedDateTimePattern.CreateWithInvariantCulture("MMMM d, yyyy", DateTimeZoneProviders.Tzdb)
/// Create a long date
/// <summary>Create a long date</summary>
/// <param name="app">The app view context for the current view</param>
/// <param name="instant">The instant from which a localized long date should be produced</param>
/// <returns>A text node with the long date</returns>
let longDate app (instant: Instant) =
DateTimeZoneProviders.Tzdb[app.WebLog.TimeZone]
|> Option.ofObj
@ -89,11 +46,14 @@ let longDate app (instant: Instant) =
|> Option.defaultValue "--"
|> txt
/// The pattern for a short time
/// <summary>The pattern for a short time</summary>
let shortTimePattern =
ZonedDateTimePattern.CreateWithInvariantCulture("h:mmtt", DateTimeZoneProviders.Tzdb)
/// Create a short time
/// <summary>Create a short time</summary>
/// <param name="app">The app view context for the current view</param>
/// <param name="instant">The instant from which a localized short date should be produced</param>
/// <returns>A text node with the short date</returns>
let shortTime app (instant: Instant) =
DateTimeZoneProviders.Tzdb[app.WebLog.TimeZone]
|> Option.ofObj
@ -101,11 +61,19 @@ let shortTime app (instant: Instant) =
|> Option.defaultValue "--"
|> txt
/// Display "Yes" or "No" based on the state of a boolean value
/// <summary>Display "Yes" or "No" based on the state of a boolean value</summary>
/// <param name="value">The true/false value</param>
/// <returns>A text node with <c>Yes</c> if true, <c>No</c> if false</returns>
let yesOrNo value =
raw (if value then "Yes" else "No")
/// Extract an attribute value from a list of attributes, remove that attribute if it is found
/// <summary>Extract an attribute value from a list of attributes, remove that attribute if it is found</summary>
/// <param name="name">The name of the attribute to be extracted and removed</param>
/// <param name="attrs">The list of attributes to be searched</param>
/// <returns>
/// A tuple with <c>fst</c> being <c>Some</c> with the attribute if found, <c>None</c> if not; and <c>snd</c>
/// being the list of attributes with the extracted one removed
/// </returns>
let extractAttrValue name attrs =
let valueAttr = attrs |> List.tryFind (fun x -> match x with KeyValue (key, _) when key = name -> true | _ -> false)
match valueAttr with
@ -113,8 +81,15 @@ let extractAttrValue name attrs =
Some value,
attrs |> List.filter (fun x -> match x with KeyValue (key, _) when key = name -> false | _ -> true)
| Some _ | None -> None, attrs
/// Create a text input field
/// <summary>Create a text input field</summary>
/// <param name="fieldType">The <c>input</c> field type</param>
/// <param name="attrs">Attributes for the field</param>
/// <param name="name">The name of the input field</param>
/// <param name="labelText">The text of the <c>label</c> element associated with this <c>input</c></param>
/// <param name="value">The value of the <c>input</c> field</param>
/// <param name="extra">Any extra elements to include after the <c>input</c> and <c>label</c></param>
/// <returns>A <c>div</c> element with the <c>input</c> field constructed</returns>
let inputField fieldType attrs name labelText value extra =
let fieldId, attrs = extractAttrValue "id" attrs
let cssClass, attrs = extractAttrValue "class" attrs
@ -127,23 +102,58 @@ let inputField fieldType attrs name labelText value extra =
yield! extra
]
/// Create a text input field
/// <summary>Create a text input field</summary>
/// <param name="attrs">Attributes for the field</param>
/// <param name="name">The name of the input field</param>
/// <param name="labelText">The text of the <c>label</c> element associated with this <c>input</c></param>
/// <param name="value">The value of the <c>input</c> field</param>
/// <param name="extra">Any extra elements to include after the <c>input</c> and <c>label</c></param>
/// <returns>A <c>div</c> element with the &lt;input type=text&gt; field constructed</returns>
let textField attrs name labelText value extra =
inputField "text" attrs name labelText value extra
/// Create a number input field
/// <summary>Create a number input field</summary>
/// <param name="attrs">Attributes for the field</param>
/// <param name="name">The name of the input field</param>
/// <param name="labelText">The text of the <c>label</c> element associated with this <c>input</c></param>
/// <param name="value">The value of the <c>input</c> field</param>
/// <param name="extra">Any extra elements to include after the <c>input</c> and <c>label</c></param>
/// <returns>A <c>div</c> element with the &lt;input type=number&gt; field constructed</returns>
let numberField attrs name labelText value extra =
inputField "number" attrs name labelText value extra
/// Create an e-mail input field
/// <summary>Create an e-mail input field</summary>
/// <param name="attrs">Attributes for the field</param>
/// <param name="name">The name of the input field</param>
/// <param name="labelText">The text of the <c>label</c> element associated with this <c>input</c></param>
/// <param name="value">The value of the <c>input</c> field</param>
/// <param name="extra">Any extra elements to include after the <c>input</c> and <c>label</c></param>
/// <returns>A <c>div</c> element with the &lt;input type=email&gt; field constructed</returns>
let emailField attrs name labelText value extra =
inputField "email" attrs name labelText value extra
/// Create a password input field
/// <summary>Create a password input field</summary>
/// <param name="attrs">Attributes for the field</param>
/// <param name="name">The name of the input field</param>
/// <param name="labelText">The text of the <c>label</c> element associated with this <c>input</c></param>
/// <param name="value">The value of the <c>input</c> field</param>
/// <param name="extra">Any extra elements to include after the <c>input</c> and <c>label</c></param>
/// <returns>A <c>div</c> element with the &lt;input type=password&gt; field constructed</returns>
let passwordField attrs name labelText value extra =
inputField "password" attrs name labelText value extra
/// Create a select (dropdown) field
/// <summary>Create a select (dropdown) field</summary>
/// <typeparam name="T">The type of value in the backing list</typeparam>
/// <typeparam name="a">The type of the <c>value</c> attribute</typeparam>
/// <param name="attrs">Attributes for the field</param>
/// <param name="name">The name of the input field</param>
/// <param name="labelText">The text of the <c>label</c> element associated with this <c>input</c></param>
/// <param name="value">The value of the <c>input</c> field</param>
/// <param name="values">The backing list for this dropdown</param>
/// <param name="idFunc">The function to extract the ID (<c>value</c> attribute)</param>
/// <param name="displayFunc">The function to extract the displayed version of the item</param>
/// <param name="extra">Any extra elements to include after the <c>input</c> and <c>label</c></param>
/// <returns>A <c>div</c> element with the &lt;select&gt; field constructed</returns>
let selectField<'T, 'a>
attrs name labelText value (values: 'T seq) (idFunc: 'T -> 'a) (displayFunc: 'T -> string) extra =
let cssClass, attrs = extractAttrValue "class" attrs
@ -157,7 +167,13 @@ let selectField<'T, 'a>
yield! extra
]
/// Create a checkbox input styled as a switch
/// <summary>Create a checkbox input styled as a switch</summary>
/// <param name="attrs">Attributes for the field</param>
/// <param name="name">The name of the input field</param>
/// <param name="labelText">The text of the <c>label</c> element associated with this <c>input</c></param>
/// <param name="value">Whether the checkbox should be checked or not</param>
/// <param name="extra">Any extra elements to include after the <c>input</c> and <c>label</c></param>
/// <returns>A <c>div</c> element with the switch-style &lt;input type=checkbox&gt; field constructed</returns>
let checkboxSwitch attrs name labelText (value: bool) extra =
let cssClass, attrs = extractAttrValue "class" attrs
div [ _class $"""form-check form-switch {defaultArg cssClass ""}""" ] [
@ -168,17 +184,17 @@ let checkboxSwitch attrs name labelText (value: bool) extra =
yield! extra
]
/// A standard save button
/// <summary>A standard save button</summary>
let saveButton =
button [ _type "submit"; _class "btn btn-sm btn-primary" ] [ raw "Save Changes" ]
/// A spacer bullet to use between action links
/// <summary>A spacer bullet to use between action links</summary>
let actionSpacer =
span [ _class "text-muted" ] [ raw " &bull; " ]
/// Functions for generating content in varying layouts
/// <summary>Functions for generating content in varying layouts</summary>
module Layout =
/// Generate the title tag for a page
let private titleTag (app: AppViewContext) =
title [] [ txt app.PageTitle; raw " &laquo; Admin &laquo; "; txt app.WebLog.Name ]
@ -272,15 +288,21 @@ module Layout =
]
]
]
/// Render a page with a partial layout (htmx request)
/// <summary>Render a page with a partial layout (htmx request)</summary>
/// <param name="content">A function that, when given a view context, will return a view</param>
/// <param name="app">The app view context to use when rendering the view</param>
/// <returns>A constructed Giraffe View Engine view</returns>
let partial content app =
html [ _lang "en" ] [
titleTag app
yield! pageView content app
]
/// Render a page with a full layout
/// <summary>Render a page with a full layout</summary>
/// <param name="content">A function that, when given a view context, will return a view</param>
/// <param name="app">The app view context to use when rendering the view</param>
/// <returns>A constructed Giraffe View Engine view</returns>
let full content app =
html [ _lang "en" ] [
meta [ _name "viewport"; _content "width=device-width, initial-scale=1" ]
@ -299,8 +321,11 @@ module Layout =
script [ _src (relUrl app "themes/admin/admin.js") ] []
]
]
/// Render a bare layout
/// <summary>Render a bare layout</summary>
/// <param name="content">A function that, when given a view context, will return a view</param>
/// <param name="app">The app view context to use when rendering the view</param>
/// <returns>A constructed Giraffe View Engine view</returns>
let bare (content: AppViewContext -> XmlNode list) app =
html [ _lang "en" ] [
title [] []
@ -311,14 +336,17 @@ module Layout =
// ~~ SHARED TEMPLATES BETWEEN POSTS AND PAGES
open Giraffe.Htmx.Common
/// The round-trip instant pattern
/// <summary>The round-trip instant pattern</summary>
let roundTrip = InstantPattern.CreateWithInvariantCulture "uuuu'-'MM'-'dd'T'HH':'mm':'ss'.'fffffff"
/// Capitalize the first letter in the given string
let private capitalize (it: string) =
$"{(string it[0]).ToUpper()}{it[1..]}"
/// The common edit form shared by pages and posts
/// <summary>The common edit form shared by pages and posts</summary>
/// <param name="model">The model to use to render this view</param>
/// <param name="app">The app view context to use to render this view</param>
/// <returns>A common edit view</returns>
let commonEdit (model: EditCommonModel) app = [
textField [ _class "mb-3"; _required; _autofocus ] (nameof model.Title) "Title" model.Title []
textField [ _class "mb-3"; _required ] (nameof model.Permalink) "Permalink" model.Permalink [
@ -352,13 +380,18 @@ let commonEdit (model: EditCommonModel) app = [
]
/// Display a common template list
/// <summary>Display a common template list</summary>
/// <param name="model">The edit model</param>
/// <param name="templates">A list of available templates for this page or post</param>
/// <returns>A &lt;select&gt; element to allow a template to be selected</returns>
let commonTemplates (model: EditCommonModel) (templates: MetaItem seq) =
selectField [ _class "mb-3" ] (nameof model.Template) $"{capitalize model.Entity} Template" model.Template templates
(_.Name) (_.Value) []
_.Name _.Value []
/// Display the metadata item edit form
/// <summary>Display the metadata item edit form</summary>
/// <param name="model">The edit model</param>
/// <returns>A form for editing metadata</returns>
let commonMetaItems (model: EditCommonModel) =
let items = Array.zip model.MetaNames model.MetaValues
let metaDetail idx (name, value) =
@ -371,7 +404,7 @@ let commonMetaItems (model: EditCommonModel) =
div [ _class "col-3" ] [ textField [ _id $"MetaNames_{idx}" ] (nameof model.MetaNames) "Name" name [] ]
div [ _class "col-8" ] [ textField [ _id $"MetaValues_{idx}" ] (nameof model.MetaValues) "Value" value [] ]
]
fieldset [] [
legend [] [
raw "Metadata "
@ -393,7 +426,10 @@ let commonMetaItems (model: EditCommonModel) =
]
/// Revision preview template
/// <summary>Revision preview template</summary>
/// <param name="rev">The revision to preview</param>
/// <param name="app">The app view context to use when rendering the preview</param>
/// <returns>A view with a revision preview</returns>
let commonPreview (rev: Revision) app =
div [ _class "mwl-revision-preview mb-3" ] [
rev.Text.AsHtml() |> addBaseToRelativeUrls app.WebLog.ExtraPath |> raw
@ -401,7 +437,10 @@ let commonPreview (rev: Revision) app =
|> List.singleton
/// Form to manage permalinks for pages or posts
/// <summary>Form to manage permalinks for pages or posts</summary>
/// <param name="model">The manage permalinks model to be rendered</param>
/// <param name="app">The app view context to use when rendering this view</param>
/// <returns>A view for managing permalinks for a page or post</returns>
let managePermalinks (model: ManagePermalinksModel) app = [
let baseUrl = relUrl app $"admin/{model.Entity}/"
let linkDetail idx link =
@ -465,7 +504,10 @@ let managePermalinks (model: ManagePermalinksModel) app = [
]
]
/// Form to manage revisions for pages or posts
/// <summary>Form to manage revisions for pages or posts</summary>
/// <param name="model">The manage revisions model to be rendered</param>
/// <param name="app">The app view context to use when rendering this view</param>
/// <returns>A view for managing revisions for a page or post</returns>
let manageRevisions (model: ManageRevisionsModel) app = [
let revUrlBase = relUrl app $"admin/{model.Entity}/{model.Id}/revision"
let revDetail idx (rev: Revision) =

View File

@ -1,5 +1,5 @@
{
"Generator": "myWebLog 2.2",
{
"Generator": "myWebLog 3",
"Logging": {
"LogLevel": {
"MyWebLog.Handlers": "Information"
@ -8,7 +8,7 @@
"Kestrel": {
"Endpoints": {
"Http": {
"Url": "http://0.0.0.0:80"
"Url": "http://0.0.0.0:5000"
}
}
}